Skip Menu |
Report information
Id: 122445
Status: resolved
Priority: 0/
Queue: perl5

Owner: Nobody
Requestors: chr.stahlhut [at] gmail.com
Cc:
AdminCc:

Operating System: (no value)
PatchStatus: (no value)
Severity: low
Type: unknown
Perl Version: (no value)
Fixed In: (no value)



Subject: Segmentation fault while debugging programs using bignum in 5.18.2
Download (untitled) / with headers
text/plain 6.1k
Hi! Trying to debug the attached program via 'perl -d ./debug-me.pl' produces a segmentation fault for me. This seems to be related to the exact position of the breakpoint ('$DB::single=2') set in the code. Summary of my perl5 (revision 5 version 18 subversion 2) configuration: Platform: osname=linux, osvers=3.12.21-gentoo-r1, archname=x86_64-linux-thread-multi uname='linux azmodan 3.12.21-gentoo-r1 #1 smp fri jun 6 23:37:17 cest 2014 x86_64 intel(r) core(tm) i5-3570k cpu @ 3.40ghz genuineintel gnulinux ' config_args='-des -Duseshrplib -Darchname=x86_64-linux-thread -Dcc=x86_64-pc-linux-gnu-gcc -Doptimize=-O2 -march=native -pipe -Dldflags=-Wl,-O1 -Wl,--as-needed -Dprefix=/usr -Dinstallprefix=/usr -Dsiteprefix=/usr/local -Dvendorprefix=/usr -Dscriptdir=/usr/bin -Dprivlib=/usr/lib64/perl5/5.18.2 -Darchlib=/usr/lib64/perl5/5.18.2/x86_64-linux-thread-multi -Dsitelib=/usr/local/lib64/perl5/5.18.2 -Dsitearch=/usr/local/lib64/perl5/5.18.2/x86_64-linux-thread-multi -Dvendorlib=/usr/lib64/perl5/vendor_perl/5.18.2 -Dvendorarch=/usr/lib64/perl5/vendor_perl/5.18.2/x86_64-linux-thread-multi -Dman1dir=/usr/share/man/man1 -Dman3dir=/usr/share/man/man3 -Dsiteman1dir=/usr/local/man/man1 -Dsiteman3dir=/usr/local/man/man3 -Dvendorman1dir=/usr/share/man/man1 -Dvendorman3dir=/usr/share/man/man3 -Dman1ext=1 -Dman3ext=3pm -Dlibperl=libperl.so.5.18.2 -Dlocincpth=/usr/include -Dglibpth=/lib64 /usr/lib64 -Duselargefiles -Dd_semctl_semun -Dcf_by=Gentoo -Dmyhostname=localhost -Dperladmin=root@localhost -Dinstallusrbinperl=n -Ud_csh -Uusenm -Di_ndbm -Di_gdbm -Di_db -Dusethreads -DDEBUGGING=none -Dinc_version_list=5.18.0/x86_64-linux-thread-multi 5.18.0 5.18.1/x86_64-linux-thread-multi 5.18.1 -Dlibpth=/usr/local/lib64 /lib64 /usr/lib64 -Dnoextensions=ODBM_File' hint=recommended, useposix=true, d_sigaction=define useithreads=define, usemultiplicity=define useperlio=define, d_sfio=undef, uselargefiles=define, usesocks=undef use64bitint=define, use64bitall=define, uselongdouble=undef usemymalloc=n, bincompat5005=undef Compiler: cc='x86_64-pc-linux-gnu-gcc', ccflags ='-D_REENTRANT -D_GNU_SOURCE -fno-strict-aliasing -pipe -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64', optimize='-O2 -march=native -pipe', cppflags='-D_REENTRANT -D_GNU_SOURCE -fno-strict-aliasing -pipe' ccversion='', gccversion='4.7.3', gccosandvers='' intsize=4, longsize=8, ptrsize=8, doublesize=8, byteorder=12345678 d_longlong=define, longlongsize=8, d_longdbl=define, longdblsize=16 ivtype='long', ivsize=8, nvtype='double', nvsize=8, Off_t='off_t', lseeksize=8 alignbytes=8, prototype=define Linker and Libraries: ld='x86_64-pc-linux-gnu-gcc', ldflags ='-Wl,-O1 -Wl,--as-needed' libpth=/usr/local/lib64 /lib64 /usr/lib64 libs=-lnsl -lgdbm -ldb -ldl -lm -lcrypt -lutil -lpthread -lc -lgdbm_compat perllibs=-lnsl -ldl -lm -lcrypt -lutil -lpthread -lc libc=/lib/libc-2.19.so, so=so, useshrplib=true, libperl=libperl.so.5.18.2 gnulibc_version='2.19' Dynamic Linking: dlsrc=dl_dlopen.xs, dlext=so, d_dlsymun=undef, ccdlflags='-Wl,-E' cccdlflags='-fPIC', lddlflags='-shared -O2 -march=native -pipe -Wl,-O1 -Wl,--as-needed' Characteristics of this binary (from libperl): Compile-time options: HAS_TIMES MULTIPLICITY PERLIO_LAYERS PERL_DONT_CREATE_GVSV PERL_HASH_FUNC_ONE_AT_A_TIME_HARD PERL_IMPLICIT_CONTEXT PERL_MALLOC_WRAP PERL_PRESERVE_IVUV PERL_SAWAMPERSAND USE_64_BIT_ALL USE_64_BIT_INT USE_ITHREADS USE_LARGE_FILES USE_LOCALE USE_LOCALE_COLLATE USE_LOCALE_CTYPE USE_LOCALE_NUMERIC USE_PERLIO USE_PERL_ATOF USE_REENTRANT_API Locally applied patches: gentoo/EUMM-RUNPATH - https://bugs.gentoo.org/105054 cpan/ExtUtils-MakeMaker: drop $PORTAGE_TMPDIR from LD_RUN_PATH gentoo/EUMM_delete_packlist - Don't install .packlist or perllocal.pod for perl or vendor gentoo/config_over - Remove -rpath and append LDFLAGS to lddlflags gentoo/cpan_definstalldirs - Provide a sensible INSTALLDIRS default for modules installed from CPAN. gentoo/cpanplus_definstalldirs - Configure CPANPLUS to use the site directories by default. gentoo/create_libperl_soname - https://bugs.gentoo.org/286840 Set libperl soname gentoo/drop_fstack_protector - https://bugs.gentoo.org/348557 Don't force -fstack-protector on everyone. gentoo/enc2xs - Tweak enc2xs to follow symlinks and ignore missing @INC directories. gentoo/mod_paths - Add /etc/perl to @INC gentoo/patchlevel - List packaged patches for perl-5.18.2-r1(#2) in patchlevel.h gentoo/aix_soname - aix gcc detection and shared library soname support gentoo/opensolars_headers - Add headers for opensolaris gentoo/cleanup-paths - Cleanup PATH and shrpenv gentoo/usr_local - Remove /usr/local paths gentoo/hints_hpux - Fix hpux hints gentoo/darwin-cc-ld - https://bugs.gentoo.org/297751 darwin: Use $CC to link gentoo/interix - Fix interix hints fixes/net_smtp_docs - [rt.cpan.org #36038] Document the Net::SMTP 'Port' option debian/cpan-missing-site-dirs - Fix CPAN::FirstTime defaults with nonexisting site dirs if a parent is writable fixes/memoize_storable_nstore - [rt.cpan.org #77790] Memoize::Storable: respect 'nstore' option not respected fixes/net_ftp_failed_command - [rt.cpan.org #37700] Net::FTP: cope gracefully with a failed command fixes/perlbug-patchlist - [3541c11] [perl #118433] Make perlbug look up the list of local patches at run time fixes/module_metadata_taint_fix - [bff978f] [rt.cpan.org #88576] untaint version, if needed, in Module::Metadata fixes/IPC-SysV-spelling - [rt.cpan.org #86736] Fix spelling of IPC_CREAT in IPC-SysV documentation fixes/freemint - Built under linux Compiled at Jul 30 2014 12:58:24 @INC: /etc/perl /usr/local/lib64/perl5/5.18.2/x86_64-linux-thread-multi /usr/local/lib64/perl5/5.18.2 /usr/lib64/perl5/vendor_perl/5.18.2/x86_64-linux-thread-multi /usr/lib64/perl5/vendor_perl/5.18.2 /usr/local/lib64/perl5 /usr/lib64/perl5/vendor_perl /usr/lib64/perl5/5.18.2/x86_64-linux-thread-multi /usr/lib64/perl5/5.18.2 .
Subject: debug-me.pl
Download debug-me.pl
text/x-perl 84b
#!/usr/bin/perl use bignum; $DB::single=2; print "I want to be debugged. :-(\n";
RT-Send-CC: perl5-porters [...] perl.org
Download (untitled) / with headers
text/plain 552b
On Wed Jul 30 14:51:25 2014, chr.stahlhut@gmail.com wrote: Show quoted text
> Hi! > > Trying to debug the attached program via 'perl -d ./debug-me.pl' > produces a segmentation fault for me.
To be more precise, this happens: christian@azmodan ~ $ perl -d ./debug-me.pl Loading DB routines from perl5db.pl version 1.39_10 Editor support available. Enter h or 'h h' for help, or 'man perldebug' for more help. main::(./debug-me.pl:4): $DB::single=2; DB<1> c Segmentation fault
RT-Send-CC: perl5-porters [...] perl.org
Download (untitled) / with headers
text/plain 1.1k
On Wed Jul 30 14:55:21 2014, chr.stahlhut@gmail.com wrote: Show quoted text
> On Wed Jul 30 14:51:25 2014, chr.stahlhut@gmail.com wrote:
> > Hi! > > > > Trying to debug the attached program via 'perl -d ./debug-me.pl' > > produces a segmentation fault for me.
> > To be more precise, this happens: > > christian@azmodan ~ $ perl -d ./debug-me.pl > > Loading DB routines from perl5db.pl version 1.39_10 > Editor support available. > > Enter h or 'h h' for help, or 'man perldebug' for more help. > > main::(./debug-me.pl:4): $DB::single=2; > DB<1> > c > Segmentation fault
I can reproduce this with the perls available via perlbrew at least as far back as 5.10.1: ##### [p5p] 38 $ perlbrew use perl-5.10.1 [p5p] 39 $ perl -v This is perl, v5.10.1 (*) built for x86_64-linux Copyright 1987-2009, Larry Wall [snip] [p5p] 40 $ perl -d 122445-debug-me.pl Loading DB routines from perl5db.pl version 1.32 Editor support available. Enter h or `h h' for help, or `man perldebug' for more help. main::(122445-debug-me.pl:4): $DB::single=2; DB<1> c Segmentation fault (core dumped) #####
RT-Send-CC: perl5-porters [...] perl.org
Download (untitled) / with headers
text/plain 1.4k
On Wed Jul 30 14:55:21 2014, chr.stahlhut@gmail.com wrote: Show quoted text
> On Wed Jul 30 14:51:25 2014, chr.stahlhut@gmail.com wrote:
> > Hi! > > > > Trying to debug the attached program via 'perl -d ./debug-me.pl' > > produces a segmentation fault for me.
> > To be more precise, this happens: > > christian@azmodan ~ $ perl -d ./debug-me.pl > > Loading DB routines from perl5db.pl version 1.39_10 > Editor support available. > > Enter h or 'h h' for help, or 'man perldebug' for more help. > > main::(./debug-me.pl:4): $DB::single=2; > DB<1> > c > Segmentation fault
Is it possible that you are using $DB::single in a manner for which is not intended? In the documenation to DB.pm, I read: ##### Global Variables The following "public" global names can be read by clients of this API. Beware that these should be considered "readonly". [snip] $DB::single Single-step flag. Will be true if the API will stop at the next statement. ##### You are trying to assign to $DB::single, which seems to violate the "readonly" stipulation. Moreover, when I hear something described as a "flag", my first impulse is to think of it as a Boolean with 1 usually representing True and 0 representing False. (Granted there is one point in DB.pm where a value of 2 is assigned to $DB::single.) I don't claim to speak definitively here. Thank you very much. Jim Keenan
Subject: Re: [perl #122445] Segmentation fault while debugging programs using bignum in 5.18.2
Date: Wed, 30 Jul 2014 21:55:51 -0400
From: John Peacock <john.peacock [...] havurah-software.org>
CC: perl5-porters [...] perl.org
To: perlbug-followup [...] perl.org
Download (untitled) / with headers
text/plain 501b
On 07/30/2014 09:34 PM, James E Keenan via RT wrote: Show quoted text
> You are trying to assign to $DB::single, which seems to violate the "readonly" stipulation.
Setting a debugging break programatically by assigning to $DB::single is both documented (see Debugging Compile-Time Statements): http://perldoc.perl.org/perldebug.html and incredibly useful (hint, you can also set it conditionally to break in a loop only when specific conditions are true). It is also the only way to debug a BEGIN block. John
RT-Send-CC: perl5-porters [...] perl.org
Download (untitled) / with headers
text/plain 5.4k
On Wed Jul 30 14:55:21 2014, chr.stahlhut@gmail.com wrote: Show quoted text
> On Wed Jul 30 14:51:25 2014, chr.stahlhut@gmail.com wrote:
> > Hi! > > > > Trying to debug the attached program via 'perl -d ./debug-me.pl' > > produces a segmentation fault for me.
> > To be more precise, this happens: > > christian@azmodan ~ $ perl -d ./debug-me.pl > > Loading DB routines from perl5db.pl version 1.39_10 > Editor support available. > > Enter h or 'h h' for help, or 'man perldebug' for more help. > > main::(./debug-me.pl:4): $DB::single=2; > DB<1> > c > Segmentation fault
This appears to be happening in the debugger at line 4146: (gdb) p my_perl->Icurcop->cop_line $3 = 4146 when it tries to execute: # Turn off all flags except single-stepping. $single &= 1; Partial backtrace: #0 Perl_Gv_AMupdate (my_perl=my_perl@entry=0x602010, stash=0xa28678, destructing=destructing@entry=false) at gv.c:2456 #1 0x00007ffff794f808 in Perl_amagic_call (my_perl=my_perl@entry=0x602010, left=left@entry=0x6050a8, right=right@entry=0xb3d7e0, method=46, flags=4) at gv.c:2849 #2 0x00007ffff7952a4a in Perl_try_amagic_bin (my_perl=my_perl@entry=0x602010, method=method@entry=46, flags=flags@entry=4) at gv.c:2726 #3 0x00007ffff7a4c41e in Perl_pp_bit_and (my_perl=0x602010) at pp.c:2193 #4 0x00007ffff79cc30d in Perl_runops_debug (my_perl=0x602010) at dump.c:2361 #5 0x00007ffff794fb33 in Perl_amagic_call (my_perl=my_perl@entry=0x602010, left=left@entry=0x6050a8, right=right@entry=0x602138, method=method@entry=12, flags=flags@entry=9) at gv.c:3237 #6 0x00007ffff795018c in Perl_amagic_call (my_perl=my_perl@entry=0x602010, left=left@entry=0x6050a8, right=right@entry=0xb3d7e0, method=46, flags=4) at gv.c:3180 #7 0x00007ffff7952a4a in Perl_try_amagic_bin (my_perl=my_perl@entry=0x602010, method=method@entry=46, flags=flags@entry=4) at gv.c:2726 #8 0x00007ffff7a4c41e in Perl_pp_bit_and (my_perl=0x602010) at pp.c:2193 #9 0x00007ffff79cc30d in Perl_runops_debug (my_perl=0x602010) at dump.c:2361 #10 0x00007ffff794fb33 in Perl_amagic_call (my_perl=my_perl@entry=0x602010, left=left@entry=0x6050a8, right=right@entry=0x602138, method=method@entry=12, flags=flags@entry=9) at gv.c:3237 #11 0x00007ffff795018c in Perl_amagic_call (my_perl=my_perl@entry=0x602010, left=left@entry=0x6050a8, right=right@entry=0xb3d7e0, method=46, flags=4) at gv.c:3180 #12 0x00007ffff7952a4a in Perl_try_amagic_bin (my_perl=my_perl@entry=0x602010, method=method@entry=46, flags=flags@entry=4) at gv.c:2726 #13 0x00007ffff7a4c41e in Perl_pp_bit_and (my_perl=0x602010) at pp.c:2193 #14 0x00007ffff79cc30d in Perl_runops_debug (my_perl=0x602010) at dump.c:2361 #15 0x00007ffff794fb33 in Perl_amagic_call (my_perl=my_perl@entry=0x602010, left=left@entry=0x6050a8, right=right@entry=0x602138, method=method@entry=12, flags=flags@entry=9) at gv.c:3237 #16 0x00007ffff795018c in Perl_amagic_call (my_perl=my_perl@entry=0x602010, left=left@entry=0x6050a8, right=right@entry=0xb3d7e0, method=46, flags=4) at gv.c:3180 #17 0x00007ffff7952a4a in Perl_try_amagic_bin (my_perl=my_perl@entry=0x602010, method=method@entry=46, flags=flags@entry=4) at gv.c:2726 #18 0x00007ffff7a4c41e in Perl_pp_bit_and (my_perl=0x602010) at pp.c:2193 #19 0x00007ffff79cc30d in Perl_runops_debug (my_perl=0x602010) at dump.c:2361 #20 0x00007ffff794fb33 in Perl_amagic_call (my_perl=my_perl@entry=0x602010, left=left@entry=0x6050a8, right=right@entry=0x602138, method=method@entry=12, flags=flags@entry=9) at gv.c:3237 ... goes on for hundreds of levels Here's the bottom of the trace when I broke in earlier (I stopped looking at 30000 on the full backtrace): #460 0x00007ffff79cc34d in Perl_runops_debug (my_perl=0x602010) at dump.c:2361 #461 0x00007ffff794fb73 in Perl_amagic_call (my_perl=my_perl@entry=0x602010, left=left@entry=0x6050a8, right=right@entry=0x602138, method=method@entry=9, flags=flags@entry=9) at gv.c:3239 #462 0x00007ffff7a2e17d in Perl_sv_2iv_flags (my_perl=my_perl@entry=0x602010, sv=0x6050a8, flags=<optimized out>, flags@entry=2) at sv.c:2362 #463 0x00007ffff7a78846 in Perl_pp_dbstate (my_perl=0x602010) at pp_ctl.c:1946 #464 0x00007ffff79cc34d in Perl_runops_debug (my_perl=0x602010) at dump.c:2361 #465 0x00007ffff794464c in S_run_body (oldscope=1, my_perl=0x5d) at perl.c:2408 #466 perl_run (my_perl=0x602010) at perl.c:2336 #467 0x0000000000400fb8 in main (argc=4, argv=0x7fffffffe8c8, env=0x7fffffffe8f0) at perlmain.c:114 The start of the recursion is the call to SvIV(PL_DBsingle) in pp_dbstate. As a workaround, you can disable bignum for the $DB::single assignment: Loading DB routines from perl5db.pl version 1.45 Editor support available. Enter h or 'h h' for help, or 'man perldebug' for more help. main::(../debug-me.pl:4): { no bignum; $DB::single=2; } DB<1> c main::(../debug-me.pl:6): print "I want to be debugged. :-(\n"; DB<1> c I want to be debugged. :-( Debugged program terminated. Use q to quit or R to restart, use o inhibit_exit to avoid stopping after program termination, h q, h R or h o to get additional info. DB<1> q [Inferior 1 (process 1609) exited normally] I don't see a simple fix, I think we'd need to add set and get magic to $DB::single (and possibly to $DB::signal and $DB::trace) that stores the values as in IVs in my_perl rather than SVs with their possible unwanted magic. Tony
RT-Send-CC: perl5-porters [...] perl.org
Download (untitled) / with headers
text/plain 103b
The workaround does it for me, thank you! (I'm sorry that there is no easy solution though.) Christian
RT-Send-CC: perl5-porters [...] perl.org
Download (untitled) / with headers
text/plain 378b
On Sun Aug 03 19:12:14 2014, tonyc wrote: Show quoted text
> I don't see a simple fix, I think we'd need to add set and get magic > to $DB::single (and possibly to $DB::signal and $DB::trace) that > stores the values as in IVs in my_perl rather than SVs with their > possible unwanted magic.
Attached is a test and a patch that does just that. This is my first time implementing magic. Tony
Subject: 0001-perl-122445-test-for-overload-assigned-to-DB-single.patch
From c58dab6ae371e8b8d20ab9445a4eca168bc388c9 Mon Sep 17 00:00:00 2001 From: Tony Cook <tony@develop-help.com> Date: Thu, 14 Aug 2014 11:09:10 +1000 Subject: [perl #122445] test for overload assigned to $DB::single --- t/run/switchd.t | 20 +++++++++++++++++++- 1 file changed, 19 insertions(+), 1 deletion(-) diff --git a/t/run/switchd.t b/t/run/switchd.t index b5d4d42..4958ce7 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 => 18); +plan(tests => 19); my $r; @@ -275,3 +275,21 @@ is( "42\n", 'UTF8 length caches on $DB::sub are flushed' ); + +{ +local $TODO = "This crashes"; +is( + runperl( + switches => [ '-Ilib', '-d:switchd_empty' ], + progs => [ split "\n", + 'use bignum; + $DB::single=2; + print qq/debugged\n/; + ' + ], + stderr => 1 + ), + "debugged\n", + "\$DB::single set to overload" +); +} -- 1.7.10.4
Subject: 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
RT-Send-CC: perl5-porters [...] perl.org
Download (untitled) / with headers
text/plain 503b
On Wed Aug 13 18:25:26 2014, tonyc wrote: Show quoted text
> On Sun Aug 03 19:12:14 2014, tonyc wrote:
> > I don't see a simple fix, I think we'd need to add set and get magic > > to $DB::single (and possibly to $DB::signal and $DB::trace) that > > stores the values as in IVs in my_perl rather than SVs with their > > possible unwanted magic.
> > Attached is a test and a patch that does just that.
Your patch looks good to me. Show quoted text
> This is my first time implementing magic.
Congratulations! -- Father Chrysostomos
RT-Send-CC: perl5-porters [...] perl.org
Download (untitled) / with headers
text/plain 3.3k
On Wed Aug 13 18:25:26 2014, tonyc wrote: Show quoted text
> > Attached is a test and a patch that does just that. > > This is my first time implementing magic. > > Tony >
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 */ Why are these IVs and not chars or bits in a char? 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; This code is begging for a bitfield or 4 char array that can be cast/union to I32. +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; +} Factor out the SvIV_nomg calls. Also instead of using the constants DBVARMG_* and mg_private, why not put the pointer to the IV (or whatever) into mg_ptr? then no more switch and the code is branchless. Interps can't be realloced. 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", Why are we using up a precious letter? per letter magic limitation became obsolete when mg_findext was added. Why not have it be ~/PERL_MAGIC_ext like regular 3rd party XS magic? Or this is for Dump() reasons? instead of @@ -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); + how about @@ -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, &PL_DBsingle_iv, 0); + SvSETMAGIC(PL_DBsingle); + that will also require svt_dup function to update the pointer in mg_ptr to the one from the new interp. -- bulk88 ~ bulk88 at hotmail.com
RT-Send-CC: perl5-porters [...] perl.org
Download (untitled) / with headers
text/plain 3.4k
Thanks for the feedback. On Fri Aug 15 04:47:22 2014, bulk88 wrote: Show quoted text
> On Wed Aug 13 18:25:26 2014, tonyc wrote:
> > > > Attached is a test and a patch that does just that. > > > > This is my first time implementing magic. > > > > Tony > >
> > 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 */ > > > Why are these IVs and not chars or bits in a char?
I considered this, but perl5db.pl stores flags in $DB::single and $DB::trace at least. Another debugger might use more flags. Show quoted text
> > 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; > > This code is begging for a bitfield or 4 char array that can be > cast/union to I32.
Since I don't want to assumed limited sizes for these variables, I can't make this optimization. Show quoted text
> +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; > +} > > Factor out the SvIV_nomg calls. Also instead of using the constants > DBVARMG_* and mg_private, why not put the pointer to the IV (or > whatever) into mg_ptr? then no more switch and the code is branchless. > Interps can't be realloced.
I made the PL_*_iv variables into an array, which removed the switch and factored out the SvIV_nomg() calls. Show quoted text
> 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", > > Why are we using up a precious letter? per letter magic limitation > became obsolete when mg_findext was added. > Why not have it be ~/PERL_MAGIC_ext like regular 3rd party XS magic? > Or this is for Dump() reasons?
When I wrote it I checked the core for use of PERL_MAGIC_ext and didn't find any, so I assumed it was best practice in core to add new magic. As you say, it makes the sv_dump() output more intelligible. Using the indexes as I've done also helps to make it readable. Tony
Subject: 0002-perl-122445-use-magic-on-DB-single-etc-to-avoid-over.patch
From bd4f4f6d975802435ad5925aede188a0f131907f Mon Sep 17 00:00:00 2001 From: Tony Cook <tony@develop-help.com> Date: Thu, 2 Oct 2014 15:54:58 +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 PL_DBcontrol array. --- embed.fnc | 2 ++ embed.h | 2 ++ embedvar.h | 1 + intrpvar.h | 2 ++ mg.c | 21 +++++++++++++++++++++ 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 | 1 + t/run/switchd.t | 3 --- 16 files changed, 82 insertions(+), 5 deletions(-) diff --git a/embed.fnc b/embed.fnc index 5de2f83..3def772 100644 --- a/embed.fnc +++ b/embed.fnc @@ -831,6 +831,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 @@ -854,6 +855,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 ed04c7c..bcd1f42 100644 --- a/embed.h +++ b/embed.h @@ -1200,6 +1200,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) @@ -1218,6 +1219,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 --- 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 --- 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 --- 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 --- 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 478b415..241ea31 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); @@ -3962,6 +3965,7 @@ void Perl_init_debugger(pTHX) { HV * const ostash = PL_curstash; + MAGIC *mg; PL_curstash = (HV *)SvREFCNT_inc_simple(PL_debstash); @@ -3978,12 +3982,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 436c7d1..065134c 100644 --- a/perl.h +++ b/perl.h @@ -5247,6 +5247,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 --- 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 d72ec1c..0b6980e 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 bd6234f..949d1b5 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 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 5f29137..764c91a 100644 --- a/sv.c +++ b/sv.c @@ -14578,6 +14578,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 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
RT-Send-CC: perl5-porters [...] perl.org
Download (untitled) / with headers
text/plain 187b
On Wed Oct 01 23:25:07 2014, tonyc wrote: Show quoted text
> Thanks for the feedback.
Updated patch applied as 2c2d7daa95190ae95ae6486d1734a1167ea05966 and a6d695237c4c14fa287df157c4907e01d4647641. Tony


This service is sponsored and maintained by Best Practical Solutions and runs on Perl.org infrastructure.

For issues related to this RT instance (aka "perlbug"), please contact perlbug-admin at perl.org