File Coverage

blib/lib/Sub/Replace.pm

Criterion	Covered	Total	%
statement	25	26	96.1
branch	5	10	50.0
condition	1	3	33.3
subroutine	6	6	100.0
pod	1	1	100.0
total	38	46	82.6

package Sub::Replace;
$Sub::Replace::VERSION = '0.1.0';
# ABSTRACT: Replace subroutines in packages with controlled effects

use 5.010001;
no strict 'refs';

use Carp ();
use Sub::Delete 1.00002 ();

sub sub_replace {
    @_ = %{ $_[0] } if @_ == 1 && ref $_[0] eq 'HASH';
    goto &_sub_replace;
}

sub _sub_replace {
    Carp::croak "Odd number of elements in sub_replace" if @_ % 2;

    my $caller = caller;

    my %old;
    while ( my ( $name, $sub ) = splice @_, 0, 2 ) {

        ( my $stashname, $name )
          = $name =~ /(.*::)((?:(?!::).)*)\z/s
          ? ( $1, $2 )
          : ( $caller . "::", $name );

        my $fullname = "${stashname}${name}";

        my $old = $old{$fullname} = \&{$fullname};
        Sub::Delete::delete_sub $fullname if defined $old;
        *{$fullname} = $sub if defined $sub;
    }

    return \%old;
}

1;

#pod =encoding utf8
#pod
#pod =head1 SYNOPSIS
#pod
#pod     use Sub::Replace;
#pod
#pod     sub one { say 'One' }
#pod
#pod     one(); # One
#pod
#pod     BEGIN { Sub::Replace::sub_replace('one', sub { say 'Uno' }); }
#pod
#pod     one(); # Uno
#pod
#pod     BEGIN { Sub::Replace::sub_replace('one', sub { say 'Eins' }); }
#pod
#pod     one(); # Eins
#pod
#pod =head1 DESCRIPTION
#pod
#pod In Perl, replacing a subroutine in a symbol table is as easy as doing:
#pod
#pod     *TargetPackage::target_sub = sub { ... };
#pod
#pod However that may cause a lot of trouble for compiled code
#pod with mentions to C<\&target_sub>. For example,
#pod
#pod     sub one { say 'One' }
#pod     one();
#pod     BEGIN { *one = sub { say 'Uno' }; }
#pod     one();
#pod     BEGIN { *one = sub { say 'Eins' }; }
#pod     one();
#pod
#pod will not output
#pod
#pod     One
#pod     Uno
#pod     Eins
#pod
#pod but
#pod
#pod     Eins
#pod     Eins
#pod     Eins
#pod
#pod This module provides a C function to address that.
#pod
#pod =head1 FUNCTIONS
#pod
#pod =head2 sub_replace
#pod
#pod     $old = Sub::Replace::sub_replace($name, $code);
#pod     $old = Sub::Replace::sub_replace($name1, $code1, $name2, $code2);
#pod     $old = Sub::Replace::sub_replace(\%subs);
#pod
#pod The sub name may be fully qualified (eg. C<'TargetPackage::target_sub'>) or not
#pod (like C<'target_sub'>). In the latter case, the caller package will be used.
#pod
#pod The return is a hash ref which maps the fully qualified names into
#pod the previously installed subroutines (or C if none were there).
#pod This is suitable to undo a previous C  by calling
#pod
#pod     Sub::Replace::sub_replace($old);
#pod
#pod =head1 CAVEATS
#pod
#pod The same as mentioned in L, namely:
#pod you may be surprised by taking references to globs in between
#pod calls to C.
#pod
#pod =head1 SEE ALSO
#pod
#pod L
#pod
#pod =cut

__END__