File Coverage

blib/lib/Module/Pluggable/Ordered.pm

Criterion	Covered	Total	%
statement	48	49	97.9
branch	9	12	75.0
condition	5	11	45.4
subroutine	8	8	100.0
pod			n/a
total	70	80	87.5

package Module::Pluggable::Ordered;
# I really regret this ugliness, but it's needed in the face of backwards
# compatibility, and I don't want "code this funky" wandering around CPAN
# without warnings if I can help it. :) Those using ancient versions of Perl can
# use -w for global warnings. Unfortunately, there's not much else I can do. If
# anyone has any suggestions, please do file a bug report. Thanks.

BEGIN
{
	if($] >= 5.00600)
	{
		require warnings;
		import warnings;
	}
}
use strict;
require Module::Pluggable;
use UNIVERSAL::require;
use vars qw($VERSION);
$VERSION = '1.5';

sub import {
    my ($self, %args) = @_;
    my $subname = $args{sub_name} || "plugins";

	my %only;
	my %except;

    %only   = map { $_ => 1 } @{$args{'only'}}    if defined $args{'only'};
    %except = map { $_ => 1 } @{$args{'$except'}} if defined $args{'except'};

    my $caller = $args{package} || caller;

    no strict;

    *{"${caller}::call_plugins"} = sub {
        my ($thing, $name, @args)  = @_;
        my @plugins = ();
        for ($thing->$subname()) {
            next if (keys %only   && !$only{$_}   );
            next if (keys %except &&  $except{$_} );
            push @plugins, $_;
        }

        $_->require for @plugins;

        my $order_name = "${name}_order";
        for my $class (sort { $a->$order_name() <=> $b->$order_name() }
                       grep { $_->can($order_name) }
                       @plugins) {
            $class->$name(@args);
        }
    };

    *{"${caller}::${subname}_ordered"} = sub {
        my $thing  = shift;

		my @plugins = $thing->$subname();
		$_->require for @plugins;

		return	map  { $_->[0] }
				sort { $a->[1] <=> $b->[1] }
				map  { [ $_, ( $_->can('_order') ? $_->_order : 50 ) ] }
				@plugins;
	};

    goto &Module::Pluggable::import;
}

1;
__END__