lib/perl5db.pl

   1 package DB;
   2
   3 # Debugger for Perl 5.00x; perl5db.pl patch level:
   4
   5 # It is crucial that there is no lexicals in scope of `eval ""' down below
   6 sub eval {
   7     # 'my' would make it visible from user code
   8     #    but so does local! --tchrist  [... into @DB::res, not @res. IZ]
   9     local @res;
  10     {
  11         local $otrace = $trace;
  12         local $osingle = $single;
  13         local $od = $^D;
  14         { ($evalarg) = $evalarg =~ /(.*)/s; }
  15         @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
  16         $trace = $otrace;
  17         $single = $osingle;
  18         $^D = $od;
  19     }
  20     my $at = $@;
  21     local $saved[0];            # Preserve the old value of $@
  22     eval { &DB::save };
  23     if ($at) {
  24         print $OUT $at;
  25     } elsif ($onetimeDump) {
  26         dumpit($OUT, \@res) if $onetimeDump eq 'dump';
  27         methods($res[0])    if $onetimeDump eq 'methods';
  28     }
  29     @res;
  30 }
  31
  32 # After this point it is safe to introduce lexicals
  33 # However, one should not overdo it: leave as much control from outside as possible
  34
  35 $VERSION = 1.15;
  36 $header = "perl5db.pl version $VERSION";
  37
  38 #
  39 # This file is automatically included if you do perl -d.
  40 # It's probably not useful to include this yourself.
  41 #
  42 # Before venturing further into these twisty passages, it is
  43 # wise to read the perldebguts man page or risk the ire of dragons.
  44 #
  45 # Perl supplies the values for %sub.  It effectively inserts
  46 # a &DB'DB(); in front of every place that can have a
  47 # breakpoint. Instead of a subroutine call it calls &DB::sub with
  48 # $DB::sub being the called subroutine. It also inserts a BEGIN
  49 # {require 'perl5db.pl'} before the first line.
  50 #
  51 # After each `require'd file is compiled, but before it is executed, a
  52 # call to DB::postponed($main::{'_<'.$filename}) is emulated. Here the
  53 # $filename is the expanded name of the `require'd file (as found as
  54 # value of %INC).
  55 #
  56 # Additional services from Perl interpreter:
  57 #
  58 # if caller() is called from the package DB, it provides some
  59 # additional data.
  60 #
  61 # The array @{$main::{'_<'.$filename}} (herein called @dbline) is the
  62 # line-by-line contents of $filename.
  63 #
  64 # The hash %{'_<'.$filename} (herein called %dbline) contains
  65 # breakpoints and action (it is keyed by line number), and individual
  66 # entries are settable (as opposed to the whole hash). Only true/false
  67 # is important to the interpreter, though the values used by
  68 # perl5db.pl have the form "$break_condition\0$action". Values are
  69 # magical in numeric context.
  70 #
  71 # The scalar ${'_<'.$filename} contains $filename.
  72 #
  73 # Note that no subroutine call is possible until &DB::sub is defined
  74 # (for subroutines defined outside of the package DB). In fact the same is
  75 # true if $deep is not defined.
  76 #
  77 # $Log: perldb.pl,v $
  78
  79 #
  80 # At start reads $rcfile that may set important options.  This file
  81 # may define a subroutine &afterinit that will be executed after the
  82 # debugger is initialized.
  83 #
  84 # After $rcfile is read reads environment variable PERLDB_OPTS and parses
  85 # it as a rest of `O ...' line in debugger prompt.
  86 #
  87 # The options that can be specified only at startup:
  88 # [To set in $rcfile, call &parse_options("optionName=new_value").]
  89 #
  90 # TTY  - the TTY to use for debugging i/o.
  91 #
  92 # noTTY - if set, goes in NonStop mode.  On interrupt if TTY is not set
  93 # uses the value of noTTY or "/tmp/perldbtty$$" to find TTY using
  94 # Term::Rendezvous.  Current variant is to have the name of TTY in this
  95 # file.
  96 #
  97 # ReadLine - If false, dummy ReadLine is used, so you can debug
  98 # ReadLine applications.
  99 #
 100 # NonStop - if true, no i/o is performed until interrupt.
 101 #
 102 # LineInfo - file or pipe to print line number info to.  If it is a
 103 # pipe, a short "emacs like" message is used.
 104 #
 105 # RemotePort - host:port to connect to on remote host for remote debugging.
 106 #
 107 # Example $rcfile: (delete leading hashes!)
 108 #
 109 # &parse_options("NonStop=1 LineInfo=db.out");
 110 # sub afterinit { $trace = 1; }
 111 #
 112 # The script will run without human intervention, putting trace
 113 # information into db.out.  (If you interrupt it, you would better
 114 # reset LineInfo to something "interactive"!)
 115 #
 116 ##################################################################
 117
 118 # Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich)
 119
 120 # modified Perl debugger, to be run from Emacs in perldb-mode
 121 # Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990
 122 # Johan Vromans -- upgrade to 4.0 pl 10
 123 # Ilya Zakharevich -- patches after 5.001 (and some before ;-)
 124
 125 # Changelog:
 126
 127 # A lot of things changed after 0.94. First of all, core now informs
 128 # debugger about entry into XSUBs, overloaded operators, tied operations,
 129 # BEGIN and END. Handy with `O f=2'.
 130
 131 # This can make debugger a little bit too verbose, please be patient
 132 # and report your problems promptly.
 133
 134 # Now the option frame has 3 values: 0,1,2.
 135
 136 # Note that if DESTROY returns a reference to the object (or object),
 137 # the deletion of data may be postponed until the next function call,
 138 # due to the need to examine the return value.
 139
 140 # Changes: 0.95: `v' command shows versions.
 141 # Changes: 0.96: `v' command shows version of readline.
 142 #       primitive completion works (dynamic variables, subs for `b' and `l',
 143 #               options). Can `p %var'
 144 #       Better help (`h <' now works). New commands <<, >>, {, {{.
 145 #       {dump|print}_trace() coded (to be able to do it from <<cmd).
 146 #       `c sub' documented.
 147 #       At last enough magic combined to stop after the end of debuggee.
 148 #       !! should work now (thanks to Emacs bracket matching an extra
 149 #       `]' in a regexp is caught).
 150 #       `L', `D' and `A' span files now (as documented).
 151 #       Breakpoints in `require'd code are possible (used in `R').
 152 #       Some additional words on internal work of debugger.
 153 #       `b load filename' implemented.
 154 #       `b postpone subr' implemented.
 155 #       now only `q' exits debugger (overwritable on $inhibit_exit).
 156 #       When restarting debugger breakpoints/actions persist.
 157 #     Buglet: When restarting debugger only one breakpoint/action per
 158 #               autoloaded function persists.
 159 # Changes: 0.97: NonStop will not stop in at_exit().
 160 #       Option AutoTrace implemented.
 161 #       Trace printed differently if frames are printed too.
 162 #       new `inhibitExit' option.
 163 #       printing of a very long statement interruptible.
 164 # Changes: 0.98: New command `m' for printing possible methods
 165 #       'l -' is a synonym for `-'.
 166 #       Cosmetic bugs in printing stack trace.
 167 #       `frame' & 8 to print "expanded args" in stack trace.
 168 #       Can list/break in imported subs.
 169 #       new `maxTraceLen' option.
 170 #       frame & 4 and frame & 8 granted.
 171 #       new command `m'
 172 #       nonstoppable lines do not have `:' near the line number.
 173 #       `b compile subname' implemented.
 174 #       Will not use $` any more.
 175 #       `-' behaves sane now.
 176 # Changes: 0.99: Completion for `f', `m'.
 177 #       `m' will remove duplicate names instead of duplicate functions.
 178 #       `b load' strips trailing whitespace.
 179 #       completion ignores leading `|'; takes into account current package
 180 #       when completing a subroutine name (same for `l').
 181 # Changes: 1.07: Many fixed by tchrist 13-March-2000
 182 #   BUG FIXES:
 183 #   + Added bare minimal security checks on perldb rc files, plus
 184 #     comments on what else is needed.
 185 #   + Fixed the ornaments that made "|h" completely unusable.
 186 #     They are not used in print_help if they will hurt.  Strip pod
 187 #     if we're paging to less.
 188 #   + Fixed mis-formatting of help messages caused by ornaments
 189 #     to restore Larry's original formatting.
 190 #   + Fixed many other formatting errors.  The code is still suboptimal,
 191 #     and needs a lot of work at restructuring.  It's also misindented
 192 #     in many places.
 193 #   + Fixed bug where trying to look at an option like your pager
 194 #     shows "1".
 195 #   + Fixed some $? processing.  Note: if you use csh or tcsh, you will
 196 #     lose.  You should consider shell escapes not using their shell,
 197 #     or else not caring about detailed status.  This should really be
 198 #     unified into one place, too.
 199 #   + Fixed bug where invisible trailing whitespace on commands hoses you,
 200 #     tricking Perl into thinking you weren't calling a debugger command!
 201 #   + Fixed bug where leading whitespace on commands hoses you.  (One
 202 #     suggests a leading semicolon or any other irrelevant non-whitespace
 203 #     to indicate literal Perl code.)
 204 #   + Fixed bugs that ate warnings due to wrong selected handle.
 205 #   + Fixed a precedence bug on signal stuff.
 206 #   + Fixed some unseemly wording.
 207 #   + Fixed bug in help command trying to call perl method code.
 208 #   + Fixed to call dumpvar from exception handler.  SIGPIPE killed us.
 209 #   ENHANCEMENTS:
 210 #   + Added some comments.  This code is still nasty spaghetti.
 211 #   + Added message if you clear your pre/post command stacks which was
 212 #     very easy to do if you just typed a bare >, <, or {.  (A command
 213 #     without an argument should *never* be a destructive action; this
 214 #     API is fundamentally screwed up; likewise option setting, which
 215 #     is equally buggered.)
 216 #   + Added command stack dump on argument of "?" for >, <, or {.
 217 #   + Added a semi-built-in doc viewer command that calls man with the
 218 #     proper %Config::Config path (and thus gets caching, man -k, etc),
 219 #     or else perldoc on obstreperous platforms.
 220 #   + Added to and rearranged the help information.
 221 #   + Detected apparent misuse of { ... } to declare a block; this used
 222 #     to work but now is a command, and mysteriously gave no complaint.
 223 #
 224 # Changes: 1.08: Apr 25, 2001  Jon Eveland <jweveland@yahoo.com>
 225 #   BUG FIX:
 226 #   + This patch to perl5db.pl cleans up formatting issues on the help
 227 #     summary (h h) screen in the debugger.  Mostly columnar alignment
 228 #     issues, plus converted the printed text to use all spaces, since
 229 #     tabs don't seem to help much here.
 230 #
 231 # Changes: 1.09: May 19, 2001  Ilya Zakharevich <ilya@math.ohio-state.edu>
 232 #   0) Minor bugs corrected;
 233 #   a) Support for auto-creation of new TTY window on startup, either
 234 #      unconditionally, or if started as a kid of another debugger session;
 235 #   b) New `O'ption CreateTTY
 236 #       I<CreateTTY>       bits control attempts to create a new TTY on events:
 237 #                          1: on fork()   2: debugger is started inside debugger
 238 #                          4: on startup
 239 #   c) Code to auto-create a new TTY window on OS/2 (currently one
 240 #      extra window per session - need named pipes to have more...);
 241 #   d) Simplified interface for custom createTTY functions (with a backward
 242 #      compatibility hack); now returns the TTY name to use; return of ''
 243 #      means that the function reset the I/O handles itself;
 244 #   d') Better message on the semantic of custom createTTY function;
 245 #   e) Convert the existing code to create a TTY into a custom createTTY
 246 #      function;
 247 #   f) Consistent support for TTY names of the form "TTYin,TTYout";
 248 #   g) Switch line-tracing output too to the created TTY window;
 249 #   h) make `b fork' DWIM with CORE::GLOBAL::fork;
 250 #   i) High-level debugger API cmd_*():
 251 #      cmd_b_load($filenamepart)            # b load filenamepart
 252 #      cmd_b_line($lineno [, $cond])        # b lineno [cond]
 253 #      cmd_b_sub($sub [, $cond])            # b sub [cond]
 254 #      cmd_stop()                           # Control-C
 255 #      cmd_d($lineno)                       # d lineno
 256 #      The cmd_*() API returns FALSE on failure; in this case it outputs
 257 #      the error message to the debugging output.
 258 #   j) Low-level debugger API
 259 #      break_on_load($filename)             # b load filename
 260 #      @files = report_break_on_load()      # List files with load-breakpoints
 261 #      breakable_line_in_filename($name, $from [, $to])
 262 #                                           # First breakable line in the
 263 #                                           # range $from .. $to.  $to defaults
 264 #                                           # to $from, and may be less than $to
 265 #      breakable_line($from [, $to])        # Same for the current file
 266 #      break_on_filename_line($name, $lineno [, $cond])
 267 #                                           # Set breakpoint,$cond defaults to 1
 268 #      break_on_filename_line_range($name, $from, $to [, $cond])
 269 #                                           # As above, on the first
 270 #                                           # breakable line in range
 271 #      break_on_line($lineno [, $cond])     # As above, in the current file
 272 #      break_subroutine($sub [, $cond])     # break on the first breakable line
 273 #      ($name, $from, $to) = subroutine_filename_lines($sub)
 274 #                                           # The range of lines of the text
 275 #      The low-level API returns TRUE on success, and die()s on failure.
 276 #
 277 # Changes: 1.10: May 23, 2001  Daniel Lewart <d-lewart@uiuc.edu>
 278 #   BUG FIXES:
 279 #   + Fixed warnings generated by "perl -dWe 42"
 280 #   + Corrected spelling errors
 281 #   + Squeezed Help (h) output into 80 columns
 282 #
 283 # Changes: 1.11: May 24, 2001  David Dyck <dcd@tc.fluke.com>
 284 #   + Made "x @INC" work like it used to
 285 #
 286 # Changes: 1.12: May 24, 2001  Daniel Lewart <d-lewart@uiuc.edu>
 287 #   + Fixed warnings generated by "O" (Show debugger options)
 288 #   + Fixed warnings generated by "p 42" (Print expression)
 289 # Changes: 1.13: Jun 19, 2001 Scott.L.Miller@compaq.com
 290 #   + Added windowSize option
 291 # Changes: 1.14: Oct  9, 2001 multiple
 292 #   + Clean up after itself on VMS (Charles Lane in 12385)
 293 #   + Adding "@ file" syntax (Peter Scott in 12014)
 294 #   + Debug reloading selfloaded stuff (Ilya Zakharevich in 11457)
 295 #   + $^S and other debugger fixes (Ilya Zakharevich in 11120)
 296 #   + Forgot a my() declaration (Ilya Zakharevich in 11085)
 297 # Changes: 1.15: Nov  6, 2001 Michael G Schwern <schwern@pobox.com>
 298 #   + Updated 1.14 change log
 299 #   + Added *dbline explainatory comments
 300 #   + Mentioning perldebguts man page
 301 ####################################################################
 302
 303 # Needed for the statement after exec():
 304
 305 BEGIN { $ini_warn = $^W; $^W = 0 } # Switch compilation warnings off until another BEGIN.
 306 local($^W) = 0;                 # Switch run-time warnings off during init.
 307 warn (                  # Do not ;-)
 308       $dumpvar::hashDepth,
 309       $dumpvar::arrayDepth,
 310       $dumpvar::dumpDBFiles,
 311       $dumpvar::dumpPackages,
 312       $dumpvar::quoteHighBit,
 313       $dumpvar::printUndef,
 314       $dumpvar::globPrint,
 315       $dumpvar::usageOnly,
 316       @ARGS,
 317       $Carp::CarpLevel,
 318       $panic,
 319       $second_time,
 320      ) if 0;
 321
 322 # Command-line + PERLLIB:
 323 @ini_INC = @INC;
 324
 325 # $prevwarn = $prevdie = $prevbus = $prevsegv = ''; # Does not help?!
 326
 327 $trace = $signal = $single = 0; # Uninitialized warning suppression
 328                                 # (local $^W cannot help - other packages!).
 329 $inhibit_exit = $option{PrintRet} = 1;
 330
 331 @options     = qw(hashDepth arrayDepth dumpDepth
 332                   DumpDBFiles DumpPackages DumpReused
 333                   compactDump veryCompact quote HighBit undefPrint
 334                   globPrint PrintRet UsageOnly frame AutoTrace
 335                   TTY noTTY ReadLine NonStop LineInfo maxTraceLen
 336                   recallCommand ShellBang pager tkRunning ornaments
 337                   signalLevel warnLevel dieLevel inhibit_exit
 338                   ImmediateStop bareStringify CreateTTY
 339                   RemotePort windowSize);
 340
 341 %optionVars    = (
 342                  hashDepth      => \$dumpvar::hashDepth,
 343                  arrayDepth     => \$dumpvar::arrayDepth,
 344                  DumpDBFiles    => \$dumpvar::dumpDBFiles,
 345                  DumpPackages   => \$dumpvar::dumpPackages,
 346                  DumpReused     => \$dumpvar::dumpReused,
 347                  HighBit        => \$dumpvar::quoteHighBit,
 348                  undefPrint     => \$dumpvar::printUndef,
 349                  globPrint      => \$dumpvar::globPrint,
 350                  UsageOnly      => \$dumpvar::usageOnly,
 351                  CreateTTY      => \$CreateTTY,
 352                  bareStringify  => \$dumpvar::bareStringify,
 353                  frame          => \$frame,
 354                  AutoTrace      => \$trace,
 355                  inhibit_exit   => \$inhibit_exit,
 356                  maxTraceLen    => \$maxtrace,
 357                  ImmediateStop  => \$ImmediateStop,
 358                  RemotePort     => \$remoteport,
 359                  windowSize     => \$window,
 360 );
 361
 362 %optionAction  = (
 363                   compactDump   => \&dumpvar::compactDump,
 364                   veryCompact   => \&dumpvar::veryCompact,
 365                   quote         => \&dumpvar::quote,
 366                   TTY           => \&TTY,
 367                   noTTY         => \&noTTY,
 368                   ReadLine      => \&ReadLine,
 369                   NonStop       => \&NonStop,
 370                   LineInfo      => \&LineInfo,
 371                   recallCommand => \&recallCommand,
 372                   ShellBang     => \&shellBang,
 373                   pager         => \&pager,
 374                   signalLevel   => \&signalLevel,
 375                   warnLevel     => \&warnLevel,
 376                   dieLevel      => \&dieLevel,
 377                   tkRunning     => \&tkRunning,
 378                   ornaments     => \&ornaments,
 379                   RemotePort    => \&RemotePort,
 380                  );
 381
 382 %optionRequire = (
 383                   compactDump   => 'dumpvar.pl',
 384                   veryCompact   => 'dumpvar.pl',
 385                   quote         => 'dumpvar.pl',
 386                  );
 387
 388 # These guys may be defined in $ENV{PERL5DB} :
 389 $rl             = 1     unless defined $rl;
 390 $warnLevel      = 1     unless defined $warnLevel;
 391 $dieLevel       = 1     unless defined $dieLevel;
 392 $signalLevel    = 1     unless defined $signalLevel;
 393 $pre            = []    unless defined $pre;
 394 $post           = []    unless defined $post;
 395 $pretype        = []    unless defined $pretype;
 396 $CreateTTY      = 3     unless defined $CreateTTY;
 397
 398 warnLevel($warnLevel);
 399 dieLevel($dieLevel);
 400 signalLevel($signalLevel);
 401
 402 pager(
 403       defined $ENV{PAGER}              ? $ENV{PAGER} :
 404       eval { require Config } &&
 405         defined $Config::Config{pager} ? $Config::Config{pager}
 406                                        : 'more'
 407      ) unless defined $pager;
 408 setman();
 409 &recallCommand("!") unless defined $prc;
 410 &shellBang("!") unless defined $psh;
 411 sethelp();
 412 $maxtrace = 400 unless defined $maxtrace;
 413 $ini_pids = $ENV{PERLDB_PIDS};
 414 if (defined $ENV{PERLDB_PIDS}) {
 415   $pids = "[$ENV{PERLDB_PIDS}]";
 416   $ENV{PERLDB_PIDS} .= "->$$";
 417   $term_pid = -1;
 418 } else {
 419   $ENV{PERLDB_PIDS} = "$$";
 420   $pids = '';
 421   $term_pid = $$;
 422 }
 423 $pidprompt = '';
 424 *emacs = $slave_editor if $slave_editor;        # May be used in afterinit()...
 425
 426 if (-e "/dev/tty") {  # this is the wrong metric!
 427   $rcfile=".perldb";
 428 } else {
 429   $rcfile="perldb.ini";
 430 }
 431
 432 # This isn't really safe, because there's a race
 433 # between checking and opening.  The solution is to
 434 # open and fstat the handle, but then you have to read and
 435 # eval the contents.  But then the silly thing gets
 436 # your lexical scope, which is unfortunately at best.
 437 sub safe_do {
 438     my $file = shift;
 439
 440     # Just exactly what part of the word "CORE::" don't you understand?
 441     local $SIG{__WARN__};
 442     local $SIG{__DIE__};
 443
 444     unless (is_safe_file($file)) {
 445         CORE::warn <<EO_GRIPE;
 446 perldb: Must not source insecure rcfile $file.
 447         You or the superuser must be the owner, and it must not
 448         be writable by anyone but its owner.
 449 EO_GRIPE
 450         return;
 451     }
 452
 453     do $file;
 454     CORE::warn("perldb: couldn't parse $file: $@") if $@;
 455 }
 456
 457
 458 # Verifies that owner is either real user or superuser and that no
 459 # one but owner may write to it.  This function is of limited use
 460 # when called on a path instead of upon a handle, because there are
 461 # no guarantees that filename (by dirent) whose file (by ino) is
 462 # eventually accessed is the same as the one tested.
 463 # Assumes that the file's existence is not in doubt.
 464 sub is_safe_file {
 465     my $path = shift;
 466     stat($path) || return;      # mysteriously vaporized
 467     my($dev,$ino,$mode,$nlink,$uid,$gid) = stat(_);
 468
 469     return 0 if $uid != 0 && $uid != $<;
 470     return 0 if $mode & 022;
 471     return 1;
 472 }
 473
 474 if (-f $rcfile) {
 475     safe_do("./$rcfile");
 476 }
 477 elsif (defined $ENV{HOME} && -f "$ENV{HOME}/$rcfile") {
 478     safe_do("$ENV{HOME}/$rcfile");
 479 }
 480 elsif (defined $ENV{LOGDIR} && -f "$ENV{LOGDIR}/$rcfile") {
 481     safe_do("$ENV{LOGDIR}/$rcfile");
 482 }
 483
 484 if (defined $ENV{PERLDB_OPTS}) {
 485   parse_options($ENV{PERLDB_OPTS});
 486 }
 487
 488 if ( not defined &get_fork_TTY and defined $ENV{TERM} and $ENV{TERM} eq 'xterm'
 489      and defined $ENV{WINDOWID} and defined $ENV{DISPLAY} ) { # _inside_ XTERM?
 490     *get_fork_TTY = \&xterm_get_fork_TTY;
 491 } elsif ($^O eq 'os2') {
 492     *get_fork_TTY = \&os2_get_fork_TTY;
 493 }
 494
 495 # Here begin the unreadable code.  It needs fixing.
 496
 497 if (exists $ENV{PERLDB_RESTART}) {
 498   delete $ENV{PERLDB_RESTART};
 499   # $restart = 1;
 500   @hist = get_list('PERLDB_HIST');
 501   %break_on_load = get_list("PERLDB_ON_LOAD");
 502   %postponed = get_list("PERLDB_POSTPONE");
 503   my @had_breakpoints= get_list("PERLDB_VISITED");
 504   for (0 .. $#had_breakpoints) {
 505     my %pf = get_list("PERLDB_FILE_$_");
 506     $postponed_file{$had_breakpoints[$_]} = \%pf if %pf;
 507   }
 508   my %opt = get_list("PERLDB_OPT");
 509   my ($opt,$val);
 510   while (($opt,$val) = each %opt) {
 511     $val =~ s/[\\\']/\\$1/g;
 512     parse_options("$opt'$val'");
 513   }
 514   @INC = get_list("PERLDB_INC");
 515   @ini_INC = @INC;
 516   $pretype = [get_list("PERLDB_PRETYPE")];
 517   $pre = [get_list("PERLDB_PRE")];
 518   $post = [get_list("PERLDB_POST")];
 519   @typeahead = get_list("PERLDB_TYPEAHEAD", @typeahead);
 520 }
 521
 522 if ($notty) {
 523   $runnonstop = 1;
 524 } else {
 525   # Is Perl being run from a slave editor or graphical debugger?
 526   $slave_editor = ((defined $main::ARGV[0]) and ($main::ARGV[0] eq '-emacs'));
 527   $rl = 0, shift(@main::ARGV) if $slave_editor;
 528
 529   #require Term::ReadLine;
 530
 531   if ($^O eq 'cygwin') {
 532     # /dev/tty is binary. use stdin for textmode
 533     undef $console;
 534   } elsif (-e "/dev/tty") {
 535     $console = "/dev/tty";
 536   } elsif ($^O eq 'dos' or -e "con" or $^O eq 'MSWin32') {
 537     $console = "con";
 538   } elsif ($^O eq 'MacOS') {
 539     if ($MacPerl::Version !~ /MPW/) {
 540       $console = "Dev:Console:Perl Debug"; # Separate window for application
 541     } else {
 542       $console = "Dev:Console";
 543     }
 544   } else {
 545     $console = "sys\$command";
 546   }
 547
 548   if (($^O eq 'MSWin32') and ($slave_editor or defined $ENV{EMACS})) {
 549     $console = undef;
 550   }
 551
 552   if ($^O eq 'NetWare') {
 553         $console = undef;
 554   }
 555
 556   # Around a bug:
 557   if (defined $ENV{OS2_SHELL} and ($slave_editor or $ENV{WINDOWID})) { # In OS/2
 558     $console = undef;
 559   }
 560
 561   if ($^O eq 'epoc') {
 562     $console = undef;
 563   }
 564
 565   $console = $tty if defined $tty;
 566
 567   if (defined $remoteport) {
 568     require IO::Socket;
 569     $OUT = new IO::Socket::INET( Timeout  => '10',
 570                                  PeerAddr => $remoteport,
 571                                  Proto    => 'tcp',
 572                                );
 573     if (!$OUT) { die "Unable to connect to remote host: $remoteport\n"; }
 574     $IN = $OUT;
 575   } else {
 576     create_IN_OUT(4) if $CreateTTY & 4;
 577     if ($console) {
 578       my ($i, $o) = split /,/, $console;
 579       $o = $i unless defined $o;
 580       open(IN,"+<$i") || open(IN,"<$i") || open(IN,"<&STDIN");
 581       open(OUT,"+>$o") || open(OUT,">$o") || open(OUT,">&STDERR")
 582         || open(OUT,">&STDOUT");        # so we don't dongle stdout
 583     } elsif (not defined $console) {
 584       open(IN,"<&STDIN");
 585       open(OUT,">&STDERR") || open(OUT,">&STDOUT"); # so we don't dongle stdout
 586       $console = 'STDIN/OUT';
 587     }
 588     # so open("|more") can read from STDOUT and so we don't dingle stdin
 589     $IN = \*IN, $OUT = \*OUT if $console or not defined $console;
 590   }
 591   my $previous = select($OUT);
 592   $| = 1;                       # for DB::OUT
 593   select($previous);
 594
 595   $LINEINFO = $OUT unless defined $LINEINFO;
 596   $lineinfo = $console unless defined $lineinfo;
 597
 598   $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
 599   unless ($runnonstop) {
 600     if ($term_pid eq '-1') {
 601       print $OUT "\nDaughter DB session started...\n";
 602     } else {
 603       print $OUT "\nLoading DB routines from $header\n";
 604       print $OUT ("Editor support ",
 605                   $slave_editor ? "enabled" : "available",
 606                   ".\n");
 607       print $OUT "\nEnter h or `h h' for help, or `$doccmd perldebug' for more help.\n\n";
 608     }
 609   }
 610 }
 611
 612 @ARGS = @ARGV;
 613 for (@args) {
 614     s/\'/\\\'/g;
 615     s/(.*)/'$1'/ unless /^-?[\d.]+$/;
 616 }
 617
 618 if (defined &afterinit) {       # May be defined in $rcfile
 619   &afterinit();
 620 }
 621
 622 $I_m_init = 1;
 623
 624 ############################################################ Subroutines
 625
 626 sub DB {
 627     # _After_ the perl program is compiled, $single is set to 1:
 628     if ($single and not $second_time++) {
 629       if ($runnonstop) {        # Disable until signal
 630         for ($i=0; $i <= $stack_depth; ) {
 631             $stack[$i++] &= ~1;
 632         }
 633         $single = 0;
 634         # return;                       # Would not print trace!
 635       } elsif ($ImmediateStop) {
 636         $ImmediateStop = 0;
 637         $signal = 1;
 638       }
 639     }
 640     $runnonstop = 0 if $single or $signal; # Disable it if interactive.
 641     &save;
 642     ($package, $filename, $line) = caller;
 643     $filename_ini = $filename;
 644     $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
 645       "package $package;";      # this won't let them modify, alas
 646     local(*dbline) = $main::{'_<' . $filename};
 647     $max = $#dbline;
 648     if ($dbline{$line} && (($stop,$action) = split(/\0/,$dbline{$line}))) {
 649         if ($stop eq '1') {
 650             $signal |= 1;
 651         } elsif ($stop) {
 652             $evalarg = "\$DB::signal |= 1 if do {$stop}"; &eval;
 653             $dbline{$line} =~ s/;9($|\0)/$1/;
 654         }
 655     }
 656     my $was_signal = $signal;
 657     if ($trace & 2) {
 658       for (my $n = 0; $n <= $#to_watch; $n++) {
 659         $evalarg = $to_watch[$n];
 660         local $onetimeDump;     # Do not output results
 661         my ($val) = &eval;      # Fix context (&eval is doing array)?
 662         $val = ( (defined $val) ? "'$val'" : 'undef' );
 663         if ($val ne $old_watch[$n]) {
 664           $signal = 1;
 665           print $OUT <<EOP;
 666 Watchpoint $n:\t$to_watch[$n] changed:
 667     old value:\t$old_watch[$n]
 668     new value:\t$val
 669 EOP
 670           $old_watch[$n] = $val;
 671         }
 672       }
 673     }
 674     if ($trace & 4) {           # User-installed watch
 675       return if watchfunction($package, $filename, $line)
 676         and not $single and not $was_signal and not ($trace & ~4);
 677     }
 678     $was_signal = $signal;
 679     $signal = 0;
 680     if ($single || ($trace & 1) || $was_signal) {
 681         if ($slave_editor) {
 682             $position = "\032\032$filename:$line:0\n";
 683             print_lineinfo($position);
 684         } elsif ($package eq 'DB::fake') {
 685           $term || &setterm;
 686           print_help(<<EOP);
 687 Debugged program terminated.  Use B<q> to quit or B<R> to restart,
 688   use B<O> I<inhibit_exit> to avoid stopping after program termination,
 689   B<h q>, B<h R> or B<h O> to get additional info.
 690 EOP
 691           $package = 'main';
 692           $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
 693             "package $package;";        # this won't let them modify, alas
 694         } else {
 695             $sub =~ s/\'/::/;
 696             $prefix = $sub =~ /::/ ? "" : "${'package'}::";
 697             $prefix .= "$sub($filename:";
 698             $after = ($dbline[$line] =~ /\n$/ ? '' : "\n");
 699             if (length($prefix) > 30) {
 700                 $position = "$prefix$line):\n$line:\t$dbline[$line]$after";
 701                 $prefix = "";
 702                 $infix = ":\t";
 703             } else {
 704                 $infix = "):\t";
 705                 $position = "$prefix$line$infix$dbline[$line]$after";
 706             }
 707             if ($frame) {
 708                 print_lineinfo(' ' x $stack_depth, "$line:\t$dbline[$line]$after");
 709             } else {
 710                 print_lineinfo($position);
 711             }
 712             for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { #{ vi
 713                 last if $dbline[$i] =~ /^\s*[\;\}\#\n]/;
 714                 last if $signal;
 715                 $after = ($dbline[$i] =~ /\n$/ ? '' : "\n");
 716                 $incr_pos = "$prefix$i$infix$dbline[$i]$after";
 717                 $position .= $incr_pos;
 718                 if ($frame) {
 719                     print_lineinfo(' ' x $stack_depth, "$i:\t$dbline[$i]$after");
 720                 } else {
 721                     print_lineinfo($incr_pos);
 722                 }
 723             }
 724         }
 725     }
 726     $evalarg = $action, &eval if $action;
 727     if ($single || $was_signal) {
 728         local $level = $level + 1;
 729         foreach $evalarg (@$pre) {
 730           &eval;
 731         }
 732         print $OUT $stack_depth . " levels deep in subroutine calls!\n"
 733           if $single & 4;
 734         $start = $line;
 735         $incr = -1;             # for backward motion.
 736         @typeahead = (@$pretype, @typeahead);
 737       CMD:
 738         while (($term || &setterm),
 739                ($term_pid == $$ or resetterm(1)),
 740                defined ($cmd=&readline("$pidprompt  DB" . ('<' x $level) .
 741                                        ($#hist+1) . ('>' x $level) .
 742                                        " ")))
 743         {
 744                 $single = 0;
 745                 $signal = 0;
 746                 $cmd =~ s/\\$/\n/ && do {
 747                     $cmd .= &readline("  cont: ");
 748                     redo CMD;
 749                 };
 750                 $cmd =~ /^$/ && ($cmd = $laststep);
 751                 push(@hist,$cmd) if length($cmd) > 1;
 752               PIPE: {
 753                     $cmd =~ s/^\s+//s;   # trim annoying leading whitespace
 754                     $cmd =~ s/\s+$//s;   # trim annoying trailing whitespace
 755                     ($i) = split(/\s+/,$cmd);
 756                     if ($alias{$i}) {
 757                         # squelch the sigmangler
 758                         local $SIG{__DIE__};
 759                         local $SIG{__WARN__};
 760                         eval "\$cmd =~ $alias{$i}";
 761                         if ($@) {
 762                             print $OUT "Couldn't evaluate `$i' alias: $@";
 763                             next CMD;
 764                         }
 765                     }
 766                    $cmd =~ /^q$/ && ($fall_off_end = 1) && clean_ENV() && exit $?;
 767                     $cmd =~ /^h$/ && do {
 768                         print_help($help);
 769                         next CMD; };
 770                     $cmd =~ /^h\s+h$/ && do {
 771                         print_help($summary);
 772                         next CMD; };
 773                     # support long commands; otherwise bogus errors
 774                     # happen when you ask for h on <CR> for example
 775                     $cmd =~ /^h\s+(\S.*)$/ && do {
 776                         my $asked = $1;                 # for proper errmsg
 777                         my $qasked = quotemeta($asked); # for searching
 778                         # XXX: finds CR but not <CR>
 779                         if ($help =~ /^<?(?:[IB]<)$qasked/m) {
 780                           while ($help =~ /^(<?(?:[IB]<)$qasked([\s\S]*?)\n)(?!\s)/mg) {
 781                             print_help($1);
 782                           }
 783                         } else {
 784                             print_help("B<$asked> is not a debugger command.\n");
 785                         }
 786                         next CMD; };
 787                     $cmd =~ /^t$/ && do {
 788                         $trace ^= 1;
 789                         print $OUT "Trace = " .
 790                             (($trace & 1) ? "on" : "off" ) . "\n";
 791                         next CMD; };
 792                     $cmd =~ /^S(\s+(!)?(.+))?$/ && do {
 793                         $Srev = defined $2; $Spatt = $3; $Snocheck = ! defined $1;
 794                         foreach $subname (sort(keys %sub)) {
 795                             if ($Snocheck or $Srev^($subname =~ /$Spatt/)) {
 796                                 print $OUT $subname,"\n";
 797                             }
 798                         }
 799                         next CMD; };
 800                     $cmd =~ /^v$/ && do {
 801                         list_versions(); next CMD};
 802                     $cmd =~ s/^X\b/V $package/;
 803                     $cmd =~ /^V$/ && do {
 804                         $cmd = "V $package"; };
 805                     $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
 806                         local ($savout) = select($OUT);
 807                         $packname = $1;
 808                         @vars = split(' ',$2);
 809                         do 'dumpvar.pl' unless defined &main::dumpvar;
 810                         if (defined &main::dumpvar) {
 811                             local $frame = 0;
 812                             local $doret = -2;
 813                             # must detect sigpipe failures
 814                             eval { &main::dumpvar($packname,@vars) };
 815                             if ($@) {
 816                                 die unless $@ =~ /dumpvar print failed/;
 817                             }
 818                         } else {
 819                             print $OUT "dumpvar.pl not available.\n";
 820                         }
 821                         select ($savout);
 822                         next CMD; };
 823                     $cmd =~ s/^x\b/ / && do { # So that will be evaled
 824                         $onetimeDump = 'dump'; };
 825                     $cmd =~ s/^m\s+([\w:]+)\s*$/ / && do {
 826                         methods($1); next CMD};
 827                     $cmd =~ s/^m\b/ / && do { # So this will be evaled
 828                         $onetimeDump = 'methods'; };
 829                     $cmd =~ /^f\b\s*(.*)/ && do {
 830                         $file = $1;
 831                         $file =~ s/\s+$//;
 832                         if (!$file) {
 833                             print $OUT "The old f command is now the r command.\n";
 834                             print $OUT "The new f command switches filenames.\n";
 835                             next CMD;
 836                         }
 837                         if (!defined $main::{'_<' . $file}) {
 838                             if (($try) = grep(m#^_<.*$file#, keys %main::)) {{
 839                                               $try = substr($try,2);
 840                                               print $OUT "Choosing $try matching `$file':\n";
 841                                               $file = $try;
 842                                           }}
 843                         }
 844                         if (!defined $main::{'_<' . $file}) {
 845                             print $OUT "No file matching `$file' is loaded.\n";
 846                             next CMD;
 847                         } elsif ($file ne $filename) {
 848                             *dbline = $main::{'_<' . $file};
 849                             $max = $#dbline;
 850                             $filename = $file;
 851                             $start = 1;
 852                             $cmd = "l";
 853                           } else {
 854                             print $OUT "Already in $file.\n";
 855                             next CMD;
 856                           }
 857                       };
 858                     $cmd =~ s/^l\s+-\s*$/-/;
 859                     $cmd =~ /^([lb])\b\s*(\$.*)/s && do {
 860                         $evalarg = $2;
 861                         my ($s) = &eval;
 862                         print($OUT "Error: $@\n"), next CMD if $@;
 863                         $s = CvGV_name($s);
 864                         print($OUT "Interpreted as: $1 $s\n");
 865                         $cmd = "$1 $s";
 866                     };
 867                     $cmd =~ /^l\b\s*([\':A-Za-z_][\':\w]*(\[.*\])?)/s && do {
 868                         my $s = $subname = $1;
 869                         $subname =~ s/\'/::/;
 870                         $subname = $package."::".$subname
 871                           unless $subname =~ /::/;
 872                         $subname = "CORE::GLOBAL::$s"
 873                           if not defined &$subname and $s !~ /::/
 874                              and defined &{"CORE::GLOBAL::$s"};
 875                         $subname = "main".$subname if substr($subname,0,2) eq "::";
 876                         @pieces = split(/:/,find_sub($subname) || $sub{$subname});
 877                         $subrange = pop @pieces;
 878                         $file = join(':', @pieces);
 879                         if ($file ne $filename) {
 880                             print $OUT "Switching to file '$file'.\n"
 881                                 unless $slave_editor;
 882                             *dbline = $main::{'_<' . $file};
 883                             $max = $#dbline;
 884                             $filename = $file;
 885                         }
 886                         if ($subrange) {
 887                             if (eval($subrange) < -$window) {
 888                                 $subrange =~ s/-.*/+/;
 889                             }
 890                             $cmd = "l $subrange";
 891                         } else {
 892                             print $OUT "Subroutine $subname not found.\n";
 893                             next CMD;
 894                         } };
 895                     $cmd =~ /^\.$/ && do {
 896                         $incr = -1;             # for backward motion.
 897                         $start = $line;
 898                         $filename = $filename_ini;
 899                         *dbline = $main::{'_<' . $filename};
 900                         $max = $#dbline;
 901                         print_lineinfo($position);
 902                         next CMD };
 903                     $cmd =~ /^w\b\s*(\d*)$/ && do {
 904                         $incr = $window - 1;
 905                         $start = $1 if $1;
 906                         $start -= $preview;
 907                         #print $OUT 'l ' . $start . '-' . ($start + $incr);
 908                         $cmd = 'l ' . $start . '-' . ($start + $incr); };
 909                     $cmd =~ /^-$/ && do {
 910                         $start -= $incr + $window + 1;
 911                         $start = 1 if $start <= 0;
 912                         $incr = $window - 1;
 913                         $cmd = 'l ' . ($start) . '+'; };
 914                     $cmd =~ /^l$/ && do {
 915                         $incr = $window - 1;
 916                         $cmd = 'l ' . $start . '-' . ($start + $incr); };
 917                     $cmd =~ /^l\b\s*(\d*)\+(\d*)$/ && do {
 918                         $start = $1 if $1;
 919                         $incr = $2;
 920                         $incr = $window - 1 unless $incr;
 921                         $cmd = 'l ' . $start . '-' . ($start + $incr); };
 922                     $cmd =~ /^l\b\s*((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
 923                         $end = (!defined $2) ? $max : ($4 ? $4 : $2);
 924                         $end = $max if $end > $max;
 925                         $i = $2;
 926                         $i = $line if $i eq '.';
 927                         $i = 1 if $i < 1;
 928                         $incr = $end - $i;
 929                         if ($slave_editor) {
 930                             print $OUT "\032\032$filename:$i:0\n";
 931                             $i = $end;
 932                         } else {
 933                             for (; $i <= $end; $i++) {
 934                                 my ($stop,$action);
 935                                 ($stop,$action) = split(/\0/, $dbline{$i}) if
 936                                     $dbline{$i};
 937                                 $arrow = ($i==$line
 938                                           and $filename eq $filename_ini)
 939                                   ?  '==>'
 940                                     : ($dbline[$i]+0 ? ':' : ' ') ;
 941                                 $arrow .= 'b' if $stop;
 942                                 $arrow .= 'a' if $action;
 943                                 print $OUT "$i$arrow\t", $dbline[$i];
 944                                 $i++, last if $signal;
 945                             }
 946                             print $OUT "\n" unless $dbline[$i-1] =~ /\n$/;
 947                         }
 948                         $start = $i; # remember in case they want more
 949                         $start = $max if $start > $max;
 950                         next CMD; };
 951                     $cmd =~ /^D$/ && do {
 952                       print $OUT "Deleting all breakpoints...\n";
 953                       my $file;
 954                       for $file (keys %had_breakpoints) {
 955                         local *dbline = $main::{'_<' . $file};
 956                         my $max = $#dbline;
 957                         my $was;
 958
 959                         for ($i = 1; $i <= $max ; $i++) {
 960                             if (defined $dbline{$i}) {
 961                                 $dbline{$i} =~ s/^[^\0]+//;
 962                                 if ($dbline{$i} =~ s/^\0?$//) {
 963                                     delete $dbline{$i};
 964                                 }
 965                             }
 966                         }
 967
 968                         if (not $had_breakpoints{$file} &= ~1) {
 969                             delete $had_breakpoints{$file};
 970                         }
 971                       }
 972                       undef %postponed;
 973                       undef %postponed_file;
 974                       undef %break_on_load;
 975                       next CMD; };
 976                     $cmd =~ /^L$/ && do {
 977                       my $file;
 978                       for $file (keys %had_breakpoints) {
 979                         local *dbline = $main::{'_<' . $file};
 980                         my $max = $#dbline;
 981                         my $was;
 982
 983                         for ($i = 1; $i <= $max; $i++) {
 984                             if (defined $dbline{$i}) {
 985                                 print $OUT "$file:\n" unless $was++;
 986                                 print $OUT " $i:\t", $dbline[$i];
 987                                 ($stop,$action) = split(/\0/, $dbline{$i});
 988                                 print $OUT "   break if (", $stop, ")\n"
 989                                   if $stop;
 990                                 print $OUT "   action:  ", $action, "\n"
 991                                   if $action;
 992                                 last if $signal;
 993                             }
 994                         }
 995                       }
 996                       if (%postponed) {
 997                         print $OUT "Postponed breakpoints in subroutines:\n";
 998                         my $subname;
 999                         for $subname (keys %postponed) {
1000                           print $OUT " $subname\t$postponed{$subname}\n";
1001                           last if $signal;
1002                         }
1003                       }
1004                       my @have = map { # Combined keys
1005                         keys %{$postponed_file{$_}}
1006                       } keys %postponed_file;
1007                       if (@have) {
1008                         print $OUT "Postponed breakpoints in files:\n";
1009                         my ($file, $line);
1010                         for $file (keys %postponed_file) {
1011                           my $db = $postponed_file{$file};
1012                           print $OUT " $file:\n";
1013                           for $line (sort {$a <=> $b} keys %$db) {
1014                                 print $OUT "  $line:\n";
1015                                 my ($stop,$action) = split(/\0/, $$db{$line});
1016                                 print $OUT "    break if (", $stop, ")\n"
1017                                   if $stop;
1018                                 print $OUT "    action:  ", $action, "\n"
1019                                   if $action;
1020                                 last if $signal;
1021                           }
1022                           last if $signal;
1023                         }
1024                       }
1025                       if (%break_on_load) {
1026                         print $OUT "Breakpoints on load:\n";
1027                         my $file;
1028                         for $file (keys %break_on_load) {
1029                           print $OUT " $file\n";
1030                           last if $signal;
1031                         }
1032                       }
1033                       if ($trace & 2) {
1034                         print $OUT "Watch-expressions:\n";
1035                         my $expr;
1036                         for $expr (@to_watch) {
1037                           print $OUT " $expr\n";
1038                           last if $signal;
1039                         }
1040                       }
1041                       next CMD; };
1042                     $cmd =~ /^b\b\s*load\b\s*(.*)/ && do {
1043                         my $file = $1; $file =~ s/\s+$//;
1044                         cmd_b_load($file);
1045                         next CMD; };
1046                     $cmd =~ /^b\b\s*(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
1047                         my $cond = length $3 ? $3 : '1';
1048                         my ($subname, $break) = ($2, $1 eq 'postpone');
1049                         $subname =~ s/\'/::/g;
1050                         $subname = "${'package'}::" . $subname
1051                           unless $subname =~ /::/;
1052                         $subname = "main".$subname if substr($subname,0,2) eq "::";
1053                         $postponed{$subname} = $break
1054                           ? "break +0 if $cond" : "compile";
1055                         next CMD; };
1056                     $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/ && do {
1057                         $subname = $1;
1058                         $cond = length $2 ? $2 : '1';
1059                         cmd_b_sub($subname, $cond);
1060                         next CMD; };
1061                     $cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do {
1062                         $i = $1 || $line;
1063                         $cond = length $2 ? $2 : '1';
1064                         cmd_b_line($i, $cond);
1065                         next CMD; };
1066                     $cmd =~ /^d\b\s*(\d*)/ && do {
1067                         cmd_d($1 || $line);
1068                         next CMD; };
1069                     $cmd =~ /^A$/ && do {
1070                       print $OUT "Deleting all actions...\n";
1071                       my $file;
1072                       for $file (keys %had_breakpoints) {
1073                         local *dbline = $main::{'_<' . $file};
1074                         my $max = $#dbline;
1075                         my $was;
1076
1077                         for ($i = 1; $i <= $max ; $i++) {
1078                             if (defined $dbline{$i}) {
1079                                 $dbline{$i} =~ s/\0[^\0]*//;
1080                                 delete $dbline{$i} if $dbline{$i} eq '';
1081                             }
1082                         }
1083
1084                         unless ($had_breakpoints{$file} &= ~2) {
1085                             delete $had_breakpoints{$file};
1086                         }
1087                       }
1088                       next CMD; };
1089                     $cmd =~ /^O\s*$/ && do {
1090                         for (@options) {
1091                             &dump_option($_);
1092                         }
1093                         next CMD; };
1094                     $cmd =~ /^O\s*(\S.*)/ && do {
1095                         parse_options($1);
1096                         next CMD; };
1097                     $cmd =~ /^\<\<\s*(.*)/ && do { # \<\< for CPerl sake: not HERE
1098                         push @$pre, action($1);
1099                         next CMD; };
1100                     $cmd =~ /^>>\s*(.*)/ && do {
1101                         push @$post, action($1);
1102                         next CMD; };
1103                     $cmd =~ /^<\s*(.*)/ && do {
1104                         unless ($1) {
1105                             print $OUT "All < actions cleared.\n";
1106                             $pre = [];
1107                             next CMD;
1108                         }
1109                         if ($1 eq '?') {
1110                             unless (@$pre) {
1111                                 print $OUT "No pre-prompt Perl actions.\n";
1112                                 next CMD;
1113                             }
1114                             print $OUT "Perl commands run before each prompt:\n";
1115                             for my $action ( @$pre ) {
1116                                 print $OUT "\t< -- $action\n";
1117                             }
1118                             next CMD;
1119                         }
1120                         $pre = [action($1)];
1121                         next CMD; };
1122                     $cmd =~ /^>\s*(.*)/ && do {
1123                         unless ($1) {
1124                             print $OUT "All > actions cleared.\n";
1125                             $post = [];
1126                             next CMD;
1127                         }
1128                         if ($1 eq '?') {
1129                             unless (@$post) {
1130                                 print $OUT "No post-prompt Perl actions.\n";
1131                                 next CMD;
1132                             }
1133                             print $OUT "Perl commands run after each prompt:\n";
1134                             for my $action ( @$post ) {
1135                                 print $OUT "\t> -- $action\n";
1136                             }
1137                             next CMD;
1138                         }
1139                         $post = [action($1)];
1140                         next CMD; };
1141                     $cmd =~ /^\{\{\s*(.*)/ && do {
1142                         if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,2))) {
1143                             print $OUT "{{ is now a debugger command\n",
1144                                 "use `;{{' if you mean Perl code\n";
1145                             $cmd = "h {{";
1146                             redo CMD;
1147                         }
1148                         push @$pretype, $1;
1149                         next CMD; };
1150                     $cmd =~ /^\{\s*(.*)/ && do {
1151                         unless ($1) {
1152                             print $OUT "All { actions cleared.\n";
1153                             $pretype = [];
1154                             next CMD;
1155                         }
1156                         if ($1 eq '?') {
1157                             unless (@$pretype) {
1158                                 print $OUT "No pre-prompt debugger actions.\n";
1159                                 next CMD;
1160                             }
1161                             print $OUT "Debugger commands run before each prompt:\n";
1162                             for my $action ( @$pretype ) {
1163                                 print $OUT "\t{ -- $action\n";
1164                             }
1165                             next CMD;
1166                         }
1167                         if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,1))) {
1168                             print $OUT "{ is now a debugger command\n",
1169                                 "use `;{' if you mean Perl code\n";
1170                             $cmd = "h {";
1171                             redo CMD;
1172                         }
1173                         $pretype = [$1];
1174                         next CMD; };
1175                     $cmd =~ /^a\b\s*(\d*)\s*(.*)/ && do {
1176                         $i = $1 || $line; $j = $2;
1177                         if (length $j) {
1178                             if ($dbline[$i] == 0) {
1179                                 print $OUT "Line $i may not have an action.\n";
1180                             } else {
1181                                 $had_breakpoints{$filename} |= 2;
1182                                 $dbline{$i} =~ s/\0[^\0]*//;
1183                                 $dbline{$i} .= "\0" . action($j);
1184                             }
1185                         } else {
1186                             $dbline{$i} =~ s/\0[^\0]*//;
1187                             delete $dbline{$i} if $dbline{$i} eq '';
1188                         }
1189                         next CMD; };
1190                     $cmd =~ /^n$/ && do {
1191                         end_report(), next CMD if $finished and $level <= 1;
1192                         $single = 2;
1193                         $laststep = $cmd;
1194                         last CMD; };
1195                     $cmd =~ /^s$/ && do {
1196                         end_report(), next CMD if $finished and $level <= 1;
1197                         $single = 1;
1198                         $laststep = $cmd;
1199                         last CMD; };
1200                     $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {
1201                         end_report(), next CMD if $finished and $level <= 1;
1202                         $subname = $i = $1;
1203                         #  Probably not needed, since we finish an interactive
1204                         #  sub-session anyway...
1205                         # local $filename = $filename;
1206                         # local *dbline = *dbline;      # XXX Would this work?!
1207                         if ($i =~ /\D/) { # subroutine name
1208                             $subname = $package."::".$subname
1209                                 unless $subname =~ /::/;
1210                             ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
1211                             $i += 0;
1212                             if ($i) {
1213                                 $filename = $file;
1214                                 *dbline = $main::{'_<' . $filename};
1215                                 $had_breakpoints{$filename} |= 1;
1216                                 $max = $#dbline;
1217                                 ++$i while $dbline[$i] == 0 && $i < $max;
1218                             } else {
1219                                 print $OUT "Subroutine $subname not found.\n";
1220                                 next CMD;
1221                             }
1222                         }
1223                         if ($i) {
1224                             if ($dbline[$i] == 0) {
1225                                 print $OUT "Line $i not breakable.\n";
1226                                 next CMD;
1227                             }
1228                             $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
1229                         }
1230                         for ($i=0; $i <= $stack_depth; ) {
1231                             $stack[$i++] &= ~1;
1232                         }
1233                         last CMD; };
1234                     $cmd =~ /^r$/ && do {
1235                         end_report(), next CMD if $finished and $level <= 1;
1236                         $stack[$stack_depth] |= 1;
1237                         $doret = $option{PrintRet} ? $stack_depth - 1 : -2;
1238                         last CMD; };
1239                     $cmd =~ /^R$/ && do {
1240                         print $OUT "Warning: some settings and command-line options may be lost!\n";
1241                         my (@script, @flags, $cl);
1242                         push @flags, '-w' if $ini_warn;
1243                         # Put all the old includes at the start to get
1244                         # the same debugger.
1245                         for (@ini_INC) {
1246                           push @flags, '-I', $_;
1247                         }
1248                         push @flags, '-T' if ${^TAINT};
1249                         # Arrange for setting the old INC:
1250                         set_list("PERLDB_INC", @ini_INC);
1251                         if ($0 eq '-e') {
1252                           for (1..$#{'::_<-e'}) { # The first line is PERL5DB
1253                                 chomp ($cl =  ${'::_<-e'}[$_]);
1254                             push @script, '-e', $cl;
1255                           }
1256                         } else {
1257                           @script = $0;
1258                         }
1259                         set_list("PERLDB_HIST",
1260                                  $term->Features->{getHistory}
1261                                  ? $term->GetHistory : @hist);
1262                         my @had_breakpoints = keys %had_breakpoints;
1263                         set_list("PERLDB_VISITED", @had_breakpoints);
1264                         set_list("PERLDB_OPT", %option);
1265                         set_list("PERLDB_ON_LOAD", %break_on_load);
1266                         my @hard;
1267                         for (0 .. $#had_breakpoints) {
1268                           my $file = $had_breakpoints[$_];
1269                           *dbline = $main::{'_<' . $file};
1270                           next unless %dbline or $postponed_file{$file};
1271                           (push @hard, $file), next
1272                             if $file =~ /^\(\w*eval/;
1273                           my @add;
1274                           @add = %{$postponed_file{$file}}
1275                             if $postponed_file{$file};
1276                           set_list("PERLDB_FILE_$_", %dbline, @add);
1277                         }
1278                         for (@hard) { # Yes, really-really...
1279                           # Find the subroutines in this eval
1280                           *dbline = $main::{'_<' . $_};
1281                           my ($quoted, $sub, %subs, $line) = quotemeta $_;
1282                           for $sub (keys %sub) {
1283                             next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
1284                             $subs{$sub} = [$1, $2];
1285                           }
1286                           unless (%subs) {
1287                             print $OUT
1288                               "No subroutines in $_, ignoring breakpoints.\n";
1289                             next;
1290                           }
1291                         LINES: for $line (keys %dbline) {
1292                             # One breakpoint per sub only:
1293                             my ($offset, $sub, $found);
1294                           SUBS: for $sub (keys %subs) {
1295                               if ($subs{$sub}->[1] >= $line # Not after the subroutine
1296                                   and (not defined $offset # Not caught
1297                                        or $offset < 0 )) { # or badly caught
1298                                 $found = $sub;
1299                                 $offset = $line - $subs{$sub}->[0];
1300                                 $offset = "+$offset", last SUBS if $offset >= 0;
1301                               }
1302                             }
1303                             if (defined $offset) {
1304                               $postponed{$found} =
1305                                 "break $offset if $dbline{$line}";
1306                             } else {
1307                               print $OUT "Breakpoint in $_:$line ignored: after all the subroutines.\n";
1308                             }
1309                           }
1310                         }
1311                         set_list("PERLDB_POSTPONE", %postponed);
1312                         set_list("PERLDB_PRETYPE", @$pretype);
1313                         set_list("PERLDB_PRE", @$pre);
1314                         set_list("PERLDB_POST", @$post);
1315                         set_list("PERLDB_TYPEAHEAD", @typeahead);
1316                         $ENV{PERLDB_RESTART} = 1;
1317                         delete $ENV{PERLDB_PIDS}; # Restore ini state
1318                         $ENV{PERLDB_PIDS} = $ini_pids if defined $ini_pids;
1319                         #print "$^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS";
1320                         exec($^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS) ||
1321                         print $OUT "exec failed: $!\n";
1322                         last CMD; };
1323                     $cmd =~ /^T$/ && do {
1324                         print_trace($OUT, 1); # skip DB
1325                         next CMD; };
1326                     $cmd =~ /^W\s*$/ && do {
1327                         $trace &= ~2;
1328                         @to_watch = @old_watch = ();
1329                         next CMD; };
1330                     $cmd =~ /^W\b\s*(.*)/s && do {
1331                         push @to_watch, $1;
1332                         $evalarg = $1;
1333                         my ($val) = &eval;
1334                         $val = (defined $val) ? "'$val'" : 'undef' ;
1335                         push @old_watch, $val;
1336                         $trace |= 2;
1337                         next CMD; };
1338                     $cmd =~ /^\/(.*)$/ && do {
1339                         $inpat = $1;
1340                         $inpat =~ s:([^\\])/$:$1:;
1341                         if ($inpat ne "") {
1342                             # squelch the sigmangler
1343                             local $SIG{__DIE__};
1344                             local $SIG{__WARN__};
1345                             eval '$inpat =~ m'."\a$inpat\a";
1346                             if ($@ ne "") {
1347                                 print $OUT "$@";
1348                                 next CMD;
1349                             }
1350                             $pat = $inpat;
1351                         }
1352                         $end = $start;
1353                         $incr = -1;
1354                         eval '
1355                             for (;;) {
1356                                 ++$start;
1357                                 $start = 1 if ($start > $max);
1358                                 last if ($start == $end);
1359                                 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1360                                     if ($slave_editor) {
1361                                         print $OUT "\032\032$filename:$start:0\n";
1362                                     } else {
1363                                         print $OUT "$start:\t", $dbline[$start], "\n";
1364                                     }
1365                                     last;
1366                                 }
1367                             } ';
1368                         print $OUT "/$pat/: not found\n" if ($start == $end);
1369                         next CMD; };
1370                     $cmd =~ /^\?(.*)$/ && do {
1371                         $inpat = $1;
1372                         $inpat =~ s:([^\\])\?$:$1:;
1373                         if ($inpat ne "") {
1374                             # squelch the sigmangler
1375                             local $SIG{__DIE__};
1376                             local $SIG{__WARN__};
1377                             eval '$inpat =~ m'."\a$inpat\a";
1378                             if ($@ ne "") {
1379                                 print $OUT $@;
1380                                 next CMD;
1381                             }
1382                             $pat = $inpat;
1383                         }
1384                         $end = $start;
1385                         $incr = -1;
1386                         eval '
1387                             for (;;) {
1388                                 --$start;
1389                                 $start = $max if ($start <= 0);
1390                                 last if ($start == $end);
1391                                 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1392                                     if ($slave_editor) {
1393                                         print $OUT "\032\032$filename:$start:0\n";
1394                                     } else {
1395                                         print $OUT "$start:\t", $dbline[$start], "\n";
1396                                     }
1397                                     last;
1398                                 }
1399                             } ';
1400                         print $OUT "?$pat?: not found\n" if ($start == $end);
1401                         next CMD; };
1402                     $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
1403                         pop(@hist) if length($cmd) > 1;
1404                         $i = $1 ? ($#hist-($2||1)) : ($2||$#hist);
1405                         $cmd = $hist[$i];
1406                         print $OUT $cmd, "\n";
1407                         redo CMD; };
1408                     $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {
1409                         &system($1);
1410                         next CMD; };
1411                     $cmd =~ /^$rc([^$rc].*)$/ && do {
1412                         $pat = "^$1";
1413                         pop(@hist) if length($cmd) > 1;
1414                         for ($i = $#hist; $i; --$i) {
1415                             last if $hist[$i] =~ /$pat/;
1416                         }
1417                         if (!$i) {
1418                             print $OUT "No such command!\n\n";
1419                             next CMD;
1420                         }
1421                         $cmd = $hist[$i];
1422                         print $OUT $cmd, "\n";
1423                         redo CMD; };
1424                     $cmd =~ /^$sh$/ && do {
1425                         &system($ENV{SHELL}||"/bin/sh");
1426                         next CMD; };
1427                     $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do {
1428                         # XXX: using csh or tcsh destroys sigint retvals!
1429                         #&system($1);  # use this instead
1430                         &system($ENV{SHELL}||"/bin/sh","-c",$1);
1431                         next CMD; };
1432                     $cmd =~ /^H\b\s*(-(\d+))?/ && do {
1433                         $end = $2 ? ($#hist-$2) : 0;
1434                         $hist = 0 if $hist < 0;
1435                         for ($i=$#hist; $i>$end; $i--) {
1436                             print $OUT "$i: ",$hist[$i],"\n"
1437                               unless $hist[$i] =~ /^.?$/;
1438                         };
1439                         next CMD; };
1440                     $cmd =~ /^(?:man|(?:perl)?doc)\b(?:\s+([^(]*))?$/ && do {
1441                         runman($1);
1442                         next CMD; };
1443                     $cmd =~ s/^p$/print {\$DB::OUT} \$_/;
1444                     $cmd =~ s/^p\b/print {\$DB::OUT} /;
1445                     $cmd =~ s/^=\s*// && do {
1446                         my @keys;
1447                         if (length $cmd == 0) {
1448                             @keys = sort keys %alias;
1449                         }
1450                         elsif (my($k,$v) = ($cmd =~ /^(\S+)\s+(\S.*)/)) {
1451                             # can't use $_ or kill //g state
1452                             for my $x ($k, $v) { $x =~ s/\a/\\a/g }
1453                             $alias{$k} = "s\a$k\a$v\a";
1454                             # squelch the sigmangler
1455                             local $SIG{__DIE__};
1456                             local $SIG{__WARN__};
1457                             unless (eval "sub { s\a$k\a$v\a }; 1") {
1458                                 print $OUT "Can't alias $k to $v: $@\n";
1459                                 delete $alias{$k};
1460                                 next CMD;
1461                             }
1462                             @keys = ($k);
1463                         }
1464                         else {
1465                             @keys = ($cmd);
1466                         }
1467                         for my $k (@keys) {
1468                             if ((my $v = $alias{$k}) =~ s\as\a$k\a(.*)\a$\a1\a) {
1469                                 print $OUT "$k\t= $1\n";
1470                             }
1471                             elsif (defined $alias{$k}) {
1472                                     print $OUT "$k\t$alias{$k}\n";
1473                             }
1474                             else {
1475                                 print "No alias for $k\n";
1476                             }
1477                         }
1478                         next CMD; };
1479                     $cmd =~ /^\@\s*(.*\S)/ && do {
1480                       if (open my $fh, $1) {
1481                         push @cmdfhs, $fh;
1482                       }
1483                       else {
1484                         &warn("Can't execute `$1': $!\n");
1485                       }
1486                       next CMD; };
1487                     $cmd =~ /^\|\|?\s*[^|]/ && do {
1488                         if ($pager =~ /^\|/) {
1489                             open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1490                             open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1491                         } else {
1492                             open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT");
1493                         }
1494                         fix_less();
1495                         unless ($piped=open(OUT,$pager)) {
1496                             &warn("Can't pipe output to `$pager'");
1497                             if ($pager =~ /^\|/) {
1498                                 open(OUT,">&STDOUT") # XXX: lost message
1499                                     || &warn("Can't restore DB::OUT");
1500                                 open(STDOUT,">&SAVEOUT")
1501                                   || &warn("Can't restore STDOUT");
1502                                 close(SAVEOUT);
1503                             } else {
1504                                 open(OUT,">&STDOUT") # XXX: lost message
1505                                     || &warn("Can't restore DB::OUT");
1506                             }
1507                             next CMD;
1508                         }
1509                         $SIG{PIPE}= \&DB::catch if $pager =~ /^\|/
1510                             && ("" eq $SIG{PIPE}  ||  "DEFAULT" eq $SIG{PIPE});
1511                         $selected= select(OUT);
1512                         $|= 1;
1513                         select( $selected ), $selected= "" unless $cmd =~ /^\|\|/;
1514                         $cmd =~ s/^\|+\s*//;
1515                         redo PIPE;
1516                     };
1517                     # XXX Local variants do not work!
1518                     $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
1519                     $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
1520                     $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
1521                 }               # PIPE:
1522             $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
1523             if ($onetimeDump) {
1524                 $onetimeDump = undef;
1525             } elsif ($term_pid == $$) {
1526                 print $OUT "\n";
1527             }
1528         } continue {            # CMD:
1529             if ($piped) {
1530                 if ($pager =~ /^\|/) {
1531                     $? = 0;
1532                     # we cannot warn here: the handle is missing --tchrist
1533                     close(OUT) || print SAVEOUT "\nCan't close DB::OUT\n";
1534
1535                     # most of the $? crud was coping with broken cshisms
1536                     if ($?) {
1537                         print SAVEOUT "Pager `$pager' failed: ";
1538                         if ($? == -1) {
1539                             print SAVEOUT "shell returned -1\n";
1540                         } elsif ($? >> 8) {
1541                             print SAVEOUT
1542                               ( $? & 127 ) ? " (SIG#".($?&127).")" : "",
1543                               ( $? & 128 ) ? " -- core dumped" : "", "\n";
1544                         } else {
1545                             print SAVEOUT "status ", ($? >> 8), "\n";
1546                         }
1547                     }
1548
1549                     open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1550                     open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1551                     $SIG{PIPE} = "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
1552                     # Will stop ignoring SIGPIPE if done like nohup(1)
1553                     # does SIGINT but Perl doesn't give us a choice.
1554                 } else {
1555                     open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT");
1556                 }
1557                 close(SAVEOUT);
1558                 select($selected), $selected= "" unless $selected eq "";
1559                 $piped= "";
1560             }
1561         }                       # CMD:
1562        $fall_off_end = 1 unless defined $cmd; # Emulate `q' on EOF
1563         foreach $evalarg (@$post) {
1564           &eval;
1565         }
1566     }                           # if ($single || $signal)
1567     ($@, $!, $^E, $,, $/, $\, $^W) = @saved;
1568     ();
1569 }
1570
1571 # The following code may be executed now:
1572 # BEGIN {warn 4}
1573
1574 sub sub {
1575     my ($al, $ret, @ret) = "";
1576     if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') {
1577         $al = " for $$sub";
1578     }
1579     local $stack_depth = $stack_depth + 1; # Protect from non-local exits
1580     $#stack = $stack_depth;
1581     $stack[-1] = $single;
1582     $single &= 1;
1583     $single |= 4 if $stack_depth == $deep;
1584     ($frame & 4
1585      ? ( print_lineinfo(' ' x ($stack_depth - 1), "in  "),
1586          # Why -1? But it works! :-(
1587          print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1588      : print_lineinfo(' ' x ($stack_depth - 1), "entering $sub$al\n")) if $frame;
1589     if (wantarray) {
1590         @ret = &$sub;
1591         $single |= $stack[$stack_depth--];
1592         ($frame & 4
1593          ? ( print_lineinfo(' ' x $stack_depth, "out "),
1594              print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1595          : print_lineinfo(' ' x $stack_depth, "exited $sub$al\n")) if $frame & 2;
1596         if ($doret eq $stack_depth or $frame & 16) {
1597             my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1598             print $fh ' ' x $stack_depth if $frame & 16;
1599             print $fh "list context return from $sub:\n";
1600             dumpit($fh, \@ret );
1601             $doret = -2;
1602         }
1603         @ret;
1604     } else {
1605         if (defined wantarray) {
1606             $ret = &$sub;
1607         } else {
1608             &$sub; undef $ret;
1609         };
1610         $single |= $stack[$stack_depth--];
1611         ($frame & 4
1612          ? (  print_lineinfo(' ' x $stack_depth, "out "),
1613               print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1614          : print_lineinfo(' ' x $stack_depth, "exited $sub$al\n")) if $frame & 2;
1615         if ($doret eq $stack_depth or $frame & 16 and defined wantarray) {
1616             my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1617             print $fh (' ' x $stack_depth) if $frame & 16;
1618             print $fh (defined wantarray
1619                          ? "scalar context return from $sub: "
1620                          : "void context return from $sub\n");
1621             dumpit( $fh, $ret ) if defined wantarray;
1622             $doret = -2;
1623         }
1624         $ret;
1625     }
1626 }
1627
1628 ### The API section
1629
1630 ### Functions with multiple modes of failure die on error, the rest
1631 ### returns FALSE on error.
1632 ### User-interface functions cmd_* output error message.
1633
1634 sub break_on_load {
1635   my $file = shift;
1636   $break_on_load{$file} = 1;
1637   $had_breakpoints{$file} |= 1;
1638 }
1639
1640 sub report_break_on_load {
1641   sort keys %break_on_load;
1642 }
1643
1644 sub cmd_b_load {
1645   my $file = shift;
1646   my @files;
1647   {
1648     push @files, $file;
1649     push @files, $::INC{$file} if $::INC{$file};
1650     $file .= '.pm', redo unless $file =~ /\./;
1651   }
1652   break_on_load($_) for @files;
1653   @files = report_break_on_load;
1654   print $OUT "Will stop on load of `@files'.\n";
1655 }
1656
1657 $filename_error = '';
1658
1659 sub breakable_line {
1660   my ($from, $to) = @_;
1661   my $i = $from;
1662   if (@_ >= 2) {
1663     my $delta = $from < $to ? +1 : -1;
1664     my $limit = $delta > 0 ? $#dbline : 1;
1665     $limit = $to if ($limit - $to) * $delta > 0;
1666     $i += $delta while $dbline[$i] == 0 and ($limit - $i) * $delta > 0;
1667   }
1668   return $i unless $dbline[$i] == 0;
1669   my ($pl, $upto) = ('', '');
1670   ($pl, $upto) = ('s', "..$to") if @_ >=2 and $from != $to;
1671   die "Line$pl $from$upto$filename_error not breakable\n";
1672 }
1673
1674 sub breakable_line_in_filename {
1675   my ($f) = shift;
1676   local *dbline = $main::{'_<' . $f};
1677   local $filename_error = " of `$f'";
1678   breakable_line(@_);
1679 }
1680
1681 sub break_on_line {
1682   my ($i, $cond) = @_;
1683   $cond = 1 unless @_ >= 2;
1684   my $inii = $i;
1685   my $after = '';
1686   my $pl = '';
1687   die "Line $i$filename_error not breakable.\n" if $dbline[$i] == 0;
1688   $had_breakpoints{$filename} |= 1;
1689   if ($dbline{$i}) { $dbline{$i} =~ s/^[^\0]*/$cond/; }
1690   else { $dbline{$i} = $cond; }
1691 }
1692
1693 sub cmd_b_line {
1694   eval { break_on_line(@_); 1 } or print $OUT $@ and return;
1695 }
1696
1697 sub break_on_filename_line {
1698   my ($f, $i, $cond) = @_;
1699   $cond = 1 unless @_ >= 3;
1700   local *dbline = $main::{'_<' . $f};
1701   local $filename_error = " of `$f'";
1702   local $filename = $f;
1703   break_on_line($i, $cond);
1704 }
1705
1706 sub break_on_filename_line_range {
1707   my ($f, $from, $to, $cond) = @_;
1708   my $i = breakable_line_in_filename($f, $from, $to);
1709   $cond = 1 unless @_ >= 3;
1710   break_on_filename_line($f,$i,$cond);
1711 }
1712
1713 sub subroutine_filename_lines {
1714   my ($subname,$cond) = @_;
1715   # Filename below can contain ':'
1716   find_sub($subname) =~ /^(.*):(\d+)-(\d+)$/;
1717 }
1718
1719 sub break_subroutine {
1720   my $subname = shift;
1721   my ($file,$s,$e) = subroutine_filename_lines($subname) or
1722     die "Subroutine $subname not found.\n";
1723   $cond = 1 unless @_ >= 2;
1724   break_on_filename_line_range($file,$s,$e,@_);
1725 }
1726
1727 sub cmd_b_sub {
1728   my ($subname,$cond) = @_;
1729   $cond = 1 unless @_ >= 2;
1730   unless (ref $subname eq 'CODE') {
1731     $subname =~ s/\'/::/g;
1732     my $s = $subname;
1733     $subname = "${'package'}::" . $subname
1734       unless $subname =~ /::/;
1735     $subname = "CORE::GLOBAL::$s"
1736       if not defined &$subname and $s !~ /::/ and defined &{"CORE::GLOBAL::$s"};
1737     $subname = "main".$subname if substr($subname,0,2) eq "::";
1738   }
1739   eval { break_subroutine($subname,$cond); 1 } or print $OUT $@ and return;
1740 }
1741
1742 sub cmd_stop {                  # As on ^C, but not signal-safy.
1743   $signal = 1;
1744 }
1745
1746 sub delete_breakpoint {
1747   my $i = shift;
1748   die "Line $i not breakable.\n" if $dbline[$i] == 0;
1749   $dbline{$i} =~ s/^[^\0]*//;
1750   delete $dbline{$i} if $dbline{$i} eq '';
1751 }
1752
1753 sub cmd_d {
1754   my $i = shift;
1755   eval { delete_breakpoint $i; 1 } or print $OUT $@ and return;
1756 }
1757
1758 ### END of the API section
1759
1760 sub save {
1761     @saved = ($@, $!, $^E, $,, $/, $\, $^W);
1762     $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
1763 }
1764
1765 sub print_lineinfo {
1766   resetterm(1) if $LINEINFO eq $OUT and $term_pid != $$;
1767   print $LINEINFO @_;
1768 }
1769
1770 # The following takes its argument via $evalarg to preserve current @_
1771
1772 sub postponed_sub {
1773   my $subname = shift;
1774   if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) {
1775     my $offset = $1 || 0;
1776     # Filename below can contain ':'
1777     my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
1778     if ($i) {
1779       $i += $offset;
1780       local *dbline = $main::{'_<' . $file};
1781       local $^W = 0;            # != 0 is magical below
1782       $had_breakpoints{$file} |= 1;
1783       my $max = $#dbline;
1784       ++$i until $dbline[$i] != 0 or $i >= $max;
1785       $dbline{$i} = delete $postponed{$subname};
1786     } else {
1787       print $OUT "Subroutine $subname not found.\n";
1788     }
1789     return;
1790   }
1791   elsif ($postponed{$subname} eq 'compile') { $signal = 1 }
1792   #print $OUT "In postponed_sub for `$subname'.\n";
1793 }
1794
1795 sub postponed {
1796   if ($ImmediateStop) {
1797     $ImmediateStop = 0;
1798     $signal = 1;
1799   }
1800   return &postponed_sub
1801     unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
1802   # Cannot be done before the file is compiled
1803   local *dbline = shift;
1804   my $filename = $dbline;
1805   $filename =~ s/^_<//;
1806   $signal = 1, print $OUT "'$filename' loaded...\n"
1807     if $break_on_load{$filename};
1808   print_lineinfo(' ' x $stack_depth, "Package $filename.\n") if $frame;
1809   return unless $postponed_file{$filename};
1810   $had_breakpoints{$filename} |= 1;
1811   #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
1812   my $key;
1813   for $key (keys %{$postponed_file{$filename}}) {
1814     $dbline{$key} = ${$postponed_file{$filename}}{$key};
1815   }
1816   delete $postponed_file{$filename};
1817 }
1818
1819 sub dumpit {
1820     local ($savout) = select(shift);
1821     my $osingle = $single;
1822     my $otrace = $trace;
1823     $single = $trace = 0;
1824     local $frame = 0;
1825     local $doret = -2;
1826     unless (defined &main::dumpValue) {
1827         do 'dumpvar.pl';
1828     }
1829     if (defined &main::dumpValue) {
1830         my $v = shift;
1831         my $maxdepth = shift || $option{dumpDepth};
1832         $maxdepth = -1 unless defined $maxdepth;   # -1 means infinite depth
1833         &main::dumpValue($v, $maxdepth);
1834     } else {
1835         print $OUT "dumpvar.pl not available.\n";
1836     }
1837     $single = $osingle;
1838     $trace = $otrace;
1839     select ($savout);
1840 }
1841
1842 # Tied method do not create a context, so may get wrong message:
1843
1844 sub print_trace {
1845   my $fh = shift;
1846   resetterm(1) if $fh eq $LINEINFO and $LINEINFO eq $OUT and $term_pid != $$;
1847   my @sub = dump_trace($_[0] + 1, $_[1]);
1848   my $short = $_[2];            # Print short report, next one for sub name
1849   my $s;
1850   for ($i=0; $i <= $#sub; $i++) {
1851     last if $signal;
1852     local $" = ', ';
1853     my $args = defined $sub[$i]{args}
1854     ? "(@{ $sub[$i]{args} })"
1855       : '' ;
1856     $args = (substr $args, 0, $maxtrace - 3) . '...'
1857       if length $args > $maxtrace;
1858     my $file = $sub[$i]{file};
1859     $file = $file eq '-e' ? $file : "file `$file'" unless $short;
1860     $s = $sub[$i]{sub};
1861     $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace;
1862     if ($short) {
1863       my $sub = @_ >= 4 ? $_[3] : $s;
1864       print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
1865     } else {
1866       print $fh "$sub[$i]{context} = $s$args" .
1867         " called from $file" .
1868           " line $sub[$i]{line}\n";
1869     }
1870   }
1871 }
1872
1873 sub dump_trace {
1874   my $skip = shift;
1875   my $count = shift || 1e9;
1876   $skip++;
1877   $count += $skip;
1878   my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
1879   my $nothard = not $frame & 8;
1880   local $frame = 0;             # Do not want to trace this.
1881   my $otrace = $trace;
1882   $trace = 0;
1883   for ($i = $skip;
1884        $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i);
1885        $i++) {
1886     @a = ();
1887     for $arg (@args) {
1888       my $type;
1889       if (not defined $arg) {
1890         push @a, "undef";
1891       } elsif ($nothard and tied $arg) {
1892         push @a, "tied";
1893       } elsif ($nothard and $type = ref $arg) {
1894         push @a, "ref($type)";
1895       } else {
1896         local $_ = "$arg";      # Safe to stringify now - should not call f().
1897         s/([\'\\])/\\$1/g;
1898         s/(.*)/'$1'/s
1899           unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
1900         s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
1901         s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
1902         push(@a, $_);
1903       }
1904     }
1905     $context = $context ? '@' : (defined $context ? "\$" : '.');
1906     $args = $h ? [@a] : undef;
1907     $e =~ s/\n\s*\;\s*\Z// if $e;
1908     $e =~ s/([\\\'])/\\$1/g if $e;
1909     if ($r) {
1910       $sub = "require '$e'";
1911     } elsif (defined $r) {
1912       $sub = "eval '$e'";
1913     } elsif ($sub eq '(eval)') {
1914       $sub = "eval {...}";
1915     }
1916     push(@sub, {context => $context, sub => $sub, args => $args,
1917                 file => $file, line => $line});
1918     last if $signal;
1919   }
1920   $trace = $otrace;
1921   @sub;
1922 }
1923
1924 sub action {
1925     my $action = shift;
1926     while ($action =~ s/\\$//) {
1927         #print $OUT "+ ";
1928         #$action .= "\n";
1929         $action .= &gets;
1930     }
1931     $action;
1932 }
1933
1934 sub unbalanced {
1935     # i hate using globals!
1936     $balanced_brace_re ||= qr{
1937         ^ \{
1938               (?:
1939                  (?> [^{}] + )              # Non-parens without backtracking
1940                |
1941                  (??{ $balanced_brace_re }) # Group with matching parens
1942               ) *
1943           \} $
1944    }x;
1945    return $_[0] !~ m/$balanced_brace_re/;
1946 }
1947
1948 sub gets {
1949     &readline("cont: ");
1950 }
1951
1952 sub system {
1953     # We save, change, then restore STDIN and STDOUT to avoid fork() since
1954     # some non-Unix systems can do system() but have problems with fork().
1955     open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
1956     open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1957     open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
1958     open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1959
1960     # XXX: using csh or tcsh destroys sigint retvals!
1961     system(@_);
1962     open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
1963     open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1964     close(SAVEIN);
1965     close(SAVEOUT);
1966
1967
1968     # most of the $? crud was coping with broken cshisms
1969     if ($? >> 8) {
1970         &warn("(Command exited ", ($? >> 8), ")\n");
1971     } elsif ($?) {
1972         &warn( "(Command died of SIG#",  ($? & 127),
1973             (($? & 128) ? " -- core dumped" : "") , ")", "\n");
1974     }
1975
1976     return $?;
1977
1978 }
1979
1980 sub setterm {
1981     local $frame = 0;
1982     local $doret = -2;
1983     eval { require Term::ReadLine } or die $@;
1984     if ($notty) {
1985         if ($tty) {
1986             my ($i, $o) = split $tty, /,/;
1987             $o = $i unless defined $o;
1988             open(IN,"<$i") or die "Cannot open TTY `$i' for read: $!";
1989             open(OUT,">$o") or die "Cannot open TTY `$o' for write: $!";
1990             $IN = \*IN;
1991             $OUT = \*OUT;
1992             my $sel = select($OUT);
1993             $| = 1;
1994             select($sel);
1995         } else {
1996             eval "require Term::Rendezvous;" or die;
1997             my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
1998             my $term_rv = new Term::Rendezvous $rv;
1999             $IN = $term_rv->IN;
2000             $OUT = $term_rv->OUT;
2001         }
2002     }
2003     if ($term_pid eq '-1') {            # In a TTY with another debugger
2004         resetterm(2);
2005     }
2006     if (!$rl) {
2007         $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
2008     } else {
2009         $term = new Term::ReadLine 'perldb', $IN, $OUT;
2010
2011         $rl_attribs = $term->Attribs;
2012         $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}'
2013           if defined $rl_attribs->{basic_word_break_characters}
2014             and index($rl_attribs->{basic_word_break_characters}, ":") == -1;
2015         $rl_attribs->{special_prefixes} = '$@&%';
2016         $rl_attribs->{completer_word_break_characters} .= '$@&%';
2017         $rl_attribs->{completion_function} = \&db_complete;
2018     }
2019     $LINEINFO = $OUT unless defined $LINEINFO;
2020     $lineinfo = $console unless defined $lineinfo;
2021     $term->MinLine(2);
2022     if ($term->Features->{setHistory} and "@hist" ne "?") {
2023       $term->SetHistory(@hist);
2024     }
2025     ornaments($ornaments) if defined $ornaments;
2026     $term_pid = $$;
2027 }
2028
2029 # Example get_fork_TTY functions
2030 sub xterm_get_fork_TTY {
2031   (my $name = $0) =~ s,^.*[/\\],,s;
2032   open XT, qq[3>&1 xterm -title "Daughter Perl debugger $pids $name" -e sh -c 'tty 1>&3;\
2033  sleep 10000000' |];
2034   my $tty = <XT>;
2035   chomp $tty;
2036   $pidprompt = '';              # Shown anyway in titlebar
2037   return $tty;
2038 }
2039
2040 # This example function resets $IN, $OUT itself
2041 sub os2_get_fork_TTY {
2042   local $^F = 40;                       # XXXX Fixme!
2043   my ($in1, $out1, $in2, $out2);
2044   # Having -d in PERL5OPT would lead to a disaster...
2045   local $ENV{PERL5OPT} = $ENV{PERL5OPT}    if $ENV{PERL5OPT};
2046   $ENV{PERL5OPT} =~ s/(?:^|(?<=\s))-d\b//  if $ENV{PERL5OPT};
2047   $ENV{PERL5OPT} =~ s/(?:^|(?<=\s))-d\B/-/ if $ENV{PERL5OPT};
2048   print $OUT "Making kid PERL5OPT->`$ENV{PERL5OPT}'.\n" if $ENV{PERL5OPT};
2049   (my $name = $0) =~ s,^.*[/\\],,s;
2050   my @args;
2051   if ( pipe $in1, $out1 and pipe $in2, $out2
2052        # system P_SESSION will fail if there is another process
2053        # in the same session with a "dependent" asynchronous child session.
2054        and @args = ($rl, fileno $in1, fileno $out2,
2055                     "Daughter Perl debugger $pids $name") and
2056        (($kpid = CORE::system 4, $^X, '-we', <<'ES', @args) >= 0 # P_SESSION
2057 use OS2::Process;
2058
2059 my ($rl, $in) = (shift, shift);         # Read from $in and pass through
2060 set_title pop;
2061 system P_NOWAIT, $^X, '-we', <<EOS or die "Cannot start a grandkid";
2062   open IN, '<&=$in' or die "open <&=$in: \$!";
2063   \$| = 1; print while sysread IN, \$_, 1<<16;
2064 EOS
2065
2066 my $out = shift;
2067 open OUT, ">&=$out" or die "Cannot open &=$out for writing: $!";
2068 select OUT;    $| = 1;
2069 require Term::ReadKey if $rl;
2070 Term::ReadKey::ReadMode(4) if $rl; # Nodelay on kbd.  Pipe is automatically nodelay...
2071 print while sysread STDIN, $_, 1<<($rl ? 16 : 0);
2072 ES
2073          or warn "system P_SESSION: $!, $^E" and 0)
2074         and close $in1 and close $out2 ) {
2075       $pidprompt = '';                  # Shown anyway in titlebar
2076       reset_IN_OUT($in2, $out1);
2077       $tty = '*reset*';
2078       return '';                        # Indicate that reset_IN_OUT is called
2079    }
2080    return;
2081 }
2082
2083 sub create_IN_OUT {     # Create a window with IN/OUT handles redirected there
2084     my $in = &get_fork_TTY if defined &get_fork_TTY;
2085     $in = $fork_TTY if defined $fork_TTY; # Backward compatibility
2086     if (not defined $in) {
2087       my $why = shift;
2088       print_help(<<EOP) if $why == 1;
2089 I<#########> Forked, but do not know how to create a new B<TTY>. I<#########>
2090 EOP
2091       print_help(<<EOP) if $why == 2;
2092 I<#########> Daughter session, do not know how to change a B<TTY>. I<#########>
2093   This may be an asynchronous session, so the parent debugger may be active.
2094 EOP
2095       print_help(<<EOP) if $why != 4;
2096   Since two debuggers fight for the same TTY, input is severely entangled.
2097
2098 EOP
2099       print_help(<<EOP);
2100   I know how to switch the output to a different window in xterms
2101   and OS/2 consoles only.  For a manual switch, put the name of the created I<TTY>
2102   in B<\$DB::fork_TTY>, or define a function B<DB::get_fork_TTY()> returning this.
2103
2104   On I<UNIX>-like systems one can get the name of a I<TTY> for the given window
2105   by typing B<tty>, and disconnect the I<shell> from I<TTY> by B<sleep 1000000>.
2106
2107 EOP
2108     } elsif ($in ne '') {
2109       TTY($in);
2110     } else {
2111       $console = '';            # Indicate no need to open-from-the-console
2112     }
2113     undef $fork_TTY;
2114 }
2115
2116 sub resetterm {                 # We forked, so we need a different TTY
2117     my $in = shift;
2118     my $systemed = $in > 1 ? '-' : '';
2119     if ($pids) {
2120       $pids =~ s/\]/$systemed->$$]/;
2121     } else {
2122       $pids = "[$term_pid->$$]";
2123     }
2124     $pidprompt = $pids;
2125     $term_pid = $$;
2126     return unless $CreateTTY & $in;
2127     create_IN_OUT($in);
2128 }
2129
2130 sub readline {
2131   local $.;
2132   if (@typeahead) {
2133     my $left = @typeahead;
2134     my $got = shift @typeahead;
2135     print $OUT "auto(-$left)", shift, $got, "\n";
2136     $term->AddHistory($got)
2137       if length($got) > 1 and defined $term->Features->{addHistory};
2138     return $got;
2139   }
2140   local $frame = 0;
2141   local $doret = -2;
2142   while (@cmdfhs) {
2143     my $line = CORE::readline($cmdfhs[-1]);
2144     defined $line ? (print $OUT ">> $line" and return $line)
2145                   : close pop @cmdfhs;
2146   }
2147   if (ref $OUT and UNIVERSAL::isa($OUT, 'IO::Socket::INET')) {
2148     $OUT->write(join('', @_));
2149     my $stuff;
2150     $IN->recv( $stuff, 2048 );  # XXX: what's wrong with sysread?
2151     $stuff;
2152   }
2153   else {
2154     $term->readline(@_);
2155   }
2156 }
2157
2158 sub dump_option {
2159     my ($opt, $val)= @_;
2160     $val = option_val($opt,'N/A');
2161     $val =~ s/([\\\'])/\\$1/g;
2162     printf $OUT "%20s = '%s'\n", $opt, $val;
2163 }
2164
2165 sub option_val {
2166     my ($opt, $default)= @_;
2167     my $val;
2168     if (defined $optionVars{$opt}
2169         and defined ${$optionVars{$opt}}) {
2170         $val = ${$optionVars{$opt}};
2171     } elsif (defined $optionAction{$opt}
2172         and defined &{$optionAction{$opt}}) {
2173         $val = &{$optionAction{$opt}}();
2174     } elsif (defined $optionAction{$opt}
2175              and not defined $option{$opt}
2176              or defined $optionVars{$opt}
2177              and not defined ${$optionVars{$opt}}) {
2178         $val = $default;
2179     } else {
2180         $val = $option{$opt};
2181     }
2182     $val = $default unless defined $val;
2183     $val
2184 }
2185
2186 sub parse_options {
2187     local($_)= @_;
2188     # too dangerous to let intuitive usage overwrite important things
2189     # defaultion should never be the default
2190     my %opt_needs_val = map { ( $_ => 1 ) } qw{
2191         dumpDepth arrayDepth hashDepth LineInfo maxTraceLen ornaments windowSize
2192         pager quote ReadLine recallCommand RemotePort ShellBang TTY
2193     };
2194     while (length) {
2195         my $val_defaulted;
2196         s/^\s+// && next;
2197         s/^(\w+)(\W?)// or print($OUT "Invalid option `$_'\n"), last;
2198         my ($opt,$sep) = ($1,$2);
2199         my $val;
2200         if ("?" eq $sep) {
2201             print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
2202               if /^\S/;
2203             #&dump_option($opt);
2204         } elsif ($sep !~ /\S/) {
2205             $val_defaulted = 1;
2206             $val = "1";  #  this is an evil default; make 'em set it!
2207         } elsif ($sep eq "=") {
2208
2209             if (s/ (["']) ( (?: \\. | (?! \1 ) [^\\] )* ) \1 //x) {
2210                 my $quote = $1;
2211                 ($val = $2) =~ s/\\([$quote\\])/$1/g;
2212             } else {
2213                 s/^(\S*)//;
2214             $val = $1;
2215                 print OUT qq(Option better cleared using $opt=""\n)
2216                     unless length $val;
2217             }
2218
2219         } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
2220             my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
2221             s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
2222               print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
2223             ($val = $1) =~ s/\\([\\$end])/$1/g;
2224         }
2225
2226         my $option;
2227         my $matches = grep( /^\Q$opt/  && ($option = $_),  @options  )
2228                    || grep( /^\Q$opt/i && ($option = $_),  @options  );
2229
2230         print($OUT "Unknown option `$opt'\n"), next     unless $matches;
2231         print($OUT "Ambiguous option `$opt'\n"), next   if $matches > 1;
2232
2233        if ($opt_needs_val{$option} && $val_defaulted) {
2234             print $OUT "Option `$opt' is non-boolean.  Use `O $option=VAL' to set, `O $option?' to query\n";
2235             next;
2236         }
2237
2238         $option{$option} = $val if defined $val;
2239
2240         eval qq{
2241                 local \$frame = 0;
2242                 local \$doret = -2;
2243                 require '$optionRequire{$option}';
2244                 1;
2245          } || die  # XXX: shouldn't happen
2246             if  defined $optionRequire{$option}     &&
2247                 defined $val;
2248
2249         ${$optionVars{$option}} = $val
2250             if  defined $optionVars{$option}        &&
2251                 defined $val;
2252
2253         &{$optionAction{$option}} ($val)
2254             if defined $optionAction{$option}       &&
2255                defined &{$optionAction{$option}}    &&
2256                defined $val;
2257
2258         # Not $rcfile
2259         dump_option($option)    unless $OUT eq \*STDERR;
2260     }
2261 }
2262
2263 sub set_list {
2264   my ($stem,@list) = @_;
2265   my $val;
2266   $ENV{"${stem}_n"} = @list;
2267   for $i (0 .. $#list) {
2268     $val = $list[$i];
2269     $val =~ s/\\/\\\\/g;
2270     $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
2271     $ENV{"${stem}_$i"} = $val;
2272   }
2273 }
2274
2275 sub get_list {
2276   my $stem = shift;
2277   my @list;
2278   my $n = delete $ENV{"${stem}_n"};
2279   my $val;
2280   for $i (0 .. $n - 1) {
2281     $val = delete $ENV{"${stem}_$i"};
2282     $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
2283     push @list, $val;
2284   }
2285   @list;
2286 }
2287
2288 sub catch {
2289     $signal = 1;
2290     return;                     # Put nothing on the stack - malloc/free land!
2291 }
2292
2293 sub warn {
2294     my($msg)= join("",@_);
2295     $msg .= ": $!\n" unless $msg =~ /\n$/;
2296     print $OUT $msg;
2297 }
2298
2299 sub reset_IN_OUT {
2300     my $switch_li = $LINEINFO eq $OUT;
2301     if ($term and $term->Features->{newTTY}) {
2302       ($IN, $OUT) = (shift, shift);
2303       $term->newTTY($IN, $OUT);
2304     } elsif ($term) {
2305         &warn("Too late to set IN/OUT filehandles, enabled on next `R'!\n");
2306     } else {
2307       ($IN, $OUT) = (shift, shift);
2308     }
2309     my $o = select $OUT;
2310     $| = 1;
2311     select $o;
2312     $LINEINFO = $OUT if $switch_li;
2313 }
2314
2315 sub TTY {
2316     if (@_ and $term and $term->Features->{newTTY}) {
2317       my ($in, $out) = shift;
2318       if ($in =~ /,/) {
2319         ($in, $out) = split /,/, $in, 2;
2320       } else {
2321         $out = $in;
2322       }
2323       open IN, $in or die "cannot open `$in' for read: $!";
2324       open OUT, ">$out" or die "cannot open `$out' for write: $!";
2325       reset_IN_OUT(\*IN,\*OUT);
2326       return $tty = $in;
2327     }
2328     &warn("Too late to set TTY, enabled on next `R'!\n") if $term and @_;
2329     # Useful if done through PERLDB_OPTS:
2330     $console = $tty = shift if @_;
2331     $tty or $console;
2332 }
2333
2334 sub noTTY {
2335     if ($term) {
2336         &warn("Too late to set noTTY, enabled on next `R'!\n") if @_;
2337     }
2338     $notty = shift if @_;
2339     $notty;
2340 }
2341
2342 sub ReadLine {
2343     if ($term) {
2344         &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_;
2345     }
2346     $rl = shift if @_;
2347     $rl;
2348 }
2349
2350 sub RemotePort {
2351     if ($term) {
2352         &warn("Too late to set RemotePort, enabled on next 'R'!\n") if @_;
2353     }
2354     $remoteport = shift if @_;
2355     $remoteport;
2356 }
2357
2358 sub tkRunning {
2359     if (${$term->Features}{tkRunning}) {
2360         return $term->tkRunning(@_);
2361     } else {
2362         print $OUT "tkRunning not supported by current ReadLine package.\n";
2363         0;
2364     }
2365 }
2366
2367 sub NonStop {
2368     if ($term) {
2369         &warn("Too late to set up NonStop mode, enabled on next `R'!\n") if @_;
2370     }
2371     $runnonstop = shift if @_;
2372     $runnonstop;
2373 }
2374
2375 sub pager {
2376     if (@_) {
2377         $pager = shift;
2378         $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
2379     }
2380     $pager;
2381 }
2382
2383 sub shellBang {
2384     if (@_) {
2385         $sh = quotemeta shift;
2386         $sh .= "\\b" if $sh =~ /\w$/;
2387     }
2388     $psh = $sh;
2389     $psh =~ s/\\b$//;
2390     $psh =~ s/\\(.)/$1/g;
2391     $psh;
2392 }
2393
2394 sub ornaments {
2395   if (defined $term) {
2396     local ($warnLevel,$dieLevel) = (0, 1);
2397     return '' unless $term->Features->{ornaments};
2398     eval { $term->ornaments(@_) } || '';
2399   } else {
2400     $ornaments = shift;
2401   }
2402 }
2403
2404 sub recallCommand {
2405     if (@_) {
2406         $rc = quotemeta shift;
2407         $rc .= "\\b" if $rc =~ /\w$/;
2408     }
2409     $prc = $rc;
2410     $prc =~ s/\\b$//;
2411     $prc =~ s/\\(.)/$1/g;
2412     $prc;
2413 }
2414
2415 sub LineInfo {
2416     return $lineinfo unless @_;
2417     $lineinfo = shift;
2418     my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
2419     $slave_editor = ($stream =~ /^\|/);
2420     open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
2421     $LINEINFO = \*LINEINFO;
2422     my $save = select($LINEINFO);
2423     $| = 1;
2424     select($save);
2425     $lineinfo;
2426 }
2427
2428 sub list_versions {
2429   my %version;
2430   my $file;
2431   for (keys %INC) {
2432     $file = $_;
2433     s,\.p[lm]$,,i ;
2434     s,/,::,g ;
2435     s/^perl5db$/DB/;
2436     s/^Term::ReadLine::readline$/readline/;
2437     if (defined ${ $_ . '::VERSION' }) {
2438       $version{$file} = "${ $_ . '::VERSION' } from ";
2439     }
2440     $version{$file} .= $INC{$file};
2441   }
2442   dumpit($OUT,\%version);
2443 }
2444
2445 sub sethelp {
2446     # XXX: make sure there are tabs between the command and explanation,
2447     #      or print_help will screw up your formatting if you have
2448     #      eeevil ornaments enabled.  This is an insane mess.
2449
2450     $help = "
2451 B<T>            Stack trace.
2452 B<s> [I<expr>]  Single step [in I<expr>].
2453 B<n> [I<expr>]  Next, steps over subroutine calls [in I<expr>].
2454 <B<CR>>         Repeat last B<n> or B<s> command.
2455 B<r>            Return from current subroutine.
2456 B<c> [I<line>|I<sub>]   Continue; optionally inserts a one-time-only breakpoint
2457                 at the specified position.
2458 B<l> I<min>B<+>I<incr>  List I<incr>+1 lines starting at I<min>.
2459 B<l> I<min>B<->I<max>   List lines I<min> through I<max>.
2460 B<l> I<line>            List single I<line>.
2461 B<l> I<subname> List first window of lines from subroutine.
2462 B<l> I<\$var>           List first window of lines from subroutine referenced by I<\$var>.
2463 B<l>            List next window of lines.
2464 B<->            List previous window of lines.
2465 B<w> [I<line>]  List window around I<line>.
2466 B<.>            Return to the executed line.
2467 B<f> I<filename>        Switch to viewing I<filename>. File must be already loaded.
2468                 I<filename> may be either the full name of the file, or a regular
2469                 expression matching the full file name:
2470                 B<f> I</home/me/foo.pl> and B<f> I<oo\\.> may access the same file.
2471                 Evals (with saved bodies) are considered to be filenames:
2472                 B<f> I<(eval 7)> and B<f> I<eval 7\\b> access the body of the 7th eval
2473                 (in the order of execution).
2474 B</>I<pattern>B</>      Search forwards for I<pattern>; final B</> is optional.
2475 B<?>I<pattern>B<?>      Search backwards for I<pattern>; final B<?> is optional.
2476 B<L>            List all breakpoints and actions.
2477 B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>.
2478 B<t>            Toggle trace mode.
2479 B<t> I<expr>            Trace through execution of I<expr>.
2480 B<b> [I<line>] [I<condition>]
2481                 Set breakpoint; I<line> defaults to the current execution line;
2482                 I<condition> breaks if it evaluates to true, defaults to '1'.
2483 B<b> I<subname> [I<condition>]
2484                 Set breakpoint at first line of subroutine.
2485 B<b> I<\$var>           Set breakpoint at first line of subroutine referenced by I<\$var>.
2486 B<b> B<load> I<filename> Set breakpoint on `require'ing the given file.
2487 B<b> B<postpone> I<subname> [I<condition>]
2488                 Set breakpoint at first line of subroutine after
2489                 it is compiled.
2490 B<b> B<compile> I<subname>
2491                 Stop after the subroutine is compiled.
2492 B<d> [I<line>]  Delete the breakpoint for I<line>.
2493 B<D>            Delete all breakpoints.
2494 B<a> [I<line>] I<command>
2495                 Set an action to be done before the I<line> is executed;
2496                 I<line> defaults to the current execution line.
2497                 Sequence is: check for breakpoint/watchpoint, print line
2498                 if necessary, do action, prompt user if necessary,
2499                 execute line.
2500 B<a> [I<line>]  Delete the action for I<line>.
2501 B<A>            Delete all actions.
2502 B<W> I<expr>            Add a global watch-expression.
2503 B<W>            Delete all watch-expressions.
2504 B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current).
2505                 Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
2506 B<X> [I<vars>]  Same as \"B<V> I<currentpackage> [I<vars>]\".
2507 B<x> I<expr>            Evals expression in list context, dumps the result.
2508 B<m> I<expr>            Evals expression in list context, prints methods callable
2509                 on the first element of the result.
2510 B<m> I<class>           Prints methods callable via the given class.
2511
2512 B<<> ?                  List Perl commands to run before each prompt.
2513 B<<> I<expr>            Define Perl command to run before each prompt.
2514 B<<<> I<expr>           Add to the list of Perl commands to run before each prompt.
2515 B<>> ?                  List Perl commands to run after each prompt.
2516 B<>> I<expr>            Define Perl command to run after each prompt.
2517 B<>>B<>> I<expr>                Add to the list of Perl commands to run after each prompt.
2518 B<{> I<db_command>      Define debugger command to run before each prompt.
2519 B<{> ?                  List debugger commands to run before each prompt.
2520 B<{{> I<db_command>     Add to the list of debugger commands to run before each prompt.
2521 B<$prc> I<number>       Redo a previous command (default previous command).
2522 B<$prc> I<-number>      Redo number'th-to-last command.
2523 B<$prc> I<pattern>      Redo last command that started with I<pattern>.
2524                 See 'B<O> I<recallCommand>' too.
2525 B<$psh$psh> I<cmd>      Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
2526   . ( $rc eq $sh ? "" : "
2527 B<$psh> [I<cmd>]        Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
2528                 See 'B<O> I<shellBang>' too.
2529 B<@>I<file>             Execute I<file> containing debugger commands (may nest).
2530 B<H> I<-number> Display last number commands (default all).
2531 B<p> I<expr>            Same as \"I<print {DB::OUT} expr>\" in current package.
2532 B<|>I<dbcmd>            Run debugger command, piping DB::OUT to current pager.
2533 B<||>I<dbcmd>           Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
2534 B<\=> [I<alias> I<value>]       Define a command alias, or list current aliases.
2535 I<command>              Execute as a perl statement in current package.
2536 B<v>            Show versions of loaded modules.
2537 B<R>            Pure-man-restart of debugger, some of debugger state
2538                 and command-line options may be lost.
2539                 Currently the following settings are preserved:
2540                 history, breakpoints and actions, debugger B<O>ptions
2541                 and the following command-line options: I<-w>, I<-I>, I<-e>.
2542
2543 B<O> [I<opt>] ...       Set boolean option to true
2544 B<O> [I<opt>B<?>]       Query options
2545 B<O> [I<opt>B<=>I<val>] [I<opt>=B<\">I<val>B<\">] ...
2546                 Set options.  Use quotes in spaces in value.
2547     I<recallCommand>, I<ShellBang>      chars used to recall command or spawn shell;
2548     I<pager>                    program for output of \"|cmd\";
2549     I<tkRunning>                        run Tk while prompting (with ReadLine);
2550     I<signalLevel> I<warnLevel> I<dieLevel>     level of verbosity;
2551     I<inhibit_exit>             Allows stepping off the end of the script.
2552     I<ImmediateStop>            Debugger should stop as early as possible.
2553     I<RemotePort>                       Remote hostname:port for remote debugging
2554   The following options affect what happens with B<V>, B<X>, and B<x> commands:
2555     I<arrayDepth>, I<hashDepth>         print only first N elements ('' for all);
2556     I<compactDump>, I<veryCompact>      change style of array and hash dump;
2557     I<globPrint>                        whether to print contents of globs;
2558     I<DumpDBFiles>              dump arrays holding debugged files;
2559     I<DumpPackages>             dump symbol tables of packages;
2560     I<DumpReused>                       dump contents of \"reused\" addresses;
2561     I<quote>, I<HighBit>, I<undefPrint>         change style of string dump;
2562     I<bareStringify>            Do not print the overload-stringified value;
2563   Other options include:
2564     I<PrintRet>         affects printing of return value after B<r> command,
2565     I<frame>            affects printing messages on subroutine entry/exit.
2566     I<AutoTrace>        affects printing messages on possible breaking points.
2567     I<maxTraceLen>      gives max length of evals/args listed in stack trace.
2568     I<ornaments>        affects screen appearance of the command line.
2569     I<CreateTTY>        bits control attempts to create a new TTY on events:
2570                         1: on fork()    2: debugger is started inside debugger
2571                         4: on startup
2572         During startup options are initialized from \$ENV{PERLDB_OPTS}.
2573         You can put additional initialization options I<TTY>, I<noTTY>,
2574         I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use
2575         `B<R>' after you set them).
2576
2577 B<q> or B<^D>           Quit. Set B<\$DB::finished = 0> to debug global destruction.
2578 B<h> [I<db_command>]    Get help [on a specific debugger command], enter B<|h> to page.
2579 B<h h>          Summary of debugger commands.
2580 B<$doccmd> I<manpage>   Runs the external doc viewer B<$doccmd> command on the
2581                 named Perl I<manpage>, or on B<$doccmd> itself if omitted.
2582                 Set B<\$DB::doccmd> to change viewer.
2583
2584 Type `|h' for a paged display if this was too hard to read.
2585
2586 "; # Fix balance of vi % matching: }}}}
2587
2588     #  note: tabs in the following section are not-so-helpful
2589     $summary = <<"END_SUM";
2590 I<List/search source lines:>               I<Control script execution:>
2591   B<l> [I<ln>|I<sub>]  List source code            B<T>           Stack trace
2592   B<-> or B<.>      List previous/current line  B<s> [I<expr>]    Single step [in expr]
2593   B<w> [I<line>]    List around line            B<n> [I<expr>]    Next, steps over subs
2594   B<f> I<filename>  View source in file         <B<CR>/B<Enter>>  Repeat last B<n> or B<s>
2595   B</>I<pattern>B</> B<?>I<patt>B<?>   Search forw/backw    B<r>           Return from subroutine
2596   B<v>           Show versions of modules    B<c> [I<ln>|I<sub>]  Continue until position
2597 I<Debugger controls:>                        B<L>           List break/watch/actions
2598   B<O> [...]     Set debugger options        B<t> [I<expr>]    Toggle trace [trace expr]
2599   B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I<cmd>] Do pre/post-prompt B<b> [I<ln>|I<event>|I<sub>] [I<cnd>] Set breakpoint
2600   B<$prc> [I<N>|I<pat>]   Redo a previous command     B<d> [I<ln>] or B<D> Delete a/all breakpoints
2601   B<H> [I<-num>]    Display last num commands   B<a> [I<ln>] I<cmd>  Do cmd before line
2602   B<=> [I<a> I<val>]   Define/list an alias        B<W> I<expr>      Add a watch expression
2603   B<h> [I<db_cmd>]  Get help on command         B<A> or B<W>      Delete all actions/watch
2604   B<|>[B<|>]I<db_cmd>  Send output to pager        B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
2605   B<q> or B<^D>     Quit                        B<R>           Attempt a restart
2606 I<Data Examination:>     B<expr>     Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
2607   B<x>|B<m> I<expr>       Evals expr in list context, dumps the result or lists methods.
2608   B<p> I<expr>         Print expression (uses script's current package).
2609   B<S> [[B<!>]I<pat>]     List subroutine names [not] matching pattern
2610   B<V> [I<Pk> [I<Vars>]]  List Variables in Package.  Vars can be ~pattern or !pattern.
2611   B<X> [I<Vars>]       Same as \"B<V> I<current_package> [I<Vars>]\".
2612 For more help, type B<h> I<cmd_letter>, or run B<$doccmd perldebug> for all docs.
2613 END_SUM
2614                                 # ')}}; # Fix balance of vi % matching
2615 }
2616
2617 sub print_help {
2618     local $_ = shift;
2619
2620     # Restore proper alignment destroyed by eeevil I<> and B<>
2621     # ornaments: A pox on both their houses!
2622     #
2623     # A help command will have everything up to and including
2624     # the first tab sequence padded into a field 16 (or if indented 20)
2625     # wide.  If it's wider than that, an extra space will be added.
2626     s{
2627         ^                       # only matters at start of line
2628           ( \040{4} | \t )*     # some subcommands are indented
2629           ( < ?                 # so <CR> works
2630             [BI] < [^\t\n] + )  # find an eeevil ornament
2631           ( \t+ )               # original separation, discarded
2632           ( .* )                # this will now start (no earlier) than
2633                                 # column 16
2634     } {
2635         my($leadwhite, $command, $midwhite, $text) = ($1, $2, $3, $4);
2636         my $clean = $command;
2637         $clean =~ s/[BI]<([^>]*)>/$1/g;
2638     # replace with this whole string:
2639         ($leadwhite ? " " x 4 : "")
2640       . $command
2641       . ((" " x (16 + ($leadwhite ? 4 : 0) - length($clean))) || " ")
2642       . $text;
2643
2644     }mgex;
2645
2646     s{                          # handle bold ornaments
2647         B < ( [^>] + | > ) >
2648     } {
2649           $Term::ReadLine::TermCap::rl_term_set[2]
2650         . $1
2651         . $Term::ReadLine::TermCap::rl_term_set[3]
2652     }gex;
2653
2654     s{                          # handle italic ornaments
2655         I < ( [^>] + | > ) >
2656     } {
2657           $Term::ReadLine::TermCap::rl_term_set[0]
2658         . $1
2659         . $Term::ReadLine::TermCap::rl_term_set[1]
2660     }gex;
2661
2662     print $OUT $_;
2663 }
2664
2665 sub fix_less {
2666     return if defined $ENV{LESS} && $ENV{LESS} =~ /r/;
2667     my $is_less = $pager =~ /\bless\b/;
2668     if ($pager =~ /\bmore\b/) {
2669         my @st_more = stat('/usr/bin/more');
2670         my @st_less = stat('/usr/bin/less');
2671         $is_less = @st_more    && @st_less
2672                 && $st_more[0] == $st_less[0]
2673                 && $st_more[1] == $st_less[1];
2674     }
2675     # changes environment!
2676     $ENV{LESS} .= 'r'   if $is_less;
2677 }
2678
2679 sub diesignal {
2680     local $frame = 0;
2681     local $doret = -2;
2682     $SIG{'ABRT'} = 'DEFAULT';
2683     kill 'ABRT', $$ if $panic++;
2684     if (defined &Carp::longmess) {
2685         local $SIG{__WARN__} = '';
2686         local $Carp::CarpLevel = 2;             # mydie + confess
2687         &warn(Carp::longmess("Signal @_"));
2688     }
2689     else {
2690         print $DB::OUT "Got signal @_\n";
2691     }
2692     kill 'ABRT', $$;
2693 }
2694
2695 sub dbwarn {
2696   local $frame = 0;
2697   local $doret = -2;
2698   local $SIG{__WARN__} = '';
2699   local $SIG{__DIE__} = '';
2700   eval { require Carp } if defined $^S; # If error/warning during compilation,
2701                                         # require may be broken.
2702   CORE::warn(@_, "\nCannot print stack trace, load with -MCarp option to see stack"),
2703     return unless defined &Carp::longmess;
2704   my ($mysingle,$mytrace) = ($single,$trace);
2705   $single = 0; $trace = 0;
2706   my $mess = Carp::longmess(@_);
2707   ($single,$trace) = ($mysingle,$mytrace);
2708   &warn($mess);
2709 }
2710
2711 sub dbdie {
2712   local $frame = 0;
2713   local $doret = -2;
2714   local $SIG{__DIE__} = '';
2715   local $SIG{__WARN__} = '';
2716   my $i = 0; my $ineval = 0; my $sub;
2717   if ($dieLevel > 2) {
2718       local $SIG{__WARN__} = \&dbwarn;
2719       &warn(@_);                # Yell no matter what
2720       return;
2721   }
2722   if ($dieLevel < 2) {
2723     die @_ if $^S;              # in eval propagate
2724   }
2725   # No need to check $^S, eval is much more robust nowadays
2726   eval { require Carp }; #if defined $^S;# If error/warning during compilation,
2727                                         # require may be broken.
2728
2729   die(@_, "\nCannot print stack trace, load with -MCarp option to see stack")
2730     unless defined &Carp::longmess;
2731
2732   # We do not want to debug this chunk (automatic disabling works
2733   # inside DB::DB, but not in Carp).
2734   my ($mysingle,$mytrace) = ($single,$trace);
2735   $single = 0; $trace = 0;
2736   my $mess = "@_";
2737   {
2738     package Carp;               # Do not include us in the list
2739     eval {
2740       $mess = Carp::longmess(@_);
2741     };
2742   }
2743   ($single,$trace) = ($mysingle,$mytrace);
2744   die $mess;
2745 }
2746
2747 sub warnLevel {
2748   if (@_) {
2749     $prevwarn = $SIG{__WARN__} unless $warnLevel;
2750     $warnLevel = shift;
2751     if ($warnLevel) {
2752       $SIG{__WARN__} = \&DB::dbwarn;
2753     } elsif ($prevwarn) {
2754       $SIG{__WARN__} = $prevwarn;
2755     }
2756   }
2757   $warnLevel;
2758 }
2759
2760 sub dieLevel {
2761   if (@_) {
2762     $prevdie = $SIG{__DIE__} unless $dieLevel;
2763     $dieLevel = shift;
2764     if ($dieLevel) {
2765       $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
2766       #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
2767       print $OUT "Stack dump during die enabled",
2768         ( $dieLevel == 1 ? " outside of evals" : ""), ".\n"
2769           if $I_m_init;
2770       print $OUT "Dump printed too.\n" if $dieLevel > 2;
2771     } elsif ($prevdie) {
2772       $SIG{__DIE__} = $prevdie;
2773       print $OUT "Default die handler restored.\n";
2774     }
2775   }
2776   $dieLevel;
2777 }
2778
2779 sub signalLevel {
2780   if (@_) {
2781     $prevsegv = $SIG{SEGV} unless $signalLevel;
2782     $prevbus = $SIG{BUS} unless $signalLevel;
2783     $signalLevel = shift;
2784     if ($signalLevel) {
2785       $SIG{SEGV} = \&DB::diesignal;
2786       $SIG{BUS} = \&DB::diesignal;
2787     } else {
2788       $SIG{SEGV} = $prevsegv;
2789       $SIG{BUS} = $prevbus;
2790     }
2791   }
2792   $signalLevel;
2793 }
2794
2795 sub CvGV_name {
2796   my $in = shift;
2797   my $name = CvGV_name_or_bust($in);
2798   defined $name ? $name : $in;
2799 }
2800
2801 sub CvGV_name_or_bust {
2802   my $in = shift;
2803   return if $skipCvGV;          # Backdoor to avoid problems if XS broken...
2804   return unless ref $in;
2805   $in = \&$in;                  # Hard reference...
2806   eval {require Devel::Peek; 1} or return;
2807   my $gv = Devel::Peek::CvGV($in) or return;
2808   *$gv{PACKAGE} . '::' . *$gv{NAME};
2809 }
2810
2811 sub find_sub {
2812   my $subr = shift;
2813   $sub{$subr} or do {
2814     return unless defined &$subr;
2815     my $name = CvGV_name_or_bust($subr);
2816     my $data;
2817     $data = $sub{$name} if defined $name;
2818     return $data if defined $data;
2819
2820     # Old stupid way...
2821     $subr = \&$subr;            # Hard reference
2822     my $s;
2823     for (keys %sub) {
2824       $s = $_, last if $subr eq \&$_;
2825     }
2826     $sub{$s} if $s;
2827   }
2828 }
2829
2830 sub methods {
2831   my $class = shift;
2832   $class = ref $class if ref $class;
2833   local %seen;
2834   local %packs;
2835   methods_via($class, '', 1);
2836   methods_via('UNIVERSAL', 'UNIVERSAL', 0);
2837 }
2838
2839 sub methods_via {
2840   my $class = shift;
2841   return if $packs{$class}++;
2842   my $prefix = shift;
2843   my $prepend = $prefix ? "via $prefix: " : '';
2844   my $name;
2845   for $name (grep {defined &{${"${class}::"}{$_}}}
2846              sort keys %{"${class}::"}) {
2847     next if $seen{ $name }++;
2848     print $DB::OUT "$prepend$name\n";
2849   }
2850   return unless shift;          # Recurse?
2851   for $name (@{"${class}::ISA"}) {
2852     $prepend = $prefix ? $prefix . " -> $name" : $name;
2853     methods_via($name, $prepend, 1);
2854   }
2855 }
2856
2857 sub setman {
2858     $doccmd = $^O !~ /^(?:MSWin32|VMS|os2|dos|amigaos|riscos|MacOS|NetWare)\z/s
2859                 ? "man"             # O Happy Day!
2860                 : "perldoc";        # Alas, poor unfortunates
2861 }
2862
2863 sub runman {
2864     my $page = shift;
2865     unless ($page) {
2866         &system("$doccmd $doccmd");
2867         return;
2868     }
2869     # this way user can override, like with $doccmd="man -Mwhatever"
2870     # or even just "man " to disable the path check.
2871     unless ($doccmd eq 'man') {
2872         &system("$doccmd $page");
2873         return;
2874     }
2875
2876     $page = 'perl' if lc($page) eq 'help';
2877
2878     require Config;
2879     my $man1dir = $Config::Config{'man1dir'};
2880     my $man3dir = $Config::Config{'man3dir'};
2881     for ($man1dir, $man3dir) { s#/[^/]*\z## if /\S/ }
2882     my $manpath = '';
2883     $manpath .= "$man1dir:" if $man1dir =~ /\S/;
2884     $manpath .= "$man3dir:" if $man3dir =~ /\S/ && $man1dir ne $man3dir;
2885     chop $manpath if $manpath;
2886     # harmless if missing, I figure
2887     my $oldpath = $ENV{MANPATH};
2888     $ENV{MANPATH} = $manpath if $manpath;
2889     my $nopathopt = $^O =~ /dunno what goes here/;
2890     if (CORE::system($doccmd,
2891                 # I just *know* there are men without -M
2892                 (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),
2893             split ' ', $page) )
2894     {
2895         unless ($page =~ /^perl\w/) {
2896             if (grep { $page eq $_ } qw{
2897                 5004delta 5005delta amiga api apio book boot bot call compile
2898                 cygwin data dbmfilter debug debguts delta diag doc dos dsc embed
2899                 faq faq1 faq2 faq3 faq4 faq5 faq6 faq7 faq8 faq9 filter fork
2900                 form func guts hack hist hpux intern ipc lexwarn locale lol mod
2901                 modinstall modlib number obj op opentut os2 os390 pod port
2902                 ref reftut run sec style sub syn thrtut tie toc todo toot tootc
2903                 trap unicode var vms win32 xs xstut
2904               })
2905             {
2906                 $page =~ s/^/perl/;
2907                 CORE::system($doccmd,
2908                         (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),
2909                         $page);
2910             }
2911         }
2912     }
2913     if (defined $oldpath) {
2914         $ENV{MANPATH} = $manpath;
2915     } else {
2916         delete $ENV{MANPATH};
2917     }
2918 }
2919
2920 # The following BEGIN is very handy if debugger goes havoc, debugging debugger?
2921
2922 BEGIN {                 # This does not compile, alas.
2923   $IN = \*STDIN;                # For bugs before DB::OUT has been opened
2924   $OUT = \*STDERR;              # For errors before DB::OUT has been opened
2925   $sh = '!';
2926   $rc = ',';
2927   @hist = ('?');
2928   $deep = 100;                  # warning if stack gets this deep
2929   $window = 10;
2930   $preview = 3;
2931   $sub = '';
2932   $SIG{INT} = \&DB::catch;
2933   # This may be enabled to debug debugger:
2934   #$warnLevel = 1 unless defined $warnLevel;
2935   #$dieLevel = 1 unless defined $dieLevel;
2936   #$signalLevel = 1 unless defined $signalLevel;
2937
2938   $db_stop = 0;                 # Compiler warning
2939   $db_stop = 1 << 30;
2940   $level = 0;                   # Level of recursive debugging
2941   # @stack and $doret are needed in sub sub, which is called for DB::postponed.
2942   # Triggers bug (?) in perl is we postpone this until runtime:
2943   @postponed = @stack = (0);
2944   $stack_depth = 0;             # Localized $#stack
2945   $doret = -2;
2946   $frame = 0;
2947 }
2948
2949 BEGIN {$^W = $ini_warn;}        # Switch warnings back
2950
2951 #use Carp;                      # This did break, left for debugging
2952
2953 sub db_complete {
2954   # Specific code for b c l V m f O, &blah, $blah, @blah, %blah
2955   my($text, $line, $start) = @_;
2956   my ($itext, $search, $prefix, $pack) =
2957     ($text, "^\Q${'package'}::\E([^:]+)\$");
2958
2959   return sort grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines
2960                                (map { /$search/ ? ($1) : () } keys %sub)
2961     if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/;
2962   return sort grep /^\Q$text/, values %INC # files
2963     if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/;
2964   return sort map {($_, db_complete($_ . "::", "V ", 2))}
2965     grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # top-packages
2966       if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/;
2967   return sort map {($_, db_complete($_ . "::", "V ", 2))}
2968     grep !/^main::/,
2969       grep /^\Q$text/, map { /^(.*)::$/ ? ($prefix . "::$1") : ()} keys %{$prefix . '::'}
2970                                  # packages
2971         if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/
2972           and $text =~ /^(.*[^:])::?(\w*)$/  and $prefix = $1;
2973   if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files
2974     # We may want to complete to (eval 9), so $text may be wrong
2975     $prefix = length($1) - length($text);
2976     $text = $1;
2977     return sort
2978         map {substr $_, 2 + $prefix} grep /^_<\Q$text/, (keys %main::), $0
2979   }
2980   if ((substr $text, 0, 1) eq '&') { # subroutines
2981     $text = substr $text, 1;
2982     $prefix = "&";
2983     return sort map "$prefix$_",
2984                grep /^\Q$text/,
2985                  (keys %sub),
2986                  (map { /$search/ ? ($1) : () }
2987                     keys %sub);
2988   }
2989   if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
2990     $pack = ($1 eq 'main' ? '' : $1) . '::';
2991     $prefix = (substr $text, 0, 1) . $1 . '::';
2992     $text = $2;
2993     my @out
2994       = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ;
2995     if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2996       return db_complete($out[0], $line, $start);
2997     }
2998     return sort @out;
2999   }
3000   if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
3001     $pack = ($package eq 'main' ? '' : $package) . '::';
3002     $prefix = substr $text, 0, 1;
3003     $text = substr $text, 1;
3004     my @out = map "$prefix$_", grep /^\Q$text/,
3005        (grep /^_?[a-zA-Z]/, keys %$pack),
3006        ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ;
3007     if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
3008       return db_complete($out[0], $line, $start);
3009     }
3010     return sort @out;
3011   }
3012   if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space
3013     my @out = grep /^\Q$text/, @options;
3014     my $val = option_val($out[0], undef);
3015     my $out = '? ';
3016     if (not defined $val or $val =~ /[\n\r]/) {
3017       # Can do nothing better
3018     } elsif ($val =~ /\s/) {
3019       my $found;
3020       foreach $l (split //, qq/\"\'\#\|/) {
3021         $out = "$l$val$l ", last if (index $val, $l) == -1;
3022       }
3023     } else {
3024       $out = "=$val ";
3025     }
3026     # Default to value if one completion, to question if many
3027     $rl_attribs->{completer_terminator_character} = (@out == 1 ? $out : '? ');
3028     return sort @out;
3029   }
3030   return $term->filename_list($text); # filenames
3031 }
3032
3033 sub end_report {
3034   print $OUT "Use `q' to quit or `R' to restart.  `h q' for details.\n"
3035 }
3036
3037 sub clean_ENV {
3038     if (defined($ini_pids)) {
3039         $ENV{PERLDB_PIDS} = $ini_pids;
3040     } else {
3041         delete($ENV{PERLDB_PIDS});
3042     }
3043 }
3044
3045 END {
3046   $finished = 1 if $inhibit_exit;      # So that some keys may be disabled.
3047   $fall_off_end = 1 unless $inhibit_exit;
3048   # Do not stop in at_exit() and destructors on exit:
3049   $DB::single = !$fall_off_end && !$runnonstop;
3050   DB::fake::at_exit() unless $fall_off_end or $runnonstop;
3051 }
3052
3053 package DB::fake;
3054
3055 sub at_exit {
3056   "Debugged program terminated.  Use `q' to quit or `R' to restart.";
3057 }
3058
3059 package DB;                     # Do not trace this 1; below!
3060
3061 1;