PageRenderTime 194ms CodeModel.GetById 38ms app.highlight 140ms RepoModel.GetById 1ms app.codeStats 1ms

/IronPython_Main/Runtime/Tests/LinqDlrTests/testenv/perl/lib/perl5db.pl

#
Perl | 2708 lines | 2336 code | 122 blank | 250 comment | 346 complexity | cd6c6e1e1013ccf2cd73d23aa4915f3c MD5 | raw file

Large files files are truncated, but you can click here to view the full file

   1package DB;
   2
   3# Debugger for Perl 5.00x; perl5db.pl patch level:
   4
   5$VERSION = 1.07;
   6$header = "perl5db.pl version $VERSION";
   7
   8#
   9# This file is automatically included if you do perl -d.
  10# It's probably not useful to include this yourself.
  11#
  12# Perl supplies the values for %sub.  It effectively inserts
  13# a &DB'DB(); in front of every place that can have a
  14# breakpoint. Instead of a subroutine call it calls &DB::sub with
  15# $DB::sub being the called subroutine. It also inserts a BEGIN
  16# {require 'perl5db.pl'} before the first line.
  17#
  18# After each `require'd file is compiled, but before it is executed, a
  19# call to DB::postponed($main::{'_<'.$filename}) is emulated. Here the
  20# $filename is the expanded name of the `require'd file (as found as
  21# value of %INC).
  22#
  23# Additional services from Perl interpreter:
  24#
  25# if caller() is called from the package DB, it provides some
  26# additional data.
  27#
  28# The array @{$main::{'_<'.$filename}} is the line-by-line contents of
  29# $filename.
  30#
  31# The hash %{'_<'.$filename} contains breakpoints and action (it is
  32# keyed by line number), and individual entries are settable (as
  33# opposed to the whole hash). Only true/false is important to the
  34# interpreter, though the values used by perl5db.pl have the form
  35# "$break_condition\0$action". Values are magical in numeric context.
  36#
  37# The scalar ${'_<'.$filename} contains $filename.
  38#
  39# Note that no subroutine call is possible until &DB::sub is defined
  40# (for subroutines defined outside of the package DB). In fact the same is
  41# true if $deep is not defined.
  42#
  43# $Log:	perldb.pl,v $
  44
  45#
  46# At start reads $rcfile that may set important options.  This file
  47# may define a subroutine &afterinit that will be executed after the
  48# debugger is initialized.
  49#
  50# After $rcfile is read reads environment variable PERLDB_OPTS and parses
  51# it as a rest of `O ...' line in debugger prompt.
  52#
  53# The options that can be specified only at startup:
  54# [To set in $rcfile, call &parse_options("optionName=new_value").]
  55#
  56# TTY  - the TTY to use for debugging i/o.
  57#
  58# noTTY - if set, goes in NonStop mode.  On interrupt if TTY is not set
  59# uses the value of noTTY or "/tmp/perldbtty$$" to find TTY using
  60# Term::Rendezvous.  Current variant is to have the name of TTY in this
  61# file.
  62#
  63# ReadLine - If false, dummy ReadLine is used, so you can debug
  64# ReadLine applications.
  65#
  66# NonStop - if true, no i/o is performed until interrupt.
  67#
  68# LineInfo - file or pipe to print line number info to.  If it is a
  69# pipe, a short "emacs like" message is used.
  70#
  71# RemotePort - host:port to connect to on remote host for remote debugging.
  72#
  73# Example $rcfile: (delete leading hashes!)
  74#
  75# &parse_options("NonStop=1 LineInfo=db.out");
  76# sub afterinit { $trace = 1; }
  77#
  78# The script will run without human intervention, putting trace
  79# information into db.out.  (If you interrupt it, you would better
  80# reset LineInfo to something "interactive"!)
  81#
  82##################################################################
  83
  84# Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich)
  85# Latest version available: ftp://ftp.math.ohio-state.edu/pub/users/ilya/perl
  86
  87# modified Perl debugger, to be run from Emacs in perldb-mode
  88# Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990
  89# Johan Vromans -- upgrade to 4.0 pl 10
  90# Ilya Zakharevich -- patches after 5.001 (and some before ;-)
  91
  92# Changelog:
  93
  94# A lot of things changed after 0.94. First of all, core now informs
  95# debugger about entry into XSUBs, overloaded operators, tied operations,
  96# BEGIN and END. Handy with `O f=2'.
  97
  98# This can make debugger a little bit too verbose, please be patient
  99# and report your problems promptly.
 100
 101# Now the option frame has 3 values: 0,1,2.
 102
 103# Note that if DESTROY returns a reference to the object (or object),
 104# the deletion of data may be postponed until the next function call,
 105# due to the need to examine the return value.
 106
 107# Changes: 0.95: `v' command shows versions.
 108# Changes: 0.96: `v' command shows version of readline.
 109#	primitive completion works (dynamic variables, subs for `b' and `l',
 110#		options). Can `p %var'
 111#	Better help (`h <' now works). New commands <<, >>, {, {{.
 112#	{dump|print}_trace() coded (to be able to do it from <<cmd).
 113#	`c sub' documented.
 114#	At last enough magic combined to stop after the end of debuggee.
 115#	!! should work now (thanks to Emacs bracket matching an extra
 116#	`]' in a regexp is caught).
 117#	`L', `D' and `A' span files now (as documented).
 118#	Breakpoints in `require'd code are possible (used in `R').
 119#	Some additional words on internal work of debugger.
 120#	`b load filename' implemented.
 121#	`b postpone subr' implemented.
 122#	now only `q' exits debugger (overwriteable on $inhibit_exit).
 123#	When restarting debugger breakpoints/actions persist.
 124#     Buglet: When restarting debugger only one breakpoint/action per 
 125#		autoloaded function persists.
 126# Changes: 0.97: NonStop will not stop in at_exit().
 127#	Option AutoTrace implemented.
 128#	Trace printed differently if frames are printed too.
 129#	new `inhibitExit' option.
 130#	printing of a very long statement interruptible.
 131# Changes: 0.98: New command `m' for printing possible methods
 132#	'l -' is a synonim for `-'.
 133#	Cosmetic bugs in printing stack trace.
 134#	`frame' & 8 to print "expanded args" in stack trace.
 135#	Can list/break in imported subs.
 136#	new `maxTraceLen' option.
 137#	frame & 4 and frame & 8 granted.
 138#	new command `m'
 139#	nonstoppable lines do not have `:' near the line number.
 140#	`b compile subname' implemented.
 141#	Will not use $` any more.
 142#	`-' behaves sane now.
 143# Changes: 0.99: Completion for `f', `m'.
 144#	`m' will remove duplicate names instead of duplicate functions.
 145#	`b load' strips trailing whitespace.
 146#	completion ignores leading `|'; takes into account current package
 147#	when completing a subroutine name (same for `l').
 148# Changes: 1.07: Many fixed by tchrist 13-March-2000
 149#   BUG FIXES:
 150#   + Added bare mimimal security checks on perldb rc files, plus
 151#     comments on what else is needed.
 152#   + Fixed the ornaments that made "|h" completely unusable.
 153#     They are not used in print_help if they will hurt.  Strip pod
 154#     if we're paging to less.
 155#   + Fixed mis-formatting of help messages caused by ornaments
 156#     to restore Larry's original formatting.  
 157#   + Fixed many other formatting errors.  The code is still suboptimal, 
 158#     and needs a lot of work at restructuing. It's also misindented
 159#     in many places.
 160#   + Fixed bug where trying to look at an option like your pager
 161#     shows "1".  
 162#   + Fixed some $? processing.  Note: if you use csh or tcsh, you will
 163#     lose.  You should consider shell escapes not using their shell,
 164#     or else not caring about detailed status.  This should really be
 165#     unified into one place, too.
 166#   + Fixed bug where invisible trailing whitespace on commands hoses you,
 167#     tricking Perl into thinking you wern't calling a debugger command!
 168#   + Fixed bug where leading whitespace on commands hoses you.  (One
 169#     suggests a leading semicolon or any other irrelevant non-whitespace
 170#     to indicate literal Perl code.)
 171#   + Fixed bugs that ate warnings due to wrong selected handle.
 172#   + Fixed a precedence bug on signal stuff.
 173#   + Fixed some unseemly wording.
 174#   + Fixed bug in help command trying to call perl method code.
 175#   + Fixed to call dumpvar from exception handler.  SIGPIPE killed us.
 176#   ENHANCEMENTS:
 177#   + Added some comments.  This code is still nasty spaghetti.
 178#   + Added message if you clear your pre/post command stacks which was
 179#     very easy to do if you just typed a bare >, <, or {.  (A command
 180#     without an argument should *never* be a destructive action; this
 181#     API is fundamentally screwed up; likewise option setting, which
 182#     is equally buggered.)
 183#   + Added command stack dump on argument of "?" for >, <, or {.
 184#   + Added a semi-built-in doc viewer command that calls man with the
 185#     proper %Config::Config path (and thus gets caching, man -k, etc),
 186#     or else perldoc on obstreperous platforms.
 187#   + Added to and rearranged the help information.
 188#   + Detected apparent misuse of { ... } to declare a block; this used
 189#     to work but now is a command, and mysteriously gave no complaint.
 190
 191####################################################################
 192
 193# Needed for the statement after exec():
 194
 195BEGIN { $ini_warn = $^W; $^W = 0 } # Switch compilation warnings off until another BEGIN.
 196local($^W) = 0;			# Switch run-time warnings off during init.
 197warn (			# Do not ;-)
 198      $dumpvar::hashDepth,     
 199      $dumpvar::arrayDepth,    
 200      $dumpvar::dumpDBFiles,   
 201      $dumpvar::dumpPackages,  
 202      $dumpvar::quoteHighBit,  
 203      $dumpvar::printUndef,    
 204      $dumpvar::globPrint,     
 205      $dumpvar::usageOnly,
 206      @ARGS,
 207      $Carp::CarpLevel,
 208      $panic,
 209      $second_time,
 210     ) if 0;
 211
 212# Command-line + PERLLIB:
 213@ini_INC = @INC;
 214
 215# $prevwarn = $prevdie = $prevbus = $prevsegv = ''; # Does not help?!
 216
 217$trace = $signal = $single = 0;	# Uninitialized warning suppression
 218                                # (local $^W cannot help - other packages!).
 219$inhibit_exit = $option{PrintRet} = 1;
 220
 221@options     = qw(hashDepth arrayDepth DumpDBFiles DumpPackages DumpReused
 222		  compactDump veryCompact quote HighBit undefPrint
 223		  globPrint PrintRet UsageOnly frame AutoTrace
 224		  TTY noTTY ReadLine NonStop LineInfo maxTraceLen
 225		  recallCommand ShellBang pager tkRunning ornaments
 226		  signalLevel warnLevel dieLevel inhibit_exit
 227		  ImmediateStop bareStringify
 228		  RemotePort);
 229
 230%optionVars    = (
 231		 hashDepth	=> \$dumpvar::hashDepth,
 232		 arrayDepth	=> \$dumpvar::arrayDepth,
 233		 DumpDBFiles	=> \$dumpvar::dumpDBFiles,
 234		 DumpPackages	=> \$dumpvar::dumpPackages,
 235		 DumpReused	=> \$dumpvar::dumpReused,
 236		 HighBit	=> \$dumpvar::quoteHighBit,
 237		 undefPrint	=> \$dumpvar::printUndef,
 238		 globPrint	=> \$dumpvar::globPrint,
 239		 UsageOnly	=> \$dumpvar::usageOnly,     
 240		 bareStringify	=> \$dumpvar::bareStringify,
 241		 frame          => \$frame,
 242		 AutoTrace      => \$trace,
 243		 inhibit_exit   => \$inhibit_exit,
 244		 maxTraceLen	=> \$maxtrace,
 245		 ImmediateStop	=> \$ImmediateStop,
 246		 RemotePort	=> \$remoteport,
 247);
 248
 249%optionAction  = (
 250		  compactDump	=> \&dumpvar::compactDump,
 251		  veryCompact	=> \&dumpvar::veryCompact,
 252		  quote		=> \&dumpvar::quote,
 253		  TTY		=> \&TTY,
 254		  noTTY		=> \&noTTY,
 255		  ReadLine	=> \&ReadLine,
 256		  NonStop	=> \&NonStop,
 257		  LineInfo	=> \&LineInfo,
 258		  recallCommand	=> \&recallCommand,
 259		  ShellBang	=> \&shellBang,
 260		  pager		=> \&pager,
 261		  signalLevel	=> \&signalLevel,
 262		  warnLevel	=> \&warnLevel,
 263		  dieLevel	=> \&dieLevel,
 264		  tkRunning	=> \&tkRunning,
 265		  ornaments	=> \&ornaments,
 266		  RemotePort	=> \&RemotePort,
 267		 );
 268
 269%optionRequire = (
 270		  compactDump	=> 'dumpvar.pl',
 271		  veryCompact	=> 'dumpvar.pl',
 272		  quote		=> 'dumpvar.pl',
 273		 );
 274
 275# These guys may be defined in $ENV{PERL5DB} :
 276$rl		= 1	unless defined $rl;
 277$warnLevel	= 0	unless defined $warnLevel;
 278$dieLevel	= 0	unless defined $dieLevel;
 279$signalLevel	= 1	unless defined $signalLevel;
 280$pre		= []	unless defined $pre;
 281$post		= []	unless defined $post;
 282$pretype	= []	unless defined $pretype;
 283
 284warnLevel($warnLevel);
 285dieLevel($dieLevel);
 286signalLevel($signalLevel);
 287
 288&pager(
 289    (defined($ENV{PAGER}) 
 290	? $ENV{PAGER}
 291	: ($^O eq 'os2' 
 292	   ? 'cmd /c more' 
 293	   : 'more'))) unless defined $pager;
 294setman();
 295&recallCommand("!") unless defined $prc;
 296&shellBang("!") unless defined $psh;
 297$maxtrace = 400 unless defined $maxtrace;
 298
 299if (-e "/dev/tty") {  # this is the wrong metric!
 300  $rcfile=".perldb";
 301} else {
 302  $rcfile="perldb.ini";
 303}
 304
 305# This isn't really safe, because there's a race
 306# between checking and opening.  The solution is to
 307# open and fstat the handle, but then you have to read and
 308# eval the contents.  But then the silly thing gets
 309# your lexical scope, which is unfortunately at best.
 310sub safe_do { 
 311    my $file = shift;
 312
 313    # Just exactly what part of the word "CORE::" don't you understand?
 314    local $SIG{__WARN__};  
 315    local $SIG{__DIE__};    
 316
 317    unless (is_safe_file($file)) {
 318	CORE::warn <<EO_GRIPE;
 319perldb: Must not source insecure rcfile $file.
 320        You or the superuser must be the owner, and it must not 
 321	be writable by anyone but its owner.
 322EO_GRIPE
 323	return;
 324    } 
 325
 326    do $file;
 327    CORE::warn("perldb: couldn't parse $file: $@") if $@;
 328}
 329
 330
 331# Verifies that owner is either real user or superuser and that no
 332# one but owner may write to it.  This function is of limited use
 333# when called on a path instead of upon a handle, because there are
 334# no guarantees that filename (by dirent) whose file (by ino) is
 335# eventually accessed is the same as the one tested. 
 336# Assumes that the file's existence is not in doubt.
 337sub is_safe_file {
 338    my $path = shift;
 339    stat($path) || return;	# mysteriously vaporized
 340    my($dev,$ino,$mode,$nlink,$uid,$gid) = stat(_);
 341
 342    return 0 if $uid != 0 && $uid != $<;
 343    return 0 if $mode & 022;
 344    return 1;
 345}
 346
 347if (-f $rcfile) {
 348    safe_do("./$rcfile");
 349} 
 350elsif (defined $ENV{HOME} && -f "$ENV{HOME}/$rcfile") {
 351    safe_do("$ENV{HOME}/$rcfile");
 352}
 353elsif (defined $ENV{LOGDIR} && -f "$ENV{LOGDIR}/$rcfile") {
 354    safe_do("$ENV{LOGDIR}/$rcfile");
 355}
 356
 357if (defined $ENV{PERLDB_OPTS}) {
 358  parse_options($ENV{PERLDB_OPTS});
 359}
 360
 361# Here begin the unreadable code.  It needs fixing.
 362
 363if (exists $ENV{PERLDB_RESTART}) {
 364  delete $ENV{PERLDB_RESTART};
 365  # $restart = 1;
 366  @hist = get_list('PERLDB_HIST');
 367  %break_on_load = get_list("PERLDB_ON_LOAD");
 368  %postponed = get_list("PERLDB_POSTPONE");
 369  my @had_breakpoints= get_list("PERLDB_VISITED");
 370  for (0 .. $#had_breakpoints) {
 371    my %pf = get_list("PERLDB_FILE_$_");
 372    $postponed_file{$had_breakpoints[$_]} = \%pf if %pf;
 373  }
 374  my %opt = get_list("PERLDB_OPT");
 375  my ($opt,$val);
 376  while (($opt,$val) = each %opt) {
 377    $val =~ s/[\\\']/\\$1/g;
 378    parse_options("$opt'$val'");
 379  }
 380  @INC = get_list("PERLDB_INC");
 381  @ini_INC = @INC;
 382  $pretype = [get_list("PERLDB_PRETYPE")];
 383  $pre = [get_list("PERLDB_PRE")];
 384  $post = [get_list("PERLDB_POST")];
 385  @typeahead = get_list("PERLDB_TYPEAHEAD", @typeahead);
 386}
 387
 388if ($notty) {
 389  $runnonstop = 1;
 390} else {
 391  # Is Perl being run from a slave editor or graphical debugger?
 392  $slave_editor = ((defined $main::ARGV[0]) and ($main::ARGV[0] eq '-emacs'));
 393  $rl = 0, shift(@main::ARGV) if $slave_editor;
 394
 395  #require Term::ReadLine;
 396
 397  if ($^O eq 'cygwin') {
 398    # /dev/tty is binary. use stdin for textmode
 399    undef $console;
 400  } elsif (-e "/dev/tty") {
 401    $console = "/dev/tty";
 402  } elsif ($^O eq 'dos' or -e "con" or $^O eq 'MSWin32') {
 403    $console = "con";
 404  } elsif ($^O eq 'MacOS') {
 405    if ($MacPerl::Version !~ /MPW/) {
 406      $console = "Dev:Console:Perl Debug"; # Separate window for application
 407    } else {
 408      $console = "Dev:Console";
 409    }
 410  } else {
 411    $console = "sys\$command";
 412  }
 413
 414  if (($^O eq 'MSWin32') and ($slave_editor or defined $ENV{EMACS})) {
 415    $console = undef;
 416  }
 417
 418  # Around a bug:
 419  if (defined $ENV{OS2_SHELL} and ($slave_editor or $ENV{WINDOWID})) { # In OS/2
 420    $console = undef;
 421  }
 422
 423  if ($^O eq 'epoc') {
 424    $console = undef;
 425  }
 426
 427  $console = $tty if defined $tty;
 428
 429  if (defined $remoteport) {
 430    require IO::Socket;
 431    $OUT = new IO::Socket::INET( Timeout  => '10',
 432                                 PeerAddr => $remoteport,
 433                                 Proto    => 'tcp',
 434                               );
 435    if (!$OUT) { die "Unable to connect to remote host: $remoteport\n"; }
 436    $IN = $OUT;
 437  }
 438  else {
 439    if (defined $console) {
 440      open(IN,"+<$console") || open(IN,"<$console") || open(IN,"<&STDIN");
 441      open(OUT,"+>$console") || open(OUT,">$console") || open(OUT,">&STDERR")
 442        || open(OUT,">&STDOUT");	# so we don't dongle stdout
 443    } else {
 444      open(IN,"<&STDIN");
 445      open(OUT,">&STDERR") || open(OUT,">&STDOUT"); # so we don't dongle stdout
 446      $console = 'STDIN/OUT';
 447    }
 448    # so open("|more") can read from STDOUT and so we don't dingle stdin
 449    $IN = \*IN;
 450
 451    $OUT = \*OUT;
 452  }
 453  select($OUT);
 454  $| = 1;			# for DB::OUT
 455  select(STDOUT);
 456
 457  $LINEINFO = $OUT unless defined $LINEINFO;
 458  $lineinfo = $console unless defined $lineinfo;
 459
 460  $| = 1;			# for real STDOUT
 461
 462  $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
 463  unless ($runnonstop) {
 464    print $OUT "\nLoading DB routines from $header\n";
 465    print $OUT ("Editor support ",
 466		$slave_editor ? "enabled" : "available",
 467		".\n");
 468    print $OUT "\nEnter h or `h h' for help, or `$doccmd perldebug' for more help.\n\n";
 469  }
 470}
 471
 472@ARGS = @ARGV;
 473for (@args) {
 474    s/\'/\\\'/g;
 475    s/(.*)/'$1'/ unless /^-?[\d.]+$/;
 476}
 477
 478if (defined &afterinit) {	# May be defined in $rcfile
 479  &afterinit();
 480}
 481
 482$I_m_init = 1;
 483
 484############################################################ Subroutines
 485
 486sub DB {
 487    # _After_ the perl program is compiled, $single is set to 1:
 488    if ($single and not $second_time++) {
 489      if ($runnonstop) {	# Disable until signal
 490	for ($i=0; $i <= $stack_depth; ) {
 491	    $stack[$i++] &= ~1;
 492	}
 493	$single = 0;
 494	# return;			# Would not print trace!
 495      } elsif ($ImmediateStop) {
 496	$ImmediateStop = 0;
 497	$signal = 1;
 498      }
 499    }
 500    $runnonstop = 0 if $single or $signal; # Disable it if interactive.
 501    &save;
 502    ($package, $filename, $line) = caller;
 503    $filename_ini = $filename;
 504    $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
 505      "package $package;";	# this won't let them modify, alas
 506    local(*dbline) = $main::{'_<' . $filename};
 507    $max = $#dbline;
 508    if (($stop,$action) = split(/\0/,$dbline{$line})) {
 509	if ($stop eq '1') {
 510	    $signal |= 1;
 511	} elsif ($stop) {
 512	    $evalarg = "\$DB::signal |= 1 if do {$stop}"; &eval;
 513	    $dbline{$line} =~ s/;9($|\0)/$1/;
 514	}
 515    }
 516    my $was_signal = $signal;
 517    if ($trace & 2) {
 518      for (my $n = 0; $n <= $#to_watch; $n++) {
 519	$evalarg = $to_watch[$n];
 520	local $onetimeDump;	# Do not output results
 521	my ($val) = &eval;	# Fix context (&eval is doing array)?
 522	$val = ( (defined $val) ? "'$val'" : 'undef' );
 523	if ($val ne $old_watch[$n]) {
 524	  $signal = 1;
 525	  print $OUT <<EOP;
 526Watchpoint $n:\t$to_watch[$n] changed:
 527    old value:\t$old_watch[$n]
 528    new value:\t$val
 529EOP
 530	  $old_watch[$n] = $val;
 531	}
 532      }
 533    }
 534    if ($trace & 4) {		# User-installed watch
 535      return if watchfunction($package, $filename, $line) 
 536	and not $single and not $was_signal and not ($trace & ~4);
 537    }
 538    $was_signal = $signal;
 539    $signal = 0;
 540    if ($single || ($trace & 1) || $was_signal) {
 541	if ($slave_editor) {
 542	    $position = "\032\032$filename:$line:0\n";
 543	    print $LINEINFO $position;
 544	} elsif ($package eq 'DB::fake') {
 545	  $term || &setterm;
 546	  print_help(<<EOP);
 547Debugged program terminated.  Use B<q> to quit or B<R> to restart,
 548  use B<O> I<inhibit_exit> to avoid stopping after program termination,
 549  B<h q>, B<h R> or B<h O> to get additional info.  
 550EOP
 551	  $package = 'main';
 552	  $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
 553	    "package $package;";	# this won't let them modify, alas
 554	} else {
 555	    $sub =~ s/\'/::/;
 556	    $prefix = $sub =~ /::/ ? "" : "${'package'}::";
 557	    $prefix .= "$sub($filename:";
 558	    $after = ($dbline[$line] =~ /\n$/ ? '' : "\n");
 559	    if (length($prefix) > 30) {
 560	        $position = "$prefix$line):\n$line:\t$dbline[$line]$after";
 561		$prefix = "";
 562		$infix = ":\t";
 563	    } else {
 564		$infix = "):\t";
 565		$position = "$prefix$line$infix$dbline[$line]$after";
 566	    }
 567	    if ($frame) {
 568		print $LINEINFO ' ' x $stack_depth, "$line:\t$dbline[$line]$after";
 569	    } else {
 570		print $LINEINFO $position;
 571	    }
 572	    for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { #{ vi
 573		last if $dbline[$i] =~ /^\s*[\;\}\#\n]/;
 574		last if $signal;
 575		$after = ($dbline[$i] =~ /\n$/ ? '' : "\n");
 576		$incr_pos = "$prefix$i$infix$dbline[$i]$after";
 577		$position .= $incr_pos;
 578		if ($frame) {
 579		    print $LINEINFO ' ' x $stack_depth, "$i:\t$dbline[$i]$after";
 580		} else {
 581		    print $LINEINFO $incr_pos;
 582		}
 583	    }
 584	}
 585    }
 586    $evalarg = $action, &eval if $action;
 587    if ($single || $was_signal) {
 588	local $level = $level + 1;
 589	foreach $evalarg (@$pre) {
 590	  &eval;
 591	}
 592	print $OUT $stack_depth . " levels deep in subroutine calls!\n"
 593	  if $single & 4;
 594	$start = $line;
 595	$incr = -1;		# for backward motion.
 596	@typeahead = (@$pretype, @typeahead);
 597      CMD:
 598	while (($term || &setterm),
 599	       ($term_pid == $$ or &resetterm),
 600	       defined ($cmd=&readline("  DB" . ('<' x $level) .
 601				       ($#hist+1) . ('>' x $level) .
 602				       " "))) 
 603        {
 604		$single = 0;
 605		$signal = 0;
 606		$cmd =~ s/\\$/\n/ && do {
 607		    $cmd .= &readline("  cont: ");
 608		    redo CMD;
 609		};
 610		$cmd =~ /^$/ && ($cmd = $laststep);
 611		push(@hist,$cmd) if length($cmd) > 1;
 612	      PIPE: {
 613		    $cmd =~ s/^\s+//s;   # trim annoying leading whitespace
 614		    $cmd =~ s/\s+$//s;   # trim annoying trailing whitespace
 615		    ($i) = split(/\s+/,$cmd);
 616		    if ($alias{$i}) { 
 617			# squelch the sigmangler
 618			local $SIG{__DIE__};
 619			local $SIG{__WARN__};
 620			eval "\$cmd =~ $alias{$i}";
 621			if ($@) {
 622			    print $OUT "Couldn't evaluate `$i' alias: $@";
 623			    next CMD;
 624			} 
 625		    }
 626                   $cmd =~ /^q$/ && ($fall_off_end = 1) && exit $?;
 627		    $cmd =~ /^h$/ && do {
 628			print_help($help);
 629			next CMD; };
 630		    $cmd =~ /^h\s+h$/ && do {
 631			print_help($summary);
 632			next CMD; };
 633		    # support long commands; otherwise bogus errors
 634		    # happen when you ask for h on <CR> for example
 635		    $cmd =~ /^h\s+(\S.*)$/ && do {      
 636			my $asked = $1;			# for proper errmsg
 637			my $qasked = quotemeta($asked); # for searching
 638			# XXX: finds CR but not <CR>
 639			if ($help =~ /^<?(?:[IB]<)$qasked/m) {
 640			  while ($help =~ /^(<?(?:[IB]<)$qasked([\s\S]*?)\n)(?!\s)/mg) {
 641			    print_help($1);
 642			  }
 643			} else {
 644			    print_help("B<$asked> is not a debugger command.\n");
 645			}
 646			next CMD; };
 647		    $cmd =~ /^t$/ && do {
 648			$trace ^= 1;
 649			print $OUT "Trace = " .
 650			    (($trace & 1) ? "on" : "off" ) . "\n";
 651			next CMD; };
 652		    $cmd =~ /^S(\s+(!)?(.+))?$/ && do {
 653			$Srev = defined $2; $Spatt = $3; $Snocheck = ! defined $1;
 654			foreach $subname (sort(keys %sub)) {
 655			    if ($Snocheck or $Srev^($subname =~ /$Spatt/)) {
 656				print $OUT $subname,"\n";
 657			    }
 658			}
 659			next CMD; };
 660		    $cmd =~ /^v$/ && do {
 661			list_versions(); next CMD};
 662		    $cmd =~ s/^X\b/V $package/;
 663		    $cmd =~ /^V$/ && do {
 664			$cmd = "V $package"; };
 665		    $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
 666			local ($savout) = select($OUT);
 667			$packname = $1;
 668			@vars = split(' ',$2);
 669			do 'dumpvar.pl' unless defined &main::dumpvar;
 670			if (defined &main::dumpvar) {
 671			    local $frame = 0;
 672			    local $doret = -2;
 673			    # must detect sigpipe failures
 674			    eval { &main::dumpvar($packname,@vars) };
 675			    if ($@) {
 676				die unless $@ =~ /dumpvar print failed/;
 677			    } 
 678			} else {
 679			    print $OUT "dumpvar.pl not available.\n";
 680			}
 681			select ($savout);
 682			next CMD; };
 683		    $cmd =~ s/^x\b/ / && do { # So that will be evaled
 684			$onetimeDump = 'dump'; };
 685		    $cmd =~ s/^m\s+([\w:]+)\s*$/ / && do {
 686			methods($1); next CMD};
 687		    $cmd =~ s/^m\b/ / && do { # So this will be evaled
 688			$onetimeDump = 'methods'; };
 689		    $cmd =~ /^f\b\s*(.*)/ && do {
 690			$file = $1;
 691			$file =~ s/\s+$//;
 692			if (!$file) {
 693			    print $OUT "The old f command is now the r command.\n";
 694			    print $OUT "The new f command switches filenames.\n";
 695			    next CMD;
 696			}
 697			if (!defined $main::{'_<' . $file}) {
 698			    if (($try) = grep(m#^_<.*$file#, keys %main::)) {{
 699					      $try = substr($try,2);
 700					      print $OUT "Choosing $try matching `$file':\n";
 701					      $file = $try;
 702					  }}
 703			}
 704			if (!defined $main::{'_<' . $file}) {
 705			    print $OUT "No file matching `$file' is loaded.\n";
 706			    next CMD;
 707			} elsif ($file ne $filename) {
 708			    *dbline = $main::{'_<' . $file};
 709			    $max = $#dbline;
 710			    $filename = $file;
 711			    $start = 1;
 712			    $cmd = "l";
 713			  } else {
 714			    print $OUT "Already in $file.\n";
 715			    next CMD;
 716			  }
 717		      };
 718		    $cmd =~ s/^l\s+-\s*$/-/;
 719		    $cmd =~ /^([lb])\b\s*(\$.*)/s && do {
 720			$evalarg = $2;
 721			my ($s) = &eval;
 722			print($OUT "Error: $@\n"), next CMD if $@;
 723			$s = CvGV_name($s);
 724			print($OUT "Interpreted as: $1 $s\n");
 725			$cmd = "$1 $s";
 726		    };
 727		    $cmd =~ /^l\b\s*([\':A-Za-z_][\':\w]*(\[.*\])?)/s && do {
 728			$subname = $1;
 729			$subname =~ s/\'/::/;
 730			$subname = $package."::".$subname 
 731			  unless $subname =~ /::/;
 732			$subname = "main".$subname if substr($subname,0,2) eq "::";
 733			@pieces = split(/:/,find_sub($subname) || $sub{$subname});
 734			$subrange = pop @pieces;
 735			$file = join(':', @pieces);
 736			if ($file ne $filename) {
 737			    print $OUT "Switching to file '$file'.\n"
 738				unless $slave_editor;
 739			    *dbline = $main::{'_<' . $file};
 740			    $max = $#dbline;
 741			    $filename = $file;
 742			}
 743			if ($subrange) {
 744			    if (eval($subrange) < -$window) {
 745				$subrange =~ s/-.*/+/;
 746			    }
 747			    $cmd = "l $subrange";
 748			} else {
 749			    print $OUT "Subroutine $subname not found.\n";
 750			    next CMD;
 751			} };
 752		    $cmd =~ /^\.$/ && do {
 753			$incr = -1;		# for backward motion.
 754			$start = $line;
 755			$filename = $filename_ini;
 756			*dbline = $main::{'_<' . $filename};
 757			$max = $#dbline;
 758			print $LINEINFO $position;
 759			next CMD };
 760		    $cmd =~ /^w\b\s*(\d*)$/ && do {
 761			$incr = $window - 1;
 762			$start = $1 if $1;
 763			$start -= $preview;
 764			#print $OUT 'l ' . $start . '-' . ($start + $incr);
 765			$cmd = 'l ' . $start . '-' . ($start + $incr); };
 766		    $cmd =~ /^-$/ && do {
 767			$start -= $incr + $window + 1;
 768			$start = 1 if $start <= 0;
 769			$incr = $window - 1;
 770			$cmd = 'l ' . ($start) . '+'; };
 771		    $cmd =~ /^l$/ && do {
 772			$incr = $window - 1;
 773			$cmd = 'l ' . $start . '-' . ($start + $incr); };
 774		    $cmd =~ /^l\b\s*(\d*)\+(\d*)$/ && do {
 775			$start = $1 if $1;
 776			$incr = $2;
 777			$incr = $window - 1 unless $incr;
 778			$cmd = 'l ' . $start . '-' . ($start + $incr); };
 779		    $cmd =~ /^l\b\s*((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
 780			$end = (!defined $2) ? $max : ($4 ? $4 : $2);
 781			$end = $max if $end > $max;
 782			$i = $2;
 783			$i = $line if $i eq '.';
 784			$i = 1 if $i < 1;
 785			$incr = $end - $i;
 786			if ($slave_editor) {
 787			    print $OUT "\032\032$filename:$i:0\n";
 788			    $i = $end;
 789			} else {
 790			    for (; $i <= $end; $i++) {
 791			        ($stop,$action) = split(/\0/, $dbline{$i});
 792			        $arrow = ($i==$line 
 793					  and $filename eq $filename_ini) 
 794				  ?  '==>' 
 795				    : ($dbline[$i]+0 ? ':' : ' ') ;
 796				$arrow .= 'b' if $stop;
 797				$arrow .= 'a' if $action;
 798				print $OUT "$i$arrow\t", $dbline[$i];
 799				$i++, last if $signal;
 800			    }
 801			    print $OUT "\n" unless $dbline[$i-1] =~ /\n$/;
 802			}
 803			$start = $i; # remember in case they want more
 804			$start = $max if $start > $max;
 805			next CMD; };
 806		    $cmd =~ /^D$/ && do {
 807		      print $OUT "Deleting all breakpoints...\n";
 808		      my $file;
 809		      for $file (keys %had_breakpoints) {
 810			local *dbline = $main::{'_<' . $file};
 811			my $max = $#dbline;
 812			my $was;
 813			
 814			for ($i = 1; $i <= $max ; $i++) {
 815			    if (defined $dbline{$i}) {
 816				$dbline{$i} =~ s/^[^\0]+//;
 817				if ($dbline{$i} =~ s/^\0?$//) {
 818				    delete $dbline{$i};
 819				}
 820			    }
 821			}
 822			
 823			if (not $had_breakpoints{$file} &= ~1) {
 824			    delete $had_breakpoints{$file};
 825			}
 826		      }
 827		      undef %postponed;
 828		      undef %postponed_file;
 829		      undef %break_on_load;
 830		      next CMD; };
 831		    $cmd =~ /^L$/ && do {
 832		      my $file;
 833		      for $file (keys %had_breakpoints) {
 834			local *dbline = $main::{'_<' . $file};
 835			my $max = $#dbline;
 836			my $was;
 837			
 838			for ($i = 1; $i <= $max; $i++) {
 839			    if (defined $dbline{$i}) {
 840			        print $OUT "$file:\n" unless $was++;
 841				print $OUT " $i:\t", $dbline[$i];
 842				($stop,$action) = split(/\0/, $dbline{$i});
 843				print $OUT "   break if (", $stop, ")\n"
 844				  if $stop;
 845				print $OUT "   action:  ", $action, "\n"
 846				  if $action;
 847				last if $signal;
 848			    }
 849			}
 850		      }
 851		      if (%postponed) {
 852			print $OUT "Postponed breakpoints in subroutines:\n";
 853			my $subname;
 854			for $subname (keys %postponed) {
 855			  print $OUT " $subname\t$postponed{$subname}\n";
 856			  last if $signal;
 857			}
 858		      }
 859		      my @have = map { # Combined keys
 860			keys %{$postponed_file{$_}}
 861		      } keys %postponed_file;
 862		      if (@have) {
 863			print $OUT "Postponed breakpoints in files:\n";
 864			my ($file, $line);
 865			for $file (keys %postponed_file) {
 866			  my $db = $postponed_file{$file};
 867			  print $OUT " $file:\n";
 868			  for $line (sort {$a <=> $b} keys %$db) {
 869				print $OUT "  $line:\n";
 870				my ($stop,$action) = split(/\0/, $$db{$line});
 871				print $OUT "    break if (", $stop, ")\n"
 872				  if $stop;
 873				print $OUT "    action:  ", $action, "\n"
 874				  if $action;
 875				last if $signal;
 876			  }
 877			  last if $signal;
 878			}
 879		      }
 880		      if (%break_on_load) {
 881			print $OUT "Breakpoints on load:\n";
 882			my $file;
 883			for $file (keys %break_on_load) {
 884			  print $OUT " $file\n";
 885			  last if $signal;
 886			}
 887		      }
 888		      if ($trace & 2) {
 889			print $OUT "Watch-expressions:\n";
 890			my $expr;
 891			for $expr (@to_watch) {
 892			  print $OUT " $expr\n";
 893			  last if $signal;
 894			}
 895		      }
 896		      next CMD; };
 897		    $cmd =~ /^b\b\s*load\b\s*(.*)/ && do {
 898			my $file = $1; $file =~ s/\s+$//;
 899			{
 900			  $break_on_load{$file} = 1;
 901			  $break_on_load{$::INC{$file}} = 1 if $::INC{$file};
 902			  $file .= '.pm', redo unless $file =~ /\./;
 903			}
 904			$had_breakpoints{$file} |= 1;
 905			print $OUT "Will stop on load of `@{[join '\', `', sort keys %break_on_load]}'.\n";
 906			next CMD; };
 907		    $cmd =~ /^b\b\s*(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
 908			my $cond = length $3 ? $3 : '1';
 909			my ($subname, $break) = ($2, $1 eq 'postpone');
 910			$subname =~ s/\'/::/g;
 911			$subname = "${'package'}::" . $subname
 912			  unless $subname =~ /::/;
 913			$subname = "main".$subname if substr($subname,0,2) eq "::";
 914			$postponed{$subname} = $break 
 915			  ? "break +0 if $cond" : "compile";
 916			next CMD; };
 917		    $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/ && do {
 918			$subname = $1;
 919			$cond = length $2 ? $2 : '1';
 920			$subname =~ s/\'/::/g;
 921			$subname = "${'package'}::" . $subname
 922			  unless $subname =~ /::/;
 923			$subname = "main".$subname if substr($subname,0,2) eq "::";
 924			# Filename below can contain ':'
 925			($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
 926			$i += 0;
 927			if ($i) {
 928			    local $filename = $file;
 929			    local *dbline = $main::{'_<' . $filename};
 930			    $had_breakpoints{$filename} |= 1;
 931			    $max = $#dbline;
 932			    ++$i while $dbline[$i] == 0 && $i < $max;
 933			    $dbline{$i} =~ s/^[^\0]*/$cond/;
 934			} else {
 935			    print $OUT "Subroutine $subname not found.\n";
 936			}
 937			next CMD; };
 938		    $cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do {
 939			$i = $1 || $line;
 940			$cond = length $2 ? $2 : '1';
 941			if ($dbline[$i] == 0) {
 942			    print $OUT "Line $i not breakable.\n";
 943			} else {
 944			    $had_breakpoints{$filename} |= 1;
 945			    $dbline{$i} =~ s/^[^\0]*/$cond/;
 946			}
 947			next CMD; };
 948		    $cmd =~ /^d\b\s*(\d*)/ && do {
 949			$i = $1 || $line;
 950                        if ($dbline[$i] == 0) {
 951                            print $OUT "Line $i not breakable.\n";
 952                        } else {
 953			    $dbline{$i} =~ s/^[^\0]*//;
 954			    delete $dbline{$i} if $dbline{$i} eq '';
 955                        }
 956			next CMD; };
 957		    $cmd =~ /^A$/ && do {
 958		      print $OUT "Deleting all actions...\n";
 959		      my $file;
 960		      for $file (keys %had_breakpoints) {
 961			local *dbline = $main::{'_<' . $file};
 962			my $max = $#dbline;
 963			my $was;
 964			
 965			for ($i = 1; $i <= $max ; $i++) {
 966			    if (defined $dbline{$i}) {
 967				$dbline{$i} =~ s/\0[^\0]*//;
 968				delete $dbline{$i} if $dbline{$i} eq '';
 969			    }
 970			}
 971			
 972			unless ($had_breakpoints{$file} &= ~2) {
 973			    delete $had_breakpoints{$file};
 974			}
 975		      }
 976		      next CMD; };
 977		    $cmd =~ /^O\s*$/ && do {
 978			for (@options) {
 979			    &dump_option($_);
 980			}
 981			next CMD; };
 982		    $cmd =~ /^O\s*(\S.*)/ && do {
 983			parse_options($1);
 984			next CMD; };
 985		    $cmd =~ /^\<\<\s*(.*)/ && do { # \<\< for CPerl sake: not HERE
 986			push @$pre, action($1);
 987			next CMD; };
 988		    $cmd =~ /^>>\s*(.*)/ && do {
 989			push @$post, action($1);
 990			next CMD; };
 991		    $cmd =~ /^<\s*(.*)/ && do {
 992			unless ($1) {
 993			    print $OUT "All < actions cleared.\n";
 994			    $pre = [];
 995			    next CMD;
 996			} 
 997			if ($1 eq '?') {
 998			    unless (@$pre) {
 999				print $OUT "No pre-prompt Perl actions.\n";
1000				next CMD;
1001			    } 
1002			    print $OUT "Perl commands run before each prompt:\n";
1003			    for my $action ( @$pre ) {
1004				print $OUT "\t< -- $action\n";
1005			    } 
1006			    next CMD;
1007			} 
1008			$pre = [action($1)];
1009			next CMD; };
1010		    $cmd =~ /^>\s*(.*)/ && do {
1011			unless ($1) {
1012			    print $OUT "All > actions cleared.\n";
1013			    $post = [];
1014			    next CMD;
1015			}
1016			if ($1 eq '?') {
1017			    unless (@$post) {
1018				print $OUT "No post-prompt Perl actions.\n";
1019				next CMD;
1020			    } 
1021			    print $OUT "Perl commands run after each prompt:\n";
1022			    for my $action ( @$post ) {
1023				print $OUT "\t> -- $action\n";
1024			    } 
1025			    next CMD;
1026			} 
1027			$post = [action($1)];
1028			next CMD; };
1029		    $cmd =~ /^\{\{\s*(.*)/ && do {
1030			if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,2))) { 
1031			    print $OUT "{{ is now a debugger command\n",
1032				"use `;{{' if you mean Perl code\n";
1033			    $cmd = "h {{";
1034			    redo CMD;
1035			} 
1036			push @$pretype, $1;
1037			next CMD; };
1038		    $cmd =~ /^\{\s*(.*)/ && do {
1039			unless ($1) {
1040			    print $OUT "All { actions cleared.\n";
1041			    $pretype = [];
1042			    next CMD;
1043			}
1044			if ($1 eq '?') {
1045			    unless (@$pretype) {
1046				print $OUT "No pre-prompt debugger actions.\n";
1047				next CMD;
1048			    } 
1049			    print $OUT "Debugger commands run before each prompt:\n";
1050			    for my $action ( @$pretype ) {
1051				print $OUT "\t{ -- $action\n";
1052			    } 
1053			    next CMD;
1054			} 
1055			if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,1))) { 
1056			    print $OUT "{ is now a debugger command\n",
1057				"use `;{' if you mean Perl code\n";
1058			    $cmd = "h {";
1059			    redo CMD;
1060			} 
1061			$pretype = [$1];
1062			next CMD; };
1063		    $cmd =~ /^a\b\s*(\d*)\s*(.*)/ && do {
1064			$i = $1 || $line; $j = $2;
1065			if (length $j) {
1066			    if ($dbline[$i] == 0) {
1067				print $OUT "Line $i may not have an action.\n";
1068			    } else {
1069				$had_breakpoints{$filename} |= 2;
1070				$dbline{$i} =~ s/\0[^\0]*//;
1071				$dbline{$i} .= "\0" . action($j);
1072			    }
1073			} else {
1074			    $dbline{$i} =~ s/\0[^\0]*//;
1075			    delete $dbline{$i} if $dbline{$i} eq '';
1076			}
1077			next CMD; };
1078		    $cmd =~ /^n$/ && do {
1079		        end_report(), next CMD if $finished and $level <= 1;
1080			$single = 2;
1081			$laststep = $cmd;
1082			last CMD; };
1083		    $cmd =~ /^s$/ && do {
1084		        end_report(), next CMD if $finished and $level <= 1;
1085			$single = 1;
1086			$laststep = $cmd;
1087			last CMD; };
1088		    $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {
1089		        end_report(), next CMD if $finished and $level <= 1;
1090			$subname = $i = $1;
1091			#  Probably not needed, since we finish an interactive
1092			#  sub-session anyway...
1093			# local $filename = $filename;
1094			# local *dbline = *dbline;	# XXX Would this work?!
1095			if ($i =~ /\D/) { # subroutine name
1096			    $subname = $package."::".$subname 
1097			        unless $subname =~ /::/;
1098			    ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
1099			    $i += 0;
1100			    if ($i) {
1101			        $filename = $file;
1102				*dbline = $main::{'_<' . $filename};
1103				$had_breakpoints{$filename} |= 1;
1104				$max = $#dbline;
1105				++$i while $dbline[$i] == 0 && $i < $max;
1106			    } else {
1107				print $OUT "Subroutine $subname not found.\n";
1108				next CMD; 
1109			    }
1110			}
1111			if ($i) {
1112			    if ($dbline[$i] == 0) {
1113				print $OUT "Line $i not breakable.\n";
1114				next CMD;
1115			    }
1116			    $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
1117			}
1118			for ($i=0; $i <= $stack_depth; ) {
1119			    $stack[$i++] &= ~1;
1120			}
1121			last CMD; };
1122		    $cmd =~ /^r$/ && do {
1123		        end_report(), next CMD if $finished and $level <= 1;
1124			$stack[$stack_depth] |= 1;
1125			$doret = $option{PrintRet} ? $stack_depth - 1 : -2;
1126			last CMD; };
1127		    $cmd =~ /^R$/ && do {
1128		        print $OUT "Warning: some settings and command-line options may be lost!\n";
1129			my (@script, @flags, $cl);
1130			push @flags, '-w' if $ini_warn;
1131			# Put all the old includes at the start to get
1132			# the same debugger.
1133			for (@ini_INC) {
1134			  push @flags, '-I', $_;
1135			}
1136			# Arrange for setting the old INC:
1137			set_list("PERLDB_INC", @ini_INC);
1138			if ($0 eq '-e') {
1139			  for (1..$#{'::_<-e'}) { # The first line is PERL5DB
1140			        chomp ($cl =  ${'::_<-e'}[$_]);
1141			    push @script, '-e', $cl;
1142			  }
1143			} else {
1144			  @script = $0;
1145			}
1146			set_list("PERLDB_HIST", 
1147				 $term->Features->{getHistory} 
1148				 ? $term->GetHistory : @hist);
1149			my @had_breakpoints = keys %had_breakpoints;
1150			set_list("PERLDB_VISITED", @had_breakpoints);
1151			set_list("PERLDB_OPT", %option);
1152			set_list("PERLDB_ON_LOAD", %break_on_load);
1153			my @hard;
1154			for (0 .. $#had_breakpoints) {
1155			  my $file = $had_breakpoints[$_];
1156			  *dbline = $main::{'_<' . $file};
1157			  next unless %dbline or $postponed_file{$file};
1158			  (push @hard, $file), next 
1159			    if $file =~ /^\(eval \d+\)$/;
1160			  my @add;
1161			  @add = %{$postponed_file{$file}}
1162			    if $postponed_file{$file};
1163			  set_list("PERLDB_FILE_$_", %dbline, @add);
1164			}
1165			for (@hard) { # Yes, really-really...
1166			  # Find the subroutines in this eval
1167			  *dbline = $main::{'_<' . $_};
1168			  my ($quoted, $sub, %subs, $line) = quotemeta $_;
1169			  for $sub (keys %sub) {
1170			    next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
1171			    $subs{$sub} = [$1, $2];
1172			  }
1173			  unless (%subs) {
1174			    print $OUT
1175			      "No subroutines in $_, ignoring breakpoints.\n";
1176			    next;
1177			  }
1178			LINES: for $line (keys %dbline) {
1179			    # One breakpoint per sub only:
1180			    my ($offset, $sub, $found);
1181			  SUBS: for $sub (keys %subs) {
1182			      if ($subs{$sub}->[1] >= $line # Not after the subroutine
1183				  and (not defined $offset # Not caught
1184				       or $offset < 0 )) { # or badly caught
1185				$found = $sub;
1186				$offset = $line - $subs{$sub}->[0];
1187				$offset = "+$offset", last SUBS if $offset >= 0;
1188			      }
1189			    }
1190			    if (defined $offset) {
1191			      $postponed{$found} =
1192				"break $offset if $dbline{$line}";
1193			    } else {
1194			      print $OUT "Breakpoint in $_:$line ignored: after all the subroutines.\n";
1195			    }
1196			  }
1197			}
1198			set_list("PERLDB_POSTPONE", %postponed);
1199			set_list("PERLDB_PRETYPE", @$pretype);
1200			set_list("PERLDB_PRE", @$pre);
1201			set_list("PERLDB_POST", @$post);
1202			set_list("PERLDB_TYPEAHEAD", @typeahead);
1203			$ENV{PERLDB_RESTART} = 1;
1204			#print "$^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS";
1205			exec $^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS;
1206			print $OUT "exec failed: $!\n";
1207			last CMD; };
1208		    $cmd =~ /^T$/ && do {
1209			print_trace($OUT, 1); # skip DB
1210			next CMD; };
1211		    $cmd =~ /^W\s*$/ && do {
1212			$trace &= ~2;
1213			@to_watch = @old_watch = ();
1214			next CMD; };
1215		    $cmd =~ /^W\b\s*(.*)/s && do {
1216			push @to_watch, $1;
1217			$evalarg = $1;
1218			my ($val) = &eval;
1219			$val = (defined $val) ? "'$val'" : 'undef' ;
1220			push @old_watch, $val;
1221			$trace |= 2;
1222			next CMD; };
1223		    $cmd =~ /^\/(.*)$/ && do {
1224			$inpat = $1;
1225			$inpat =~ s:([^\\])/$:$1:;
1226			if ($inpat ne "") {
1227			    # squelch the sigmangler
1228			    local $SIG{__DIE__};
1229			    local $SIG{__WARN__};
1230			    eval '$inpat =~ m'."\a$inpat\a";	
1231			    if ($@ ne "") {
1232				print $OUT "$@";
1233				next CMD;
1234			    }
1235			    $pat = $inpat;
1236			}
1237			$end = $start;
1238			$incr = -1;
1239			eval '
1240			    for (;;) {
1241				++$start;
1242				$start = 1 if ($start > $max);
1243				last if ($start == $end);
1244				if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1245				    if ($slave_editor) {
1246					print $OUT "\032\032$filename:$start:0\n";
1247				    } else {
1248					print $OUT "$start:\t", $dbline[$start], "\n";
1249				    }
1250				    last;
1251				}
1252			    } ';
1253			print $OUT "/$pat/: not found\n" if ($start == $end);
1254			next CMD; };
1255		    $cmd =~ /^\?(.*)$/ && do {
1256			$inpat = $1;
1257			$inpat =~ s:([^\\])\?$:$1:;
1258			if ($inpat ne "") {
1259			    # squelch the sigmangler
1260			    local $SIG{__DIE__};
1261			    local $SIG{__WARN__};
1262			    eval '$inpat =~ m'."\a$inpat\a";	
1263			    if ($@ ne "") {
1264				print $OUT $@;
1265				next CMD;
1266			    }
1267			    $pat = $inpat;
1268			}
1269			$end = $start;
1270			$incr = -1;
1271			eval '
1272			    for (;;) {
1273				--$start;
1274				$start = $max if ($start <= 0);
1275				last if ($start == $end);
1276				if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1277				    if ($slave_editor) {
1278					print $OUT "\032\032$filename:$start:0\n";
1279				    } else {
1280					print $OUT "$start:\t", $dbline[$start], "\n";
1281				    }
1282				    last;
1283				}
1284			    } ';
1285			print $OUT "?$pat?: not found\n" if ($start == $end);
1286			next CMD; };
1287		    $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
1288			pop(@hist) if length($cmd) > 1;
1289			$i = $1 ? ($#hist-($2||1)) : ($2||$#hist);
1290			$cmd = $hist[$i];
1291			print $OUT $cmd, "\n";
1292			redo CMD; };
1293		    $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {
1294			&system($1);
1295			next CMD; };
1296		    $cmd =~ /^$rc([^$rc].*)$/ && do {
1297			$pat = "^$1";
1298			pop(@hist) if length($cmd) > 1;
1299			for ($i = $#hist; $i; --$i) {
1300			    last if $hist[$i] =~ /$pat/;
1301			}
1302			if (!$i) {
1303			    print $OUT "No such command!\n\n";
1304			    next CMD;
1305			}
1306			$cmd = $hist[$i];
1307			print $OUT $cmd, "\n";
1308			redo CMD; };
1309		    $cmd =~ /^$sh$/ && do {
1310			&system($ENV{SHELL}||"/bin/sh");
1311			next CMD; };
1312		    $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do {
1313			# XXX: using csh or tcsh destroys sigint retvals!
1314			#&system($1);  # use this instead
1315			&system($ENV{SHELL}||"/bin/sh","-c",$1);
1316			next CMD; };
1317		    $cmd =~ /^H\b\s*(-(\d+))?/ && do {
1318			$end = $2 ? ($#hist-$2) : 0;
1319			$hist = 0 if $hist < 0;
1320			for ($i=$#hist; $i>$end; $i--) {
1321			    print $OUT "$i: ",$hist[$i],"\n"
1322			      unless $hist[$i] =~ /^.?$/;
1323			};
1324			next CMD; };
1325		    $cmd =~ /^(?:man|(?:perl)?doc)\b(?:\s+([^(]*))?$/ && do {
1326			runman($1);
1327			next CMD; };
1328		    $cmd =~ s/^p$/print {\$DB::OUT} \$_/;
1329		    $cmd =~ s/^p\b/print {\$DB::OUT} /;
1330		    $cmd =~ s/^=\s*// && do {
1331			my @keys;
1332			if (length $cmd == 0) {
1333			    @keys = sort keys %alias;
1334			} 
1335                        elsif (my($k,$v) = ($cmd =~ /^(\S+)\s+(\S.*)/)) {
1336			    # can't use $_ or kill //g state
1337			    for my $x ($k, $v) { $x =~ s/\a/\\a/g }
1338			    $alias{$k} = "s\a$k\a$v\a";
1339			    # squelch the sigmangler
1340			    local $SIG{__DIE__};
1341			    local $SIG{__WARN__};
1342			    unless (eval "sub { s\a$k\a$v\a }; 1") {
1343				print $OUT "Can't alias $k to $v: $@\n"; 
1344				delete $alias{$k};
1345				next CMD;
1346			    } 
1347			    @keys = ($k);
1348			} 
1349			else {
1350			    @keys = ($cmd);
1351			} 
1352			for my $k (@keys) {
1353			    if ((my $v = $alias{$k}) =~ ss\a$k\a(.*)\a$1) {
1354				print $OUT "$k\t= $1\n";
1355			    } 
1356			    elsif (defined $alias{$k}) {
1357				    print $OUT "$k\t$alias{$k}\n";
1358			    } 
1359			    else {
1360				print "No alias for $k\n";
1361			    } 
1362			}
1363			next CMD; };
1364		    $cmd =~ /^\|\|?\s*[^|]/ && do {
1365			if ($pager =~ /^\|/) {
1366			    open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1367			    open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1368			} else {
1369			    open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT");
1370			}
1371			fix_less();
1372			unless ($piped=open(OUT,$pager)) {
1373			    &warn("Can't pipe output to `$pager'");
1374			    if ($pager =~ /^\|/) {
1375				open(OUT,">&STDOUT") # XXX: lost message
1376				    || &warn("Can't restore DB::OUT");
1377				open(STDOUT,">&SAVEOUT")
1378				  || &warn("Can't restore STDOUT");
1379				close(SAVEOUT);
1380			    } else {
1381				open(OUT,">&STDOUT") # XXX: lost message
1382				    || &warn("Can't restore DB::OUT");
1383			    }
1384			    next CMD;
1385			}
1386			$SIG{PIPE}= \&DB::catch if $pager =~ /^\|/
1387			    && ("" eq $SIG{PIPE}  ||  "DEFAULT" eq $SIG{PIPE});
1388			$selected= select(OUT);
1389			$|= 1;
1390			select( $selected ), $selected= "" unless $cmd =~ /^\|\|/;
1391			$cmd =~ s/^\|+\s*//;
1392			redo PIPE; 
1393		    };
1394		    # XXX Local variants do not work!
1395		    $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
1396		    $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
1397		    $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
1398		}		# PIPE:
1399	    $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
1400	    if ($onetimeDump) {
1401		$onetimeDump = undef;
1402	    } elsif ($term_pid == $$) {
1403		print $OUT "\n";
1404	    }
1405	} continue {		# CMD:
1406	    if ($piped) {
1407		if ($pager =~ /^\|/) {
1408		    $? = 0;  
1409		    # we cannot warn here: the handle is missing --tchrist
1410		    close(OUT) || print SAVEOUT "\nCan't close DB::OUT\n";
1411
1412		    # most of the $? crud was coping with broken cshisms
1413		    if ($?) {
1414			print SAVEOUT "Pager `$pager' failed: ";
1415			if ($? == -1) {
1416			    print SAVEOUT "shell returned -1\n";
1417			} elsif ($? >> 8) {
1418			    print SAVEOUT 
1419			      ( $? & 127 ) ? " (SIG#".($?&127).")" : "", 
1420			      ( $? & 128 ) ? " -- core dumped" : "", "\n";
1421			} else {
1422			    print SAVEOUT "status ", ($? >> 8), "\n";
1423			} 
1424		    } 
1425
1426		    open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1427		    open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1428		    $SIG{PIPE} = "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
1429		    # Will stop ignoring SIGPIPE if done like nohup(1)
1430		    # does SIGINT but Perl doesn't give us a choice.
1431		} else {
1432		    open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT");
1433		}
1434		close(SAVEOUT);
1435		select($selected), $selected= "" unless $selected eq "";
1436		$piped= "";
1437	    }
1438	}			# CMD:
1439       $fall_off_end = 1 unless defined $cmd; # Emulate `q' on EOF
1440	foreach $evalarg (@$post) {
1441	  &eval;
1442	}
1443    }				# if ($single || $signal)
1444    ($@, $!, $^E, $,, $/, $\, $^W) = @saved;
1445    ();
1446}
1447
1448# The following code may be executed now:
1449# BEGIN {warn 4}
1450
1451sub sub {
1452    my ($al, $ret, @ret) = "";
1453    if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') {
1454	$al = " for $$sub";
1455    }
1456    local $stack_depth = $stack_depth + 1; # Protect from non-local exits
1457    $#stack = $stack_depth;
1458    $stack[-1] = $single;
1459    $single &= 1;
1460    $single |= 4 if $stack_depth == $deep;
1461    ($frame & 4 
1462     ? ( (print $LINEINFO ' ' x ($stack_depth - 1), "in  "), 
1463	 # Why -1? But it works! :-(
1464	 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1465     : print $LINEINFO ' ' x ($stack_depth - 1), "entering $sub$al\n") if $frame;
1466    if (wantarray) {
1467	@ret = &$sub;
1468	$single |= $stack[$stack_depth--];
1469	($frame & 4 
1470	 ? ( (print $LINEINFO ' ' x $stack_depth, "out "), 
1471	     print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1472	 : print $LINEINFO ' ' x $stack_depth, "exited $sub$al\n") if $frame & 2;
1473	if ($doret eq $stack_depth or $frame & 16) {
1474            my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1475	    print $fh ' ' x $stack_depth if $frame & 16;
1476	    print $fh "list context return from $sub:\n"; 
1477	    dumpit($fh, \@ret );
1478	    $doret = -2;
1479	}
1480	@ret;
1481    } else {
1482        if (defined wantarray) {
1483	    $ret = &$sub;
1484        } else {
1485            &$sub; undef $ret;
1486        };
1487	$single |= $stack[$stack_depth--];
1488	($frame & 4 
1489	 ? ( (print $LINEINFO ' ' x $stack_depth, "out "), 
1490	      print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1491	 : print $LINEINFO ' ' x $stack_depth, "exited $sub$al\n") if $frame & 2;
1492	if ($doret eq $stack_depth or $frame & 16 and defined wantarray) {
1493            my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1494	    print $fh (' ' x $stack_depth) if $frame & 16;
1495	    print $fh (defined wantarray 
1496			 ? "scalar context return from $sub: " 
1497			 : "void context return from $sub\n");
1498	    dumpit( $fh, $ret ) if defined wantarray;
1499	    $doret = -2;
1500	}
1501	$ret;
1502    }
1503}
1504
1505sub save {
1506    @saved = ($@, $!, $^E, $,, $/, $\, $^W);
1507    $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
1508}
1509
1510# The following takes its argument via $evalarg to preserve current @_
1511
1512sub eval {
1513    # 'my' would make it visible from user code
1514    #    but so does local! --tchrist  
1515    local @res;			
1516    {
1517	local $otrace = $trace;
1518	local $osingle = $single;
1519	local $od = $^D;
1520	{ ($evalarg) = $evalarg =~ /(.*)/s; }
1521	@res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
1522	$trace = $otrace;
1523	$single = $osingle;
1524	$^D = $od;
1525    }
1526    my $at = $@;
1527    local $saved[0];		# Preserve the old value of $@
1528    eval { &DB::save };
1529    if ($at) {
1530	print $OUT $at;
1531    } elsif ($onetimeDump eq 'dump') {
1532	dumpit($OUT, \@res);
1533    } elsif ($onetimeDump eq 'methods') {
1534	methods($res[0]);
1535    }
1536    @res;
1537}
1538
1539sub postponed_sub {
1540  my $subname = shift;
1541  if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) {
1542    my $offset = $1 || 0;
1543    # Filename below can contain ':'
1544    my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
1545    if ($i) {
1546      $i += $offset;
1547      local *dbline = $main::{'_<' . $file};
1548      local $^W = 0;		# != 0 is magical below
1549      $had_breakpoints{$file} |= 1;
1550      my $max = $#dbline;
1551      ++$i until $dbline[$i] != 0 or $i >= $max;
1552      $dbline{$i} = delete $p

Large files files are truncated, but you can click here to view the full file