diff options
| -rw-r--r-- | embed.fnc | 2 | ||||
| -rw-r--r-- | embed.h | 2 | ||||
| -rw-r--r-- | embedvar.h | 1 | ||||
| -rw-r--r-- | intrpvar.h | 2 | ||||
| -rw-r--r-- | mg.c | 21 | ||||
| -rw-r--r-- | mg_names.c | 1 | ||||
| -rw-r--r-- | mg_raw.h | 2 | ||||
| -rw-r--r-- | mg_vtable.h | 5 | ||||
| -rw-r--r-- | perl.c | 18 | ||||
| -rw-r--r-- | perl.h | 10 | ||||
| -rw-r--r-- | pod/perlguts.pod | 2 | ||||
| -rw-r--r-- | pp_ctl.c | 2 | ||||
| -rw-r--r-- | proto.h | 12 | ||||
| -rw-r--r-- | regen/mg_vtable.pl | 3 | ||||
| -rw-r--r-- | sv.c | 1 | ||||
| -rw-r--r-- | t/run/switchd.t | 3 |
16 files changed, 82 insertions, 5 deletions
@@ -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 @@ -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 */ @@ -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(<)" }, @@ -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] @@ -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; } @@ -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 @@ -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; @@ -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 { @@ -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" ); -} |