diff options
| -rw-r--r-- | pad.c | 10 | ||||
| -rwxr-xr-x | t/op/eval.t | 48 |
2 files changed, 52 insertions, 6 deletions
@@ -1120,13 +1120,15 @@ Perl_pad_free(pTHX_ PADOFFSET po) if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) { SvPADTMP_off(PL_curpad[po]); #ifdef USE_ITHREADS + /* SV could be a shared hash key (eg bugid #19022) */ + if ( #ifdef PERL_COPY_ON_WRITE - if (SvIsCOW(PL_curpad[po])) { - sv_force_normal_flags(PL_curpad[po], SV_COW_DROP_PV); - } else + !SvIsCOW(PL_curpad[po]) +#else + !SvFAKE(PL_curpad[po]) #endif + ) SvREADONLY_off(PL_curpad[po]); /* could be a freed constant */ - #endif } if ((I32)po < PL_padix) diff --git a/t/op/eval.t b/t/op/eval.t index e81b9f76a5..8e8f69c0b8 100755 --- a/t/op/eval.t +++ b/t/op/eval.t @@ -1,6 +1,11 @@ #!./perl -print "1..84\n"; +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +print "1..87\n"; eval 'print "ok 1\n";'; @@ -346,7 +351,8 @@ eval q{ my $yyy = 888; my $zzz = 999; fred5(); }; { $eval = eval 'sub { eval "sub { %S }" }'; $eval->({}); - print "ok 78\n"; + print "ok $test\n"; + $test++; } # evals that appear in the DB package should see the lexical scope of the @@ -375,3 +381,41 @@ our $x = 1; print DB::db5() == 3 ? 'ok' : 'not ok', " $test\n"; $test++; print db6() == 4 ? 'ok' : 'not ok', " $test\n"; $test++; } +require './test.pl'; +$NO_ENDING = 1; +# [perl #19022] used to end up with shared hash warnings +# The program should generate no output, so anything we see is on stderr +my $got = runperl (prog => '$h{a}=1; foreach my $k (keys %h) {eval qq{\$k}}', + stderr => 1); + +if ($got eq '') { + print "ok $test\n"; +} else { + print "not ok $test\n"; + _diag ("# Got '$got'\n"); +} +$test++; + +# And a buggy way of fixing #19022 made this fail - $k became undef after the +# eval for a build with copy on write +{ + my %h; + $h{a}=1; + foreach my $k (keys %h) { + if (defined $k and $k eq 'a') { + print "ok $test\n"; + } else { + print "not $test # got ", _q ($k), "\n"; + } + $test++; + + eval "\$k"; + + if (defined $k and $k eq 'a') { + print "ok $test\n"; + } else { + print "not $test # got ", _q ($k), "\n"; + } + $test++; + } +} |