perl5db.pl

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

			    last if $hist[$i] =~ /$pat/;
			}
			if (!$i) {
			    print $OUT "No such command!\n\n";
			    next CMD;
			}
			$cmd = $hist[$i];
			print $OUT $cmd, "\n";
			redo CMD; };
		    $cmd =~ /^$sh$/ && do {
			&system($ENV{SHELL}||"/bin/sh");
			next CMD; };
		    $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do {
			# XXX: using csh or tcsh destroys sigint retvals!
			#&system($1);  # use this instead
			&system($ENV{SHELL}||"/bin/sh","-c",$1);
			next CMD; };
		    $cmd =~ /^H\b\s*(-(\d+))?/ && do {
			$end = $2 ? ($#hist-$2) : 0;
			$hist = 0 if $hist < 0;
			for ($i=$#hist; $i>$end; $i--) {
			    print $OUT "$i: ",$hist[$i],"\n"
			      unless $hist[$i] =~ /^.?$/;
			};
			next CMD; };
		    $cmd =~ /^(?:man|(?:perl)?doc)\b(?:\s+([^(]*))?$/ && do {
			runman($1);
			next CMD; };
		    $cmd =~ s/^p$/print {\$DB::OUT} \$_/;
		    $cmd =~ s/^p\b/print {\$DB::OUT} /;
		    $cmd =~ s/^=\s*// && do {
			my @keys;
			if (length $cmd == 0) {
			    @keys = sort keys %alias;
			} 
                        elsif (my($k,$v) = ($cmd =~ /^(\S+)\s+(\S.*)/)) {
			    # can't use $_ or kill //g state
			    for my $x ($k, $v) { $x =~ s/\a/\\a/g }
			    $alias{$k} = "s\a$k\a$v\a";
			    # squelch the sigmangler
			    local $SIG{__DIE__};
			    local $SIG{__WARN__};
			    unless (eval "sub { s\a$k\a$v\a }; 1") {
				print $OUT "Can't alias $k to $v: $@\n"; 
				delete $alias{$k};
				next CMD;
			    } 
			    @keys = ($k);
			} 
			else {
			    @keys = ($cmd);
			} 
			for my $k (@keys) {
			    if ((my $v = $alias{$k}) =~ ss\a$k\a(.*)\a$1) {
				print $OUT "$k\t= $1\n";
			    } 
			    elsif (defined $alias{$k}) {
				    print $OUT "$k\t$alias{$k}\n";
			    } 
			    else {
				print "No alias for $k\n";
			    } 
			}
			next CMD; };
		    $cmd =~ /^\|\|?\s*[^|]/ && do {
			if ($pager =~ /^\|/) {
			    open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
			    open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
			} else {
			    open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT");
			}
			fix_less();
			unless ($piped=open(OUT,$pager)) {
			    &warn("Can't pipe output to `$pager'");
			    if ($pager =~ /^\|/) {
				open(OUT,">&STDOUT") # XXX: lost message
				    || &warn("Can't restore DB::OUT");
				open(STDOUT,">&SAVEOUT")
				  || &warn("Can't restore STDOUT");
				close(SAVEOUT);
			    } else {
				open(OUT,">&STDOUT") # XXX: lost message
				    || &warn("Can't restore DB::OUT");
			    }
			    next CMD;
			}
			$SIG{PIPE}= \&DB::catch if $pager =~ /^\|/
			    && ("" eq $SIG{PIPE}  ||  "DEFAULT" eq $SIG{PIPE});
			$selected= select(OUT);
			$|= 1;
			select( $selected ), $selected= "" unless $cmd =~ /^\|\|/;
			$cmd =~ s/^\|+\s*//;
			redo PIPE; 
		    };
		    # XXX Local variants do not work!
		    $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
		    $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
		    $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
		}		# PIPE:
	    $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
	    if ($onetimeDump) {
		$onetimeDump = undef;
	    } elsif ($term_pid == $$) {
		print $OUT "\n";
	    }
	} continue {		# CMD:
	    if ($piped) {
		if ($pager =~ /^\|/) {
		    $? = 0;  
		    # we cannot warn here: the handle is missing --tchrist
		    close(OUT) || print SAVEOUT "\nCan't close DB::OUT\n";

		    # most of the $? crud was coping with broken cshisms
		    if ($?) {
			print SAVEOUT "Pager `$pager' failed: ";
			if ($? == -1) {
			    print SAVEOUT "shell returned -1\n";
			} elsif ($? >> 8) {
			    print SAVEOUT 
			      ( $? & 127 ) ? " (SIG#".($?&127).")" : "", 
			      ( $? & 128 ) ? " -- core dumped" : "", "\n";
			} else {
			    print SAVEOUT "status ", ($? >> 8), "\n";
			} 
		    } 

		    open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
		    open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
		    $SIG{PIPE} = "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
		    # Will stop ignoring SIGPIPE if done like nohup(1)
		    # does SIGINT but Perl doesn't give us a choice.
		} else {
		    open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT");
		}
		close(SAVEOUT);
		select($selected), $selected= "" unless $selected eq "";
		$piped= "";
	    }
	}			# CMD:
       $fall_off_end = 1 unless defined $cmd; # Emulate `q' on EOF
	foreach $evalarg (@$post) {
	  &eval;
	}
    }				# if ($single || $signal)
    ($@, $!, $^E, $,, $/, $\, $^W) = @saved;
    ();
}

# The following code may be executed now:
# BEGIN {warn 4}

sub sub {
    my ($al, $ret, @ret) = "";
    if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') {
	$al = " for $$sub";
    }
    local $stack_depth = $stack_depth + 1; # Protect from non-local exits
    $#stack = $stack_depth;
    $stack[-1] = $single;
    $single &= 1;
    $single |= 4 if $stack_depth == $deep;
    ($frame & 4 
     ? ( (print $LINEINFO ' ' x ($stack_depth - 1), "in  "), 
	 # Why -1? But it works! :-(
	 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
     : print $LINEINFO ' ' x ($stack_depth - 1), "entering $sub$al\n") if $frame;
    if (wantarray) {
	@ret = &$sub;
	$single |= $stack[$stack_depth--];
	($frame & 4 
	 ? ( (print $LINEINFO ' ' x $stack_depth, "out "), 
	     print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
	 : 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;
	}
	@ret;
    } else {
        if (defined wantarray) {
	    $ret = &$sub;
        } else {
            &$sub; undef $ret;
        };
	$single |= $stack[$stack_depth--];
	($frame & 4 
	 ? ( (print $LINEINFO ' ' x $stack_depth, "out "), 
	      print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
	 : 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");
	    dumpit( $fh, $ret ) if defined wantarray;
	    $doret = -2;
	}
	$ret;
    }
}

sub save {
    @saved = ($@, $!, $^E, $,, $/, $\, $^W);
    $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
}

# The following takes its argument via $evalarg to preserve current @_

sub eval {
    # 'my' would make it visible from user code
    #    but so does local! --tchrist  
    local @res;			
    {
	local $otrace = $trace;
	local $osingle = $single;
	local $od = $^D;
	{ ($evalarg) = $evalarg =~ /(.*)/s; }
	@res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
	$trace = $otrace;
	$single = $osingle;
	$^D = $od;
    }
    my $at = $@;
    local $saved[0];		# Preserve the old value of $@
    eval { &DB::save };
    if ($at) {
	print $OUT $at;
    } elsif ($onetimeDump eq 'dump') {
	dumpit($OUT, \@res);
    } elsif ($onetimeDump eq 'methods') {
	methods($res[0]);
    }
    @res;
}

sub postponed_sub {
  my $subname = shift;
  if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) {
    my $offset = $1 || 0;
    # Filename below can contain ':'
    my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
    if ($i) {
      $i += $offset;
      local *dbline = $main::{'_<' . $file};
      local $^W = 0;		# != 0 is magical below
      $had_breakpoints{$file} |= 1;
      my $max = $#dbline;
      ++$i until $dbline[$i] != 0 or $i >= $max;
      $dbline{$i} = delete $postponed{$subname};
    } else {
      print $OUT "Subroutine $subname not found.\n";
    }
    return;
  }
  elsif ($postponed{$subname} eq 'compile') { $signal = 1 }
  #print $OUT "In postponed_sub for `$subname'.\n";
}

sub postponed {
  if ($ImmediateStop) {
    $ImmediateStop = 0;
    $signal = 1;
  }
  return &postponed_sub
    unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
  # Cannot be done before the file is compiled
  local *dbline = shift;
  my $filename = $dbline;
  $filename =~ s/^_<//;
  $signal = 1, print $OUT "'$filename' loaded...\n"
    if $break_on_load{$filename};
  print $LINEINFO ' ' x $stack_depth, "Package $filename.\n" if $frame;
  return unless $postponed_file{$filename};
  $had_breakpoints{$filename} |= 1;
  #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
  my $key;
  for $key (keys %{$postponed_file{$filename}}) {
    $dbline{$key} = ${$postponed_file{$filename}}{$key};
  }
  delete $postponed_file{$filename};
}

sub dumpit {
    local ($savout) = select(shift);
    my $osingle = $single;
    my $otrace = $trace;
    $single = $trace = 0;
    local $frame = 0;
    local $doret = -2;
    unless (defined &main::dumpValue) {
	do 'dumpvar.pl';
    }
    if (defined &main::dumpValue) {
	&main::dumpValue(shift);
    } else {
	print $OUT "dumpvar.pl not available.\n";
    }
    $single = $osingle;
    $trace = $otrace;
    select ($savout);    
}

# Tied method do not create a context, so may get wrong message:

sub print_trace {
  my $fh = shift;
  my @sub = dump_trace($_[0] + 1, $_[1]);
  my $short = $_[2];		# Print short report, next one for sub name
  my $s;
  for ($i=0; $i <= $#sub; $i++) {
    last if $signal;
    local $" = ', ';
    my $args = defined $sub[$i]{args} 
    ? "(@{ $sub[$i]{args} })"
      : '' ;
    $args = (substr $args, 0, $maxtrace - 3) . '...' 
      if length $args > $maxtrace;
    my $file = $sub[$i]{file};
    $file = $file eq '-e' ? $file : "file `$file'" unless $short;
    $s = $sub[$i]{sub};
    $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace;    
    if ($short) {
      my $sub = @_ >= 4 ? $_[3] : $s;
      print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
    } else {
      print $fh "$sub[$i]{context} = $s$args" .
	" called from $file" . 
	  " line $sub[$i]{line}\n";
    }
  }
}

sub dump_trace {
  my $skip = shift;
  my $count = shift || 1e9;
  $skip++;
  $count += $skip;
  my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
  my $nothard = not $frame & 8;
  local $frame = 0;		# Do not want to trace this.
  my $otrace = $trace;
  $trace = 0;
  for ($i = $skip; 
       $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i); 
       $i++) {
    @a = ();
    for $arg (@args) {
      my $type;
      if (not defined $arg) {
	push @a, "undef";
      } elsif ($nothard and tied $arg) {
	push @a, "tied";
      } elsif ($nothard and $type = ref $arg) {
	push @a, "ref($type)";
      } else {
	local $_ = "$arg";	# Safe to stringify now - should not call f().
	s/([\'\\])/\\$1/g;
	s/(.*)/'$1'/s
	  unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
	s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
	s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
	push(@a, $_);
      }
    }
    $context = $context ? '@' : (defined $context ? "\$" : '.');
    $args = $h ? [@a] : undef;
    $e =~ s/\n\s*\;\s*\Z// if $e;
    $e =~ s/([\\\'])/\\$1/g if $e;
    if ($r) {
      $sub = "require '$e'";
    } elsif (defined $r) {
      $sub = "eval '$e'";
    } elsif ($sub eq '(eval)') {
      $sub = "eval {...}";
    }
    push(@sub, {context => $context, sub => $sub, args => $args,
		file => $file, line => $line});
    last if $signal;
  }
  $trace = $otrace;
  @sub;
}

sub action {
    my $action = shift;
    while ($action =~ s/\\$//) {
	#print $OUT "+ ";
	#$action .= "\n";
	$action .= &gets;
    }
    $action;
}

sub unbalanced { 
    # i hate using globals!
    $balanced_brace_re ||= qr{ 
	^ \{
	      (?:
		 (?> [^{}] + )    	    # Non-parens without backtracking
	       |
		 (??{ $balanced_brace_re }) # Group with matching parens
	      ) *
	  \} $
   }x;
   return $_[0] !~ m/$balanced_brace_re/;
}

sub gets {
    &readline("cont: ");
}

sub system {
    # We save, change, then restore STDIN and STDOUT to avoid fork() since
    # some non-Unix systems can do system() but have problems with fork().
    open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
    open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
    open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
    open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");

    # XXX: using csh or tcsh destroys sigint retvals!
    system(@_);
    open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
    open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
    close(SAVEIN); 
    close(SAVEOUT);


    # most of the $? crud was coping with broken cshisms
    if ($? >> 8) {