Bug #47213 for PadWalker: [PATCH] Add set_closed_over($cv, $hash)

--- PadWalker.pm | 8 +++++++- PadWalker.xs | 46 ++++++++++++++++++++++++++++++++++++++++++++++ t/closure.t | 45 +++++++++++++++++++++++++++++++++++++++++++-- 3 files changed, 96 insertions(+), 3 deletions(-) diff --git a/PadWalker.pm b/PadWalker.pm index 7c14f3e..460143d 100644 --- a/PadWalker.pm +++ b/PadWalker.pm @@ -9,7 +9,7 @@ require DynaLoader; require 5.008; @ISA = qw(Exporter DynaLoader); -@EXPORT_OK = qw(peek_my peek_our closed_over peek_sub var_name); +@EXPORT_OK = qw(peek_my peek_our closed_over peek_sub var_name set_closed_over); %EXPORT_TAGS = (all => \@EXPORT_OK); $VERSION = '1.7'; @@ -112,6 +112,12 @@ in other words, the variables which it closes over. This I<does> have reasonable uses: see L<Data::Dump::Streamer>, for example (a future version of which may in fact use C<closed_over>). +=item set_closed_over SUB, HASH_REF + +C<set_closed_over> reassigns the pad variables that are closed over by the subroutine. + +The second argument is a hash of references, much like the one returned from C<closed_over>. + =item var_name LEVEL, VAR_REF =item var_name SUB, VAR_REF diff --git a/PadWalker.xs b/PadWalker.xs index 6e1809c..1840bd3 100644 --- a/PadWalker.xs +++ b/PadWalker.xs @@ -489,6 +489,52 @@ CV* cv; EXTEND(SP, 1); PUSHs(sv_2mortal(newRV_noinc((SV*)ret))); + + +void +set_closed_over(sv, pad) +SV* sv; +HV* pad; + PREINIT: + I32 i; + CV *cv = (CV *)SvRV(sv); + U32 val_depth = CvDEPTH(cv) ? CvDEPTH(cv) : 1; + AV *pad_namelist = (AV*) *av_fetch(CvPADLIST(cv), 0, FALSE); + AV *pad_vallist = (AV*) *av_fetch(CvPADLIST(cv), val_depth, FALSE); + CODE: + for (i=av_len(pad_namelist); i>=0; --i) { + SV** name_ptr = av_fetch(pad_namelist, i, 0); + + if (name_ptr && SvPOKp(*name_ptr)) { + SV* name_sv = *name_ptr; + char* name_str = SvPVX(name_sv); + STRLEN name_len = strlen(name_str); + + if (SvFAKE(name_sv) && 0 == (SvFLAGS(name_sv) & SVpad_OUR)) { + SV **restore_ref = hv_fetch(pad, name_str, name_len, FALSE); + if ( restore_ref ) { + if ( SvROK(*restore_ref) ) { + SV *restore = SvRV(*restore_ref); + SV **orig = av_fetch(pad_vallist, i, 0); + + if ( !orig || !*orig || strcmp(sv_reftype(*orig, 0), sv_reftype(restore, 0)) == 0 ) { + SvREFCNT_inc(restore); + + if ( av_store(pad_vallist, i, restore) == NULL ) + SvREFCNT_dec(restore); + } else { + croak("Incorrect reftype for variable %s (got %s expected %s)", name_str, sv_reftype(restore, 0), sv_reftype(*orig, 0)); + } + } else { + croak("The variable for %s is not a reference", name_str); + } + } + } + } + } + + + void closed_over(cv) CV* cv; diff --git a/t/closure.t b/t/closure.t index d8faf87..354c177 100644 --- a/t/closure.t +++ b/t/closure.t @@ -1,7 +1,7 @@ use strict; use warnings; -use PadWalker 'closed_over'; +use PadWalker 'closed_over', 'set_closed_over'; -print "1..16\n"; +print "1..21\n"; my $x=2; my $h = closed_over (my $sub = sub {my $y = $x++}); @@ -53,7 +53,48 @@ sub bar{ bar(); our $blah = 9; +no warnings 'misc'; my $blah = sub {$blah}; my ($vars, $indices) = closed_over($blah); print (keys %$vars == 0 ? "ok 15\n" : "not ok 15\n"); print (keys %$indices == 0 ? "ok 16\n" : "not ok 16\n"); + + +{ + my $x = 1; + my @foo = (); + my $other = 5; + my $h = closed_over( my $sub = sub { my $y = $x++; push @foo, $y; $y } ); + + my @keys = keys %$h; + + print( @keys == 2 ? "ok 17\n" : "not ok 17\n" ); + print( ${ $h->{'$x'} } eq 1 ? "ok 18\n" : "not ok 18\n" ); + + print( $sub->() == 1 ? "ok 19\n" : "not ok 19\n" ); + + set_closed_over( $sub, { '$x' => \$other } ); + + print( $sub->() == 5 ? "ok 20\n" : "not ok 20\n" ); + + print( $x == 2 ? "ok 21\n" : "not ok 21\n" ); + print( $other == 6 ? "ok 22\n" : "not ok 22\n" ); + + print( @foo == 2 ? "ok 23\n" : "not ok 23\n" ); + + print( $foo[0] == 1 ? "ok 24\n" : "not ok 24\n" ); + + print( $foo[1] == 5 ? "ok 25\n" : "not ok 25\n" ); + + my @other; + + set_closed_over( $sub, { '@foo' => \@other } ); + + print( $sub->() == 6 ? "ok 26\n" : "not ok 26\n" ); + + print( @other == 1 ? "ok 27\n" : "not ok 27\n" ); + + eval { set_closed_over( $sub, { '@foo' => \"foo" } ) }; + + print ( $@ ? "ok 28\n" : "not ok 28\n" ); +} -- 1.6.1.2