File Coverage

blib/lib/POE/Component/Pluggable/Pipeline.pm

Criterion	Covered	Total	%
statement	12	196	6.1
branch	0	88	0.0
condition	0	4	0.0
subroutine	4	20	20.0
pod	13	13	100.0
total	29	321	9.0

package POE::Component::Pluggable::Pipeline;

use strict;
use warnings;
use Carp;
use Scalar::Util qw(weaken);

our $VERSION = '1.26';

sub new {
    my ($package, $pluggable) = @_;

    my $self = bless {
        PLUGS    => {},
        PIPELINE => [],
        HANDLES  => {},
        OBJECT   => $pluggable,
    }, $package;

    weaken($self->{OBJECT});

    return $self;
}

sub push {
    my ($self, $alias, $plug) = @_;

    if ($self->{PLUGS}{$alias}) {
        $@ = "Plugin named '$alias' already exists ($self->{PLUGS}{$alias})";
        return;
    }

    my $return = $self->_register($alias, $plug);
    return if !$return;

    push @{ $self->{PIPELINE} }, $plug;
    return scalar @{ $self->{PIPELINE} };
}

sub pop {
    my ($self) = @_;

    return if !@{ $self->{PIPELINE} };

    my $plug = pop @{ $self->{PIPELINE} };
    my $alias = $self->{PLUGS}{$plug};
    $self->_unregister($alias, $plug);

    return wantarray ? ($plug, $alias) : $plug;
}

sub unshift {
    my ($self, $alias, $plug) = @_;

    if ($self->{PLUGS}{$alias}) {
        $@ = "Plugin named '$alias' already exists ($self->{PLUGS}{$alias}";
        return;
    }

    my $return = $self->_register($alias, $plug);
    return if !$return;

    unshift @{ $self->{PIPELINE} }, $plug;
    return scalar @{ $self->{PIPELINE} };
}

sub shift {
    my ($self) = @_;

    return if !@{ $self->{PIPELINE} };

    my $plug = shift @{ $self->{PIPELINE} };
    my $alias = $self->{PLUGS}{$plug};
    $self->_unregister($alias, $plug);

    return wantarray ? ($plug, $alias) : $plug;
}

sub replace {
    my ($self, $old, $new_a, $new_p) = @_;

    my ($old_a, $old_p) = ref $old
        ? ($self->{PLUGS}{$old}, $old)
        : ($old, $self->{PLUGS}{$old})
    ;

    if (!$old_p) {
        $@ = "Plugin '$old_a' does not exist";
        return;
    }

    $self->_unregister($old_a, $old_p);

    if ($self->{PLUGS}{$new_a}) {
        $@ = "Plugin named '$new_a' already exists ($self->{PLUGS}{$new_a}";
        return;
    }

    my $return = $self->_register($new_a, $new_p);
    return if !$return;

    for my $plugin (@{ $self->{PIPELINE} }) {
        if ($plugin == $old_p) {
            $plugin = $new_p;
            last;
        }
    }

    return 1;
}

sub remove {
    my ($self, $old) = @_;
    my ($old_a, $old_p) = ref $old
        ? ($self->{PLUGS}{$old}, $old)
        : ($old, $self->{PLUGS}{$old})
    ;

    if (!$old_p) {
        $@ = "Plugin '$old_a' does not exist";
        return;
    }

    my $i = 0;
    for my $plugin (@{ $self->{PIPELINE} }) {
        if ($plugin == $old_p) {
            splice(@{ $self->{PIPELINE} }, $i, 1);
            last;
        }
        $i++;
    }

    $self->_unregister($old_a, $old_p);

    return wantarray ? ($old_p, $old_a) : $old_p;
}

sub get {
    my ($self, $old) = @_;

    my ($old_a, $old_p) = ref $old
        ? ($self->{PLUGS}{$old}, $old)
        : ($old, $self->{PLUGS}{$old})
    ;


    if (!$old_p) {
        $@ = "Plugin '$old_a' does not exist";
        return;
    }

    return wantarray ? ($old_p, $old_a) : $old_p;
}

sub get_index {
    my ($self, $old) = @_;

    my ($old_a, $old_p) = ref $old
        ? ($self->{PLUGS}{$old}, $old)
        : ($old, $self->{PLUGS}{$old})
    ;

    if (!$old_p) {
        $@ = "Plugin '$old_a' does not exist";
        return -1;
    }

    my $i = 0;
    for my $plugin (@{ $self->{PIPELINE} }) {
        return $i if $plugin == $old_p;
        $i++;
    }

    return -1;
}

sub insert_before {
    my ($self, $old, $new_a, $new_p) = @_;

    my ($old_a, $old_p) = ref $old
        ? ($self->{PLUGS}{$old}, $old)
        : ($old, $self->{PLUGS}{$old})
    ;

    if (!$old_p) {
        $@ = "Plugin '$old_a' does not exist";
        return;
    }

    if ($self->{PLUGS}{$new_a}) {
        $@ = "Plugin named '$new_a' already exists ($self->{PLUGS}{$new_a}";
        return;
    }

    my $return = $self->_register($new_a, $new_p);
    return if !$return;

    my $i = 0;
    for my $plugin (@{ $self->{PIPELINE} }) {
        if ($plugin == $old_p) {
            splice(@{ $self->{PIPELINE} }, $i, 0, $new_p);
            last;
        }
        $i++;
    }

    return 1;
}

sub insert_after {
    my ($self, $old, $new_a, $new_p) = @_;
    my ($old_a, $old_p) = ref $old
        ? ($self->{PLUGS}{$old}, $old)
        : ($old, $self->{PLUGS}{$old})
    ;

    if (!$old_p) {
        $@ = "Plugin '$old_a' does not exist";
        return;
    }

    if ($self->{PLUGS}{$new_a}) {
        $@ = "Plugin named '$new_a' already exists ($self->{PLUGS}{$new_a}";
        return;
    }

    my $return = $self->_register($new_a, $new_p);
    return if !$return;

    my $i = 0;
    for my $plugin (@{ $self->{PIPELINE} }) {
        if ($plugin == $old_p) {
            splice(@{ $self->{PIPELINE} }, $i+1, 0, $new_p);
            last;
        }
        $i++;
    }

    return 1;
}

sub bump_up {
    my ($self, $old, $diff) = @_;
    my $idx = $self->get_index($old);

    return -1 if $idx < 0;

    my $pipeline = $self->{PIPELINE};
    $diff ||= 1;

    my $pos = $idx - $diff;

    if ($pos < 0) {
        carp "$idx - $diff is negative, moving to head of the pipeline";
    }

    splice(@$pipeline, $pos, 0, splice(@$pipeline, $idx, 1));
    return $pos;
}

sub bump_down {
    my ($self, $old, $diff) = @_;
    my $idx = $self->get_index($old);

    return -1 if $idx < 0;

    my $pipeline = $self->{PIPELINE};
    $diff ||= 1;

    my $pos = $idx + $diff;

    if ($pos >= @$pipeline) {
        carp "$idx + $diff is too high, moving to back of the pipeline";
    }

    splice(@$pipeline, $pos, 0, splice(@$pipeline, $idx, 1));
    return $pos;
}

sub _register {
    my ($self, $alias, $plug) = @_;
    return if !defined $self->{OBJECT};

    my $return;
    my $sub = "$self->{OBJECT}{_pluggable_reg_prefix}register";
    eval { $return = $plug->$sub($self->{OBJECT}) };

    if ($@) {
        chomp $@;
        my $error = "$sub call on plugin '$alias' failed: $@";
        $self->_handle_error($error, $plug, $alias);
    }
    elsif (!$return) {
        my $error = "$sub call on plugin '$alias' did not return a true value";
        $self->_handle_error($error, $plug, $alias);
    }

    $self->{PLUGS}{$plug} = $alias;
    $self->{PLUGS}{$alias} = $plug;

    $self->{OBJECT}->_pluggable_event(
        "$self->{OBJECT}{_pluggable_prefix}plugin_add",
        $alias, $plug,
    );

    return $return;
}

sub _unregister {
    my ($self, $alias, $plug) = @_;
    return if !defined $self->{OBJECT};

    my $return;
    my $sub = "$self->{OBJECT}{_pluggable_reg_prefix}unregister";
    eval { $return = $plug->$sub($self->{OBJECT}) };

    if ($@) {
        chomp $@;
        my $error = "$sub call on plugin '$alias' failed: $@";
        $self->_handle_error($error, $plug, $alias);
    }
    elsif (!$return) {
        my $error = "$sub call on plugin '$alias' did not return a true value";
        $self->_handle_error($error, $plug, $alias);
    }

    delete $self->{PLUGS}{$plug};
    delete $self->{PLUGS}{$alias};
    delete $self->{HANDLES}{$plug};

    $self->{OBJECT}->_pluggable_event(
        "$self->{OBJECT}{_pluggable_prefix}plugin_del",
        $alias, $plug,
    );

    return $return;
}

sub _handle_error {
    my ($self, $error, $plugin, $alias) = @_;

    warn "$error\n" if $self->{OBJECT}{_pluggable_debug};
    $self->{OBJECT}->_pluggable_event(
        "$self->{OBJECT}{_pluggable_prefix}plugin_error",
        $error, $plugin, $alias,
    );

    return;
}

1;
__END__