File Coverage

blib/lib/Require/HookChain.pm

Criterion	Covered	Total	%
statement	41	46	89.1
branch	16	22	72.7
condition	5	9	55.5
subroutine	5	5	100.0
pod			n/a
total	67	82	81.7

## no critic: TestingAndDebugging::RequireUseStrict
package Require::HookChain;

our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
our $DATE = '2023-07-23'; # DATE
our $DIST = 'Require-HookChain'; # DIST
our $VERSION = '0.015'; # VERSION

#IFUNBUILT
# use strict;
# use warnings;
#END IFUNBUILT

# be minimalistic, use our own blessed() so we don't have to load any module (in this case, Scalar::Util)
unless (defined &blessed) {
    *blessed = sub { my $arg = shift; my $ref = ref $arg; $ref && $ref !~ /\A(SCALAR|ARRAY|HASH|GLOB|Regexp)\z/ };
}

our $debug;

my $our_hook; $our_hook = sub {
    my ($self, $filename) = @_;

    warn "[Require::HookChain] require($filename) ...\n" if $debug;

    my $r = Require::HookChain::r->new(filename => $filename);

    for my $item (@INC) {
        my $ref = ref $item;

        if (!$ref) {
            # load from ordinary file
            next if defined $r->src;

            my $path = "$item/$filename";
            if (-f $path) {
                warn "[Require::HookChain] Loading $filename from $path ...\n" if $debug;
                open my $fh, "<", $path
                    or die "Can't open $path: $!";
                local $/;
                $r->src(scalar <$fh>);
                close $fh;
                next;
            }
        } elsif ($ref =~ /\ARequire::HookChain::(.+)/) {
            warn "[Require::HookChain] Calling hook $1 ...\n" if $debug;
            # currently return value is ignored
            $item->INC($r);
        }
    }

    my $src = $r->src;
    if (defined $src) {
        return \$src;
    } else {
        die "Can't locate $filename in \@INC";
    }
};

sub import {
    my $class = shift;

    # get early options first (-debug)
    {
        my $i = -1;
        while ($i < @_) {
            $i++;
            if ($_[$i] eq '-debug') {
                $debug = $_[$i+1];
                $i++;
                next;
            } elsif ($_[$i] =~ /\A-/) {
                $i++;
                next;
            } else {
                last;
            }
        }
    }

    warn "[Require::HookChain] (Re-)installing our own hook at the beginning of \@INC ...\n"
        if $debug;
    unless (@INC && blessed($INC[0]) && $INC[0] == $our_hook) {
        @INC = ($our_hook, grep { !(blessed($_) && $_ == $our_hook) } @INC);
    }

    # get the rest of the options and hook
    my $end;
    while (@_) {
        my $el = shift @_;
        if ($el eq '-end') {
            $end = shift @_;
            next;
        } elsif ($el eq '-debug') {
            # we've processed this
            shift @_;
            next;
        } else {
            my $pkg = "Require::HookChain::$el";
            (my $pkg_pm = "$pkg.pm") =~ s!::!/!g;
            warn "[Require::HookChain] Installing hook $el to the ".($end ? "end":"beginning")." of \@INC, args (".join(",", @_).") ...\n"
                if $debug;
            require $pkg_pm;
            my $c_hook = $pkg->new(@_);
            if ($end) {
                push @INC, $c_hook;
            } else {
                # install the hook after uss
                splice @INC, 1, 0, $c_hook;
            }
            last;
        }
    }
}

package Require::HookChain::r;

sub new {
    my ($class, %args) = @_;
    bless \%args, $class;
}

sub filename {
    my $self = shift;
    $self->{filename};
}

sub src {
    my $self = shift;
    if (@_) {
        my $old = $self->{src};
        $self->{src} = shift;
        return $old;
    } else {
        return $self->{src};
    }
}

1;
# ABSTRACT: Chainable require hooks

__END__