for perl5db.pl against missing args destroying pre-post command setups
authorRichard Foley <richard.foley@rfi.net>
Wed, 19 Feb 2003 13:24:38 +0000 (14:24 +0100)
committerhv <hv@crypt.org>
Sun, 2 Mar 2003 15:16:38 +0000 (15:16 +0000)
Message-ID: <B374141B0A424D4F9CF143CC51B3ADD98579DB@NZURC900PEX1.ubsgs.ubsgroup.net>

p4raw-id: //depot/perl@18800

lib/perl5db.pl

index f43d838..31a562d 100644 (file)
@@ -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 <richard.foley@rfi.net>
+#   + 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<m> I<expr>            Evals expression in list context, prints methods callable
                on the first element of the result.
 B<m> I<class>          Prints methods callable via the given class.
 B<M>           Show versions of loaded modules.
+B<y> [I<n> [I<vars>]]  List lexical variables I<n> levels up from current sub
 
 B<<> ?                 List Perl commands to run before each prompt.
 B<<> I<expr>           Define Perl command to run before each prompt.
 B<<<> I<expr>          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<expr>           Define Perl command to run after each prompt.
 B<>>B<>> I<expr>               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<db_command>     Define debugger command to run before each prompt.
 B<{> ?                 List debugger commands to run before each prompt.
 B<{{> I<db_command>    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<number>      Redo a previous command (default previous command).
 B<$prc> I<-number>     Redo number'th-to-last command.
 B<$prc> I<pattern>     Redo last command that started with I<pattern>.
@@ -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 = 'pre-perl';
+               $aref  = $pre;  
+       } elsif ($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;
-