Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Segmentation fault while debugging programs using bignum in 5.18.2 #14013

Closed
p5pRT opened this issue Jul 30, 2014 · 20 comments
Closed

Segmentation fault while debugging programs using bignum in 5.18.2 #14013

p5pRT opened this issue Jul 30, 2014 · 20 comments

Comments

@p5pRT
Copy link

p5pRT commented Jul 30, 2014

Migrated from rt.perl.org#122445 (status was 'resolved')

Searchable as RT122445$

@p5pRT
Copy link
Author

p5pRT commented Jul 30, 2014

From chr.stahlhut@gmail.com

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
  .

@p5pRT
Copy link
Author

p5pRT commented Jul 30, 2014

From chr.stahlhut@gmail.com

debug-me.pl

@p5pRT
Copy link
Author

p5pRT commented Jul 30, 2014

From chr.stahlhut@gmail.com

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

@p5pRT
Copy link
Author

p5pRT commented Jul 30, 2014

From [Unknown Contact. See original ticket]

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

@p5pRT
Copy link
Author

p5pRT commented Jul 31, 2014

From @jkeenan

On Wed Jul 30 14​:55​:21 2014, chr.stahlhut@​gmail.com wrote​:

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)
#####

@p5pRT
Copy link
Author

p5pRT commented Jul 31, 2014

The RT System itself - Status changed from 'new' to 'open'

@p5pRT
Copy link
Author

p5pRT commented Jul 31, 2014

From @jkeenan

On Wed Jul 30 14​:55​:21 2014, chr.stahlhut@​gmail.com wrote​:

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

@p5pRT
Copy link
Author

p5pRT commented Jul 31, 2014

From @JohnPeacock

On 07/30/2014 09​:34 PM, James E Keenan via RT wrote​:

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

@p5pRT
Copy link
Author

p5pRT commented Aug 4, 2014

From @tonycoz

On Wed Jul 30 14​:55​:21 2014, chr.stahlhut@​gmail.com wrote​:

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

@p5pRT
Copy link
Author

p5pRT commented Aug 5, 2014

From chr.stahlhut@gmail.com

The workaround does it for me, thank you!
(I'm sorry that there is no easy solution though.)
Christian

@p5pRT
Copy link
Author

p5pRT commented Aug 5, 2014

From [Unknown Contact. See original ticket]

The workaround does it for me, thank you!
(I'm sorry that there is no easy solution though.)
Christian

@p5pRT
Copy link
Author

p5pRT commented Aug 14, 2014

From @tonycoz

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.

This is my first time implementing magic.

Tony

@p5pRT
Copy link
Author

p5pRT commented Aug 14, 2014

From @tonycoz

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

@p5pRT
Copy link
Author

p5pRT commented Aug 14, 2014

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

@p5pRT
Copy link
Author

p5pRT commented Aug 14, 2014

From @cpansprout

On Wed Aug 13 18​:25​:26 2014, tonyc wrote​:

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.

This is my first time implementing magic.

Congratulations!

--

Father Chrysostomos

@p5pRT
Copy link
Author

p5pRT commented Aug 15, 2014

From @bulk88

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

Inline Patch
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?
Inline Patch
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.

Inline Patch
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

@p5pRT
Copy link
Author

p5pRT commented Oct 2, 2014

From @tonycoz

Thanks for the feedback.

On Fri Aug 15 04​:47​:22 2014, bulk88 wrote​:

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.

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.

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

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

@p5pRT
Copy link
Author

p5pRT commented Oct 2, 2014

From @tonycoz

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

@p5pRT
Copy link
Author

p5pRT commented Oct 9, 2014

From @tonycoz

On Wed Oct 01 23​:25​:07 2014, tonyc wrote​:

Thanks for the feedback.

Updated patch applied as 2c2d7da and a6d6952.

Tony

@p5pRT
Copy link
Author

p5pRT commented Oct 9, 2014

@tonycoz - Status changed from 'open' to 'resolved'

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Labels
None yet
Projects
None yet
Development

No branches or pull requests

1 participant