lib/perl5db.pl

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