File Coverage

blib/lib/Module/Patch.pm

Criterion	Covered	Total	%
statement	138	172	80.2
branch	58	110	52.7
condition	17	43	39.5
subroutine	13	14	92.8
pod	1	3	33.3
total	227	342	66.3

package Module::Patch;

use 5.010001;
use strict 'subs', 'vars';
use warnings;
use Log::ger;

use Monkey::Patch::Action qw();
use Package::Stash;
use Package::Util::Lite qw(package_exists);

our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
our $DATE = '2024-04-17'; # DATE
our $DIST = 'Module-Patch'; # DIST
our $VERSION = '0.278'; # VERSION

our @EXPORT_OK = qw(patch_package);

sub is_loaded {
    my $mod = shift;

    (my $mod_pm = "$mod.pm") =~ s!::!/!g;
    exists($INC{$mod_pm}) && $INC{$mod_pm};
}

my%loaded_by_us;

sub import {
    my $self = shift;

    my $caller = caller;

    if ($self eq __PACKAGE__) {
        # we are not subclassed, provide exports
        for my $exp (@_) {
            die "$exp is not exported by ".__PACKAGE__
                unless grep { $_ eq $exp } @EXPORT_OK;
            *{"$caller\::$exp"} = \&{$exp};
        }
    } else {
        # patch already applied, ignore
        return if ${"$self\::handles"};

        # get patch data from patch_data()
        unless (${"$self\::patch_data_cached"}) {
            ${"$self\::patch_data_cached"} = $self->patch_data;
        }

        # we are subclassed, patch caller with patch data
        my %opts = @_;

        my $load;
        if (exists $opts{-load_target}) {
            $load = $opts{-load_target};
            delete $opts{-load_target};
        }
        $load //= ${"$self\::patch_data_cached"}->{-load_target};
        $load //= 1;

        my $force;
        if (exists $opts{-force}) {
            $force = $opts{-force};
            delete $opts{-force};
        }
        $force //= ${"$self\::patch_data_cached"}->{-force};
        $force //= 0;

        my $warn;
        if (exists $opts{-warn_target_loaded}) {
            $warn = $opts{-warn_target_loaded};
            delete $opts{-warn_target_loaded};
        }
        $warn //= ${"$self\::patch_data_cached"}->{"-warn_target_loaded"};
        $warn //= 1;

        my $pdata = ${"$self\::patch_data_cached"} or
            die "BUG: $self: No patch data supplied";
        my $v = $pdata->{v} // 1;
        my $curv = 3;
        if ($v == 1 || $v == 2) {
            my $mpv;
            if ($v == 1) {
                $mpv = "0.06 or earlier";
            } elsif ($v == 2) {
                $mpv = "0.07-0.09";
            }
            die "$self ".( ${"$self\::VERSION" } // "?" ).
                " requires Module::Patch $mpv (patch_data format v=$v),".
                " this is Module::Patch ".($Module::Patch::VERSION // '?').
                " (v=$curv), please install an older version of ".
                "Module::Patch or upgrade $self";
        } elsif ($v == 3) {
            # ok, current version
        } else {
            die "BUG: $self: Unknown patch_data format version ($v), ".
                "only v=$curv supported by this version of Module::Patch";
        }

        my $target = $self;
        $target =~ s/(?<=\w)::[Pp]atch::\w+$//
            or die "BUG: $self: Bad patch module name '$target', it should ".
                "end with '::Patch::YourCategory'";

        if (is_loaded($target)) {
            if (!$loaded_by_us{$target}) {
                if ($load && $warn) {
                    warn "$target is loaded before ".__PACKAGE__.", this is ".
                        "not recommended since $target might export subs ".
                        "before " . __PACKAGE__." gets the chance to patch " .
                        "them";
                }
            }
        } else {
            if ($load) {
                eval "package $caller; use $target"; ## no critic: BuiltinFunctions::ProhibitStringyEval
                die if $@;
                $loaded_by_us{$target}++;
            } else {
                if ($warn) {
                    warn "$target does not exist and we are told not to load ".
                        "it, skipped patching";
                }
                return;
            }
        }

        # read patch module's configs
        no warnings 'once';
        my $pcdata = $pdata->{config} // {};
        my $config = \%{"$self\::config"};
        while (my ($k, $v) = each %$pcdata) {
            die "Invalid configuration defined by $self\::patch_data(): ".
                "$k: must start with dash" unless $k =~ /\A-/;
            $config->{$k} = $v->{default};
            if (exists $opts{$k}) {
                $config->{$k} = $opts{$k};
                delete $opts{$k};
            }
        }

        if (keys %opts) {
            die "$self: Unknown option(s): ".join(", ", keys %opts);
        }

        if ($pdata->{after_read_config}) {
            $pdata->{after_read_config}->();
        }

        if ($pdata->{before_patch}) {
            $pdata->{before_patch}->();
        }

        log_trace "Module::Patch: patching $target with $self ...";
        ${"$self\::handles"} = patch_package(
            $target, $pdata->{patches},
            {force=>$force, patch_module=>ref($self) || $self});

        if ($pdata->{after_patch}) {
            $pdata->{after_patch}->();
        }

    }
}

sub unimport {
    my $self = shift;

    if ($self eq __PACKAGE__) {
        # we are not subclassed, do nothing
    } else {
        my $pdata = ${"$self\::patch_data_cached"} or
            die "BUG: $self: No patch data supplied";

        if ($pdata->{before_unpatch}) {
            $pdata->{before_unpatch}->();
        }

        my $handles = ${"$self\::handles"};
        log_trace "Module::Patch: Unpatching $self ...";
        undef ${"$self\::handles"};
        # do we need to undef ${"$self\::config"}?, i'm thinking not really

        if ($pdata->{after_unpatch}) {
            $pdata->{after_unpatch}->();
        }

    }
}

sub patch_data {
    die "BUG: patch_data() should be provided by subclass";
}

sub patch_package {
    my ($package0, $patches_spec, $opts) = @_;
    $opts //= {};

    my $handles = {};
    for my $target (ref($package0) eq 'ARRAY' ? @$package0 : ($package0)) {
        die "FATAL: Target module '$target' not loaded"
            unless package_exists($target);
        my $target_version = ${"$target\::VERSION"};
        my $target_subs;

        my $i = 0;
      PATCH:
        for my $pspec (@$patches_spec) {
            my $act = $pspec->{action};
            my $errp = ($opts->{patch_module} ? "$opts->{patch_module}: ":"").
                "patch[$i]"; # error prefix
            $act or die "BUG: $errp: no action supplied";
            $act =~ /\A(wrap|add|replace|add_or_replace|delete)\z/ or die
                "BUG: $errp: action '$pspec->{action}' unknown";
            if ($act eq 'delete') {
                $pspec->{code} and die "BUG: $errp: for action 'delete', ".
                    "code must not be supplied";
            } else {
                $pspec->{code} or die "BUG: $errp: code not supplied";
            }

            my $sub_names = ref($pspec->{sub_name}) eq 'ARRAY' ?
                [@{ $pspec->{sub_name} }] : [$pspec->{sub_name}];
            for (@$sub_names) {
                $_ = qr/.*/    if $_ eq ':all';
                $_ = qr/^_/    if $_ eq ':private';
                $_ = qr/^[^_]/ if $_ eq ':public';
                die "BUG: $errp: unknown tag in sub_name $_" if /^:/;
            }

            my @s;
            for my $sub_name (@$sub_names) {
                if (ref($sub_name) eq 'Regexp') {
                    unless ($target_subs) {
                        $target_subs = [Package::Stash->new($target)->list_all_symbols("CODE")];
                    }
                    for (@$target_subs) {
                        push @s, $_ if $_ !~~ @s && $_ =~ $sub_name;
                    }
                } else {
                    push @s, $sub_name;
                }
            }

            unless (!defined($pspec->{mod_version}) ||
                        $pspec->{mod_version} eq ':all') {
                defined($target_version) && length($target_version)
                    or die "FATAL: Target package '$target' does not have ".
                    "\$VERSION";
                my $mod_versions = $pspec->{mod_version};
                $mod_versions = ref($mod_versions) eq 'ARRAY' ?
                    [@$mod_versions] : [$mod_versions];
                for (@$mod_versions) {
                    $_ = qr/.*/    if $_ eq ':all';
                    die "BUG: $errp: unknown tag in mod_version $_"
                        if /^:/;
                }

                unless (grep {
                    ref($_) eq 'Regexp' ? $target_version =~ $_ : $target_version eq $_
                } @$mod_versions) {
                    warn "$errp: Target module version $target_version ".
                        "does not match [".join(", ", @$mod_versions)."], ".
                        ($opts->{force} ?
                         "patching anyway (force)":"skipped"). ".";
                    next PATCH unless $opts->{force};
                }
            }

            for my $s (@s) {
                #log_trace("Patching %s ...", $s);
                $handles->{"$target\::$s"} =
                    Monkey::Patch::Action::patch_package(
                        $target, $s, $act, $pspec->{code});
            }

            $i++;
        } # for $pspec
    } # for $target
    $handles;
}

1;
# ABSTRACT: Patch package with a set of patches

__END__