In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/2c247e84d4c0ff4b5c5fe6c10b3257c55520332a?hp=9bcdb3dd02eeb4602916eaf43f73d58395ffd840>
- Log ----------------------------------------------------------------- commit 2c247e84d4c0ff4b5c5fe6c10b3257c55520332a Author: Shlomi Fish <[email protected]> Date: Tue Sep 4 22:40:38 2012 -0400 perl5db: more tests This patch adds more tests for lib/perl5db.pl on lib/perl5db.t. One note is that I'm a bit uncomfortable about the test for ".", which did not initially work exactly as I expected, due to debugger quirks. This patch also fixes a bug where the /pattern/ command (and possibly the ?pattern? command as well) got broken due to the addition of "use strict;", and adds tests for them. M MANIFEST M lib/perl5db.pl M lib/perl5db.t M lib/perl5db/t/test-l-statement-1 A lib/perl5db/t/test-l-statement-2 commit 32050a639a295d8d8a4d4c664592c86f79aa1383 Author: Shlomi Fish <[email protected]> Date: Tue Sep 4 22:37:13 2012 -0400 perl5db: fix an accidental effect of strictures see https://rt.perl.org/rt3/Ticket/Display.html?id=114284 M lib/perl5db.pl ----------------------------------------------------------------------- Summary of changes: MANIFEST | 1 + lib/perl5db.pl | 88 +++++++++++------ lib/perl5db.t | 203 +++++++++++++++++++++++++++++++++++++- lib/perl5db/t/test-l-statement-1 | 12 +++ lib/perl5db/t/test-l-statement-2 | 24 +++++ 5 files changed, 293 insertions(+), 35 deletions(-) create mode 100644 lib/perl5db/t/test-l-statement-2 diff --git a/MANIFEST b/MANIFEST index dde4011..c0bfe2d 100644 --- a/MANIFEST +++ b/MANIFEST @@ -4327,6 +4327,7 @@ lib/perl5db/t/rt-66110 Tests for the Perl debugger lib/perl5db/t/symbol-table-bug Tests for the Perl debugger lib/perl5db/t/taint Tests for the Perl debugger lib/perl5db/t/test-l-statement-1 Tests for the Perl debugger +lib/perl5db/t/test-l-statement-2 Tests for the Perl debugger lib/perl5db/t/test-r-statement Tests for the Perl debugger lib/perl5db/t/uncalled-subroutine Tests for the Perl debugger lib/perl5db/t/with-subroutine Tests for the Perl debugger diff --git a/lib/perl5db.pl b/lib/perl5db.pl index 0751738..39c18e5 100644 --- a/lib/perl5db.pl +++ b/lib/perl5db.pl @@ -1731,6 +1731,7 @@ use vars qw( $stack_depth @to_watch $try + $end ); sub DB { @@ -1741,7 +1742,6 @@ sub DB { my $position; my ($prefix, $after, $infix); my $pat; - my $end; if ($ENV{PERL5DB_THREADED}) { $tid = eval { "[".threads->tid."]" }; @@ -1755,7 +1755,7 @@ sub DB { if ($runnonstop) { # Disable until signal # If there's any call stack in place, turn off single # stepping into subs throughout the stack. - for ( my $i = 0 ; $i <= $stack_depth ; ) { + for my $i (0 .. $stack_depth) { $stack[ $i++ ] &= ~1; } @@ -1832,7 +1832,7 @@ sub DB { # If we have any watch expressions ... if ( $trace & 2 ) { - for ( my $n = 0 ; $n <= $#to_watch ; $n++ ) { + for my $n (0 .. $#to_watch) { $evalarg = $to_watch[$n]; local $onetimeDump; # Tell DB::eval() to not output results @@ -1853,7 +1853,7 @@ Watchpoint $n:\t$to_watch[$n] changed: EOP $old_watch[$n] = $val; } ## end if ($val ne $old_watch... - } ## end for (my $n = 0 ; $n <= ... + } ## end for my $n (0 .. } ## end if ($trace & 2) =head2 C<watchfunction()> @@ -2002,7 +2002,9 @@ number information, and print that. # Scan forward, stopping at either the end or the next # unbreakable line. - for ( my $i = $line + 1 ; $i <= $max && $dbline[$i] == 0 ; ++$i ) + { + my $i = $line + 1; + while ( $i <= $max && $dbline[$i] == 0 ) { #{ vi # Drop out on null statements, block closers, and comments. @@ -2027,7 +2029,12 @@ number information, and print that. else { depth_print_lineinfo($explicit_stop, $incr_pos); } - } ## end for ($i = $line + 1 ; $i... + } + continue + { + $i++; + }## end while ($i = $line + 1 ; $i... + } } ## end else [ if ($slave_editor) } ## end if ($single || ($trace... @@ -2688,8 +2695,8 @@ in this and all call levels above this one. } ## end if ($i) # Turn off stack tracing from here up. - for ( $i = 0 ; $i <= $stack_depth ; ) { - $stack[ $i++ ] &= ~1; + for my $i (0 .. $stack_depth) { + $stack[ $i ] &= ~1; } last CMD; }; @@ -2757,7 +2764,8 @@ mess us up. $cmd =~ /^\/(.*)$/ && do { # The pattern as a string. - my $inpat = $1; + use vars qw($inpat); + $inpat = $1; # Remove the final slash. $inpat =~ s:([^\\])/$:$1:; @@ -2957,11 +2965,15 @@ If a command is found, it is placed in C<$cmd> and executed via C<redo>. pop(@hist) if length($cmd) > 1; # Look backward through the history. - for ( $i = $#hist ; $i ; --$i ) { + $i = $#hist; + while ($i) { # Stop if we find it. last if $hist[$i] =~ /$pat/; } + continue { + $i--; + } if ( !$i ) { @@ -3033,12 +3045,16 @@ Prints the contents of C<@hist> (if any). # Start at the end of the array. # Stay in while we're still above the ending value. # Tick back by one each time around the loop. - for ( $i = $#hist ; $i > $end ; $i-- ) { + $i = $#hist; + while ( $i > $end ) { # Print the command unless it has no arguments. print $OUT "$i: ", $hist[$i], "\n" unless $hist[$i] =~ /^.?$/; } + continue { + $i--; + } next CMD; }; @@ -4059,7 +4075,7 @@ sub delete_action { local *dbline = $main::{ '_<' . $file }; $max = $#dbline; my $was; - for ( $i = 1 ; $i <= $max ; $i++ ) { + for $i (1 .. $max) { if ( defined $dbline{$i} ) { $dbline{$i} =~ s/\0[^\0]*//; delete $dbline{$i} if $dbline{$i} eq ''; @@ -4067,7 +4083,7 @@ sub delete_action { unless ( $had_breakpoints{$file} &= ~2 ) { delete $had_breakpoints{$file}; } - } ## end for ($i = 1 ; $i <= $max... + } ## end for ($i = 1 .. $max) } ## end for my $file (keys %had_breakpoints) } ## end else [ if (defined($i)) } ## end sub delete_action @@ -4692,7 +4708,7 @@ sub delete_breakpoint { my $was; # For all lines in this file ... - for ( $i = 1 ; $i <= $max ; $i++ ) { + for $i (1 .. $max) { # If there's a breakpoint or action on this line ... if ( defined $dbline{$i} ) { @@ -4706,7 +4722,7 @@ sub delete_breakpoint { _delete_breakpoint_data_ref($file, $i); } } ## end if (defined $dbline{$i... - } ## end for ($i = 1 ; $i <= $max... + } ## end for $i (1 .. $max) # If, after we turn off the "there were breakpoints in this file" # bit, the entry in %had_breakpoints for this file is zero, @@ -5051,7 +5067,7 @@ sub cmd_l { # - whether a line has a break or not # - whether a line has an action or not else { - for ( ; $i <= $end ; $i++ ) { + while ($i <= $end) { # Check for breakpoints and actions. my ( $stop, $action ); @@ -5074,7 +5090,10 @@ sub cmd_l { # Move on to the next line. Drop out on an interrupt. $i++, last if $signal; - } ## end for (; $i <= $end ; $i++) + } + continue { + $i++; + }## end while (; $i <= $end ; $i++) # Line the prompt up; print a newline if the last line listed # didn't have a newline. @@ -5132,7 +5151,7 @@ sub cmd_L { # in this file? # For each line in the file ... - for ( my $i = 1 ; $i <= $max ; $i++ ) { + for my $i (1 .. $max) { # We've got something on this line. if ( defined $dbline{$i} ) { @@ -5159,7 +5178,7 @@ sub cmd_L { # Quit if the user hit interrupt. last if $signal; } ## end if (defined $dbline{$i... - } ## end for ($i = 1 ; $i <= $max... + } ## end for my $i (1 .. $max) } ## end for my $file (keys %had_breakpoints) } ## end if ($break_wanted or $action_wanted) @@ -5727,7 +5746,7 @@ sub print_trace { # Run through the traceback info, format it, and print it. my $s; - for ( my $i = 0 ; $i <= $#sub ; $i++ ) { + for my $i (0 .. $#sub) { # Drop out if the user has lost interest and hit control-C. last if $signal; @@ -5767,7 +5786,7 @@ sub print_trace { . " called from $file" . " line $sub[$i]{line}\n"; } - } ## end for ($i = 0 ; $i <= $#sub... + } ## end for my $i (0 .. $#sub) } ## end sub print_trace =head2 dump_trace(skip[,count]) @@ -5835,12 +5854,12 @@ sub dump_trace { # number of stack frames, or we run out - caller() returns nothing - we # quit. # Up the stack frame index to go back one more level each time. - for ( - my $i = $skip ; + { + my $i = $skip; + while ( $i < $count - and ( $p, $file, $line, $sub, $h, $context, $e, $r ) = caller($i) ; - $i++ - ) + and ( $p, $file, $line, $sub, $h, $context, $e, $r ) = caller($i) + ) { # Go through the arguments and save them for later. @@ -5926,7 +5945,11 @@ sub dump_trace { # Stop processing frames if the user hit control-C. last if $signal; - } ## end for ($i = $skip ; $i < ... + } ## end while ($i) + continue { + $i++; + } + } # Restore the trace value again. $trace = $otrace; @@ -8666,8 +8689,11 @@ Look through all the symbols in the package. C<grep> out all the possible hashes =cut - my @out = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, - keys %$pack; + my @out = do { + no strict 'refs'; + map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, + keys %$pack; + }; =pod @@ -9376,7 +9402,7 @@ sub cmd_pre580_D { my $was; # For all lines in this file ... - for ( my $i = 1 ; $i <= $max ; $i++ ) { + for my $i (1 .. $max) { # If there's a breakpoint or action on this line ... if ( defined $dbline{$i} ) { @@ -9389,7 +9415,7 @@ sub cmd_pre580_D { delete $dbline{$i}; } } ## end if (defined $dbline{$i... - } ## end for ($i = 1 ; $i <= $max... + } ## end for my $i (1 .. $max) # If, after we turn off the "there were breakpoints in this file" # bit, the entry in %had_breakpoints for this file is zero, diff --git a/lib/perl5db.t b/lib/perl5db.t index b6936b2..9276fad 100644 --- a/lib/perl5db.t +++ b/lib/perl5db.t @@ -28,7 +28,7 @@ BEGIN { } } -plan(34); +plan(40); my $rc_filename = '.perldb'; @@ -367,7 +367,7 @@ sub _run { ::runperl( switches => [ - '-d', + '-d', ($self->_include_t ? ('-I', '../lib/perl5db/t') : ()) ], stderr => 1, @@ -689,11 +689,11 @@ package main; "'" . quotemeta($prog_fn) . "' line %s\\n", (map { quotemeta($_) } @$_) ) - } + } ( ['.', 'main::baz', 14,], ['.', 'main::bar', 9,], - ['.', 'main::foo', 6] + ['.', 'main::foo', 6], ) ); $wrapper->contents_like( @@ -902,6 +902,201 @@ package main; ); } +{ + my $wrapper = DebugWrap->new( + { + cmds => + [ + 'l', + q/# After l 1/, + 'l', + q/# After l 2/, + '-', + q/# After -/, + 'q', + ], + prog => '../lib/perl5db/t/test-l-statement-1', + } + ); + + my $first_l_out = qr/ + 1==>\s+\$x\ =\ 1;\n + 2:\s+print\ "1\\n";\n + 3\s*\n + 4:\s+\$x\ =\ 2;\n + 5:\s+print\ "2\\n";\n + 6\s*\n + 7:\s+\$x\ =\ 3;\n + 8:\s+print\ "3\\n";\n + 9\s*\n + 10:\s+\$x\ =\ 4;\n + /msx; + + my $second_l_out = qr/ + 11:\s+print\ "4\\n";\n + 12\s*\n + 13:\s+\$x\ =\ 5;\n + 14:\s+print\ "5\\n";\n + 15\s*\n + 16:\s+\$x\ =\ 6;\n + 17:\s+print\ "6\\n";\n + 18\s*\n + 19:\s+\$x\ =\ 7;\n + 20:\s+print\ "7\\n";\n + /msx; + $wrapper->contents_like( + qr/ + ^$first_l_out + [^\n]*?DB<\d+>\ \#\ After\ l\ 1\n + [\ \t]*\n + [^\n]*?DB<\d+>\ l\s*\n + $second_l_out + [^\n]*?DB<\d+>\ \#\ After\ l\ 2\n + [\ \t]*\n + [^\n]*?DB<\d+>\ -\s*\n + $first_l_out + [^\n]*?DB<\d+>\ \#\ After\ -\n + /msx, + 'l followed by l and then followed by -', + ); +} + +{ + my $wrapper = DebugWrap->new( + { + cmds => + [ + 'l fact', + 'q', + ], + prog => '../lib/perl5db/t/test-l-statement-2', + } + ); + + my $first_l_out = qr/ + 6\s+sub\ fact\ \{\n + 7:\s+my\ \$n\ =\ shift;\n + 8:\s+if\ \(\$n\ >\ 1\)\ \{\n + 9:\s+return\ \$n\ \*\ fact\(\$n\ -\ 1\); + /msx; + + $wrapper->contents_like( + qr/ + DB<1>\s+l\ fact\n + $first_l_out + /msx, + 'l subroutine_name', + ); +} + +{ + my $wrapper = DebugWrap->new( + { + cmds => + [ + 'b fact', + 'c', + # Repeat several times to avoid @typeahead problems. + '.', + '.', + '.', + '.', + 'q', + ], + prog => '../lib/perl5db/t/test-l-statement-2', + } + ); + + my $line_out = qr / + ^main::fact\([^\n]*?:7\):\n + ^7:\s+my\ \$n\ =\ shift;\n + /msx; + + $wrapper->contents_like( + qr/ + $line_out + $line_out + /msx, + 'Test the "." command', + ); +} + +# Testing that the f command works. +{ + my $wrapper = DebugWrap->new( + { + cmds => + [ + 'f ../lib/perl5db/t/MyModule.pm', + 'b 12', + 'c', + q/do { use IO::Handle; STDOUT->autoflush(1); print "Var=$var\n"; }/, + 'c', + 'q', + ], + include_t => 1, + prog => '../lib/perl5db/t/filename-line-breakpoint' + } + ); + + $wrapper->output_like(qr/ + ^Var=Bar$ + .* + ^In\ MyModule\.$ + .* + ^In\ Main\ File\.$ + .* + /msx, + "f command is working.", + ); +} + +# We broke the /pattern/ command because apparently the CORE::eval-s inside +# lib/perl5db.pl cannot handle lexical variable properly. So we now fix this +# bug. +# +# TODO : +# +# 1. Go over the rest of the "eval"s in lib/perl5db.t and see if they cause +# problems. +{ + my $wrapper = DebugWrap->new( + { + cmds => + [ + '/for/', + 'q', + ], + prog => '../lib/perl5db/t/eval-line-bug', + } + ); + + $wrapper->contents_like( + qr/12: \s* for\ my\ \$q\ \(1\ \.\.\ 10\)\ \{/msx, + "/pat/ command is working and found a match.", + ); +} + +{ + my $wrapper = DebugWrap->new( + { + cmds => + [ + 'b 22', + 'c', + '?for?', + 'q', + ], + prog => '../lib/perl5db/t/eval-line-bug', + } + ); + + $wrapper->contents_like( + qr/12: \s* for\ my\ \$q\ \(1\ \.\.\ 10\)\ \{/msx, + "?pat? command is working and found a match.", + ); +} + END { 1 while unlink ($rc_filename, $out_fn); } diff --git a/lib/perl5db/t/test-l-statement-1 b/lib/perl5db/t/test-l-statement-1 index c3cf5b0..990a169 100644 --- a/lib/perl5db/t/test-l-statement-1 +++ b/lib/perl5db/t/test-l-statement-1 @@ -6,3 +6,15 @@ print "2\n"; $x = 3; print "3\n"; + +$x = 4; +print "4\n"; + +$x = 5; +print "5\n"; + +$x = 6; +print "6\n"; + +$x = 7; +print "7\n"; diff --git a/lib/perl5db/t/test-l-statement-2 b/lib/perl5db/t/test-l-statement-2 new file mode 100644 index 0000000..9e6a210 --- /dev/null +++ b/lib/perl5db/t/test-l-statement-2 @@ -0,0 +1,24 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +sub fact { + my $n = shift; + if ($n > 1) { + return $n * fact($n - 1); + } else { + return 1; + } +} + +sub bar { + print "One\n"; + print "Two\n"; + print "Three\n"; + + return; +} + +fact(5); +bar(); -- Perl5 Master Repository
