In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/067bb83c81c90d49b193f506de7fb39006f8b3c2?hp=710891042a142a482afd4eed1f3b1feb27a9c504>
- Log ----------------------------------------------------------------- commit 067bb83c81c90d49b193f506de7fb39006f8b3c2 Author: Nicholas Clark <[email protected]> Date: Wed Jul 21 13:56:53 2010 +0100 In Carp, minimise the amount of code running in package DB. Use a block to limit it to just the invocation of caller. M lib/Carp.pm commit 5b235299a82969c391c126a8d9a1475362a595a6 Author: Nicholas Clark <[email protected]> Date: Wed Jul 21 13:41:44 2010 +0100 Add Perl_init_dbargs(), to set up @DB::args without losing SV references. M embed.fnc M embed.h M perl.c M pp_ctl.c M proto.h M t/op/caller.t ----------------------------------------------------------------------- Summary of changes: embed.fnc | 1 + embed.h | 2 ++ lib/Carp.pm | 6 ++++-- perl.c | 21 ++++++++++++++++++--- pp_ctl.c | 7 ++----- proto.h | 1 + t/op/caller.t | 43 ++++++++++++++++++++++++++++++++++++++++++- 7 files changed, 70 insertions(+), 11 deletions(-) diff --git a/embed.fnc b/embed.fnc index 37c7f2b..751b9aa 100644 --- a/embed.fnc +++ b/embed.fnc @@ -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 diff --git a/embed.h b/embed.h index fffdede..07aa965 100644 --- a/embed.h +++ b/embed.h @@ -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 diff --git a/lib/Carp.pm b/lib/Carp.pm index a08ff0f..add42d2 100644 --- a/lib/Carp.pm +++ b/lib/Carp.pm @@ -1,6 +1,6 @@ package Carp; -our $VERSION = '1.16'; +our $VERSION = '1.17'; our $MaxEvalLen = 0; our $Verbose = 0; @@ -66,11 +66,13 @@ sub cluck { warn longmess @_ } sub caller_info { my $i = shift(@_) + 1; - package DB; my %call_info; + { + package DB; @call_info{ qw(pack file line sub has_args wantarray evaltext is_require) } = defined &{"CORE::GLOBAL::caller"} ? &{"CORE::GLOBAL::caller"}($i) : caller($i); + } unless (defined $call_info{pack}) { return (); diff --git a/perl.c b/perl.c index 0edad78..d52d79f 100644 --- a/perl.c +++ b/perl.c @@ -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)); diff --git a/pp_ctl.c b/pp_ctl.c index a93d6dc..57118a4 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -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); diff --git a/proto.h b/proto.h index 1fc1180..08cb30b 100644 --- a/proto.h +++ b/proto.h @@ -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 27a55a8..40782be 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 $@; -- Perl5 Master Repository
