lib/perl5db.pl

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