Add Perl_init_dbargs(), to set up @DB::args without losing SV references.
authorNicholas Clark <nick@ccl4.org>
Wed, 21 Jul 2010 12:41:44 +0000 (13:41 +0100)
committerNicholas Clark <nick@ccl4.org>
Wed, 21 Jul 2010 12:41:44 +0000 (13:41 +0100)
embed.fnc
embed.h
perl.c
pp_ctl.c
proto.h
t/op/caller.t

index 37c7f2b..751b9aa 100644 (file)
--- 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 (file)
--- a/embed.h
+++ b/embed.h
 #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/perl.c b/perl.c
index 0edad78..d52d79f 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -3773,6 +3773,22 @@ S_forbid_setid(pTHX_ const char flag, const bool suidscript) /* g */
         Perl_croak(aTHX_ "No %s allowed with (suid) fdscript", message);
 }
 
+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)
 {
@@ -3780,9 +3796,8 @@ Perl_init_debugger(pTHX)
     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));
index a93d6dc..57118a4 100644 (file)
--- 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 (file)
--- 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)
index 27a55a8..40782be 100644 (file)
@@ -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 $@;