From: Father Chrysostomos <sprout@cpan.org>
Date: Sat, 26 Oct 2013 13:00:59 +0000 (-0700)
Subject: Make PL_DBgv and other db interp vars refcounted
X-Git-Tag: upstream/5.20.0~1456
X-Git-Url: http://review.tizen.org/git/?a=commitdiff_plain;h=8cece9139aefc96dd3920fa7908afea1581f51b7;p=platform%2Fupstream%2Fperl.git

Make PL_DBgv and other db interp vars refcounted

$ PERL5DB=1 perl -de '*DB::DB = sub {} if 0; sub DB::DB{}'
No DB::DB routine defined at -e line 1.

When the ‘if’ gets folded and *DB::DB is freed, it triggers
gv_try_downgrade, causing $DB::{DB} to be deleted and PL_DBgv to point
to a freed SV.  A higher refcount would prevent gv_try_downgrade from
touching it.
---

diff --git a/perl.c b/perl.c
index 1835062..c4726c4 100644
--- a/perl.c
+++ b/perl.c
@@ -959,9 +959,6 @@ perl_destruct(pTHXx)
     PL_stderrgv = NULL;
     PL_last_in_gv = NULL;
     PL_replgv = NULL;
-    PL_DBgv = NULL;
-    PL_DBline = NULL;
-    PL_DBsub = NULL;
     PL_DBsingle = NULL;
     PL_DBtrace = NULL;
     PL_DBsignal = NULL;
@@ -969,6 +966,13 @@ perl_destruct(pTHXx)
     PL_dbargs = NULL;
     PL_debstash = NULL;
 
+    SvREFCNT_dec(PL_DBgv);
+    SvREFCNT_dec(PL_DBline);
+    SvREFCNT_dec(PL_DBsub);
+    PL_DBgv = NULL;
+    PL_DBline = NULL;
+    PL_DBsub = NULL;
+
     SvREFCNT_dec(PL_argvout_stack);
     PL_argvout_stack = NULL;
 
@@ -4043,9 +4047,15 @@ Perl_init_debugger(pTHX)
     PL_curstash = (HV *)SvREFCNT_inc_simple(PL_debstash);
 
     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));
+    PL_DBgv = MUTABLE_GV(
+	SvREFCNT_inc(gv_fetchpvs("DB::DB", GV_ADDMULTI, SVt_PVGV))
+    );
+    PL_DBline = MUTABLE_GV(
+	SvREFCNT_inc(gv_fetchpvs("DB::dbline", GV_ADDMULTI, SVt_PVAV))
+    );
+    PL_DBsub = MUTABLE_GV(SvREFCNT_inc(
+	gv_HVadd(gv_fetchpvs("DB::sub", GV_ADDMULTI, SVt_PVHV))
+    ));
     PL_DBsingle = GvSV((gv_fetchpvs("DB::single", GV_ADDMULTI, SVt_PV)));
     if (!SvIOK(PL_DBsingle))
 	sv_setiv(PL_DBsingle, 0);
diff --git a/sv.c b/sv.c
index 99b1182..f174b18 100644
--- a/sv.c
+++ b/sv.c
@@ -13620,9 +13620,9 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_errgv		= gv_dup(proto_perl->Ierrgv, param);
 
     /* shortcuts to debugging objects */
-    PL_DBgv		= gv_dup(proto_perl->IDBgv, param);
-    PL_DBline		= gv_dup(proto_perl->IDBline, param);
-    PL_DBsub		= gv_dup(proto_perl->IDBsub, param);
+    PL_DBgv		= gv_dup_inc(proto_perl->IDBgv, param);
+    PL_DBline		= gv_dup_inc(proto_perl->IDBline, param);
+    PL_DBsub		= gv_dup_inc(proto_perl->IDBsub, param);
     PL_DBsingle		= sv_dup(proto_perl->IDBsingle, param);
     PL_DBtrace		= sv_dup(proto_perl->IDBtrace, param);
     PL_DBsignal		= sv_dup(proto_perl->IDBsignal, param);
diff --git a/t/run/switchd.t b/t/run/switchd.t
index e66a17f..1b5141c 100644
--- a/t/run/switchd.t
+++ b/t/run/switchd.t
@@ -9,7 +9,7 @@ BEGIN { require "./test.pl"; }
 
 # This test depends on t/lib/Devel/switchd*.pm.
 
-plan(tests => 14);
+plan(tests => 15);
 
 my $r;
 
@@ -147,6 +147,16 @@ like(
   qr/^No DB::DB routine defined/,
   "No crash when &DB::DB exists but isn't actually defined",
 );
+# or seen and defined later
+is(
+  runperl(
+    switches => [ '-Ilib', '-d:nodb' ], # nodb.pm contains *DB::DB...if 0
+    prog     => 'warn; sub DB::DB { print qq-ok\n-; exit }',
+    stderr   => 1,
+  ),
+  "ok\n",
+  "DB::DB works after '*DB::DB if 0'",
+);
 
 # [perl #115742] Recursive DB::DB clobbering its own pad
 like(