perl5db.pl

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

package DB;

# Debugger for Perl 5.00x; perl5db.pl patch level:

$VERSION = 1.07;
$header = "perl5db.pl version $VERSION";

#
# This file is automatically included if you do perl -d.
# It's probably not useful to include this yourself.
#
# Perl supplies the values for %sub.  It effectively inserts
# a &DB'DB(); in front of every place that can have a
# breakpoint. Instead of a subroutine call it calls &DB::sub with
# $DB::sub being the called subroutine. It also inserts a BEGIN
# {require 'perl5db.pl'} before the first line.
#
# After each `require'd file is compiled, but before it is executed, a
# call to DB::postponed($main::{'_<'.$filename}) is emulated. Here the
# $filename is the expanded name of the `require'd file (as found as
# value of %INC).
#
# Additional services from Perl interpreter:
#
# if caller() is called from the package DB, it provides some
# additional data.
#
# The array @{$main::{'_<'.$filename}} is the line-by-line contents of
# $filename.
#
# The hash %{'_<'.$filename} contains breakpoints and action (it is
# keyed by line number), and individual entries are settable (as
# opposed to the whole hash). Only true/false is important to the
# interpreter, though the values used by perl5db.pl have the form
# "$break_condition\0$action". Values are magical in numeric context.
#
# The scalar ${'_<'.$filename} contains $filename.
#
# Note that no subroutine call is possible until &DB::sub is defined
# (for subroutines defined outside of the package DB). In fact the same is
# true if $deep is not defined.
#
# $Log:	perldb.pl,v $

#
# At start reads $rcfile that may set important options.  This file
# may define a subroutine &afterinit that will be executed after the
# debugger is initialized.
#
# After $rcfile is read reads environment variable PERLDB_OPTS and parses
# it as a rest of `O ...' line in debugger prompt.
#
# The options that can be specified only at startup:
# [To set in $rcfile, call &parse_options("optionName=new_value").]
#
# TTY  - the TTY to use for debugging i/o.
#
# noTTY - if set, goes in NonStop mode.  On interrupt if TTY is not set
# uses the value of noTTY or "/tmp/perldbtty$$" to find TTY using
# Term::Rendezvous.  Current variant is to have the name of TTY in this
# file.
#
# ReadLine - If false, dummy ReadLine is used, so you can debug
# ReadLine applications.
#
# NonStop - if true, no i/o is performed until interrupt.
#
# LineInfo - file or pipe to print line number info to.  If it is a
# pipe, a short "emacs like" message is used.
#
# RemotePort - host:port to connect to on remote host for remote debugging.
#
# Example $rcfile: (delete leading hashes!)
#
# &parse_options("NonStop=1 LineInfo=db.out");
# sub afterinit { $trace = 1; }
#
# The script will run without human intervention, putting trace
# information into db.out.  (If you interrupt it, you would better
# reset LineInfo to something "interactive"!)
#
##################################################################

# Enhanced by [e-mail] (Ilya Zakharevich)
# Latest version available: ftp://ftp.math.ohio-state.edu/pub/users/ilya/perl

# modified Perl debugger, to be run from Emacs in perldb-mode
# Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990
# Johan Vromans -- upgrade to 4.0 pl 10
# Ilya Zakharevich -- patches after 5.001 (and some before ;-)

# Changelog:

# A lot of things changed after 0.94. First of all, core now informs
# debugger about entry into XSUBs, overloaded operators, tied operations,
# BEGIN and END. Handy with `O f=2'.

# This can make debugger a little bit too verbose, please be patient
# and report your problems promptly.

# Now the option frame has 3 values: 0,1,2.

# Note that if DESTROY returns a reference to the object (or object),
# the deletion of data may be postponed until the next function call,
# due to the need to examine the return value.

# Changes: 0.95: `v' command shows versions.
# Changes: 0.96: `v' command shows version of readline.
#	primitive completion works (dynamic variables, subs for `b' and `l',
#		options). Can `p %var'
#	Better help (`h <' now works). New commands <<, >>, {, {{.
#	{dump|print}_trace() coded (to be able to do it from <<cmd).
#	`c sub' documented.
#	At last enough magic combined to stop after the end of debuggee.
#	!! should work now (thanks to Emacs bracket matching an extra
#	`]' in a regexp is caught).
#	`L', `D' and `A' span files now (as documented).
#	Breakpoints in `require'd code are possible (used in `R').
#	Some additional words on internal work of debugger.
#	`b load filename' implemented.
#	`b postpone subr' implemented.
#	now only `q' exits debugger (overwriteable on $inhibit_exit).
#	When restarting debugger breakpoints/actions persist.
#     Buglet: When restarting debugger only one breakpoint/action per 
#		autoloaded function persists.
# Changes: 0.97: NonStop will not stop in at_exit().
#	Option AutoTrace implemented.
#	Trace printed differently if frames are printed too.
#	new `inhibitExit' option.
#	printing of a very long statement interruptible.
# Changes: 0.98: New command `m' for printing possible methods
#	'l -' is a synonim for `-'.
#	Cosmetic bugs in printing stack trace.
#	`frame' & 8 to print "expanded args" in stack trace.
#	Can list/break in imported subs.
#	new `maxTraceLen' option.
#	frame & 4 and frame & 8 granted.
#	new command `m'
#	nonstoppable lines do not have `:' near the line number.
#	`b compile subname' implemented.
#	Will not use $` any more.
#	`-' behaves sane now.
# Changes: 0.99: Completion for `f', `m'.
#	`m' will remove duplicate names instead of duplicate functions.
#	`b load' strips trailing whitespace.
#	completion ignores leading `|'; takes into account current package
#	when completing a subroutine name (same for `l').
# Changes: 1.07: Many fixed by tchrist 13-March-2000
#   BUG FIXES:
#   + Added bare mimimal security checks on perldb rc files, plus
#     comments on what else is needed.
#   + Fixed the ornaments that made "|h" completely unusable.
#     They are not used in print_help if they will hurt.  Strip pod
#     if we're paging to less.
#   + Fixed mis-formatting of help messages caused by ornaments
#     to restore Larry's original formatting.  
#   + Fixed many other formatting errors.  The code is still suboptimal, 
#     and needs a lot of work at restructuing. It's also misindented
#     in many places.
#   + Fixed bug where trying to look at an option like your pager
#     shows "1".  
#   + Fixed some $? processing.  Note: if you use csh or tcsh, you will
#     lose.  You should consider shell escapes not using their shell,
#     or else not caring about detailed status.  This should really be
#     unified into one place, too.
#   + Fixed bug where invisible trailing whitespace on commands hoses you,
#     tricking Perl into thinking you wern't calling a debugger command!
#   + Fixed bug where leading whitespace on commands hoses you.  (One
#     suggests a leading semicolon or any other irrelevant non-whitespace
#     to indicate literal Perl code.)
#   + Fixed bugs that ate warnings due to wrong selected handle.
#   + Fixed a precedence bug on signal stuff.
#   + Fixed some unseemly wording.
#   + Fixed bug in help command trying to call perl method code.
#   + Fixed to call dumpvar from exception handler.  SIGPIPE killed us.
#   ENHANCEMENTS:
#   + Added some comments.  This code is still nasty spaghetti.
#   + Added message if you clear your pre/post command stacks which was
#     very easy to do if you just typed a bare >, <, or {.  (A command
#     without an argument should *never* be a destructive action; this
#     API is fundamentally screwed up; likewise option setting, which
#     is equally buggered.)
#   + Added command stack dump on argument of "?" for >, <, or {.
#   + Added a semi-built-in doc viewer command that calls man with the
#     proper %Config::Config path (and thus gets caching, man -k, etc),
#     or else perldoc on obstreperous platforms.
#   + Added to and rearranged the help information.
#   + Detected apparent misuse of { ... } to declare a block; this used
#     to work but now is a command, and mysteriously gave no complaint.

####################################################################

# Needed for the statement after exec():

BEGIN { $ini_warn = $^W; $^W = 0 } # Switch compilation warnings off until another BEGIN.
local($^W) = 0;			# Switch run-time warnings off during init.
warn (			# Do not ;-)
      $dumpvar::hashDepth,     
      $dumpvar::arrayDepth,    
      $dumpvar::dumpDBFiles,   
      $dumpvar::dumpPackages,  
      $dumpvar::quoteHighBit,  
      $dumpvar::printUndef,    
      $dumpvar::globPrint,     
      $dumpvar::usageOnly,
      @ARGS,
      $Carp::CarpLevel,
      $panic,
      $second_time,
     ) if 0;

# Command-line + PERLLIB:
@ini_INC = @INC;

# $prevwarn = $prevdie = $prevbus = $prevsegv = ''; # Does not help?!

$trace = $signal = $single = 0;	# Uninitialized warning suppression
                                # (local $^W cannot help - other packages!).
$inhibit_exit = $option{PrintRet} = 1;

@options     = qw(hashDepth arrayDepth DumpDBFiles DumpPackages DumpReused
		  compactDump veryCompact quote HighBit undefPrint
		  globPrint PrintRet UsageOnly frame AutoTrace
		  TTY noTTY ReadLine NonStop LineInfo maxTraceLen
		  recallCommand ShellBang pager tkRunning ornaments
		  signalLevel warnLevel dieLevel inhibit_exit
		  ImmediateStop bareStringify
		  RemotePort);

%optionVars    = (
		 hashDepth	=> \$dumpvar::hashDepth,
		 arrayDepth	=> \$dumpvar::arrayDepth,
		 DumpDBFiles	=> \$dumpvar::dumpDBFiles,
		 DumpPackages	=> \$dumpvar::dumpPackages,
		 DumpReused	=> \$dumpvar::dumpReused,
		 HighBit	=> \$dumpvar::quoteHighBit,
		 undefPrint	=> \$dumpvar::printUndef,
		 globPrint	=> \$dumpvar::globPrint,
		 UsageOnly	=> \$dumpvar::usageOnly,     
		 bareStringify	=> \$dumpvar::bareStringify,
		 frame          => \$frame,
		 AutoTrace      => \$trace,
		 inhibit_exit   => \$inhibit_exit,
		 maxTraceLen	=> \$maxtrace,
		 ImmediateStop	=> \$ImmediateStop,
		 RemotePort	=> \$remoteport,
);

%optionAction  = (
		  compactDump	=> \&dumpvar::compactDump,
		  veryCompact	=> \&dumpvar::veryCompact,
		  quote		=> \&dumpvar::quote,
		  TTY		=> \&TTY,
		  noTTY		=> \&noTTY,
		  ReadLine	=> \&ReadLine,
		  NonStop	=> \&NonStop,
		  LineInfo	=> \&LineInfo,
		  recallCommand	=> \&recallCommand,
		  ShellBang	=> \&shellBang,
		  pager		=> \&pager,
		  signalLevel	=> \&signalLevel,
		  warnLevel	=> \&warnLevel,
		  dieLevel	=> \&dieLevel,
		  tkRunning	=> \&tkRunning,
		  ornaments	=> \&ornaments,
		  RemotePort	=> \&RemotePort,
		 );

%optionRequire = (
		  compactDump	=> 'dumpvar.pl',
		  veryCompact	=> 'dumpvar.pl',
		  quote		=> 'dumpvar.pl',
		 );

# These guys may be defined in $ENV{PERL5DB} :
$rl		= 1	unless defined $rl;
$warnLevel	= 0	unless defined $warnLevel;
$dieLevel	= 0	unless defined $dieLevel;
$signalLevel	= 1	unless defined $signalLevel;
$pre		= []	unless defined $pre;
$post		= []	unless defined $post;
$pretype	= []	unless defined $pretype;

warnLevel($warnLevel);
dieLevel($dieLevel);
signalLevel($signalLevel);

&pager(
    (defined($ENV{PAGER}) 
	? $ENV{PAGER}
	: ($^O eq 'os2' 
	   ? 'cmd /c more' 
	   : 'more'))) unless defined $pager;
setman();
&recallCommand("!") unless defined $prc;
&shellBang("!") unless defined $psh;
$maxtrace = 400 unless defined $maxtrace;

if (-e "/dev/tty") {  # this is the wrong metric!
  $rcfile=".perldb";
} else {
  $rcfile="perldb.ini";
}

# This isn't really safe, because there's a race
# between checking and opening.  The solution is to
# open and fstat the handle, but then you have to read and
# eval the contents.  But then the silly thing gets
# your lexical scope, which is unfortunately at best.
sub safe_do { 
    my $file = shift;

    # Just exactly what part of the word "CORE::" don't you understand?
    local $SIG{__WARN__};  
    local $SIG{__DIE__};    

    unless (is_safe_file($file)) {
	CORE::warn <<EO_GRIPE;
perldb: Must not source insecure rcfile $file.
        You or the superuser must be the owner, and it must not 
	be writable by anyone but its owner.
EO_GRIPE
	return;
    } 

    do $file;
    CORE::warn("perldb: couldn't parse $file: $@") if $@;
}


# Verifies that owner is either real user or superuser and that no
# one but owner may write to it.  This function is of limited use
# when called on a path instead of upon a handle, because there are
# no guarantees that filename (by dirent) whose file (by ino) is
# eventually accessed is the same as the one tested. 
# Assumes that the file's existence is not in doubt.
sub is_safe_file {
    my $path = shift;
    stat($path) || return;	# mysteriously vaporized
    my($dev,$ino,$mode,$nlink,$uid,$gid) = stat(_);

    return 0 if $uid != 0 && $uid != $<;
    return 0 if $mode & 022;
    return 1;
}

if (-f $rcfile) {
    safe_do("./$rcfile");
} 
elsif (defined $ENV{HOME} && -f "$ENV{HOME}/$rcfile") {
    safe_do("$ENV{HOME}/$rcfile");
}
elsif (defined $ENV{LOGDIR} && -f "$ENV{LOGDIR}/$rcfile") {
    safe_do("$ENV{LOGDIR}/$rcfile");
}

if (defined $ENV{PERLDB_OPTS}) {
  parse_options($ENV{PERLDB_OPTS});
}

# Here begin the unreadable code.  It needs fixing.

if (exists $ENV{PERLDB_RESTART}) {
  delete $ENV{PERLDB_RESTART};
  # $restart = 1;
  @hist = get_list('PERLDB_HIST');
  %break_on_load = get_list("PERLDB_ON_LOAD");
  %postponed = get_list("PERLDB_POSTPONE");
  my @had_breakpoints= get_list("PERLDB_VISITED");
  for (0 .. $#had_breakpoints) {
    my %pf = get_list("PERLDB_FILE_$_");
    $postponed_file{$had_breakpoints[$_]} = \%pf if %pf;
  }
  my %opt = get_list("PERLDB_OPT");
  my ($opt,$val);
  while (($opt,$val) = each %opt) {
    $val =~ s/[\\\']/\\$1/g;
    parse_options("$opt'$val'");
  }
  @INC = get_list("PERLDB_INC");
  @ini_INC = @INC;
  $pretype = [get_list("PERLDB_PRETYPE")];
  $pre = [get_list("PERLDB_PRE")];
  $post = [get_list("PERLDB_POST")];
  @typeahead = get_list("PERLDB_TYPEAHEAD", @typeahead);
}

if ($notty) {
  $runnonstop = 1;
} else {
  # Is Perl being run from a slave editor or graphical debugger?
  $slave_editor = ((defined $main::ARGV[0]) and ($main::ARGV[0] eq '-emacs'));
  $rl = 0, shift(@main::ARGV) if $slave_editor;

  #require Term::ReadLine;

  if ($^O eq 'cygwin' || $^O eq 'msys') {
    # /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";
  } elsif ($^O eq 'MacOS') {
    if ($MacPerl::Version !~ /MPW/) {
      $console = "Dev:Console:Perl Debug"; # Separate window for application
    } else {
      $console = "Dev:Console";
    }
  } else {
    $console = "sys\$command";
  }

  if (($^O eq 'MSWin32') and ($slave_editor or defined $ENV{EMACS})) {
    $console = undef;
  }

  # Around a bug:
  if (defined $ENV{OS2_SHELL} and ($slave_editor or $ENV{WINDOWID})) { # In OS/2
    $console = undef;
  }

  if ($^O eq 'epoc') {
    $console = undef;
  }

  $console = $tty if defined $tty;

  if (defined $remoteport) {
    require IO::Socket;
    $OUT = new IO::Socket::INET( Timeout  => '10',
                                 PeerAddr => $remoteport,
                                 Proto    => 'tcp',