p5pRT
commented
11 years ago From bpmedley@cpan.org
This is a bug report for perl from bpmedley@cpan.org\, generated with the help of perlbug 1.39 running under perl 5.17.7.
From 1d2b211d6ca342928e1d829444523076fcd6c2e9 Mon Sep 17 00:00:00 2001 From: bpm \bpm@​linuxdev\.\(none\) Date: Sat\, 22 Dec 2012 15:27:53 -0600 Subject: [PATCH] Add in a) trace lines that match a re; b) ability to return up to N subroutines; c) add in frame command (dumps info about a stack frame). MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="------------1.7.1"
This is a multi-part message in MIME format. --------------1.7.1 Content-Type: text/plain; charset=UTF-8; format=fixed Content-Transfer-Encoding: 8bit
lib/perl5db.pl | 70 +++++++++++++++- lib/perl5db.t | 182 +++++++++++++++++++++++++++++++++++++++- lib/perl5db/t/test-r-statement | 9 ++ 3 files changed\, 256 insertions(+)\, 5 deletions(-)
--------------1.7.1 Content-Type: text/x-patch; name="0001-Add-in-a-trace-lines-that-match-a-re-b-ability-to-re.patch" Content-Transfer-Encoding: 8bit Content-Disposition: attachment; filename="0001-Add-in-a-trace-lines-that-match-a-re-b-ability-to-re.patch"
Inline Patch
```diff diff --git a/lib/perl5db.pl b/lib/perl5db.pl index f7420a3..4fded50 100644 --- a/lib/perl5db.pl +++ b/lib/perl5db.pl @@ -911,10 +911,11 @@ $trace = $signal = $single = 0; # Uninitialized warning suppression # value when the 'r' command is used to return from a subroutine. $inhibit_exit = $option{PrintRet} = 1; -use vars qw($trace_to_depth); +use vars qw($trace_to_depth $trace_to_re); # Default to 1E9 so it won't be limited to a certain recursion depth. $trace_to_depth = 1E9; +$trace_to_re = undef; =head1 OPTION PROCESSING @@ -2468,6 +2469,7 @@ my %cmd_lookup = 'H' => { t => 'm', v => '_handle_H_command', }, 'S' => { t => 'm', v => '_handle_S_command', }, 'T' => { t => 'm', v => '_handle_T_command', }, + 'frame' => { t => 'm', v => '_handle_frame_command', }, 'W' => { t => 'm', v => '_handle_W_command', }, 'c' => { t => 's', v => \&_DB__handle_c_command, }, 'f' => { t => 's', v => \&_DB__handle_f_command, }, @@ -3349,12 +3351,30 @@ sub _handle_t_command { $trace ^= 1; local $\ = ''; $DB::trace_to_depth = $levels ? $stack_depth + $levels : 1E9; + $DB::trace_to_re = undef; print {$OUT} "Trace = " . ( ( $trace & 1 ) ? ( $levels ? "on (to level $DB::trace_to_depth)" : "on" ) : "off" ) . "\n"; next CMD; } + elsif ($levels =~ m#^qr/(.*?)/$#) { + $levels =~ s#^qr/(.*?)/$#$1#; + $DB::trace_to_depth = 1E9; + $DB::trace_to_re = qr/$levels/; + + $trace ^= 1; + local $\ = ''; + + print {$OUT} "Trace = " . ( ( $trace & 1 ) ? "on qr(/$levels/)" : "off" ) . "\n"; + + next CMD; + } + else { + # trace an expression + $DB::cmd =~ s/^t\s+/\$DB::trace |= 1;\n/; + redo CMD; + } return; } @@ -3519,13 +3539,48 @@ sub _handle_r_command { # Can't do anything if the program's over. next CMD if DB::_DB__is_finished(); - # Turn on stack trace. + # Turn on single stepping in frame. $stack[$stack_depth] |= 1; # Print return value unless the stack is empty. $doret = $option{PrintRet} ? $stack_depth - 1 : -2; last CMD; } + elsif ($DB::cmd =~ s/^r\s+(\d+)$//) { + my $levels = $1; + + # Can't do anything if the program's over. + next CMD if DB::_DB__is_finished(); + + # Turn off single stepping in frames (except where we stop). + for my $i (reverse(0 .. $stack_depth)) { + $stack[ $i ] = 0; + + --$levels; + if (0 >= $levels) { + $doret = $option{PrintRet} ? $i - 1 : -2; + $stack[ $i ] |= 1; + last if 0 >= $levels; + } + } + + last CMD; + } + + return; +} + +sub _handle_frame_command { + my $self = shift; + our @sub; + + if ($DB::cmd =~ m/^frame\s?(\d+)?$/) { + my $depth = $1 || 0; + my $frame = 2 + $depth; # skip DB + $onetimeDump = 'dump'; + @sub = DB::dump_trace($frame, 1); + $DB::cmd = '@DB::Obj::sub'; + } return; } @@ -4256,7 +4311,12 @@ sub lsub : lvalue { sub depth_print_lineinfo { my $always_print = shift; - print_lineinfo( @_ ) if ($always_print or $stack_depth < $trace_to_depth); + if ($trace_to_re) { + print_lineinfo( @_ ) if ($always_print or join("", @_) =~ m/$trace_to_re/); + } + else { + print_lineinfo( @_ ) if ($always_print or $stack_depth < $trace_to_depth); + } } =head1 EXTENDED COMMAND HANDLING AND THE COMMAND API @@ -5403,6 +5463,7 @@ Display the (nested) parentage of the module or object given. sub cmd_i { my $cmd = shift; my $line = shift; + require mro; foreach my $isa ( split( /\s+/, $line ) ) { $evalarg = $isa; ($isa) = DB::eval(); @@ -8833,7 +8894,8 @@ sub methods_via { # $crawl_upward true: keep going up the tree. # Find all the classes this one is a subclass of. - my $class_ISA_ref = do { no strict "refs"; \@{"${class}::ISA"} }; + require mro; + my $class_ISA_ref = mro::get_linear_isa($class); for my $name ( @$class_ISA_ref ) { # Set up the new prefix. diff --git a/lib/perl5db.t b/lib/perl5db.t index f79d958..8db8bfb 100644 --- a/lib/perl5db.t +++ b/lib/perl5db.t @@ -28,7 +28,7 @@ BEGIN { } } -plan(108); +plan(116); my $rc_filename = '.perldb'; @@ -1030,6 +1030,130 @@ sub _calc_trace_wrapper /msx, 'r statement is working properly.', ); + + $wrapper = DebugWrap->new( + { + cmds => + [ + 'b 28', + 'c', + 'r 1', + 'q', + ], + prog => '../lib/perl5db/t/test-r-statement', + } + ); + + $wrapper->output_like( + qr/ + ^Foo$ + .*? + ^Baz$ + /msx, + 'r statement is working properly.', + ); + + $wrapper = DebugWrap->new( + { + cmds => + [ + 'b 28', + 'c', + 'r 2', + 'q', + ], + prog => '../lib/perl5db/t/test-r-statement', + } + ); + + $wrapper->output_like( + qr/ + ^Foo$ + .*? + ^Baz$ + .*? + ^Bal$ + /msx, + 'r statement is working properly.', + ); +} + +{ + my $wrapper = DebugWrap->new( + { + cmds => + [ + 'b 10', + 'c', + 'frame', + 'q', + ], + prog => '../lib/perl5db/t/test-frame-statement', + } + ); + + $wrapper->contents_like( + qr/ + 'args'\s+=\>\s+ARRAY + .*? + 0\s+1\s* + .*? + 2\s+'ref\(ARRAY\)' + .*? + 'sub'\s+=\>\s+'main::threeArgs' + /msx, + 'frame statement is working properly.', + ); + + $wrapper = DebugWrap->new( + { + cmds => + [ + 'b 17', + 'c', + 'frame 1', + 'q', + ], + prog => '../lib/perl5db/t/test-frame-statement', + } + ); + + $wrapper->contents_like( + qr/ + 'args'\s+=\>\s+ARRAY + .*? + 0\s+1\s* + .*? + 2\s+'ref\(ARRAY\)' + .*? + 'sub'\s+=\>\s+'main::threeArgs' + /msx, + 'frame statement is working properly.', + ); + + $wrapper = DebugWrap->new( + { + cmds => + [ + 'b 17', + 'c', + 'frame', + 'q', + ], + prog => '../lib/perl5db/t/test-frame-statement', + } + ); + + $wrapper->contents_like( + qr/ + 'args'\s+=\>\s+ARRAY + .*? + 0\s+'ref\(HASH\)' + .*? + 'sub'\s+=\>\s+'main::oneArg' + /msx, + 'frame statement is working properly.', + ); } { @@ -2270,6 +2394,62 @@ sub _calc_trace_wrapper ); } +{ + my $wrapper = DebugWrap->new( + { + cmds => + [ + 't qr/Val/', + 'c', + 'q', + ], + prog => '../lib/perl5db/t/disable-breakpoints-1', + } + ); + + $wrapper->contents_like( + qr/\d+:\s+\$x = "FirstVal";/ms, + 'Test the t command (with a qr//)', + ); +} + +{ + my $wrapper = DebugWrap->new( + { + cmds => + [ + 't qr/Symbol::gensym/', + 't $io = IO::File->new()', + 'q', + ], + prog => '../lib/perl5db/t/disable-breakpoints-1', + } + ); + + $wrapper->contents_like( + qr/Symbol::gensym\(..\/lib\/Symbol.pm:\d+\)/ms, + 'Test the t command (with an expression)', + ); +} + +{ + my $wrapper = DebugWrap->new( + { + cmds => + [ + 't $io = IO::File->new()', + 'q', + ], + prog => '../lib/perl5db/t/disable-breakpoints-1', + } + ); + + $wrapper->contents_like( + qr/IO::Handle::new\(..\/lib\/IO\/Handle.pm:\d+\)/ms, + 'Test the t command (with an expression)', + ); +} + # Test the o AutoTrace command { my $wrapper = DebugWrap->new( diff --git a/lib/perl5db/t/test-r-statement b/lib/perl5db/t/test-r-statement index f8c7bf5..8e1a1dc 100644 --- a/lib/perl5db/t/test-r-statement +++ b/lib/perl5db/t/test-r-statement @@ -18,9 +18,18 @@ sub mysub print "Bar\n"; } + insub(); + + print "Bal\n"; + return; } +sub insub +{ + print "Baz\n"; +} + mysub(); $var .= "More"; --------------1.7.1-- --- ```Flags: category=core severity=wishlist
Site configuration information for perl 5.17.7:
Configured by bpm at Fri Dec 21 17:39:25 CST 2012.
Summary of my perl5 (revision 5 version 17 subversion 7) configuration: Derived from: 7a0fe8d157063a5d4017c60814c1ea577f105a72 Platform: osname=linux\, osvers=2.6.32-279.14.1.el6.x86_64\, archname=x86_64-linux uname='linux linuxdev 2.6.32-279.14.1.el6.x86_64 #1 smp tue nov 6 23:43:09 utc 2012 x86_64 x86_64 x86_64 gnulinux ' config_args='-des -A ccflags=-fPIC -Dusedevel -Dprefix=/opt/shlomif-d-perl' hint=recommended\, useposix=true\, d_sigaction=define useithreads=undef\, usemultiplicity=undef useperlio=define\, d_sfio=undef\, uselargefiles=define\, usesocks=undef use64bitint=define\, use64bitall=define\, uselongdouble=undef usemymalloc=n\, bincompat5005=undef Compiler: cc='cc'\, ccflags ='-fPIC -fno-strict-aliasing -pipe -fstack-protector -I/usr/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64'\, optimize='-O2'\, cppflags='-fPIC -fno-strict-aliasing -pipe -fstack-protector -I/usr/local/include' ccversion=''\, gccversion='4.4.6 20120305 (Red Hat 4.4.6-4)'\, 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='cc'\, ldflags =' -fstack-protector -L/usr/local/lib' libpth=/usr/local/lib /lib/../lib64 /usr/lib/../lib64 /lib /usr/lib /lib64 /usr/lib64 /usr/local/lib64 libs=-lnsl -ldl -lm -lcrypt -lutil -lc perllibs=-lnsl -ldl -lm -lcrypt -lutil -lc libc=\, so=so\, useshrplib=false\, libperl=libperl.a gnulibc_version='2.12' Dynamic Linking: dlsrc=dl_dlopen.xs\, dlext=so\, d_dlsymun=undef\, ccdlflags='-Wl\,-E' cccdlflags='-fPIC'\, lddlflags='-shared -O2 -L/usr/local/lib -fstack-protector'
Locally applied patches:
@INC for perl 5.17.7: /opt/shlomif-d-perl/lib/site_perl/5.17.7/x86_64-linux /opt/shlomif-d-perl/lib/site_perl/5.17.7 /opt/shlomif-d-perl/lib/5.17.7/x86_64-linux /opt/shlomif-d-perl/lib/5.17.7 .
Environment for perl 5.17.7: HOME=/home/bpm LANG=en_US.UTF-8 LANGUAGE (unset) LD_LIBRARY_PATH (unset) LOGDIR (unset) PATH=/usr/lib64/qt-3.3/bin:/usr/local/bin:/bin:/usr/bin:/usr/local/sbin:/usr/sbin:/sbin:/home/bpm/bin PERL_BADLANG (unset) SHELL=/bin/bash
Migrated from rt.perl.org#116180 (status was 'open')
Searchable as RT116180$