File Coverage

blib/lib/Object/Pluggable.pm

Criterion	Covered	Total	%
statement	102	164	62.2
branch	39	82	47.5
condition	9	30	30.0
subroutine	16	20	80.0
pod	8	8	100.0
total	174	304	57.2

package Object::Pluggable;
BEGIN {
  $Object::Pluggable::AUTHORITY = 'cpan:HINRIK';
}
BEGIN {
  $Object::Pluggable::VERSION = '1.29';
}

use strict;
use warnings;
use Carp;
use Object::Pluggable::Pipeline;
use Object::Pluggable::Constants qw(:ALL);

sub _pluggable_init {
    my ($self, %opts) = @_;

    $self->{'_pluggable_' . lc $_} = delete $opts{$_} for keys %opts;
    $self->{_pluggable_reg_prefix} = 'plugin_' if !$self->{_pluggable_reg_prefix};
    $self->{_pluggable_prefix} = 'pluggable_' if !$self->{_pluggable_prefix};

    if (ref $self->{_pluggable_types} eq 'ARRAY') {
        $self->{_pluggable_types} = { map { $_ => $_ } @{ $self->{_pluggable_types} } };
    }
    elsif (ref $self->{_pluggable_types} ne 'HASH') {
        croak "Argument 'types' must be supplied";
    }

    return 1;
}

sub _pluggable_destroy {
    my ($self) = @_;
    $self->plugin_del( $_ ) for keys %{ $self->plugin_list() };
    return;
}

sub _pluggable_event {
    return;
}

sub _pluggable_process {
    my ($self, $type, $event, $args) = @_;

    if (!defined $type || !defined $event) {
        carp 'Please supply an event type and name!';
        return;
    }

    $event = lc $event;
    my $pipeline = $self->pipeline;
    my $prefix = $self->{_pluggable_prefix};
    $event =~ s/^\Q$prefix\E//;
    my $sub = join '_', $self->{_pluggable_types}{$type}, $event;
    my $return = PLUGIN_EAT_NONE;
    my $self_ret = $return;
    my @extra_args;

    local $@;
    if ($self->can($sub)) {
        eval { $self_ret = $self->$sub($self, \(@$args), \@extra_args ) };
        $self->_handle_error($self, $sub, $self_ret);
    }
    elsif ( $self->can('_default') ) {
        eval { $self_ret = $self->_default($self, $sub, \(@$args), \@extra_args) };
        $self->_handle_error($self, '_default', $self_ret);
    }

    $self_ret = PLUGIN_EAT_NONE unless defined $self_ret;
    return $return if $self_ret == PLUGIN_EAT_PLUGIN;
    $return = PLUGIN_EAT_ALL if $self_ret == PLUGIN_EAT_CLIENT;
    return PLUGIN_EAT_ALL if $self_ret == PLUGIN_EAT_ALL;

    if (@extra_args) {
        push @$args, @extra_args;
        @extra_args = ();
    }

    for my $plugin (@{ $pipeline->{PIPELINE} }) {
        if ($self eq $plugin
          || !$pipeline->{HANDLES}{$plugin}{$type}{$event}
          && !$pipeline->{HANDLES}{$plugin}{$type}{all}) {
            next;
        }

        my $ret = PLUGIN_EAT_NONE;

        my $alias = ($pipeline->get($plugin))[1];
        if ($plugin->can($sub)) {
            eval { $ret = $plugin->$sub($self, \(@$args), \@extra_args) };
            $self->_handle_error($plugin, $sub, $ret, $alias);
        }
        elsif ( $plugin->can('_default') ) {
            eval { $ret = $plugin->_default($self, $sub, \(@$args), \@extra_args) };
            $self->_handle_error($plugin, '_default', $ret, $alias);
        }

	$ret = PLUGIN_EAT_NONE unless defined $ret;
        return $return if $ret == PLUGIN_EAT_PLUGIN;
        $return = PLUGIN_EAT_ALL if $ret == PLUGIN_EAT_CLIENT;
        return PLUGIN_EAT_ALL if $ret == PLUGIN_EAT_ALL;

        if (@extra_args) {
            push @$args, @extra_args;
            @extra_args = ();
        }
    }

    return $return;
}

sub _handle_error {
    my ($self, $object, $sub, $return, $source) = @_;
    $source = defined $source ? "plugin '$source'" : 'self';

    if ($@) {
        chomp $@;
        my $error = "$sub call on $source failed: $@";
        warn "$error\n" if $self->{_pluggable_debug};

        $self->_pluggable_event(
            "$self->{_pluggable_prefix}plugin_error",
            $error, ($object == $self ? ($object, $source) : ()),
        );
    }
    elsif ( !defined $return ||
      ($return != PLUGIN_EAT_NONE
      && $return != PLUGIN_EAT_PLUGIN
      && $return != PLUGIN_EAT_CLIENT
      && $return != PLUGIN_EAT_ALL) ) {
        my $error = "$sub call on $source did not return a valid EAT constant";
        warn "$error\n" if $self->{_pluggable_debug};

        $self->_pluggable_event(
            "$self->{_pluggable_prefix}plugin_error",
            $error, ($object == $self ? ($object, $source) : ()),
        );
    }

    return;
}

# accesses the plugin pipeline
sub pipeline {
    my ($self) = @_;
    local $@;
    eval { $self->{_PLUGINS}->isa('Object::Pluggble::Pipeline') };
    $self->{_PLUGINS} = Object::Pluggable::Pipeline->new($self) if $@;
    return $self->{_PLUGINS};
}

# Adds a new plugin object
sub plugin_add {
    my ($self, $name, $plugin, @args) = @_;

    if (!defined $name || !defined $plugin) {
        carp 'Please supply a name and the plugin object to be added!';
        return;
    }

    return $self->pipeline->push($name, $plugin, @args);
}

# Removes a plugin object
sub plugin_del {
    my ($self, $name, @args) = @_;

    if (!defined $name) {
        carp 'Please supply a name/object for the plugin to be removed!';
        return;
    }

    my $return = scalar $self->pipeline->remove($name, @args);
    return $return;
}

# Gets the plugin object
sub plugin_get {
    my ($self, $name) = @_;

    if (!defined $name) {
        carp 'Please supply a name/object for the plugin to be removed!';
        return;
    }

    return scalar $self->pipeline->get($name);
}

# Lists loaded plugins
sub plugin_list {
    my ($self) = @_;
    my $pipeline = $self->pipeline;

    my %return = map {$pipeline->{PLUGS}{$_} => $_} @{ $pipeline->{PIPELINE} };
    return \%return;
}

# Lists loaded plugins in order!
sub plugin_order {
    my ($self) = @_;
    return $self->pipeline->{PIPELINE};
}

sub plugin_register {
    my ($self, $plugin, $type, @events) = @_;
    my $pipeline = $self->pipeline;

    if (!grep { $_ eq $type } keys %{ $self->{_pluggable_types} }) {
        carp "The event type '$type' is not supported!";
        return;
    }

    if (!defined $plugin) {
        carp 'Please supply the plugin object to register events for!';
        return;
    }

    if (!@events) {
        carp 'Please supply at least one event to register!';
        return;
    }

    for my $ev (@events) {
        if (ref $ev and ref $ev eq 'ARRAY') {
            $pipeline->{HANDLES}{$plugin}{$type}{lc $_} = 1 for @$ev;
        }
        else {
            $pipeline->{HANDLES}{$plugin}{$type}{lc $ev} = 1;
        }
    }

    return 1;
}

sub plugin_unregister {
    my ($self, $plugin, $type, @events) = @_;
    my $pipeline = $self->pipeline;

    if (!grep { $_ eq $type } keys %{ $self->{_pluggable_types} }) {
        carp "The event type '$type' is not supported!";
        return;
    }

    if (!defined $plugin) {
        carp 'Please supply the plugin object to register!';
        return;
    }

    if (!@events) {
        carp 'Please supply at least one event to unregister!';
        return;
    }

    for my $ev (@events) {
        if (ref $ev and ref $ev eq "ARRAY") {
            for my $e (map { lc } @$ev) {
                if (!delete $pipeline->{HANDLES}{$plugin}{$type}{$e}) {
                    carp "The event '$e' does not exist!";
                    next;
                }
            }
        }
        else {
            $ev = lc $ev;
            if (!delete $pipeline->{HANDLES}{$plugin}{$type}{$ev}) {
                carp "The event '$ev' does not exist!";
                next;
            }
        }
    }

    return 1;
}

1;
__END__