lib/perl5db.pl

   1 package 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
 195 BEGIN { $ini_warn = $^W; $^W = 0 } # Switch compilation warnings off until another BEGIN.
 196 local($^W) = 0;                 # Switch run-time warnings off during init.
 197 warn (                  # 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
 284 warnLevel($warnLevel);
 285 dieLevel($dieLevel);
 286 signalLevel($signalLevel);
 287
 288 &pager(
 289     (defined($ENV{PAGER})
 290         ? $ENV{PAGER}
 291         : ($^O eq 'os2'
 292            ? 'cmd /c more'
 293            : 'more'))) unless defined $pager;
 294 setman();
 295 &recallCommand("!") unless defined $prc;
 296 &shellBang("!") unless defined $psh;
 297 $maxtrace = 400 unless defined $maxtrace;
 298
 299 if (-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.
 310 sub 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;
 319 perldb: 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.
 322 EO_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.
 337 sub 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
 347 if (-f $rcfile) {
 348     safe_do("./$rcfile");
 349 }
 350 elsif (defined $ENV{HOME} && -f "$ENV{HOME}/$rcfile") {
 351     safe_do("$ENV{HOME}/$rcfile");
 352 }
 353 elsif (defined $ENV{LOGDIR} && -f "$ENV{LOGDIR}/$rcfile") {
 354     safe_do("$ENV{LOGDIR}/$rcfile");
 355 }
 356
 357 if (defined $ENV{PERLDB_OPTS}) {
 358   parse_options($ENV{PERLDB_OPTS});
 359 }
 360
 361 # Here begin the unreadable code.  It needs fixing.
 362
 363 if (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
 388 if ($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;
 473 for (@args) {
 474     s/\'/\\\'/g;
 475     s/(.*)/'$1'/ unless /^-?[\d.]+$/;
 476 }
 477
 478 if (defined &afterinit) {       # May be defined in $rcfile
 479   &afterinit();
 480 }
 481
 482 $I_m_init = 1;
 483
 484 ############################################################ Subroutines
 485
 486 sub 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;
 526 Watchpoint $n:\t$to_watch[$n] changed:
 527     old value:\t$old_watch[$n]
 528     new value:\t$val
 529 EOP
 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);
 547 Debugged 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.
 550 EOP
 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}) =~ s\as\a$k\a(.*)\a$\a1\a) {
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
1451 sub 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
1505 sub save {
1506     @saved = ($@, $!, $^E, $,, $/, $\, $^W);
1507     $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
1508 }
1509
1510 # The following takes its argument via $evalarg to preserve current @_
1511
1512 sub 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
1539 sub 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 $postponed{$subname};
1553     } else {
1554       print $OUT "Subroutine $subname not found.\n";
1555     }
1556     return;
1557   }
1558   elsif ($postponed{$subname} eq 'compile') { $signal = 1 }
1559   #print $OUT "In postponed_sub for `$subname'.\n";
1560 }
1561
1562 sub postponed {
1563   if ($ImmediateStop) {
1564     $ImmediateStop = 0;
1565     $signal = 1;
1566   }
1567   return &postponed_sub
1568     unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
1569   # Cannot be done before the file is compiled
1570   local *dbline = shift;
1571   my $filename = $dbline;
1572   $filename =~ s/^_<//;
1573   $signal = 1, print $OUT "'$filename' loaded...\n"
1574     if $break_on_load{$filename};
1575   print $LINEINFO ' ' x $stack_depth, "Package $filename.\n" if $frame;
1576   return unless $postponed_file{$filename};
1577   $had_breakpoints{$filename} |= 1;
1578   #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
1579   my $key;
1580   for $key (keys %{$postponed_file{$filename}}) {
1581     $dbline{$key} = ${$postponed_file{$filename}}{$key};
1582   }
1583   delete $postponed_file{$filename};
1584 }
1585
1586 sub dumpit {
1587     local ($savout) = select(shift);
1588     my $osingle = $single;
1589     my $otrace = $trace;
1590     $single = $trace = 0;
1591     local $frame = 0;
1592     local $doret = -2;
1593     unless (defined &main::dumpValue) {
1594         do 'dumpvar.pl';
1595     }
1596     if (defined &main::dumpValue) {
1597         &main::dumpValue(shift);
1598     } else {
1599         print $OUT "dumpvar.pl not available.\n";
1600     }
1601     $single = $osingle;
1602     $trace = $otrace;
1603     select ($savout);
1604 }
1605
1606 # Tied method do not create a context, so may get wrong message:
1607
1608 sub print_trace {
1609   my $fh = shift;
1610   my @sub = dump_trace($_[0] + 1, $_[1]);
1611   my $short = $_[2];            # Print short report, next one for sub name
1612   my $s;
1613   for ($i=0; $i <= $#sub; $i++) {
1614     last if $signal;
1615     local $" = ', ';
1616     my $args = defined $sub[$i]{args}
1617     ? "(@{ $sub[$i]{args} })"
1618       : '' ;
1619     $args = (substr $args, 0, $maxtrace - 3) . '...'
1620       if length $args > $maxtrace;
1621     my $file = $sub[$i]{file};
1622     $file = $file eq '-e' ? $file : "file `$file'" unless $short;
1623     $s = $sub[$i]{sub};
1624     $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace;
1625     if ($short) {
1626       my $sub = @_ >= 4 ? $_[3] : $s;
1627       print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
1628     } else {
1629       print $fh "$sub[$i]{context} = $s$args" .
1630         " called from $file" .
1631           " line $sub[$i]{line}\n";
1632     }
1633   }
1634 }
1635
1636 sub dump_trace {
1637   my $skip = shift;
1638   my $count = shift || 1e9;
1639   $skip++;
1640   $count += $skip;
1641   my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
1642   my $nothard = not $frame & 8;
1643   local $frame = 0;             # Do not want to trace this.
1644   my $otrace = $trace;
1645   $trace = 0;
1646   for ($i = $skip;
1647        $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i);
1648        $i++) {
1649     @a = ();
1650     for $arg (@args) {
1651       my $type;
1652       if (not defined $arg) {
1653         push @a, "undef";
1654       } elsif ($nothard and tied $arg) {
1655         push @a, "tied";
1656       } elsif ($nothard and $type = ref $arg) {
1657         push @a, "ref($type)";
1658       } else {
1659         local $_ = "$arg";      # Safe to stringify now - should not call f().
1660         s/([\'\\])/\\$1/g;
1661         s/(.*)/'$1'/s
1662           unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
1663         s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
1664         s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
1665         push(@a, $_);
1666       }
1667     }
1668     $context = $context ? '@' : (defined $context ? "\$" : '.');
1669     $args = $h ? [@a] : undef;
1670     $e =~ s/\n\s*\;\s*\Z// if $e;
1671     $e =~ s/([\\\'])/\\$1/g if $e;
1672     if ($r) {
1673       $sub = "require '$e'";
1674     } elsif (defined $r) {
1675       $sub = "eval '$e'";
1676     } elsif ($sub eq '(eval)') {
1677       $sub = "eval {...}";
1678     }
1679     push(@sub, {context => $context, sub => $sub, args => $args,
1680                 file => $file, line => $line});
1681     last if $signal;
1682   }
1683   $trace = $otrace;
1684   @sub;
1685 }
1686
1687 sub action {
1688     my $action = shift;
1689     while ($action =~ s/\\$//) {
1690         #print $OUT "+ ";
1691         #$action .= "\n";
1692         $action .= &gets;
1693     }
1694     $action;
1695 }
1696
1697 sub unbalanced {
1698     # i hate using globals!
1699     $balanced_brace_re ||= qr{
1700         ^ \{
1701               (?:
1702                  (?> [^{}] + )              # Non-parens without backtracking
1703                |
1704                  (??{ $balanced_brace_re }) # Group with matching parens
1705               ) *
1706           \} $
1707    }x;
1708    return $_[0] !~ m/$balanced_brace_re/;
1709 }
1710
1711 sub gets {
1712     &readline("cont: ");
1713 }
1714
1715 sub system {
1716     # We save, change, then restore STDIN and STDOUT to avoid fork() since
1717     # some non-Unix systems can do system() but have problems with fork().
1718     open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
1719     open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1720     open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
1721     open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1722
1723     # XXX: using csh or tcsh destroys sigint retvals!
1724     system(@_);
1725     open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
1726     open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1727     close(SAVEIN);
1728     close(SAVEOUT);
1729
1730
1731     # most of the $? crud was coping with broken cshisms
1732     if ($? >> 8) {
1733         &warn("(Command exited ", ($? >> 8), ")\n");
1734     } elsif ($?) {
1735         &warn( "(Command died of SIG#",  ($? & 127),
1736             (($? & 128) ? " -- core dumped" : "") , ")", "\n");
1737     }
1738
1739     return $?;
1740
1741 }
1742
1743 sub setterm {
1744     local $frame = 0;
1745     local $doret = -2;
1746     eval { require Term::ReadLine } or die $@;
1747     if ($notty) {
1748         if ($tty) {
1749             open(IN,"<$tty") or die "Cannot open TTY `$TTY' for read: $!";
1750             open(OUT,">$tty") or die "Cannot open TTY `$TTY' for write: $!";
1751             $IN = \*IN;
1752             $OUT = \*OUT;
1753             my $sel = select($OUT);
1754             $| = 1;
1755             select($sel);
1756         } else {
1757             eval "require Term::Rendezvous;" or die;
1758             my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
1759             my $term_rv = new Term::Rendezvous $rv;
1760             $IN = $term_rv->IN;
1761             $OUT = $term_rv->OUT;
1762         }
1763     }
1764     if (!$rl) {
1765         $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
1766     } else {
1767         $term = new Term::ReadLine 'perldb', $IN, $OUT;
1768
1769         $rl_attribs = $term->Attribs;
1770         $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}'
1771           if defined $rl_attribs->{basic_word_break_characters}
1772             and index($rl_attribs->{basic_word_break_characters}, ":") == -1;
1773         $rl_attribs->{special_prefixes} = '$@&%';
1774         $rl_attribs->{completer_word_break_characters} .= '$@&%';
1775         $rl_attribs->{completion_function} = \&db_complete;
1776     }
1777     $LINEINFO = $OUT unless defined $LINEINFO;
1778     $lineinfo = $console unless defined $lineinfo;
1779     $term->MinLine(2);
1780     if ($term->Features->{setHistory} and "@hist" ne "?") {
1781       $term->SetHistory(@hist);
1782     }
1783     ornaments($ornaments) if defined $ornaments;
1784     $term_pid = $$;
1785 }
1786
1787 sub resetterm {                 # We forked, so we need a different TTY
1788     $term_pid = $$;
1789     if (defined &get_fork_TTY) {
1790       &get_fork_TTY;
1791     } elsif (not defined $fork_TTY
1792              and defined $ENV{TERM} and $ENV{TERM} eq 'xterm'
1793              and defined $ENV{WINDOWID} and defined $ENV{DISPLAY}) {
1794         # Possibly _inside_ XTERM
1795         open XT, q[3>&1 xterm -title 'Forked Perl debugger' -e sh -c 'tty 1>&3;\
1796  sleep 10000000' |];
1797         $fork_TTY = <XT>;
1798         chomp $fork_TTY;
1799     }
1800     if (defined $fork_TTY) {
1801       TTY($fork_TTY);
1802       undef $fork_TTY;
1803     } else {
1804       print_help(<<EOP);
1805 I<#########> Forked, but do not know how to change a B<TTY>. I<#########>
1806   Define B<\$DB::fork_TTY>
1807        - or a function B<DB::get_fork_TTY()> which will set B<\$DB::fork_TTY>.
1808   The value of B<\$DB::fork_TTY> should be the name of I<TTY> to use.
1809   On I<UNIX>-like systems one can get the name of a I<TTY> for the given window
1810   by typing B<tty>, and disconnect the I<shell> from I<TTY> by B<sleep 1000000>.
1811 EOP
1812     }
1813 }
1814
1815 sub readline {
1816   local $.;
1817   if (@typeahead) {
1818     my $left = @typeahead;
1819     my $got = shift @typeahead;
1820     print $OUT "auto(-$left)", shift, $got, "\n";
1821     $term->AddHistory($got)
1822       if length($got) > 1 and defined $term->Features->{addHistory};
1823     return $got;
1824   }
1825   local $frame = 0;
1826   local $doret = -2;
1827   if (ref $OUT and UNIVERSAL::isa($OUT, 'IO::Socket::INET')) {
1828     $OUT->write(join('', @_));
1829     my $stuff;
1830     $IN->recv( $stuff, 2048 );  # XXX: what's wrong with sysread?
1831     $stuff;
1832   }
1833   else {
1834     $term->readline(@_);
1835   }
1836 }
1837
1838 sub dump_option {
1839     my ($opt, $val)= @_;
1840     $val = option_val($opt,'N/A');
1841     $val =~ s/([\\\'])/\\$1/g;
1842     printf $OUT "%20s = '%s'\n", $opt, $val;
1843 }
1844
1845 sub option_val {
1846     my ($opt, $default)= @_;
1847     my $val;
1848     if (defined $optionVars{$opt}
1849         and defined ${$optionVars{$opt}}) {
1850         $val = ${$optionVars{$opt}};
1851     } elsif (defined $optionAction{$opt}
1852         and defined &{$optionAction{$opt}}) {
1853         $val = &{$optionAction{$opt}}();
1854     } elsif (defined $optionAction{$opt}
1855              and not defined $option{$opt}
1856              or defined $optionVars{$opt}
1857              and not defined ${$optionVars{$opt}}) {
1858         $val = $default;
1859     } else {
1860         $val = $option{$opt};
1861     }
1862     $val
1863 }
1864
1865 sub parse_options {
1866     local($_)= @_;
1867     # too dangerous to let intuitive usage overwrite important things
1868     # defaultion should never be the default
1869     my %opt_needs_val = map { ( $_ => 1 ) } qw{
1870         arrayDepth hashDepth LineInfo maxTraceLen ornaments
1871         pager quote ReadLine recallCommand RemotePort ShellBang TTY
1872     };
1873     while (length) {
1874         my $val_defaulted;
1875         s/^\s+// && next;
1876         s/^(\w+)(\W?)// or print($OUT "Invalid option `$_'\n"), last;
1877         my ($opt,$sep) = ($1,$2);
1878         my $val;
1879         if ("?" eq $sep) {
1880             print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
1881               if /^\S/;
1882             #&dump_option($opt);
1883         } elsif ($sep !~ /\S/) {
1884             $val_defaulted = 1;
1885             $val = "1";  #  this is an evil default; make 'em set it!
1886         } elsif ($sep eq "=") {
1887
1888             if (s/ (["']) ( (?: \\. | (?! \1 ) [^\\] )* ) \1 //x) {
1889                 my $quote = $1;
1890                 ($val = $2) =~ s/\\([$quote\\])/$1/g;
1891             } else {
1892                 s/^(\S*)//;
1893             $val = $1;
1894                 print OUT qq(Option better cleared using $opt=""\n)
1895                     unless length $val;
1896             }
1897
1898         } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
1899             my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
1900             s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
1901               print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
1902             ($val = $1) =~ s/\\([\\$end])/$1/g;
1903         }
1904
1905         my $option;
1906         my $matches = grep( /^\Q$opt/  && ($option = $_),  @options  )
1907                    || grep( /^\Q$opt/i && ($option = $_),  @options  );
1908
1909         print($OUT "Unknown option `$opt'\n"), next     unless $matches;
1910         print($OUT "Ambiguous option `$opt'\n"), next   if $matches > 1;
1911
1912        if ($opt_needs_val{$option} && $val_defaulted) {
1913             print $OUT "Option `$opt' is non-boolean.  Use `O $option=VAL' to set, `O $option?' to query\n";
1914             next;
1915         }
1916
1917         $option{$option} = $val if defined $val;
1918
1919         eval qq{
1920                 local \$frame = 0;
1921                 local \$doret = -2;
1922                 require '$optionRequire{$option}';
1923                 1;
1924          } || die  # XXX: shouldn't happen
1925             if  defined $optionRequire{$option}     &&
1926                 defined $val;
1927
1928         ${$optionVars{$option}} = $val
1929             if  defined $optionVars{$option}        &&
1930                 defined $val;
1931
1932         &{$optionAction{$option}} ($val)
1933             if defined $optionAction{$option}       &&
1934                defined &{$optionAction{$option}}    &&
1935                defined $val;
1936
1937         # Not $rcfile
1938         dump_option($option)    unless $OUT eq \*STDERR;
1939     }
1940 }
1941
1942 sub set_list {
1943   my ($stem,@list) = @_;
1944   my $val;
1945   $ENV{"${stem}_n"} = @list;
1946   for $i (0 .. $#list) {
1947     $val = $list[$i];
1948     $val =~ s/\\/\\\\/g;
1949     $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
1950     $ENV{"${stem}_$i"} = $val;
1951   }
1952 }
1953
1954 sub get_list {
1955   my $stem = shift;
1956   my @list;
1957   my $n = delete $ENV{"${stem}_n"};
1958   my $val;
1959   for $i (0 .. $n - 1) {
1960     $val = delete $ENV{"${stem}_$i"};
1961     $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
1962     push @list, $val;
1963   }
1964   @list;
1965 }
1966
1967 sub catch {
1968     $signal = 1;
1969     return;                     # Put nothing on the stack - malloc/free land!
1970 }
1971
1972 sub warn {
1973     my($msg)= join("",@_);
1974     $msg .= ": $!\n" unless $msg =~ /\n$/;
1975     print $OUT $msg;
1976 }
1977
1978 sub TTY {
1979     if (@_ and $term and $term->Features->{newTTY}) {
1980       my ($in, $out) = shift;
1981       if ($in =~ /,/) {
1982         ($in, $out) = split /,/, $in, 2;
1983       } else {
1984         $out = $in;
1985       }
1986       open IN, $in or die "cannot open `$in' for read: $!";
1987       open OUT, ">$out" or die "cannot open `$out' for write: $!";
1988       $term->newTTY(\*IN, \*OUT);
1989       $IN       = \*IN;
1990       $OUT      = \*OUT;
1991       return $tty = $in;
1992     } elsif ($term and @_) {
1993         &warn("Too late to set TTY, enabled on next `R'!\n");
1994     }
1995     $tty = shift if @_;
1996     $tty or $console;
1997 }
1998
1999 sub noTTY {
2000     if ($term) {
2001         &warn("Too late to set noTTY, enabled on next `R'!\n") if @_;
2002     }
2003     $notty = shift if @_;
2004     $notty;
2005 }
2006
2007 sub ReadLine {
2008     if ($term) {
2009         &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_;
2010     }
2011     $rl = shift if @_;
2012     $rl;
2013 }
2014
2015 sub RemotePort {
2016     if ($term) {
2017         &warn("Too late to set RemotePort, enabled on next 'R'!\n") if @_;
2018     }
2019     $remoteport = shift if @_;
2020     $remoteport;
2021 }
2022
2023 sub tkRunning {
2024     if (${$term->Features}{tkRunning}) {
2025         return $term->tkRunning(@_);
2026     } else {
2027         print $OUT "tkRunning not supported by current ReadLine package.\n";
2028         0;
2029     }
2030 }
2031
2032 sub NonStop {
2033     if ($term) {
2034         &warn("Too late to set up NonStop mode, enabled on next `R'!\n") if @_;
2035     }
2036     $runnonstop = shift if @_;
2037     $runnonstop;
2038 }
2039
2040 sub pager {
2041     if (@_) {
2042         $pager = shift;
2043         $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
2044     }
2045     $pager;
2046 }
2047
2048 sub shellBang {
2049     if (@_) {
2050         $sh = quotemeta shift;
2051         $sh .= "\\b" if $sh =~ /\w$/;
2052     }
2053     $psh = $sh;
2054     $psh =~ s/\\b$//;
2055     $psh =~ s/\\(.)/$1/g;
2056     &sethelp;
2057     $psh;
2058 }
2059
2060 sub ornaments {
2061   if (defined $term) {
2062     local ($warnLevel,$dieLevel) = (0, 1);
2063     return '' unless $term->Features->{ornaments};
2064     eval { $term->ornaments(@_) } || '';
2065   } else {
2066     $ornaments = shift;
2067   }
2068 }
2069
2070 sub recallCommand {
2071     if (@_) {
2072         $rc = quotemeta shift;
2073         $rc .= "\\b" if $rc =~ /\w$/;
2074     }
2075     $prc = $rc;
2076     $prc =~ s/\\b$//;
2077     $prc =~ s/\\(.)/$1/g;
2078     &sethelp;
2079     $prc;
2080 }
2081
2082 sub LineInfo {
2083     return $lineinfo unless @_;
2084     $lineinfo = shift;
2085     my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
2086     $slave_editor = ($stream =~ /^\|/);
2087     open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
2088     $LINEINFO = \*LINEINFO;
2089     my $save = select($LINEINFO);
2090     $| = 1;
2091     select($save);
2092     $lineinfo;
2093 }
2094
2095 sub list_versions {
2096   my %version;
2097   my $file;
2098   for (keys %INC) {
2099     $file = $_;
2100     s,\.p[lm]$,,i ;
2101     s,/,::,g ;
2102     s/^perl5db$/DB/;
2103     s/^Term::ReadLine::readline$/readline/;
2104     if (defined ${ $_ . '::VERSION' }) {
2105       $version{$file} = "${ $_ . '::VERSION' } from ";
2106     }
2107     $version{$file} .= $INC{$file};
2108   }
2109   dumpit($OUT,\%version);
2110 }
2111
2112 sub sethelp {
2113     # XXX: make sure these are tabs between the command and explantion,
2114     #      or print_help will screw up your formatting if you have
2115     #      eeevil ornaments enabled.  This is an insane mess.
2116
2117     $help = "
2118 B<T>            Stack trace.
2119 B<s> [I<expr>]  Single step [in I<expr>].
2120 B<n> [I<expr>]  Next, steps over subroutine calls [in I<expr>].
2121 <B<CR>>         Repeat last B<n> or B<s> command.
2122 B<r>            Return from current subroutine.
2123 B<c> [I<line>|I<sub>]   Continue; optionally inserts a one-time-only breakpoint
2124                 at the specified position.
2125 B<l> I<min>B<+>I<incr>  List I<incr>+1 lines starting at I<min>.
2126 B<l> I<min>B<->I<max>   List lines I<min> through I<max>.
2127 B<l> I<line>            List single I<line>.
2128 B<l> I<subname> List first window of lines from subroutine.
2129 B<l> I<\$var>           List first window of lines from subroutine referenced by I<\$var>.
2130 B<l>            List next window of lines.
2131 B<->            List previous window of lines.
2132 B<w> [I<line>]  List window around I<line>.
2133 B<.>            Return to the executed line.
2134 B<f> I<filename>        Switch to viewing I<filename>. File must be already loaded.
2135                 I<filename> may be either the full name of the file, or a regular
2136                 expression matching the full file name:
2137                 B<f> I</home/me/foo.pl> and B<f> I<oo\\.> may access the same file.
2138                 Evals (with saved bodies) are considered to be filenames:
2139                 B<f> I<(eval 7)> and B<f> I<eval 7\\b> access the body of the 7th eval
2140                 (in the order of execution).
2141 B</>I<pattern>B</>      Search forwards for I<pattern>; final B</> is optional.
2142 B<?>I<pattern>B<?>      Search backwards for I<pattern>; final B<?> is optional.
2143 B<L>            List all breakpoints and actions.
2144 B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>.
2145 B<t>            Toggle trace mode.
2146 B<t> I<expr>            Trace through execution of I<expr>.
2147 B<b> [I<line>] [I<condition>]
2148                 Set breakpoint; I<line> defaults to the current execution line;
2149                 I<condition> breaks if it evaluates to true, defaults to '1'.
2150 B<b> I<subname> [I<condition>]
2151                 Set breakpoint at first line of subroutine.
2152 B<b> I<\$var>           Set breakpoint at first line of subroutine referenced by I<\$var>.
2153 B<b> B<load> I<filename> Set breakpoint on `require'ing the given file.
2154 B<b> B<postpone> I<subname> [I<condition>]
2155                 Set breakpoint at first line of subroutine after
2156                 it is compiled.
2157 B<b> B<compile> I<subname>
2158                 Stop after the subroutine is compiled.
2159 B<d> [I<line>]  Delete the breakpoint for I<line>.
2160 B<D>            Delete all breakpoints.
2161 B<a> [I<line>] I<command>
2162                 Set an action to be done before the I<line> is executed;
2163                 I<line> defaults to the current execution line.
2164                 Sequence is: check for breakpoint/watchpoint, print line
2165                 if necessary, do action, prompt user if necessary,
2166                 execute line.
2167 B<a> [I<line>]  Delete the action for I<line>.
2168 B<A>            Delete all actions.
2169 B<W> I<expr>            Add a global watch-expression.
2170 B<W>            Delete all watch-expressions.
2171 B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current).
2172                 Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
2173 B<X> [I<vars>]  Same as \"B<V> I<currentpackage> [I<vars>]\".
2174 B<x> I<expr>            Evals expression in list context, dumps the result.
2175 B<m> I<expr>            Evals expression in list context, prints methods callable
2176                 on the first element of the result.
2177 B<m> I<class>           Prints methods callable via the given class.
2178
2179 B<<> ?                  List Perl commands to run before each prompt.
2180 B<<> I<expr>            Define Perl command to run before each prompt.
2181 B<<<> I<expr>           Add to the list of Perl commands to run before each prompt.
2182 B<>> ?                  List Perl commands to run after each prompt.
2183 B<>> I<expr>            Define Perl command to run after each prompt.
2184 B<>>B<>> I<expr>                Add to the list of Perl commands to run after each prompt.
2185 B<{> I<db_command>      Define debugger command to run before each prompt.
2186 B<{> ?                  List debugger commands to run before each prompt.
2187 B<<> I<expr>            Define Perl command to run before each prompt.
2188 B<{{> I<db_command>     Add to the list of debugger commands to run before each prompt.
2189 B<$prc> I<number>       Redo a previous command (default previous command).
2190 B<$prc> I<-number>      Redo number'th-to-last command.
2191 B<$prc> I<pattern>      Redo last command that started with I<pattern>.
2192                 See 'B<O> I<recallCommand>' too.
2193 B<$psh$psh> I<cmd>      Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
2194   . ( $rc eq $sh ? "" : "
2195 B<$psh> [I<cmd>]        Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
2196                 See 'B<O> I<shellBang>' too.
2197 B<H> I<-number> Display last number commands (default all).
2198 B<p> I<expr>            Same as \"I<print {DB::OUT} expr>\" in current package.
2199 B<|>I<dbcmd>            Run debugger command, piping DB::OUT to current pager.
2200 B<||>I<dbcmd>           Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
2201 B<\=> [I<alias> I<value>]       Define a command alias, or list current aliases.
2202 I<command>              Execute as a perl statement in current package.
2203 B<v>            Show versions of loaded modules.
2204 B<R>            Pure-man-restart of debugger, some of debugger state
2205                 and command-line options may be lost.
2206                 Currently the following setting are preserved:
2207                 history, breakpoints and actions, debugger B<O>ptions
2208                 and the following command-line options: I<-w>, I<-I>, I<-e>.
2209
2210 B<O> [I<opt>] ...       Set boolean option to true
2211 B<O> [I<opt>B<?>]       Query options
2212 B<O> [I<opt>B<=>I<val>] [I<opt>=B<\">I<val>B<\">] ...
2213                 Set options.  Use quotes in spaces in value.
2214     I<recallCommand>, I<ShellBang>      chars used to recall command or spawn shell;
2215     I<pager>                    program for output of \"|cmd\";
2216     I<tkRunning>                        run Tk while prompting (with ReadLine);
2217     I<signalLevel> I<warnLevel> I<dieLevel>     level of verbosity;
2218     I<inhibit_exit>             Allows stepping off the end of the script.
2219     I<ImmediateStop>            Debugger should stop as early as possible.
2220     I<RemotePort>                       Remote hostname:port for remote debugging
2221   The following options affect what happens with B<V>, B<X>, and B<x> commands:
2222     I<arrayDepth>, I<hashDepth>         print only first N elements ('' for all);
2223     I<compactDump>, I<veryCompact>      change style of array and hash dump;
2224     I<globPrint>                        whether to print contents of globs;
2225     I<DumpDBFiles>              dump arrays holding debugged files;
2226     I<DumpPackages>             dump symbol tables of packages;
2227     I<DumpReused>                       dump contents of \"reused\" addresses;
2228     I<quote>, I<HighBit>, I<undefPrint>         change style of string dump;
2229     I<bareStringify>            Do not print the overload-stringified value;
2230   Other options include:
2231     I<PrintRet>         affects printing of return value after B<r> command,
2232     I<frame>            affects printing messages on entry and exit from subroutines.
2233     I<AutoTrace>        affects printing messages on every possible breaking point.
2234     I<maxTraceLen>      gives maximal length of evals/args listed in stack trace.
2235     I<ornaments>        affects screen appearance of the command line.
2236         During startup options are initialized from \$ENV{PERLDB_OPTS}.
2237         You can put additional initialization options I<TTY>, I<noTTY>,
2238         I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use
2239         `B<R>' after you set them).
2240
2241 B<q> or B<^D>           Quit. Set B<\$DB::finished = 0> to debug global destruction.
2242 B<h> [I<db_command>]    Get help [on a specific debugger command], enter B<|h> to page.
2243 B<h h>          Summary of debugger commands.
2244 B<$doccmd> I<manpage>   Runs the external doc viewer B<$doccmd> command on the
2245                 named Perl I<manpage>, or on B<$doccmd> itself if omitted.
2246                 Set B<\$DB::doccmd> to change viewer.
2247
2248 Type `|h' for a paged display if this was too hard to read.
2249
2250 "; # Fix balance of vi % matching: } }}
2251
2252     $summary = <<"END_SUM";
2253 I<List/search source lines:>               I<Control script execution:>
2254   B<l> [I<ln>|I<sub>]  List source code            B<T>           Stack trace
2255   B<-> or B<.>      List previous/current line  B<s> [I<expr>]    Single step [in expr]
2256   B<w> [I<line>]    List around line            B<n> [I<expr>]    Next, steps over subs
2257   B<f> I<filename>  View source in file         <B<CR>/B<Enter>>  Repeat last B<n> or B<s>
2258   B</>I<pattern>B</> B<?>I<patt>B<?>   Search forw/backw    B<r>           Return from subroutine
2259   B<v>        Show versions of modules    B<c> [I<ln>|I<sub>]  Continue until position
2260 I<Debugger controls:>                        B<L>           List break/watch/actions
2261   B<O> [...]     Set debugger options        B<t> [I<expr>]    Toggle trace [trace expr]
2262   B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I<cmd>] Do pre/post-prompt B<b> [I<ln>|I<event>|I<sub>] [I<cnd>] Set breakpoint
2263   B<$prc> [I<N>|I<pat>]   Redo a previous command     B<d> [I<ln>] or B<D> Delete a/all breakpoints
2264   B<H> [I<-num>]    Display last num commands   B<a> [I<ln>] I<cmd>  Do cmd before line
2265   B<=> [I<a> I<val>]   Define/list an alias        B<W> I<expr>      Add a watch expression
2266   B<h> [I<db_cmd>]  Get help on command         B<A> or B<W>      Delete all actions/watch
2267   B<|>[B<|>]I<db_cmd>  Send output to pager        B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
2268   B<q> or B<^D>     Quit                          B<R>        Attempt a restart
2269 I<Data Examination:>          B<expr>     Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
2270   B<x>|B<m> I<expr>     Evals expr in list context, dumps the result or lists methods.
2271   B<p> I<expr>  Print expression (uses script's current package).
2272   B<S> [[B<!>]I<pat>]   List subroutine names [not] matching pattern
2273   B<V> [I<Pk> [I<Vars>]]        List Variables in Package.  Vars can be ~pattern or !pattern.
2274   B<X> [I<Vars>]        Same as \"B<V> I<current_package> [I<Vars>]\".
2275 For more help, type B<h> I<cmd_letter>, or run B<$doccmd perldebug> for all docs.
2276 END_SUM
2277                                 # ')}}; # Fix balance of vi % matching
2278 }
2279
2280 sub print_help {
2281     local $_ = shift;
2282
2283     # Restore proper alignment destroyed by eeevil I<> and B<>
2284     # ornaments: A pox on both their houses!
2285     #
2286     # A help command will have everything up to and including
2287     # the first tab sequence paddeed into a field 16 (or if indented 20)
2288     # wide.  If it's wide than that, an extra space will be added.
2289     s{
2290         ^                       # only matters at start of line
2291           ( \040{4} | \t )*     # some subcommands are indented
2292           ( < ?                 # so <CR> works
2293             [BI] < [^\t\n] + )  # find an eeevil ornament
2294           ( \t+ )               # original separation, discarded
2295           ( .* )                # this will now start (no earlier) than
2296                                 # column 16
2297     } {
2298         my($leadwhite, $command, $midwhite, $text) = ($1, $2, $3, $4);
2299         my $clean = $command;
2300         $clean =~ s/[BI]<([^>]*)>/$1/g;
2301     # replace with this whole string:
2302         (length($leadwhite) ? " " x 4 : "")
2303       . $command
2304       . ((" " x (16 + (length($leadwhite) ? 4 : 0) - length($clean))) || " ")
2305       . $text;
2306
2307     }mgex;
2308
2309     s{                          # handle bold ornaments
2310         B < ( [^>] + | > ) >
2311     } {
2312           $Term::ReadLine::TermCap::rl_term_set[2]
2313         . $1
2314         . $Term::ReadLine::TermCap::rl_term_set[3]
2315     }gex;
2316
2317     s{                          # handle italic ornaments
2318         I < ( [^>] + | > ) >
2319     } {
2320           $Term::ReadLine::TermCap::rl_term_set[0]
2321         . $1
2322         . $Term::ReadLine::TermCap::rl_term_set[1]
2323     }gex;
2324
2325     print $OUT $_;
2326 }
2327
2328 sub fix_less {
2329     return if defined $ENV{LESS} && $ENV{LESS} =~ /r/;
2330     my $is_less = $pager =~ /\bless\b/;
2331     if ($pager =~ /\bmore\b/) {
2332         my @st_more = stat('/usr/bin/more');
2333         my @st_less = stat('/usr/bin/less');
2334         $is_less = @st_more    && @st_less
2335                 && $st_more[0] == $st_less[0]
2336                 && $st_more[1] == $st_less[1];
2337     }
2338     # changes environment!
2339     $ENV{LESS} .= 'r'   if $is_less;
2340 }
2341
2342 sub diesignal {
2343     local $frame = 0;
2344     local $doret = -2;
2345     $SIG{'ABRT'} = 'DEFAULT';
2346     kill 'ABRT', $$ if $panic++;
2347     if (defined &Carp::longmess) {
2348         local $SIG{__WARN__} = '';
2349         local $Carp::CarpLevel = 2;             # mydie + confess
2350         &warn(Carp::longmess("Signal @_"));
2351     }
2352     else {
2353         print $DB::OUT "Got signal @_\n";
2354     }
2355     kill 'ABRT', $$;
2356 }
2357
2358 sub dbwarn {
2359   local $frame = 0;
2360   local $doret = -2;
2361   local $SIG{__WARN__} = '';
2362   local $SIG{__DIE__} = '';
2363   eval { require Carp } if defined $^S; # If error/warning during compilation,
2364                                         # require may be broken.
2365   warn(@_, "\nCannot print stack trace, load with -MCarp option to see stack"),
2366     return unless defined &Carp::longmess;
2367   my ($mysingle,$mytrace) = ($single,$trace);
2368   $single = 0; $trace = 0;
2369   my $mess = Carp::longmess(@_);
2370   ($single,$trace) = ($mysingle,$mytrace);
2371   &warn($mess);
2372 }
2373
2374 sub dbdie {
2375   local $frame = 0;
2376   local $doret = -2;
2377   local $SIG{__DIE__} = '';
2378   local $SIG{__WARN__} = '';
2379   my $i = 0; my $ineval = 0; my $sub;
2380   if ($dieLevel > 2) {
2381       local $SIG{__WARN__} = \&dbwarn;
2382       &warn(@_);                # Yell no matter what
2383       return;
2384   }
2385   if ($dieLevel < 2) {
2386     die @_ if $^S;              # in eval propagate
2387   }
2388   eval { require Carp } if defined $^S; # If error/warning during compilation,
2389                                         # require may be broken.
2390
2391   die(@_, "\nCannot print stack trace, load with -MCarp option to see stack")
2392     unless defined &Carp::longmess;
2393
2394   # We do not want to debug this chunk (automatic disabling works
2395   # inside DB::DB, but not in Carp).
2396   my ($mysingle,$mytrace) = ($single,$trace);
2397   $single = 0; $trace = 0;
2398   my $mess = Carp::longmess(@_);
2399   ($single,$trace) = ($mysingle,$mytrace);
2400   die $mess;
2401 }
2402
2403 sub warnLevel {
2404   if (@_) {
2405     $prevwarn = $SIG{__WARN__} unless $warnLevel;
2406     $warnLevel = shift;
2407     if ($warnLevel) {
2408       $SIG{__WARN__} = \&DB::dbwarn;
2409     } else {
2410       $SIG{__WARN__} = $prevwarn;
2411     }
2412   }
2413   $warnLevel;
2414 }
2415
2416 sub dieLevel {
2417   if (@_) {
2418     $prevdie = $SIG{__DIE__} unless $dieLevel;
2419     $dieLevel = shift;
2420     if ($dieLevel) {
2421       $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
2422       #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
2423       print $OUT "Stack dump during die enabled",
2424         ( $dieLevel == 1 ? " outside of evals" : ""), ".\n"
2425           if $I_m_init;
2426       print $OUT "Dump printed too.\n" if $dieLevel > 2;
2427     } else {
2428       $SIG{__DIE__} = $prevdie;
2429       print $OUT "Default die handler restored.\n";
2430     }
2431   }
2432   $dieLevel;
2433 }
2434
2435 sub signalLevel {
2436   if (@_) {
2437     $prevsegv = $SIG{SEGV} unless $signalLevel;
2438     $prevbus = $SIG{BUS} unless $signalLevel;
2439     $signalLevel = shift;
2440     if ($signalLevel) {
2441       $SIG{SEGV} = \&DB::diesignal;
2442       $SIG{BUS} = \&DB::diesignal;
2443     } else {
2444       $SIG{SEGV} = $prevsegv;
2445       $SIG{BUS} = $prevbus;
2446     }
2447   }
2448   $signalLevel;
2449 }
2450
2451 sub CvGV_name {
2452   my $in = shift;
2453   my $name = CvGV_name_or_bust($in);
2454   defined $name ? $name : $in;
2455 }
2456
2457 sub CvGV_name_or_bust {
2458   my $in = shift;
2459   return if $skipCvGV;          # Backdoor to avoid problems if XS broken...
2460   $in = \&$in;                  # Hard reference...
2461   eval {require Devel::Peek; 1} or return;
2462   my $gv = Devel::Peek::CvGV($in) or return;
2463   *$gv{PACKAGE} . '::' . *$gv{NAME};
2464 }
2465
2466 sub find_sub {
2467   my $subr = shift;
2468   $sub{$subr} or do {
2469     return unless defined &$subr;
2470     my $name = CvGV_name_or_bust($subr);
2471     my $data;
2472     $data = $sub{$name} if defined $name;
2473     return $data if defined $data;
2474
2475     # Old stupid way...
2476     $subr = \&$subr;            # Hard reference
2477     my $s;
2478     for (keys %sub) {
2479       $s = $_, last if $subr eq \&$_;
2480     }
2481     $sub{$s} if $s;
2482   }
2483 }
2484
2485 sub methods {
2486   my $class = shift;
2487   $class = ref $class if ref $class;
2488   local %seen;
2489   local %packs;
2490   methods_via($class, '', 1);
2491   methods_via('UNIVERSAL', 'UNIVERSAL', 0);
2492 }
2493
2494 sub methods_via {
2495   my $class = shift;
2496   return if $packs{$class}++;
2497   my $prefix = shift;
2498   my $prepend = $prefix ? "via $prefix: " : '';
2499   my $name;
2500   for $name (grep {defined &{${"${class}::"}{$_}}}
2501              sort keys %{"${class}::"}) {
2502     next if $seen{ $name }++;
2503     print $DB::OUT "$prepend$name\n";
2504   }
2505   return unless shift;          # Recurse?
2506   for $name (@{"${class}::ISA"}) {
2507     $prepend = $prefix ? $prefix . " -> $name" : $name;
2508     methods_via($name, $prepend, 1);
2509   }
2510 }
2511
2512 sub setman {
2513     $doccmd = $^O !~ /^(?:MSWin32|VMS|os2|dos|amigaos|riscos|MacOS)\z/s
2514                 ? "man"             # O Happy Day!
2515                 : "perldoc";        # Alas, poor unfortunates
2516 }
2517
2518 sub runman {
2519     my $page = shift;
2520     unless ($page) {
2521         &system("$doccmd $doccmd");
2522         return;
2523     }
2524     # this way user can override, like with $doccmd="man -Mwhatever"
2525     # or even just "man " to disable the path check.
2526     unless ($doccmd eq 'man') {
2527         &system("$doccmd $page");
2528         return;
2529     }
2530
2531     $page = 'perl' if lc($page) eq 'help';
2532
2533     require Config;
2534     my $man1dir = $Config::Config{'man1dir'};
2535     my $man3dir = $Config::Config{'man3dir'};
2536     for ($man1dir, $man3dir) { s#/[^/]*\z## if /\S/ }
2537     my $manpath = '';
2538     $manpath .= "$man1dir:" if $man1dir =~ /\S/;
2539     $manpath .= "$man3dir:" if $man3dir =~ /\S/ && $man1dir ne $man3dir;
2540     chop $manpath if $manpath;
2541     # harmless if missing, I figure
2542     my $oldpath = $ENV{MANPATH};
2543     $ENV{MANPATH} = $manpath if $manpath;
2544     my $nopathopt = $^O =~ /dunno what goes here/;
2545     if (system($doccmd,
2546                 # I just *know* there are men without -M
2547                 (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),
2548             split ' ', $page) )
2549     {
2550         unless ($page =~ /^perl\w/) {
2551             if (grep { $page eq $_ } qw{
2552                 5004delta 5005delta amiga api apio book boot bot call compile
2553                 cygwin data dbmfilter debug debguts delta diag doc dos dsc embed
2554                 faq faq1 faq2 faq3 faq4 faq5 faq6 faq7 faq8 faq9 filter fork
2555                 form func guts hack hist hpux intern ipc lexwarn locale lol mod
2556                 modinstall modlib number obj op opentut os2 os390 pod port
2557                 ref reftut run sec style sub syn thrtut tie toc todo toot tootc
2558                 trap unicode var vms win32 xs xstut
2559               })
2560             {
2561                 $page =~ s/^/perl/;
2562                 system($doccmd,
2563                         (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),
2564                         $page);
2565             }
2566         }
2567     }
2568     if (defined $oldpath) {
2569         $ENV{MANPATH} = $manpath;
2570     } else {
2571         delete $ENV{MANPATH};
2572     }
2573 }
2574
2575 # The following BEGIN is very handy if debugger goes havoc, debugging debugger?
2576
2577 BEGIN {                 # This does not compile, alas.
2578   $IN = \*STDIN;                # For bugs before DB::OUT has been opened
2579   $OUT = \*STDERR;              # For errors before DB::OUT has been opened
2580   $sh = '!';
2581   $rc = ',';
2582   @hist = ('?');
2583   $deep = 100;                  # warning if stack gets this deep
2584   $window = 10;
2585   $preview = 3;
2586   $sub = '';
2587   $SIG{INT} = \&DB::catch;
2588   # This may be enabled to debug debugger:
2589   #$warnLevel = 1 unless defined $warnLevel;
2590   #$dieLevel = 1 unless defined $dieLevel;
2591   #$signalLevel = 1 unless defined $signalLevel;
2592
2593   $db_stop = 0;                 # Compiler warning
2594   $db_stop = 1 << 30;
2595   $level = 0;                   # Level of recursive debugging
2596   # @stack and $doret are needed in sub sub, which is called for DB::postponed.
2597   # Triggers bug (?) in perl is we postpone this until runtime:
2598   @postponed = @stack = (0);
2599   $stack_depth = 0;             # Localized $#stack
2600   $doret = -2;
2601   $frame = 0;
2602 }
2603
2604 BEGIN {$^W = $ini_warn;}        # Switch warnings back
2605
2606 #use Carp;                      # This did break, left for debuggin
2607
2608 sub db_complete {
2609   # Specific code for b c l V m f O, &blah, $blah, @blah, %blah
2610   my($text, $line, $start) = @_;
2611   my ($itext, $search, $prefix, $pack) =
2612     ($text, "^\Q${'package'}::\E([^:]+)\$");
2613
2614   return sort grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines
2615                                (map { /$search/ ? ($1) : () } keys %sub)
2616     if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/;
2617   return sort grep /^\Q$text/, values %INC # files
2618     if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/;
2619   return sort map {($_, db_complete($_ . "::", "V ", 2))}
2620     grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # top-packages
2621       if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/;
2622   return sort map {($_, db_complete($_ . "::", "V ", 2))}
2623     grep !/^main::/,
2624       grep /^\Q$text/, map { /^(.*)::$/ ? ($prefix . "::$1") : ()} keys %{$prefix . '::'}
2625                                  # packages
2626         if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/
2627           and $text =~ /^(.*[^:])::?(\w*)$/  and $prefix = $1;
2628   if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files
2629     # We may want to complete to (eval 9), so $text may be wrong
2630     $prefix = length($1) - length($text);
2631     $text = $1;
2632     return sort
2633         map {substr $_, 2 + $prefix} grep /^_<\Q$text/, (keys %main::), $0
2634   }
2635   if ((substr $text, 0, 1) eq '&') { # subroutines
2636     $text = substr $text, 1;
2637     $prefix = "&";
2638     return sort map "$prefix$_",
2639                grep /^\Q$text/,
2640                  (keys %sub),
2641                  (map { /$search/ ? ($1) : () }
2642                     keys %sub);
2643   }
2644   if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
2645     $pack = ($1 eq 'main' ? '' : $1) . '::';
2646     $prefix = (substr $text, 0, 1) . $1 . '::';
2647     $text = $2;
2648     my @out
2649       = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ;
2650     if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2651       return db_complete($out[0], $line, $start);
2652     }
2653     return sort @out;
2654   }
2655   if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
2656     $pack = ($package eq 'main' ? '' : $package) . '::';
2657     $prefix = substr $text, 0, 1;
2658     $text = substr $text, 1;
2659     my @out = map "$prefix$_", grep /^\Q$text/,
2660        (grep /^_?[a-zA-Z]/, keys %$pack),
2661        ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ;
2662     if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2663       return db_complete($out[0], $line, $start);
2664     }
2665     return sort @out;
2666   }
2667   if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space
2668     my @out = grep /^\Q$text/, @options;
2669     my $val = option_val($out[0], undef);
2670     my $out = '? ';
2671     if (not defined $val or $val =~ /[\n\r]/) {
2672       # Can do nothing better
2673     } elsif ($val =~ /\s/) {
2674       my $found;
2675       foreach $l (split //, qq/\"\'\#\|/) {
2676         $out = "$l$val$l ", last if (index $val, $l) == -1;
2677       }
2678     } else {
2679       $out = "=$val ";
2680     }
2681     # Default to value if one completion, to question if many
2682     $rl_attribs->{completer_terminator_character} = (@out == 1 ? $out : '? ');
2683     return sort @out;
2684   }
2685   return $term->filename_list($text); # filenames
2686 }
2687
2688 sub end_report {
2689   print $OUT "Use `q' to quit or `R' to restart.  `h q' for details.\n"
2690 }
2691
2692 END {
2693   $finished = 1 if $inhibit_exit;      # So that some keys may be disabled.
2694   $fall_off_end = 1 unless $inhibit_exit;
2695   # Do not stop in at_exit() and destructors on exit:
2696   $DB::single = !$fall_off_end && !$runnonstop;
2697   DB::fake::at_exit() unless $fall_off_end or $runnonstop;
2698 }
2699
2700 package DB::fake;
2701
2702 sub at_exit {
2703   "Debugged program terminated.  Use `q' to quit or `R' to restart.";
2704 }
2705
2706 package DB;                     # Do not trace this 1; below!
2707
2708 1;