File Coverage

blib/lib/Plugin/System.pm

Criterion	Covered	Total	%
statement	6	35	17.1
branch	0	10	0.0
condition			n/a
subroutine	2	9	22.2
pod	0	3	0.0
total	8	57	14.0

## no critic: TestingAndDebugging::RequireUseStrict
package Plugin::System;

#IFBUILT
use strict 'subs', 'vars';
use warnings;
#END IFBUILT

our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
our $DATE = '2024-03-02'; # DATE
our $DIST = 'Plugin-System'; # DIST
our $VERSION = '0.000001'; # VERSION

our $re_addr = qr/\(0x([0-9a-f]+)/o;

our %Target_Packages;      # key=package name, value=1
our %Per_Package_Handlers; # key=package name, value={ $hook=>$handlers, ... }

my $sub0 = sub {0};
my $sub1 = sub {1};

sub install_routines {
    my ($target_pkg, $routines) = @_;

    if (!defined &subname) {
        #if (eval { require Sub::Name; 1 }) {
        #    *subname = \&Sub::Name::subname;
        #} else {
            *subname = sub {};
        #}
    }

    for my $r (@$routines) {
        my ($code, $name) = @$r;
        *{"$target_pkg\::$name"} = $code;
        subname("$target_pkg\::$name", $code);
    }
}

sub add_target {
    my ($pkg, %args) = @_;

    # check arguments
    my $hooks = delete $args{hooks} or die "Please specify 'hooks' argument";
    for (keys %$hooks) { /\A\w+\z/ or die "Invalid syntax in hook name '$_', please use alphanumeric only" };

    keys %args and die "Unknown argument(s): ".join(", ", sort keys %args);

    # if already defined, overwrite previous configuration
    $Target_Packages{$pkg} = {hooks => $hooks};
}

sub init_target {
    my $pkg = shift;

    my $args = $Target_Packages{$pkg} or die "Package '$pkg' has not been added as target yet";

    my $routines = [];
    for my $hook (keys %{ $args->{hooks} }) {
        push @$routines, [sub(;&@) { shift->() }, "hook_$hook"];
    }
    install_routines($pkg, $routines);
}

sub _import_to {
    my $pkg = shift;
    my $target_pkg = shift;

    add_target($target_pkg, @_);
    init_target($target_pkg);
}

sub import {
    my $pkg = shift;

    my $caller = caller(0);
    $pkg->_import_to($caller, @_);
}

1;
# ABSTRACT: A plugin system for your Perl framework or application

__END__