File Coverage

blib/lib/Dancer/Plugin.pm

Criterion	Covered	Total	%
statement	76	80	95.0
branch	5	6	83.3
condition	5	7	71.4
subroutine	19	21	90.4
pod	6	9	66.6
total	111	123	90.2

package Dancer::Plugin;
our $AUTHORITY = 'cpan:SUKRIA';
#ABSTRACT: helper for writing Dancer plugins
$Dancer::Plugin::VERSION = '1.3520';
use strict;
use warnings;
use Carp;

use base 'Exporter';
use Dancer::Config 'setting';
use Dancer::Hook;
use Dancer::Factory::Hook;
use Dancer::Exception qw(:all);

use base 'Exporter';
use vars qw(@EXPORT);

@EXPORT = qw(
  add_hook
  register
  register_plugin
  plugin_setting
  register_hook
  execute_hooks
  execute_hook
  plugin_args
);

sub register($&);

my $_keywords = {};

sub add_hook { Dancer::Hook->new(@_) }

sub plugin_args { (undef, @_) }

sub plugin_setting {
    my $plugin_orig_name = caller();
    (my $plugin_name = $plugin_orig_name) =~ s/Dancer::Plugin:://;

    return setting('plugins')->{$plugin_name} ||= {};
}

sub register_hook {
    Dancer::Factory::Hook->instance->install_hooks(@_);
}

sub execute_hooks {
    Dancer::Deprecation->deprecated(reason => "use 'execute_hook'",
                                    version => '1.3098',
                                    fatal => 0);
    Dancer::Factory::Hook->instance->execute_hooks(@_);
}

sub execute_hook {
    Dancer::Factory::Hook->instance->execute_hooks(@_);
}

sub register($&) {
    my ($keyword, $code) = @_;
    my $plugin_name = caller();

    $keyword =~ /^[a-zA-Z_]+[a-zA-Z0-9_]*$/
      or raise core_plugin => "You can't use '$keyword', it is an invalid name"
        . " (it should match ^[a-zA-Z_]+[a-zA-Z0-9_]*$ )";

    if (
        grep { $_ eq $keyword }
        map  { s/^(?:\$|%|&|@|\*)//; $_ }
        (@Dancer::EXPORT, @Dancer::EXPORT_OK)
    ) {
        raise core_plugin => "You can't use '$keyword', this is a reserved keyword";
    }
    while (my ($plugin, $keywords) = each %$_keywords) {
        if (grep { $_->[0] eq $keyword } @$keywords) {
            raise core_plugin => "You can't use $keyword, "
                . "this is a keyword reserved by $plugin";
        }
    }

    $_keywords->{$plugin_name} ||= [];
    push @{$_keywords->{$plugin_name}}, [$keyword => $code];
}

sub register_plugin {
    my ($application) = shift || caller(1);
    my ($plugin) = caller();

    my @symbols = set_plugin_symbols($plugin);
    {
        no strict 'refs';
        # tried to use unshift, but it yields an undef warning on $plugin (perl v5.12.1)
        @{"${plugin}::ISA"} = ('Dancer::Plugin', @{"${plugin}::ISA"});
        # this works because Dancer::Plugin already ISA Exporter
        push @{"${plugin}::EXPORT"}, @symbols;
    }
    return 1;
}

sub set_plugin_symbols {
    my ($plugin) = @_;

    for my $keyword (@{$_keywords->{$plugin}}) {
        my ($name, $code) = @$keyword;
        {
            no strict 'refs';
            *{"${plugin}::${name}"} = $code;
        }
    }
    return map { $_->[0] } @{$_keywords->{$plugin}};
}

1;

__END__