From: Richard Foley Date: Wed, 19 Feb 2003 13:24:38 +0000 (+0100) Subject: for perl5db.pl against missing args destroying pre-post command setups X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=35408c4e725204f0bcaafd30aabe18784af1b4af;p=p5sagit%2Fp5-mst-13.2.git for perl5db.pl against missing args destroying pre-post command setups Message-ID: p4raw-id: //depot/perl@18800 --- diff --git a/lib/perl5db.pl b/lib/perl5db.pl index f43d838..31a562d 100644 --- a/lib/perl5db.pl +++ b/lib/perl5db.pl @@ -1,7 +1,7 @@ package DB; # Debugger for Perl 5.00x; perl5db.pl patch level: -$VERSION = 1.19; +$VERSION = 1.20; $header = "perl5db.pl version $VERSION"; # It is crucial that there is no lexicals in scope of `eval ""' down below @@ -79,7 +79,6 @@ sub eval { # true if $deep is not defined. # # $Log: perldb.pl,v $ - # # At start reads $rcfile that may set important options. This file # may define a subroutine &afterinit that will be executed after the @@ -320,6 +319,9 @@ sub eval { # + fixed missing cmd_O bug # Changes: 1.19: Mar 29, 2002 Spider Boardman # + Added missing local()s -- DB::DB is called recursively. +# Changes: 1.20: Feb 17, 2003 Richard Foley +# + pre'n'post commands no longer trashed with no args +# + watch val joined out of eval() # #################################################################### @@ -716,7 +718,7 @@ sub DB { for (my $n = 0; $n <= $#to_watch; $n++) { $evalarg = $to_watch[$n]; local $onetimeDump; # Do not output results - my ($val) = &eval; # Fix context (&eval is doing array)? + my ($val) = join("', '", &eval); # Fix context (&eval is doing array)? - rjsf $val = ( (defined $val) ? "'$val'" : 'undef' ); if ($val ne $old_watch[$n]) { $signal = 1; @@ -919,90 +921,12 @@ EOP $start = 1 if $start <= 0; $incr = $window - 1; $cmd = 'l ' . ($start) . '+'; }; - # rjsf -> - $cmd =~ /^([aAbBhlLMoOvwWP])\b\s*(.*)/s && do { + # rjsf -> + $cmd =~ /^([aAbBhlLMoOPvwW]\b|[<>\{]{1,2})\s*(.*)/so && do { &cmd_wrapper($1, $2, $line); next CMD; }; - # <- rjsf - $cmd =~ /^\<\<\s*(.*)/ && do { # \<\< for CPerl sake: not HERE - push @$pre, action($1); - next CMD; }; - $cmd =~ /^>>\s*(.*)/ && do { - push @$post, action($1); - next CMD; }; - $cmd =~ /^<\s*(.*)/ && do { - unless ($1) { - print $OUT "All < actions cleared.\n"; - $pre = []; - next CMD; - } - if ($1 eq '?') { - unless (@$pre) { - print $OUT "No pre-prompt Perl actions.\n"; - next CMD; - } - print $OUT "Perl commands run before each prompt:\n"; - for my $action ( @$pre ) { - print $OUT "\t< -- $action\n"; - } - next CMD; - } - $pre = [action($1)]; - next CMD; }; - $cmd =~ /^>\s*(.*)/ && do { - unless ($1) { - print $OUT "All > actions cleared.\n"; - $post = []; - next CMD; - } - if ($1 eq '?') { - unless (@$post) { - print $OUT "No post-prompt Perl actions.\n"; - next CMD; - } - print $OUT "Perl commands run after each prompt:\n"; - for my $action ( @$post ) { - print $OUT "\t> -- $action\n"; - } - next CMD; - } - $post = [action($1)]; - next CMD; }; - $cmd =~ /^\{\{\s*(.*)/ && do { - if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,2))) { - print $OUT "{{ is now a debugger command\n", - "use `;{{' if you mean Perl code\n"; - $cmd = "h {{"; - redo CMD; - } - push @$pretype, $1; - next CMD; }; - $cmd =~ /^\{\s*(.*)/ && do { - unless ($1) { - print $OUT "All { actions cleared.\n"; - $pretype = []; - next CMD; - } - if ($1 eq '?') { - unless (@$pretype) { - print $OUT "No pre-prompt debugger actions.\n"; - next CMD; - } - print $OUT "Debugger commands run before each prompt:\n"; - for my $action ( @$pretype ) { - print $OUT "\t{ -- $action\n"; - } - next CMD; - } - if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,1))) { - print $OUT "{ is now a debugger command\n", - "use `;{' if you mean Perl code\n"; - $cmd = "h {"; - redo CMD; - } - $pretype = [$1]; - next CMD; }; + # rjsf <- pre|post commands stripped out $cmd =~ /^y(?:\s+(\d*)\s*(.*))?$/ && do { eval { require PadWalker; PadWalker->VERSION(0.08) } or &warn($@ =~ /locate/ @@ -1161,8 +1085,8 @@ EOP $cmd =~ /^T$/ && do { print_trace($OUT, 1); # skip DB next CMD; }; - $cmd =~ /^w\b\s*(.*)/s && do { &cmd_w($1); next CMD; }; - $cmd =~ /^W\b\s*(.*)/s && do { &cmd_W($1); next CMD; }; + $cmd =~ /^w\b\s*(.*)/s && do { &cmd_w('w', $1); next CMD; }; + $cmd =~ /^W\b\s*(.*)/s && do { &cmd_W('W', $1); next CMD; }; $cmd =~ /^\/(.*)$/ && do { $inpat = $1; $inpat =~ s:([^\\])/$:$1:; @@ -1484,7 +1408,7 @@ sub sub { ### returns FALSE on error. ### User-interface functions cmd_* output error message. -### Note all cmd_[a-zA-Z]'s require $line, $dblineno as first arguments +### Note all cmd_[a-zA-Z]'s require $cmd, $line, $dblineno as first arguments my %set = ( # 'pre580' => { @@ -1502,6 +1426,14 @@ my %set = ( # 'w' => 'v', 'W' => 'pre580_W', }, + 'pre590' => { + '<' => 'pre590_prepost', + '<<' => 'pre590_prepost', + '>' => 'pre590_prepost', + '>>' => 'pre590_prepost', + '{' => 'pre590_prepost', + '{{' => 'pre590_prepost', + }, ); sub cmd_wrapper { @@ -1513,14 +1445,15 @@ sub cmd_wrapper { # to old (pre580) or other command sets easily # my $call = 'cmd_'.( - $set{$CommandSet}{$cmd} || $cmd + $set{$CommandSet}{$cmd} || ($cmd =~ /^[<>{]+/o ? 'prepost' : $cmd) ); # print "cmd_wrapper($cmd): $CommandSet($set{$CommandSet}{$cmd}) => call($call)\n"; - return &$call($line, $dblineno); + return &$call($cmd, $line, $dblineno); } sub cmd_a { + my $cmd = shift; # a my $line = shift || ''; # [.|line] expr my $dbline = shift; $line =~ s/^(\.|(?:[^\d]))/$dbline/; if ($line =~ /^\s*(\d*)\s*(\S.+)/) { @@ -1540,6 +1473,7 @@ sub cmd_a { } sub cmd_A { + my $cmd = shift; # A my $line = shift || ''; my $dbline = shift; $line =~ s/^\./$dbline/; if ($line eq '*') { @@ -1577,6 +1511,7 @@ sub delete_action { } sub cmd_b { + my $cmd = shift; # b my $line = shift; # [.|line] [cond] my $dbline = shift; $line =~ s/^\./$dbline/; if ($line =~ /^\s*$/) { @@ -1721,6 +1656,7 @@ sub cmd_b_sub { } sub cmd_B { + my $cmd = shift; # B my $line = ($_[0] =~ /^\./) ? $dbline : shift || ''; my $dbline = shift; $line =~ s/^\./$dbline/; if ($line eq '*') { @@ -1770,6 +1706,7 @@ sub cmd_stop { # As on ^C, but not signal-safy. } sub cmd_h { + my $cmd = shift; # h my $line = shift || ''; if ($line =~ /^h\s*/) { print_help($help); @@ -1793,6 +1730,7 @@ sub cmd_h { sub cmd_l { my $current_line = $line; + my $cmd = shift; # l my $line = shift; $line =~ s/^-\s*$/-/; if ($line =~ /^(\$.*)/s) { @@ -1802,7 +1740,7 @@ sub cmd_l { $s = CvGV_name($s); print($OUT "Interpreted as: $1 $s\n"); $line = "$1 $s"; - &cmd_l($s); + &cmd_l('l', $s); } elsif ($line =~ /^([\':A-Za-z_][\':\w]*(\[.*\])?)/s) { my $s = $subname = $1; $subname =~ s/\'/::/; @@ -1827,20 +1765,20 @@ sub cmd_l { $subrange =~ s/-.*/+/; } $line = $subrange; - &cmd_l($subrange); + &cmd_l('l', $subrange); } else { print $OUT "Subroutine $subname not found.\n"; } } elsif ($line =~ /^\s*$/) { $incr = $window - 1; $line = $start . '-' . ($start + $incr); - &cmd_l($line); + &cmd_l('l', $line); } elsif ($line =~ /^(\d*)\+(\d*)$/) { $start = $1 if $1; $incr = $2; $incr = $window - 1 unless $incr; $line = $start . '-' . ($start + $incr); - &cmd_l($line); + &cmd_l('l', $line); } elsif ($line =~ /^((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/) { $end = (!defined $2) ? $max : ($4 ? $4 : $2); $end = $max if $end > $max; @@ -1873,6 +1811,7 @@ sub cmd_l { } sub cmd_L { + my $cmd = shift; # L my $arg = shift || 'abw'; $arg = 'abw' unless $CommandSet eq '580'; # sigh... my $action_wanted = ($arg =~ /a/) ? 1 : 0; my $break_wanted = ($arg =~ /b/) ? 1 : 0; @@ -1950,6 +1889,7 @@ sub cmd_M { } sub cmd_o { + my $cmd = shift; # o my $opt = shift || ''; # opt[=val] if ($opt =~ /^(\S.*)/) { &parse_options($1); @@ -1967,6 +1907,7 @@ sub cmd_O { } sub cmd_v { + my $cmd = shift; # v my $line = shift; if ($line =~ /^(\d*)$/) { @@ -1974,16 +1915,17 @@ sub cmd_v { $start = $1 if $1; $start -= $preview; $line = $start . '-' . ($start + $incr); - &cmd_l($line); + &cmd_l('l', $line); } } sub cmd_w { + my $cmd = shift; # w my $expr = shift || ''; if ($expr =~ /^(\S.*)/) { push @to_watch, $expr; $evalarg = $expr; - my ($val) = &eval; + my ($val) = join(' ', &eval); $val = (defined $val) ? "'$val'" : 'undef' ; push @old_watch, $val; $trace |= 2; @@ -1993,6 +1935,7 @@ sub cmd_w { } sub cmd_W { + my $cmd = shift; # W my $expr = shift || ''; if ($expr eq '*') { $trace &= ~2; @@ -2854,16 +2797,20 @@ B I Evals expression in list context, prints methods callable on the first element of the result. B I Prints methods callable via the given class. B Show versions of loaded modules. +B [I [I]] List lexical variables I levels up from current sub B<<> ? List Perl commands to run before each prompt. B<<> I Define Perl command to run before each prompt. B<<<> I Add to the list of Perl commands to run before each prompt. +B<< *> Delete the list of perl commands to run before each prompt. B<>> ? List Perl commands to run after each prompt. B<>> I Define Perl command to run after each prompt. B<>>B<>> I Add to the list of Perl commands to run after each prompt. +B<>>B< *> Delete the list of Perl commands to run after each prompt. B<{> I Define debugger command to run before each prompt. B<{> ? List debugger commands to run before each prompt. B<{{> I Add to the list of debugger commands to run before each prompt. +B<{ *> Delete the list of debugger commands to run before each prompt. B<$prc> I Redo a previous command (default previous command). B<$prc> I<-number> Redo number'th-to-last command. B<$prc> I Redo last command that started with I. @@ -3647,6 +3594,7 @@ sub cmd_pre580_null { } sub cmd_pre580_a { + my $xcmd = shift; # my $cmd = shift; if ($cmd =~ /^(\d*)\s*(.*)/) { $i = $1 || $line; $j = $2; @@ -3666,6 +3614,7 @@ sub cmd_pre580_a { } sub cmd_pre580_b { + my $xcmd = shift; # my $cmd = shift; my $dbline = shift; if ($cmd =~ /^load\b\s*(.*)/) { @@ -3691,6 +3640,7 @@ sub cmd_pre580_b { } sub cmd_pre580_D { + my $xcmd = shift; # my $cmd = shift; if ($cmd =~ /^\s*$/) { print $OUT "Deleting all breakpoints...\n"; @@ -3720,6 +3670,7 @@ sub cmd_pre580_D { } sub cmd_pre580_h { + my $xcmd = shift; # my $cmd = shift; if ($cmd =~ /^\s*$/) { print_help($pre580_help); @@ -3740,6 +3691,7 @@ sub cmd_pre580_h { } sub cmd_pre580_W { + my $xcmd = shift; # my $cmd = shift; if ($cmd =~ /^$/) { $trace &= ~2; @@ -3754,6 +3706,67 @@ sub cmd_pre580_W { } } +sub cmd_pre590_prepost { + my $cmd = shift; + my $line = shift || '*'; # delete + my $dbline = shift; + + return &cmd_prepost($cmd, $line, $dbline); +} + +sub cmd_prepost { # cannot do &cmd_<(), <, <<, >>, {, {{, etc. + my $cmd = shift; + my $line = shift || '?'; + + my $which = ''; + my $aref = []; + if ($cmd =~ /^\/o) { + $which = 'post-perl'; + $aref = $post; + } elsif ($cmd =~ /^\{/o) { + if ($cmd =~ /^\{.*\}$/o && unbalanced(substr($cmd,1))) { + print $OUT "$cmd is now a debugger command\nuse `;$cmd' if you mean Perl code\n"; + # $DB::cmd = "h $cmd"; + # redo CMD; + } else { + $which = 'pre-debugger'; + $aref = $pretype; + } + } + + unless ($which) { + print $OUT "Confused by command: $cmd\n"; + } else { + if ($line =~ /^\s*\?\s*$/o) { + unless (@$aref) { + print $OUT "No $which actions.\n"; +# print $OUT "If you meant to delete them all - use '$cmd *' or 'o commandSet=pre590'\n"; # hint + } else { + print $OUT "$which commands:\n"; + foreach my $action (@$aref) { + print $OUT "\t$cmd -- $action\n"; + } + } + } else { + if (length($cmd) == 1) { + if ($line =~ /^\s*\*\s*$/o) { + @$aref = (); # delete + print $OUT "All $cmd actions cleared.\n"; + } else { + @$aref = action($line); # set + } + } elsif (length($cmd) == 2) { # append + push @$aref, action($line); + } else { + print $OUT "Confused by strange length of $which command($cmd)...\n"; + } + } + } +} + package DB::fake; sub at_exit { @@ -3763,4 +3776,3 @@ sub at_exit { package DB; # Do not trace this 1; below! 1; -