perl5db.pl

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

	&warn("(Command exited ", ($? >> 8), ")\n");
    } elsif ($?) { 
	&warn( "(Command died of SIG#",  ($? & 127),
	    (($? & 128) ? " -- core dumped" : "") , ")", "\n");
    } 

    return $?;

}

sub setterm {
    local $frame = 0;
    local $doret = -2;
    eval { require Term::ReadLine } or die $@;
    if ($notty) {
	if ($tty) {
	    open(IN,"<$tty") or die "Cannot open TTY `$TTY' for read: $!";
	    open(OUT,">$tty") or die "Cannot open TTY `$TTY' for write: $!";
	    $IN = \*IN;
	    $OUT = \*OUT;
	    my $sel = select($OUT);
	    $| = 1;
	    select($sel);
	} else {
	    eval "require Term::Rendezvous;" or die;
	    my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
	    my $term_rv = new Term::Rendezvous $rv;
	    $IN = $term_rv->IN;
	    $OUT = $term_rv->OUT;
	}
    }
    if (!$rl) {
	$term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
    } else {
	$term = new Term::ReadLine 'perldb', $IN, $OUT;

	$rl_attribs = $term->Attribs;
	$rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}' 
	  if defined $rl_attribs->{basic_word_break_characters} 
	    and index($rl_attribs->{basic_word_break_characters}, ":") == -1;
	$rl_attribs->{special_prefixes} = '$@&%';
	$rl_attribs->{completer_word_break_characters} .= '$@&%';
	$rl_attribs->{completion_function} = \&db_complete; 
    }
    $LINEINFO = $OUT unless defined $LINEINFO;
    $lineinfo = $console unless defined $lineinfo;
    $term->MinLine(2);
    if ($term->Features->{setHistory} and "@hist" ne "?") {
      $term->SetHistory(@hist);
    }
    ornaments($ornaments) if defined $ornaments;
    $term_pid = $$;
}

sub resetterm {			# We forked, so we need a different TTY
    $term_pid = $$;
    if (defined &get_fork_TTY) {
      &get_fork_TTY;
    } elsif (not defined $fork_TTY 
	     and defined $ENV{TERM} and $ENV{TERM} eq 'xterm' 
	     and defined $ENV{WINDOWID} and defined $ENV{DISPLAY}) { 
        # Possibly _inside_ XTERM
        open XT, q[3>&1 xterm -title 'Forked Perl debugger' -e sh -c 'tty 1>&3;\
 sleep 10000000' |];
        $fork_TTY = <XT>;
        chomp $fork_TTY;
    }
    if (defined $fork_TTY) {
      TTY($fork_TTY);
      undef $fork_TTY;
    } else {
      print_help(<<EOP);
I<#########> Forked, but do not know how to change a B<TTY>. I<#########>
  Define B<\$DB::fork_TTY> 
       - or a function B<DB::get_fork_TTY()> which will set B<\$DB::fork_TTY>.
  The value of B<\$DB::fork_TTY> should be the name of I<TTY> to use.
  On I<UNIX>-like systems one can get the name of a I<TTY> for the given window
  by typing B<tty>, and disconnect the I<shell> from I<TTY> by B<sleep 1000000>.
EOP
    }
}

sub readline {
  local $.;
  if (@typeahead) {
    my $left = @typeahead;
    my $got = shift @typeahead;
    print $OUT "auto(-$left)", shift, $got, "\n";
    $term->AddHistory($got) 
      if length($got) > 1 and defined $term->Features->{addHistory};
    return $got;
  }
  local $frame = 0;
  local $doret = -2;
  if (ref $OUT and UNIVERSAL::isa($OUT, 'IO::Socket::INET')) {
    $OUT->write(join('', @_));
    my $stuff;
    $IN->recv( $stuff, 2048 );  # XXX: what's wrong with sysread?
    $stuff;
  }
  else {
    $term->readline(@_);
  }
}

sub dump_option {
    my ($opt, $val)= @_;
    $val = option_val($opt,'N/A');
    $val =~ s/([\\\'])/\\$1/g;
    printf $OUT "%20s = '%s'\n", $opt, $val;
}

sub option_val {
    my ($opt, $default)= @_;
    my $val;
    if (defined $optionVars{$opt}
	and defined ${$optionVars{$opt}}) {
	$val = ${$optionVars{$opt}};
    } elsif (defined $optionAction{$opt}
	and defined &{$optionAction{$opt}}) {
	$val = &{$optionAction{$opt}}();
    } elsif (defined $optionAction{$opt}
	     and not defined $option{$opt}
	     or defined $optionVars{$opt}
	     and not defined ${$optionVars{$opt}}) {
	$val = $default;
    } else {
	$val = $option{$opt};
    }
    $val
}

sub parse_options {
    local($_)= @_;
    # too dangerous to let intuitive usage overwrite important things
    # defaultion should never be the default
    my %opt_needs_val = map { ( $_ => 1 ) } qw{
        arrayDepth hashDepth LineInfo maxTraceLen ornaments
        pager quote ReadLine recallCommand RemotePort ShellBang TTY
    };
    while (length) {
	my $val_defaulted;
	s/^\s+// && next;
	s/^(\w+)(\W?)// or print($OUT "Invalid option `$_'\n"), last;
	my ($opt,$sep) = ($1,$2);
	my $val;
	if ("?" eq $sep) {
	    print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
	      if /^\S/;
	    #&dump_option($opt);
	} elsif ($sep !~ /\S/) {
	    $val_defaulted = 1;
	    $val = "1";  #  this is an evil default; make 'em set it!
	} elsif ($sep eq "=") {

            if (s/ (["']) ( (?: \\. | (?! \1 ) [^\\] )* ) \1 //x) { 
                my $quote = $1;
                ($val = $2) =~ s/\\([$quote\\])/$1/g;
	    } else { 
		s/^(\S*)//;
	    $val = $1;
		print OUT qq(Option better cleared using $opt=""\n)
		    unless length $val;
	    }

	} else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
	    my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
	    s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
	      print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
	    ($val = $1) =~ s/\\([\\$end])/$1/g;
	}

	my $option;
	my $matches = grep( /^\Q$opt/  && ($option = $_),  @options  )
		   || grep( /^\Q$opt/i && ($option = $_),  @options  );

	print($OUT "Unknown option `$opt'\n"), next 	unless $matches;
	print($OUT "Ambiguous option `$opt'\n"), next 	if $matches > 1;

       if ($opt_needs_val{$option} && $val_defaulted) {
	    print $OUT "Option `$opt' is non-boolean.  Use `O $option=VAL' to set, `O $option?' to query\n";
	    next;
	} 

	$option{$option} = $val if defined $val;

	eval qq{
		local \$frame = 0; 
		local \$doret = -2; 
	        require '$optionRequire{$option}';
		1;
	 } || die  # XXX: shouldn't happen
	    if  defined $optionRequire{$option}	    &&
	        defined $val;

	${$optionVars{$option}} = $val 	    
	    if  defined $optionVars{$option}        &&
		defined $val;

	&{$optionAction{$option}} ($val)    
	    if defined $optionAction{$option}	    &&
               defined &{$optionAction{$option}}    &&
               defined $val;

	# Not $rcfile
	dump_option($option) 	unless $OUT eq \*STDERR; 
    }
}

sub set_list {
  my ($stem,@list) = @_;
  my $val;
  $ENV{"${stem}_n"} = @list;
  for $i (0 .. $#list) {
    $val = $list[$i];
    $val =~ s/\\/\\\\/g;
    $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
    $ENV{"${stem}_$i"} = $val;
  }
}

sub get_list {
  my $stem = shift;
  my @list;
  my $n = delete $ENV{"${stem}_n"};
  my $val;
  for $i (0 .. $n - 1) {
    $val = delete $ENV{"${stem}_$i"};
    $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
    push @list, $val;
  }
  @list;
}

sub catch {
    $signal = 1;
    return;			# Put nothing on the stack - malloc/free land!
}

sub warn {
    my($msg)= join("",@_);
    $msg .= ": $!\n" unless $msg =~ /\n$/;
    print $OUT $msg;
}

sub TTY {
    if (@_ and $term and $term->Features->{newTTY}) {
      my ($in, $out) = shift;
      if ($in =~ /,/) {
	($in, $out) = split /,/, $in, 2;
      } else {
	$out = $in;
      }
      open IN, $in or die "cannot open `$in' for read: $!";
      open OUT, ">$out" or die "cannot open `$out' for write: $!";
      $term->newTTY(\*IN, \*OUT);
      $IN	= \*IN;
      $OUT	= \*OUT;
      return $tty = $in;
    } elsif ($term and @_) {
	&warn("Too late to set TTY, enabled on next `R'!\n");
    } 
    $tty = shift if @_;
    $tty or $console;
}

sub noTTY {
    if ($term) {
	&warn("Too late to set noTTY, enabled on next `R'!\n") if @_;
    }
    $notty = shift if @_;
    $notty;
}

sub ReadLine {
    if ($term) {
	&warn("Too late to set ReadLine, enabled on next `R'!\n") if @_;
    }
    $rl = shift if @_;
    $rl;
}

sub RemotePort {
    if ($term) {
        &warn("Too late to set RemotePort, enabled on next 'R'!\n") if @_;
    }
    $remoteport = shift if @_;
    $remoteport;
}

sub tkRunning {
    if (${$term->Features}{tkRunning}) {
        return $term->tkRunning(@_);
    } else {
	print $OUT "tkRunning not supported by current ReadLine package.\n";
	0;
    }
}

sub NonStop {
    if ($term) {
	&warn("Too late to set up NonStop mode, enabled on next `R'!\n") if @_;
    }
    $runnonstop = shift if @_;
    $runnonstop;
}

sub pager {
    if (@_) {
	$pager = shift;
	$pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
    }
    $pager;
}

sub shellBang {
    if (@_) {
	$sh = quotemeta shift;
	$sh .= "\\b" if $sh =~ /\w$/;
    }
    $psh = $sh;
    $psh =~ s/\\b$//;
    $psh =~ s/\\(.)/$1/g;
    &sethelp;
    $psh;
}

sub ornaments {
  if (defined $term) {
    local ($warnLevel,$dieLevel) = (0, 1);
    return '' unless $term->Features->{ornaments};
    eval { $term->ornaments(@_) } || '';
  } else {
    $ornaments = shift;
  }
}

sub recallCommand {
    if (@_) {
	$rc = quotemeta shift;
	$rc .= "\\b" if $rc =~ /\w$/;
    }
    $prc = $rc;
    $prc =~ s/\\b$//;
    $prc =~ s/\\(.)/$1/g;
    &sethelp;
    $prc;
}

sub LineInfo {
    return $lineinfo unless @_;
    $lineinfo = shift;
    my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
    $slave_editor = ($stream =~ /^\|/);
    open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
    $LINEINFO = \*LINEINFO;
    my $save = select($LINEINFO);
    $| = 1;
    select($save);
    $lineinfo;
}

sub list_versions {
  my %version;
  my $file;
  for (keys %INC) {
    $file = $_;
    s,\.p[lm]$,,i ;
    s,/,::,g ;
    s/^perl5db$/DB/;
    s/^Term::ReadLine::readline$/readline/;
    if (defined ${ $_ . '::VERSION' }) {
      $version{$file} = "${ $_ . '::VERSION' } from ";
    } 
    $version{$file} .= $INC{$file};
  }
  dumpit($OUT,\%version);
}

sub sethelp {
    # XXX: make sure these are tabs between the command and explantion,
    #      or print_help will screw up your formatting if you have
    #      eeevil ornaments enabled.  This is an insane mess.

    $help = "
B<T>		Stack trace.
B<s> [I<expr>]	Single step [in I<expr>].
B<n> [I<expr>]	Next, steps over subroutine calls [in I<expr>].
<B<CR>>		Repeat last B<n> or B<s> command.
B<r>		Return from current subroutine.
B<c> [I<line>|I<sub>]	Continue; optionally inserts a one-time-only breakpoint
		at the specified position.
B<l> I<min>B<+>I<incr>	List I<incr>+1 lines starting at I<min>.
B<l> I<min>B<->I<max>	List lines I<min> through I<max>.
B<l> I<line>		List single I<line>.
B<l> I<subname>	List first window of lines from subroutine.
B<l> I<\$var>		List first window of lines from subroutine referenced by I<\$var>.
B<l>		List next window of lines.
B<->		List previous window of lines.
B<w> [I<line>]	List window around I<line>.
B<.>		Return to the executed line.
B<f> I<filename>	Switch to viewing I<filename>. File must be already loaded.
		I<filename> may be either the full name of the file, or a regular
		expression matching the full file name:
		B<f> I</home/me/foo.pl> and B<f> I<oo\\.> may access the same file.
		Evals (with saved bodies) are considered to be filenames:
		B<f> I<(eval 7)> and B<f> I<eval 7\\b> access the body of the 7th eval
		(in the order of execution).
B</>I<pattern>B</>	Search forwards for I<pattern>; final B</> is optional.
B<?>I<pattern>B<?>	Search backwards for I<pattern>; final B<?> is optional.
B<L>		List all breakpoints and actions.
B<S> [[B<!>]I<pattern>]	List subroutine names [not] matching I<pattern>.
B<t>		Toggle trace mode.
B<t> I<expr>		Trace through execution of I<expr>.
B<b> [I<line>] [I<condition>]
		Set breakpoint; I<line> defaults to the current execution line;
		I<condition> breaks if it evaluates to true, defaults to '1'.
B<b> I<subname> [I<condition>]
		Set breakpoint at first line of subroutine.
B<b> I<\$var>		Set breakpoint at first line of subroutine referenced by I<\$var>.
B<b> B<load> I<filename> Set breakpoint on `require'ing the given file.
B<b> B<postpone> I<subname> [I<condition>]
		Set breakpoint at first line of subroutine after 
		it is compiled.
B<b> B<compile> I<subname>
		Stop after the subroutine is compiled.
B<d> [I<line>]	Delete the breakpoint for I<line>.
B<D>		Delete all breakpoints.
B<a> [I<line>] I<command>
		Set