This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix skip logic in pad_tidy and cv_clone
authorFather Chrysostomos <sprout@cpan.org>
Tue, 20 Aug 2013 06:17:08 +0000 (23:17 -0700)
committerFather Chrysostomos <sprout@cpan.org>
Tue, 20 Aug 2013 19:50:00 +0000 (12:50 -0700)
Commit 325e1816dc changed the logic for determining whether a pad
entry is to be treated like a constant; i.e., shared between recursion
levels and sub clones.

According the old logic, a pad entry must be shared if it is marked
READONLY or is a shared hash key scalar.  According to the new logic,
the entry must be shared if the pad name has a zero-length PV (i.e.,
&PL_sv_no).

Two pieces of code were still following the old logic.  Changing them
fixes this old bug:

my $close_over_me;
sub  {
    () = $close_over_me;
    open my $fh, "/dev/null";
    print "$$fh\n"
}->();
__END__

Output:
*main::

The name attached to the implicit rv2gv op in open() was not being
copied by sub clones.

The previous commit is also part of the fix.

In the tests, I tested the combination of sub cloning and recursion,
since it seemed like a good idea (and also as a result of copying and
pasting :-).

S_pmtrans was still relying on the old logic, so it gets changed, too.

op.c
pad.c
t/op/gv.t

diff --git a/op.c b/op.c
index 44d2f20..c5964eb 100644 (file)
--- a/op.c
+++ b/op.c
@@ -4268,7 +4268,7 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
 
        swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
 #ifdef USE_ITHREADS
-       cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
+       cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
        SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
        PAD_SETSV(cPADOPo->op_padix, swash);
        SvPADTMP_on(swash);
diff --git a/pad.c b/pad.c
index d2b6c4f..d8d9322 100644 (file)
--- a/pad.c
+++ b/pad.c
@@ -1773,16 +1773,16 @@ Perl_pad_tidy(pTHX_ padtidy_type type)
        for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
            SV *namesv;
 
-           if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
-               continue;
            /*
             * The only things that a clonable function needs in its
-            * pad are anonymous subs.
+            * pad are anonymous subs, constants and GVs.
             * The rest are created anew during cloning.
             */
+           if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]))
+               continue;
            if (!((namesv = namep[ix]) != NULL &&
-                 namesv != &PL_sv_undef &&
-                  *SvPVX_const(namesv) == '&'))
+                 PadnamePV(namesv) &&
+                  (!PadnameLEN(namesv) || *SvPVX_const(namesv) == '&')))
            {
                SvREFCNT_dec(PL_curpad[ix]);
                PL_curpad[ix] = NULL;
@@ -2120,7 +2120,7 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, bool newcv)
                    SvPADSTALE_on(sv);
            }
        }
-       else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
+       else if (IS_PADGV(ppad[ix]) || (namesv && PadnamePV(namesv))) {
            sv = SvREFCNT_inc_NN(ppad[ix]);
        }
        else {
index c01c5d2..7494e09 100644 (file)
--- a/t/op/gv.t
+++ b/t/op/gv.t
@@ -12,7 +12,7 @@ BEGIN {
 
 use warnings;
 
-plan( tests => 253 );
+plan( tests => 254 );
 
 # type coercion on assignment
 $foo = 'foo';
@@ -651,6 +651,20 @@ is join(' ', r(4)),
   '*main::$fh *main::$fh *main::$fh *main::$fh *main::$fh',
   'recursion does not cause lex handles to lose their names';
 
+# And sub cloning, too; not just recursion
+my $close_over_me;
+is join(' ', sub {
+    () = $close_over_me;
+    my @output;
+    @output = CORE::__SUB__->($_[0]-1) if $_[0];
+    open my $fh, "TEST";
+    push @output, $$fh;
+    close $fh;
+    @output;
+   }->(4)),
+  '*main::$fh *main::$fh *main::$fh *main::$fh *main::$fh',
+  'sub cloning does not cause lex handles to lose their names';
+
 # [perl #71254] - Assigning a glob to a variable that has a current
 # match position. (We are testing that Perl_magic_setmglob respects globs'
 # special used of SvSCREAM.)