perl5db.pl

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

			  print $OUT " $file:\n";
			  for $line (sort {$a <=> $b} keys %$db) {
				print $OUT "  $line:\n";
				my ($stop,$action) = split(/\0/, $$db{$line});
				print $OUT "    break if (", $stop, ")\n"
				  if $stop;
				print $OUT "    action:  ", $action, "\n"
				  if $action;
				last if $signal;
			  }
			  last if $signal;
			}
		      }
		      if (%break_on_load) {
			print $OUT "Breakpoints on load:\n";
			my $file;
			for $file (keys %break_on_load) {
			  print $OUT " $file\n";
			  last if $signal;
			}
		      }
		      if ($trace & 2) {
			print $OUT "Watch-expressions:\n";
			my $expr;
			for $expr (@to_watch) {
			  print $OUT " $expr\n";
			  last if $signal;
			}
		      }
		      next CMD; };
		    $cmd =~ /^b\b\s*load\b\s*(.*)/ && do {
			my $file = $1; $file =~ s/\s+$//;
			{
			  $break_on_load{$file} = 1;
			  $break_on_load{$::INC{$file}} = 1 if $::INC{$file};
			  $file .= '.pm', redo unless $file =~ /\./;
			}
			$had_breakpoints{$file} |= 1;
			print $OUT "Will stop on load of `@{[join '\', `', sort keys %break_on_load]}'.\n";
			next CMD; };
		    $cmd =~ /^b\b\s*(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
			my $cond = length $3 ? $3 : '1';
			my ($subname, $break) = ($2, $1 eq 'postpone');
			$subname =~ s/\'/::/g;
			$subname = "${'package'}::" . $subname
			  unless $subname =~ /::/;
			$subname = "main".$subname if substr($subname,0,2) eq "::";
			$postponed{$subname} = $break 
			  ? "break +0 if $cond" : "compile";
			next CMD; };
		    $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/ && do {
			$subname = $1;
			$cond = length $2 ? $2 : '1';
			$subname =~ s/\'/::/g;
			$subname = "${'package'}::" . $subname
			  unless $subname =~ /::/;
			$subname = "main".$subname if substr($subname,0,2) eq "::";
			# Filename below can contain ':'
			($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
			$i += 0;
			if ($i) {
			    local $filename = $file;
			    local *dbline = $main::{'_<' . $filename};
			    $had_breakpoints{$filename} |= 1;
			    $max = $#dbline;
			    ++$i while $dbline[$i] == 0 && $i < $max;
			    $dbline{$i} =~ s/^[^\0]*/$cond/;
			} else {
			    print $OUT "Subroutine $subname not found.\n";
			}
			next CMD; };
		    $cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do {
			$i = $1 || $line;
			$cond = length $2 ? $2 : '1';
			if ($dbline[$i] == 0) {
			    print $OUT "Line $i not breakable.\n";
			} else {
			    $had_breakpoints{$filename} |= 1;
			    $dbline{$i} =~ s/^[^\0]*/$cond/;
			}
			next CMD; };
		    $cmd =~ /^d\b\s*(\d*)/ && do {
			$i = $1 || $line;
                        if ($dbline[$i] == 0) {
                            print $OUT "Line $i not breakable.\n";
                        } else {
			    $dbline{$i} =~ s/^[^\0]*//;
			    delete $dbline{$i} if $dbline{$i} eq '';
                        }
			next CMD; };
		    $cmd =~ /^A$/ && do {
		      print $OUT "Deleting all actions...\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[^\0]*//;
				delete $dbline{$i} if $dbline{$i} eq '';
			    }
			}
			
			unless ($had_breakpoints{$file} &= ~2) {
			    delete $had_breakpoints{$file};
			}
		      }
		      next CMD; };
		    $cmd =~ /^O\s*$/ && do {
			for (@options) {
			    &dump_option($_);
			}
			next CMD; };
		    $cmd =~ /^O\s*(\S.*)/ && do {
			parse_options($1);
			next CMD; };
		    $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; };
		    $cmd =~ /^a\b\s*(\d*)\s*(.*)/ && do {
			$i = $1 || $line; $j = $2;
			if (length $j) {
			    if ($dbline[$i] == 0) {
				print $OUT "Line $i may not have an action.\n";
			    } else {
				$had_breakpoints{$filename} |= 2;
				$dbline{$i} =~ s/\0[^\0]*//;
				$dbline{$i} .= "\0" . action($j);
			    }
			} else {
			    $dbline{$i} =~ s/\0[^\0]*//;
			    delete $dbline{$i} if $dbline{$i} eq '';
			}
			next CMD; };
		    $cmd =~ /^n$/ && do {
		        end_report(), next CMD if $finished and $level <= 1;
			$single = 2;
			$laststep = $cmd;
			last CMD; };
		    $cmd =~ /^s$/ && do {
		        end_report(), next CMD if $finished and $level <= 1;
			$single = 1;
			$laststep = $cmd;
			last CMD; };
		    $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {
		        end_report(), next CMD if $finished and $level <= 1;
			$subname = $i = $1;
			#  Probably not needed, since we finish an interactive
			#  sub-session anyway...
			# local $filename = $filename;
			# local *dbline = *dbline;	# XXX Would this work?!
			if ($i =~ /\D/) { # subroutine name
			    $subname = $package."::".$subname 
			        unless $subname =~ /::/;
			    ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
			    $i += 0;
			    if ($i) {
			        $filename = $file;
				*dbline = $main::{'_<' . $filename};
				$had_breakpoints{$filename} |= 1;
				$max = $#dbline;
				++$i while $dbline[$i] == 0 && $i < $max;
			    } else {
				print $OUT "Subroutine $subname not found.\n";
				next CMD; 
			    }
			}
			if ($i) {
			    if ($dbline[$i] == 0) {
				print $OUT "Line $i not breakable.\n";
				next CMD;
			    }
			    $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
			}
			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_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";
			my (@script, @flags, $cl);
			push @flags, '-w' if $ini_warn;
			# Put all the old includes at the start to get
			# the same debugger.
			for (@ini_INC) {
			  push @flags, '-I', $_;
			}
			# Arrange for setting the old INC:
			set_list("PERLDB_INC", @ini_INC);
			if ($0 eq '-e') {
			  for (1..$#{'::_<-e'}) { # The first line is PERL5DB
			        chomp ($cl =  ${'::_<-e'}[$_]);
			    push @script, '-e', $cl;
			  }
			} else {
			  @script = $0;
			}
			set_list("PERLDB_HIST", 
				 $term->Features->{getHistory} 
				 ? $term->GetHistory : @hist);
			my @had_breakpoints = keys %had_breakpoints;
			set_list("PERLDB_VISITED", @had_breakpoints);
			set_list("PERLDB_OPT", %option);
			set_list("PERLDB_ON_LOAD", %break_on_load);
			my @hard;
			for (0 .. $#had_breakpoints) {
			  my $file = $had_breakpoints[$_];
			  *dbline = $main::{'_<' . $file};
			  next unless %dbline or $postponed_file{$file};
			  (push @hard, $file), next 
			    if $file =~ /^\(eval \d+\)$/;
			  my @add;
			  @add = %{$postponed_file{$file}}
			    if $postponed_file{$file};
			  set_list("PERLDB_FILE_$_", %dbline, @add);
			}
			for (@hard) { # Yes, really-really...
			  # Find the subroutines in this eval
			  *dbline = $main::{'_<' . $_};
			  my ($quoted, $sub, %subs, $line) = quotemeta $_;
			  for $sub (keys %sub) {
			    next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
			    $subs{$sub} = [$1, $2];
			  }
			  unless (%subs) {
			    print $OUT
			      "No subroutines in $_, ignoring breakpoints.\n";
			    next;
			  }
			LINES: for $line (keys %dbline) {
			    # One breakpoint per sub only:
			    my ($offset, $sub, $found);
			  SUBS: for $sub (keys %subs) {
			      if ($subs{$sub}->[1] >= $line # Not after the subroutine
				  and (not defined $offset # Not caught
				       or $offset < 0 )) { # or badly caught
				$found = $sub;
				$offset = $line - $subs{$sub}->[0];
				$offset = "+$offset", last SUBS if $offset >= 0;
			      }
			    }
			    if (defined $offset) {
			      $postponed{$found} =
				"break $offset if $dbline{$line}";
			    } else {
			      print $OUT "Breakpoint in $_:$line ignored: after all the subroutines.\n";
			    }
			  }
			}
			set_list("PERLDB_POSTPONE", %postponed);
			set_list("PERLDB_PRETYPE", @$pretype);
			set_list("PERLDB_PRE", @$pre);
			set_list("PERLDB_POST", @$post);
			set_list("PERLDB_TYPEAHEAD", @typeahead);
			$ENV{PERLDB_RESTART} = 1;
			#print "$^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS";
			exec $^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS;
			print $OUT "exec failed: $!\n";
			last CMD; };
		    $cmd =~ /^T$/ && do {
			print_trace($OUT, 1); # skip DB
			next CMD; };
		    $cmd =~ /^W\s*$/ && do {
			$trace &= ~2;
			@to_watch = @old_watch = ();
			next CMD; };
		    $cmd =~ /^W\b\s*(.*)/s && do {
			push @to_watch, $1;
			$evalarg = $1;
			my ($val) = &eval;
			$val = (defined $val) ? "'$val'" : 'undef' ;
			push @old_watch, $val;
			$trace |= 2;
			next CMD; };
		    $cmd =~ /^\/(.*)$/ && do {
			$inpat = $1;
			$inpat =~ s:([^\\])/$:$1:;
			if ($inpat ne "") {
			    # squelch the sigmangler
			    local $SIG{__DIE__};
			    local $SIG{__WARN__};
			    eval '$inpat =~ m'."\a$inpat\a";	
			    if ($@ ne "") {
				print $OUT "$@";
				next CMD;
			    }
			    $pat = $inpat;
			}
			$end = $start;
			$incr = -1;
			eval '
			    for (;;) {
				++$start;
				$start = 1 if ($start > $max);
				last if ($start == $end);
				if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
				    if ($slave_editor) {
					print $OUT "\032\032$filename:$start:0\n";
				    } else {
					print $OUT "$start:\t", $dbline[$start], "\n";
				    }
				    last;
				}
			    } ';
			print $OUT "/$pat/: not found\n" if ($start == $end);
			next CMD; };
		    $cmd =~ /^\?(.*)$/ && do {
			$inpat = $1;
			$inpat =~ s:([^\\])\?$:$1:;
			if ($inpat ne "") {
			    # squelch the sigmangler
			    local $SIG{__DIE__};
			    local $SIG{__WARN__};
			    eval '$inpat =~ m'."\a$inpat\a";	
			    if ($@ ne "") {
				print $OUT $@;
				next CMD;
			    }
			    $pat = $inpat;
			}
			$end = $start;
			$incr = -1;
			eval '
			    for (;;) {
				--$start;
				$start = $max if ($start <= 0);
				last if ($start == $end);
				if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
				    if ($slave_editor) {
					print $OUT "\032\032$filename:$start:0\n";
				    } else {
					print $OUT "$start:\t", $dbline[$start], "\n";
				    }
				    last;
				}
			    } ';
			print $OUT "?$pat?: not found\n" if ($start == $end);
			next CMD; };
		    $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
			pop(@hist) if length($cmd) > 1;
			$i = $1 ? ($#hist-($2||1)) : ($2||$#hist);
			$cmd = $hist[$i];
			print $OUT $cmd, "\n";
			redo CMD; };
		    $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {
			&system($1);
			next CMD; };
		    $cmd =~ /^$rc([^$rc].*)$/ && do {
			$pat = "^$1";
			pop(@hist) if length($cmd) > 1;
			for ($i = $#hist; $i; --$i) {