From @tonycoz

0002-perl-122445-use-magic-on-DB-single-etc-to-avoid-over.patch

From 8e1d231cb12e865e16527390965136f0d2213bb8 Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Thu, 14 Aug 2014 11:19:22 +1000
Subject: [perl #122445] use magic on $DB::single etc to avoid overload issues

This prevents perl recursing infinitely when an overloaded object is
assigned to $DB::single, $DB::trace or $DB::signal

This is done by referencing their values as IVs instead of as SVs in
dbstate, and by adding magic to those variables so that assignments to
the scalars update the _iv variables.
---
 embed.fnc          |    2 ++
 embed.h            |    2 ++
 embedvar.h         |    3 +++
 intrpvar.h         |    4 ++++
 mg.c               |   48 ++++++++++++++++++++++++++++++++++++++++++++++++
 mg_names.c         |    1 +
 mg_raw.h           |    2 ++
 mg_vtable.h        |    5 +++++
 perl.c             |   18 +++++++++++++++++-
 perl.h             |   10 ++++++++++
 pod/perlguts.pod   |    2 ++
 pp_ctl.c           |    2 +-
 proto.h            |   12 ++++++++++++
 regen/mg_vtable.pl |    3 +++
 sv.c               |    3 +++
 t/run/switchd.t    |    3 ---
 16 files changed, 115 insertions(+), 5 deletions(-)

diff --git a/embed.fnc b/embed.fnc
index b70404d..97e31d4 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -823,6 +823,7 @@ p	|int	|magic_freeovrld|NN SV* sv|NN MAGIC* mg
 p	|int	|magic_get	|NN SV* sv|NN MAGIC* mg
 p	|int	|magic_getarylen|NN SV* sv|NN const MAGIC* mg
 p	|int	|magic_getdefelem|NN SV* sv|NN MAGIC* mg
+p	|int	|magic_getdebugvar|NN SV* sv|NN MAGIC* mg
 p	|int	|magic_getnkeys	|NN SV* sv|NN MAGIC* mg
 p	|int	|magic_getpack	|NN SV* sv|NN MAGIC* mg
 p	|int	|magic_getpos	|NN SV* sv|NN MAGIC* mg
@@ -846,6 +847,7 @@ p	|int	|magic_setarylen|NN SV* sv|NN MAGIC* mg
 p	|int	|magic_cleararylen_p|NN SV* sv|NN MAGIC* mg
 p	|int	|magic_freearylen_p|NN SV* sv|NN MAGIC* mg
 p	|int	|magic_setdbline|NN SV* sv|NN MAGIC* mg
+p	|int	|magic_setdebugvar|NN SV* sv|NN MAGIC* mg
 p	|int	|magic_setdefelem|NN SV* sv|NN MAGIC* mg
 p	|int	|magic_setenv	|NN SV* sv|NN MAGIC* mg
 dp	|int	|magic_sethint	|NN SV* sv|NN MAGIC* mg
diff --git a/embed.h b/embed.h
index 3962901..5b1578f 100644
--- a/embed.h
+++ b/embed.h
@@ -1184,6 +1184,7 @@
 #define magic_freeovrld(a,b)	Perl_magic_freeovrld(aTHX_ a,b)
 #define magic_get(a,b)		Perl_magic_get(aTHX_ a,b)
 #define magic_getarylen(a,b)	Perl_magic_getarylen(aTHX_ a,b)
+#define magic_getdebugvar(a,b)	Perl_magic_getdebugvar(aTHX_ a,b)
 #define magic_getdefelem(a,b)	Perl_magic_getdefelem(aTHX_ a,b)
 #define magic_getnkeys(a,b)	Perl_magic_getnkeys(aTHX_ a,b)
 #define magic_getpack(a,b)	Perl_magic_getpack(aTHX_ a,b)
@@ -1202,6 +1203,7 @@
 #define magic_set_all_env(a,b)	Perl_magic_set_all_env(aTHX_ a,b)
 #define magic_setarylen(a,b)	Perl_magic_setarylen(aTHX_ a,b)
 #define magic_setdbline(a,b)	Perl_magic_setdbline(aTHX_ a,b)
+#define magic_setdebugvar(a,b)	Perl_magic_setdebugvar(aTHX_ a,b)
 #define magic_setdefelem(a,b)	Perl_magic_setdefelem(aTHX_ a,b)
 #define magic_setenv(a,b)	Perl_magic_setenv(aTHX_ a,b)
 #define magic_sethint(a,b)	Perl_magic_sethint(aTHX_ a,b)
diff --git a/embedvar.h b/embedvar.h
index 454c1ee..a6aee7d 100644
--- a/embedvar.h
+++ b/embedvar.h
@@ -47,9 +47,12 @@
 #define PL_DBgv			(vTHX->IDBgv)
 #define PL_DBline		(vTHX->IDBline)
 #define PL_DBsignal		(vTHX->IDBsignal)
+#define PL_DBsignal_iv		(vTHX->IDBsignal_iv)
 #define PL_DBsingle		(vTHX->IDBsingle)
+#define PL_DBsingle_iv		(vTHX->IDBsingle_iv)
 #define PL_DBsub		(vTHX->IDBsub)
 #define PL_DBtrace		(vTHX->IDBtrace)
+#define PL_DBtrace_iv		(vTHX->IDBtrace_iv)
 #define PL_Dir			(vTHX->IDir)
 #define PL_Env			(vTHX->IEnv)
 #define PL_HasMultiCharFold	(vTHX->IHasMultiCharFold)
diff --git a/intrpvar.h b/intrpvar.h
index 9dd4e16..a8fa1ef 100644
--- a/intrpvar.h
+++ b/intrpvar.h
@@ -390,6 +390,10 @@ PERLVAR(I, DBtrace,	SV *)		/*  $DB::trace  */
 PERLVAR(I, DBsignal,	SV *)		/*  $DB::signal */
 PERLVAR(I, dbargs,	AV *)		/* args to call listed by caller function */
 
+PERLVAR(I, DBsingle_iv, IV)
+PERLVAR(I, DBtrace_iv,  IV)
+PERLVAR(I, DBsignal_iv, IV)
+
 /* symbol tables */
 PERLVAR(I, debstash,	HV *)		/* symbol table for perldb package */
 PERLVAR(I, globalstash,	HV *)		/* global keyword overrides imported here */
diff --git a/mg.c b/mg.c
index e1fc578..82eae84 100644
--- a/mg.c
+++ b/mg.c
@@ -3397,6 +3397,54 @@ Perl_magic_copycallchecker(pTHX_ SV *sv, MAGIC *mg, SV *nsv,
     return 1;
 }
 
+int
+Perl_magic_setdebugvar(pTHX_ SV *sv, MAGIC *mg) {
+    PERL_ARGS_ASSERT_MAGIC_SETDEBUGVAR;
+
+    switch (mg->mg_private) {
+    case DBVARMG_SINGLE:
+        PL_DBsingle_iv = SvIV_nomg(sv);
+        break;
+
+    case DBVARMG_TRACE:
+        PL_DBtrace_iv = SvIV_nomg(sv);
+        break;
+
+    case DBVARMG_SIGNAL:
+        PL_DBsignal_iv = SvIV_nomg(sv);
+        break;
+
+    default:
+        NOT_REACHED;
+    }
+
+    return 1;
+}
+
+int
+Perl_magic_getdebugvar(pTHX_ SV *sv, MAGIC *mg) {
+    PERL_ARGS_ASSERT_MAGIC_GETDEBUGVAR;
+
+    switch (mg->mg_private) {
+    case DBVARMG_SINGLE:
+        sv_setiv(sv, PL_DBsingle_iv);
+        break;
+
+    case DBVARMG_TRACE:
+        sv_setiv(sv, PL_DBtrace_iv);
+        break;
+
+    case DBVARMG_SIGNAL:
+        sv_setiv(sv, PL_DBsignal_iv);
+        break;
+
+    default:
+        NOT_REACHED;
+    }
+
+    return 0;
+}
+
 /*
  * Local variables:
  * c-indentation-style: bsd
diff --git a/mg_names.c b/mg_names.c
index 73dc3f9..52eed71 100644
--- a/mg_names.c
+++ b/mg_names.c
@@ -10,6 +10,7 @@
 	{ PERL_MAGIC_arylen,         "arylen(#)" },
 	{ PERL_MAGIC_rhash,          "rhash(%)" },
 	{ PERL_MAGIC_proto,          "proto(&)" },
+	{ PERL_MAGIC_debugvar,       "debugvar(*)" },
 	{ PERL_MAGIC_pos,            "pos(.)" },
 	{ PERL_MAGIC_symtab,         "symtab(:)" },
 	{ PERL_MAGIC_backref,        "backref(<)" },
diff --git a/mg_raw.h b/mg_raw.h
index f508ad0..984f1d7 100644
--- a/mg_raw.h
+++ b/mg_raw.h
@@ -14,6 +14,8 @@
       "/* rhash '%' extra data for restricted hashes */" },
     { '&', "magic_vtable_max",
       "/* proto '&' my sub prototype CV */" },
+    { '*', "want_vtbl_debugvar",
+      "/* debugvar '*' $DB::single, signal, trace vars */" },
     { '.', "want_vtbl_pos | PERL_MAGIC_VALUE_MAGIC",
       "/* pos '.' pos() lvalue */" },
     { ':', "magic_vtable_max | PERL_MAGIC_VALUE_MAGIC",
diff --git a/mg_vtable.h b/mg_vtable.h
index f391713..104e936 100644
--- a/mg_vtable.h
+++ b/mg_vtable.h
@@ -16,6 +16,7 @@
 #define PERL_MAGIC_arylen         '#' /* Array length ($#ary) */
 #define PERL_MAGIC_rhash          '%' /* extra data for restricted hashes */
 #define PERL_MAGIC_proto          '&' /* my sub prototype CV */
+#define PERL_MAGIC_debugvar       '*' /* $DB::single, signal, trace vars */
 #define PERL_MAGIC_pos            '.' /* pos() lvalue */
 #define PERL_MAGIC_symtab         ':' /* extra data for symbol tables */
 #define PERL_MAGIC_backref        '<' /* for weak ref data */
@@ -64,6 +65,7 @@ enum {		/* pass one of these to get_vtbl */
     want_vtbl_checkcall,
     want_vtbl_collxfrm,
     want_vtbl_dbline,
+    want_vtbl_debugvar,
     want_vtbl_defelem,
     want_vtbl_env,
     want_vtbl_envelem,
@@ -98,6 +100,7 @@ EXTCONST char * const PL_magic_vtable_names[magic_vtable_max] = {
     "checkcall",
     "collxfrm",
     "dbline",
+    "debugvar",
     "defelem",
     "env",
     "envelem",
@@ -155,6 +158,7 @@ EXT_MGVTBL PL_magic_vtables[magic_vtable_max] = {
   { 0, 0, 0, 0, 0, 0, 0, 0 },
 #endif
   { 0, Perl_magic_setdbline, 0, 0, 0, 0, 0, 0 },
+  { Perl_magic_getdebugvar, Perl_magic_setdebugvar, 0, 0, 0, 0, 0, 0 },
   { Perl_magic_getdefelem, Perl_magic_setdefelem, 0, 0, 0, 0, 0, 0 },
   { 0, Perl_magic_set_all_env, 0, Perl_magic_clear_all_env, 0, 0, 0, 0 },
   { 0, Perl_magic_setenv, 0, Perl_magic_clearenv, 0, 0, 0, 0 },
@@ -197,6 +201,7 @@ EXT_MGVTBL PL_magic_vtables[magic_vtable_max];
 #define PL_vtbl_checkcall PL_magic_vtables[want_vtbl_checkcall]
 #define PL_vtbl_collxfrm PL_magic_vtables[want_vtbl_collxfrm]
 #define PL_vtbl_dbline PL_magic_vtables[want_vtbl_dbline]
+#define PL_vtbl_debugvar PL_magic_vtables[want_vtbl_debugvar]
 #define PL_vtbl_defelem PL_magic_vtables[want_vtbl_defelem]
 #define PL_vtbl_env PL_magic_vtables[want_vtbl_env]
 #define PL_vtbl_envelem PL_magic_vtables[want_vtbl_envelem]
diff --git a/perl.c b/perl.c
index e84f1d5..cb14726 100644
--- a/perl.c
+++ b/perl.c
@@ -968,6 +968,9 @@ perl_destruct(pTHXx)
     PL_DBsingle = NULL;
     PL_DBtrace = NULL;
     PL_DBsignal = NULL;
+    PL_DBsingle_iv = 0;
+    PL_DBtrace_iv = 0;
+    PL_DBsignal_iv = 0;
     PL_DBcv = NULL;
     PL_dbargs = NULL;
     PL_debstash = NULL;
@@ -2386,7 +2389,7 @@ S_run_body(pTHX_ I32 oldscope)
 	    my_exit(0);
 	}
 	if (PERLDB_SINGLE && PL_DBsingle)
-	    sv_setiv(PL_DBsingle, 1);
+            PL_DBsingle_iv = 1;
 	if (PL_initav) {
 	    PERL_SET_PHASE(PERL_PHASE_INIT);
 	    call_list(oldscope, PL_initav);
@@ -3959,6 +3962,7 @@ void
 Perl_init_debugger(pTHX)
 {
     HV * const ostash = PL_curstash;
+    MAGIC *mg;
 
     PL_curstash = (HV *)SvREFCNT_inc_simple(PL_debstash);
 
@@ -3975,12 +3979,24 @@ Perl_init_debugger(pTHX)
     PL_DBsingle = GvSV((gv_fetchpvs("DB::single", GV_ADDMULTI, SVt_PV)));
     if (!SvIOK(PL_DBsingle))
 	sv_setiv(PL_DBsingle, 0);
+    mg = sv_magicext(PL_DBsingle, NULL, PERL_MAGIC_debugvar, &PL_vtbl_debugvar, 0, 0);
+    mg->mg_private = DBVARMG_SINGLE;
+    SvSETMAGIC(PL_DBsingle);
+
     PL_DBtrace = GvSV((gv_fetchpvs("DB::trace", GV_ADDMULTI, SVt_PV)));
     if (!SvIOK(PL_DBtrace))
 	sv_setiv(PL_DBtrace, 0);
+    mg = sv_magicext(PL_DBtrace, NULL, PERL_MAGIC_debugvar, &PL_vtbl_debugvar, 0, 0);
+    mg->mg_private = DBVARMG_TRACE;
+    SvSETMAGIC(PL_DBtrace);
+
     PL_DBsignal = GvSV((gv_fetchpvs("DB::signal", GV_ADDMULTI, SVt_PV)));
     if (!SvIOK(PL_DBsignal))
 	sv_setiv(PL_DBsignal, 0);
+    mg = sv_magicext(PL_DBsignal, NULL, PERL_MAGIC_debugvar, &PL_vtbl_debugvar, 0, 0);
+    mg->mg_private = DBVARMG_SIGNAL;
+    SvSETMAGIC(PL_DBsignal);
+
     SvREFCNT_dec(PL_curstash);
     PL_curstash = ostash;
 }
diff --git a/perl.h b/perl.h
index d03c0e8..110ed55 100644
--- a/perl.h
+++ b/perl.h
@@ -5924,6 +5924,16 @@ extern void moncontrol(int);
 #define PERL_PV_PRETTY_DUMP  PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_QUOTE
 #define PERL_PV_PRETTY_REGPROP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_LTGT|PERL_PV_ESCAPE_RE|PERL_PV_ESCAPE_NONASCII
 
+#ifdef PERL_CORE
+
+/* Used for debugvar magic */
+
+#define DBVARMG_SINGLE	0
+#define DBVARMG_TRACE	1
+#define DBVARMG_SIGNAL	2
+
+#endif
+
 /*
 
    (KEEP THIS LAST IN perl.h!)
diff --git a/pod/perlguts.pod b/pod/perlguts.pod
index bcd2672..fbfa9cb 100644
--- a/pod/perlguts.pod
+++ b/pod/perlguts.pod
@@ -1169,6 +1169,8 @@ will be lost.
  %  PERL_MAGIC_rhash          (none)         extra data for restricted
                                              hashes
  &  PERL_MAGIC_proto          (none)         my sub prototype CV
+ *  PERL_MAGIC_debugvar       vtbl_debugvar  $DB::single, signal, trace
+                                             vars
  .  PERL_MAGIC_pos            vtbl_pos       pos() lvalue
  :  PERL_MAGIC_symtab         (none)         extra data for symbol
                                              tables
diff --git a/pp_ctl.c b/pp_ctl.c
index 5e671ee..aca051e 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1943,7 +1943,7 @@ PP(pp_dbstate)
     PERL_ASYNC_CHECK();
 
     if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
-	    || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
+	    || PL_DBsingle_iv || PL_DBsignal_iv || PL_DBtrace_iv)
     {
 	dSP;
 	PERL_CONTEXT *cx;
diff --git a/proto.h b/proto.h
index 1e42903..5359c92 100644
--- a/proto.h
+++ b/proto.h
@@ -2316,6 +2316,12 @@ PERL_CALLCONV int	Perl_magic_getarylen(pTHX_ SV* sv, const MAGIC* mg)
 #define PERL_ARGS_ASSERT_MAGIC_GETARYLEN	\
 	assert(sv); assert(mg)
 
+PERL_CALLCONV int	Perl_magic_getdebugvar(pTHX_ SV* sv, MAGIC* mg)
+			__attribute__nonnull__(pTHX_1)
+			__attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MAGIC_GETDEBUGVAR	\
+	assert(sv); assert(mg)
+
 PERL_CALLCONV int	Perl_magic_getdefelem(pTHX_ SV* sv, MAGIC* mg)
 			__attribute__nonnull__(pTHX_1)
 			__attribute__nonnull__(pTHX_2);
@@ -2432,6 +2438,12 @@ PERL_CALLCONV int	Perl_magic_setdbline(pTHX_ SV* sv, MAGIC* mg)
 #define PERL_ARGS_ASSERT_MAGIC_SETDBLINE	\
 	assert(sv); assert(mg)
 
+PERL_CALLCONV int	Perl_magic_setdebugvar(pTHX_ SV* sv, MAGIC* mg)
+			__attribute__nonnull__(pTHX_1)
+			__attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MAGIC_SETDEBUGVAR	\
+	assert(sv); assert(mg)
+
 PERL_CALLCONV int	Perl_magic_setdefelem(pTHX_ SV* sv, MAGIC* mg)
 			__attribute__nonnull__(pTHX_1)
 			__attribute__nonnull__(pTHX_2);
diff --git a/regen/mg_vtable.pl b/regen/mg_vtable.pl
index 0bbfbfd..51c1306 100644
--- a/regen/mg_vtable.pl
+++ b/regen/mg_vtable.pl
@@ -108,6 +108,8 @@ my %mg =
      ext => { char => '~', desc => 'Available for use by extensions' },
      checkcall => { char => ']', value_magic => 1, vtable => 'checkcall',
 		    desc => 'inlining/mutation of call to this CV'},
+     debugvar => { char => '*', desc => '$DB::single, signal, trace vars',
+		   vtable => 'debugvar' },
 );
 
 # These have a subtly different "namespace" from the magic types.
@@ -144,6 +146,7 @@ my %sig =
      'hintselem' => {set => 'sethint', clear => 'clearhint'},
      'hints' => {clear => 'clearhints'},
      'checkcall' => {copy => 'copycallchecker'},
+     'debugvar' => { set => 'setdebugvar', get => 'getdebugvar' },
 );
 
 my ($vt, $raw, $names) = map {
diff --git a/sv.c b/sv.c
index afd4376..a7a41dd 100644
--- a/sv.c
+++ b/sv.c
@@ -13819,6 +13819,9 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_DBsingle		= sv_dup(proto_perl->IDBsingle, param);
     PL_DBtrace		= sv_dup(proto_perl->IDBtrace, param);
     PL_DBsignal		= sv_dup(proto_perl->IDBsignal, param);
+    PL_DBsingle_iv	= proto_perl->IDBsingle_iv;
+    PL_DBtrace_iv	= proto_perl->IDBtrace_iv;
+    PL_DBsignal_iv	= proto_perl->IDBsignal_iv;
 
     /* symbol tables */
     PL_defstash		= hv_dup_inc(proto_perl->Idefstash, param);
diff --git a/t/run/switchd.t b/t/run/switchd.t
index 4958ce7..ceabbfe 100644
--- a/t/run/switchd.t
+++ b/t/run/switchd.t
@@ -276,8 +276,6 @@ is(
   'UTF8 length caches on $DB::sub are flushed'
 );
 
-{
-local $TODO = "This crashes";
 is(
   runperl(
    switches => [ '-Ilib', '-d:switchd_empty' ],
@@ -292,4 +290,3 @@ is(
   "debugged\n",
   "\$DB::single set to overload"
 );
-}
-- 
1.7.10.4

Segmentation fault while debugging programs using bignum in 5.18.2 #14013

Description

Metadata

Metadata

Assignees

Labels

Type

Projects

Milestone

Relationships

Development

Issue actions