X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2Fperl5db.pl;h=7b0567c4039f7c858a4ed162451c035af06ed480;hb=9bea678f36dc293400ada67aa122ef456a9dcf74;hp=bad153c57462b1d9c691917028db26f6505cb7a0;hpb=ee239bfe47dc5d504cf50bb8f48401031aa791d7;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/lib/perl5db.pl b/lib/perl5db.pl
index bad153c..7b0567c 100644
--- a/lib/perl5db.pl
+++ b/lib/perl5db.pl
@@ -2,7 +2,7 @@ package DB;
 
 # Debugger for Perl 5.00x; perl5db.pl patch level:
 
-$VERSION = 1.04;
+$VERSION = 1.0403;
 $header = "perl5db.pl version $VERSION";
 
 # Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich)
@@ -235,7 +235,11 @@ $pretype = [] unless defined $pretype;
 warnLevel($warnLevel);
 dieLevel($dieLevel);
 signalLevel($signalLevel);
-&pager(defined($ENV{PAGER}) ? $ENV{PAGER} : "|more") unless defined $pager;
+&pager((defined($ENV{PAGER}) 
+	? $ENV{PAGER}
+	: ($^O eq 'os2' 
+	   ? 'cmd /c more' 
+	   : 'more'))) unless defined $pager;
 &recallCommand("!") unless defined $prc;
 &shellBang("!") unless defined $psh;
 $maxtrace = 400 unless defined $maxtrace;
@@ -292,7 +296,10 @@ if ($notty) {
 
   #require Term::ReadLine;
 
-  if (-e "/dev/tty") {
+  if ($^O =~ /cygwin/) {
+    # /dev/tty is binary. use stdin for textmode
+    undef $console;
+  } elsif (-e "/dev/tty") {
     $console = "/dev/tty";
   } elsif ($^O eq 'dos' or -e "con" or $^O eq 'MSWin32') {
     $console = "con";
@@ -309,6 +316,10 @@ if ($notty) {
     $console = undef;
   }
 
+  if ($^O eq 'epoc') {
+    $console = undef;
+  }
+
   $console = $tty if defined $tty;
 
   if (defined $console) {
@@ -339,7 +350,7 @@ if ($notty) {
     print $OUT ("Emacs support ",
 		$emacs ? "enabled" : "available",
 		".\n");
-    print $OUT "\nEnter h or `h h' for help.\n\n";
+    print $OUT "\nEnter h or `h h' for help, run `perldoc perldebug' for more help.\n\n";
   }
 }
 
@@ -361,7 +372,7 @@ sub DB {
     # _After_ the perl program is compiled, $single is set to 1:
     if ($single and not $second_time++) {
       if ($runnonstop) {	# Disable until signal
-	for ($i=0; $i <= $#stack; ) {
+	for ($i=0; $i <= $stack_depth; ) {
 	    $stack[$i++] &= ~1;
 	}
 	$single = 0;
@@ -391,6 +402,7 @@ sub DB {
     if ($trace & 2) {
       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)?
 	$val = ( (defined $val) ? "'$val'" : 'undef' );
 	if ($val ne $old_watch[$n]) {
@@ -411,11 +423,11 @@ EOP
     $was_signal = $signal;
     $signal = 0;
     if ($single || ($trace & 1) || $was_signal) {
-	$term || &setterm;
 	if ($emacs) {
 	    $position = "\032\032$filename:$line:0\n";
 	    print $LINEINFO $position;
 	} elsif ($package eq 'DB::fake') {
+	  $term || &setterm;
 	  print_help(<<EOP);
 Debugged program terminated.  Use B<q> to quit or B<R> to restart,
   use B<O> I<inhibit_exit> to avoid stopping after program termination,
@@ -438,7 +450,7 @@ EOP
 		$position = "$prefix$line$infix$dbline[$line]$after";
 	    }
 	    if ($frame) {
-		print $LINEINFO ' ' x $#stack, "$line:\t$dbline[$line]$after";
+		print $LINEINFO ' ' x $stack_depth, "$line:\t$dbline[$line]$after";
 	    } else {
 		print $LINEINFO $position;
 	    }
@@ -449,7 +461,7 @@ EOP
 		$incr_pos = "$prefix$i$infix$dbline[$i]$after";
 		$position .= $incr_pos;
 		if ($frame) {
-		    print $LINEINFO ' ' x $#stack, "$i:\t$dbline[$i]$after";
+		    print $LINEINFO ' ' x $stack_depth, "$i:\t$dbline[$i]$after";
 		} else {
 		    print $LINEINFO $incr_pos;
 		}
@@ -462,11 +474,11 @@ EOP
 	foreach $evalarg (@$pre) {
 	  &eval;
 	}
-	print $OUT $#stack . " levels deep in subroutine calls!\n"
+	print $OUT $stack_depth . " levels deep in subroutine calls!\n"
 	  if $single & 4;
 	$start = $line;
 	$incr = -1;		# for backward motion.
-	@typeahead = @$pretype, @typeahead;
+	@typeahead = (@$pretype, @typeahead);
       CMD:
 	while (($term || &setterm),
 	       ($term_pid == $$ or &resetterm),
@@ -639,8 +651,9 @@ EOP
 				$arrow .= 'b' if $stop;
 				$arrow .= 'a' if $action;
 				print $OUT "$i$arrow\t", $dbline[$i];
-				last if $signal;
+				$i++, last if $signal;
 			    }
+			    print $OUT "\n" unless $dbline[$i-1] =~ /\n$/;
 			}
 			$start = $i; # remember in case they want more
 			$start = $max if $start > $max;
@@ -878,14 +891,14 @@ EOP
 			    }
 			    $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
 			}
-			for ($i=0; $i <= $#stack; ) {
+			for ($i=0; $i <= $stack_depth; ) {
 			    $stack[$i++] &= ~1;
 			}
 			last CMD; };
 		    $cmd =~ /^r$/ && do {
 		        end_report(), next CMD if $finished and $level <= 1;
-			$stack[$#stack] |= 1;
-			$doret = $option{PrintRet} ? $#stack - 1 : -2;
+			$stack[$stack_depth] |= 1;
+			$doret = $option{PrintRet} ? $stack_depth - 1 : -2;
 			last CMD; };
 		    $cmd =~ /^R$/ && do {
 		        print $OUT "Warning: some settings and command-line options may be lost!\n";
@@ -1045,7 +1058,7 @@ EOP
 			pop(@hist) if length($cmd) > 1;
 			$i = $1 ? ($#hist-($2?$2:1)) : ($2?$2:$#hist);
 			$cmd = $hist[$i];
-			print $OUT $cmd;
+			print $OUT $cmd, "\n";
 			redo CMD; };
 		    $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {
 			&system($1);
@@ -1061,7 +1074,7 @@ EOP
 			    next CMD;
 			}
 			$cmd = $hist[$i];
-			print $OUT $cmd;
+			print $OUT $cmd, "\n";
 			redo CMD; };
 		    $cmd =~ /^$sh$/ && do {
 			&system($ENV{SHELL}||"/bin/sh");
@@ -1168,24 +1181,26 @@ sub sub {
     if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') {
 	$al = " for $$sub";
     }
-    push(@stack, $single);
+    local $stack_depth = $stack_depth + 1; # Protect from non-local exits
+    $#stack = $stack_depth;
+    $stack[-1] = $single;
     $single &= 1;
-    $single |= 4 if $#stack == $deep;
+    $single |= 4 if $stack_depth == $deep;
     ($frame & 4 
-     ? ( (print $LINEINFO ' ' x ($#stack - 1), "in  "), 
+     ? ( (print $LINEINFO ' ' x ($stack_depth - 1), "in  "), 
 	 # Why -1? But it works! :-(
 	 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
-     : print $LINEINFO ' ' x ($#stack - 1), "entering $sub$al\n") if $frame;
+     : print $LINEINFO ' ' x ($stack_depth - 1), "entering $sub$al\n") if $frame;
     if (wantarray) {
 	@ret = &$sub;
-	$single |= pop(@stack);
+	$single |= $stack[$stack_depth--];
 	($frame & 4 
-	 ? ( (print $LINEINFO ' ' x $#stack, "out "), 
+	 ? ( (print $LINEINFO ' ' x $stack_depth, "out "), 
 	     print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
-	 : print $LINEINFO ' ' x $#stack, "exited $sub$al\n") if $frame & 2;
-	if ($doret eq $#stack or $frame & 16) {
-            my $fh = ($doret eq $#stack ? $OUT : $LINEINFO);
-	    print $fh ' ' x $#stack if $frame & 16;
+	 : print $LINEINFO ' ' x $stack_depth, "exited $sub$al\n") if $frame & 2;
+	if ($doret eq $stack_depth or $frame & 16) {
+            my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
+	    print $fh ' ' x $stack_depth if $frame & 16;
 	    print $fh "list context return from $sub:\n"; 
 	    dumpit($fh, \@ret );
 	    $doret = -2;
@@ -1197,14 +1212,14 @@ sub sub {
         } else {
             &$sub; undef $ret;
         };
-	$single |= pop(@stack);
+	$single |= $stack[$stack_depth--];
 	($frame & 4 
-	 ? ( (print $LINEINFO ' ' x $#stack, "out "), 
+	 ? ( (print $LINEINFO ' ' x $stack_depth, "out "), 
 	      print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
-	 : print $LINEINFO ' ' x $#stack, "exited $sub$al\n") if $frame & 2;
-	if ($doret eq $#stack or $frame & 16 and defined wantarray) {
-            my $fh = ($doret eq $#stack ? $OUT : $LINEINFO);
-	    print $fh (' ' x $#stack) if $frame & 16;
+	 : print $LINEINFO ' ' x $stack_depth, "exited $sub$al\n") if $frame & 2;
+	if ($doret eq $stack_depth or $frame & 16 and defined wantarray) {
+            my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
+	    print $fh (' ' x $stack_depth) if $frame & 16;
 	    print $fh (defined wantarray 
 			 ? "scalar context return from $sub: " 
 			 : "void context return from $sub\n");
@@ -1225,7 +1240,6 @@ sub save {
 sub eval {
     my @res;
     {
-	local (@stack) = @stack; # guard against recursive debugging
 	my $otrace = $trace;
 	my $osingle = $single;
 	my $od = $^D;
@@ -1283,7 +1297,7 @@ sub postponed {
   $filename =~ s/^_<//;
   $signal = 1, print $OUT "'$filename' loaded...\n"
     if $break_on_load{$filename};
-  print $LINEINFO ' ' x $#stack, "Package $filename.\n" if $frame;
+  print $LINEINFO ' ' x $stack_depth, "Package $filename.\n" if $frame;
   return unless $postponed_file{$filename};
   $had_breakpoints{$filename}++;
   #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
@@ -1431,7 +1445,6 @@ sub system {
 sub setterm {
     local $frame = 0;
     local $doret = -2;
-    local @stack = @stack;		# Prevent growth by failing `use'.
     eval { require Term::ReadLine } or die $@;
     if ($notty) {
 	if ($tty) {
@@ -1746,13 +1759,7 @@ sub list_versions {
     } 
     $version{$file} .= $INC{$file};
   }
-  do 'dumpvar.pl' unless defined &main::dumpValue;
-  if (defined &main::dumpValue) {
-    local $frame = 0;
-    &main::dumpValue(\%version);
-  } else {
-    print $OUT "dumpvar.pl not available.\n";
-  }
+  dumpit($OUT,\%version);
 }
 
 sub sethelp {
@@ -1860,6 +1867,8 @@ B<R>		Pure-man-restart of debugger, some of debugger state
 		history, breakpoints and actions, debugger B<O>ptions 
 		and the following command-line options: I<-w>, I<-I>, I<-e>.
 B<h> [I<db_command>]	Get help [on a specific debugger command], enter B<|h> to page.
+		Complete description of debugger is available in B<perldebug>
+		section of Perl documention
 B<h h>		Summary of debugger commands.
 B<q> or B<^D>		Quit. Set B<\$DB::finished = 0> to debug global destruction.
 
@@ -1869,18 +1878,17 @@ I<List/search source lines:>               I<Control script execution:>
   B<l> [I<ln>|I<sub>]  List source code            B<T>           Stack trace
   B<-> or B<.>      List previous/current line  B<s> [I<expr>]    Single step [in expr]
   B<w> [I<line>]    List around line            B<n> [I<expr>]    Next, steps over subs
-  B<f> I<filename>  View source in file         <B<CR>>        Repeat last B<n> or B<s>
+  B<f> I<filename>  View source in file         <B<CR>/B<Enter>>  Repeat last B<n> or B<s>
   B</>I<pattern>B</> B<?>I<patt>B<?>   Search forw/backw    B<r>           Return from subroutine
   B<v>	      Show versions of modules    B<c> [I<ln>|I<sub>]  Continue until position
 I<Debugger controls:>                        B<L>           List break/watch/actions
   B<O> [...]     Set debugger options        B<t> [I<expr>]    Toggle trace [trace expr]
-  B<<>[B<<>] or B<{>[B<{>] [I<cmd>]   Do before prompt   B<b> [I<ln>|I<event>] [I<cnd>]  Set breakpoint
-  B<>>[B<>>] [I<cmd>]  Do after prompt             B<b> I<sub> [I<cnd>] Set breakpoint for sub
+  B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I<cmd>] Do pre/post-prompt B<b> [I<ln>|I<event>|I<sub>] [I<cnd>] Set breakpoint
   B<$prc> [I<N>|I<pat>]   Redo a previous command     B<d> [I<ln>] or B<D> Delete a/all breakpoints
   B<H> [I<-num>]    Display last num commands   B<a> [I<ln>] I<cmd>  Do cmd before line
   B<=> [I<a> I<val>]   Define/list an alias        B<W> I<expr>      Add a watch expression
   B<h> [I<db_cmd>]  Get help on command         B<A> or B<W>      Delete all actions/watch
-  B<|>[B<|>]I<dbcmd>   Send output to pager        B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
+  B<|>[B<|>]I<db_cmd>  Send output to pager        B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
   B<q> or B<^D>     Quit			  B<R>	      Attempt a restart
 I<Data Examination:>	      B<expr>     Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
   B<x>|B<m> I<expr>	Evals expr in array context, dumps the result or lists methods.
@@ -1888,6 +1896,7 @@ I<Data Examination:>	      B<expr>     Execute perl code, also see: B<s>,B<n>,B<
   B<S> [[B<!>]I<pat>]	List subroutine names [not] matching pattern
   B<V> [I<Pk> [I<Vars>]]	List Variables in Package.  Vars can be ~pattern or !pattern.
   B<X> [I<Vars>]	Same as \"B<V> I<current_package> [I<Vars>]\".
+I<More help for> B<db_cmd>I<:>  Type B<h> I<cmd_letter>  Run B<perldoc perldebug> for more help.
 END_SUM
 				# ')}}; # Fix balance of Emacs parsing
 }
@@ -2072,6 +2081,7 @@ BEGIN {			# This does not compile, alas.
   # @stack and $doret are needed in sub sub, which is called for DB::postponed.
   # Triggers bug (?) in perl is we postpone this until runtime:
   @postponed = @stack = (0);
+  $stack_depth = 0;		# Localized $#stack
   $doret = -2;
   $frame = 0;
 }