File Coverage

blib/lib/ScriptX.pm

Criterion	Covered	Total	%
statement	24	184	13.0
branch	14	100	14.0
condition	1	28	3.5
subroutine	2	10	20.0
pod	4	4	100.0
total	45	326	13.8

package ScriptX;

our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
our $DATE = '2020-10-01'; # DATE
our $DIST = 'ScriptX'; # DIST
our $VERSION = '0.000002'; # VERSION

# IFUNBUILT
# use strict;
# use warnings;
# END IFUNBUILT
use Log::ger;

our %Plugins;
our %Handlers;

my $Stash = {
    plugins => \%Plugins,
    handlers => \%Handlers,
};

sub run_event {
    my %args = @_;

    my $name = $args{name};
    log_trace "[scriptx] -> run_event(%s)", \%args;
    defined $name or die "Please supply 'name'";
    $Handlers{$name} ||= [];

    my $before_name = "before_$name";
    $Handlers{$before_name} ||= [];

    my $after_name = "after_$name";
    $Handlers{$after_name} ||= [];

    my $req_handler                          = $args{req_handler};                          $req_handler                          = 0 unless defined $req_handler;
    my $run_all_handlers                     = $args{run_all_handlers};                     $run_all_handlers                     = 1 unless defined $run_all_handlers;
    my $allow_before_handler_to_cancel_event = $args{allow_before_handler_to_cancel_event}; $allow_before_handler_to_cancel_event = 1 unless defined $allow_before_handler_to_cancel_event;
    my $allow_before_handler_to_skip_rest    = $args{allow_before_handler_to_skip_rest};    $allow_before_handler_to_skip_rest    = 1 unless defined $allow_before_handler_to_skip_rest;
    my $allow_handler_to_skip_rest           = $args{allow_handler_to_skip_rest};           $allow_handler_to_skip_rest           = 1 unless defined $allow_handler_to_skip_rest;
    my $allow_handler_to_repeat_event        = $args{allow_handler_to_repeat_event};        $allow_handler_to_repeat_event        = 1 unless defined $allow_handler_to_repeat_event;
    my $allow_after_handler_to_repeat_event  = $args{allow_after_handler_to_repeat_event};  $allow_after_handler_to_repeat_event  = 1 unless defined $allow_after_handler_to_repeat_event;
    my $allow_after_handler_to_skip_rest     = $args{allow_after_handler_to_skip_rest};     $allow_after_handler_to_skip_rest     = 1 unless defined $allow_after_handler_to_skip_rest;
    my $stop_after_first_handler_failure     = $args{stop_after_first_handler_failure};     $stop_after_first_handler_failure     = 1 unless defined $stop_after_first_handler_failure;

    my ($res, $is_success);

  RUN_BEFORE_EVENT_HANDLERS:
    {
        last if $name =~ /\A(after|before)_/;
        local $Stash->{event} = $before_name;
        my $i = 0;
        for my $rec (@{ $Handlers{$before_name} }) {
            $i++;
            my ($label, $prio, $handler) = @$rec;
            log_trace "[scriptx] [event %s] [%d/%d] -> handler %s ...",
                $before_name, $i, scalar(@{ $Handlers{$before_name} }), $label;
            $res = $handler->($Stash);
            $is_success = $res->[0] =~ /\A[123]/;
            log_trace "[scriptx] [event %s] [%d/%d] <- handler %s: %s (%s)",
                $before_name, $i, scalar(@{ $Handlers{$before_name} }), $label,
                $res, $is_success ? "success" : "fail";
            if ($res->[0] == 601) {
                if ($allow_before_handler_to_cancel_event) {
                    log_trace "[scriptx] Cancelling event $name (status 601)";
                    goto RETURN;
                } else {
                    die "$before_name handler returns 601 when allow_before_handler_to_cancel_event is set to false";
                }
            }
            if ($res->[0] == 201) {
                if ($allow_before_handler_to_skip_rest) {
                    log_trace "[scriptx] Skipping the rest of the $before_name handlers (status 201)";
                    last RUN_BEFORE_EVENT_HANDLERS;
                } else {
                    log_trace "[scriptx] $before_name handler returns 201, but we ignore it because allow_before_handler_to_skip_rest is set to false";
                }
            }
        }
    }

  RUN_EVENT_HANDLERS:
    {
        local $Stash->{event} = $name;
        my $i = 0;
        $res = [304, "There is no handler for event $name"];
        $is_success = 1;
        if ($req_handler) {
            die "There is no handler for event $name"
                unless @{ $Handlers{$name} };
        }

        for my $rec (@{ $Handlers{$name} }) {
            $i++;
            my ($label, $prio, $handler) = @$rec;
            log_trace "[scriptx] [event %s] [%d/%d] -> handler %s ...",
                $name, $i, scalar(@{ $Handlers{$name} }), $label;
            $res = $handler->($Stash);
            $is_success = $res->[0] =~ /\A[123]/;
            log_trace "[scriptx] [event %s] [%d/%d] <- handler %s: %s (%s)",
                $name, $i, scalar(@{ $Handlers{$name} }), $label,
                $res, $is_success ? "success" : "fail";
            last RUN_EVENT_HANDLERS if $is_success && !$run_all_handlers;
            if ($res->[0] == 601) {
                die "$name handler is not allowed to return 601";
            }
            if ($res->[0] == 602) {
                if ($allow_handler_to_repeat_event) {
                    log_trace "[scriptx] Repeating event $name (handler returns 602)";
                    goto RUN_EVENT_HANDLERS;
                } else {
                    die "$name handler returns 602 when allow_handler_to_repeat_event is set to false";
                }
            }
            if ($res->[0] == 201) {
                if ($allow_handler_to_skip_rest) {
                    log_trace "[scriptx] Skipping the rest of the $name handlers (status 201)";
                    last RUN_EVENT_HANDLERS;
                } else {
                    log_trace "[scriptx] $name handler returns 201, but we ignore it because allow_handler_to_skip_rest is set to false";
                }
            }
            last RUN_EVENT_HANDLERS if !$is_success && $stop_after_first_handler_failure;
        }
    }

    if ($is_success && $args{on_success}) {
        log_trace "[scriptx] Running on_success ...";
        $args{on_success}->($Stash);
    } elsif (!$is_success && $args{on_failure}) {
        log_trace "[scriptx] Running on_failure ...";
        $args{on_failure}->($Stash);
    }

  RUN_AFTER_EVENT_HANDLERS:
    {
        last if $name =~ /\A(after|before)_/;
        local $Stash->{event} = $after_name;
        my $i = 0;
        for my $rec (@{ $Handlers{$after_name} }) {
            $i++;
            my ($label, $prio, $handler) = @$rec;
            log_trace "[scriptx] [event %s] [%d/%d] -> handler %s ...",
                $after_name, $i, scalar(@{ $Handlers{$after_name} }), $label;
            $res = $handler->($Stash);
            $is_success = $res->[0] =~ /\A[123]/;
            log_trace "[scriptx] [event %s] [%d/%d] <- handler %s: %s (%s)",
                $after_name, $i, scalar(@{ $Handlers{$after_name} }), $label,
                $res, $is_success ? "success" : "fail";
            if ($res->[0] == 602) {
                if ($allow_after_handler_to_repeat_event) {
                    log_trace "[scriptx] Repeating event $name (status 602)";
                    goto RUN_EVENT_HANDLERS;
                } else {
                    die "$after_name handler returns 602 when allow_after_handler_to_repeat_event it set to false";
                }
            }
            if ($res->[0] == 201) {
                if ($allow_after_handler_to_skip_rest) {
                    log_trace "[scriptx] Skipping the rest of the $after_name handlers (status 201)";
                    last RUN_AFTER_EVENT_HANDLERS;
                } else {
                    log_trace "[scriptx] $after_name handler returns 201, but we ignore it because allow_after_handler_to_skip_rest is set to false";
                }
            }
        }
    }

  RETURN:
    log_trace "[scriptx] <- run_event(name=%s)", $name;
    undef;
}

sub run {
    run_event(
        name => 'run',
    );
}

my $handler_seq = 0;
sub add_handler {
    my ($event, $label, $prio, $handler) = @_;

    # XXX check for known events?
    $Handlers{$event} ||= [];

    # keep sorted
    splice @{ $Handlers{$event} }, 0, scalar(@{ $Handlers{$event} }),
        (sort { $a->[1] <=> $b->[1] || $a->[3] <=> $b->[3] } @{ $Handlers{$event} }, [$label, $prio, $handler, $handler_seq++]);
}

sub activate_plugin {
    my ($plugin_name0, $args) = @_;

    my ($plugin_name, $wanted_event, $wanted_prio) =
        $plugin_name0 =~ /\A(\w+(?:::\w+)*)(?:\@(\w+)(?:\@(\d+))?)?\z/
        or die "Invalid plugin name syntax, please use Foo::Bar or ".
        "Foo::Bar\@event or Foo::Bar\@event\@prio\n";

    local $Stash->{plugin_name} = $plugin_name;
    local $Stash->{plugin_args} = $args;

    run_event(
        name => 'activate_plugin',
        on_success => sub {
            my $package = "ScriptX::$plugin_name";
            (my $package_pm = "$package.pm") =~ s!::!/!g;
            log_trace "[scriptx] Loading module $package ...";
            require $package_pm;
            my $obj = $package->new(%{ $args || {} });
            $obj->activate($wanted_event, $wanted_prio);
        },
        on_failure => sub {
            die "Cannot activate plugin $plugin_name";
        },
    );
}

sub _import {
    #log_trace "_import(%s)", \@_;
    while (@_) {
        my $plugin_name0 = shift;
        my $plugin_args = @_ && ref($_[0]) eq 'HASH' ? shift : {};
        activate_plugin($plugin_name0, $plugin_args);
    }
}

sub _unflatten_import {
    my ($env, $what) = @_;

    $what ||= "import";
    my @imports;
    my $plugin_name0;
    my @plugin_args;

    my @elems = ref $env eq 'ARRAY' ? @$env : split /,/, $env;
    while (@elems) {
        my $el = shift @elems;
        # dash prefix to disambiguate between plugin name and arguments, e.g.
        # '-PluginName,argname,argval,argname2,argval2,-Plugin2Name,...'
        if ($el =~ /\A-(\w+(?:::\w+)*(?:\@.+)?)\z/) {
            if (defined $plugin_name0) {
                push @imports, $plugin_name0;
                push @imports, {@plugin_args} if @plugin_args;
            }
            $plugin_name0 = $1;
            @plugin_args = ();
            if (!@elems) {
                push @imports, $1;
            }
        } else {
            die "Invalid syntax in $what, first element needs to be ".
                "a plugin name (e.g. -Foo), not '$el'"
                unless defined $plugin_name0;
                push @plugin_args, $el;
            if (!@elems) {
                push @imports, $plugin_name0;
                push @imports, {@plugin_args} if @plugin_args;
            }
        }
    }
    @imports;
}

my $read_env;
sub import {
    my $class = shift;

  READ_ENV:
    {
        last if $read_env;
      READ_SCRIPTX_IMPORT:
        {
            last unless defined $ENV{SCRIPTX_IMPORT};
            log_trace "[scriptx] Reading env variable SCRIPTX_IMPORT ...";
            _import(_unflatten_import($ENV{SCRIPTX_IMPORT}, "SCRIPTX_IMPORT"));
            $read_env++;
            last READ_ENV;
        }

      READ_SCRIPTX_IMPORT_JSON:
        {
            last unless defined $ENV{SCRIPTX_IMPORT_JSON};
            require JSON::PP;
            log_trace "[scriptx] Reading env variable SCRIPTX_IMPORT_JSON ...";
            my $imports = JSON::PP::decode_json($ENV{SCRIPTX_IMPORT_JSON});
            _import(@$imports);
            $read_env++;
            last READ_ENV;
        }
    }

    if (@_ && $_[0] =~ /\A-/) {
        # user that specify imports on command-line, e.g. using -MScriptX=...
        # can use the ENV syntax so she can specify plugin arguments more
        # easily: -MScriptX=-Run,command,foobar,-AnotherPlugin,...
        _import(_unflatten_import(\@_, "import arguments"));
    } else {
        _import(@_);
    }
}

1;
# ABSTRACT: A plugin-based script framework

__END__