r38722 - in /branches/upstream/libpadwalker-perl/current: Changes PadWalker.pm PadWalker.xs README t/closure.t
jawnsy-guest at users.alioth.debian.org
jawnsy-guest at users.alioth.debian.org
Fri Jun 26 14:50:50 UTC 2009
Author: jawnsy-guest
Date: Fri Jun 26 14:50:45 2009
New Revision: 38722
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=38722
Log:
[svn-upgrade] Integrating new upstream version, libpadwalker-perl (1.9)
Modified:
branches/upstream/libpadwalker-perl/current/Changes
branches/upstream/libpadwalker-perl/current/PadWalker.pm
branches/upstream/libpadwalker-perl/current/PadWalker.xs
branches/upstream/libpadwalker-perl/current/README
branches/upstream/libpadwalker-perl/current/t/closure.t
Modified: branches/upstream/libpadwalker-perl/current/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libpadwalker-perl/current/Changes?rev=38722&op=diff
==============================================================================
--- branches/upstream/libpadwalker-perl/current/Changes (original)
+++ branches/upstream/libpadwalker-perl/current/Changes Fri Jun 26 14:50:45 2009
@@ -120,3 +120,9 @@
1.7 Mon Feb 4 09:56:31 GMT 2008
- Keep up with changes in blead post-5.10 (@33030)
+1.8 Thu 25 Jun 2009 21:17:17 BST
+ - Apply patches from doy (#41710) and nothingmuch (set_closed_over).
+
+1.9 Fri 26 Jun 2009 10:01:17 BST
+ - Identical to 1.8, but with the bogus metadata ._ files removed
+ from the distributed tar file.
Modified: branches/upstream/libpadwalker-perl/current/PadWalker.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libpadwalker-perl/current/PadWalker.pm?rev=38722&op=diff
==============================================================================
--- branches/upstream/libpadwalker-perl/current/PadWalker.pm (original)
+++ branches/upstream/libpadwalker-perl/current/PadWalker.pm Fri Jun 26 14:50:45 2009
@@ -9,10 +9,10 @@
require 5.008;
@ISA = qw(Exporter DynaLoader);
- at EXPORT_OK = qw(peek_my peek_our closed_over peek_sub var_name);
+ at EXPORT_OK = qw(peek_my peek_our closed_over peek_sub var_name set_closed_over);
%EXPORT_TAGS = (all => \@EXPORT_OK);
-$VERSION = '1.7';
+$VERSION = '1.9';
bootstrap PadWalker $VERSION;
@@ -112,6 +112,12 @@
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
@@ -137,9 +143,9 @@
Robin Houston <robin at cpan.org>
-With contributions from Richard Soberberg, bug-spotting
-from Peter Scott and Dave Mitchell, and suggestions from
-demerphq.
+With contributions from Richard Soberberg, Jesse Luehrs and
+Yuval Kogman, bug-spotting from Peter Scott, Dave Mitchell and
+Goro Fuji, and suggestions from demerphq.
=head1 SEE ALSO
@@ -147,7 +153,7 @@
=head1 COPYRIGHT
-Copyright (c) 2000-2007, Robin Houston. All Rights Reserved.
+Copyright (c) 2000-2009, Robin Houston. All Rights Reserved.
This module is free software. It may be used, redistributed
and/or modified under the same terms as Perl itself.
Modified: branches/upstream/libpadwalker-perl/current/PadWalker.xs
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libpadwalker-perl/current/PadWalker.xs?rev=38722&op=diff
==============================================================================
--- branches/upstream/libpadwalker-perl/current/PadWalker.xs (original)
+++ branches/upstream/libpadwalker-perl/current/PadWalker.xs Fri Jun 26 14:50:45 2009
@@ -358,9 +358,17 @@
get_closed_over(CV *cv, HV *hash, HV *indices)
{
I32 i;
- 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);
+ U32 val_depth;
+ AV *pad_namelist;
+ AV *pad_vallist;
+
+ if (!CvPADLIST(cv)) {
+ return;
+ }
+
+ val_depth = CvDEPTH(cv) ? CvDEPTH(cv) : 1;
+ pad_namelist = (AV*) *av_fetch(CvPADLIST(cv), 0, FALSE);
+ pad_vallist = (AV*) *av_fetch(CvPADLIST(cv), val_depth, FALSE);
debug_print(("av_len(CvPADLIST(cv)) = %ld\n", av_len(CvPADLIST(cv)) ));
@@ -488,6 +496,52 @@
SvREFCNT_dec((SV*) ignore);
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)
Modified: branches/upstream/libpadwalker-perl/current/README
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libpadwalker-perl/current/README?rev=38722&op=diff
==============================================================================
--- branches/upstream/libpadwalker-perl/current/README (original)
+++ branches/upstream/libpadwalker-perl/current/README Fri Jun 26 14:50:45 2009
@@ -1,5 +1,5 @@
-----------------------------------------------------------------------------
-| PadWalker v1.7 - Robin Houston
+| PadWalker v1.8 - Robin Houston
-----------------------------------------------------------------------------
NAME
@@ -78,6 +78,13 @@
does have reasonable uses: see Data::Dump::Streamer, for example (a
future version of which may in fact use "closed_over").
+ set_closed_over SUB, HASH_REF
+ "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 "closed_over".
+
var_name LEVEL, VAR_REF
var_name SUB, VAR_REF
"var_name(sub, var_ref)" returns the name of the variable referred
@@ -106,6 +113,6 @@
Devel::LexAlias, Devel::Caller, Sub::Parameters
COPYRIGHT
- Copyright (c) 2000-2007, Robin Houston. All Rights Reserved. This mod-
+ Copyright (c) 2000-2009, Robin Houston. All Rights Reserved. This mod-
ule is free software. It may be used, redistributed and/or modified
under the same terms as Perl itself.
Modified: branches/upstream/libpadwalker-perl/current/t/closure.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libpadwalker-perl/current/t/closure.t?rev=38722&op=diff
==============================================================================
--- branches/upstream/libpadwalker-perl/current/t/closure.t (original)
+++ branches/upstream/libpadwalker-perl/current/t/closure.t Fri Jun 26 14:50:45 2009
@@ -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..28\n";
my $x=2;
my $h = closed_over (my $sub = sub {my $y = $x++});
@@ -53,7 +53,48 @@
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" );
+}
More information about the Pkg-perl-cvs-commits
mailing list