for perl5db.pl against missing args destroying pre-post command setups

Message-ID: <B374141B0A424D4F9CF143CC51B3ADD98579DB@NZURC900PEX1.ubsgs.ubsgroup.net>

p4raw-id: //depot/perl@18800

1 files changed, 108 insertions, 96 deletions

diff --git a/lib/perl5db.pl b/lib/perl5db.pl
index f43d8383fb..31a562dd72 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 <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;
-