view release on metacpan or  search on metacpan

script/rsybak  view on Meta::CPAN

#
#    die "'$obj' not an object" unless blessed($obj);
#    die "Please specify action" unless $action0;
#    die "Invalid action '$action0', please choose add|replace|add_or_replace|wrap|delete"
#        unless $action0 =~ /\A(add|replace|add_or_replace|wrap|delete)\z/;
#    if ($action0 eq 'delete') {
#        die "code not needed for 'delete' action" if $code0;
#    } else {
#        die "Please specify code" unless $code0;
#    }
#
#    my $package = ref($obj);
#    my $name = "$package\::$methname";
#    my $action = defined(&$name) ? 'wrap' : 'add';
#
#    my $code = sub {
#        my $ctx  = $action eq 'wrap' ? shift : undef;
#        my $self = $_[0];
#        no warnings 'numeric';
#        if ($obj == $self) {
#            if ($action0 eq 'add') {
#                $code0->(@_);
#            } elsif ($action0 eq 'replace') {
#                $code0->(@_);
#            } elsif ($action0 eq 'add_or_replace') {
#                $code0->(@_);
#            } elsif ($action0 eq 'wrap') {
#                my $octx = {%$ctx};
#                $code0->($octx, @_);
#            } elsif ($action0 eq 'delete') {
#                die "Undefined method '$methname' for object '$obj'";
#            } else {
#                die "BUG: Unknown action '$action0'";
#            }
#        } else {
#            if ($action eq 'wrap') {
#                return $ctx->{orig}->(@_);
#            } else {
#                die "Undefined method '$methname' for object '$obj'";
#            }
#        }
#    };
#
#    patch_package($package, $methname, $action, $code, @extra);
#}
#
#1;
#
#__END__
#
### Monkey/Patch/Action/Handle.pm ###
#package Monkey::Patch::Action::Handle;
#
#our $DATE = '2018-04-02'; 
#our $VERSION = '0.061'; 
#
#use 5.010;
#use strict;
#use warnings;
#
#use Scalar::Util qw(weaken);
#use Sub::Delete;
#
#my %stacks;
#
#sub __find_previous {
#    my ($stack, $code) = @_;
#    state $empty = sub {};
#
#    for my $i (1..$#$stack) {
#        if ($stack->[$i][1] == $code) {
#            return $stack->[$i-1][2] // $stack->[$i-1][1];
#        }
#    }
#    $empty;
#}
#
#sub new {
#    my ($class, %args) = @_;
#
#    my $type = $args{-type};
#    delete $args{-type};
#
#    my $code = $args{code};
#
#    my $name = "$args{package}::$args{subname}";
#    my $stack;
#    if (!$stacks{$name}) {
#        $stacks{$name} = [];
#        push @{$stacks{$name}}, [sub => \&$name] if defined(&$name);
#    }
#    $stack = $stacks{$name};
#
#    my $self = bless \%args, $class;
#
#    no strict 'refs';
#    no warnings 'redefine';
#    if ($type eq 'sub') {
#        push @$stack, [$type => $code];
#        *$name = $code;
#    } elsif ($type eq 'delete') {
#        $code = sub {};
#        $args{code} = $code;
#        push @$stack, [$type, $code];
#        delete_sub $name;
#    } elsif ($type eq 'wrap') {
#        weaken($self);
#        my $wrapper = sub {
#            my $ctx = {
#                package => $self->{package},
#                subname => $self->{subname},
#                extra   => $self->{extra},
#                orig    => __find_previous($stack, $self->{code}),
#            };
#            unshift @_, $ctx;
#            goto &{$self->{code}};
#        };
#        push @$stack, [$type => $code => $wrapper];
#        *$name = $wrapper;
#    }
#
#    $self;
#}
#
#sub DESTROY {
#    my $self = shift;
#
#    my $name  = "$self->{package}::$self->{subname}";
#    my $stack = $stacks{$name};
#    my $code  = $self->{code};
#
#    for my $i (0..$#$stack) {
#        if($stack->[$i][1] == $code) {
#            if ($stack->[$i+1]) {
#                if ($stack->[$i+1][0] eq 'wrap' &&
#                        ($i == 0 || $stack->[$i-1][0] eq 'delete')) {
#                    my $p = $self->{patcher};
#                    warn "Warning: unapplying patch to $name ".
#                        "(applied in $p->[1]:$p->[2]) before a wrapping patch";
#                }
#            }
#
#            no strict 'refs';
#            if ($i == @$stack-1) {
#                if ($i) {
#                    no warnings 'redefine';
#                    if ($stack->[$i-1][0] eq 'delete') {
#                        delete_sub $name;
#                    } else {
#                        *$name = $stack->[$i-1][2] // $stack->[$i-1][1];
#                    }
#                } else {
#                    delete_sub $name;
#                }
#            }
#            splice @$stack, $i, 1;
#            last;
#        }
#    }
#}
#
#1;
#
#__END__
#
### Nodejs/Util.pm ###
#package Nodejs::Util;