diff options
| -rw-r--r-- | embed.fnc | 1 | ||||
| -rw-r--r-- | embed.h | 2 | ||||
| -rw-r--r-- | perl.c | 21 | ||||
| -rw-r--r-- | pp_ctl.c | 7 | ||||
| -rw-r--r-- | proto.h | 1 | ||||
| -rw-r--r-- | t/op/caller.t | 43 |
6 files changed, 66 insertions, 9 deletions
@@ -518,6 +518,7 @@ sR |bool |ingroup |Gid_t testgid|bool effective : Used in toke.c p |void |init_argv_symbols|int argc|NN char **argv : Used in mg.c +po |void |init_db_args p |void |init_debugger Ap |void |init_stacks Ap |void |init_tm |NN struct tm *ptm @@ -331,6 +331,8 @@ #endif #ifdef PERL_CORE #define init_argv_symbols Perl_init_argv_symbols +#endif +#ifdef PERL_CORE #define init_debugger Perl_init_debugger #endif #define init_stacks Perl_init_stacks @@ -3774,15 +3774,30 @@ S_forbid_setid(pTHX_ const char flag, const bool suidscript) /* g */ } void +Perl_init_dbargs(pTHX) +{ + AV *const args = PL_dbargs = GvAV(gv_AVadd((gv_fetchpvs("DB::args", + GV_ADDMULTI, + SVt_PVAV)))); + + if (AvREAL(args)) { + /* Someone has already created it. + It might have entries, and if we just turn off AvREAL(), they will + "leak" until global destruction. */ + av_clear(args); + } + AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */ +} + +void Perl_init_debugger(pTHX) { dVAR; HV * const ostash = PL_curstash; PL_curstash = PL_debstash; - PL_dbargs = GvAV(gv_AVadd((gv_fetchpvs("DB::args", GV_ADDMULTI, - SVt_PVAV)))); - AvREAL_off(PL_dbargs); + + Perl_init_dbargs(aTHX); PL_DBgv = gv_fetchpvs("DB::DB", GV_ADDMULTI, SVt_PVGV); PL_DBline = gv_fetchpvs("DB::dbline", GV_ADDMULTI, SVt_PVAV); PL_DBsub = gv_HVadd(gv_fetchpvs("DB::sub", GV_ADDMULTI, SVt_PVHV)); @@ -1791,11 +1791,8 @@ PP(pp_caller) AV * const ary = cx->blk_sub.argarray; const int off = AvARRAY(ary) - AvALLOC(ary); - if (!PL_dbargs) { - PL_dbargs = GvAV(gv_AVadd(gv_fetchpvs("DB::args", GV_ADDMULTI, - SVt_PVAV))); - AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */ - } + if (!PL_dbargs) + Perl_init_dbargs(aTHX); if (AvMAX(PL_dbargs) < AvFILLp(ary) + off) av_extend(PL_dbargs, AvFILLp(ary) + off); @@ -1164,6 +1164,7 @@ PERL_CALLCONV void Perl_init_argv_symbols(pTHX_ int argc, char **argv) #define PERL_ARGS_ASSERT_INIT_ARGV_SYMBOLS \ assert(argv) +PERL_CALLCONV void Perl_init_db_args(pTHX); PERL_CALLCONV void Perl_init_debugger(pTHX); PERL_CALLCONV void Perl_init_stacks(pTHX); PERL_CALLCONV void Perl_init_tm(pTHX_ struct tm *ptm) diff --git a/t/op/caller.t b/t/op/caller.t index 27a55a8312..40782bee70 100644 --- a/t/op/caller.t +++ b/t/op/caller.t @@ -5,7 +5,7 @@ BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; - plan( tests => 78 ); + plan( tests => 80 ); } my @c; @@ -163,6 +163,47 @@ sub hint_fetch { $results[10]->{$key}; } +{ + my $tmpfile = tempfile(); + + open my $fh, '>', $tmpfile or die "open $tmpfile: $!"; + print $fh <<'EOP'; +#!perl -wl +use strict; + +{ + package KAZASH ; + + sub DESTROY { + print "DESTROY"; + } +} + +@DB::args = bless [], 'KAZASH'; + +print $^P; +print scalar @DB::args; + +{ + local $^P = shift; +} + +@DB::args = (); # At this point, the object should be freed. + +print $^P; +print scalar @DB::args; + +# It shouldn't leak. +EOP + + foreach (0, 1) { + my $got = runperl(progfile => $tmpfile, args => [$_]); + $got =~ s/\s+/ /gs; + like($got, qr/\s*0 1 DESTROY 0 0\s*/, + "\@DB::args doesn't leak with \$^P = $_"); + } +} + $::testing_caller = 1; do './op/caller.pl' or die $@; |