view release on metacpan or  search on metacpan

lib/Module/Patch.pm  view on Meta::CPAN

        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";