In perl.git, the branch maint-5.12 has been updated <http://perl5.git.perl.org/perl.git/commitdiff/765c7045405cdf0f0fd923088ca05f84574e6b08?hp=66dc6eccbbef5ab6051b190fd068e45d6e503930>
- Log ----------------------------------------------------------------- commit 765c7045405cdf0f0fd923088ca05f84574e6b08 Author: Craig A. Berry <[email protected]> Date: Thu Jul 22 08:27:40 2010 -0500 Looser filename matching for new Carp.t tests. M lib/Carp.t commit 2b8f0c4f5e2bbeae56c0b799abbc7388029a979c Author: Nicholas Clark <[email protected]> Date: Thu Jul 22 09:44:27 2010 +0100 In Carp, if @DB::args still contains our sentinel, reset it. This ensures that nothing outside our routine can unintentionally get the address of our sentinel. M lib/Carp.pm commit 97705941a4f8815e68824b8a3cb68fd91fb7bbc3 Author: Nicholas Clark <[email protected]> Date: Wed Jul 21 20:17:47 2010 +0100 Detect incomplete caller overrides in Carp, and avoid using bogus @DB::args. To get arguments into its backtraces, Carp relies on caller setting @DB::args when called from package DB. @DB::args isn't refcounted (and can't be). Not all overriders of &CORE::GLOBAL::caller set @DB::args properly, with the result that @DB::arg can become "stale", with strange errors, at a distance. However, it is possible to detect that @DB::args has not been updated, and take evasive action. This is preferable to presenting the user (or logfile) with silently wrong backtraces, and much preferable to the occasional "Bizarre copy" exception. M lib/Carp.pm M lib/Carp.t commit b6e29a90fcfda302fee226f69a8a117f83d929ac Author: Nicholas Clark <[email protected]> Date: Wed Jul 21 15:00:03 2010 +0100 Fix error in 5b235299a82969c3, which gcc didn't spot, but g++ did. C, of course, is happy enough without a function prototype. M embed.fnc M proto.h commit 7a42e36bec890c13e188dca1b8fc556937c75ed7 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 b73f93fc6399df69b8dd13b3620ea4ef289b9d5a 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 | 2 ++ embed.h | 2 ++ lib/Carp.pm | 15 ++++++++++++--- lib/Carp.t | 25 +++++++++++++++++++++---- perl.c | 21 ++++++++++++++++++--- pp_ctl.c | 7 ++----- proto.h | 1 + t/op/caller.t | 43 ++++++++++++++++++++++++++++++++++++++++++- 8 files changed, 100 insertions(+), 16 deletions(-) diff --git a/embed.fnc b/embed.fnc index f93d27c..7e00e79 100644 --- a/embed.fnc +++ b/embed.fnc @@ -507,6 +507,8 @@ sR |bool |ingroup |Gid_t testgid|bool effective #endif : Used in toke.c p |void |init_argv_symbols|int argc|NN char **argv +: Used in pp_ctl.c +po |void |init_dbargs : Used in mg.c p |void |init_debugger Ap |void |init_stacks diff --git a/embed.h b/embed.h index 663cb6b..2b80af0 100644 --- a/embed.h +++ b/embed.h @@ -328,6 +328,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..b2948ea 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,14 @@ sub cluck { warn longmess @_ } sub caller_info { my $i = shift(@_) + 1; - package DB; my %call_info; + { + package DB; + @args = \$i; # A sentinal, which no-one else has the address of @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 (); @@ -78,7 +81,13 @@ sub caller_info { my $sub_name = Carp::get_subname(\%call_info); if ($call_info{has_args}) { - my @args = map {Carp::format_arg($_)} @DB::args; + my @args; + if (@DB::args == 1 && ref $DB::args[0] eq ref \$i && $DB::args[0] == \$i) { + @DB::args = (); # Don't let anyone see the address of $i + @args = "** Incomplete caller override detected; \...@db::args were not set **"; + } else { + @args = map {Carp::format_arg($_)} @DB::args; + } if ($MaxArgNums and @args > $MaxArgNums) { # More than we want to show? $#args = $MaxArgNums; push @args, '...'; diff --git a/lib/Carp.t b/lib/Carp.t index 1eee4c4..b383ce3 100644 --- a/lib/Carp.t +++ b/lib/Carp.t @@ -11,7 +11,7 @@ my $Is_VMS = $^O eq 'VMS'; use Carp qw(carp cluck croak confess); -plan tests => 39; +plan tests => 49; ok 1; @@ -270,20 +270,37 @@ cluck_undef (0, "undef", 2, undef, 4); # check that Carp respects CORE::GLOBAL::caller override after Carp # has been compiled -{ +for my $proper_job (0, 1) { + print '# ', ($proper_job ? '' : 'Not '), "setting \...@db::args in caller override\n"; my $accum = ''; local *CORE::GLOBAL::caller = sub { local *__ANON__="fakecaller"; my @c=CORE::caller(@_); $c[0] ||= 'undef'; $accum .= "@c[0..3]\n"; - return CORE::caller(($_[0]||0)+1); + if ($proper_job && CORE::caller() eq 'DB') { + package DB; + return CORE::caller(($_[0]||0)+1); + } else { + return CORE::caller(($_[0]||0)+1); + } }; eval "scalar caller()"; like( $accum, qr/main::fakecaller/, "test CORE::GLOBAL::caller override in eval"); $accum = ''; - A::long(); + my $got = A::long(42); like( $accum, qr/main::fakecaller/, "test CORE::GLOBAL::caller override in Carp"); + my $package = 'A'; + my $warning = $proper_job ? '' + : "\Q** Incomplete caller override detected; \...@db::args were not set **\E"; + for (0..2) { + my $previous_package = $package; + ++$package; + like( $got, qr/${package}::long\($warning\) called at $previous_package line 7/, "Correct arguments for $package" ); + } + my $arg = $proper_job ? 42 : $warning; + like( $got, qr!A::long\($arg\) called at.+\b(?i:carp\.t) line \d+!, + 'Correct arguments for A' ); } # line 1 "A" diff --git a/perl.c b/perl.c index dfb549d..05cea40 100644 --- a/perl.c +++ b/perl.c @@ -3767,15 +3767,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 a1784d1..5ab6044 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -1799,11 +1799,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 979076f..3306ab0 100644 --- a/proto.h +++ b/proto.h @@ -1121,6 +1121,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_dbargs(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 67992f1..49296a8 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
