diff options
author | Father Chrysostomos <sprout@cpan.org> | 2013-08-19 23:17:08 -0700 |
---|---|---|
committer | Father Chrysostomos <sprout@cpan.org> | 2013-08-20 12:50:00 -0700 |
commit | 3a6ce63afe9bfc9bf645e0c127824d8426a7ee67 (patch) | |
tree | 6a994506662ea1964fea6cddf3afc61f994ca276 | |
parent | 25451ceff7e8f05c501ecc72a1b3536005f391f7 (diff) | |
download | perl-3a6ce63afe9bfc9bf645e0c127824d8426a7ee67.tar.gz |
Fix skip logic in pad_tidy and cv_clone
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.
-rw-r--r-- | op.c | 2 | ||||
-rw-r--r-- | pad.c | 12 | ||||
-rw-r--r-- | t/op/gv.t | 16 |
3 files changed, 22 insertions, 8 deletions
@@ -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); @@ -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 { @@ -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.) |