File Coverage

blib/lib/Plugin/Tiny.pm

Criterion	Covered	Total	%
statement	70	81	86.4
branch	26	40	65.0
condition	9	12	75.0
subroutine	14	15	93.3
pod	6	6	100.0
total	125	154	81.1

#ABSTRACT: A tiny plugin system for perl
package Plugin::Tiny;
$Plugin::Tiny::VERSION = '0.012';
use strict;
use warnings;
use Carp 'confess';
use Module::Runtime 'use_package_optimistically';
use Scalar::Util 'blessed';
use Moo;
use MooX::Types::MooseLike::Base qw(Bool Str HashRef ArrayRef Object);
use namespace::clean;

#use Data::Dumper;


has '_registry' => (    #href with phases and plugin objects
    is       => 'ro',
    isa      => HashRef[Object],
    default  => sub { {} },
    init_arg => undef,
);


has 'debug' => (is => 'ro', isa => Bool, default => sub {0});


has 'prefix' => (is => 'ro', isa => Str);


has 'role' => (is => 'ro', isa => ArrayRef[Str]);


#
# METHODS
#


#Re-write init argument 'role' as arrayref if not yet arrayref.
around BUILDARGS => sub {
    my $orig  = shift;
    my $class = shift;
    my %args  = @_;

    if ($args{role} && ref ($args{role}) ne 'ARRAY'){
        $args{role}=[$args{role}];
    }
    return $class->$orig(%args);
};



sub register {
    my $self   = shift;
    my %args   = @_;
    my $plugin = delete $args{plugin} or confess "Need plugin";

    if ($self->prefix) {
        $plugin = $self->prefix . $plugin;
    }
    my $phase =
      $args{phase}
      ? delete $args{phase}
      : $self->default_phase($plugin);

    if (defined $self->{_registry}{$phase} && !$args{force}) {
        confess <
There is already a plugin registered under this phase. If you really want to
overwrite the current plugin with a new one, use 'force=>1'.
END
    }

     use_package_optimistically($plugin)->can('new') or confess "Can't load '$plugin'";

    my $roles = $self->role if $self->role;    #default role
    $roles = delete $args{role} if exists $args{role};

    #rewrite scalar as arrayref
    $roles = [$roles] if ($roles && !ref $roles);

    if ($roles && ref $roles eq 'ARRAY') {
        foreach my $role (@{$roles}) {
            if ($plugin->DOES($role)) {
                $self->_debug("Plugin '$plugin' does role '$role'");
            }
            else {
                confess qq(Plugin '$plugin' doesn't do role '$role');
            }
        }
    }

    $self->{_registry}{$phase} = $plugin->new(%args)
      || confess "Can't make $plugin";
    $self->_debug("register $plugin [$phase]");
    return $self->{_registry}{$phase};
}



sub register_bundle {
    my $self = shift;
    my $bundle = shift or return;
    foreach my $plugin (keys %{$bundle}) {
        my %args = %{$bundle->{$plugin}};
        $args{plugin} = $plugin;
        $self->register(%args) or confess "Registering $plugin failed";
    }
    return $bundle;
}



sub get_plugin {
    my $self = shift;
    my $phase = shift or return;
    return if (!$self->{_registry}{$phase});
    return $self->{_registry}{$phase};
}



sub default_phase {
    my $self = shift;
    my $plugin = shift or return;    #a class name

    if ($self->prefix) {
        my $phase  = $plugin;
        my $prefix = $self->prefix;
        $phase =~ s/$prefix//;
        $phase =~ s/:://g;
        return $phase;
    }
    else {
        my @parts = split('::', $plugin);
        return $parts[-1];
    }
}


#Todo: Not sure what it returns on error.


sub get_class {
    my $self = shift;
    my $plugin = shift or return;
    blessed($plugin);
}



sub get_phase {
    my $self = shift;
    my $plugin = shift or return;
    blessed($plugin);
    my $current_class = $self->get_class($plugin);

    #print 'z:['.join(' ', keys %{$self->{_registry}})."]\n";
    foreach my $phase (keys %{$self->{_registry}}) {
        my $registered_class = blessed($self->{_registry}{$phase});
        print "[$phase] $registered_class === $current_class\n";
        return $phase if ("$registered_class" eq "$current_class");
    }

}


#
# PRIVATE
#

sub _debug {
    print $_[1] . "\n" if $_[0]->debug;
}

1;

__END__