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

diff --git a/embed.fnc b/embed.fnc
index 758af03..a06de68 100644 (file)
--- 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 4b7cbb1..91b5bfe 100644 (file)
--- 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 adc207d..2659d02 100644 (file)
--- 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 ee1d3ed..a5248a8 100644 (file)
--- 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 5566372..9653c70 100644 (file)
--- 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 73dc3f9..52eed71 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 f11bcb4..5acd883 100644 (file)
--- 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 f0f3192..3235476 100644 (file)
--- 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 466f966..b70ead0 100644 (file)
--- 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 3d02f3a..4f5fd9a 100644 (file)
--- 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 0a90a04..51eb005 100644 (file)
--- 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 0bbfbfd..51c1306 100644 (file)
--- 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 b2dcc91..dd0a97e 100644 (file)
--- 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 6780df5..1f11e87 100644 (file)
--- 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"
 );
-}