perl5db.pl

MSYS在windows下模拟了一个类unix的终端

                               );
    if (!$OUT) { die "Unable to connect to remote host: $remoteport\n"; }
    $IN = $OUT;
  }
  else {
    if (defined $console) {
      open(IN,"+<$console") || open(IN,"<$console") || open(IN,"<&STDIN");
      open(OUT,"+>$console") || open(OUT,">$console") || open(OUT,">&STDERR")
        || open(OUT,">&STDOUT");	# so we don't dongle stdout
    } else {
      open(IN,"<&STDIN");
      open(OUT,">&STDERR") || open(OUT,">&STDOUT"); # so we don't dongle stdout
      $console = 'STDIN/OUT';
    }
    # so open("|more") can read from STDOUT and so we don't dingle stdin
    $IN = \*IN;

    $OUT = \*OUT;
  }
  select($OUT);
  $| = 1;			# for DB::OUT
  select(STDOUT);

  $LINEINFO = $OUT unless defined $LINEINFO;
  $lineinfo = $console unless defined $lineinfo;

  $| = 1;			# for real STDOUT

  $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
  unless ($runnonstop) {
    print $OUT "\nLoading DB routines from $header\n";
    print $OUT ("Editor support ",
		$slave_editor ? "enabled" : "available",
		".\n");
    print $OUT "\nEnter h or `h h' for help, or `$doccmd perldebug' for more help.\n\n";
  }
}

@ARGS = @ARGV;
for (@args) {
    s/\'/\\\'/g;
    s/(.*)/'$1'/ unless /^-?[\d.]+$/;
}

if (defined &afterinit) {	# May be defined in $rcfile
  &afterinit();
}

$I_m_init = 1;

############################################################ Subroutines

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_depth; ) {
	    $stack[$i++] &= ~1;
	}
	$single = 0;
	# return;			# Would not print trace!
      } elsif ($ImmediateStop) {
	$ImmediateStop = 0;
	$signal = 1;
      }
    }
    $runnonstop = 0 if $single or $signal; # Disable it if interactive.
    &save;
    ($package, $filename, $line) = caller;
    $filename_ini = $filename;
    $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
      "package $package;";	# this won't let them modify, alas
    local(*dbline) = $main::{'_<' . $filename};
    $max = $#dbline;
    if (($stop,$action) = split(/\0/,$dbline{$line})) {
	if ($stop eq '1') {
	    $signal |= 1;
	} elsif ($stop) {
	    $evalarg = "\$DB::signal |= 1 if do {$stop}"; &eval;
	    $dbline{$line} =~ s/;9($|\0)/$1/;
	}
    }
    my $was_signal = $signal;
    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]) {
	  $signal = 1;
	  print $OUT <<EOP;
Watchpoint $n:\t$to_watch[$n] changed:
    old value:\t$old_watch[$n]
    new value:\t$val
EOP
	  $old_watch[$n] = $val;
	}
      }
    }
    if ($trace & 4) {		# User-installed watch
      return if watchfunction($package, $filename, $line) 
	and not $single and not $was_signal and not ($trace & ~4);
    }
    $was_signal = $signal;
    $signal = 0;
    if ($single || ($trace & 1) || $was_signal) {
	if ($slave_editor) {
	    $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,
  B<h q>, B<h R> or B<h O> to get additional info.  
EOP
	  $package = 'main';
	  $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
	    "package $package;";	# this won't let them modify, alas
	} else {
	    $sub =~ s/\'/::/;
	    $prefix = $sub =~ /::/ ? "" : "${'package'}::";
	    $prefix .= "$sub($filename:";
	    $after = ($dbline[$line] =~ /\n$/ ? '' : "\n");
	    if (length($prefix) > 30) {
	        $position = "$prefix$line):\n$line:\t$dbline[$line]$after";
		$prefix = "";
		$infix = ":\t";
	    } else {
		$infix = "):\t";
		$position = "$prefix$line$infix$dbline[$line]$after";
	    }
	    if ($frame) {
		print $LINEINFO ' ' x $stack_depth, "$line:\t$dbline[$line]$after";
	    } else {
		print $LINEINFO $position;
	    }
	    for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { #{ vi
		last if $dbline[$i] =~ /^\s*[\;\}\#\n]/;
		last if $signal;
		$after = ($dbline[$i] =~ /\n$/ ? '' : "\n");
		$incr_pos = "$prefix$i$infix$dbline[$i]$after";
		$position .= $incr_pos;
		if ($frame) {
		    print $LINEINFO ' ' x $stack_depth, "$i:\t$dbline[$i]$after";
		} else {
		    print $LINEINFO $incr_pos;
		}
	    }
	}
    }
    $evalarg = $action, &eval if $action;
    if ($single || $was_signal) {
	local $level = $level + 1;
	foreach $evalarg (@$pre) {
	  &eval;
	}
	print $OUT $stack_depth . " levels deep in subroutine calls!\n"
	  if $single & 4;
	$start = $line;
	$incr = -1;		# for backward motion.
	@typeahead = (@$pretype, @typeahead);
      CMD:
	while (($term || &setterm),
	       ($term_pid == $$ or &resetterm),
	       defined ($cmd=&readline("  DB" . ('<' x $level) .
				       ($#hist+1) . ('>' x $level) .
				       " "))) 
        {
		$single = 0;
		$signal = 0;
		$cmd =~ s/\\$/\n/ && do {
		    $cmd .= &readline("  cont: ");
		    redo CMD;
		};
		$cmd =~ /^$/ && ($cmd = $laststep);
		push(@hist,$cmd) if length($cmd) > 1;
	      PIPE: {
		    $cmd =~ s/^\s+//s;   # trim annoying leading whitespace
		    $cmd =~ s/\s+$//s;   # trim annoying trailing whitespace
		    ($i) = split(/\s+/,$cmd);
		    if ($alias{$i}) { 
			# squelch the sigmangler
			local $SIG{__DIE__};
			local $SIG{__WARN__};
			eval "\$cmd =~ $alias{$i}";
			if ($@) {
			    print $OUT "Couldn't evaluate `$i' alias: $@";
			    next CMD;
			} 
		    }
                   $cmd =~ /^q$/ && ($fall_off_end = 1) && exit $?;
		    $cmd =~ /^h$/ && do {
			print_help($help);
			next CMD; };
		    $cmd =~ /^h\s+h$/ && do {
			print_help($summary);
			next CMD; };
		    # support long commands; otherwise bogus errors
		    # happen when you ask for h on <CR> for example
		    $cmd =~ /^h\s+(\S.*)$/ && do {      
			my $asked = $1;			# for proper errmsg
			my $qasked = quotemeta($asked); # for searching
			# XXX: finds CR but not <CR>
			if ($help =~ /^<?(?:[IB]<)$qasked/m) {
			  while ($help =~ /^(<?(?:[IB]<)$qasked([\s\S]*?)\n)(?!\s)/mg) {
			    print_help($1);
			  }
			} else {
			    print_help("B<$asked> is not a debugger command.\n");
			}
			next CMD; };
		    $cmd =~ /^t$/ && do {
			$trace ^= 1;
			print $OUT "Trace = " .
			    (($trace & 1) ? "on" : "off" ) . "\n";
			next CMD; };
		    $cmd =~ /^S(\s+(!)?(.+))?$/ && do {
			$Srev = defined $2; $Spatt = $3; $Snocheck = ! defined $1;
			foreach $subname (sort(keys %sub)) {
			    if ($Snocheck or $Srev^($subname =~ /$Spatt/)) {
				print $OUT $subname,"\n";
			    }
			}
			next CMD; };
		    $cmd =~ /^v$/ && do {
			list_versions(); next CMD};
		    $cmd =~ s/^X\b/V $package/;
		    $cmd =~ /^V$/ && do {
			$cmd = "V $package"; };
		    $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
			local ($savout) = select($OUT);
			$packname = $1;
			@vars = split(' ',$2);
			do 'dumpvar.pl' unless defined &main::dumpvar;
			if (defined &main::dumpvar) {
			    local $frame = 0;
			    local $doret = -2;
			    # must detect sigpipe failures
			    eval { &main::dumpvar($packname,@vars) };
			    if ($@) {
				die unless $@ =~ /dumpvar print failed/;
			    } 
			} else {
			    print $OUT "dumpvar.pl not available.\n";
			}
			select ($savout);
			next CMD; };
		    $cmd =~ s/^x\b/ / && do { # So that will be evaled
			$onetimeDump = 'dump'; };
		    $cmd =~ s/^m\s+([\w:]+)\s*$/ / && do {
			methods($1); next CMD};
		    $cmd =~ s/^m\b/ / && do { # So this will be evaled
			$onetimeDump = 'methods'; };
		    $cmd =~ /^f\b\s*(.*)/ && do {
			$file = $1;
			$file =~ s/\s+$//;
			if (!$file) {
			    print $OUT "The old f command is now the r command.\n";
			    print $OUT "The new f command switches filenames.\n";
			    next CMD;
			}
			if (!defined $main::{'_<' . $file}) {
			    if (($try) = grep(m#^_<.*$file#, keys %main::)) {{
					      $try = substr($try,2);
					      print $OUT "Choosing $try matching `$file':\n";
					      $file = $try;
					  }}
			}
			if (!defined $main::{'_<' . $file}) {
			    print $OUT "No file matching `$file' is loaded.\n";
			    next CMD;
			} elsif ($file ne $filename) {
			    *dbline = $main::{'_<' . $file};
			    $max = $#dbline;
			    $filename = $file;
			    $start = 1;
			    $cmd = "l";
			  } else {
			    print $OUT "Already in $file.\n";
			    next CMD;
			  }
		      };
		    $cmd =~ s/^l\s+-\s*$/-/;
		    $cmd =~ /^([lb])\b\s*(\$.*)/s && do {
			$evalarg = $2;
			my ($s) = &eval;
			print($OUT "Error: $@\n"), next CMD if $@;
			$s = CvGV_name($s);
			print($OUT "Interpreted as: $1 $s\n");
			$cmd = "$1 $s";
		    };
		    $cmd =~ /^l\b\s*([\':A-Za-z_][\':\w]*(\[.*\])?)/s && do {
			$subname = $1;
			$subname =~ s/\'/::/;
			$subname = $package."::".$subname 
			  unless $subname =~ /::/;
			$subname = "main".$subname if substr($subname,0,2) eq "::";
			@pieces = split(/:/,find_sub($subname) || $sub{$subname});
			$subrange = pop @pieces;
			$file = join(':', @pieces);
			if ($file ne $filename) {
			    print $OUT "Switching to file '$file'.\n"
				unless $slave_editor;
			    *dbline = $main::{'_<' . $file};
			    $max = $#dbline;
			    $filename = $file;
			}
			if ($subrange) {
			    if (eval($subrange) < -$window) {
				$subrange =~ s/-.*/+/;
			    }
			    $cmd = "l $subrange";
			} else {
			    print $OUT "Subroutine $subname not found.\n";
			    next CMD;
			} };
		    $cmd =~ /^\.$/ && do {
			$incr = -1;		# for backward motion.
			$start = $line;
			$filename = $filename_ini;
			*dbline = $main::{'_<' . $filename};
			$max = $#dbline;
			print $LINEINFO $position;
			next CMD };
		    $cmd =~ /^w\b\s*(\d*)$/ && do {
			$incr = $window - 1;
			$start = $1 if $1;
			$start -= $preview;
			#print $OUT 'l ' . $start . '-' . ($start + $incr);
			$cmd = 'l ' . $start . '-' . ($start + $incr); };
		    $cmd =~ /^-$/ && do {
			$start -= $incr + $window + 1;
			$start = 1 if $start <= 0;
			$incr = $window - 1;
			$cmd = 'l ' . ($start) . '+'; };
		    $cmd =~ /^l$/ && do {
			$incr = $window - 1;
			$cmd = 'l ' . $start . '-' . ($start + $incr); };
		    $cmd =~ /^l\b\s*(\d*)\+(\d*)$/ && do {
			$start = $1 if $1;
			$incr = $2;
			$incr = $window - 1 unless $incr;
			$cmd = 'l ' . $start . '-' . ($start + $incr); };
		    $cmd =~ /^l\b\s*((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
			$end = (!defined $2) ? $max : ($4 ? $4 : $2);
			$end = $max if $end > $max;
			$i = $2;
			$i = $line if $i eq '.';
			$i = 1 if $i < 1;
			$incr = $end - $i;
			if ($slave_editor) {
			    print $OUT "\032\032$filename:$i:0\n";
			    $i = $end;
			} else {
			    for (; $i <= $end; $i++) {
			        ($stop,$action) = split(/\0/, $dbline{$i});
			        $arrow = ($i==$line 
					  and $filename eq $filename_ini) 
				  ?  '==>' 
				    : ($dbline[$i]+0 ? ':' : ' ') ;
				$arrow .= 'b' if $stop;
				$arrow .= 'a' if $action;
				print $OUT "$i$arrow\t", $dbline[$i];
				$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;
			next CMD; };
		    $cmd =~ /^D$/ && do {
		      print $OUT "Deleting all breakpoints...\n";
		      my $file;
		      for $file (keys %had_breakpoints) {
			local *dbline = $main::{'_<' . $file};
			my $max = $#dbline;
			my $was;
			
			for ($i = 1; $i <= $max ; $i++) {
			    if (defined $dbline{$i}) {
				$dbline{$i} =~ s/^[^\0]+//;
				if ($dbline{$i} =~ s/^\0?$//) {
				    delete $dbline{$i};
				}
			    }
			}
			
			if (not $had_breakpoints{$file} &= ~1) {
			    delete $had_breakpoints{$file};
			}
		      }
		      undef %postponed;
		      undef %postponed_file;
		      undef %break_on_load;
		      next CMD; };
		    $cmd =~ /^L$/ && do {
		      my $file;
		      for $file (keys %had_breakpoints) {
			local *dbline = $main::{'_<' . $file};
			my $max = $#dbline;
			my $was;
			
			for ($i = 1; $i <= $max; $i++) {
			    if (defined $dbline{$i}) {
			        print $OUT "$file:\n" unless $was++;
				print $OUT " $i:\t", $dbline[$i];
				($stop,$action) = split(/\0/, $dbline{$i});
				print $OUT "   break if (", $stop, ")\n"
				  if $stop;
				print $OUT "   action:  ", $action, "\n"
				  if $action;
				last if $signal;
			    }
			}
		      }
		      if (%postponed) {
			print $OUT "Postponed breakpoints in subroutines:\n";
			my $subname;
			for $subname (keys %postponed) {
			  print $OUT " $subname\t$postponed{$subname}\n";
			  last if $signal;
			}
		      }
		      my @have = map { # Combined keys
			keys %{$postponed_file{$_}}
		      } keys %postponed_file;
		      if (@have) {
			print $OUT "Postponed breakpoints in files:\n";
			my ($file, $line);
			for $file (keys %postponed_file) {
			  my $db = $postponed_file{$file};