[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 PL_DBcontrol array.

16 files changed, 82 insertions, 5 deletions

diff --git a/embed.fnc b/embed.fnc
index 758af030d0..a06de68bfb 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -836,6 +836,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
@@ -859,6 +860,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 4b7cbb176b..91b5bfe2a1 100644
--- a/embed.h
+++ b/embed.h
@@ -1202,6 +1202,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)
@@ -1220,6 +1221,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 adc207d6bd..2659d02c56 100644
--- a/embedvar.h
+++ b/embedvar.h
@@ -43,6 +43,7 @@
 #define PL_AboveLatin1		(vTHX->IAboveLatin1)
 #define PL_Argv			(vTHX->IArgv)
 #define PL_Cmd			(vTHX->ICmd)
+#define PL_DBcontrol		(vTHX->IDBcontrol)
 #define PL_DBcv			(vTHX->IDBcv)
 #define PL_DBgv			(vTHX->IDBgv)
 #define PL_DBline		(vTHX->IDBline)
diff --git a/intrpvar.h b/intrpvar.h
index ee1d3ed523..a5248a8bcc 100644
--- a/intrpvar.h
+++ b/intrpvar.h
@@ -393,6 +393,8 @@ PERLVAR(I, DBtrace,	SV *)		/*  $DB::trace  */
 PERLVAR(I, DBsignal,	SV *)		/*  $DB::signal */
 PERLVAR(I, dbargs,	AV *)		/* args to call listed by caller function */
 
+PERLVARA(I, DBcontrol,    DBVARMG_COUNT, IV) /* IV versions of $DB::single, trace, signal */
+
 /* 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 55663725ad..9653c707e8 100644
--- a/mg.c
+++ b/mg.c
@@ -3403,6 +3403,27 @@ 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;
+
+    assert(mg->mg_private >= DBVARMG_SINGLE && mg->mg_private < DBVARMG_COUNT);
+
+    PL_DBcontrol[mg->mg_private] = SvIV_nomg(sv);
+
+    return 1;
+}
+
+int
+Perl_magic_getdebugvar(pTHX_ SV *sv, MAGIC *mg) {
+    PERL_ARGS_ASSERT_MAGIC_GETDEBUGVAR;
+
+    assert(mg->mg_private >= DBVARMG_SINGLE && mg->mg_private < DBVARMG_COUNT);
+    sv_setiv(sv, PL_DBcontrol[mg->mg_private]);
+
+    return 0;
+}
+
 /*
  * Local variables:
  * c-indentation-style: bsd
diff --git a/mg_names.c b/mg_names.c
index 73dc3f9502..52eed71790 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 f508ad0e57..984f1d7ce5 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 f391713761..104e936cba 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 f11bcb4b95..5acd88368c 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;
@@ -2389,7 +2392,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);
@@ -3957,6 +3960,7 @@ void
 Perl_init_debugger(pTHX)
 {
     HV * const ostash = PL_curstash;
+    MAGIC *mg;
 
     PL_curstash = (HV *)SvREFCNT_inc_simple(PL_debstash);
 
@@ -3973,12 +3977,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 f0f3192d0d..3235476cb7 100644
--- a/perl.h
+++ b/perl.h
@@ -5240,6 +5240,16 @@ typedef enum {
 	(SAWAMPERSAND_LEFT|SAWAMPERSAND_MIDDLE|SAWAMPERSAND_RIGHT)
 #endif
 
+/* Used for debugvar magic */
+#define DBVARMG_SINGLE  0
+#define DBVARMG_TRACE   1
+#define DBVARMG_SIGNAL  2
+#define DBVARMG_COUNT   3
+
+#define PL_DBsingle_iv  (PL_DBcontrol[DBVARMG_SINGLE])
+#define PL_DBtrace_iv   (PL_DBcontrol[DBVARMG_TRACE])
+#define PL_DBsignal_iv  (PL_DBcontrol[DBVARMG_SIGNAL])
+
 /* Various states of the input record separator SV (rs) */
 #define RsSNARF(sv)   (! SvOK(sv))
 #define RsSIMPLE(sv)  (SvOK(sv) && (! SvPOK(sv) || SvCUR(sv)))
diff --git a/pod/perlguts.pod b/pod/perlguts.pod
index 466f96635e..b70ead05e1 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 3d02f3a96a..4f5fd9a038 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1939,7 +1939,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 0a90a04921..51eb005f38 100644
--- a/proto.h
+++ b/proto.h
@@ -2350,6 +2350,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);
@@ -2466,6 +2472,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 0bbfbfdf6d..51c130685b 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 b2dcc91d85..dd0a97e2b4 100644
--- a/sv.c
+++ b/sv.c
@@ -14577,6 +14577,7 @@ 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);
+    Copy(proto_perl->IDBcontrol, PL_DBcontrol, DBVARMG_COUNT, 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 6780df5f65..1f11e8756d 100644
--- a/t/run/switchd.t
+++ b/t/run/switchd.t
@@ -286,8 +286,6 @@ is(
   '-d does not conflict with sort optimisations'
 );
 
-{
-local $TODO = "This crashes";
 is(
   runperl(
    switches => [ '-Ilib', '-d:switchd_empty' ],
@@ -302,4 +300,3 @@ is(
   "debugged\n",
   "\$DB::single set to overload"
 );
-}