lib/perl5db.pl

   1 =head1 NAME
   2
   3 C<perl5db.pl> - the perl debugger
   4
   5 =head1 SYNOPSIS
   6
   7     perl -d  your_Perl_script
   8
   9 =head1 DESCRIPTION
  10
  11 C<perl5db.pl> is the perl debugger. It is loaded automatically by Perl when
  12 you invoke a script with C<perl -d>. This documentation tries to outline the
  13 structure and services provided by C<perl5db.pl>, and to describe how you
  14 can use them.
  15
  16 =head1 GENERAL NOTES
  17
  18 The debugger can look pretty forbidding to many Perl programmers. There are
  19 a number of reasons for this, many stemming out of the debugger's history.
  20
  21 When the debugger was first written, Perl didn't have a lot of its nicer
  22 features - no references, no lexical variables, no closures, no object-oriented
  23 programming. So a lot of the things one would normally have done using such
  24 features was done using global variables, globs and the C<local()> operator
  25 in creative ways.
  26
  27 Some of these have survived into the current debugger; a few of the more
  28 interesting and still-useful idioms are noted in this section, along with notes
  29 on the comments themselves.
  30
  31 =head2 Why not use more lexicals?
  32
  33 Experienced Perl programmers will note that the debugger code tends to use
  34 mostly package globals rather than lexically-scoped variables. This is done
  35 to allow a significant amount of control of the debugger from outside the
  36 debugger itself.
  37
  38 Unfortunately, though the variables are accessible, they're not well
  39 documented, so it's generally been a decision that hasn't made a lot of
  40 difference to most users. Where appropriate, comments have been added to
  41 make variables more accessible and usable, with the understanding that these
  42 i<are> debugger internals, and are therefore subject to change. Future
  43 development should probably attempt to replace the globals with a well-defined
  44 API, but for now, the variables are what we've got.
  45
  46 =head2 Automated variable stacking via C<local()>
  47
  48 As you may recall from reading C<perlfunc>, the C<local()> operator makes a
  49 temporary copy of a variable in the current scope. When the scope ends, the
  50 old copy is restored. This is often used in the debugger to handle the
  51 automatic stacking of variables during recursive calls:
  52
  53      sub foo {
  54         local $some_global++;
  55
  56         # Do some stuff, then ...
  57         return;
  58      }
  59
  60 What happens is that on entry to the subroutine, C<$some_global> is localized,
  61 then altered. When the subroutine returns, Perl automatically undoes the
  62 localization, restoring the previous value. Voila, automatic stack management.
  63
  64 The debugger uses this trick a I<lot>. Of particular note is C<DB::eval>,
  65 which lets the debugger get control inside of C<eval>'ed code. The debugger
  66 localizes a saved copy of C<$@> inside the subroutine, which allows it to
  67 keep C<$@> safe until it C<DB::eval> returns, at which point the previous
  68 value of C<$@> is restored. This makes it simple (well, I<simpler>) to keep
  69 track of C<$@> inside C<eval>s which C<eval> other C<eval's>.
  70
  71 In any case, watch for this pattern. It occurs fairly often.
  72
  73 =head2 The C<^> trick
  74
  75 This is used to cleverly reverse the sense of a logical test depending on
  76 the value of an auxiliary variable. For instance, the debugger's C<S>
  77 (search for subroutines by pattern) allows you to negate the pattern
  78 like this:
  79
  80    # Find all non-'foo' subs:
  81    S !/foo/
  82
  83 Boolean algebra states that the truth table for XOR looks like this:
  84
  85 =over 4
  86
  87 =item * 0 ^ 0 = 0
  88
  89 (! not present and no match) --> false, don't print
  90
  91 =item * 0 ^ 1 = 1
  92
  93 (! not present and matches) --> true, print
  94
  95 =item * 1 ^ 0 = 1
  96
  97 (! present and no match) --> true, print
  98
  99 =item * 1 ^ 1 = 0
 100
 101 (! present and matches) --> false, don't print
 102
 103 =back
 104
 105 As you can see, the first pair applies when C<!> isn't supplied, and
 106 the second pair applies when it isn't. The XOR simply allows us to
 107 compact a more complicated if-then-elseif-else into a more elegant
 108 (but perhaps overly clever) single test. After all, it needed this
 109 explanation...
 110
 111 =head2 FLAGS, FLAGS, FLAGS
 112
 113 There is a certain C programming legacy in the debugger. Some variables,
 114 such as C<$single>, C<$trace>, and C<$frame>, have "magical" values composed
 115 of 1, 2, 4, etc. (powers of 2) OR'ed together. This allows several pieces
 116 of state to be stored independently in a single scalar.
 117
 118 A test like
 119
 120     if ($scalar & 4) ...
 121
 122 is checking to see if the appropriate bit is on. Since each bit can be
 123 "addressed" independently in this way, C<$scalar> is acting sort of like
 124 an array of bits. Obviously, since the contents of C<$scalar> are just a
 125 bit-pattern, we can save and restore it easily (it will just look like
 126 a number).
 127
 128 The problem, is of course, that this tends to leave magic numbers scattered
 129 all over your program whenever a bit is set, cleared, or checked. So why do
 130 it?
 131
 132 =over 4
 133
 134
 135 =item * First, doing an arithmetical or bitwise operation on a scalar is
 136 just about the fastest thing you can do in Perl: C<use constant> actually
 137 creates a subroutine call, and array hand hash lookups are much slower. Is
 138 this over-optimization at the expense of readability? Possibly, but the
 139 debugger accesses these  variables a I<lot>. Any rewrite of the code will
 140 probably have to benchmark alternate implementations and see which is the
 141 best balance of readability and speed, and then document how it actually
 142 works.
 143
 144 =item * Second, it's very easy to serialize a scalar number. This is done in
 145 the restart code; the debugger state variables are saved in C<%ENV> and then
 146 restored when the debugger is restarted. Having them be just numbers makes
 147 this trivial.
 148
 149 =item * Third, some of these variables are being shared with the Perl core
 150 smack in the middle of the interpreter's execution loop. It's much faster for
 151 a C program (like the interpreter) to check a bit in a scalar than to access
 152 several different variables (or a Perl array).
 153
 154 =back
 155
 156 =head2 What are those C<XXX> comments for?
 157
 158 Any comment containing C<XXX> means that the comment is either somewhat
 159 speculative - it's not exactly clear what a given variable or chunk of
 160 code is doing, or that it is incomplete - the basics may be clear, but the
 161 subtleties are not completely documented.
 162
 163 Send in a patch if you can clear up, fill out, or clarify an C<XXX>.
 164
 165 =head1 DATA STRUCTURES MAINTAINED BY CORE
 166
 167 There are a number of special data structures provided to the debugger by
 168 the Perl interpreter.
 169
 170 The array C<@{$main::{'_<'.$filename}}> (aliased locally to C<@dbline> via glob
 171 assignment) contains the text from C<$filename>, with each element
 172 corresponding to a single line of C<$filename>.
 173
 174 The hash C<%{'_<'.$filename}> (aliased locally to C<%dbline> via glob
 175 assignment) contains breakpoints and actions.  The keys are line numbers;
 176 you can set individual values, but not the whole hash. The Perl interpreter
 177 uses this hash to determine where breakpoints have been set. Any true value is
 178 considered to be a breakpoint; C<perl5db.pl> uses "$break_condition\0$action".
 179 Values are magical in numeric context: 1 if the line is breakable, 0 if not.
 180
 181 The scalar ${'_<'.$filename} contains $filename  XXX What?
 182
 183 =head1 DEBUGGER STARTUP
 184
 185 When C<perl5db.pl> starts, it reads an rcfile (C<perl5db.ini> for
 186 non-interactive sessions, C<.perldb> for interactive ones) that can set a number
 187 of options. In addition, this file may define a subroutine C<&afterinit>
 188 that will be executed (in the debugger's context) after the debugger has
 189 initialized itself.
 190
 191 Next, it checks the C<PERLDB_OPTS> environment variable and treats its
 192 contents as the argument of a debugger <C<o> command.
 193
 194 =head2 STARTUP-ONLY OPTIONS
 195
 196 The following options can only be specified at startup.
 197 To set them in your rcfile, add a call to
 198 C<&parse_options("optionName=new_value")>.
 199
 200 =over 4
 201
 202 =item * TTY
 203
 204 the TTY to use for debugging i/o.
 205
 206 =item * noTTY
 207
 208 if set, goes in NonStop mode.  On interrupt, if TTY is not set,
 209 uses the value of noTTY or "/tmp/perldbtty$$" to find TTY using
 210 Term::Rendezvous.  Current variant is to have the name of TTY in this
 211 file.
 212
 213 =item * ReadLine
 214
 215 If false, a dummy  ReadLine is used, so you can debug
 216 ReadLine applications.
 217
 218 =item * NonStop
 219
 220 if true, no i/o is performed until interrupt.
 221
 222 =item * LineInfo
 223
 224 file or pipe to print line number info to.  If it is a
 225 pipe, a short "emacs like" message is used.
 226
 227 =item * RemotePort
 228
 229 host:port to connect to on remote host for remote debugging.
 230
 231 =back
 232
 233 =head3 SAMPLE RCFILE
 234
 235  &parse_options("NonStop=1 LineInfo=db.out");
 236   sub afterinit { $trace = 1; }
 237
 238 The script will run without human intervention, putting trace
 239 information into C<db.out>.  (If you interrupt it, you had better
 240 reset C<LineInfo> to something "interactive"!)
 241
 242 =head1 INTERNALS DESCRIPTION
 243
 244 =head2 DEBUGGER INTERFACE VARIABLES
 245
 246 Perl supplies the values for C<%sub>.  It effectively inserts
 247 a C<&DB'DB();> in front of each place that can have a
 248 breakpoint. At each subroutine call, it calls C<&DB::sub> with
 249 C<$DB::sub> set to the called subroutine. It also inserts a C<BEGIN
 250 {require 'perl5db.pl'}> before the first line.
 251
 252 After each C<require>d file is compiled, but before it is executed, a
 253 call to C<&DB::postponed($main::{'_<'.$filename})> is done. C<$filename>
 254 is the expanded name of the C<require>d file (as found via C<%INC>).
 255
 256 =head3 IMPORTANT INTERNAL VARIABLES
 257
 258 =head4 C<$CreateTTY>
 259
 260 Used to control when the debugger will attempt to acquire another TTY to be
 261 used for input.
 262
 263 =over
 264
 265 =item * 1 -  on C<fork()>
 266
 267 =item * 2 - debugger is started inside debugger
 268
 269 =item * 4 -  on startup
 270
 271 =back
 272
 273 =head4 C<$doret>
 274
 275 The value -2 indicates that no return value should be printed.
 276 Any other positive value causes C<DB::sub> to print return values.
 277
 278 =head4 C<$evalarg>
 279
 280 The item to be eval'ed by C<DB::eval>. Used to prevent messing with the current
 281 contents of C<@_> when C<DB::eval> is called.
 282
 283 =head4 C<$frame>
 284
 285 Determines what messages (if any) will get printed when a subroutine (or eval)
 286 is entered or exited.
 287
 288 =over 4
 289
 290 =item * 0 -  No enter/exit messages
 291
 292 =item * 1 - Print "entering" messages on subroutine entry
 293
 294 =item * 2 - Adds exit messages on subroutine exit. If no other flag is on, acts like 1+2.
 295
 296 =item * 4 - Extended messages: C<in|out> I<context>=I<fully-qualified sub name> from I<file>:I<line>>. If no other flag is on, acts like 1+4.
 297
 298 =item * 8 - Adds parameter information to messages, and overloaded stringify and tied FETCH is enabled on the printed arguments. Ignored if C<4> is not on.
 299
 300 =item * 16 - Adds C<I<context> return from I<subname>: I<value>> messages on subroutine/eval exit. Ignored if C<4> is is not on.
 301
 302 =back
 303
 304 To get everything, use C<$frame=30> (or C<o f-30> as a debugger command).
 305 The debugger internally juggles the value of C<$frame> during execution to
 306 protect external modules that the debugger uses from getting traced.
 307
 308 =head4 C<$level>
 309
 310 Tracks current debugger nesting level. Used to figure out how many
 311 C<E<lt>E<gt>> pairs to surround the line number with when the debugger
 312 outputs a prompt. Also used to help determine if the program has finished
 313 during command parsing.
 314
 315 =head4 C<$onetimeDump>
 316
 317 Controls what (if anything) C<DB::eval()> will print after evaluating an
 318 expression.
 319
 320 =over 4
 321
 322 =item * C<undef> - don't print anything
 323
 324 =item * C<dump> - use C<dumpvar.pl> to display the value returned
 325
 326 =item * C<methods> - print the methods callable on the first item returned
 327
 328 =back
 329
 330 =head4 C<$onetimeDumpDepth>
 331
 332 Controls how far down C<dumpvar.pl> will go before printing '...' while
 333 dumping a structure. Numeric. If C<undef>, print all levels.
 334
 335 =head4 C<$signal>
 336
 337 Used to track whether or not an C<INT> signal has been detected. C<DB::DB()>,
 338 which is called before every statement, checks this and puts the user into
 339 command mode if it finds C<$signal> set to a true value.
 340
 341 =head4 C<$single>
 342
 343 Controls behavior during single-stepping. Stacked in C<@stack> on entry to
 344 each subroutine; popped again at the end of each subroutine.
 345
 346 =over 4
 347
 348 =item * 0 - run continuously.
 349
 350 =item * 1 - single-step, go into subs. The 's' command.
 351
 352 =item * 2 - single-step, don't go into subs. The 'n' command.
 353
 354 =item * 4 - print current sub depth (turned on to force this when "too much
 355 recursion" occurs.
 356
 357 =back
 358
 359 =head4 C<$trace>
 360
 361 Controls the output of trace information.
 362
 363 =over 4
 364
 365 =item * 1 - The C<t> command was entered to turn on tracing (every line executed is printed)
 366
 367 =item * 2 - watch expressions are active
 368
 369 =item * 4 - user defined a C<watchfunction()> in C<afterinit()>
 370
 371 =back
 372
 373 =head4 C<$slave_editor>
 374
 375 1 if C<LINEINFO> was directed to a pipe; 0 otherwise.
 376
 377 =head4 C<@cmdfhs>
 378
 379 Stack of filehandles that C<DB::readline()> will read commands from.
 380 Manipulated by the debugger's C<source> command and C<DB::readline()> itself.
 381
 382 =head4 C<@dbline>
 383
 384 Local alias to the magical line array, C<@{$main::{'_<'.$filename}}> ,
 385 supplied by the Perl interpreter to the debugger. Contains the source.
 386
 387 =head4 C<@old_watch>
 388
 389 Previous values of watch expressions. First set when the expression is
 390 entered; reset whenever the watch expression changes.
 391
 392 =head4 C<@saved>
 393
 394 Saves important globals (C<$@>, C<$!>, C<$^E>, C<$,>, C<$/>, C<$\>, C<$^W>)
 395 so that the debugger can substitute safe values while it's running, and
 396 restore them when it returns control.
 397
 398 =head4 C<@stack>
 399
 400 Saves the current value of C<$single> on entry to a subroutine.
 401 Manipulated by the C<c> command to turn off tracing in all subs above the
 402 current one.
 403
 404 =head4 C<@to_watch>
 405
 406 The 'watch' expressions: to be evaluated before each line is executed.
 407
 408 =head4 C<@typeahead>
 409
 410 The typeahead buffer, used by C<DB::readline>.
 411
 412 =head4 C<%alias>
 413
 414 Command aliases. Stored as character strings to be substituted for a command
 415 entered.
 416
 417 =head4 C<%break_on_load>
 418
 419 Keys are file names, values are 1 (break when this file is loaded) or undef
 420 (don't break when it is loaded).
 421
 422 =head4 C<%dbline>
 423
 424 Keys are line numbers, values are "condition\0action". If used in numeric
 425 context, values are 0 if not breakable, 1 if breakable, no matter what is
 426 in the actual hash entry.
 427
 428 =head4 C<%had_breakpoints>
 429
 430 Keys are file names; values are bitfields:
 431
 432 =over 4
 433
 434 =item * 1 - file has a breakpoint in it.
 435
 436 =item * 2 - file has an action in it.
 437
 438 =back
 439
 440 A zero or undefined value means this file has neither.
 441
 442 =head4 C<%option>
 443
 444 Stores the debugger options. These are character string values.
 445
 446 =head4 C<%postponed>
 447
 448 Saves breakpoints for code that hasn't been compiled yet.
 449 Keys are subroutine names, values are:
 450
 451 =over 4
 452
 453 =item * 'compile' - break when this sub is compiled
 454
 455 =item * 'break +0 if <condition>' - break (conditionally) at the start of this routine. The condition will be '1' if no condition was specified.
 456
 457 =back
 458
 459 =head4 C<%postponed_file>
 460
 461 This hash keeps track of breakpoints that need to be set for files that have
 462 not yet been compiled. Keys are filenames; values are references to hashes.
 463 Each of these hashes is keyed by line number, and its values are breakpoint
 464 definitions ("condition\0action").
 465
 466 =head1 DEBUGGER INITIALIZATION
 467
 468 The debugger's initialization actually jumps all over the place inside this
 469 package. This is because there are several BEGIN blocks (which of course
 470 execute immediately) spread through the code. Why is that?
 471
 472 The debugger needs to be able to change some things and set some things up
 473 before the debugger code is compiled; most notably, the C<$deep> variable that
 474 C<DB::sub> uses to tell when a program has recursed deeply. In addition, the
 475 debugger has to turn off warnings while the debugger code is compiled, but then
 476 restore them to their original setting before the program being debugged begins
 477 executing.
 478
 479 The first C<BEGIN> block simply turns off warnings by saving the current
 480 setting of C<$^W> and then setting it to zero. The second one initializes
 481 the debugger variables that are needed before the debugger begins executing.
 482 The third one puts C<$^X> back to its former value.
 483
 484 We'll detail the second C<BEGIN> block later; just remember that if you need
 485 to initialize something before the debugger starts really executing, that's
 486 where it has to go.
 487
 488 =cut
 489
 490 package DB;
 491
 492 use IO::Handle;
 493
 494 # Debugger for Perl 5.00x; perl5db.pl patch level:
 495 $VERSION = 1.25;
 496
 497 $header  = "perl5db.pl version $VERSION";
 498
 499 =head1 DEBUGGER ROUTINES
 500
 501 =head2 C<DB::eval()>
 502
 503 This function replaces straight C<eval()> inside the debugger; it simplifies
 504 the process of evaluating code in the user's context.
 505
 506 The code to be evaluated is passed via the package global variable
 507 C<$DB::evalarg>; this is done to avoid fiddling with the contents of C<@_>.
 508
 509 We preserve the current settings of X<C<$trace>>, X<C<$single>>, and X<C<$^D>>;
 510 add the X<C<$usercontext>> (that's the preserved values of C<$@>, C<$!>,
 511 C<$^E>, C<$,>, C<$/>, C<$\>, and C<$^W>, grabbed when C<DB::DB> got control,
 512 and the user's current package) and a add a newline before we do the C<eval()>.
 513 This causes the proper context to be used when the eval is actually done.
 514 Afterward, we restore C<$trace>, C<$single>, and C<$^D>.
 515
 516 Next we need to handle C<$@> without getting confused. We save C<$@> in a
 517 local lexical, localize C<$saved[0]> (which is where C<save()> will put
 518 C<$@>), and then call C<save()> to capture C<$@>, C<$!>, C<$^E>, C<$,>,
 519 C<$/>, C<$\>, and C<$^W>) and set C<$,>, C<$/>, C<$\>, and C<$^W> to values
 520 considered sane by the debugger. If there was an C<eval()> error, we print
 521 it on the debugger's output. If X<C<$onetimedump>> is defined, we call
 522 X<C<dumpit>> if it's set to 'dump', or X<C<methods>> if it's set to
 523 'methods'. Setting it to something else causes the debugger to do the eval
 524 but not print the result - handy if you want to do something else with it
 525 (the "watch expressions" code does this to get the value of the watch
 526 expression but not show it unless it matters).
 527
 528 In any case, we then return the list of output from C<eval> to the caller,
 529 and unwinding restores the former version of C<$@> in C<@saved> as well
 530 (the localization of C<$saved[0]> goes away at the end of this scope).
 531
 532 =head3 Parameters and variables influencing execution of DB::eval()
 533
 534 C<DB::eval> isn't parameterized in the standard way; this is to keep the
 535 debugger's calls to C<DB::eval()> from mucking with C<@_>, among other things.
 536 The variables listed below influence C<DB::eval()>'s execution directly.
 537
 538 =over 4
 539
 540 =item C<$evalarg> - the thing to actually be eval'ed
 541
 542 =item C<$trace> - Current state of execution tracing (see X<$trace>)
 543
 544 =item C<$single> - Current state of single-stepping (see X<$single>)
 545
 546 =item C<$onetimeDump> - what is to be displayed after the evaluation
 547
 548 =item C<$onetimeDumpDepth> - how deep C<dumpit()> should go when dumping results
 549
 550 =back
 551
 552 The following variables are altered by C<DB::eval()> during its execution. They
 553 are "stacked" via C<local()>, enabling recursive calls to C<DB::eval()>.
 554
 555 =over 4
 556
 557 =item C<@res> - used to capture output from actual C<eval>.
 558
 559 =item C<$otrace> - saved value of C<$trace>.
 560
 561 =item C<$osingle> - saved value of C<$single>.
 562
 563 =item C<$od> - saved value of C<$^D>.
 564
 565 =item C<$saved[0]> - saved value of C<$@>.
 566
 567 =item $\ - for output of C<$@> if there is an evaluation error.
 568
 569 =back
 570
 571 =head3 The problem of lexicals
 572
 573 The context of C<DB::eval()> presents us with some problems. Obviously,
 574 we want to be 'sandboxed' away from the debugger's internals when we do
 575 the eval, but we need some way to control how punctuation variables and
 576 debugger globals are used.
 577
 578 We can't use local, because the code inside C<DB::eval> can see localized
 579 variables; and we can't use C<my> either for the same reason. The code
 580 in this routine compromises and uses C<my>.
 581
 582 After this routine is over, we don't have user code executing in the debugger's
 583 context, so we can use C<my> freely.
 584
 585 =cut
 586
 587 ############################################## Begin lexical danger zone
 588
 589 # 'my' variables used here could leak into (that is, be visible in)
 590 # the context that the code being evaluated is executing in. This means that
 591 # the code could modify the debugger's variables.
 592 #
 593 # Fiddling with the debugger's context could be Bad. We insulate things as
 594 # much as we can.
 595
 596 sub eval {
 597
 598     # 'my' would make it visible from user code
 599     #    but so does local! --tchrist
 600     # Remember: this localizes @DB::res, not @main::res.
 601     local @res;
 602     {
 603         # Try to keep the user code from messing  with us. Save these so that
 604         # even if the eval'ed code changes them, we can put them back again.
 605         # Needed because the user could refer directly to the debugger's
 606         # package globals (and any 'my' variables in this containing scope)
 607         # inside the eval(), and we want to try to stay safe.
 608         local $otrace  = $trace;
 609         local $osingle = $single;
 610         local $od      = $^D;
 611
 612         # Untaint the incoming eval() argument.
 613         { ($evalarg) = $evalarg =~ /(.*)/s; }
 614
 615         # $usercontext built in DB::DB near the comment
 616         # "set up the context for DB::eval ..."
 617         # Evaluate and save any results.
 618         @res =
 619           eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
 620
 621         # Restore those old values.
 622         $trace  = $otrace;
 623         $single = $osingle;
 624         $^D     = $od;
 625     }
 626
 627     # Save the current value of $@, and preserve it in the debugger's copy
 628     # of the saved precious globals.
 629     my $at = $@;
 630
 631     # Since we're only saving $@, we only have to localize the array element
 632     # that it will be stored in.
 633     local $saved[0];        # Preserve the old value of $@
 634     eval { &DB::save };
 635
 636     # Now see whether we need to report an error back to the user.
 637     if ($at) {
 638         local $\ = '';
 639         print $OUT $at;
 640     }
 641
 642     # Display as required by the caller. $onetimeDump and $onetimedumpDepth
 643     # are package globals.
 644     elsif ($onetimeDump) {
 645       if ($onetimeDump eq 'dump') {
 646         local $option{dumpDepth} = $onetimedumpDepth
 647           if defined $onetimedumpDepth;
 648         dumpit($OUT, \@res);
 649       }
 650       elsif ($onetimeDump eq 'methods') {
 651             methods($res[0]);
 652       }
 653     } ## end elsif ($onetimeDump)
 654     @res;
 655 } ## end sub eval
 656
 657 ############################################## End lexical danger zone
 658
 659 # After this point it is safe to introduce lexicals
 660 # The code being debugged will be executing in its own context, and
 661 # can't see the inside of the debugger.
 662 #
 663 # However, one should not overdo it: leave as much control from outside as
 664 # possible. If you make something a lexical, it's not going to be addressable
 665 # from outside the debugger even if you know its name.
 666
 667 # This file is automatically included if you do perl -d.
 668 # It's probably not useful to include this yourself.
 669 #
 670 # Before venturing further into these twisty passages, it is
 671 # wise to read the perldebguts man page or risk the ire of dragons.
 672 #
 673 # (It should be noted that perldebguts will tell you a lot about
 674 # the underlying mechanics of how the debugger interfaces into the
 675 # Perl interpreter, but not a lot about the debugger itself. The new
 676 # comments in this code try to address this problem.)
 677
 678 # Note that no subroutine call is possible until &DB::sub is defined
 679 # (for subroutines defined outside of the package DB). In fact the same is
 680 # true if $deep is not defined.
 681 #
 682 # $Log: perldb.pl,v $
 683
 684 # Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich)
 685
 686 # modified Perl debugger, to be run from Emacs in perldb-mode
 687 # Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990
 688 # Johan Vromans -- upgrade to 4.0 pl 10
 689 # Ilya Zakharevich -- patches after 5.001 (and some before ;-)
 690
 691 # (We have made efforts to  clarify the comments in the change log
 692 # in other places; some of them may seem somewhat obscure as they
 693 # were originally written, and explaining them away from the code
 694 # in question seems conterproductive.. -JM)
 695
 696 ########################################################################
 697 # Changes: 0.94
 698 #   + A lot of things changed after 0.94. First of all, core now informs
 699 #     debugger about entry into XSUBs, overloaded operators, tied operations,
 700 #     BEGIN and END. Handy with `O f=2'.
 701 #   + This can make debugger a little bit too verbose, please be patient
 702 #     and report your problems promptly.
 703 #   + Now the option frame has 3 values: 0,1,2. XXX Document!
 704 #   + Note that if DESTROY returns a reference to the object (or object),
 705 #     the deletion of data may be postponed until the next function call,
 706 #     due to the need to examine the return value.
 707 #
 708 # Changes: 0.95
 709 #   + `v' command shows versions.
 710 #
 711 # Changes: 0.96
 712 #   + `v' command shows version of readline.
 713 #     primitive completion works (dynamic variables, subs for `b' and `l',
 714 #     options). Can `p %var'
 715 #   + Better help (`h <' now works). New commands <<, >>, {, {{.
 716 #     {dump|print}_trace() coded (to be able to do it from <<cmd).
 717 #   + `c sub' documented.
 718 #   + At last enough magic combined to stop after the end of debuggee.
 719 #   + !! should work now (thanks to Emacs bracket matching an extra
 720 #     `]' in a regexp is caught).
 721 #   + `L', `D' and `A' span files now (as documented).
 722 #   + Breakpoints in `require'd code are possible (used in `R').
 723 #   +  Some additional words on internal work of debugger.
 724 #   + `b load filename' implemented.
 725 #   + `b postpone subr' implemented.
 726 #   + now only `q' exits debugger (overwritable on $inhibit_exit).
 727 #   + When restarting debugger breakpoints/actions persist.
 728 #   + Buglet: When restarting debugger only one breakpoint/action per
 729 #             autoloaded function persists.
 730 #
 731 # Changes: 0.97: NonStop will not stop in at_exit().
 732 #   + Option AutoTrace implemented.
 733 #   + Trace printed differently if frames are printed too.
 734 #   + new `inhibitExit' option.
 735 #   + printing of a very long statement interruptible.
 736 # Changes: 0.98: New command `m' for printing possible methods
 737 #   + 'l -' is a synonym for `-'.
 738 #   + Cosmetic bugs in printing stack trace.
 739 #   +  `frame' & 8 to print "expanded args" in stack trace.
 740 #   + Can list/break in imported subs.
 741 #   + new `maxTraceLen' option.
 742 #   + frame & 4 and frame & 8 granted.
 743 #   + new command `m'
 744 #   + nonstoppable lines do not have `:' near the line number.
 745 #   + `b compile subname' implemented.
 746 #   + Will not use $` any more.
 747 #   + `-' behaves sane now.
 748 # Changes: 0.99: Completion for `f', `m'.
 749 #   +  `m' will remove duplicate names instead of duplicate functions.
 750 #   + `b load' strips trailing whitespace.
 751 #     completion ignores leading `|'; takes into account current package
 752 #     when completing a subroutine name (same for `l').
 753 # Changes: 1.07: Many fixed by tchrist 13-March-2000
 754 #   BUG FIXES:
 755 #   + Added bare minimal security checks on perldb rc files, plus
 756 #     comments on what else is needed.
 757 #   + Fixed the ornaments that made "|h" completely unusable.
 758 #     They are not used in print_help if they will hurt.  Strip pod
 759 #     if we're paging to less.
 760 #   + Fixed mis-formatting of help messages caused by ornaments
 761 #     to restore Larry's original formatting.
 762 #   + Fixed many other formatting errors.  The code is still suboptimal,
 763 #     and needs a lot of work at restructuring.  It's also misindented
 764 #     in many places.
 765 #   + Fixed bug where trying to look at an option like your pager
 766 #     shows "1".
 767 #   + Fixed some $? processing.  Note: if you use csh or tcsh, you will
 768 #     lose.  You should consider shell escapes not using their shell,
 769 #     or else not caring about detailed status.  This should really be
 770 #     unified into one place, too.
 771 #   + Fixed bug where invisible trailing whitespace on commands hoses you,
 772 #     tricking Perl into thinking you weren't calling a debugger command!
 773 #   + Fixed bug where leading whitespace on commands hoses you.  (One
 774 #     suggests a leading semicolon or any other irrelevant non-whitespace
 775 #     to indicate literal Perl code.)
 776 #   + Fixed bugs that ate warnings due to wrong selected handle.
 777 #   + Fixed a precedence bug on signal stuff.
 778 #   + Fixed some unseemly wording.
 779 #   + Fixed bug in help command trying to call perl method code.
 780 #   + Fixed to call dumpvar from exception handler.  SIGPIPE killed us.
 781 #   ENHANCEMENTS:
 782 #   + Added some comments.  This code is still nasty spaghetti.
 783 #   + Added message if you clear your pre/post command stacks which was
 784 #     very easy to do if you just typed a bare >, <, or {.  (A command
 785 #     without an argument should *never* be a destructive action; this
 786 #     API is fundamentally screwed up; likewise option setting, which
 787 #     is equally buggered.)
 788 #   + Added command stack dump on argument of "?" for >, <, or {.
 789 #   + Added a semi-built-in doc viewer command that calls man with the
 790 #     proper %Config::Config path (and thus gets caching, man -k, etc),
 791 #     or else perldoc on obstreperous platforms.
 792 #   + Added to and rearranged the help information.
 793 #   + Detected apparent misuse of { ... } to declare a block; this used
 794 #     to work but now is a command, and mysteriously gave no complaint.
 795 #
 796 # Changes: 1.08: Apr 25, 2001  Jon Eveland <jweveland@yahoo.com>
 797 #   BUG FIX:
 798 #   + This patch to perl5db.pl cleans up formatting issues on the help
 799 #     summary (h h) screen in the debugger.  Mostly columnar alignment
 800 #     issues, plus converted the printed text to use all spaces, since
 801 #     tabs don't seem to help much here.
 802 #
 803 # Changes: 1.09: May 19, 2001  Ilya Zakharevich <ilya@math.ohio-state.edu>
 804 #   Minor bugs corrected;
 805 #   + Support for auto-creation of new TTY window on startup, either
 806 #     unconditionally, or if started as a kid of another debugger session;
 807 #   + New `O'ption CreateTTY
 808 #       I<CreateTTY>      bits control attempts to create a new TTY on events:
 809 #                         1: on fork()
 810 #                         2: debugger is started inside debugger
 811 #                         4: on startup
 812 #   + Code to auto-create a new TTY window on OS/2 (currently one
 813 #     extra window per session - need named pipes to have more...);
 814 #   + Simplified interface for custom createTTY functions (with a backward
 815 #     compatibility hack); now returns the TTY name to use; return of ''
 816 #     means that the function reset the I/O handles itself;
 817 #   + Better message on the semantic of custom createTTY function;
 818 #   + Convert the existing code to create a TTY into a custom createTTY
 819 #     function;
 820 #   + Consistent support for TTY names of the form "TTYin,TTYout";
 821 #   + Switch line-tracing output too to the created TTY window;
 822 #   + make `b fork' DWIM with CORE::GLOBAL::fork;
 823 #   + High-level debugger API cmd_*():
 824 #      cmd_b_load($filenamepart)            # b load filenamepart
 825 #      cmd_b_line($lineno [, $cond])        # b lineno [cond]
 826 #      cmd_b_sub($sub [, $cond])            # b sub [cond]
 827 #      cmd_stop()                           # Control-C
 828 #      cmd_d($lineno)                       # d lineno (B)
 829 #      The cmd_*() API returns FALSE on failure; in this case it outputs
 830 #      the error message to the debugging output.
 831 #   + Low-level debugger API
 832 #      break_on_load($filename)             # b load filename
 833 #      @files = report_break_on_load()      # List files with load-breakpoints
 834 #      breakable_line_in_filename($name, $from [, $to])
 835 #                                           # First breakable line in the
 836 #                                           # range $from .. $to.  $to defaults
 837 #                                           # to $from, and may be less than
 838 #                                           # $to
 839 #      breakable_line($from [, $to])        # Same for the current file
 840 #      break_on_filename_line($name, $lineno [, $cond])
 841 #                                           # Set breakpoint,$cond defaults to
 842 #                                           # 1
 843 #      break_on_filename_line_range($name, $from, $to [, $cond])
 844 #                                           # As above, on the first
 845 #                                           # breakable line in range
 846 #      break_on_line($lineno [, $cond])     # As above, in the current file
 847 #      break_subroutine($sub [, $cond])     # break on the first breakable line
 848 #      ($name, $from, $to) = subroutine_filename_lines($sub)
 849 #                                           # The range of lines of the text
 850 #      The low-level API returns TRUE on success, and die()s on failure.
 851 #
 852 # Changes: 1.10: May 23, 2001  Daniel Lewart <d-lewart@uiuc.edu>
 853 #   BUG FIXES:
 854 #   + Fixed warnings generated by "perl -dWe 42"
 855 #   + Corrected spelling errors
 856 #   + Squeezed Help (h) output into 80 columns
 857 #
 858 # Changes: 1.11: May 24, 2001  David Dyck <dcd@tc.fluke.com>
 859 #   + Made "x @INC" work like it used to
 860 #
 861 # Changes: 1.12: May 24, 2001  Daniel Lewart <d-lewart@uiuc.edu>
 862 #   + Fixed warnings generated by "O" (Show debugger options)
 863 #   + Fixed warnings generated by "p 42" (Print expression)
 864 # Changes: 1.13: Jun 19, 2001 Scott.L.Miller@compaq.com
 865 #   + Added windowSize option
 866 # Changes: 1.14: Oct  9, 2001 multiple
 867 #   + Clean up after itself on VMS (Charles Lane in 12385)
 868 #   + Adding "@ file" syntax (Peter Scott in 12014)
 869 #   + Debug reloading selfloaded stuff (Ilya Zakharevich in 11457)
 870 #   + $^S and other debugger fixes (Ilya Zakharevich in 11120)
 871 #   + Forgot a my() declaration (Ilya Zakharevich in 11085)
 872 # Changes: 1.15: Nov  6, 2001 Michael G Schwern <schwern@pobox.com>
 873 #   + Updated 1.14 change log
 874 #   + Added *dbline explainatory comments
 875 #   + Mentioning perldebguts man page
 876 # Changes: 1.16: Feb 15, 2002 Mark-Jason Dominus <mjd@plover.com>
 877 #   + $onetimeDump improvements
 878 # Changes: 1.17: Feb 20, 2002 Richard Foley <richard.foley@rfi.net>
 879 #   Moved some code to cmd_[.]()'s for clarity and ease of handling,
 880 #   rationalised the following commands and added cmd_wrapper() to
 881 #   enable switching between old and frighteningly consistent new
 882 #   behaviours for diehards: 'o CommandSet=pre580' (sigh...)
 883 #     a(add),       A(del)            # action expr   (added del by line)
 884 #   + b(add),       B(del)            # break  [line] (was b,D)
 885 #   + w(add),       W(del)            # watch  expr   (was W,W)
 886 #                                     # added del by expr
 887 #   + h(summary), h h(long)           # help (hh)     (was h h,h)
 888 #   + m(methods),   M(modules)        # ...           (was m,v)
 889 #   + o(option)                       # lc            (was O)
 890 #   + v(view code), V(view Variables) # ...           (was w,V)
 891 # Changes: 1.18: Mar 17, 2002 Richard Foley <richard.foley@rfi.net>
 892 #   + fixed missing cmd_O bug
 893 # Changes: 1.19: Mar 29, 2002 Spider Boardman
 894 #   + Added missing local()s -- DB::DB is called recursively.
 895 # Changes: 1.20: Feb 17, 2003 Richard Foley <richard.foley@rfi.net>
 896 #   + pre'n'post commands no longer trashed with no args
 897 #   + watch val joined out of eval()
 898 # Changes: 1.21: Jun 04, 2003 Joe McMahon <mcmahon@ibiblio.org>
 899 #   + Added comments and reformatted source. No bug fixes/enhancements.
 900 #   + Includes cleanup by Robin Barker and Jarkko Hietaniemi.
 901 # Changes: 1.22  Jun 09, 2003 Alex Vandiver <alexmv@MIT.EDU>
 902 #   + Flush stdout/stderr before the debugger prompt is printed.
 903 # Changes: 1.23: Dec 21, 2003 Dominique Quatravaux
 904 #   + Fix a side-effect of bug #24674 in the perl debugger ("odd taint bug")
 905 # Changes: 1.24: Mar 03, 2004 Richard Foley <richard.foley@rfi.net>
 906 #   + Added command to save all debugger commands for sourcing later.
 907 #   + Added command to display parent inheritence tree of given class.
 908 #   + Fixed minor newline in history bug.
 909 # Changes: 1.25 (again :)
 910 #   + unfork the 5.8.x and 5.9.x debuggers.
 911 #   + Richard Foley and Joe McMahon
 912 ####################################################################
 913
 914 =head1 DEBUGGER INITIALIZATION
 915
 916 The debugger starts up in phases.
 917
 918 =head2 BASIC SETUP
 919
 920 First, it initializes the environment it wants to run in: turning off
 921 warnings during its own compilation, defining variables which it will need
 922 to avoid warnings later, setting itself up to not exit when the program
 923 terminates, and defaulting to printing return values for the C<r> command.
 924
 925 =cut
 926
 927 # Needed for the statement after exec():
 928 #
 929 # This BEGIN block is simply used to switch off warnings during debugger
 930 # compiliation. Probably it would be better practice to fix the warnings,
 931 # but this is how it's done at the moment.
 932
 933
 934 BEGIN {
 935     $ini_warn = $^W;
 936     $^W = 0;
 937 }    # Switch compilation warnings off until another BEGIN.
 938
 939 # test if assertions are supported and actived:
 940 BEGIN {
 941     $ini_assertion=
 942     eval "sub asserting_test : assertion {1}; 1";
 943     # $ini_assertion = undef => assertions unsupported,
 944     #        "       = 1     => assertions suported
 945     # print "\$ini_assertion=$ini_assertion\n";
 946 }
 947
 948 local ($^W) = 0;    # Switch run-time warnings off during init.
 949
 950 # This would probably be better done with "use vars", but that wasn't around
 951 # when this code was originally written. (Neither was "use strict".) And on
 952 # the principle of not fiddling with something that was working, this was
 953 # left alone.
 954 warn(               # Do not ;-)
 955     # These variables control the execution of 'dumpvar.pl'.
 956     $dumpvar::hashDepth,
 957     $dumpvar::arrayDepth,
 958     $dumpvar::dumpDBFiles,
 959     $dumpvar::dumpPackages,
 960     $dumpvar::quoteHighBit,
 961     $dumpvar::printUndef,
 962     $dumpvar::globPrint,
 963     $dumpvar::usageOnly,
 964
 965     # used to save @ARGV and extract any debugger-related flags.
 966     @ARGS,
 967
 968     # used to control die() reporting in diesignal()
 969     $Carp::CarpLevel,
 970
 971     # used to prevent multiple entries to diesignal()
 972     # (if for instance diesignal() itself dies)
 973     $panic,
 974
 975     # used to prevent the debugger from running nonstop
 976     # after a restart
 977     $second_time,
 978   )
 979   if 0;
 980
 981 # Command-line + PERLLIB:
 982 # Save the contents of @INC before they are modified elsewhere.
 983 @ini_INC = @INC;
 984
 985 # This was an attempt to clear out the previous values of various
 986 # trapped errors. Apparently it didn't help. XXX More info needed!
 987 # $prevwarn = $prevdie = $prevbus = $prevsegv = ''; # Does not help?!
 988
 989 # We set these variables to safe values. We don't want to blindly turn
 990 # off warnings, because other packages may still want them.
 991 $trace = $signal = $single = 0;   # Uninitialized warning suppression
 992                                   # (local $^W cannot help - other packages!).
 993
 994 # Default to not exiting when program finishes; print the return
 995 # value when the 'r' command is used to return from a subroutine.
 996 $inhibit_exit = $option{PrintRet} = 1;
 997
 998 =head1 OPTION PROCESSING
 999
1000 The debugger's options are actually spread out over the debugger itself and
1001 C<dumpvar.pl>; some of these are variables to be set, while others are
1002 subs to be called with a value. To try to make this a little easier to
1003 manage, the debugger uses a few data structures to define what options
1004 are legal and how they are to be processed.
1005
1006 First, the C<@options> array defines the I<names> of all the options that
1007 are to be accepted.
1008
1009 =cut
1010
1011 @options = qw(
1012             CommandSet
1013             hashDepth    arrayDepth     dumpDepth
1014             DumpDBFiles  DumpPackages   DumpReused
1015             compactDump  veryCompact    quote
1016             HighBit      undefPrint     globPrint
1017             PrintRet     UsageOnl       frame
1018             AutoTrace    TTY            noTTY
1019             ReadLine     NonStop        LineInfo
1020             maxTraceLen  recallCommand  ShellBang
1021             pager        tkRunning      ornaments
1022             signalLevel  warnLevel      dieLevel
1023             inhibit_exit ImmediateStop  bareStringify
1024             CreateTTY    RemotePort     windowSize
1025             DollarCaretP OnlyAssertions WarnAssertions
1026         );
1027
1028 @RememberOnROptions = qw(DollarCaretP OnlyAssertions);
1029
1030 =pod
1031
1032 Second, C<optionVars> lists the variables that each option uses to save its
1033 state.
1034
1035 =cut
1036
1037 %optionVars = (
1038      hashDepth     => \$dumpvar::hashDepth,
1039      arrayDepth    => \$dumpvar::arrayDepth,
1040      CommandSet    => \$CommandSet,
1041      DumpDBFiles   => \$dumpvar::dumpDBFiles,
1042      DumpPackages  => \$dumpvar::dumpPackages,
1043      DumpReused    => \$dumpvar::dumpReused,
1044      HighBit       => \$dumpvar::quoteHighBit,
1045      undefPrint    => \$dumpvar::printUndef,
1046      globPrint     => \$dumpvar::globPrint,
1047      UsageOnly     => \$dumpvar::usageOnly,
1048      CreateTTY     => \$CreateTTY,
1049      bareStringify => \$dumpvar::bareStringify,
1050      frame         => \$frame,
1051      AutoTrace     => \$trace,
1052      inhibit_exit  => \$inhibit_exit,
1053      maxTraceLen   => \$maxtrace,
1054      ImmediateStop => \$ImmediateStop,
1055      RemotePort    => \$remoteport,
1056      windowSize    => \$window,
1057      WarnAssertions => \$warnassertions,
1058 );
1059
1060 =pod
1061
1062 Third, C<%optionAction> defines the subroutine to be called to process each
1063 option.
1064
1065 =cut
1066
1067 %optionAction = (
1068     compactDump   => \&dumpvar::compactDump,
1069     veryCompact   => \&dumpvar::veryCompact,
1070     quote         => \&dumpvar::quote,
1071     TTY           => \&TTY,
1072     noTTY         => \&noTTY,
1073     ReadLine      => \&ReadLine,
1074     NonStop       => \&NonStop,
1075     LineInfo      => \&LineInfo,
1076     recallCommand => \&recallCommand,
1077     ShellBang     => \&shellBang,
1078     pager         => \&pager,
1079     signalLevel   => \&signalLevel,
1080     warnLevel     => \&warnLevel,
1081     dieLevel      => \&dieLevel,
1082     tkRunning     => \&tkRunning,
1083     ornaments     => \&ornaments,
1084     RemotePort    => \&RemotePort,
1085     DollarCaretP  => \&DollarCaretP,
1086     OnlyAssertions=> \&OnlyAssertions,
1087 );
1088
1089 =pod
1090
1091 Last, the C<%optionRequire> notes modules that must be C<require>d if an
1092 option is used.
1093
1094 =cut
1095
1096 # Note that this list is not complete: several options not listed here
1097 # actually require that dumpvar.pl be loaded for them to work, but are
1098 # not in the table. A subsequent patch will correct this problem; for
1099 # the moment, we're just recommenting, and we are NOT going to change
1100 # function.
1101 %optionRequire = (
1102     compactDump => 'dumpvar.pl',
1103     veryCompact => 'dumpvar.pl',
1104     quote       => 'dumpvar.pl',
1105     );
1106
1107 =pod
1108
1109 There are a number of initialization-related variables which can be set
1110 by putting code to set them in a BEGIN block in the C<PERL5DB> environment
1111 variable. These are:
1112
1113 =over 4
1114
1115 =item C<$rl> - readline control XXX needs more explanation
1116
1117 =item C<$warnLevel> - whether or not debugger takes over warning handling
1118
1119 =item C<$dieLevel> - whether or not debugger takes over die handling
1120
1121 =item C<$signalLevel> - whether or not debugger takes over signal handling
1122
1123 =item C<$pre> - preprompt actions (array reference)
1124
1125 =item C<$post> - postprompt actions (array reference)
1126
1127 =item C<$pretype>
1128
1129 =item C<$CreateTTY> - whether or not to create a new TTY for this debugger
1130
1131 =item C<$CommandSet> - which command set to use (defaults to new, documented set)
1132
1133 =back
1134
1135 =cut
1136
1137 # These guys may be defined in $ENV{PERL5DB} :
1138 $rl          = 1     unless defined $rl;
1139 $warnLevel   = 1     unless defined $warnLevel;
1140 $dieLevel    = 1     unless defined $dieLevel;
1141 $signalLevel = 1     unless defined $signalLevel;
1142 $pre         = []    unless defined $pre;
1143 $post        = []    unless defined $post;
1144 $pretype     = []    unless defined $pretype;
1145 $CreateTTY   = 3     unless defined $CreateTTY;
1146 $CommandSet  = '580' unless defined $CommandSet;
1147
1148 =pod
1149
1150 The default C<die>, C<warn>, and C<signal> handlers are set up.
1151
1152 =cut
1153
1154 warnLevel($warnLevel);
1155 dieLevel($dieLevel);
1156 signalLevel($signalLevel);
1157
1158 =pod
1159
1160 The pager to be used is needed next. We try to get it from the
1161 environment first.  if it's not defined there, we try to find it in
1162 the Perl C<Config.pm>.  If it's not there, we default to C<more>. We
1163 then call the C<pager()> function to save the pager name.
1164
1165 =cut
1166
1167 # This routine makes sure $pager is set up so that '|' can use it.
1168 pager(
1169     # If PAGER is defined in the environment, use it.
1170     defined $ENV{PAGER}
1171       ? $ENV{PAGER}
1172
1173       # If not, see if Config.pm defines it.
1174       : eval { require Config } && defined $Config::Config{pager}
1175         ? $Config::Config{pager}
1176
1177       # If not, fall back to 'more'.
1178         : 'more'
1179      )
1180      unless defined $pager;
1181
1182 =pod
1183
1184 We set up the command to be used to access the man pages, the command
1185 recall character ("!" unless otherwise defined) and the shell escape
1186 character ("!" unless otherwise defined). Yes, these do conflict, and
1187 neither works in the debugger at the moment.
1188
1189 =cut
1190
1191 setman();
1192
1193 # Set up defaults for command recall and shell escape (note:
1194 # these currently don't work in linemode debugging).
1195 &recallCommand("!") unless defined $prc;
1196 &shellBang("!")     unless defined $psh;
1197
1198 =pod
1199
1200 We then set up the gigantic string containing the debugger help.
1201 We also set the limit on the number of arguments we'll display during a
1202 trace.
1203
1204 =cut
1205
1206 sethelp();
1207
1208 # If we didn't get a default for the length of eval/stack trace args,
1209 # set it here.
1210 $maxtrace = 400 unless defined $maxtrace;
1211
1212 =head2 SETTING UP THE DEBUGGER GREETING
1213
1214 The debugger 'greeting'  helps to inform the user how many debuggers are
1215 running, and whether the current debugger is the primary or a child.
1216
1217 If we are the primary, we just hang onto our pid so we'll have it when
1218 or if we start a child debugger. If we are a child, we'll set things up
1219 so we'll have a unique greeting and so the parent will give us our own
1220 TTY later.
1221
1222 We save the current contents of the C<PERLDB_PIDS> environment variable
1223 because we mess around with it. We'll also need to hang onto it because
1224 we'll need it if we restart.
1225
1226 Child debuggers make a label out of the current PID structure recorded in
1227 PERLDB_PIDS plus the new PID. They also mark themselves as not having a TTY
1228 yet so the parent will give them one later via C<resetterm()>.
1229
1230 =cut
1231
1232 # Save the current contents of the environment; we're about to
1233 # much with it. We'll need this if we have to restart.
1234 $ini_pids = $ENV{PERLDB_PIDS};
1235
1236 if (defined $ENV{PERLDB_PIDS}) {
1237     # We're a child. Make us a label out of the current PID structure
1238     # recorded in PERLDB_PIDS plus our (new) PID. Mark us as not having
1239     # a term yet so the parent will give us one later via resetterm().
1240   $pids = "[$ENV{PERLDB_PIDS}]";
1241   $ENV{PERLDB_PIDS} .= "->$$";
1242   $term_pid = -1;
1243 } ## end if (defined $ENV{PERLDB_PIDS...
1244 else {
1245     # We're the parent PID. Initialize PERLDB_PID in case we end up with a
1246     # child debugger, and mark us as the parent, so we'll know to set up
1247     # more TTY's is we have to.
1248     $ENV{PERLDB_PIDS} = "$$";
1249     $pids     = "{pid=$$}";
1250     $term_pid = $$;
1251 }
1252
1253 $pidprompt = '';
1254
1255 # Sets up $emacs as a synonym for $slave_editor.
1256 *emacs = $slave_editor if $slave_editor;    # May be used in afterinit()...
1257
1258 =head2 READING THE RC FILE
1259
1260 The debugger will read a file of initialization options if supplied. If
1261 running interactively, this is C<.perldb>; if not, it's C<perldb.ini>.
1262
1263 =cut
1264
1265 # As noted, this test really doesn't check accurately that the debugger
1266 # is running at a terminal or not.
1267
1268 if (-e "/dev/tty") {  # this is the wrong metric!
1269   $rcfile=".perldb";
1270 }
1271 else {
1272     $rcfile = "perldb.ini";
1273 }
1274
1275 =pod
1276
1277 The debugger does a safety test of the file to be read. It must be owned
1278 either by the current user or root, and must only be writable by the owner.
1279
1280 =cut
1281
1282 # This wraps a safety test around "do" to read and evaluate the init file.
1283 #
1284 # This isn't really safe, because there's a race
1285 # between checking and opening.  The solution is to
1286 # open and fstat the handle, but then you have to read and
1287 # eval the contents.  But then the silly thing gets
1288 # your lexical scope, which is unfortunate at best.
1289 sub safe_do {
1290     my $file = shift;
1291
1292     # Just exactly what part of the word "CORE::" don't you understand?
1293     local $SIG{__WARN__};
1294     local $SIG{__DIE__};
1295
1296     unless (is_safe_file($file)) {
1297         CORE::warn <<EO_GRIPE;
1298 perldb: Must not source insecure rcfile $file.
1299         You or the superuser must be the owner, and it must not
1300         be writable by anyone but its owner.
1301 EO_GRIPE
1302         return;
1303     } ## end unless (is_safe_file($file...
1304
1305     do $file;
1306     CORE::warn("perldb: couldn't parse $file: $@") if $@;
1307 } ## end sub safe_do
1308
1309 # This is the safety test itself.
1310 #
1311 # Verifies that owner is either real user or superuser and that no
1312 # one but owner may write to it.  This function is of limited use
1313 # when called on a path instead of upon a handle, because there are
1314 # no guarantees that filename (by dirent) whose file (by ino) is
1315 # eventually accessed is the same as the one tested.
1316 # Assumes that the file's existence is not in doubt.
1317 sub is_safe_file {
1318     my $path = shift;
1319     stat($path) || return;    # mysteriously vaporized
1320     my ($dev, $ino, $mode, $nlink, $uid, $gid) = stat(_);
1321
1322     return 0 if $uid != 0 && $uid != $<;
1323     return 0 if $mode & 022;
1324     return 1;
1325 } ## end sub is_safe_file
1326
1327 # If the rcfile (whichever one we decided was the right one to read)
1328 # exists, we safely do it.
1329 if (-f $rcfile) {
1330     safe_do("./$rcfile");
1331 }
1332 # If there isn't one here, try the user's home directory.
1333 elsif (defined $ENV{HOME} && -f "$ENV{HOME}/$rcfile") {
1334     safe_do("$ENV{HOME}/$rcfile");
1335 }
1336 # Else try the login directory.
1337 elsif (defined $ENV{LOGDIR} && -f "$ENV{LOGDIR}/$rcfile") {
1338     safe_do("$ENV{LOGDIR}/$rcfile");
1339 }
1340
1341 # If the PERLDB_OPTS variable has options in it, parse those out next.
1342 if (defined $ENV{PERLDB_OPTS}) {
1343     parse_options($ENV{PERLDB_OPTS});
1344 }
1345
1346 =pod
1347
1348 The last thing we do during initialization is determine which subroutine is
1349 to be used to obtain a new terminal when a new debugger is started. Right now,
1350 the debugger only handles X Windows and OS/2.
1351
1352 =cut
1353
1354 # Set up the get_fork_TTY subroutine to be aliased to the proper routine.
1355 # Works if you're running an xterm or xterm-like window, or you're on
1356 # OS/2. This may need some expansion: for instance, this doesn't handle
1357 # OS X Terminal windows.
1358
1359
1360 if (not defined &get_fork_TTY
1361     and defined $ENV{TERM}
1362
1363     and $ENV{TERM} eq 'xterm'
1364     and defined $ENV{WINDOWID}
1365
1366     and defined $ENV{DISPLAY})
1367 {
1368     *get_fork_TTY = \&xterm_get_fork_TTY;
1369 } ## end if (not defined &get_fork_TTY...
1370 elsif ($^O eq 'os2') {
1371     *get_fork_TTY = \&os2_get_fork_TTY;
1372 }
1373 # untaint $^O, which may have been tainted by the last statement.
1374 # see bug [perl #24674]
1375 $^O =~ m/^(.*)\z/; $^O = $1;
1376
1377 # Here begin the unreadable code.  It needs fixing.
1378
1379 =head2 RESTART PROCESSING
1380
1381 This section handles the restart command. When the C<R> command is invoked, it
1382 tries to capture all of the state it can into environment variables, and
1383 then sets C<PERLDB_RESTART>. When we start executing again, we check to see
1384 if C<PERLDB_RESTART> is there; if so, we reload all the information that
1385 the R command stuffed into the environment variables.
1386
1387   PERLDB_RESTART   - flag only, contains no restart data itself.
1388   PERLDB_HIST      - command history, if it's available
1389   PERLDB_ON_LOAD   - breakpoints set by the rc file
1390   PERLDB_POSTPONE  - subs that have been loaded/not executed, and have actions
1391   PERLDB_VISITED   - files that had breakpoints
1392   PERLDB_FILE_...  - breakpoints for a file
1393   PERLDB_OPT       - active options
1394   PERLDB_INC       - the original @INC
1395   PERLDB_PRETYPE   - preprompt debugger actions
1396   PERLDB_PRE       - preprompt Perl code
1397   PERLDB_POST      - post-prompt Perl code
1398   PERLDB_TYPEAHEAD - typeahead captured by readline()
1399
1400 We chug through all these variables and plug the values saved in them
1401 back into the appropriate spots in the debugger.
1402
1403 =cut
1404
1405 if (exists $ENV{PERLDB_RESTART}) {
1406     # We're restarting, so we don't need the flag that says to restart anymore.
1407   delete $ENV{PERLDB_RESTART};
1408   # $restart = 1;
1409   @hist          = get_list('PERLDB_HIST');
1410   %break_on_load = get_list("PERLDB_ON_LOAD");
1411   %postponed     = get_list("PERLDB_POSTPONE");
1412
1413     # restore breakpoints/actions
1414   my @had_breakpoints = get_list("PERLDB_VISITED");
1415   for (0 .. $#had_breakpoints) {
1416     my %pf = get_list("PERLDB_FILE_$_");
1417     $postponed_file{ $had_breakpoints[$_] } = \%pf if %pf;
1418   }
1419
1420     # restore options
1421   my %opt = get_list("PERLDB_OPT");
1422   my ($opt, $val);
1423   while (($opt, $val) = each %opt) {
1424     $val =~ s/[\\\']/\\$1/g;
1425     parse_options("$opt'$val'");
1426   }
1427
1428     # restore original @INC
1429   @INC     = get_list("PERLDB_INC");
1430   @ini_INC = @INC;
1431
1432   # return pre/postprompt actions and typeahead buffer
1433   $pretype = [get_list("PERLDB_PRETYPE")];
1434   $pre     = [get_list("PERLDB_PRE")];
1435   $post    = [get_list("PERLDB_POST")];
1436   @typeahead = get_list("PERLDB_TYPEAHEAD", @typeahead);
1437 } ## end if (exists $ENV{PERLDB_RESTART...
1438
1439 =head2 SETTING UP THE TERMINAL
1440
1441 Now, we'll decide how the debugger is going to interact with the user.
1442 If there's no TTY, we set the debugger to run non-stop; there's not going
1443 to be anyone there to enter commands.
1444
1445 =cut
1446
1447 if ($notty) {
1448     $runnonstop = 1;
1449 }
1450
1451 =pod
1452
1453 If there is a TTY, we have to determine who it belongs to before we can
1454 proceed. If this is a slave editor or graphical debugger (denoted by
1455 the first command-line switch being '-emacs'), we shift this off and
1456 set C<$rl> to 0 (XXX ostensibly to do straight reads).
1457
1458 =cut
1459
1460 else {
1461     # Is Perl being run from a slave editor or graphical debugger?
1462     # If so, don't use readline, and set $slave_editor = 1.
1463   $slave_editor =
1464       ((defined $main::ARGV[0]) and ($main::ARGV[0] eq '-emacs'));
1465   $rl = 0, shift (@main::ARGV) if $slave_editor;
1466   #require Term::ReadLine;
1467
1468 =pod
1469
1470 We then determine what the console should be on various systems:
1471
1472 =over 4
1473
1474 =item * Cygwin - We use C<stdin> instead of a separate device.
1475
1476 =cut
1477
1478       if ($^O eq 'cygwin') {
1479         # /dev/tty is binary. use stdin for textmode
1480         undef $console;
1481     }
1482
1483 =item * Unix - use C</dev/tty>.
1484
1485 =cut
1486
1487     elsif (-e "/dev/tty") {
1488         $console = "/dev/tty";
1489     }
1490
1491 =item * Windows or MSDOS - use C<con>.
1492
1493 =cut
1494
1495     elsif ($^O eq 'dos' or -e "con" or $^O eq 'MSWin32') {
1496         $console = "con";
1497     }
1498
1499 =item * MacOS - use C<Dev:Console:Perl Debug> if this is the MPW version; C<Dev:
1500 Console> if not. (Note that Mac OS X returns 'darwin', not 'MacOS'. Also note that the debugger doesn't do anything special for 'darwin'. Maybe it should.)
1501
1502 =cut
1503
1504     elsif ($^O eq 'MacOS') {
1505         if ($MacPerl::Version !~ /MPW/) {
1506           $console =
1507             "Dev:Console:Perl Debug";    # Separate window for application
1508         }
1509         else {
1510             $console = "Dev:Console";
1511         }
1512     } ## end elsif ($^O eq 'MacOS')
1513
1514 =item * VMS - use C<sys$command>.
1515
1516 =cut
1517
1518     else {
1519         # everything else is ...
1520         $console = "sys\$command";
1521     }
1522
1523 =pod
1524
1525 =back
1526
1527 Several other systems don't use a specific console. We C<undef $console>
1528 for those (Windows using a slave editor/graphical debugger, NetWare, OS/2
1529 with a slave editor, Epoc).
1530
1531 =cut
1532
1533   if (($^O eq 'MSWin32') and ($slave_editor or defined $ENV{EMACS})) {
1534         # /dev/tty is binary. use stdin for textmode
1535     $console = undef;
1536   }
1537
1538     if ($^O eq 'NetWare') {
1539         # /dev/tty is binary. use stdin for textmode
1540         $console = undef;
1541     }
1542
1543     # In OS/2, we need to use STDIN to get textmode too, even though
1544     # it pretty much looks like Unix otherwise.
1545   if (defined $ENV{OS2_SHELL} and ($slave_editor or $ENV{WINDOWID}))
1546   { # In OS/2
1547     $console = undef;
1548   }
1549   # EPOC also falls into the 'got to use STDIN' camp.
1550   if ($^O eq 'epoc') {
1551     $console = undef;
1552   }
1553
1554 =pod
1555
1556 If there is a TTY hanging around from a parent, we use that as the console.
1557
1558 =cut
1559
1560   $console = $tty if defined $tty;
1561
1562 =head2 SOCKET HANDLING
1563
1564 The debugger is capable of opening a socket and carrying out a debugging
1565 session over the socket.
1566
1567 If C<RemotePort> was defined in the options, the debugger assumes that it
1568 should try to start a debugging session on that port. It builds the socket
1569 and then tries to connect the input and output filehandles to it.
1570
1571 =cut
1572
1573     # Handle socket stuff.
1574
1575   if (defined $remoteport) {
1576         # If RemotePort was defined in the options, connect input and output
1577         # to the socket.
1578     require IO::Socket;
1579     $OUT = new IO::Socket::INET(
1580         Timeout  => '10',
1581         PeerAddr => $remoteport,
1582         Proto    => 'tcp',
1583         );
1584     if (!$OUT) { die "Unable to connect to remote host: $remoteport\n"; }
1585     $IN = $OUT;
1586     } ## end if (defined $remoteport)
1587
1588 =pod
1589
1590 If no C<RemotePort> was defined, and we want to create a TTY on startup,
1591 this is probably a situation where multiple debuggers are running (for example,
1592 a backticked command that starts up another debugger). We create a new IN and
1593 OUT filehandle, and do the necessary mojo to create a new TTY if we know how
1594 and if we can.
1595
1596 =cut
1597
1598     # Non-socket.
1599     else {
1600         # Two debuggers running (probably a system or a backtick that invokes
1601         # the debugger itself under the running one). create a new IN and OUT
1602         # filehandle, and do the necessary mojo to create a new tty if we
1603         # know how, and we can.
1604     create_IN_OUT(4) if $CreateTTY & 4;
1605     if ($console) {
1606             # If we have a console, check to see if there are separate ins and
1607             # outs to open. (They are assumed identiical if not.)
1608
1609
1610
1611       my ($i, $o) = split /,/, $console;
1612       $o = $i unless defined $o;
1613             # read/write on in, or just read, or read on STDIN.
1614       open(IN,"+<$i") ||
1615        open(IN,"<$i") ||
1616         open(IN,"<&STDIN");
1617             # read/write/create/clobber out, or write/create/clobber out,
1618             # or merge with STDERR, or merge with STDOUT.
1619       open(OUT,   "+>$o")     ||
1620         open(OUT, ">$o")      ||
1621         open(OUT, ">&STDERR") ||
1622         open(OUT, ">&STDOUT");    # so we don't dongle stdout
1623
1624      } ## end if ($console)
1625     elsif (not defined $console) {
1626            # No console. Open STDIN.
1627             open(IN,    "<&STDIN");
1628
1629            # merge with STDERR, or with STDOUT.
1630             open(OUT,   ">&STDERR") ||
1631               open(OUT, ">&STDOUT"); # so we don't dongle stdout
1632       $console = 'STDIN/OUT';
1633         } ## end elsif (not defined $console)
1634
1635         # Keep copies of the filehandles so that when the pager runs, it
1636         # can close standard input without clobbering ours.
1637     $IN = \*IN, $OUT = \*OUT if $console or not defined $console;
1638   } ## end elsif (from if(defined $remoteport))
1639
1640     # Unbuffer DB::OUT. We need to see responses right away.
1641   my $previous = select($OUT);
1642   $| = 1;            # for DB::OUT
1643   select($previous);
1644
1645   # Line info goes to debugger output unless pointed elsewhere.
1646   # Pointing elsewhere makes it possible for slave editors to
1647   # keep track of file and position. We have both a filehandle
1648   # and a I/O description to keep track of.
1649   $LINEINFO = $OUT unless defined $LINEINFO;
1650   $lineinfo = $console unless defined $lineinfo;
1651 =pod
1652
1653 To finish initialization, we show the debugger greeting,
1654 and then call the C<afterinit()> subroutine if there is one.
1655
1656 =cut
1657
1658   # Show the debugger greeting.
1659   $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
1660   unless ($runnonstop) {
1661     local $\ = '';
1662     local $, = '';
1663     if ($term_pid eq '-1') {
1664       print $OUT "\nDaughter DB session started...\n";
1665     }
1666     else {
1667       print $OUT "\nLoading DB routines from $header\n";
1668       print $OUT (
1669         "Editor support ",
1670           $slave_editor ? "enabled" : "available", ".\n"
1671         );
1672       print $OUT
1673 "\nEnter h or `h h' for help, or `$doccmd perldebug' for more help.\n\n";
1674         } ## end else [ if ($term_pid eq '-1')
1675     } ## end unless ($runnonstop)
1676 } ## end else [ if ($notty)
1677
1678 # XXX This looks like a bug to me.
1679 # Why copy to @ARGS and then futz with @args?
1680 @ARGS = @ARGV;
1681 for (@args) {
1682     # Make sure backslashes before single quotes are stripped out, and
1683     # keep args unless they are numeric (XXX why?)
1684     s/\'/\\\'/g;
1685     s/(.*)/'$1'/ unless /^-?[\d.]+$/;
1686 }
1687
1688 # If there was an afterinit() sub defined, call it. It will get
1689 # executed in our scope, so it can fiddle with debugger globals.
1690 if (defined &afterinit) {    # May be defined in $rcfile
1691     &afterinit();
1692 }
1693 # Inform us about "Stack dump during die enabled ..." in dieLevel().
1694 $I_m_init = 1;
1695
1696 ############################################################ Subroutines
1697
1698 =head1 SUBROUTINES
1699
1700 =head2 DB
1701
1702 This gigantic subroutine is the heart of the debugger. Called before every
1703 statement, its job is to determine if a breakpoint has been reached, and
1704 stop if so; read commands from the user, parse them, and execute
1705 them, and hen send execution off to the next statement.
1706
1707 Note that the order in which the commands are processed is very important;
1708 some commands earlier in the loop will actually alter the C<$cmd> variable
1709 to create other commands to be executed later. This is all highly "optimized"
1710 but can be confusing. Check the comments for each C<$cmd ... && do {}> to
1711 see what's happening in any given command.
1712
1713 =cut
1714
1715 sub DB {
1716
1717     # Check for whether we should be running continuously or not.
1718     # _After_ the perl program is compiled, $single is set to 1:
1719     if ($single and not $second_time++) {
1720         # Options say run non-stop. Run until we get an interrupt.
1721       if ($runnonstop) {    # Disable until signal
1722             # If there's any call stack in place, turn off single
1723             # stepping into subs throughout the stack.
1724     for ($i = 0 ; $i <= $stack_depth ;) {
1725         $stack[$i++] &= ~1;
1726     }
1727             # And we are now no longer in single-step mode.
1728     $single = 0;
1729
1730             # If we simply returned at this point, we wouldn't get
1731             # the trace info. Fall on through.
1732             # return;
1733         } ## end if ($runnonstop)
1734
1735     elsif ($ImmediateStop) {
1736             # We are supposed to stop here; XXX probably a break.
1737             $ImmediateStop = 0;               # We've processed it; turn it off
1738             $signal        = 1;               # Simulate an interrupt to force
1739                                               # us into the command loop
1740         }
1741     } ## end if ($single and not $second_time...
1742
1743     # If we're in single-step mode, or an interrupt (real or fake)
1744     # has occurred, turn off non-stop mode.
1745     $runnonstop = 0 if $single or $signal;
1746
1747     # Preserve current values of $@, $!, $^E, $,, $/, $\, $^W.
1748     # The code being debugged may have altered them.
1749     &save;
1750
1751     # Since DB::DB gets called after every line, we can use caller() to
1752     # figure out where we last were executing. Sneaky, eh? This works because
1753     # caller is returning all the extra information when called from the
1754     # debugger.
1755     local($package, $filename, $line) = caller;
1756     local $filename_ini = $filename;
1757
1758     # set up the context for DB::eval, so it can properly execute
1759     # code on behalf of the user. We add the package in so that the
1760     # code is eval'ed in the proper package (not in the debugger!).
1761     local $usercontext =
1762       '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
1763       "package $package;";
1764
1765     # Create an alias to the active file magical array to simplify
1766     # the code here.
1767     local(*dbline) = $main::{'_<' . $filename};
1768
1769     # we need to check for pseudofiles on Mac OS (these are files
1770     # not attached to a filename, but instead stored in Dev:Pseudo)
1771     if ($^O eq 'MacOS' && $#dbline < 0) {
1772     $filename_ini = $filename = 'Dev:Pseudo';
1773     *dbline = $main::{'_<' . $filename};
1774     }
1775
1776     # Last line in the program.
1777     local $max = $#dbline;
1778
1779     # if we have something here, see if we should break.
1780     if ($dbline{$line} && (($stop,$action) = split(/\0/,$dbline{$line}))) {
1781         # Stop if the stop criterion says to just stop.
1782         if ($stop eq '1') {
1783             $signal |= 1;
1784         }
1785         # It's a conditional stop; eval it in the user's context and
1786         # see if we should stop. If so, remove the one-time sigil.
1787         elsif ($stop) {
1788             $evalarg = "\$DB::signal |= 1 if do {$stop}";
1789             &eval;
1790             $dbline{$line} =~ s/;9($|\0)/$1/;
1791         }
1792     } ## end if ($dbline{$line} && ...
1793
1794     # Preserve the current stop-or-not, and see if any of the W
1795     # (watch expressions) has changed.
1796     my $was_signal = $signal;
1797
1798     # If we have any watch expressions ...
1799     if ($trace & 2) {
1800       for (my $n = 0; $n <= $#to_watch; $n++) {
1801         $evalarg = $to_watch[$n];
1802         local $onetimeDump;    # Do not output results
1803
1804             # Fix context DB::eval() wants to return an array, but
1805             # we need a scalar here.
1806         my ($val) =
1807           join("', '", &eval);    # Fix context (&eval is doing array)
1808         $val = ( (defined $val) ? "'$val'" : 'undef' );
1809
1810             # Did it change?
1811         if ($val ne $old_watch[$n]) {
1812                 # Yep! Show the difference, and fake an interrupt.
1813           $signal = 1;
1814           print $OUT <<EOP;
1815 Watchpoint $n:\t$to_watch[$n] changed:
1816     old value:\t$old_watch[$n]
1817     new value:\t$val
1818 EOP
1819           $old_watch[$n] = $val;
1820             } ## end if ($val ne $old_watch...
1821         } ## end for (my $n = 0 ; $n <= ...
1822     } ## end if ($trace & 2)
1823
1824 =head2 C<watchfunction()>
1825
1826 C<watchfunction()> is a function that can be defined by the user; it is a
1827 function which will be run on each entry to C<DB::DB>; it gets the
1828 current package, filename, and line as its parameters.
1829
1830 The watchfunction can do anything it likes; it is executing in the
1831 debugger's context, so it has access to all of the debugger's internal
1832 data structures and functions.
1833
1834 C<watchfunction()> can control the debugger's actions. Any of the following
1835 will cause the debugger to return control to the user's program after
1836 C<watchfunction()> executes:
1837
1838 =over 4
1839
1840 =item * Returning a false value from the C<watchfunction()> itself.
1841
1842 =item * Altering C<$single> to a false value.
1843
1844 =item * Altering C<$signal> to a false value.
1845
1846 =item *  Turning off the '4' bit in C<$trace> (this also disables the
1847 check for C<watchfunction()>. This can be done with
1848
1849     $trace &= ~4;
1850
1851 =back
1852
1853 =cut
1854
1855     # If there's a user-defined DB::watchfunction, call it with the
1856     # current package, filename, and line. The function executes in
1857     # the DB:: package.
1858     if ($trace & 4) {    # User-installed watch
1859       return
1860         if watchfunction($package, $filename, $line)
1861         and not $single
1862         and not $was_signal
1863         and not ($trace & ~4);
1864     } ## end if ($trace & 4)
1865
1866     # Pick up any alteration to $signal in the watchfunction, and
1867     # turn off the signal now.
1868     $was_signal = $signal;
1869     $signal     = 0;
1870
1871 =head2 GETTING READY TO EXECUTE COMMANDS
1872
1873 The debugger decides to take control if single-step mode is on, the
1874 C<t> command was entered, or the user generated a signal. If the program
1875 has fallen off the end, we set things up so that entering further commands
1876 won't cause trouble, and we say that the program is over.
1877
1878 =cut
1879
1880     # Check to see if we should grab control ($single true,
1881     # trace set appropriately, or we got a signal).
1882     if ($single || ($trace & 1) || $was_signal) {
1883         # Yes, grab control.
1884     if ($slave_editor) {
1885             # Tell the editor to update its position.
1886         $position = "\032\032$filename:$line:0\n";
1887         print_lineinfo($position);
1888     }
1889
1890 =pod
1891
1892 Special check: if we're in package C<DB::fake>, we've gone through the
1893 C<END> block at least once. We set up everything so that we can continue
1894 to enter commands and have a valid context to be in.
1895
1896 =cut
1897
1898
1899     elsif ($package eq 'DB::fake') {
1900             # Fallen off the end already.
1901       $term || &setterm;
1902       print_help(<<EOP);
1903 Debugged program terminated.  Use B<q> to quit or B<R> to restart,
1904   use B<O> I<inhibit_exit> to avoid stopping after program termination,
1905   B<h q>, B<h R> or B<h O> to get additional info.
1906 EOP
1907             # Set the DB::eval context appropriately.
1908       $package     = 'main';
1909       $usercontext =
1910         '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
1911         "package $package;";    # this won't let them modify, alas
1912         } ## end elsif ($package eq 'DB::fake')
1913
1914 =pod
1915
1916 If the program hasn't finished executing, we scan forward to the
1917 next executable line, print that out, build the prompt from the file and line
1918 number information, and print that.
1919
1920 =cut
1921
1922     else {
1923             # Still somewhere in the midst of execution. Set up the
1924             #  debugger prompt.
1925             $sub =~ s/\'/::/;    # Swap Perl 4 package separators (') to
1926                                  # Perl 5 ones (sorry, we don't print Klingon
1927                                  #module names)
1928
1929         $prefix = $sub =~ /::/ ? "" : "${'package'}::";
1930         $prefix .= "$sub($filename:";
1931         $after = ($dbline[$line] =~ /\n$/ ? '' : "\n");
1932
1933             # Break up the prompt if it's really long.
1934         if (length($prefix) > 30) {
1935             $position = "$prefix$line):\n$line:\t$dbline[$line]$after";
1936             $prefix   = "";
1937             $infix    = ":\t";
1938         }
1939         else {
1940             $infix    = "):\t";
1941             $position = "$prefix$line$infix$dbline[$line]$after";
1942         }
1943
1944             # Print current line info, indenting if necessary.
1945         if ($frame) {
1946             print_lineinfo(' ' x $stack_depth, "$line:\t$dbline[$line]$after");
1947         }
1948         else {
1949             print_lineinfo($position);
1950         }
1951
1952
1953             # Scan forward, stopping at either the end or the next
1954             # unbreakable line.
1955         for ($i = $line + 1 ; $i <= $max && $dbline[$i] == 0; ++$i)
1956         { #{ vi
1957
1958                 # Drop out on null statements, block closers, and comments.
1959                 last if $dbline[$i] =~ /^\s*[\;\}\#\n]/;
1960
1961                 # Drop out if the user interrupted us.
1962                 last if $signal;
1963
1964                 # Append a newline if the line doesn't have one. Can happen
1965                 # in eval'ed text, for instance.
1966                 $after = ($dbline[$i] =~ /\n$/ ? '' : "\n");
1967
1968                 # Next executable line.
1969                 $incr_pos = "$prefix$i$infix$dbline[$i]$after";
1970                 $position .= $incr_pos;
1971                 if ($frame) {
1972                     # Print it indented if tracing is on.
1973                     print_lineinfo(' ' x $stack_depth,
1974                         "$i:\t$dbline[$i]$after");
1975                 }
1976                 else {
1977                     print_lineinfo($incr_pos);
1978                 }
1979             } ## end for ($i = $line + 1 ; $i...
1980         } ## end else [ if ($slave_editor)
1981     } ## end if ($single || ($trace...
1982
1983 =pod
1984
1985 If there's an action to be executed for the line we stopped at, execute it.
1986 If there are any preprompt actions, execute those as well.
1987
1988 =cut
1989
1990     # If there's an action, do it now.
1991     $evalarg = $action, &eval if $action;
1992
1993     # Are we nested another level (e.g., did we evaluate a function
1994     # that had a breakpoint in it at the debugger prompt)?
1995     if ($single || $was_signal) {
1996         # Yes, go down a level.
1997       local $level = $level + 1;
1998
1999         # Do any pre-prompt actions.
2000       foreach $evalarg (@$pre) {
2001         &eval;
2002       }
2003
2004         # Complain about too much recursion if we passed the limit.
2005       print $OUT $stack_depth . " levels deep in subroutine calls!\n"
2006           if $single & 4;
2007
2008         # The line we're currently on. Set $incr to -1 to stay here
2009         # until we get a command that tells us to advance.
2010         $start     = $line;
2011         $incr      = -1;        # for backward motion.
2012
2013         # Tack preprompt debugger actions ahead of any actual input.
2014         @typeahead = (@$pretype, @typeahead);
2015
2016 =head2 WHERE ARE WE?
2017
2018 XXX Relocate this section?
2019
2020 The debugger normally shows the line corresponding to the current line of
2021 execution. Sometimes, though, we want to see the next line, or to move elsewhere
2022 in the file. This is done via the C<$incr>, C<$start>, and C<$max> variables.
2023
2024 C<$incr> controls by how many lines the "current" line should move forward
2025 after a command is executed. If set to -1, this indicates that the "current"
2026 line shouldn't change.
2027
2028 C<$start> is the "current" line. It is used for things like knowing where to
2029 move forwards or backwards from when doing an C<L> or C<-> command.
2030
2031 C<$max> tells the debugger where the last line of the current file is. It's
2032 used to terminate loops most often.
2033
2034 =head2 THE COMMAND LOOP
2035
2036 Most of C<DB::DB> is actually a command parsing and dispatch loop. It comes
2037 in two parts:
2038
2039 =over 4
2040
2041 =item * The outer part of the loop, starting at the C<CMD> label. This loop
2042 reads a command and then executes it.
2043
2044 =item * The inner part of the loop, starting at the C<PIPE> label. This part
2045 is wholly contained inside the C<CMD> block and only executes a command.
2046 Used to handle commands running inside a pager.
2047
2048 =back
2049
2050 So why have two labels to restart the loop? Because sometimes, it's easier to
2051 have a command I<generate> another command and then re-execute the loop to do
2052 the new command. This is faster, but perhaps a bit more convoluted.
2053
2054 =cut
2055
2056         # The big command dispatch loop. It keeps running until the
2057         # user yields up control again.
2058         #
2059         # If we have a terminal for input, and we get something back
2060         # from readline(), keep on processing.
2061     CMD:
2062     while (
2063             # We have a terminal, or can get one ...
2064             ($term || &setterm),
2065             # ... and it belogs to this PID or we get one for this PID ...
2066            ($term_pid == $$ or resetterm(1)),
2067            defined (
2068             # ... and we got a line of command input ...
2069                 $cmd=&readline(
2070                     "$pidprompt  DB" . ('<' x $level) .  ($#hist+1) .
2071                         ('>' x $level) . " "
2072                 )
2073             )
2074           )
2075         {
2076             # ... try to execute the input as debugger commands.
2077
2078             # Don't stop running.
2079             $single = 0;
2080
2081             # No signal is active.
2082             $signal = 0;
2083
2084             # Handle continued commands (ending with \):
2085         $cmd =~ s/\\$/\n/ && do {
2086             $cmd .= &readline("  cont: ");
2087             redo CMD;
2088         };
2089
2090 =head4 The null command
2091
2092 A newline entered by itself means "re-execute the last command". We grab the
2093 command out of C<$laststep> (where it was recorded previously), and copy it
2094 back into C<$cmd> to be executed below. If there wasn't any previous command,
2095 we'll do nothing below (no command will match). If there was, we also save it
2096 in the command history and fall through to allow the command parsing to pick
2097 it up.
2098
2099 =cut
2100
2101             # Empty input means repeat the last command.
2102         $cmd =~ /^$/ && ($cmd = $laststep);
2103         chomp($cmd); # get rid of the annoying extra newline
2104         push (@hist, $cmd) if length($cmd) > 1;
2105         push (@truehist, $cmd);
2106
2107           # This is a restart point for commands that didn't arrive
2108           # via direct user input. It allows us to 'redo PIPE' to
2109           # re-execute command processing without reading a new command.
2110           PIPE: {
2111             $cmd =~ s/^\s+//s;    # trim annoying leading whitespace
2112             $cmd =~ s/\s+$//s;    # trim annoying trailing whitespace
2113             ($i) = split (/\s+/, $cmd);
2114
2115 =head3 COMMAND ALIASES
2116
2117 The debugger can create aliases for commands (these are stored in the
2118 C<%alias> hash). Before a command is executed, the command loop looks it up
2119 in the alias hash and substitutes the contents of the alias for the command,
2120 completely replacing it.
2121
2122 =cut
2123
2124                 # See if there's an alias for the command, and set it up if so.
2125             if ($alias{$i}) {
2126                     # Squelch signal handling; we want to keep control here
2127                     # if something goes loco during the alias eval.
2128                     local $SIG{__DIE__};
2129                     local $SIG{__WARN__};
2130
2131                     # This is a command, so we eval it in the DEBUGGER's
2132                     # scope! Otherwise, we can't see the special debugger
2133                     # variables, or get to the debugger's subs. (Well, we
2134                     # _could_, but why make it even more complicated?)
2135                     eval "\$cmd =~ $alias{$i}";
2136                     if ($@) {
2137                         local $\ = '';
2138                         print $OUT "Couldn't evaluate `$i' alias: $@";
2139                         next CMD;
2140                     }
2141                 } ## end if ($alias{$i})
2142
2143 =head3 MAIN-LINE COMMANDS
2144
2145 All of these commands work up to and after the program being debugged has
2146 terminated.
2147
2148 =head4 C<q> - quit
2149
2150 Quit the debugger. This entails setting the C<$fall_off_end> flag, so we don't
2151 try to execute further, cleaning any restart-related stuff out of the
2152 environment, and executing with the last value of C<$?>.
2153
2154 =cut
2155
2156                 $cmd =~ /^q$/ && do {
2157                     $fall_off_end = 1;
2158                     clean_ENV();
2159                     exit $?;
2160                 };
2161
2162 =head4 C<t> - trace
2163
2164 Turn tracing on or off. Inverts the appropriate bit in C<$trace> (q.v.).
2165
2166 =cut
2167
2168             $cmd =~ /^t$/ && do {
2169             $trace ^= 1;
2170             local $\ = '';
2171             print $OUT "Trace = " .  (($trace & 1) ? "on" : "off" ) .
2172                 "\n";
2173             next CMD;
2174         };
2175
2176 =head4 C<S> - list subroutines matching/not matching a pattern
2177
2178 Walks through C<%sub>, checking to see whether or not to print the name.
2179
2180 =cut
2181
2182             $cmd =~ /^S(\s+(!)?(.+))?$/ && do {
2183
2184                     $Srev     = defined $2;     # Reverse scan?
2185                     $Spatt    = $3;             # The pattern (if any) to use.
2186                     $Snocheck = !defined $1;    # No args - print all subs.
2187
2188                     # Need to make these sane here.
2189             local $\ = '';
2190             local $, = '';
2191
2192                     # Search through the debugger's magical hash of subs.
2193                     # If $nocheck is true, just print the sub name.
2194                     # Otherwise, check it against the pattern. We then use
2195                     # the XOR trick to reverse the condition as required.
2196             foreach $subname (sort(keys %sub)) {
2197                 if ($Snocheck or $Srev^($subname =~ /$Spatt/)) {
2198                     print $OUT $subname,"\n";
2199                 }
2200             }
2201             next CMD;
2202         };
2203
2204 =head4 C<X> - list variables in current package
2205
2206 Since the C<V> command actually processes this, just change this to the
2207 appropriate C<V> command and fall through.
2208
2209 =cut
2210
2211             $cmd =~ s/^X\b/V $package/;
2212
2213 =head4 C<V> - list variables
2214
2215 Uses C<dumpvar.pl> to dump out the current values for selected variables.
2216
2217 =cut
2218
2219                 # Bare V commands get the currently-being-debugged package
2220                 # added.
2221             $cmd =~ /^V$/ && do {
2222                 $cmd = "V $package";
2223             };
2224
2225                 # V - show variables in package.
2226                 $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
2227                     # Save the currently selected filehandle and
2228                     # force output to debugger's filehandle (dumpvar
2229                     # just does "print" for output).
2230             local ($savout) = select($OUT);
2231
2232                     # Grab package name and variables to dump.
2233             $packname = $1;
2234             @vars = split (' ', $2);
2235
2236                     # If main::dumpvar isn't here, get it.
2237             do 'dumpvar.pl' unless defined &main::dumpvar;
2238             if (defined &main::dumpvar) {
2239                         # We got it. Turn off subroutine entry/exit messages
2240                         # for the moment, along with return values.
2241                 local $frame = 0;
2242                 local $doret = -2;
2243
2244                         # must detect sigpipe failures  - not catching
2245                         # then will cause the debugger to die.
2246                         eval {
2247                             &main::dumpvar(
2248                                 $packname,
2249                                 defined $option{dumpDepth}
2250                                 ? $option{dumpDepth}
2251                                 : -1,          # assume -1 unless specified
2252                                 @vars
2253                                 );
2254                 };
2255
2256                 # The die doesn't need to include the $@, because
2257                 # it will automatically get propagated for us.
2258                 if ($@) {
2259                 die unless $@ =~ /dumpvar print failed/;
2260                 }
2261             } ## end if (defined &main::dumpvar)
2262             else {
2263                 # Couldn't load dumpvar.
2264                 print $OUT "dumpvar.pl not available.\n";
2265             }
2266                     # Restore the output filehandle, and go round again.
2267             select($savout);
2268             next CMD;
2269             };
2270
2271 =head4 C<x> - evaluate and print an expression
2272
2273 Hands the expression off to C<DB::eval>, setting it up to print the value
2274 via C<dumpvar.pl> instead of just printing it directly.
2275
2276 =cut
2277
2278                 $cmd =~ s/^x\b/ / && do {   # Remainder gets done by DB::eval()
2279                     $onetimeDump = 'dump';  # main::dumpvar shows the output
2280
2281                     # handle special  "x 3 blah" syntax XXX propagate
2282                     # doc back to special variables.
2283                         if ($cmd =~ s/^\s*(\d+)(?=\s)/ /) {
2284                           $onetimedumpDepth = $1;
2285                         }
2286                       };
2287
2288 =head4 C<m> - print methods
2289
2290 Just uses C<DB::methods> to determine what methods are available.
2291
2292 =cut
2293
2294             $cmd =~ s/^m\s+([\w:]+)\s*$/ / && do {
2295                 methods($1);
2296                 next CMD;
2297             };
2298
2299                 # m expr - set up DB::eval to do the work
2300                 $cmd =~ s/^m\b/ / && do {     # Rest gets done by DB::eval()
2301                     $onetimeDump = 'methods'; #  method output gets used there
2302             };
2303
2304 =head4 C<f> - switch files
2305
2306 =cut
2307
2308             $cmd =~ /^f\b\s*(.*)/ && do {
2309             $file = $1;
2310             $file =~ s/\s+$//;
2311
2312                     # help for no arguments (old-style was return from sub).
2313             if (!$file) {
2314                 print $OUT "The old f command is now the r command.\n"; # hint
2315                 print $OUT "The new f command switches filenames.\n";
2316                 next CMD;
2317             } ## end if (!$file)
2318
2319                     # if not in magic file list, try a close match.
2320             if (!defined $main::{'_<' . $file}) {
2321                 if (($try) = grep(m#^_<.*$file#, keys %main::)) {
2322                     {
2323                           $try = substr($try,2);
2324                           print $OUT
2325                             "Choosing $try matching `$file':\n";
2326                           $file = $try;
2327                         }
2328                     } ## end if (($try) = grep(m#^_<.*$file#...
2329                 } ## end if (!defined $main::{ ...
2330
2331                     # If not successfully switched now, we failed.
2332             if (!defined $main::{'_<' . $file}) {
2333                 print $OUT "No file matching `$file' is loaded.\n";
2334                 next CMD;
2335             }
2336
2337             # We switched, so switch the debugger internals around.
2338             elsif ($file ne $filename) {
2339                 *dbline   = $main::{ '_<' . $file };
2340                 $max      = $#dbline;
2341                 $filename = $file;
2342                 $start    = 1;
2343                 $cmd      = "l";
2344              } ## end elsif ($file ne $filename)
2345
2346              # We didn't switch; say we didn't.
2347              else {
2348                 print $OUT "Already in $file.\n";
2349                 next CMD;
2350              }
2351          };
2352
2353 =head4 C<.> - return to last-executed line.
2354
2355 We set C<$incr> to -1 to indicate that the debugger shouldn't move ahead,
2356 and then we look up the line in the magical C<%dbline> hash.
2357
2358 =cut
2359
2360                 # . command.
2361             $cmd =~ /^\.$/ && do {
2362             $incr = -1;        # for backward motion.
2363
2364                     # Reset everything to the old location.
2365             $start = $line;
2366             $filename = $filename_ini;
2367             *dbline = $main::{'_<' . $filename};
2368             $max = $#dbline;
2369
2370                     # Now where are we?
2371             print_lineinfo($position);
2372             next CMD;
2373         };
2374
2375 =head4 C<-> - back one window
2376
2377 We change C<$start> to be one window back; if we go back past the first line,
2378 we set it to be the first line. We ser C<$incr> to put us back at the
2379 currently-executing line, and then put a C<l $start +> (list one window from
2380 C<$start>) in C<$cmd> to be executed later.
2381
2382 =cut
2383
2384                 # - - back a window.
2385             $cmd =~ /^-$/ && do {
2386                     # back up by a window; go to 1 if back too far.
2387             $start -= $incr + $window + 1;
2388             $start = 1 if $start <= 0;
2389             $incr = $window - 1;
2390
2391                     # Generate and execute a "l +" command (handled below).
2392             $cmd = 'l ' . ($start) . '+';
2393         };
2394
2395 =head3 PRE-580 COMMANDS VS. NEW COMMANDS: C<a, A, b, B, h, l, L, M, o, O, P, v, w, W, E<lt>, E<lt>E<lt>, {, {{>
2396
2397 In Perl 5.8.0, a realignment of the commands was done to fix up a number of
2398 problems, most notably that the default case of several commands destroying
2399 the user's work in setting watchpoints, actions, etc. We wanted, however, to
2400 retain the old commands for those who were used to using them or who preferred
2401 them. At this point, we check for the new commands and call C<cmd_wrapper> to
2402 deal with them instead of processing them in-line.
2403
2404 =cut
2405
2406                 # All of these commands were remapped in perl 5.8.0;
2407                 # we send them off to the secondary dispatcher (see below).
2408           $cmd =~ /^([aAbBhilLMoOPvwW]\b|[<>\{]{1,2})\s*(.*)/so && do {
2409                 &cmd_wrapper($1, $2, $line);
2410                 next CMD;
2411             };
2412
2413 =head4 C<y> - List lexicals in higher scope
2414
2415 Uses C<PadWalker> to find the lexicals supplied as arguments in a scope
2416 above the current one and then displays then using C<dumpvar.pl>.
2417
2418 =cut
2419
2420                 $cmd =~ /^y(?:\s+(\d*)\s*(.*))?$/ && do {
2421
2422                     # See if we've got the necessary support.
2423                     eval { require PadWalker; PadWalker->VERSION(0.08) }
2424                       or &warn(
2425                         $@ =~ /locate/
2426                         ? "PadWalker module not found - please install\n"
2427                         : $@
2428                       )
2429                       and next CMD;
2430
2431                     # Load up dumpvar if we don't have it. If we can, that is.
2432                     do 'dumpvar.pl' unless defined &main::dumpvar;
2433                     defined &main::dumpvar
2434                       or print $OUT "dumpvar.pl not available.\n"
2435                       and next CMD;
2436
2437                     # Got all the modules we need. Find them and print them.
2438                     my @vars = split (' ', $2 || '');
2439
2440                     # Find the pad.
2441                     my $h = eval { PadWalker::peek_my(($1 || 0) + 1) };
2442
2443                     # Oops. Can't find it.
2444                     $@ and $@ =~ s/ at .*//, &warn($@), next CMD;
2445
2446                     # Show the desired vars with dumplex().
2447                     my $savout = select($OUT);
2448
2449                     # Have dumplex dump the lexicals.
2450                     dumpvar::dumplex(
2451                         $_,
2452                         $h->{$_},
2453                         defined $option{dumpDepth} ? $option{dumpDepth} : -1,
2454                         @vars
2455                     ) for sort keys %$h;
2456                     select($savout);
2457                     next CMD;
2458                 };
2459
2460 =head3 COMMANDS NOT WORKING AFTER PROGRAM ENDS
2461
2462 All of the commands below this point don't work after the program being
2463 debugged has ended. All of them check to see if the program has ended; this
2464 allows the commands to be relocated without worrying about a 'line of
2465 demarcation' above which commands can be entered anytime, and below which
2466 they can't.
2467
2468 =head4 C<n> - single step, but don't trace down into subs
2469
2470 Done by setting C<$single> to 2, which forces subs to execute straight through
2471 when entered (see X<DB::sub>). We also save the C<n> command in C<$laststep>,
2472 so a null command knows what to re-execute.
2473
2474 =cut
2475
2476                 # n - next
2477                 $cmd =~ /^n$/ && do {
2478                     end_report(), next CMD if $finished and $level <= 1;
2479                     # Single step, but don't enter subs.
2480                     $single = 2;
2481                     # Save for empty command (repeat last).
2482             $laststep = $cmd;
2483             last CMD;
2484         };
2485
2486 =head4 C<s> - single-step, entering subs
2487
2488 Sets C<$single> to 1, which causes X<DB::sub> to continue tracing inside
2489 subs. Also saves C<s> as C<$lastcmd>.
2490
2491 =cut
2492
2493                 # s - single step.
2494                 $cmd =~ /^s$/ && do {
2495                     # Get out and restart the command loop if program
2496                     # has finished.
2497                 end_report(), next CMD if $finished and $level <= 1;
2498                     # Single step should enter subs.
2499             $single = 1;
2500                     # Save for empty command (repeat last).
2501             $laststep = $cmd;
2502             last CMD;
2503         };
2504
2505 =head4 C<c> - run continuously, setting an optional breakpoint
2506
2507 Most of the code for this command is taken up with locating the optional
2508 breakpoint, which is either a subroutine name or a line number. We set
2509 the appropriate one-time-break in C<@dbline> and then turn off single-stepping
2510 in this and all call levels above this one.
2511
2512 =cut
2513
2514                 # c - start continuous execution.
2515                 $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {
2516                     # Hey, show's over. The debugged program finished
2517                     # executing already.
2518                     end_report(), next CMD if $finished and $level <= 1;
2519
2520                     # Capture the place to put a one-time break.
2521                     $subname = $i = $1;
2522
2523             #  Probably not needed, since we finish an interactive
2524             #  sub-session anyway...
2525             # local $filename = $filename;
2526             # local *dbline = *dbline;    # XXX Would this work?!
2527                     #
2528                     # The above question wonders if localizing the alias
2529                     # to the magic array works or not. Since it's commented
2530                     # out, we'll just leave that to speculation for now.
2531
2532                     # If the "subname" isn't all digits, we'll assume it
2533                     # is a subroutine name, and try to find it.
2534                     if ($subname =~ /\D/) {    # subroutine name
2535                         # Qualify it to the current package unless it's
2536                         # already qualified.
2537                         $subname = $package . "::" . $subname
2538                           unless $subname =~ /::/;
2539                         # find_sub will return "file:line_number" corresponding
2540                         # to where the subroutine is defined; we call find_sub,
2541                         # break up the return value, and assign it in one
2542                         # operation.
2543                         ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
2544
2545                         # Force the line number to be numeric.
2546                 $i += 0;
2547
2548                         # If we got a line number, we found the sub.
2549                 if ($i) {
2550                             # Switch all the debugger's internals around so
2551                             # we're actually working with that file.
2552                     $filename = $file;
2553                 *dbline = $main::{'_<' . $filename};
2554                             # Mark that there's a breakpoint in this file.
2555                 $had_breakpoints{$filename} |= 1;
2556                             # Scan forward to the first executable line
2557                             # after the 'sub whatever' line.
2558                 $max = $#dbline;
2559                 ++$i while $dbline[$i] == 0 && $i < $max;
2560                 } ## end if ($i)
2561
2562                         # We didn't find a sub by that name.
2563                 else {
2564                 print $OUT "Subroutine $subname not found.\n";
2565                 next CMD;
2566                 }
2567             } ## end if ($subname =~ /\D/)
2568
2569                     # At this point, either the subname was all digits (an
2570                     # absolute line-break request) or we've scanned through
2571                     # the code following the definition of the sub, looking
2572                     # for an executable, which we may or may not have found.
2573                     #
2574                     # If $i (which we set $subname from) is non-zero, we
2575                     # got a request to break at some line somewhere. On
2576                     # one hand, if there wasn't any real subroutine name
2577                     # involved, this will be a request to break in the current
2578                     # file at the specified line, so we have to check to make
2579                     # sure that the line specified really is breakable.
2580                     #
2581                     # On the other hand, if there was a subname supplied, the
2582                     # preceeding block has moved us to the proper file and
2583                     # location within that file, and then scanned forward
2584                     # looking for the next executable line. We have to make
2585                     # sure that one was found.
2586                     #
2587                     # On the gripping hand, we can't do anything unless the
2588                     # current value of $i points to a valid breakable line.
2589                     # Check that.
2590             if ($i) {
2591                         # Breakable?
2592                 if ($dbline[$i] == 0) {
2593                 print $OUT "Line $i not breakable.\n";
2594                 next CMD;
2595                 }
2596                         # Yes. Set up the one-time-break sigil.
2597                 $dbline{$i} =~
2598                     s/($|\0)/;9$1/; # add one-time-only b.p.
2599             } ## end if ($i)
2600
2601                     # Turn off stack tracing from here up.
2602             for ($i=0; $i <= $stack_depth; ) {
2603                 $stack[$i++] &= ~1;
2604             }
2605             last CMD;
2606         };
2607
2608 =head4 C<r> - return from a subroutine
2609
2610 For C<r> to work properly, the debugger has to stop execution again
2611 immediately after the return is executed. This is done by forcing
2612 single-stepping to be on in the call level above the current one. If
2613 we are printing return values when a C<r> is executed, set C<$doret>
2614 appropriately, and force us out of the command loop.
2615
2616 =cut
2617
2618                 # r - return from the current subroutine.
2619             $cmd =~ /^r$/ && do {
2620                     # Can't do anythign if the program's over.
2621                 end_report(), next CMD if $finished and $level <= 1;
2622                     # Turn on stack trace.
2623             $stack[$stack_depth] |= 1;
2624                     # Print return value unless the stack is empty.
2625             $doret = $option{PrintRet} ? $stack_depth - 1 : -2;
2626             last CMD;
2627         };
2628
2629 =head4 C<R> - restart
2630
2631 Restarting the debugger is a complex operation that occurs in several phases.
2632 First, we try to reconstruct the command line that was used to invoke Perl
2633 and the debugger.
2634
2635 =cut
2636
2637                 # R - restart execution.
2638             $cmd =~ /^R$/ && do {
2639                     # I may not be able to resurrect you, but here goes ...
2640                 print $OUT
2641 "Warning: some settings and command-line options may be lost!\n";
2642             my (@script, @flags, $cl);
2643
2644                     # If warn was on before, turn it on again.
2645             push @flags, '-w' if $ini_warn;
2646             if ($ini_assertion and @{^ASSERTING}) {
2647                 push @flags, (map { /\:\^\(\?\:(.*)\)\$\)/ ?
2648                         "-A$1" : "-A$_" } @{^ASSERTING});
2649             }
2650                     # Rebuild the -I flags that were on the initial
2651                     # command line.
2652             for (@ini_INC) {
2653               push @flags, '-I', $_;
2654             }
2655
2656                     # Turn on taint if it was on before.
2657             push @flags, '-T' if ${^TAINT};
2658
2659             # Arrange for setting the old INC:
2660                     # Save the current @init_INC in the environment.
2661             set_list("PERLDB_INC", @ini_INC);
2662
2663                     # If this was a perl one-liner, go to the "file"
2664                     # corresponding to the one-liner read all the lines
2665                     # out of it (except for the first one, which is going
2666                     # to be added back on again when 'perl -d' runs: that's
2667                     # the 'require perl5db.pl;' line), and add them back on
2668                     # to the command line to be executed.
2669             if ($0 eq '-e') {
2670               for (1..$#{'::_<-e'}) { # The first line is PERL5DB
2671                     chomp ($cl =  ${'::_<-e'}[$_]);
2672                 push @script, '-e', $cl;
2673               }
2674             } ## end if ($0 eq '-e')
2675
2676                     # Otherwise we just reuse the original name we had
2677                     # before.
2678             else {
2679               @script = $0;
2680             }
2681
2682 =pod
2683
2684 After the command line  has been reconstructed, the next step is to save
2685 the debugger's status in environment variables. The C<DB::set_list> routine
2686 is used to save aggregate variables (both hashes and arrays); scalars are
2687 just popped into environment variables directly.
2688
2689 =cut
2690
2691                     # If the terminal supported history, grab it and
2692                     # save that in the environment.
2693             set_list("PERLDB_HIST",
2694                  $term->Features->{getHistory}
2695                  ? $term->GetHistory
2696                  : @hist);
2697                     # Find all the files that were visited during this
2698                     # session (i.e., the debugger had magic hashes
2699                     # corresponding to them) and stick them in the environment.
2700             my @had_breakpoints = keys %had_breakpoints;
2701             set_list("PERLDB_VISITED", @had_breakpoints);
2702
2703                     # Save the debugger options we chose.
2704             set_list("PERLDB_OPT", options2remember());
2705
2706                     # Save the break-on-loads.
2707             set_list("PERLDB_ON_LOAD", %break_on_load);
2708
2709 =pod
2710
2711 The most complex part of this is the saving of all of the breakpoints. They
2712 can live in an awful lot of places, and we have to go through all of them,
2713 find the breakpoints, and then save them in the appropriate environment
2714 variable via C<DB::set_list>.
2715
2716 =cut
2717
2718                     # Go through all the breakpoints and make sure they're
2719                     # still valid.
2720             my @hard;
2721             for (0 .. $#had_breakpoints) {
2722                         # We were in this file.
2723               my $file = $had_breakpoints[$_];
2724
2725                         # Grab that file's magic line hash.
2726               *dbline = $main::{'_<' . $file};
2727
2728                         # Skip out if it doesn't exist, or if the breakpoint
2729                         # is in a postponed file (we'll do postponed ones
2730                         # later).
2731               next unless %dbline or $postponed_file{$file};
2732
2733                         # In an eval. This is a little harder, so we'll
2734                         # do more processing on that below.
2735               (push @hard, $file), next
2736                 if $file =~ /^\(\w*eval/;
2737                         # XXX I have no idea what this is doing. Yet.
2738               my @add;
2739               @add = %{$postponed_file{$file}}
2740                 if $postponed_file{$file};
2741
2742                         # Save the list of all the breakpoints for this file.
2743               set_list("PERLDB_FILE_$_", %dbline, @add);
2744             } ## end for (0 .. $#had_breakpoints)
2745
2746                     # The breakpoint was inside an eval. This is a little
2747                     # more difficult. XXX and I don't understand it.
2748             for (@hard) { # Yes, really-really...
2749                         # Get over to the eval in question.
2750               *dbline = $main::{'_<' . $_};
2751               my ($quoted, $sub, %subs, $line) = quotemeta $_;
2752               for $sub (keys %sub) {
2753                 next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
2754                 $subs{$sub} = [$1, $2];
2755               }
2756               unless (%subs) {
2757                 print $OUT
2758                   "No subroutines in $_, ignoring breakpoints.\n";
2759                 next;
2760               }
2761             LINES: for $line (keys %dbline) {
2762
2763                 # One breakpoint per sub only:
2764                 my ($offset, $sub, $found);
2765               SUBS: for $sub (keys %subs) {
2766                   if (
2767                     $subs{$sub}->[1] >= $line # Not after the subroutine
2768                   and (not defined $offset # Not caught
2769                        or $offset < 0 )) { # or badly caught
2770                 $found = $sub;
2771                 $offset = $line - $subs{$sub}->[0];
2772                 $offset = "+$offset", last SUBS if $offset >= 0;
2773                   }
2774                 }
2775                 if (defined $offset) {
2776                   $postponed{$found} =
2777                 "break $offset if $dbline{$line}";
2778                 } else {
2779                   print $OUT "Breakpoint in $_:$line ignored: after all the subroutines.\n";
2780                 }
2781
2782                         } ## end for $line (keys %dbline)
2783                     } ## end for (@hard)
2784                     # Save the other things that don't need to be
2785                     # processed.
2786             set_list("PERLDB_POSTPONE", %postponed);
2787             set_list("PERLDB_PRETYPE", @$pretype);
2788             set_list("PERLDB_PRE", @$pre);
2789             set_list("PERLDB_POST", @$post);
2790             set_list("PERLDB_TYPEAHEAD", @typeahead);
2791
2792                     # We are oficially restarting.
2793             $ENV{PERLDB_RESTART} = 1;
2794
2795                     # We are junking all child debuggers.
2796             delete $ENV{PERLDB_PIDS}; # Restore ini state
2797
2798                     # Set this back to the initial pid.
2799             $ENV{PERLDB_PIDS} = $ini_pids if defined $ini_pids;
2800
2801 =pod
2802
2803 After all the debugger status has been saved, we take the command we built
2804 up and then C<exec()> it. The debugger will spot the C<PERLDB_RESTART>
2805 environment variable and realize it needs to reload its state from the
2806 environment.
2807
2808 =cut
2809
2810                     # And run Perl again. Add the "-d" flag, all the
2811                     # flags we built up, the script (whether a one-liner
2812                     # or a file), add on the -emacs flag for a slave editor,
2813                     # and then the old arguments. We use exec() to keep the
2814                     # PID stable (and that way $ini_pids is still valid).
2815             exec($^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS) ||
2816             print $OUT "exec failed: $!\n";
2817             last CMD;
2818         };
2819
2820 =head4 C<T> - stack trace
2821
2822 Just calls C<DB::print_trace>.
2823
2824 =cut
2825
2826             $cmd =~ /^T$/ && do {
2827             print_trace($OUT, 1); # skip DB
2828             next CMD;
2829         };
2830
2831 =head4 C<w> - List window around current line.
2832
2833 Just calls C<DB::cmd_w>.
2834
2835 =cut
2836
2837             $cmd =~ /^w\b\s*(.*)/s && do { &cmd_w('w', $1); next CMD; };
2838
2839 =head4 C<W> - watch-expression processing.
2840
2841 Just calls C<DB::cmd_W>.
2842
2843 =cut
2844
2845             $cmd =~ /^W\b\s*(.*)/s && do { &cmd_W('W', $1); next CMD; };
2846
2847 =head4 C</> - search forward for a string in the source
2848
2849 We take the argument and treat it as a pattern. If it turns out to be a
2850 bad one, we return the error we got from trying to C<eval> it and exit.
2851 If not, we create some code to do the search and C<eval> it so it can't
2852 mess us up.
2853
2854 =cut
2855
2856             $cmd =~ /^\/(.*)$/ && do {
2857
2858                     # The pattern as a string.
2859             $inpat = $1;
2860
2861                     # Remove the final slash.
2862             $inpat =~ s:([^\\])/$:$1:;
2863
2864                     # If the pattern isn't null ...
2865             if ($inpat ne "") {
2866
2867                         # Turn of warn and die procesing for a bit.
2868                 local $SIG{__DIE__};
2869                 local $SIG{__WARN__};
2870
2871                         # Create the pattern.
2872                 eval '$inpat =~ m'."\a$inpat\a";
2873                 if ($@ ne "") {
2874                             # Oops. Bad pattern. No biscuit.
2875                             # Print the eval error and go back for more
2876                             # commands.
2877                 print $OUT "$@";
2878                 next CMD;
2879                 }
2880                 $pat = $inpat;
2881             } ## end if ($inpat ne "")
2882
2883                     # Set up to stop on wrap-around.
2884             $end = $start;
2885
2886                     # Don't move off the current line.
2887             $incr = -1;
2888
2889                     # Done in eval so nothing breaks if the pattern
2890                     # does something weird.
2891             eval '
2892                 for (;;) {
2893                             # Move ahead one line.
2894                 ++$start;
2895
2896                             # Wrap if we pass the last line.
2897                 $start = 1 if ($start > $max);
2898
2899                             # Stop if we have gotten back to this line again,
2900                 last if ($start == $end);
2901
2902                             # A hit! (Note, though, that we are doing
2903                             # case-insensitive matching. Maybe a qr//
2904                             # expression would be better, so the user could
2905                             # do case-sensitive matching if desired.
2906                 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
2907                     if ($slave_editor) {
2908                                     # Handle proper escaping in the slave.
2909                     print $OUT "\032\032$filename:$start:0\n";
2910                     }
2911                     else {
2912                                     # Just print the line normally.
2913                     print $OUT "$start:\t", $dbline[$start], "\n";
2914                     }
2915                                 # And quit since we found something.
2916                     last;
2917                 }
2918                 } ';
2919                     # If we wrapped, there never was a match.
2920             print $OUT "/$pat/: not found\n" if ($start == $end);
2921             next CMD;
2922         };
2923
2924 =head4 C<?> - search backward for a string in the source
2925
2926 Same as for C</>, except the loop runs backwards.
2927
2928 =cut
2929
2930                 # ? - backward pattern search.
2931             $cmd =~ /^\?(.*)$/ && do {
2932
2933                     # Get the pattern, remove trailing question mark.
2934             $inpat = $1;
2935             $inpat =~ s:([^\\])\?$:$1:;
2936
2937                     # If we've got one ...
2938             if ($inpat ne "") {
2939
2940                         # Turn off die & warn handlers.
2941                 local $SIG{__DIE__};
2942                 local $SIG{__WARN__};
2943                 eval '$inpat =~ m'."\a$inpat\a";
2944                 if ($@ ne "") {
2945                             # Ouch. Not good. Print the error.
2946                 print $OUT $@;
2947                 next CMD;
2948                 }
2949                 $pat = $inpat;
2950                     } ## end if ($inpat ne "")
2951                     # Where we are now is where to stop after wraparound.
2952             $end = $start;
2953
2954                     # Don't move away from this line.
2955             $incr = -1;
2956
2957                     # Search inside the eval to prevent pattern badness
2958                     # from killing us.
2959
2960             eval '
2961                 for (;;) {
2962                             # Back up a line.
2963                 --$start;
2964
2965                             # Wrap if we pass the first line.
2966                 $start = $max if ($start <= 0);
2967
2968                             # Quit if we get back where we started,
2969                 last if ($start == $end);
2970
2971                             # Match?
2972                 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
2973                     if ($slave_editor) {
2974                                     # Yep, follow slave editor requirements.
2975                     print $OUT "\032\032$filename:$start:0\n";
2976                     }
2977                     else {
2978                                     # Yep, just print normally.
2979                     print $OUT "$start:\t", $dbline[$start], "\n";
2980                     }
2981
2982                                 # Found, so done.
2983                     last;
2984                 }
2985                 } ';
2986             print $OUT "?$pat?: not found\n" if ($start == $end);
2987             next CMD;
2988        };
2989
2990 =head4 C<$rc> - Recall command
2991
2992 Manages the commands in C<@hist> (which is created if C<Term::ReadLine> reports
2993 that the terminal supports history). It find the the command required, puts it
2994 into C<$cmd>, and redoes the loop to execute it.
2995
2996 =cut
2997
2998                 # $rc - recall command.
2999             $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
3000
3001                     # No arguments, take one thing off history.
3002             pop (@hist) if length($cmd) > 1;
3003
3004                     # Relative (- found)?
3005                     #  Y - index back from most recent (by 1 if bare minus)
3006                     #  N - go to that particular command slot or the last
3007                     #      thing if nothing following.
3008             $i = $1 ? ($#hist-($2||1)) : ($2||$#hist);
3009
3010                     # Pick out the command desired.
3011             $cmd = $hist[$i];
3012
3013                     # Print the command to be executed and restart the loop
3014                     # with that command in the buffer.
3015             print $OUT $cmd, "\n";
3016             redo CMD;
3017         };
3018
3019 =head4 C<$sh$sh> - C<system()> command
3020
3021 Calls the C<DB::system()> to handle the command. This keeps the C<STDIN> and
3022 C<STDOUT> from getting messed up.
3023
3024 =cut
3025
3026                 # $sh$sh - run a shell command (if it's all ASCII).
3027                 # Can't run shell commands with Unicode in the debugger, hmm.
3028             $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {
3029                     # System it.
3030             &system($1);
3031             next CMD;
3032         };
3033
3034 =head4 C<$rc I<pattern> $rc> - Search command history
3035
3036 Another command to manipulate C<@hist>: this one searches it with a pattern.
3037 If a command is found, it is placed in C<$cmd> and executed via <redo>.
3038
3039 =cut
3040
3041                 # $rc pattern $rc - find a command in the history.
3042             $cmd =~ /^$rc([^$rc].*)$/ && do {
3043                     # Create the pattern to use.
3044             $pat = "^$1";
3045
3046                     # Toss off last entry if length is >1 (and it always is).
3047             pop (@hist) if length($cmd) > 1;
3048
3049                     # Look backward through the history.
3050             for ($i = $#hist; $i; --$i) {
3051                         # Stop if we find it.
3052                 last if $hist[$i] =~ /$pat/;
3053             }
3054
3055             if (!$i) {
3056                         # Never found it.
3057                 print $OUT "No such command!\n\n";
3058                 next CMD;
3059             }
3060
3061                     # Found it. Put it in the buffer, print it, and process it.
3062             $cmd = $hist[$i];
3063             print $OUT $cmd, "\n";
3064             redo CMD;
3065         };
3066
3067 =head4 C<$sh> - Invoke a shell
3068
3069 Uses C<DB::system> to invoke a shell.
3070
3071 =cut
3072
3073                 # $sh - start a shell.
3074             $cmd =~ /^$sh$/ && do {
3075                     # Run the user's shell. If none defined, run Bourne.
3076                     # We resume execution when the shell terminates.
3077             &system($ENV{SHELL}||"/bin/sh");
3078             next CMD;
3079         };
3080
3081 =head4 C<$sh I<command>> - Force execution of a command in a shell
3082
3083 Like the above, but the command is passed to the shell. Again, we use
3084 C<DB::system> to avoid problems with C<STDIN> and C<STDOUT>.
3085
3086 =cut
3087
3088                 # $sh command - start a shell and run a command in it.
3089             $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do {
3090             # XXX: using csh or tcsh destroys sigint retvals!
3091             #&system($1);  # use this instead
3092
3093                     # use the user's shell, or Bourne if none defined.
3094             &system($ENV{SHELL}||"/bin/sh","-c",$1);
3095             next CMD;
3096         };
3097
3098 =head4 C<H> - display commands in history
3099
3100 Prints the contents of C<@hist> (if any).
3101
3102 =cut
3103
3104             $cmd =~ /^H\b\s*(-(\d+))?/ && do {
3105                     # Anything other than negative numbers is ignored by
3106                     # the (incorrect) pattern, so this test does nothing.
3107             $end = $2 ? ($#hist-$2) : 0;
3108
3109                     # Set to the minimum if less than zero.
3110             $hist = 0 if $hist < 0;
3111
3112                     # Start at the end of the array.
3113                     # Stay in while we're still above the ending value.
3114                     # Tick back by one each time around the loop.
3115             for ($i=$#hist; $i>$end; $i--) {
3116
3117                         # Print the command  unless it has no arguments.
3118                 print $OUT "$i: ",$hist[$i],"\n"
3119                   unless $hist[$i] =~ /^.?$/;
3120             };
3121             next CMD;
3122         };
3123
3124 =head4 C<man, doc, perldoc> - look up documentation
3125
3126 Just calls C<runman()> to print the appropriate document.
3127
3128 =cut
3129
3130                 # man, perldoc, doc - show manual pages.
3131             $cmd =~ /^(?:man|(?:perl)?doc)\b(?:\s+([^(]*))?$/ && do {
3132             runman($1);
3133             next CMD;
3134         };
3135
3136 =head4 C<p> - print
3137
3138 Builds a C<print EXPR> expression in the C<$cmd>; this will get executed at
3139 the bottom of the loop.
3140
3141 =cut
3142
3143                 # p - print (no args): print $_.
3144             $cmd =~ s/^p$/print {\$DB::OUT} \$_/;
3145
3146                 # p - print the given expression.
3147             $cmd =~ s/^p\b/print {\$DB::OUT} /;
3148
3149 =head4 C<=> - define command alias
3150
3151 Manipulates C<%alias> to add or list command aliases.
3152
3153 =cut
3154
3155                  # = - set up a command alias.
3156             $cmd =~ s/^=\s*// && do {
3157             my @keys;
3158             if (length $cmd == 0) {
3159                         # No args, get current aliases.
3160                 @keys = sort keys %alias;
3161             } elsif (my($k,$v) = ($cmd =~ /^(\S+)\s+(\S.*)/)) {
3162                         # Creating a new alias. $k is alias name, $v is
3163                         # alias value.
3164
3165                 # can't use $_ or kill //g state
3166                 for my $x ($k, $v) {
3167                           # Escape "alarm" characters.
3168                     $x =~ s/\a/\\a/g
3169                 }
3170
3171                         # Substitute key for value, using alarm chars
3172                         # as separators (which is why we escaped them in
3173                         # the command).
3174                 $alias{$k} = "s\a$k\a$v\a";
3175
3176                         # Turn off standard warn and die behavior.
3177                 local $SIG{__DIE__};
3178                 local $SIG{__WARN__};
3179
3180                         # Is it valid Perl?
3181                 unless (eval "sub { s\a$k\a$v\a }; 1") {
3182                             # Nope. Bad alias. Say so and get out.
3183                 print $OUT "Can't alias $k to $v: $@\n";
3184                 delete $alias{$k};
3185                 next CMD;
3186                 }
3187                         # We'll only list the new one.
3188                 @keys = ($k);
3189                     } ## end elsif (my ($k, $v) = ($cmd...
3190
3191                     # The argument is the alias to list.
3192             else {
3193                 @keys = ($cmd);
3194             }
3195
3196                     # List aliases.
3197             for my $k (@keys) {
3198                         # Messy metaquoting: Trim the substiution code off.
3199                         # We use control-G as the delimiter because it's not
3200                         # likely to appear in the alias.
3201                 if ((my $v = $alias{$k}) =~ s\as\a$k\a(.*)\a$\a1\a) {
3202                             # Print the alias.
3203                 print $OUT "$k\t= $1\n";
3204                 }
3205                 elsif (defined $alias{$k}) {
3206                             # Couldn't trim it off; just print the alias code.
3207                     print $OUT "$k\t$alias{$k}\n";
3208                 }
3209                 else {
3210                             # No such, dude.
3211                 print "No alias for $k\n";
3212                 }
3213                     } ## end for my $k (@keys)
3214             next CMD;
3215         };
3216
3217 =head4 C<source> - read commands from a file.
3218
3219 Opens a lexical filehandle and stacks it on C<@cmdfhs>; C<DB::readline> will
3220 pick it up.
3221
3222 =cut
3223
3224                 # source - read commands from a file (or pipe!) and execute.
3225                     $cmd =~ /^source\s+(.*\S)/ && do {
3226               if (open my $fh, $1) {
3227                         # Opened OK; stick it in the list of file handles.
3228             push @cmdfhs, $fh;
3229               }
3230               else {
3231                         # Couldn't open it.
3232             &warn("Can't execute `$1': $!\n");
3233               }
3234               next CMD;
3235             };
3236
3237 =head4 C<save> - send current history to a file
3238
3239 Takes the complete history, (not the shrunken version you see with C<H>),
3240 and saves it to the given filename, so it can be replayed using C<source>.
3241
3242 Note that all C<^(save|source)>'s are commented out with a view to minimise recursion.
3243
3244 =cut
3245
3246                 # save source - write commands to a file for later use
3247                 $cmd =~ /^save\s*(.*)$/ && do {
3248                     my $file = $1 || '.perl5dbrc'; # default?
3249                     if (open my $fh, "> $file") {
3250                         # chomp to remove extraneous newlines from source'd files
3251                         chomp(my @truelist = map { m/^\s*(save|source)/ ? "#$_": $_ } @truehist);
3252                         print $fh join("\n", @truelist);
3253                         print "commands saved in $file\n";
3254                     } else {
3255                         &warn("Can't save debugger commands in '$1': $!\n");
3256                     }
3257                     next CMD;
3258                 };
3259
3260 =head4 C<|, ||> - pipe output through the pager.
3261
3262 FOR C<|>, we save C<OUT> (the debugger's output filehandle) and C<STDOUT>
3263 (the program's standard output). For C<||>, we only save C<OUT>. We open a
3264 pipe to the pager (restoring the output filehandles if this fails). If this
3265 is the C<|> command, we also set up a C<SIGPIPE> handler which will simply
3266 set C<$signal>, sending us back into the debugger.
3267
3268 We then trim off the pipe symbols and C<redo> the command loop at the
3269 C<PIPE> label, causing us to evaluate the command in C<$cmd> without
3270 reading another.
3271
3272 =cut
3273
3274                 # || - run command in the pager, with output to DB::OUT.
3275             $cmd =~ /^\|\|?\s*[^|]/ && do {
3276             if ($pager =~ /^\|/) {
3277                         # Default pager is into a pipe. Redirect I/O.
3278                 open(SAVEOUT,">&STDOUT") ||
3279                     &warn("Can't save STDOUT");
3280                 open(STDOUT,">&OUT") ||
3281                     &warn("Can't redirect STDOUT");
3282                     } ## end if ($pager =~ /^\|/)
3283             else {
3284                         # Not into a pipe. STDOUT is safe.
3285                 open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT");
3286             }
3287
3288                     # Fix up environment to record we have less if so.
3289             fix_less();
3290
3291             unless ($piped=open(OUT,$pager)) {
3292                         # Couldn't open pipe to pager.
3293                 &warn("Can't pipe output to `$pager'");
3294                 if ($pager =~ /^\|/) {
3295                             # Redirect I/O back again.
3296                 open(OUT,">&STDOUT") # XXX: lost message
3297                     || &warn("Can't restore DB::OUT");
3298                 open(STDOUT,">&SAVEOUT")
3299                   || &warn("Can't restore STDOUT");
3300                 close(SAVEOUT);
3301                         } ## end if ($pager =~ /^\|/)
3302                 else {
3303                             # Redirect I/O. STDOUT already safe.
3304                 open(OUT,">&STDOUT") # XXX: lost message
3305                     || &warn("Can't restore DB::OUT");
3306                 }
3307                 next CMD;
3308                     } ## end unless ($piped = open(OUT,...
3309
3310                     # Set up broken-pipe handler if necessary.
3311             $SIG{PIPE}= \&DB::catch
3312                 if $pager =~ /^\|/ &&
3313                 ("" eq $SIG{PIPE}  ||  "DEFAULT" eq $SIG{PIPE});
3314
3315                     # Save current filehandle, unbuffer out, and put it back.
3316             $selected= select(OUT);
3317             $|= 1;
3318
3319                     # Don't put it back if pager was a pipe.
3320             select( $selected ), $selected= "" unless $cmd =~ /^\|\|/;
3321
3322                     # Trim off the pipe symbols and run the command now.
3323             $cmd =~ s/^\|+\s*//;
3324             redo PIPE;
3325             };
3326
3327 =head3 END OF COMMAND PARSING
3328
3329 Anything left in C<$cmd> at this point is a Perl expression that we want to
3330 evaluate. We'll always evaluate in the user's context, and fully qualify
3331 any variables we might want to address in the C<DB> package.
3332
3333 =cut
3334
3335                 # t - turn trace on.
3336             $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
3337
3338                 # s - single-step. Remember the last command was 's'.
3339             $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
3340
3341                 # n - single-step, but not into subs. Remember last command
3342             $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
3343
3344         }        # PIPE:
3345
3346             # Make sure the flag that says "the debugger's running" is
3347             # still on, to make sure we get control again.
3348         $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd";
3349
3350             # Run *our* eval that executes in the caller's context.
3351         &eval;
3352
3353             # Turn off the one-time-dump stuff now.
3354         if ($onetimeDump) {
3355         $onetimeDump = undef;
3356                 $onetimedumpDepth = undef;
3357         }
3358         elsif ($term_pid == $$) {
3359         STDOUT->flush();
3360         STDERR->flush();
3361                 # XXX If this is the master pid, print a newline.
3362         print $OUT "\n";
3363         }
3364     } ## end while (($term || &setterm...
3365
3366 =head3 POST-COMMAND PROCESSING
3367
3368 After each command, we check to see if the command output was piped anywhere.
3369 If so, we go through the necessary code to unhook the pipe and go back to
3370 our standard filehandles for input and output.
3371
3372 =cut
3373
3374     continue {        # CMD:
3375
3376             # At the end of every command:
3377         if ($piped) {
3378                 # Unhook the pipe mechanism now.
3379         if ($pager =~ /^\|/) {
3380                     # No error from the child.
3381             $? = 0;
3382
3383             # we cannot warn here: the handle is missing --tchrist
3384             close(OUT) || print SAVEOUT "\nCan't close DB::OUT\n";
3385
3386             # most of the $? crud was coping with broken cshisms
3387                     # $? is explicitly set to 0, so this never runs.
3388             if ($?) {
3389             print SAVEOUT "Pager `$pager' failed: ";
3390             if ($? == -1) {
3391                 print SAVEOUT "shell returned -1\n";
3392             }
3393             elsif ($? >> 8) {
3394                 print SAVEOUT ( $? & 127 )
3395                     ? " (SIG#".($?&127).")"
3396                     : "", ( $? & 128 ) ? " -- core dumped" : "", "\n";
3397             }
3398             else {
3399                 print SAVEOUT "status ", ($? >> 8), "\n";
3400             }
3401                     } ## end if ($?)
3402
3403                     # Reopen filehandle for our output (if we can) and
3404                     # restore STDOUT (if we can).
3405             open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
3406             open(STDOUT,">&SAVEOUT") ||
3407                 &warn("Can't restore STDOUT");
3408
3409                     # Turn off pipe exception handler if necessary.
3410             $SIG{PIPE} = "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
3411
3412             # Will stop ignoring SIGPIPE if done like nohup(1)
3413             # does SIGINT but Perl doesn't give us a choice.
3414                 } ## end if ($pager =~ /^\|/)
3415         else {
3416                     # Non-piped "pager". Just restore STDOUT.
3417             open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT");
3418         }
3419
3420                 # Close filehandle pager was using, restore the normal one
3421                 # if necessary,
3422                 close(SAVEOUT);
3423         select($selected), $selected= "" unless $selected eq "";
3424
3425                 # No pipes now.
3426         $piped= "";
3427             } ## end if ($piped)
3428     }            # CMD:
3429
3430 =head3 COMMAND LOOP TERMINATION
3431
3432 When commands have finished executing, we come here. If the user closed the
3433 input filehandle, we turn on C<$fall_off_end> to emulate a C<q> command. We
3434 evaluate any post-prompt items. We restore C<$@>, C<$!>, C<$^E>, C<$,>, C<$/>,
3435 C<$\>, and C<$^W>, and return a null list as expected by the Perl interpreter.
3436 The interpreter will then execute the next line and then return control to us
3437 again.
3438
3439 =cut
3440
3441         # No more commands? Quit.
3442     $fall_off_end = 1 unless defined $cmd; # Emulate `q' on EOF
3443
3444         # Evaluate post-prompt commands.
3445     foreach $evalarg (@$post) {
3446       &eval;
3447     }
3448     }                # if ($single || $signal)
3449
3450     # Put the user's globals back where you found them.
3451     ($@, $!, $^E, $,, $/, $\, $^W) = @saved;
3452     ();
3453 } ## end sub DB
3454
3455 # The following code may be executed now:
3456 # BEGIN {warn 4}
3457
3458 =head2 sub
3459
3460 C<sub> is called whenever a subroutine call happens in the program being
3461 debugged. The variable C<$DB::sub> contains the name of the subroutine
3462 being called.
3463
3464 The core function of this subroutine is to actually call the sub in the proper
3465 context, capturing its output. This of course causes C<DB::DB> to get called
3466 again, repeating until the subroutine ends and returns control to C<DB::sub>
3467 again. Once control returns, C<DB::sub> figures out whether or not to dump the
3468 return value, and returns its captured copy of the return value as its own
3469 return value. The value then feeds back into the program being debugged as if
3470 C<DB::sub> hadn't been there at all.
3471
3472 C<sub> does all the work of printing the subroutine entry and exit messages
3473 enabled by setting C<$frame>. It notes what sub the autoloader got called for,
3474 and also prints the return value if needed (for the C<r> command and if
3475 the 16 bit is set in C<$frame>).
3476
3477 It also tracks the subroutine call depth by saving the current setting of
3478 C<$single> in the C<@stack> package global; if this exceeds the value in
3479 C<$deep>, C<sub> automatically turns on printing of the current depth by
3480 setting the 4 bit in C<$single>. In any case, it keeps the current setting
3481 of stop/don't stop on entry to subs set as it currently is set.
3482
3483 =head3 C<caller()> support
3484
3485 If C<caller()> is called from the package C<DB>, it provides some
3486 additional data, in the following order:
3487
3488 =over 4
3489
3490 =item * C<$package>
3491
3492 The package name the sub was in
3493
3494 =item * C<$filename>
3495
3496 The filename it was defined in
3497
3498 =item * C<$line>
3499
3500 The line number it was defined on
3501
3502 =item * C<$subroutine>
3503
3504 The subroutine name; C<'(eval)'> if an C<eval>().
3505
3506 =item * C<$hasargs>
3507
3508 1 if it has arguments, 0 if not
3509
3510 =item * C<$wantarray>
3511
3512 1 if array context, 0 if scalar context
3513
3514 =item * C<$evaltext>
3515
3516 The C<eval>() text, if any (undefined for C<eval BLOCK>)
3517
3518 =item * C<$is_require>
3519
3520 frame was created by a C<use> or C<require> statement
3521
3522 =item * C<$hints>
3523
3524 pragma information; subject to change between versions
3525
3526 =item * C<$bitmask>
3527
3528 pragma information: subject to change between versions
3529
3530 =item * C<@DB::args>
3531
3532 arguments with which the subroutine was invoked
3533
3534 =back
3535
3536 =cut
3537
3538
3539 sub sub {
3540
3541     # Whether or not the autoloader was running, a scalar to put the
3542     # sub's return value in (if needed), and an array to put the sub's
3543     # return value in (if needed).
3544     my ($al, $ret, @ret) = "";
3545
3546     # If the last ten characters are C'::AUTOLOAD', note we've traced
3547     # into AUTOLOAD for $sub.
3548     if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') {
3549     $al = " for $$sub";
3550     }
3551
3552     # We stack the stack pointer and then increment it to protect us
3553     # from a situation that might unwind a whole bunch of call frames
3554     # at once. Localizing the stack pointer means that it will automatically
3555     # unwind the same amount when multiple stack frames are unwound.
3556     local $stack_depth = $stack_depth + 1; # Protect from non-local exits
3557
3558     # Expand @stack.
3559     $#stack = $stack_depth;
3560
3561     # Save current single-step setting.
3562     $stack[-1] = $single;
3563
3564     # Turn off all flags except single-stepping.
3565     $single &= 1;
3566
3567     # If we've gotten really deeply recursed, turn on the flag that will
3568     # make us stop with the 'deep recursion' message.
3569     $single |= 4 if $stack_depth == $deep;
3570
3571     # If frame messages are on ...
3572     (
3573         $frame & 4    # Extended frame entry message
3574      ? ( print_lineinfo(' ' x ($stack_depth - 1), "in  "),
3575
3576      # Why -1? But it works! :-(
3577             # Because print_trace will call add 1 to it and then call
3578             # dump_trace; this results in our skipping -1+1 = 0 stack frames
3579             # in dump_trace.
3580      print_trace($LINEINFO, -1, 1, 1, "$sub$al")
3581     )
3582      : print_lineinfo(' ' x ($stack_depth - 1), "entering $sub$al\n")
3583           # standard frame entry message
3584     )
3585     if $frame;
3586
3587     # Determine the sub's return type,and capture approppriately.
3588     if (wantarray) {
3589         # Called in array context. call sub and capture output.
3590         # DB::DB will recursively get control again if appropriate; we'll come
3591         # back here when the sub is finished.
3592         if ($assertion) {
3593             $assertion=0;
3594         eval {
3595             @ret = &$sub;
3596         };
3597         if ($@) {
3598           print $OUT $@;
3599           $signal=1 unless $warnassertions;
3600         }
3601     }
3602     else {
3603         @ret = &$sub;
3604     }
3605
3606         # Pop the single-step value back off the stack.
3607     $single |= $stack[$stack_depth--];
3608
3609         # Check for exit trace messages...
3610     (
3611             $frame & 4         # Extended exit message
3612      ? ( print_lineinfo(' ' x $stack_depth, "out "),
3613          print_trace($LINEINFO, -1, 1, 1, "$sub$al")
3614         )
3615      : print_lineinfo(' ' x $stack_depth, "exited $sub$al\n")
3616               # Standard exit message
3617     )
3618     if $frame & 2;
3619
3620         # Print the return info if we need to.
3621     if ($doret eq $stack_depth or $frame & 16) {
3622             # Turn off output record separator.
3623         local $\ = '';
3624             my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
3625
3626             # Indent if we're printing because of $frame tracing.
3627         print $fh ' ' x $stack_depth if $frame & 16;
3628
3629             # Print the return value.
3630         print $fh "list context return from $sub:\n";
3631         dumpit($fh, \@ret );
3632
3633             # And don't print it again.
3634         $doret = -2;
3635         } ## end if ($doret eq $stack_depth...
3636         # And we have to return the return value now.
3637     @ret;
3638     } ## end if (wantarray)
3639
3640     # Scalar context.
3641     else {
3642         if ($assertion) {
3643         $assertion=0;
3644         eval {
3645             # Save the value if it's wanted at all.
3646             $ret = &$sub;
3647         };
3648         if ($@) {
3649           print $OUT $@;
3650           $signal=1 unless $warnassertions;
3651         }
3652         $ret=undef unless defined wantarray;
3653     }
3654     else {
3655         if (defined wantarray) {
3656             # Save the value if it's wanted at all.
3657             $ret = &$sub;
3658         }
3659         else {
3660             # Void return, explicitly.
3661             &$sub;
3662             undef $ret;
3663         }
3664     } # if assertion
3665
3666         # Pop the single-step value off the stack.
3667     $single |= $stack[$stack_depth--];
3668
3669         # If we're doing exit messages...
3670     (
3671             $frame & 4                        # Extended messsages
3672      ? (
3673             print_lineinfo(' ' x $stack_depth, "out "),
3674             print_trace($LINEINFO, -1, 1, 1, "$sub$al")
3675         )
3676      : print_lineinfo(' ' x $stack_depth, "exited $sub$al\n")
3677                                               # Standard messages
3678     )
3679     if $frame & 2;
3680
3681         # If we are supposed to show the return value... same as before.
3682     if ($doret eq $stack_depth or $frame & 16 and defined wantarray) {
3683         local $\ = '';
3684             my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
3685         print $fh (' ' x $stack_depth) if $frame & 16;
3686         print $fh (defined wantarray
3687              ? "scalar context return from $sub: "
3688              : "void context return from $sub\n"
3689         );
3690         dumpit( $fh, $ret ) if defined wantarray;
3691         $doret = -2;
3692         } ## end if ($doret eq $stack_depth...
3693
3694         # Return the appropriate scalar value.
3695     $ret;
3696     } ## end else [ if (wantarray)
3697 } ## end sub sub
3698
3699 =head1 EXTENDED COMMAND HANDLING AND THE COMMAND API
3700
3701 In Perl 5.8.0, there was a major realignment of the commands and what they did,
3702 Most of the changes were to systematize the command structure and to eliminate
3703 commands that threw away user input without checking.
3704
3705 The following sections describe the code added to make it easy to support
3706 multiple command sets with conflicting command names. This section is a start
3707 at unifying all command processing to make it simpler to develop commands.
3708
3709 Note that all the cmd_[a-zA-Z] subroutines require the command name, a line
3710 number, and C<$dbline> (the current line) as arguments.
3711
3712 Support functions in this section which have multiple modes of failure C<die>
3713 on error; the rest simply return a false value.
3714
3715 The user-interface functions (all of the C<cmd_*> functions) just output
3716 error messages.
3717
3718 =head2 C<%set>
3719
3720 The C<%set> hash defines the mapping from command letter to subroutine
3721 name suffix.
3722
3723 C<%set> is a two-level hash, indexed by set name and then by command name.
3724 Note that trying to set the CommandSet to 'foobar' simply results in the
3725 5.8.0 command set being used, since there's no top-level entry for 'foobar'.
3726
3727 =cut
3728
3729 ### The API section
3730
3731 ### Functions with multiple modes of failure die on error, the rest
3732 ### returns FALSE on error.
3733 ### User-interface functions cmd_* output error message.
3734
3735 ### Note all cmd_[a-zA-Z]'s require $cmd, $line, $dblineno as first arguments
3736
3737 my %set = ( #
3738     'pre580'    => {
3739         'a'    => 'pre580_a',
3740         'A'    => 'pre580_null',
3741         'b'    => 'pre580_b',
3742         'B'    => 'pre580_null',
3743         'd'    => 'pre580_null',
3744         'D'    => 'pre580_D',
3745         'h'    => 'pre580_h',
3746         'M'    => 'pre580_null',
3747         'O'    => 'o',
3748         'o'    => 'pre580_null',
3749         'v'    => 'M',
3750         'w'    => 'v',
3751         'W'    => 'pre580_W',
3752     },
3753     'pre590'    => {
3754         '<'        => 'pre590_prepost',
3755         '<<'    => 'pre590_prepost',
3756         '>'        => 'pre590_prepost',
3757         '>>'    => 'pre590_prepost',
3758         '{'        => 'pre590_prepost',
3759         '{{'    => 'pre590_prepost',
3760     },
3761 );
3762
3763 =head2 C<cmd_wrapper()> (API)
3764
3765 C<cmd_wrapper()> allows the debugger to switch command sets
3766 depending on the value of the C<CommandSet> option.
3767
3768 It tries to look up the command in the X<C<%set>> package-level I<lexical>
3769 (which means external entities can't fiddle with it) and create the name of
3770 the sub to call based on the value found in the hash (if it's there). I<All>
3771 of the commands to be handled in a set have to be added to C<%set>; if they
3772 aren't found, the 5.8.0 equivalent is called (if there is one).
3773
3774 This code uses symbolic references.
3775
3776 =cut
3777
3778 sub cmd_wrapper {
3779     my $cmd      = shift;
3780     my $line     = shift;
3781     my $dblineno = shift;
3782
3783     # Assemble the command subroutine's name by looking up the
3784     # command set and command name in %set. If we can't find it,
3785     # default to the older version of the command.
3786     my $call = 'cmd_'
3787         .( $set{$CommandSet}{$cmd}
3788         || ($cmd =~ /^[<>{]+/o ? 'prepost' : $cmd));
3789
3790
3791     # Call the command subroutine, call it by name.
3792     return &$call($cmd, $line, $dblineno);
3793 }
3794
3795 =head3 C<cmd_a> (command)
3796
3797 The C<a> command handles pre-execution actions. These are associated with a
3798 particular line, so they're stored in C<%dbline>. We default to the current
3799 line if none is specified.
3800
3801 =cut
3802
3803 sub cmd_a {
3804     my $cmd    = shift;
3805     my $line   = shift || ''; # [.|line] expr
3806     my $dbline = shift;
3807
3808     # If it's dot (here), or not all digits,  use the current line.
3809     $line =~ s/^(\.|(?:[^\d]))/$dbline/;
3810
3811     # Should be a line number followed by an expression.
3812     if ($line =~ /^\s*(\d*)\s*(\S.+)/) {
3813         my ($lineno, $expr) = ($1, $2);
3814
3815         # If we have an expression ...
3816         if (length $expr) {
3817             # ... but the line isn't breakable, complain.
3818             if ($dbline[$lineno] == 0) {
3819                 print $OUT
3820                     "Line $lineno($dbline[$lineno]) does not have an action?\n";
3821             }
3822             else {
3823                 # It's executable. Record that the line has an action.
3824                 $had_breakpoints{$filename} |= 2;
3825
3826                 # Remove any action, temp breakpoint, etc.
3827                 $dbline{$lineno} =~ s/\0[^\0]*//;
3828
3829                 # Add the action to the line.
3830                 $dbline{$lineno} .= "\0" . action($expr);
3831             }
3832         } ## end if (length $expr)
3833     } ## end if ($line =~ /^\s*(\d*)\s*(\S.+)/)
3834     else {
3835         # Syntax wrong.
3836         print $OUT
3837             "Adding an action requires an optional lineno and an expression\n"
3838             ; # hint
3839     }
3840 } ## end sub cmd_a
3841
3842 =head3 C<cmd_A> (command)
3843
3844 Delete actions. Similar to above, except the delete code is in a separate
3845 subroutine, C<delete_action>.
3846
3847 =cut
3848
3849 sub cmd_A {
3850     my $cmd    = shift; # A
3851     my $line   = shift || '';
3852     my $dbline = shift;
3853
3854     # Dot is this line.
3855     $line =~ s/^\./$dbline/;
3856
3857     # Call delete_action with a null param to delete them all.
3858     # The '1' forces the eval to be true. It'll be false only
3859     # if delete_action blows up for some reason, in which case
3860     # we print $@ and get out.
3861     if ($line eq '*') {
3862         eval { &delete_action(); 1 } or print $OUT $@ and return;
3863     }
3864
3865     # There's a real line  number. Pass it to delete_action.
3866     # Error trapping is as above.
3867     elsif ($line =~ /^(\S.*)/) {
3868         eval { &delete_action($1); 1 } or print $OUT $@ and return;
3869     }
3870
3871     # Swing and a miss. Bad syntax.
3872     else {
3873         print $OUT
3874             "Deleting an action requires a line number, or '*' for all\n"
3875             ; # hint
3876     }
3877 } ## end sub cmd_A
3878
3879 =head3 C<delete_action> (API)
3880
3881 C<delete_action> accepts either a line number or C<undef>. If a line number
3882 is specified, we check for the line being executable (if it's not, it
3883 couldn't have had an  action). If it is, we just take the action off (this
3884 will get any kind of an action, including breakpoints).
3885
3886 =cut
3887
3888 sub delete_action {
3889   my $i = shift;
3890   if (defined($i)) {
3891         # Can there be one?
3892         die "Line $i has no action .\n" if $dbline[$i] == 0;
3893
3894         # Nuke whatever's there.
3895         $dbline{$i} =~ s/\0[^\0]*//; # \^a
3896         delete $dbline{$i} if $dbline{$i} eq '';
3897     }
3898         else {
3899         print $OUT "Deleting all actions...\n";
3900         for my $file (keys %had_breakpoints) {
3901             local *dbline = $main::{'_<' . $file};
3902             my $max = $#dbline;
3903             my $was;
3904             for ($i = 1; $i <= $max ; $i++) {
3905                     if (defined $dbline{$i}) {
3906                             $dbline{$i} =~ s/\0[^\0]*//;
3907                             delete $dbline{$i} if $dbline{$i} eq '';
3908                     }
3909                 unless ($had_breakpoints{$file} &= ~2) {
3910                         delete $had_breakpoints{$file};
3911                 }
3912             } ## end for ($i = 1 ; $i <= $max...
3913         } ## end for my $file (keys %had_breakpoints)
3914     } ## end else [ if (defined($i))
3915 } ## end sub delete_action
3916
3917 =head3 C<cmd_b> (command)
3918
3919 Set breakpoints. Since breakpoints can be set in so many places, in so many
3920 ways, conditionally or not, the breakpoint code is kind of complex. Mostly,
3921 we try to parse the command type, and then shuttle it off to an appropriate
3922 subroutine to actually do the work of setting the breakpoint in the right
3923 place.
3924
3925 =cut
3926
3927 sub cmd_b {
3928     my $cmd    = shift; # b
3929     my $line   = shift; # [.|line] [cond]
3930     my $dbline = shift;
3931
3932     # Make . the current line number if it's there..
3933     $line =~ s/^\./$dbline/;
3934
3935     # No line number, no condition. Simple break on current line.
3936     if ($line =~ /^\s*$/) {
3937         &cmd_b_line($dbline, 1);
3938     }
3939
3940     # Break on load for a file.
3941     elsif ($line =~ /^load\b\s*(.*)/) {
3942         my $file = $1;
3943         $file =~ s/\s+$//;
3944         &cmd_b_load($file);
3945     }
3946
3947     # b compile|postpone <some sub> [<condition>]
3948     # The interpreter actually traps this one for us; we just put the
3949     # necessary condition in the %postponed hash.
3950     elsif ($line =~ /^(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/) {
3951         # Capture the condition if there is one. Make it true if none.
3952         my $cond = length $3 ? $3 : '1';
3953
3954         # Save the sub name and set $break to 1 if $1 was 'postpone', 0
3955         # if it was 'compile'.
3956         my ($subname, $break) = ($2, $1 eq 'postpone');
3957
3958         # De-Perl4-ify the name - ' separators to ::.
3959         $subname =~ s/\'/::/g;
3960
3961         # Qualify it into the current package unless it's already qualified.
3962         $subname = "${'package'}::" . $subname unless $subname =~ /::/;
3963
3964         # Add main if it starts with ::.
3965         $subname = "main".$subname if substr($subname,0,2) eq "::";
3966
3967         # Save the break type for this sub.
3968         $postponed{$subname} = $break ? "break +0 if $cond" : "compile";
3969     } ## end elsif ($line =~ ...
3970
3971     # b <sub name> [<condition>]
3972     elsif ($line =~ /^([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/) {
3973         #
3974         $subname = $1;
3975         $cond = length $2 ? $2 : '1';
3976         &cmd_b_sub($subname, $cond);
3977     }
3978
3979     # b <line> [<condition>].
3980     elsif ($line =~ /^(\d*)\s*(.*)/) {
3981         # Capture the line. If none, it's the current line.
3982         $line = $1 || $dbline;
3983
3984         # If there's no condition, make it '1'.
3985         $cond = length $2 ? $2 : '1';
3986
3987         # Break on line.
3988         &cmd_b_line($line, $cond);
3989     }
3990
3991     # Line didn't make sense.
3992     else {
3993         print "confused by line($line)?\n";
3994     }
3995 } ## end sub cmd_b
3996
3997 =head3 C<break_on_load> (API)
3998
3999 We want to break when this file is loaded. Mark this file in the
4000 C<%break_on_load> hash, and note that it has a breakpoint in
4001 C<%had_breakpoints>.
4002
4003 =cut
4004
4005
4006
4007 sub break_on_load {
4008   my $file = shift;
4009   $break_on_load{$file} = 1;
4010   $had_breakpoints{$file} |= 1;
4011 }
4012
4013 =head3 C<report_break_on_load> (API)
4014
4015 Gives us an array of filenames that are set to break on load. Note that
4016 only files with break-on-load are in here, so simply showing the keys
4017 suffices.
4018
4019 =cut
4020
4021 sub report_break_on_load {
4022   sort keys %break_on_load;
4023 }
4024
4025 =head3 C<cmd_b_load> (command)
4026
4027 We take the file passed in and try to find it in C<%INC> (which maps modules
4028 to files they came from). We mark those files for break-on-load via
4029 C<break_on_load> and then report that it was done.
4030
4031 =cut
4032
4033 sub cmd_b_load {
4034   my $file = shift;
4035   my @files;
4036
4037     # This is a block because that way we can use a redo inside it
4038     # even without there being any looping structure at all outside it.
4039   {
4040         # Save short name and full path if found.
4041     push @files, $file;
4042     push @files, $::INC{$file} if $::INC{$file};
4043
4044         # Tack on .pm and do it again unless there was a '.' in the name
4045         # already.
4046     $file .= '.pm', redo unless $file =~ /\./;
4047   }
4048
4049     # Do the real work here.
4050   break_on_load($_) for @files;
4051
4052     # All the files that have break-on-load breakpoints.
4053   @files = report_break_on_load;
4054
4055     # Normalize for the purposes of our printing this.
4056   local $\ = '';
4057   local $" = ' ';
4058   print $OUT "Will stop on load of `@files'.\n";
4059 }
4060
4061 =head3 C<$filename_error> (API package global)
4062
4063 Several of the functions we need to implement in the API need to work both
4064 on the current file and on other files. We don't want to duplicate code, so
4065 C<$filename_error> is used to contain the name of the file that's being
4066 worked on (if it's not the current one).
4067
4068 We can now build functions in pairs: the basic function works on the current
4069 file, and uses C<$filename_error> as part of its error message. Since this is
4070 initialized to C<''>, no filename will appear when we are working on the
4071 current file.
4072
4073 The second function is a wrapper which does the following:
4074
4075 =over 4
4076
4077 =item * Localizes C<$filename_error> and sets it to the name of the file to be processed.
4078
4079 =item * Localizes the C<*dbline> glob and reassigns it to point to the file we want to process.
4080
4081 =item * Calls the first function.
4082
4083 The first function works on the "current" (i.e., the one we changed to) file,
4084 and prints C<$filename_error> in the error message (the name of the other file)
4085 if it needs to. When the functions return, C<*dbline> is restored to point to the actual current file (the one we're executing in) and C<$filename_error> is
4086 restored to C<''>. This restores everything to the way it was before the
4087 second function was called at all.
4088
4089 See the comments in C<breakable_line> and C<breakable_line_in_file> for more
4090 details.
4091
4092 =back
4093
4094 =cut
4095
4096 $filename_error = '';
4097
4098 =head3 breakable_line($from, $to) (API)
4099
4100 The subroutine decides whether or not a line in the current file is breakable.
4101 It walks through C<@dbline> within the range of lines specified, looking for
4102 the first line that is breakable.
4103
4104 If C<$to> is greater than C<$from>, the search moves forwards, finding the
4105 first line I<after> C<$to> that's breakable, if there is one.
4106
4107 If C<$from> is greater than C<$to>, the search goes I<backwards>, finding the
4108 first line I<before> C<$to> that's breakable, if there is one.
4109
4110 =cut
4111
4112 sub breakable_line {
4113
4114   my ($from, $to) = @_;
4115
4116     # $i is the start point. (Where are the FORTRAN programs of yesteryear?)
4117   my $i = $from;
4118
4119     # If there are at least 2 arguments, we're trying to search a range.
4120   if (@_ >= 2) {
4121
4122         # $delta is positive for a forward search, negative for a backward one.
4123     my $delta = $from < $to ? +1 : -1;
4124
4125         # Keep us from running off the ends of the file.
4126     my $limit = $delta > 0 ? $#dbline : 1;
4127
4128         # Clever test. If you're a mathematician, it's obvious why this
4129         # test works. If not:
4130         # If $delta is positive (going forward), $limit will be $#dbline.
4131         #    If $to is less than $limit, ($limit - $to) will be positive, times
4132         #    $delta of 1 (positive), so the result is > 0 and we should use $to
4133         #    as the stopping point.
4134         #
4135         #    If $to is greater than $limit, ($limit - $to) is negative,
4136         #    times $delta of 1 (positive), so the result is < 0 and we should
4137         #    use $limit ($#dbline) as the stopping point.
4138         #
4139         # If $delta is negative (going backward), $limit will be 1.
4140         #    If $to is zero, ($limit - $to) will be 1, times $delta of -1
4141         #    (negative) so the result is > 0, and we use $to as the stopping
4142         #    point.
4143         #
4144         #    If $to is less than zero, ($limit - $to) will be positive,
4145         #    times $delta of -1 (negative), so the result is not > 0, and
4146         #    we use $limit (1) as the stopping point.
4147         #
4148         #    If $to is 1, ($limit - $to) will zero, times $delta of -1
4149         #    (negative), still giving zero; the result is not > 0, and
4150         #    we use $limit (1) as the stopping point.
4151         #
4152         #    if $to is >1, ($limit - $to) will be negative, times $delta of -1
4153         #    (negative), giving a positive (>0) value, so we'll set $limit to
4154         #    $to.
4155
4156     $limit = $to if ($limit - $to) * $delta > 0;
4157
4158         # The real search loop.
4159         # $i starts at $from (the point we want to start searching from).
4160         # We move through @dbline in the appropriate direction (determined
4161         # by $delta: either -1 (back) or +1 (ahead).
4162         # We stay in as long as we haven't hit an executable line
4163         # ($dbline[$i] == 0 means not executable) and we haven't reached
4164         # the limit yet (test similar to the above).
4165     $i += $delta while $dbline[$i] == 0 and ($limit - $i) * $delta > 0;
4166     } ## end if (@_ >= 2)
4167
4168     # If $i points to a line that is executable, return that.
4169   return $i unless $dbline[$i] == 0;
4170
4171     # Format the message and print it: no breakable lines in range.
4172     my ($pl, $upto) = ('', '');
4173   my ($pl, $upto) = ('', '');
4174   ($pl, $upto) = ('s', "..$to") if @_ >=2 and $from != $to;
4175
4176     # If there's a filename in filename_error, we'll see it.
4177     # If not, not.
4178   die "Line$pl $from$upto$filename_error not breakable\n";
4179 } ## end sub breakable_line
4180
4181 =head3 breakable_line_in_filename($file, $from, $to) (API)
4182
4183 Like C<breakable_line>, but look in another file.
4184
4185 =cut
4186
4187 sub breakable_line_in_filename {
4188     # Capture the file name.
4189   my ($f) = shift;
4190
4191     # Swap the magic line array over there temporarily.
4192   local *dbline = $main::{'_<' . $f};
4193
4194     # If there's an error, it's in this other file.
4195   local $filename_error = " of `$f'";
4196
4197     # Find the breakable line.
4198   breakable_line(@_);
4199
4200     # *dbline and $filename_error get restored when this block ends.
4201
4202 } ## end sub breakable_line_in_filename
4203
4204 =head3 break_on_line(lineno, [condition]) (API)
4205
4206 Adds a breakpoint with the specified condition (or 1 if no condition was
4207 specified) to the specified line. Dies if it can't.
4208
4209 =cut
4210
4211 sub break_on_line {
4212   my ($i, $cond) = @_;
4213
4214     # Always true if no condition supplied.
4215   $cond = 1 unless @_ >= 2;
4216
4217   my $inii = $i;
4218   my $after = '';
4219   my $pl = '';
4220
4221     # Woops, not a breakable line. $filename_error allows us to say
4222     # if it was in a different file.
4223   die "Line $i$filename_error not breakable.\n" if $dbline[$i] == 0;
4224
4225     # Mark this file as having breakpoints in it.
4226   $had_breakpoints{$filename} |= 1;
4227
4228     # If there is an action or condition here already ...
4229   if ($dbline{$i}) {
4230         # ... swap this condition for the existing one.
4231     $dbline{$i} =~ s/^[^\0]*/$cond/;
4232     }
4233       else {
4234         # Nothing here - just add the condition.
4235         $dbline{$i} = $cond;
4236     }
4237 } ## end sub break_on_line
4238
4239 =head3 cmd_b_line(line, [condition]) (command)
4240
4241 Wrapper for C<break_on_line>. Prints the failure message if it
4242 doesn't work.
4243
4244 =cut
4245
4246 sub cmd_b_line {
4247   eval { break_on_line(@_); 1 } or do {
4248     local $\ = '';
4249     print $OUT $@ and return;
4250   };
4251 } ## end sub cmd_b_line
4252
4253 =head3 break_on_filename_line(file, line, [condition]) (API)
4254
4255 Switches to the file specified and then calls C<break_on_line> to set
4256 the breakpoint.
4257
4258 =cut
4259
4260 sub break_on_filename_line {
4261   my ($f, $i, $cond) = @_;
4262
4263     # Always true if condition left off.
4264   $cond = 1 unless @_ >= 3;
4265
4266     # Switch the magical hash temporarily.
4267   local *dbline = $main::{'_<' . $f};
4268
4269     # Localize the variables that break_on_line uses to make its message.
4270   local $filename_error = " of `$f'";
4271   local $filename = $f;
4272
4273     # Add the breakpoint.
4274   break_on_line($i, $cond);
4275 } ## end sub break_on_filename_line
4276
4277 =head3 break_on_filename_line_range(file, from, to, [condition]) (API)
4278
4279 Switch to another file, search the range of lines specified for an
4280 executable one, and put a breakpoint on the first one you find.
4281
4282 =cut
4283
4284 sub break_on_filename_line_range {
4285   my ($f, $from, $to, $cond) = @_;
4286
4287     # Find a breakable line if there is one.
4288   my $i = breakable_line_in_filename($f, $from, $to);
4289
4290     # Find a breakable line if there is one.
4291   $cond = 1 unless @_ >= 3;
4292
4293     # Add the breakpoint.
4294   break_on_filename_line($f,$i,$cond);
4295 } ## end sub break_on_filename_line_range
4296
4297 =head3 subroutine_filename_lines(subname, [condition]) (API)
4298
4299 Search for a subroutine within a given file. The condition is ignored.
4300 Uses C<find_sub> to locate the desired subroutine.
4301
4302 =cut
4303
4304 sub subroutine_filename_lines {
4305   my ($subname,$cond) = @_;
4306
4307     # Returned value from find_sub() is fullpathname:startline-endline.
4308     # The match creates the list (fullpathname, start, end). Falling off
4309     # the end of the subroutine returns this implicitly.
4310   find_sub($subname) =~ /^(.*):(\d+)-(\d+)$/;
4311 } ## end sub subroutine_filename_lines
4312
4313 =head3 break_subroutine(subname) (API)
4314
4315 Places a break on the first line possible in the specified subroutine. Uses
4316 C<subroutine_filename_lines> to find the subroutine, and
4317 C<break_on_filename_line_range> to place the break.
4318
4319 =cut
4320
4321 sub break_subroutine {
4322   my $subname = shift;
4323
4324     # Get filename, start, and end.
4325   my ($file,$s,$e) = subroutine_filename_lines($subname)
4326     or die "Subroutine $subname not found.\n";
4327
4328     # Null condition changes to '1' (always true).
4329   $cond = 1 unless @_ >= 2;
4330
4331     # Put a break the first place possible in the range of lines
4332     # that make up this subroutine.
4333   break_on_filename_line_range($file,$s,$e,@_);
4334 } ## end sub break_subroutine
4335
4336 =head3 cmd_b_sub(subname, [condition]) (command)
4337
4338 We take the incoming subroutine name and fully-qualify it as best we can.
4339
4340 =over 4
4341
4342 =item 1. If it's already fully-qualified, leave it alone.
4343
4344 =item 2. Try putting it in the current package.
4345
4346 =item 3. If it's not there, try putting it in CORE::GLOBAL if it exists there.
4347
4348 =item 4. If it starts with '::', put it in 'main::'.
4349
4350 =back
4351
4352 After all this cleanup, we call C<break_subroutine> to try to set the
4353 breakpoint.
4354
4355 =cut
4356
4357 sub cmd_b_sub {
4358   my ($subname,$cond) = @_;
4359
4360     # Add always-true condition if we have none.
4361   $cond = 1 unless @_ >= 2;
4362
4363     # If the subname isn't a code reference, qualify it so that
4364     # break_subroutine() will work right.
4365     unless (ref $subname eq 'CODE') {
4366         # Not Perl4.
4367     $subname =~ s/\'/::/g;
4368     my $s = $subname;
4369
4370         # Put it in this package unless it's already qualified.
4371     $subname = "${'package'}::" . $subname
4372       unless $subname =~ /::/;
4373
4374         # Requalify it into CORE::GLOBAL if qualifying it into this
4375         # package resulted in its not being defined, but only do so
4376         # if it really is in CORE::GLOBAL.
4377     $subname = "CORE::GLOBAL::$s"
4378       if not defined &$subname
4379       and $s !~ /::/
4380       and defined &{"CORE::GLOBAL::$s"};
4381
4382         # Put it in package 'main' if it has a leading ::.
4383     $subname = "main".$subname if substr($subname,0,2) eq "::";
4384
4385     } ## end unless (ref $subname eq 'CODE')
4386
4387     # Try to set the breakpoint.
4388   eval { break_subroutine($subname,$cond); 1 } or do {
4389     local $\ = '';
4390     print $OUT $@ and return;
4391   }
4392 } ## end sub cmd_b_sub
4393
4394 =head3 C<cmd_B> - delete breakpoint(s) (command)
4395
4396 The command mostly parses the command line and tries to turn the argument
4397 into a line spec. If it can't, it uses the current line. It then calls
4398 C<delete_breakpoint> to actually do the work.
4399
4400 If C<*> is  specified, C<cmd_B> calls C<delete_breakpoint> with no arguments,
4401 thereby deleting all the breakpoints.
4402
4403 =cut
4404
4405 sub cmd_B {
4406     my $cmd    = shift;
4407
4408     # No line spec? Use dbline.
4409     # If there is one, use it if it's non-zero, or wipe it out if it is.
4410     my $line   = ($_[0] =~ /^\./) ? $dbline : shift || '';
4411     my $dbline = shift;
4412
4413     # If the line was dot, make the line the current one.
4414     $line =~ s/^\./$dbline/;
4415
4416     # If it's * we're deleting all the breakpoints.
4417     if ($line eq '*') {
4418         eval { &delete_breakpoint(); 1 } or print $OUT $@ and return;
4419     }
4420
4421     # If there is a line spec, delete the breakpoint on that line.
4422     elsif ($line =~ /^(\S.*)/) {
4423         eval { &delete_breakpoint($line || $dbline); 1 } or do {
4424                     local $\ = '';
4425                     print $OUT $@ and return;
4426                 };
4427     } ## end elsif ($line =~ /^(\S.*)/)
4428
4429     # No line spec.
4430     else {
4431         print $OUT
4432             "Deleting a breakpoint requires a line number, or '*' for all\n"
4433             ; # hint
4434     }
4435 } ## end sub cmd_B
4436
4437 =head3 delete_breakpoint([line]) (API)
4438
4439 This actually does the work of deleting either a single breakpoint, or all
4440 of them.
4441
4442 For a single line, we look for it in C<@dbline>. If it's nonbreakable, we
4443 just drop out with a message saying so. If it is, we remove the condition
4444 part of the 'condition\0action' that says there's a breakpoint here. If,
4445 after we've done that, there's nothing left, we delete the corresponding
4446 line in C<%dbline> to signal that no action needs to be taken for this line.
4447
4448 For all breakpoints, we iterate through the keys of C<%had_breakpoints>,
4449 which lists all currently-loaded files which have breakpoints. We then look
4450 at each line in each of these files, temporarily switching the C<%dbline>
4451 and C<@dbline> structures to point to the files in question, and do what
4452 we did in the single line case: delete the condition in C<@dbline>, and
4453 delete the key in C<%dbline> if nothing's left.
4454
4455 We then wholesale delete C<%postponed>, C<%postponed_file>, and
4456 C<%break_on_load>, because these structures contain breakpoints for files
4457 and code that haven't been loaded yet. We can just kill these off because there
4458 are no magical debugger structures associated with them.
4459
4460 =cut
4461
4462 sub delete_breakpoint {
4463   my $i = shift;
4464
4465     # If we got a line, delete just that one.
4466   if (defined($i)) {
4467
4468         # Woops. This line wasn't breakable at all.
4469       die "Line $i not breakable.\n" if $dbline[$i] == 0;
4470
4471         # Kill the condition, but leave any action.
4472       $dbline{$i} =~ s/^[^\0]*//;
4473
4474         # Remove the entry entirely if there's no action left.
4475       delete $dbline{$i} if $dbline{$i} eq '';
4476   }
4477
4478     # No line; delete them all.
4479   else {
4480           print $OUT "Deleting all breakpoints...\n";
4481
4482         # %had_breakpoints lists every file that had at least one
4483         # breakpoint in it.
4484           for my $file (keys %had_breakpoints) {
4485             # Switch to the desired file temporarily.
4486                     local *dbline = $main::{'_<' . $file};
4487
4488                     my $max = $#dbline;
4489                     my $was;
4490
4491             # For all lines in this file ...
4492                     for ($i = 1; $i <= $max ; $i++) {
4493                 # If there's a breakpoint or action on this line ...
4494                             if (defined $dbline{$i}) {
4495                     # ... remove the breakpoint.
4496                         $dbline{$i} =~ s/^[^\0]+//;
4497                         if ($dbline{$i} =~ s/^\0?$//) {
4498                         # Remove the entry altogether if no action is there.
4499                                 delete $dbline{$i};
4500                         }
4501                 } ## end if (defined $dbline{$i...
4502             } ## end for ($i = 1 ; $i <= $max...
4503
4504             # If, after we turn off the "there were breakpoints in this file"
4505             # bit, the entry in %had_breakpoints for this file is zero,
4506             # we should remove this file from the hash.
4507                     if (not $had_breakpoints{$file} &= ~1) {
4508                             delete $had_breakpoints{$file};
4509                     }
4510         } ## end for my $file (keys %had_breakpoints)
4511
4512         # Kill off all the other breakpoints that are waiting for files that
4513         # haven't been loaded yet.
4514           undef %postponed;
4515           undef %postponed_file;
4516           undef %break_on_load;
4517     } ## end else [ if (defined($i))
4518 } ## end sub delete_breakpoint
4519
4520 =head3 cmd_stop (command)
4521
4522 This is meant to be part of the new command API, but it isn't called or used
4523 anywhere else in the debugger. XXX It is probably meant for use in development
4524 of new commands.
4525
4526 =cut
4527
4528 sub cmd_stop {    # As on ^C, but not signal-safy.
4529     $signal = 1;
4530 }
4531
4532 sub cmd_stop {            # As on ^C, but not signal-safy.
4533   $signal = 1;
4534 }
4535
4536 =head3 C<cmd_h> - help command (command)
4537
4538 Does the work of either
4539
4540 =over 4
4541
4542 =item * Showing all the debugger help
4543
4544 =item * Showing help for a specific command
4545
4546 =back
4547
4548 =cut
4549
4550
4551 sub cmd_h {
4552     my $cmd    = shift;
4553
4554     # If we have no operand, assume null.
4555     my $line   = shift || '';
4556
4557     # 'h h'. Print the long-format help.
4558     if ($line  =~ /^h\s*/) {
4559         print_help($help);
4560     }
4561
4562     # 'h <something>'. Search for the command and print only its help.
4563     elsif ($line =~ /^(\S.*)$/) {
4564
4565         # support long commands; otherwise bogus errors
4566         # happen when you ask for h on <CR> for example
4567         my $asked  = $1;                # the command requested
4568                                         # (for proper error message)
4569
4570         my $qasked = quotemeta($asked); # for searching; we don't
4571                                         # want to use it as a pattern.
4572                                         # XXX: finds CR but not <CR>
4573
4574         # Search the help string for the command.
4575         if ($help =~ /^                    # Start of a line
4576                       <?                   # Optional '<'
4577                       (?:[IB]<)            # Optional markup
4578                       $qasked              # The requested command
4579                      /mx) {
4580             # It's there; pull it out and print it.
4581             while ($help =~ /^
4582                               (<?            # Optional '<'
4583                                  (?:[IB]<)   # Optional markup
4584                                  $qasked     # The command
4585                                  ([\s\S]*?)  # Description line(s)
4586                               \n)            # End of last description line
4587                               (?!\s)         # Next line not starting with
4588                                              # whitespace
4589                              /mgx) {
4590                 print_help($1);
4591               }
4592             }
4593
4594         # Not found; not a debugger command.
4595             else {
4596                 print_help("B<$asked> is not a debugger command.\n");
4597             }
4598     } ## end elsif ($line =~ /^(\S.*)$/)
4599
4600     # 'h' - print the summary help.
4601     else {
4602             print_help($summary);
4603     }
4604 } ## end sub cmd_h
4605
4606 =head3 C<cmd_i> - inheritance display
4607
4608 Display the (nested) parentage of the module or object given.
4609
4610 =cut
4611
4612 sub cmd_i {
4613     my $cmd  = shift;
4614     my $line = shift;
4615     eval { require Class::ISA };
4616     if ($@) {
4617         &warn($@ =~ /locate/ ? "Class::ISA module not found - please install\n" : $@);
4618     } else {
4619         ISA:
4620         foreach my $isa (split(/\s+/, $line)) {
4621           no strict 'refs';
4622           print join(', ', map { # snaffled unceremoniously from Class::ISA
4623                 "$_".(defined(${"$_\::VERSION"}) ? ' '.${"$_\::VERSION"} : undef)
4624               } Class::ISA::self_and_super_path($isa));
4625           print "\n";
4626         }
4627     }
4628 } ## end sub cmd_i
4629
4630 =head3 C<cmd_l> - list lines (command)
4631
4632 Most of the command is taken up with transforming all the different line
4633 specification syntaxes into 'start-stop'. After that is done, the command
4634 runs a loop over C<@dbline> for the specified range of lines. It handles
4635 the printing of each line and any markers (C<==E<gt>> for current line,
4636 C<b> for break on this line, C<a> for action on this line, C<:> for this
4637 line breakable).
4638
4639 We save the last line listed in the C<$start> global for further listing
4640 later.
4641
4642 =cut
4643
4644 sub cmd_l {
4645     my $current_line = $line;
4646     my $cmd    = shift;
4647     my $line = shift;
4648
4649     # If this is '-something', delete any spaces after the dash.
4650     $line =~ s/^-\s*$/-/;
4651
4652     # If the line is '$something', assume this is a scalar containing a
4653     # line number.
4654     if ($line =~ /^(\$.*)/s) {
4655
4656         # Set up for DB::eval() - evaluate in *user* context.
4657         $evalarg = $1;
4658         $evalarg = $2;
4659         my ($s) = &eval;
4660
4661         # Ooops. Bad scalar.
4662         print($OUT "Error: $@\n"), next CMD if $@;
4663
4664         # Good scalar. If it's a reference, find what it points to.
4665         $s = CvGV_name($s);
4666         print($OUT "Interpreted as: $1 $s\n");
4667         $line = "$1 $s";
4668
4669         # Call self recursively to really do the command.
4670         &cmd_l('l', $s);
4671     } ## end if ($line =~ /^(\$.*)/s)
4672
4673     # l name. Try to find a sub by that name.
4674     elsif ($line =~ /^([\':A-Za-z_][\':\w]*(\[.*\])?)/s) {
4675         my $s = $subname = $1;
4676
4677         # De-Perl4.
4678         $subname =~ s/\'/::/;
4679
4680         # Put it in this package unless it starts with ::.
4681         $subname = $package."::".$subname unless $subname =~ /::/;
4682
4683         # Put it in CORE::GLOBAL if t doesn't start with :: and
4684         # it doesn't live in this package and it lives in CORE::GLOBAL.
4685         $subname = "CORE::GLOBAL::$s"
4686         if not defined &$subname
4687             and $s !~ /::/
4688             and defined &{"CORE::GLOBAL::$s"};
4689
4690         # Put leading '::' names into 'main::'.
4691         $subname = "main".$subname if substr($subname,0,2) eq "::";
4692
4693         # Get name:start-stop from find_sub, and break this up at
4694         # colons.
4695         @pieces = split(/:/,find_sub($subname) || $sub{$subname});
4696
4697         # Pull off start-stop.
4698         $subrange = pop @pieces;
4699
4700         # If the name contained colons, the split broke it up.
4701         # Put it back together.
4702         $file = join(':', @pieces);
4703
4704         # If we're not in that file, switch over to it.
4705         if ($file ne $filename) {
4706             print $OUT "Switching to file '$file'.\n"
4707         unless $slave_editor;
4708
4709             # Switch debugger's magic structures.
4710             *dbline = $main::{'_<' . $file};
4711             $max = $#dbline;
4712             $filename = $file;
4713         } ## end if ($file ne $filename)
4714
4715         # Subrange is 'start-stop'. If this is less than a window full,
4716         # swap it to 'start+', which will list a window from the start point.
4717         if ($subrange) {
4718             if (eval($subrange) < -$window) {
4719         $subrange =~ s/-.*/+/;
4720             }
4721             # Call self recursively to list the range.
4722             $line = $subrange;
4723             &cmd_l('l', $subrange);
4724         } ## end if ($subrange)
4725
4726         # Couldn't find it.
4727         else {
4728             print $OUT "Subroutine $subname not found.\n";
4729         }
4730     } ## end elsif ($line =~ /^([\':A-Za-z_][\':\w]*(\[.*\])?)/s)
4731
4732     # Bare 'l' command.
4733     elsif ($line =~ /^\s*$/) {
4734         # Compute new range to list.
4735         $incr = $window - 1;
4736         $line = $start . '-' . ($start + $incr);
4737         # Recurse to do it.
4738         &cmd_l('l', $line);
4739     }
4740
4741     # l [start]+number_of_lines
4742     elsif ($line =~ /^(\d*)\+(\d*)$/) {
4743         # Don't reset start for 'l +nnn'.
4744         $start = $1 if $1;
4745
4746         # Increment for list. Use window size if not specified.
4747         # (Allows 'l +' to work.)
4748         $incr = $2;
4749         $incr = $window - 1 unless $incr;
4750
4751         # Create a line range we'll understand, and recurse to do it.
4752         $line = $start . '-' . ($start + $incr);
4753         &cmd_l('l', $line);
4754     } ## end elsif ($line =~ /^(\d*)\+(\d*)$/)
4755
4756     # l start-stop or l start,stop
4757     elsif ($line =~ /^((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/) {
4758
4759         # Determine end point; use end of file if not specified.
4760         $end = (!defined $2) ? $max : ($4 ? $4 : $2);
4761
4762         # Go on to the end, and then stop.
4763         $end = $max if $end > $max;
4764
4765         # Determine start line.
4766         $i = $2;
4767         $i = $line if $i eq '.';
4768         $i = 1 if $i < 1;
4769         $incr = $end - $i;
4770
4771         # If we're running under a slave editor, force it to show the lines.
4772         if ($slave_editor) {
4773             print $OUT "\032\032$filename:$i:0\n";
4774             $i = $end;
4775         }
4776
4777         # We're doing it ourselves. We want to show the line and special
4778         # markers for:
4779         # - the current line in execution
4780         # - whether a line is breakable or not
4781         # - whether a line has a break or not
4782         # - whether a line has an action or not
4783         else {
4784             for (; $i <= $end; $i++) {
4785                 # Check for breakpoints and actions.
4786                 my ($stop,$action);
4787                 ($stop,$action) = split(/\0/, $dbline{$i})
4788                     if $dbline{$i};
4789
4790                 # ==> if this is the current line in execution,
4791                 # : if it's breakable.
4792                 $arrow = ($i==$current_line and $filename eq $filename_ini)
4793                   ?  '==>'
4794                   : ($dbline[$i]+0 ? ':' : ' ');
4795
4796                 # Add break and action indicators.
4797                 $arrow .= 'b' if $stop;
4798                 $arrow .= 'a' if $action;
4799
4800                 # Print the line.
4801                 print $OUT "$i$arrow\t", $dbline[$i];
4802
4803                 # Move on to the next line. Drop out on an interrupt.
4804                 $i++, last if $signal;
4805             } ## end for (; $i <= $end ; $i++)
4806
4807             # Line the prompt up; print a newline if the last line listed
4808             # didn't have a newline.
4809             print $OUT "\n" unless $dbline[$i-1] =~ /\n$/;
4810         } ## end else [ if ($slave_editor)
4811
4812         # Save the point we last listed to in case another relative 'l'
4813         # command is desired. Don't let it run off the end.
4814         $start = $i;
4815         $start = $max if $start > $max;
4816     } ## end elsif ($line =~ /^((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/)
4817 } ## end sub cmd_l
4818
4819 =head3 C<cmd_L> - list breakpoints, actions, and watch expressions (command)
4820
4821 To list breakpoints, the command has to look determine where all of them are
4822 first. It starts a C<%had_breakpoints>, which tells us what all files have
4823 breakpoints and/or actions. For each file, we switch the C<*dbline> glob (the
4824 magic source and breakpoint data structures) to the file, and then look
4825 through C<%dbline> for lines with breakpoints and/or actions, listing them
4826 out. We look through C<%postponed> not-yet-compiled subroutines that have
4827 breakpoints, and through C<%postponed_file> for not-yet-C<require>'d files
4828 that have breakpoints.
4829
4830 Watchpoints are simpler: we just list the entries in C<@to_watch>.
4831
4832 =cut
4833
4834 sub cmd_L {
4835     my $cmd    = shift;
4836
4837     # If no argument, list everything. Pre-5.8.0 version always lists
4838     # everything
4839     my $arg    = shift || 'abw';
4840     $arg = 'abw' unless $CommandSet eq '580'; # sigh...
4841
4842     # See what is wanted.
4843     my $action_wanted = ($arg =~ /a/) ? 1 : 0;
4844     my $break_wanted  = ($arg =~ /b/) ? 1 : 0;
4845     my $watch_wanted  = ($arg =~ /w/) ? 1 : 0;
4846
4847     # Breaks and actions are found together, so we look in the same place
4848     # for both.
4849     if ($break_wanted or $action_wanted) {
4850         # Look in all the files with breakpoints...
4851         for my $file (keys %had_breakpoints) {
4852             # Temporary switch to this file.
4853             local *dbline = $main::{ '_<' . $file };
4854
4855             # Set up to look through the whole file.
4856             my $max = $#dbline;
4857             my $was;                         # Flag: did we print something
4858                                              # in this file?
4859
4860             # For each line in the file ...
4861             for ($i = 1; $i <= $max ; $i++) {
4862                 # We've got something on this line.
4863                 if (defined $dbline{$i}) {
4864                     # Print the header if we haven't.
4865                     print $OUT "$file:\n" unless $was++;
4866
4867                     # Print the line.
4868                     print $OUT " $i:\t", $dbline[$i];
4869
4870                     # Pull out the condition and the action.
4871                     ($stop, $action) = split (/\0/, $dbline{$i});
4872
4873                     # Print the break if there is one and it's wanted.
4874                     print $OUT "   break if (", $stop, ")\n"
4875                         if $stop
4876                         and $break_wanted;
4877
4878                     # Print the action if there is one and it's wanted.
4879                     print $OUT "   action:  ", $action, "\n"
4880                         if $action
4881                         and $action_wanted;
4882
4883                     # Quit if the user hit interrupt.
4884                     last if $signal;
4885                 } ## end if (defined $dbline{$i...
4886             } ## end for ($i = 1 ; $i <= $max...
4887         } ## end for my $file (keys %had_breakpoints)
4888     } ## end if ($break_wanted or $action_wanted)
4889
4890     # Look for breaks in not-yet-compiled subs:
4891     if (%postponed and $break_wanted) {
4892         print $OUT "Postponed breakpoints in subroutines:\n";
4893         my $subname;
4894         for $subname (keys %postponed) {
4895           print $OUT " $subname\t$postponed{$subname}\n";
4896           last if $signal;
4897         }
4898     } ## end if (%postponed and $break_wanted)
4899
4900     # Find files that have not-yet-loaded breaks:
4901     my @have = map { # Combined keys
4902             keys %{$postponed_file{$_}}
4903     } keys %postponed_file;
4904
4905     # If there are any, list them.
4906     if (@have and ($break_wanted or $action_wanted)) {
4907         print $OUT "Postponed breakpoints in files:\n";
4908         my ($file, $line);
4909
4910         for $file (keys %postponed_file) {
4911           my $db = $postponed_file{$file};
4912           print $OUT " $file:\n";
4913           for $line (sort { $a <=> $b } keys %$db) {
4914             print $OUT "  $line:\n";
4915             my ($stop, $action) = split (/\0/, $$db{$line});
4916             print $OUT "    break if (", $stop, ")\n"
4917               if $stop
4918               and $break_wanted;
4919             print $OUT "    action:  ", $action, "\n"
4920               if $action
4921               and $action_wanted;
4922             last if $signal;
4923           } ## end for $line (sort { $a <=>...
4924           last if $signal;
4925         } ## end for $file (keys %postponed_file)
4926     } ## end if (@have and ($break_wanted...
4927     if (%break_on_load and $break_wanted) {
4928         print $OUT "Breakpoints on load:\n";
4929         my $file;
4930         for $file (keys %break_on_load) {
4931           print $OUT " $file\n";
4932           last if $signal;
4933         }
4934   } ## end if (%break_on_load and...
4935   if ($watch_wanted) {
4936     if ($trace & 2) {
4937         print $OUT "Watch-expressions:\n" if @to_watch;
4938         for my $expr (@to_watch) {
4939             print $OUT " $expr\n";
4940             last if $signal;
4941         }
4942         } ## end if ($trace & 2)
4943     } ## end if ($watch_wanted)
4944 } ## end sub cmd_L
4945
4946 =head3 C<cmd_M> - list modules (command)
4947
4948 Just call C<list_modules>.
4949
4950 =cut
4951
4952 sub cmd_M {
4953     &list_modules();
4954 }
4955
4956 =head3 C<cmd_o> - options (command)
4957
4958 If this is just C<o> by itself, we list the current settings via
4959 C<dump_option>. If there's a nonblank value following it, we pass that on to
4960 C<parse_options> for processing.
4961
4962 =cut
4963
4964 sub cmd_o {
4965     my $cmd    = shift;
4966     my $opt      = shift || ''; # opt[=val]
4967
4968     # Nonblank. Try to parse and process.
4969     if ($opt =~ /^(\S.*)/) {
4970         &parse_options($1);
4971     }
4972
4973     # Blank. List the current option settings.
4974     else {
4975         for (@options) {
4976             &dump_option($_);
4977         }
4978     }
4979 } ## end sub cmd_o
4980
4981 =head3 C<cmd_O> - nonexistent in 5.8.x (command)
4982
4983 Advises the user that the O command has been renamed.
4984
4985 =cut
4986
4987 sub cmd_O {
4988     print $OUT "The old O command is now the o command.\n";        # hint
4989     print $OUT "Use 'h' to get current command help synopsis or\n"; #
4990     print $OUT "use 'o CommandSet=pre580' to revert to old usage\n"; #
4991 }
4992
4993 =head3 C<cmd_v> - view window (command)
4994
4995 Uses the C<$preview> variable set in the second C<BEGIN> block (q.v.) to
4996 move back a few lines to list the selected line in context. Uses C<cmd_l>
4997 to do the actual listing after figuring out the range of line to request.
4998
4999 =cut
5000
5001 sub cmd_v {
5002     my $cmd    = shift;
5003     my $line = shift;
5004
5005     # Extract the line to list around. (Astute readers will have noted that
5006     # this pattern will match whether or not a numeric line is specified,
5007     # which means that we'll always enter this loop (though a non-numeric
5008     # argument results in no action at all)).
5009     if ($line =~ /^(\d*)$/) {
5010         # Total number of lines to list (a windowful).
5011         $incr = $window - 1;
5012
5013         # Set the start to the argument given (if there was one).
5014         $start = $1 if $1;
5015
5016         # Back up by the context amount.
5017         $start -= $preview;
5018
5019         # Put together a linespec that cmd_l will like.
5020         $line = $start . '-' . ($start + $incr);
5021
5022         # List the lines.
5023         &cmd_l('l', $line);
5024     } ## end if ($line =~ /^(\d*)$/)
5025 } ## end sub cmd_v
5026
5027 =head3 C<cmd_w> - add a watch expression (command)
5028
5029 The 5.8 version of this command adds a watch expression if one is specified;
5030 it does nothing if entered with no operands.
5031
5032 We extract the expression, save it, evaluate it in the user's context, and
5033 save the value. We'll re-evaluate it each time the debugger passes a line,
5034 and will stop (see the code at the top of the command loop) if the value
5035 of any of the expressions changes.
5036
5037 =cut
5038
5039 sub cmd_w {
5040     my $cmd  = shift;
5041
5042     # Null expression if no arguments.
5043     my $expr = shift || '';
5044
5045     # If expression is not null ...
5046     if ($expr =~ /^(\S.*)/) {
5047         # ... save it.
5048         push @to_watch, $expr;
5049
5050         # Parameterize DB::eval and call it to get the expression's value
5051         # in the user's context. This version can handle expressions which
5052         # return a list value.
5053         $evalarg = $expr;
5054         my ($val) = join(' ', &eval);
5055         $val = (defined $val) ? "'$val'" : 'undef';
5056
5057         # Save the current value of the expression.
5058         push @old_watch, $val;
5059
5060         # We are now watching expressions.
5061         $trace |= 2;
5062     } ## end if ($expr =~ /^(\S.*)/)
5063
5064     # You have to give one to get one.
5065     else {
5066         print $OUT
5067             "Adding a watch-expression requires an expression\n"; # hint
5068     }
5069 } ## end sub cmd_w
5070
5071 =head3 C<cmd_W> - delete watch expressions (command)
5072
5073 This command accepts either a watch expression to be removed from the list
5074 of watch expressions, or C<*> to delete them all.
5075
5076 If C<*> is specified, we simply empty the watch expression list and the
5077 watch expression value list. We also turn off the bit that says we've got
5078 watch expressions.
5079
5080 If an expression (or partial expression) is specified, we pattern-match
5081 through the expressions and remove the ones that match. We also discard
5082 the corresponding values. If no watch expressions are left, we turn off
5083 the 'watching expressions' bit.
5084
5085 =cut
5086
5087 sub cmd_W {
5088     my $cmd  = shift;
5089     my $expr = shift || '';
5090
5091     # Delete them all.
5092     if ($expr eq '*') {
5093         # Not watching now.
5094         $trace &= ~2;
5095
5096         print $OUT "Deleting all watch expressions ...\n";
5097
5098         # And all gone.
5099         @to_watch = @old_watch = ();
5100     }
5101
5102     # Delete one of them.
5103     elsif ($expr =~ /^(\S.*)/) {
5104         # Where we are in the list.
5105         my $i_cnt = 0;
5106
5107         # For each expression ...
5108         foreach (@to_watch) {
5109             my $val = $to_watch[$i_cnt];
5110
5111             # Does this one match the command argument?
5112             if ($val eq $expr) { # =~ m/^\Q$i$/) {
5113                 splice(@to_watch, $i_cnt, 1);
5114             }
5115             $i_cnt++;
5116         } ## end foreach (@to_watch)
5117
5118         # We don't bother to turn watching off because
5119         #  a) we don't want to stop calling watchfunction() it it exists
5120         #  b) foreach over a null list doesn't do anything anyway
5121
5122     } ## end elsif ($expr =~ /^(\S.*)/)
5123
5124     else {
5125         print $OUT
5126 "Deleting a watch-expression requires an expression, or '*' for all\n"
5127           ; # hint
5128     }
5129 } ## end sub cmd_W
5130
5131 ### END of the API section
5132
5133 =head1 SUPPORT ROUTINES
5134
5135 These are general support routines that are used in a number of places
5136 throughout the debugger.
5137
5138 =item cmd_P
5139
5140 Something to do with assertions
5141
5142 =cut
5143
5144 sub cmd_P {
5145   if ($cmd =~ /^.\b\s*([+-]?)\s*(~?)\s*(\w+(\s*\|\s*\w+)*)\s*$/) {
5146     my ($how, $neg, $flags)=($1, $2, $3);
5147     my $acu=parse_DollarCaretP_flags($flags);
5148     if (defined $acu) {
5149       $acu= ~$acu if $neg;
5150       if ($how eq '+') { $^P|=$acu }
5151       elsif ($how eq '-') { $^P&=~$acu }
5152       else { $^P=$acu }
5153     }
5154     # else { print $OUT "undefined acu\n" }
5155   }
5156   my $expanded=expand_DollarCaretP_flags($^P);
5157   print $OUT "Internal Perl debugger flags:\n\$^P=$expanded\n";
5158   $expanded
5159 }
5160
5161 =head2 save
5162
5163 save() saves the user's versions of globals that would mess us up in C<@saved>,
5164 and installs the versions we like better.
5165
5166 =cut
5167
5168 sub save {
5169     # Save eval failure, command failure, extended OS error, output field
5170     # separator, input record separator, output record separator and
5171     # the warning setting.
5172     @saved = ($@, $!, $^E, $,, $/, $\, $^W);
5173
5174     $,     = "";             # output field separator is null string
5175     $/     = "\n";           # input record separator is newline
5176     $\     = "";             # output record separator is null string
5177     $^W    = 0;              # warnings are off
5178 } ## end sub save
5179
5180 =head2 C<print_lineinfo> - show where we are now
5181
5182 print_lineinfo prints whatever it is that it is handed; it prints it to the
5183 C<$LINEINFO> filehandle instead of just printing it to STDOUT. This allows
5184 us to feed line information to a slave editor without messing up the
5185 debugger output.
5186
5187 =cut
5188
5189 sub print_lineinfo {
5190     # Make the terminal sensible if we're not the primary debugger.
5191   resetterm(1) if $LINEINFO eq $OUT and $term_pid != $$;
5192   local $\ = '';
5193   local $, = '';
5194   print $LINEINFO @_;
5195 } ## end sub print_lineinfo
5196
5197 =head2 C<postponed_sub>
5198
5199 Handles setting postponed breakpoints in subroutines once they're compiled.
5200 For breakpoints, we use C<DB::find_sub> to locate the source file and line
5201 range for the subroutine, then mark the file as having a breakpoint,
5202 temporarily switch the C<*dbline> glob over to the source file, and then
5203 search the given range of lines to find a breakable line. If we find one,
5204 we set the breakpoint on it, deleting the breakpoint from C<%postponed>.
5205
5206 =cut
5207
5208 # The following takes its argument via $evalarg to preserve current @_
5209
5210 sub postponed_sub {
5211     # Get the subroutine name.
5212   my $subname = shift;
5213
5214     # If this is a 'break +<n> if <condition>' ...
5215   if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) {
5216         # If there's no offset, use '+0'.
5217     my $offset = $1 || 0;
5218
5219         # find_sub's value is 'fullpath-filename:start-stop'. It's
5220         # possible that the filename might have colons in it too.
5221     my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
5222     if ($i) {
5223             # We got the start line. Add the offset '+<n>' from
5224             # $postponed{subname}.
5225       $i += $offset;
5226
5227             # Switch to the file this sub is in, temporarily.
5228       local *dbline = $main::{'_<' . $file};
5229
5230             # No warnings, please.
5231       local $^W = 0;        # != 0 is magical below
5232
5233             # This file's got a breakpoint in it.
5234       $had_breakpoints{$file} |= 1;
5235
5236             # Last line in file.
5237       my $max = $#dbline;
5238
5239             # Search forward until we hit a breakable line or get to
5240             # the end of the file.
5241       ++$i until $dbline[$i] != 0 or $i >= $max;
5242
5243             # Copy the breakpoint in and delete it from %postponed.
5244       $dbline{$i} = delete $postponed{$subname};
5245         } ## end if ($i)
5246
5247         # find_sub didn't find the sub.
5248     else {
5249       local $\ = '';
5250       print $OUT "Subroutine $subname not found.\n";
5251     }
5252     return;
5253   }
5254   elsif ($postponed{$subname} eq 'compile') { $signal = 1 }
5255   #print $OUT "In postponed_sub for `$subname'.\n";
5256 }
5257
5258 =head2 C<postponed>
5259
5260 Called after each required file is compiled, but before it is executed;
5261 also called if the name of a just-compiled subroutine is a key of
5262 C<%postponed>. Propagates saved breakpoints (from C<b compile>, C<b load>,
5263 etc.) into the just-compiled code.
5264
5265 If this is a C<require>'d file, the incoming parameter is the glob
5266 C<*{"_<$filename"}>, with C<$filename> the name of the C<require>'d file.
5267
5268 If it's a subroutine, the incoming parameter is the subroutine name.
5269
5270 =cut
5271
5272 sub postponed {
5273     # If there's a break, process it.
5274     if ($ImmediateStop) {
5275     # Right, we've stopped. Turn it off.
5276     $ImmediateStop = 0;
5277
5278     # Enter the command loop when DB::DB gets called.
5279     $signal = 1;
5280     }
5281
5282     # If this is a subroutine, let postponed_sub() deal with it.
5283     return &postponed_sub unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
5284
5285     # Not a subroutine. Deal with the file.
5286     local *dbline = shift;
5287     my $filename = $dbline;
5288     $filename =~ s/^_<//;
5289     local $\ = '';
5290     $signal = 1, print $OUT "'$filename' loaded...\n"
5291     if $break_on_load{$filename};
5292     print_lineinfo(' ' x $stack_depth, "Package $filename.\n") if $frame;
5293
5294     # Do we have any breakpoints to put in this file?
5295     return unless $postponed_file{$filename};
5296
5297     # Yes. Mark this file as having breakpoints.
5298     $had_breakpoints{$filename} |= 1;
5299
5300     # "Cannot be done: unsufficient magic" - we can't just put the
5301     # breakpoints saved in %postponed_file into %dbline by assigning
5302     # the whole hash; we have to do it one item at a time for the
5303     # breakpoints to be set properly.
5304     #%dbline = %{$postponed_file{$filename}};
5305
5306     # Set the breakpoints, one at a time.
5307     my $key;
5308
5309     for $key (keys %{ $postponed_file{$filename} }) {
5310     # Stash the saved breakpoint into the current file's magic line array.
5311     $dbline{$key} = ${ $postponed_file{$filename} }{$key};
5312     }
5313
5314     # This file's been compiled; discard the stored breakpoints.
5315     delete $postponed_file{$filename};
5316
5317 } ## end sub postponed
5318
5319 =head2 C<dumpit>
5320
5321 C<dumpit> is the debugger's wrapper around dumpvar.pl.
5322
5323 It gets a filehandle (to which C<dumpvar.pl>'s output will be directed) and
5324 a reference to a variable (the thing to be dumped) as its input.
5325
5326 The incoming filehandle is selected for output (C<dumpvar.pl> is printing to
5327 the currently-selected filehandle, thank you very much). The current
5328 values of the package globals C<$single> and C<$trace> are backed up in
5329 lexicals, and they are turned off (this keeps the debugger from trying
5330 to single-step through C<dumpvar.pl> (I think.)). C<$frame> is localized to
5331 preserve its current value and it is set to zero to prevent entry/exit
5332 messages from printing, and C<$doret> is localized as well and set to -2 to
5333 prevent return values from being shown.
5334
5335 C<dumpit()> then checks to see if it needs to load C<dumpvar.pl> and
5336 tries to load it (note: if you have a C<dumpvar.pl>  ahead of the
5337 installed version in @INC, yours will be used instead. Possible security
5338 problem?).
5339
5340 It then checks to see if the subroutine C<main::dumpValue> is now defined
5341 (it should have been defined by C<dumpvar.pl>). If it has, C<dumpit()>
5342 localizes the globals necessary for things to be sane when C<main::dumpValue()>
5343 is called, and picks up the variable to be dumped from the parameter list.
5344
5345 It checks the package global C<%options> to see if there's a C<dumpDepth>
5346 specified. If not, -1 is assumed; if so, the supplied value gets passed on to
5347 C<dumpvar.pl>. This tells C<dumpvar.pl> where to leave off when dumping a
5348 structure: -1 means dump everything.
5349
5350 C<dumpValue()> is then called if possible; if not, C<dumpit()>just prints a
5351 warning.
5352
5353 In either case, C<$single>, C<$trace>, C<$frame>, and C<$doret> are restored
5354 and we then return to the caller.
5355
5356 =cut
5357
5358 sub dumpit {
5359     # Save the current output filehandle and switch to the one
5360     # passed in as the first parameter.
5361     local ($savout) = select(shift);
5362
5363     # Save current settings of $single and $trace, and then turn them off.
5364     my $osingle = $single;
5365     my $otrace  = $trace;
5366     $single = $trace = 0;
5367
5368     # XXX Okay, what do $frame and $doret do, again?
5369     local $frame = 0;
5370     local $doret = -2;
5371
5372     # Load dumpvar.pl unless we've already got the sub we need from it.
5373     unless (defined &main::dumpValue) {
5374         do 'dumpvar.pl';
5375     }
5376
5377     # If the load succeeded (or we already had dumpvalue()), go ahead
5378     # and dump things.
5379     if (defined &main::dumpValue) {
5380         local $\ = '';
5381         local $, = '';
5382         local $" = ' ';
5383         my $v = shift;
5384         my $maxdepth = shift || $option{dumpDepth};
5385         $maxdepth = -1 unless defined $maxdepth;   # -1 means infinite depth
5386     &main::dumpValue($v, $maxdepth);
5387     } ## end if (defined &main::dumpValue)
5388
5389     # Oops, couldn't load dumpvar.pl.
5390     else {
5391         local $\ = '';
5392     print $OUT "dumpvar.pl not available.\n";
5393     }
5394
5395     # Reset $single and $trace to their old values.
5396     $single = $osingle;
5397     $trace = $otrace;
5398
5399     # Restore the old filehandle.
5400     select ($savout);
5401 } ## end sub dumpit
5402
5403 =head2 C<print_trace>
5404
5405 C<print_trace>'s job is to print a stack trace. It does this via the
5406 C<dump_trace> routine, which actually does all the ferreting-out of the
5407 stack trace data. C<print_trace> takes care of formatting it nicely and
5408 printing it to the proper filehandle.
5409
5410 Parameters:
5411
5412 =over 4
5413
5414 =item * The filehandle to print to.
5415
5416 =item * How many frames to skip before starting trace.
5417
5418 =item * How many frames to print.
5419
5420 =item * A flag: if true, print a "short" trace without filenames, line numbers, or arguments
5421
5422 =back
5423
5424 The original comment below seems to be noting that the traceback may not be
5425 correct if this routine is called in a tied method.
5426
5427 =cut
5428
5429 # Tied method do not create a context, so may get wrong message:
5430
5431 sub print_trace {
5432   local $\ = '';
5433   my $fh = shift;
5434     # If this is going to a slave editor, but we're not the primary
5435     # debugger, reset it first.
5436   resetterm(1)
5437       if $fh eq $LINEINFO          # slave editor
5438       and $LINEINFO eq $OUT        # normal output
5439       and $term_pid != $$;         # not the primary
5440
5441     # Collect the actual trace information to be formatted.
5442     # This is an array of hashes of subroutine call info.
5443   my @sub = dump_trace($_[0] + 1, $_[1]);
5444
5445     # Grab the "short report" flag from @_.
5446   my $short = $_[2];        # Print short report, next one for sub name
5447
5448     # Run through the traceback info, format it, and print it.
5449   my $s;
5450   for ($i=0; $i <= $#sub; $i++) {
5451         # Drop out if the user has lost interest and hit control-C.
5452     last if $signal;
5453
5454         # Set the separator so arrys print nice.
5455     local $" = ', ';
5456
5457         # Grab and stringify the arguments if they are there.
5458     my $args =
5459         defined $sub[$i]{args}
5460         ? "(@{ $sub[$i]{args} })"
5461           : '' ;
5462         # Shorten them up if $maxtrace says they're too long.
5463     $args = (substr $args, 0, $maxtrace - 3) . '...'
5464       if length $args > $maxtrace;
5465
5466         # Get the file name.
5467     my $file = $sub[$i]{file};
5468
5469         # Put in a filename header if short is off.
5470     $file = $file eq '-e' ? $file : "file `$file'" unless $short;
5471
5472         # Get the actual sub's name, and shorten to $maxtrace's requirement.
5473     $s = $sub[$i]{sub};
5474     $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace;
5475
5476         # Short report uses trimmed file and sub names.
5477     if ($short) {
5478       my $sub = @_ >= 4 ? $_[3] : $s;
5479       print $fh
5480         "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
5481     } ## end if ($short)
5482
5483         # Non-short report includes full names.
5484     else {
5485       print $fh "$sub[$i]{context} = $s$args" .  " called from $file" .
5486       " line $sub[$i]{line}\n";
5487     }
5488     } ## end for ($i = 0 ; $i <= $#sub...
5489 } ## end sub print_trace
5490
5491 =head2 dump_trace(skip[,count])
5492
5493 Actually collect the traceback information available via C<caller()>. It does
5494 some filtering and cleanup of the data, but mostly it just collects it to
5495 make C<print_trace()>'s job easier.
5496
5497 C<skip> defines the number of stack frames to be skipped, working backwards
5498 from the most current. C<count> determines the total number of frames to
5499 be returned; all of them (well, the first 10^9) are returned if C<count>
5500 is omitted.
5501
5502 This routine returns a list of hashes, from most-recent to least-recent
5503 stack frame. Each has the following keys and values:
5504
5505 =over 4
5506
5507 =item * C<context> - C<.> (null), C<$> (scalar), or C<@> (array)
5508
5509 =item * C<sub> - subroutine name, or C<eval> information
5510
5511 =item * C<args> - undef, or a reference to an array of arguments
5512
5513 =item * C<file> - the file in which this item was defined (if any)
5514
5515 =item * C<line> - the line on which it was defined
5516
5517 =back
5518
5519 =cut
5520
5521 sub dump_trace {
5522
5523     # How many levels to skip.
5524   my $skip = shift;
5525
5526     # How many levels to show. (1e9 is a cheap way of saying "all of them";
5527     # it's unlikely that we'll have more than a billion stack frames. If you
5528     # do, you've got an awfully big machine...)
5529   my $count = shift || 1e9;
5530
5531     # We increment skip because caller(1) is the first level *back* from
5532     # the current one.  Add $skip to the count of frames so we have a
5533     # simple stop criterion, counting from $skip to $count+$skip.
5534   $skip++;
5535   $count += $skip;
5536
5537     # These variables are used to capture output from caller();
5538     my ($p, $file, $line, $sub, $h, $context);
5539
5540     my ($e, $r, @a, @sub, $args);
5541
5542     # XXX Okay... why'd we do that?
5543   my $nothard = not $frame & 8;
5544   local $frame = 0;
5545
5546     # Do not want to trace this.
5547   my $otrace = $trace;
5548   $trace = 0;
5549
5550     # Start out at the skip count.
5551     # If we haven't reached the number of frames requested, and caller() is
5552     # still returning something, stay in the loop. (If we pass the requested
5553     # number of stack frames, or we run out - caller() returns nothing - we
5554     # quit.
5555     # Up the stack frame index to go back one more level each time.
5556   for (
5557        $i = $skip;
5558        $i < $count
5559        and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i);
5560        $i++
5561       )
5562     {
5563
5564         # Go through the arguments and save them for later.
5565     @a = ();
5566     for $arg (@args) {
5567       my $type;
5568       if (not defined $arg) {
5569     push @a, "undef";
5570       }
5571
5572       elsif ($nothard and tied $arg) {
5573     push @a, "tied";
5574       }
5575       elsif ($nothard and $type = ref $arg) {
5576     push @a, "ref($type)";
5577       }
5578       else {
5579     local $_ =
5580             "$arg";    # Safe to stringify now - should not call f().
5581
5582                 # Backslash any single-quotes or backslashes.
5583     s/([\'\\])/\\$1/g;
5584
5585                 # Single-quote it unless it's a number or a colon-separated
5586                 # name.
5587     s/(.*)/'$1'/s
5588       unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
5589
5590                 # Turn high-bit characters into meta-whatever.
5591     s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
5592
5593                 # Turn control characters into ^-whatever.
5594     s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
5595
5596     push(@a, $_);
5597             } ## end else [ if (not defined $arg)
5598         } ## end for $arg (@args)
5599
5600         # If context is true, this is array (@)context.
5601         # If context is false, this is scalar ($) context.
5602         # If neither, context isn't defined. (This is apparently a 'can't
5603         # happen' trap.)
5604     $context = $context ? '@' : (defined $context ? "\$" : '.');
5605
5606         # if the sub has args ($h true), make an anonymous array of the
5607         # dumped args.
5608     $args = $h ? [@a] : undef;
5609
5610         # remove trailing newline-whitespace-semicolon-end of line sequence
5611         # from the eval text, if any.
5612     $e =~ s/\n\s*\;\s*\Z// if $e;
5613
5614         # Escape backslashed single-quotes again if necessary.
5615     $e =~ s/([\\\'])/\\$1/g if $e;
5616
5617         # if the require flag is true, the eval text is from a require.
5618     if ($r) {
5619       $sub = "require '$e'";
5620     }
5621         # if it's false, the eval text is really from an eval.
5622     elsif (defined $r) {
5623       $sub = "eval '$e'";
5624     }
5625
5626         # If the sub is '(eval)', this is a block eval, meaning we don't
5627         # know what the eval'ed text actually was.
5628     elsif ($sub eq '(eval)') {
5629       $sub = "eval {...}";
5630     }
5631
5632         # Stick the collected information into @sub as an anonymous hash.
5633     push (
5634         @sub,
5635         {
5636             context => $context,
5637             sub     => $sub,
5638             args    => $args,
5639             file    => $file,
5640             line    => $line
5641         }
5642         );
5643
5644         # Stop processing frames if the user hit control-C.
5645     last if $signal;
5646     } ## end for ($i = $skip ; $i < ...
5647
5648     # Restore the trace value again.
5649   $trace = $otrace;
5650   @sub;
5651 } ## end sub dump_trace
5652
5653 =head2 C<action()>
5654
5655 C<action()> takes input provided as the argument to an add-action command,
5656 either pre- or post-, and makes sure it's a complete command. It doesn't do
5657 any fancy parsing; it just keeps reading input until it gets a string
5658 without a trailing backslash.
5659
5660 =cut
5661
5662 sub action {
5663     my $action = shift;
5664
5665     while ($action =~ s/\\$//) {
5666         # We have a backslash on the end. Read more.
5667     $action .= &gets;
5668     } ## end while ($action =~ s/\\$//)
5669
5670     # Return the assembled action.
5671     $action;
5672 } ## end sub action
5673
5674 =head2 unbalanced
5675
5676 This routine mostly just packages up a regular expression to be used
5677 to check that the thing it's being matched against has properly-matched
5678 curly braces.
5679
5680 Of note is the definition of the $balanced_brace_re global via ||=, which
5681 speeds things up by only creating the qr//'ed expression once; if it's
5682 already defined, we don't try to define it again. A speed hack.
5683
5684 =cut
5685
5686 sub unbalanced {
5687
5688     # I hate using globals!
5689     $balanced_brace_re ||= qr{
5690     ^ \{
5691           (?:
5692          (?> [^{}] + )            # Non-parens without backtracking
5693            |
5694          (??{ $balanced_brace_re }) # Group with matching parens
5695           ) *
5696       \} $
5697    }x;
5698    return $_[0] !~ m/$balanced_brace_re/;
5699 } ## end sub unbalanced
5700
5701 =head2 C<gets()>
5702
5703 C<gets()> is a primitive (very primitive) routine to read continuations.
5704 It was devised for reading continuations for actions.
5705 it just reads more input with X<C<readline()>> and returns it.
5706
5707 =cut
5708
5709 sub gets {
5710     &readline("cont: ");
5711 }
5712
5713 =head2 C<DB::system()> - handle calls to<system()> without messing up the debugger
5714
5715 The C<system()> function assumes that it can just go ahead and use STDIN and
5716 STDOUT, but under the debugger, we want it to use the debugger's input and
5717 outout filehandles.
5718
5719 C<DB::system()> socks away the program's STDIN and STDOUT, and then substitutes
5720 the debugger's IN and OUT filehandles for them. It does the C<system()> call,
5721 and then puts everything back again.
5722
5723 =cut
5724
5725 sub system {
5726     # We save, change, then restore STDIN and STDOUT to avoid fork() since
5727     # some non-Unix systems can do system() but have problems with fork().
5728     open(SAVEIN,"<&STDIN")   || &warn("Can't save STDIN");
5729     open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
5730     open(STDIN,"<&IN")       || &warn("Can't redirect STDIN");
5731     open(STDOUT,">&OUT")     || &warn("Can't redirect STDOUT");
5732
5733     # XXX: using csh or tcsh destroys sigint retvals!
5734     system(@_);
5735     open(STDIN,"<&SAVEIN")   || &warn("Can't restore STDIN");
5736     open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
5737     close(SAVEIN);
5738     close(SAVEOUT);
5739
5740     # most of the $? crud was coping with broken cshisms
5741     if ($? >> 8) {
5742     &warn("(Command exited ", ($? >> 8), ")\n");
5743     }
5744     elsif ($?) {
5745     &warn(
5746         "(Command died of SIG#",
5747         ($? & 127),
5748         (($? & 128) ? " -- core dumped" : ""),
5749         ")", "\n"
5750         );
5751     } ## end elsif ($?)
5752
5753     return $?;
5754
5755 } ## end sub system
5756
5757 =head1 TTY MANAGEMENT
5758
5759 The subs here do some of the terminal management for multiple debuggers.
5760
5761 =head2 setterm
5762
5763 Top-level function called when we want to set up a new terminal for use
5764 by the debugger.
5765
5766 If the C<noTTY> debugger option was set, we'll either use the terminal
5767 supplied (the value of the C<noTTY> option), or we'll use C<Term::Rendezvous>
5768 to find one. If we're a forked debugger, we call C<resetterm> to try to
5769 get a whole new terminal if we can.
5770
5771 In either case, we set up the terminal next. If the C<ReadLine> option was
5772 true, we'll get a C<Term::ReadLine> object for the current terminal and save
5773 the appropriate attributes. We then
5774
5775 =cut
5776
5777 sub setterm {
5778     # Load Term::Readline, but quietly; don't debug it and don't trace it.
5779     local $frame = 0;
5780     local $doret = -2;
5781     eval { require Term::ReadLine } or die $@;
5782
5783     # If noTTY is set, but we have a TTY name, go ahead and hook up to it.
5784     if ($notty) {
5785     if ($tty) {
5786         my ($i, $o) = split $tty, /,/;
5787         $o = $i unless defined $o;
5788         open(IN,  "<$i") or die "Cannot open TTY `$i' for read: $!";
5789         open(OUT, ">$o") or die "Cannot open TTY `$o' for write: $!";
5790         $IN = \*IN;
5791         $OUT = \*OUT;
5792         my $sel = select($OUT);
5793         $| = 1;
5794         select($sel);
5795         } ## end if ($tty)
5796
5797         # We don't have a TTY - try to find one via Term::Rendezvous.
5798     else {
5799         eval "require Term::Rendezvous;" or die;
5800             # See if we have anything to pass to Term::Rendezvous.
5801             # Use /tmp/perldbtty$$ if not.
5802         my $rv = $ENV{PERLDB_NOTTY} || ".perldbtty$$";
5803
5804             # Rendezvous and get the filehandles.
5805         my $term_rv = new Term::Rendezvous $rv;
5806         $IN = $term_rv->IN;
5807         $OUT = $term_rv->OUT;
5808         } ## end else [ if ($tty)
5809     } ## end if ($notty)
5810
5811
5812     # We're a daughter debugger. Try to fork off another TTY.
5813     if ($term_pid eq '-1') {    # In a TTY with another debugger
5814     resetterm(2);
5815     }
5816
5817     # If we shouldn't use Term::ReadLine, don't.
5818     if (!$rl) {
5819     $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
5820     }
5821
5822     # We're using Term::ReadLine. Get all the attributes for this terminal.
5823     else {
5824     $term = new Term::ReadLine 'perldb', $IN, $OUT;
5825
5826     $rl_attribs = $term->Attribs;
5827     $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}'
5828       if defined $rl_attribs->{basic_word_break_characters}
5829         and index($rl_attribs->{basic_word_break_characters}, ":") == -1;
5830     $rl_attribs->{special_prefixes} = '$@&%';
5831     $rl_attribs->{completer_word_break_characters} .= '$@&%';
5832     $rl_attribs->{completion_function} = \&db_complete;
5833     } ## end else [ if (!$rl)
5834
5835     # Set up the LINEINFO filehandle.
5836     $LINEINFO = $OUT unless defined $LINEINFO;
5837     $lineinfo = $console unless defined $lineinfo;
5838
5839     $term->MinLine(2);
5840
5841     if ($term->Features->{setHistory} and "@hist" ne "?") {
5842       $term->SetHistory(@hist);
5843     }
5844
5845     # XXX Ornaments are turned on unconditionally, which is not
5846     # always a good thing.
5847     ornaments($ornaments) if defined $ornaments;
5848     $term_pid = $$;
5849 } ## end sub setterm
5850
5851 =head1 GET_FORK_TTY EXAMPLE FUNCTIONS
5852
5853 When the process being debugged forks, or the process invokes a command
5854 via C<system()> which starts a new debugger, we need to be able to get a new
5855 C<IN> and C<OUT> filehandle for the new debugger. Otherwise, the two processes
5856 fight over the terminal, and you can never quite be sure who's going to get the
5857 input you're typing.
5858
5859 C<get_fork_TTY> is a glob-aliased function which calls the real function that
5860 is tasked with doing all the necessary operating system mojo to get a new
5861 TTY (and probably another window) and to direct the new debugger to read and
5862 write there.
5863
5864 The debugger provides C<get_fork_TTY> functions which work for X Windows and
5865 OS/2. Other systems are not supported. You are encouraged to write
5866 C<get_fork_TTY> functions which work for I<your> platform and contribute them.
5867
5868 =head3 C<xterm_get_fork_TTY>
5869
5870 This function provides the C<get_fork_TTY> function for X windows. If a
5871 program running under the debugger forks, a new <xterm> window is opened and
5872 the subsidiary debugger is directed there.
5873
5874 The C<open()> call is of particular note here. We have the new C<xterm>
5875 we're spawning route file number 3 to STDOUT, and then execute the C<tty>
5876 command (which prints the device name of the TTY we'll want to use for input
5877 and output to STDOUT, then C<sleep> for a very long time, routing this output
5878 to file number 3. This way we can simply read from the <XT> filehandle (which
5879 is STDOUT from the I<commands> we ran) to get the TTY we want to use.
5880
5881 Only works if C<xterm> is in your path and C<$ENV{DISPLAY}>, etc. are
5882 properly set up.
5883
5884 =cut
5885
5886 sub xterm_get_fork_TTY {
5887   (my $name = $0) =~ s,^.*[/\\],,s;
5888   open XT,
5889 qq[3>&1 xterm -title "Daughter Perl debugger $pids $name" -e sh -c 'tty 1>&3;\
5890  sleep 10000000' |];
5891
5892     # Get the output from 'tty' and clean it up a little.
5893   my $tty = <XT>;
5894   chomp $tty;
5895
5896   $pidprompt = '';        # Shown anyway in titlebar
5897
5898     # There's our new TTY.
5899   return $tty;
5900 } ## end sub xterm_get_fork_TTY
5901
5902 =head3 C<os2_get_fork_TTY>
5903
5904 XXX It behooves an OS/2 expert to write the necessary documentation for this!
5905
5906 =cut
5907
5908 # This example function resets $IN, $OUT itself
5909 sub os2_get_fork_TTY {
5910   local $^F = 40;            # XXXX Fixme!
5911   local $\ = '';
5912   my ($in1, $out1, $in2, $out2);
5913
5914   # Having -d in PERL5OPT would lead to a disaster...
5915   local $ENV{PERL5OPT} = $ENV{PERL5OPT}    if $ENV{PERL5OPT};
5916   $ENV{PERL5OPT} =~ s/(?:^|(?<=\s))-d\b//  if $ENV{PERL5OPT};
5917   $ENV{PERL5OPT} =~ s/(?:^|(?<=\s))-d\B/-/ if $ENV{PERL5OPT};
5918   print $OUT "Making kid PERL5OPT->`$ENV{PERL5OPT}'.\n" if $ENV{PERL5OPT};
5919   local $ENV{PERL5LIB} = $ENV{PERL5LIB} ? $ENV{PERL5LIB} : $ENV{PERLLIB};
5920   $ENV{PERL5LIB} = '' unless defined $ENV{PERL5LIB};
5921   $ENV{PERL5LIB} = join ';', @ini_INC, split /;/, $ENV{PERL5LIB};
5922   (my $name = $0) =~ s,^.*[/\\],,s;
5923   my @args;
5924
5925   if (
5926             pipe $in1, $out1
5927         and pipe $in2, $out2
5928
5929        # system P_SESSION will fail if there is another process
5930        # in the same session with a "dependent" asynchronous child session.
5931        and @args = (
5932             $rl, fileno $in1, fileno $out2,
5933             "Daughter Perl debugger $pids $name"
5934         )
5935         and (
5936             ($kpid = CORE::system 4, $^X, '-we',
5937                 <<'ES', @args) >= 0 # P_SESSION
5938 END {sleep 5 unless $loaded}
5939 BEGIN {open STDIN,  '</dev/con' or warn "reopen stdin: $!"}
5940 use OS2::Process;
5941
5942 my ($rl, $in) = (shift, shift);        # Read from $in and pass through
5943 set_title pop;
5944 system P_NOWAIT, $^X, '-we', <<EOS or die "Cannot start a grandkid";
5945   open IN, '<&=$in' or die "open <&=$in: \$!";
5946   \$| = 1; print while sysread IN, \$_, 1<<16;
5947 EOS
5948
5949 my $out = shift;
5950 open OUT, ">&=$out" or die "Cannot open &=$out for writing: $!";
5951 select OUT;    $| = 1;
5952 require Term::ReadKey if $rl;
5953 Term::ReadKey::ReadMode(4) if $rl; # Nodelay on kbd.  Pipe is automatically nodelay...
5954 print while sysread STDIN, $_, 1<<($rl ? 16 : 0);
5955 ES
5956      or warn "system P_SESSION: $!, $^E" and 0
5957         )
5958     and close $in1
5959     and close $out2
5960     )
5961     {
5962       $pidprompt = '';    # Shown anyway in titlebar
5963       reset_IN_OUT($in2, $out1);
5964       $tty = '*reset*';
5965       return '';          # Indicate that reset_IN_OUT is called
5966     } ## end if (pipe $in1, $out1 and...
5967    return;
5968 } ## end sub os2_get_fork_TTY
5969
5970 =head2 C<create_IN_OUT($flags)>
5971
5972 Create a new pair of filehandles, pointing to a new TTY. If impossible,
5973 try to diagnose why.
5974
5975 Flags are:
5976
5977 =over 4
5978
5979 =item * 1 - Don't know how to create a new TTY.
5980
5981 =item * 2 - Debugger has forked, but we can't get a new TTY.
5982
5983 =item * 4 - standard debugger startup is happening.
5984
5985 =back
5986
5987 =cut
5988
5989 sub create_IN_OUT {    # Create a window with IN/OUT handles redirected there
5990
5991     # If we know how to get a new TTY, do it! $in will have
5992     # the TTY name if get_fork_TTY works.
5993     my $in = &get_fork_TTY if defined &get_fork_TTY;
5994
5995     # It used to be that
5996     $in = $fork_TTY if defined $fork_TTY; # Backward compatibility
5997     if (not defined $in) {
5998       my $why = shift;
5999
6000         # We don't know how.
6001       print_help(<<EOP) if $why == 1;
6002 I<#########> Forked, but do not know how to create a new B<TTY>. I<#########>
6003 EOP
6004
6005         # Forked debugger.
6006       print_help(<<EOP) if $why == 2;
6007 I<#########> Daughter session, do not know how to change a B<TTY>. I<#########>
6008   This may be an asynchronous session, so the parent debugger may be active.
6009 EOP
6010
6011         # Note that both debuggers are fighting over the same input.
6012       print_help(<<EOP) if $why != 4;
6013   Since two debuggers fight for the same TTY, input is severely entangled.
6014
6015 EOP
6016       print_help(<<EOP);
6017   I know how to switch the output to a different window in xterms
6018   and OS/2 consoles only.  For a manual switch, put the name of the created I<TTY>
6019   in B<\$DB::fork_TTY>, or define a function B<DB::get_fork_TTY()> returning this.
6020
6021   On I<UNIX>-like systems one can get the name of a I<TTY> for the given window
6022   by typing B<tty>, and disconnect the I<shell> from I<TTY> by B<sleep 1000000>.
6023
6024 EOP
6025     } ## end if (not defined $in)
6026
6027     elsif ($in ne '') {
6028       TTY($in);
6029     }
6030     else {
6031       $console = '';        # Indicate no need to open-from-the-console
6032     }
6033     undef $fork_TTY;
6034 } ## end sub create_IN_OUT
6035
6036 =head2 C<resetterm>
6037
6038 Handles rejiggering the prompt when we've forked off a new debugger.
6039
6040 If the new debugger happened because of a C<system()> that invoked a
6041 program under the debugger, the arrow between the old pid and the new
6042 in the prompt has I<two> dashes instead of one.
6043
6044 We take the current list of pids and add this one to the end. If there
6045 isn't any list yet, we make one up out of the initial pid associated with
6046 the terminal and our new pid, sticking an arrow (either one-dashed or
6047 two dashed) in between them.
6048
6049 If C<CreateTTY> is off, or C<resetterm> was called with no arguments,
6050 we don't try to create a new IN and OUT filehandle. Otherwise, we go ahead
6051 and try to do that.
6052
6053 =cut
6054
6055 sub resetterm {            # We forked, so we need a different TTY
6056
6057     # Needs to be passed to create_IN_OUT() as well.
6058     my $in = shift;
6059
6060     # resetterm(2): got in here because of a system() starting a debugger.
6061     # resetterm(1): just forked.
6062     my $systemed = $in > 1 ? '-' : '';
6063
6064     # If there's already a list of pids, add this to the end.
6065     if ($pids) {
6066       $pids =~ s/\]/$systemed->$$]/;
6067     }
6068
6069     # No pid list. Time to make one.
6070     else {
6071       $pids = "[$term_pid->$$]";
6072     }
6073
6074     # The prompt we're going to be using for this debugger.
6075     $pidprompt = $pids;
6076
6077     # We now 0wnz this terminal.
6078     $term_pid = $$;
6079
6080     # Just return if we're not supposed to try to create a new TTY.
6081     return unless $CreateTTY & $in;
6082
6083     # Try to create a new IN/OUT pair.
6084     create_IN_OUT($in);
6085 } ## end sub resetterm
6086
6087 =head2 C<readline>
6088
6089 First, we handle stuff in the typeahead buffer. If there is any, we shift off
6090 the next line, print a message saying we got it, add it to the terminal
6091 history (if possible), and return it.
6092
6093 If there's nothing in the typeahead buffer, check the command filehandle stack.
6094 If there are any filehandles there, read from the last one, and return the line
6095 if we got one. If not, we pop the filehandle off and close it, and try the
6096 next one up the stack.
6097
6098 If we've emptied the filehandle stack, we check to see if we've got a socket
6099 open, and we read that and return it if we do. If we don't, we just call the
6100 core C<readline()> and return its value.
6101
6102 =cut
6103
6104 sub readline {
6105
6106     # Localize to prevent it from being smashed in the program being debugged.
6107   local $.;
6108
6109     # Pull a line out of the typeahead if there's stuff there.
6110   if (@typeahead) {
6111         # How many lines left.
6112     my $left = @typeahead;
6113
6114         # Get the next line.
6115     my $got = shift @typeahead;
6116
6117         # Print a message saying we got input from the typeahead.
6118     local $\ = '';
6119     print $OUT "auto(-$left)", shift, $got, "\n";
6120
6121         # Add it to the terminal history (if possible).
6122     $term->AddHistory($got)
6123       if length($got) > 1
6124       and defined $term->Features->{addHistory};
6125     return $got;
6126     } ## end if (@typeahead)
6127
6128     # We really need to read some input. Turn off entry/exit trace and
6129     # return value printing.
6130   local $frame = 0;
6131   local $doret = -2;
6132
6133     # If there are stacked filehandles to read from ...
6134   while (@cmdfhs) {
6135         # Read from the last one in the stack.
6136     my $line = CORE::readline($cmdfhs[-1]);
6137         # If we got a line ...
6138     defined $line
6139         ? (print $OUT ">> $line" and return $line)
6140         : close pop @cmdfhs;
6141     } ## end while (@cmdfhs)
6142
6143     # Nothing on the filehandle stack. Socket?
6144   if (ref $OUT and UNIVERSAL::isa($OUT, 'IO::Socket::INET')) {
6145         # Send anyting we have to send.
6146     $OUT->write(join('', @_));
6147
6148         # Receive anything there is to receive.
6149     my $stuff;
6150     $IN->recv( $stuff, 2048 );  # XXX: what's wrong with sysread?
6151
6152         # What we got.
6153     $stuff;
6154     } ## end if (ref $OUT and UNIVERSAL::isa...
6155
6156     # No socket. Just read from the terminal.
6157   else {
6158     $term->readline(@_);
6159   }
6160 } ## end sub readline
6161
6162 =head1 OPTIONS SUPPORT ROUTINES
6163
6164 These routines handle listing and setting option values.
6165
6166 =head2 C<dump_option> - list the current value of an option setting
6167
6168 This routine uses C<option_val> to look up the value for an option.
6169 It cleans up escaped single-quotes and then displays the option and
6170 its value.
6171
6172 =cut
6173
6174 sub dump_option {
6175     my ($opt, $val)= @_;
6176     $val = option_val($opt,'N/A');
6177     $val =~ s/([\\\'])/\\$1/g;
6178     printf $OUT "%20s = '%s'\n", $opt, $val;
6179 } ## end sub dump_option
6180
6181
6182 sub options2remember {
6183   foreach my $k (@RememberOnROptions) {
6184     $option{$k}=option_val($k, 'N/A');
6185   }
6186   return %option;
6187 }
6188
6189 =head2 C<option_val> - find the current value of an option
6190
6191 This can't just be a simple hash lookup because of the indirect way that
6192 the option values are stored. Some are retrieved by calling a subroutine,
6193 some are just variables.
6194
6195 You must supply a default value to be used in case the option isn't set.
6196
6197 =cut
6198
6199 sub option_val {
6200     my ($opt, $default) = @_;
6201     my $val;
6202
6203     # Does this option exist, and is it a variable?
6204     # If so, retrieve the value via the value in %optionVars.
6205     if (defined $optionVars{$opt}
6206         and defined ${ $optionVars{$opt} }) {
6207         $val = ${ $optionVars{$opt} };
6208     }
6209
6210     # Does this option exist, and it's a subroutine?
6211     # If so, call the subroutine via the ref in %optionAction
6212     # and capture the value.
6213     elsif (defined $optionAction{$opt}
6214         and defined &{$optionAction{$opt}}) {
6215         $val = &{$optionAction{$opt}}();
6216     }
6217
6218     # If there's an action or variable for the supplied option,
6219     # but no value was set, use the default.
6220     elsif (defined $optionAction{$opt} and not defined $option{$opt}
6221          or defined $optionVars{$opt} and not defined ${$optionVars{$opt}})
6222     {
6223         $val = $default;
6224     }
6225
6226     # Otherwise, do the simple hash lookup.
6227     else {
6228     $val = $option{$opt};
6229     }
6230
6231     # If the value isn't defined, use the default.
6232     # Then return whatever the value is.
6233     $val = $default unless defined $val;
6234     $val
6235 } ## end sub option_val
6236
6237 =head2 C<parse_options>
6238
6239 Handles the parsing and execution of option setting/displaying commands.
6240
6241 An option entered by itself is assumed to be 'set me to 1' (the default value)
6242 if the option is a boolean one. If not, the user is prompted to enter a valid
6243 value or to query the current value (via 'option? ').
6244
6245 If 'option=value' is entered, we try to extract a quoted string from the
6246 value (if it is quoted). If it's not, we just use the whole value as-is.
6247
6248 We load any modules required to service this option, and then we set it: if
6249 it just gets stuck in a variable, we do that; if there's a subroutine to
6250 handle setting the option, we call that.
6251
6252 Finally, if we're running in interactive mode, we display the effect of the
6253 user's command back to the terminal, skipping this if we're setting things
6254 during initialization.
6255
6256 =cut
6257
6258 sub parse_options {
6259     local($_)= @_;
6260     local $\ = '';
6261
6262     # These options need a value. Don't allow them to be clobbered by accident.
6263     my %opt_needs_val = map { ($_ => 1) } qw{
6264         dumpDepth arrayDepth hashDepth LineInfo maxTraceLen ornaments windowSize
6265         pager quote ReadLine recallCommand RemotePort ShellBang TTY CommandSet
6266     };
6267
6268     while (length) {
6269     my $val_defaulted;
6270
6271         # Clean off excess leading whitespace.
6272     s/^\s+// && next;
6273
6274         # Options are always all word characters, followed by a non-word
6275         # separator.
6276     s/^(\w+)(\W?)// or print($OUT "Invalid option `$_'\n"), last;
6277     my ($opt,$sep) = ($1,$2);
6278
6279     my $val;
6280
6281         # '?' as separator means query, but must have whitespace after it.
6282     if ("?" eq $sep) {
6283         print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
6284           if /^\S/;
6285
6286         #&dump_option($opt);
6287     } ## end if ("?" eq $sep)
6288
6289         # Separator is whitespace (or just a carriage return).
6290         # They're going for a default, which we assume is 1.
6291     elsif ($sep !~ /\S/) {
6292         $val_defaulted = 1;
6293         $val = "1";  #  this is an evil default; make 'em set it!
6294     }
6295
6296         # Separator is =. Trying to set a value.
6297     elsif ($sep eq "=") {
6298             # If quoted, extract a quoted string.
6299             if (s/ (["']) ( (?: \\. | (?! \1 ) [^\\] )* ) \1 //x) {
6300                 my $quote = $1;
6301                 ($val = $2) =~ s/\\([$quote\\])/$1/g;
6302         }
6303
6304             # Not quoted. Use the whole thing. Warn about 'option='.
6305         else {
6306         s/^(\S*)//;
6307         $val = $1;
6308         print OUT qq(Option better cleared using $opt=""\n)
6309             unless length $val;
6310         } ## end else [ if (s/ (["']) ( (?: \\. | (?! \1 ) [^\\] )* ) \1 //x)
6311
6312     } ## end elsif ($sep eq "=")
6313
6314         # "Quoted" with [], <>, or {}.
6315     else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
6316         my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
6317         s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)//
6318             or print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
6319         ($val = $1) =~ s/\\([\\$end])/$1/g;
6320     } ## end else [ if ("?" eq $sep)
6321
6322     my $option;
6323     my $matches = grep( /^\Q$opt/  && ($option = $_),  @options  )
6324            || grep( /^\Q$opt/i && ($option = $_),  @options  );
6325
6326     print($OUT "Unknown option `$opt'\n"), next     unless $matches;
6327     print($OUT "Ambiguous option `$opt'\n"), next     if $matches > 1;
6328
6329         # Exclude non-booleans from getting set to 1 by default.
6330        if ($opt_needs_val{$option} && $val_defaulted) {
6331              my $cmd = ($CommandSet eq '580') ? 'o' : 'O';
6332         print $OUT "Option `$opt' is non-boolean.  Use `$cmd $option=VAL' to set, `$cmd $option?' to query\n";
6333         next;
6334     } ## end if ($opt_needs_val{$option...
6335
6336         # Save the option value.
6337     $option{$option} = $val if defined $val;
6338
6339         # Load any module that this option requires.
6340     eval qq{
6341         local \$frame = 0;
6342         local \$doret = -2;
6343             require '$optionRequire{$option}';
6344         1;
6345      } || die  # XXX: shouldn't happen
6346         if  defined $optionRequire{$option}        &&
6347             defined $val;
6348
6349         # Set it.
6350         # Stick it in the proper variable if it goes in a variable.
6351     ${$optionVars{$option}} = $val
6352         if  defined $optionVars{$option}        &&
6353         defined $val;
6354
6355         # Call the appropriate sub if it gets set via sub.
6356     &{$optionAction{$option}} ($val)
6357         if defined $optionAction{$option}        &&
6358                defined &{$optionAction{$option}}    &&
6359                defined $val;
6360
6361         # Not initialization - echo the value we set it to.
6362     dump_option($option)     unless $OUT eq \*STDERR;
6363     } ## end while (length)
6364 } ## end sub parse_options
6365
6366 =head1 RESTART SUPPORT
6367
6368 These routines are used to store (and restore) lists of items in environment
6369 variables during a restart.
6370
6371 =head2 set_list
6372
6373 Set_list packages up items to be stored in a set of environment variables
6374 (VAR_n, containing the number of items, and VAR_0, VAR_1, etc., containing
6375 the values). Values outside the standard ASCII charset are stored by encoding
6376 then as hexadecimal values.
6377
6378 =cut
6379
6380 sub set_list {
6381   my ($stem, @list) = @_;
6382   my $val;
6383
6384     # VAR_n: how many we have. Scalar assignment gets the number of items.
6385   $ENV{"${stem}_n"} = @list;
6386
6387     # Grab each item in the list, escape the backslashes, encode the non-ASCII
6388     # as hex, and then save in the appropriate VAR_0, VAR_1, etc.
6389   for $i (0 .. $#list) {
6390     $val = $list[$i];
6391     $val =~ s/\\/\\\\/g;
6392     $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
6393     $ENV{"${stem}_$i"} = $val;
6394     } ## end for $i (0 .. $#list)
6395 } ## end sub set_list
6396
6397 =head2 get_list
6398
6399 Reverse the set_list operation: grab VAR_n to see how many we should be getting
6400 back, and then pull VAR_0, VAR_1. etc. back out.
6401
6402 =cut
6403
6404 sub get_list {
6405   my $stem = shift;
6406   my @list;
6407   my $n = delete $ENV{"${stem}_n"};
6408   my $val;
6409   for $i (0 .. $n - 1) {
6410     $val = delete $ENV{"${stem}_$i"};
6411     $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
6412     push @list, $val;
6413   }
6414   @list;
6415 } ## end sub get_list
6416
6417 =head1 MISCELLANEOUS SIGNAL AND I/O MANAGEMENT
6418
6419 =head2 catch()
6420
6421 The C<catch()> subroutine is the essence of fast and low-impact. We simply
6422 set an already-existing global scalar variable to a constant value. This
6423 avoids allocating any memory possibly in the middle of something that will
6424 get all confused if we do.
6425
6426 =cut
6427
6428 sub catch {
6429     $signal = 1;
6430     return;    # Put nothing on the stack - malloc/free land!
6431 }
6432
6433 =head2 C<warn()>
6434
6435 C<warn> emits a warning, by joining together its arguments and printing
6436 them, with couple of fillips.
6437
6438 If the composited message I<doesn't> end with a newline, we automatically
6439 add C<$!> and a newline to the end of the message. The subroutine expects $OUT
6440 to be set to the filehandle to be used to output warnings; it makes no
6441 assumptions about what filehandles are available.
6442
6443 =cut
6444
6445 sub warn {
6446     my ($msg) = join ("", @_);
6447     $msg .= ": $!\n" unless $msg =~ /\n$/;
6448     local $\ = '';
6449     print $OUT $msg;
6450 } ## end sub warn
6451
6452 =head1 INITIALIZATION TTY SUPPORT
6453
6454 =head2 C<reset_IN_OUT>
6455
6456 This routine handles restoring the debugger's input and output filehandles
6457 after we've tried and failed to move them elsewhere.  In addition, it assigns
6458 the debugger's output filehandle to $LINEINFO if it was already open there.
6459
6460 =cut
6461
6462 sub reset_IN_OUT {
6463     my $switch_li = $LINEINFO eq $OUT;
6464
6465     # If there's a term and it's able to get a new tty, try to get one.
6466     if ($term and $term->Features->{newTTY}) {
6467       ($IN, $OUT) = (shift, shift);
6468       $term->newTTY($IN, $OUT);
6469     }
6470
6471     # This term can't get a new tty now. Better luck later.
6472     elsif ($term) {
6473         &warn("Too late to set IN/OUT filehandles, enabled on next `R'!\n");
6474     }
6475
6476     # Set the filehndles up as they were.
6477     else {
6478       ($IN, $OUT) = (shift, shift);
6479     }
6480
6481     # Unbuffer the output filehandle.
6482     my $o = select $OUT;
6483     $| = 1;
6484     select $o;
6485
6486     # Point LINEINFO to the same output filehandle if it was there before.
6487     $LINEINFO = $OUT if $switch_li;
6488 } ## end sub reset_IN_OUT
6489
6490 =head1 OPTION SUPPORT ROUTINES
6491
6492 The following routines are used to process some of the more complicated
6493 debugger options.
6494
6495 =head2 C<TTY>
6496
6497 Sets the input and output filehandles to the specified files or pipes.
6498 If the terminal supports switching, we go ahead and do it. If not, and
6499 there's already a terminal in place, we save the information to take effect
6500 on restart.
6501
6502 If there's no terminal yet (for instance, during debugger initialization),
6503 we go ahead and set C<$console> and C<$tty> to the file indicated.
6504
6505 =cut
6506
6507 sub TTY {
6508     if (@_ and $term and $term->Features->{newTTY}) {
6509         # This terminal supports switching to a new TTY.
6510         # Can be a list of two files, or on string containing both names,
6511         # comma-separated.
6512         # XXX Should this perhaps be an assignment from @_?
6513       my ($in, $out) = shift;
6514       if ($in =~ /,/) {
6515             # Split list apart if supplied.
6516     ($in, $out) = split /,/, $in, 2;
6517       }
6518     else {
6519             # Use the same file for both input and output.
6520     $out = $in;
6521       }
6522
6523         # Open file onto the debugger's filehandles, if you can.
6524       open IN, $in or die "cannot open `$in' for read: $!";
6525       open OUT, ">$out" or die "cannot open `$out' for write: $!";
6526
6527         # Swap to the new filehandles.
6528       reset_IN_OUT(\*IN,\*OUT);
6529
6530         # Save the setting for later.
6531       return $tty = $in;
6532     } ## end if (@_ and $term and $term...
6533
6534     # Terminal doesn't support new TTY, or doesn't support readline.
6535     # Can't do it now, try restarting.
6536     &warn("Too late to set TTY, enabled on next `R'!\n") if $term and @_;
6537
6538     # Useful if done through PERLDB_OPTS:
6539     # Useful if done through PERLDB_OPTS:
6540     $console = $tty = shift if @_;
6541
6542     # Return whatever the TTY is.
6543     $tty or $console;
6544 } ## end sub TTY
6545
6546 =head2 C<noTTY>
6547
6548 Sets the C<$notty> global, controlling whether or not the debugger tries to
6549 get a terminal to read from. If called after a terminal is already in place,
6550 we save the value to use it if we're restarted.
6551
6552 =cut
6553
6554 sub noTTY {
6555     if ($term) {
6556         &warn("Too late to set noTTY, enabled on next `R'!\n") if @_;
6557     }
6558     $notty = shift if @_;
6559     $notty;
6560 } ## end sub noTTY
6561
6562 =head2 C<ReadLine>
6563
6564 Sets the C<$rl> option variable. If 0, we use C<Term::ReadLine::Stub>
6565 (essentially, no C<readline> processing on this "terminal"). Otherwise, we
6566 use C<Term::ReadLine>. Can't be changed after a terminal's in place; we save
6567 the value in case a restart is done so we can change it then.
6568
6569 =cut
6570
6571 sub ReadLine {
6572     if ($term) {
6573         &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_;
6574     }
6575     $rl = shift if @_;
6576     $rl;
6577 } ## end sub ReadLine
6578
6579 =head2 C<RemotePort>
6580
6581 Sets the port that the debugger will try to connect to when starting up.
6582 If the terminal's already been set up, we can't do it, but we remember the
6583 setting in case the user does a restart.
6584
6585 =cut
6586
6587 sub RemotePort {
6588     if ($term) {
6589         &warn("Too late to set RemotePort, enabled on next 'R'!\n") if @_;
6590     }
6591     $remoteport = shift if @_;
6592     $remoteport;
6593 } ## end sub RemotePort
6594
6595 =head2 C<tkRunning>
6596
6597 Checks with the terminal to see if C<Tk> is running, and returns true or
6598 false. Returns false if the current terminal doesn't support C<readline>.
6599
6600 =cut
6601
6602 sub tkRunning {
6603     if (${ $term->Features }{tkRunning}) {
6604         return $term->tkRunning(@_);
6605     }
6606     else {
6607     local $\ = '';
6608     print $OUT "tkRunning not supported by current ReadLine package.\n";
6609     0;
6610     }
6611 } ## end sub tkRunning
6612
6613 =head2 C<NonStop>
6614
6615 Sets nonstop mode. If a terminal's already been set up, it's too late; the
6616 debugger remembers the setting in case you restart, though.
6617
6618 =cut
6619
6620 sub NonStop {
6621     if ($term) {
6622         &warn("Too late to set up NonStop mode, enabled on next `R'!\n")
6623           if @_;
6624     }
6625     $runnonstop = shift if @_;
6626     $runnonstop;
6627 } ## end sub NonStop
6628
6629
6630 sub DollarCaretP {
6631     if ($term) {
6632     &warn("Some flag changes could not take effect until next 'R'!\n") if @_;
6633     }
6634     $^P = parse_DollarCaretP_flags(shift) if @_;
6635     expand_DollarCaretP_flags($^P)
6636 }
6637
6638 sub OnlyAssertions {
6639     if ($term) {
6640         &warn("Too late to set up OnlyAssertions mode, enabled on next 'R'!\n") if @_;
6641     }
6642     if (@_) {
6643     unless (defined $ini_assertion) {
6644         if ($term) {
6645         &warn("Current Perl interpreter doesn't support assertions");
6646         }
6647         return 0;
6648     }
6649     if (shift) {
6650         unless ($ini_assertion) {
6651         print "Assertions will be active on next 'R'!\n";
6652         $ini_assertion=1;
6653         }
6654         $^P&= ~$DollarCaretP_flags{PERLDBf_SUB};
6655         $^P|=$DollarCaretP_flags{PERLDBf_ASSERTION};
6656     }
6657     else {
6658         $^P|=$DollarCaretP_flags{PERLDBf_SUB};
6659     }
6660     }
6661     !($^P & $DollarCaretP_flags{PERLDBf_SUB}) || 0;
6662 }
6663
6664 =head2 C<pager>
6665
6666 Set up the C<$pager> variable. Adds a pipe to the front unless there's one
6667 there already.
6668
6669 =cut
6670
6671 sub pager {
6672     if (@_) {
6673         $pager = shift;
6674         $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
6675     }
6676     $pager;
6677 } ## end sub pager
6678
6679 =head2 C<shellBang>
6680
6681 Sets the shell escape command, and generates a printable copy to be used
6682 in the help.
6683
6684 =cut
6685
6686 sub shellBang {
6687
6688     # If we got an argument, meta-quote it, and add '\b' if it
6689     # ends in a word character.
6690     if (@_) {
6691         $sh = quotemeta shift;
6692         $sh .= "\\b" if $sh =~ /\w$/;
6693     }
6694
6695     # Generate the printable version for the help:
6696     $psh = $sh;                       # copy it
6697     $psh =~ s/\\b$//;                 # Take off trailing \b if any
6698     $psh =~ s/\\(.)/$1/g;             # De-escape
6699     $psh;                             # return the printable version
6700 } ## end sub shellBang
6701
6702 =head2 C<ornaments>
6703
6704 If the terminal has its own ornaments, fetch them. Otherwise accept whatever
6705 was passed as the argument. (This means you can't override the terminal's
6706 ornaments.)
6707
6708 =cut
6709
6710 sub ornaments {
6711   if (defined $term) {
6712         # We don't want to show warning backtraces, but we do want die() ones.
6713     local ($warnLevel,$dieLevel) = (0, 1);
6714
6715         # No ornaments if the terminal doesn't support them.
6716     return '' unless $term->Features->{ornaments};
6717     eval { $term->ornaments(@_) } || '';
6718   }
6719
6720     # Use what was passed in if we can't determine it ourselves.
6721     else {
6722     $ornaments = shift;
6723   }
6724 } ## end sub ornaments
6725
6726 =head2 C<recallCommand>
6727
6728 Sets the recall command, and builds a printable version which will appear in
6729 the help text.
6730
6731 =cut
6732
6733 sub recallCommand {
6734
6735     # If there is input, metaquote it. Add '\b' if it ends with a word
6736     # character.
6737     if (@_) {
6738         $rc = quotemeta shift;
6739         $rc .= "\\b" if $rc =~ /\w$/;
6740     }
6741
6742     # Build it into a printable version.
6743     $prc = $rc;                             # Copy it
6744     $prc =~ s/\\b$//;                       # Remove trailing \b
6745     $prc =~ s/\\(.)/$1/g;                   # Remove escapes
6746     $prc;                                   # Return the printable version
6747 } ## end sub recallCommand
6748
6749 =head2 C<LineInfo> - where the line number information goes
6750
6751 Called with no arguments, returns the file or pipe that line info should go to.
6752
6753 Called with an argument (a file or a pipe), it opens that onto the
6754 C<LINEINFO> filehandle, unbuffers the filehandle, and then returns the
6755 file or pipe again to the caller.
6756
6757 =cut
6758
6759 sub LineInfo {
6760     return $lineinfo unless @_;
6761     $lineinfo = shift;
6762
6763     #  If this is a valid "thing to be opened for output", tack a
6764     # '>' onto the front.
6765     my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
6766
6767     # If this is a pipe, the stream points to a slave editor.
6768     $slave_editor = ($stream =~ /^\|/);
6769
6770     # Open it up and unbuffer it.
6771     open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
6772     $LINEINFO = \*LINEINFO;
6773     my $save = select($LINEINFO);
6774     $| = 1;
6775     select($save);
6776
6777     # Hand the file or pipe back again.
6778     $lineinfo;
6779 } ## end sub LineInfo
6780
6781 =head1 COMMAND SUPPORT ROUTINES
6782
6783 These subroutines provide functionality for various commands.
6784
6785 =head2 C<list_modules>
6786
6787 For the C<M> command: list modules loaded and their versions.
6788 Essentially just runs through the keys in %INC, picks up the
6789 $VERSION package globals from each package, gets the file name, and formats the
6790 information for output.
6791
6792 =cut
6793
6794
6795 sub list_modules { # versions
6796   my %version;
6797   my $file;
6798     # keys are the "as-loaded" name, values are the fully-qualified path
6799     # to the file itself.
6800   for (keys %INC) {
6801     $file = $_;
6802     s,\.p[lm]$,,i ;
6803     s,/,::,g ;
6804     s/^perl5db$/DB/;
6805     s/^Term::ReadLine::readline$/readline/;
6806         # If the package has a $VERSION package global (as all good packages
6807         # should!) decode it and save as partial message.
6808     if (defined ${ $_ . '::VERSION' }) {
6809       $version{$file} = "${ $_ . '::VERSION' } from ";
6810     }
6811
6812         # Finish up the message with the file the package came from.
6813     $version{$file} .= $INC{$file};
6814     } ## end for (keys %INC)
6815
6816     # Hey, dumpit() formats a hash nicely, so why not use it?
6817   dumpit($OUT,\%version);
6818 } ## end sub list_modules
6819
6820 =head2 C<sethelp()>
6821
6822 Sets up the monster string used to format and print the help.
6823
6824 =head3 HELP MESSAGE FORMAT
6825
6826 The help message is a peculiar format unto itself; it mixes C<pod> 'ornaments'
6827 (BE<lt>E<gt>, IE<gt>E<lt>) with tabs to come up with a format that's fairly
6828 easy to parse and portable, but which still allows the help to be a little
6829 nicer than just plain text.
6830
6831 Essentially, you define the command name (usually marked up with BE<gt>E<lt>
6832 and IE<gt>E<lt>), followed by a tab, and then the descriptive text, ending in a newline. The descriptive text can also be marked up in the same way. If you
6833 need to continue the descriptive text to another line, start that line with
6834 just tabs and then enter the marked-up text.
6835
6836 If you are modifying the help text, I<be careful>. The help-string parser is
6837 not very sophisticated, and if you don't follow these rules it will mangle the
6838 help beyond hope until you fix the string.
6839
6840 =cut
6841
6842 sub sethelp {
6843
6844     # XXX: make sure there are tabs between the command and explanation,
6845     #      or print_help will screw up your formatting if you have
6846     #      eeevil ornaments enabled.  This is an insane mess.
6847
6848     $help = "
6849 Help is currently only available for the new 580 CommandSet,
6850 if you really want old behaviour, presumably you know what
6851 you're doing ?-)
6852
6853 B<T>        Stack trace.
6854 B<s> [I<expr>]    Single step [in I<expr>].
6855 B<n> [I<expr>]    Next, steps over subroutine calls [in I<expr>].
6856 <B<CR>>        Repeat last B<n> or B<s> command.
6857 B<r>        Return from current subroutine.
6858 B<c> [I<line>|I<sub>]    Continue; optionally inserts a one-time-only breakpoint
6859         at the specified position.
6860 B<l> I<min>B<+>I<incr>    List I<incr>+1 lines starting at I<min>.
6861 B<l> I<min>B<->I<max>    List lines I<min> through I<max>.
6862 B<l> I<line>        List single I<line>.
6863 B<l> I<subname>    List first window of lines from subroutine.
6864 B<l> I<\$var>        List first window of lines from subroutine referenced by I<\$var>.
6865 B<l>        List next window of lines.
6866 B<->        List previous window of lines.
6867 B<v> [I<line>]    View window around I<line>.
6868 B<.>        Return to the executed line.
6869 B<f> I<filename>    Switch to viewing I<filename>. File must be already loaded.
6870         I<filename> may be either the full name of the file, or a regular
6871         expression matching the full file name:
6872         B<f> I</home/me/foo.pl> and B<f> I<oo\\.> may access the same file.
6873         Evals (with saved bodies) are considered to be filenames:
6874         B<f> I<(eval 7)> and B<f> I<eval 7\\b> access the body of the 7th eval
6875         (in the order of execution).
6876 B</>I<pattern>B</>    Search forwards for I<pattern>; final B</> is optional.
6877 B<?>I<pattern>B<?>    Search backwards for I<pattern>; final B<?> is optional.
6878 B<L> [I<a|b|w>]        List actions and or breakpoints and or watch-expressions.
6879 B<S> [[B<!>]I<pattern>]    List subroutine names [not] matching I<pattern>.
6880 B<t>        Toggle trace mode.
6881 B<t> I<expr>        Trace through execution of I<expr>.
6882 B<b>        Sets breakpoint on current line)
6883 B<b> [I<line>] [I<condition>]
6884         Set breakpoint; I<line> defaults to the current execution line;
6885         I<condition> breaks if it evaluates to true, defaults to '1'.
6886 B<b> I<subname> [I<condition>]
6887         Set breakpoint at first line of subroutine.
6888 B<b> I<\$var>        Set breakpoint at first line of subroutine referenced by I<\$var>.
6889 B<b> B<load> I<filename> Set breakpoint on 'require'ing the given file.
6890 B<b> B<postpone> I<subname> [I<condition>]
6891         Set breakpoint at first line of subroutine after
6892         it is compiled.
6893 B<b> B<compile> I<subname>
6894         Stop after the subroutine is compiled.
6895 B<B> [I<line>]    Delete the breakpoint for I<line>.
6896 B<B> I<*>             Delete all breakpoints.
6897 B<a> [I<line>] I<command>
6898         Set an action to be done before the I<line> is executed;
6899         I<line> defaults to the current execution line.
6900         Sequence is: check for breakpoint/watchpoint, print line
6901         if necessary, do action, prompt user if necessary,
6902         execute line.
6903 B<a>        Does nothing
6904 B<A> [I<line>]    Delete the action for I<line>.
6905 B<A> I<*>             Delete all actions.
6906 B<w> I<expr>        Add a global watch-expression.
6907 B<w>             Does nothing
6908 B<W> I<expr>        Delete a global watch-expression.
6909 B<W> I<*>             Delete all watch-expressions.
6910 B<V> [I<pkg> [I<vars>]]    List some (default all) variables in package (default current).
6911         Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
6912 B<X> [I<vars>]    Same as \"B<V> I<currentpackage> [I<vars>]\".
6913 B<y> [I<n> [I<Vars>]]   List lexicals in higher scope <n>.  Vars same as B<V>.
6914 B<x> I<expr>        Evals expression in list context, dumps the result.
6915 B<m> I<expr>        Evals expression in list context, prints methods callable
6916         on the first element of the result.
6917 B<m> I<class>        Prints methods callable via the given class.
6918 B<M>        Show versions of loaded modules.
6919 B<i> I<class>       Prints nested parents of given class.
6920 B<y> [I<n> [I<vars>]]    List lexical variables I<n> levels up from current sub
6921
6922 B<<> ?            List Perl commands to run before each prompt.
6923 B<<> I<expr>        Define Perl command to run before each prompt.
6924 B<<<> I<expr>        Add to the list of Perl commands to run before each prompt.
6925 B<< *>             Delete the list of perl commands to run before each prompt.
6926 B<>> ?            List Perl commands to run after each prompt.
6927 B<>> I<expr>        Define Perl command to run after each prompt.
6928 B<>>B<>> I<expr>        Add to the list of Perl commands to run after each prompt.
6929 B<>>B< *>         Delete the list of Perl commands to run after each prompt.
6930 B<{> I<db_command>    Define debugger command to run before each prompt.
6931 B<{> ?            List debugger commands to run before each prompt.
6932 B<{{> I<db_command>    Add to the list of debugger commands to run before each prompt.
6933 B<{ *>             Delete the list of debugger commands to run before each prompt.
6934 B<$prc> I<number>    Redo a previous command (default previous command).
6935 B<$prc> I<-number>    Redo number'th-to-last command.
6936 B<$prc> I<pattern>    Redo last command that started with I<pattern>.
6937         See 'B<O> I<recallCommand>' too.
6938 B<$psh$psh> I<cmd>      Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
6939   . (
6940     $rc eq $sh
6941     ? ""
6942     : "
6943 B<$psh> [I<cmd>]     Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")."
6944     )
6945     . "
6946         See 'B<O> I<shellBang>' too.
6947 B<source> I<file>        Execute I<file> containing debugger commands (may nest).
6948 B<save> I<file>       Save current debugger session (actual history) to I<file>.
6949 B<H> I<-number>    Display last number commands (default all).
6950 B<p> I<expr>        Same as \"I<print {DB::OUT} expr>\" in current package.
6951 B<|>I<dbcmd>        Run debugger command, piping DB::OUT to current pager.
6952 B<||>I<dbcmd>        Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
6953 B<\=> [I<alias> I<value>]    Define a command alias, or list current aliases.
6954 I<command>        Execute as a perl statement in current package.
6955 B<R>        Pure-man-restart of debugger, some of debugger state
6956         and command-line options may be lost.
6957         Currently the following settings are preserved:
6958         history, breakpoints and actions, debugger B<O>ptions
6959         and the following command-line options: I<-w>, I<-I>, I<-e>.
6960
6961 B<o> [I<opt>] ...    Set boolean option to true
6962 B<o> [I<opt>B<?>]    Query options
6963 B<o> [I<opt>B<=>I<val>] [I<opt>=B<\">I<val>B<\">] ...
6964         Set options.  Use quotes in spaces in value.
6965     I<recallCommand>, I<ShellBang>    chars used to recall command or spawn shell;
6966     I<pager>            program for output of \"|cmd\";
6967     I<tkRunning>            run Tk while prompting (with ReadLine);
6968     I<signalLevel> I<warnLevel> I<dieLevel>    level of verbosity;
6969     I<inhibit_exit>        Allows stepping off the end of the script.
6970     I<ImmediateStop>        Debugger should stop as early as possible.
6971     I<RemotePort>            Remote hostname:port for remote debugging
6972   The following options affect what happens with B<V>, B<X>, and B<x> commands:
6973     I<arrayDepth>, I<hashDepth>     print only first N elements ('' for all);
6974     I<compactDump>, I<veryCompact>     change style of array and hash dump;
6975     I<globPrint>             whether to print contents of globs;
6976     I<DumpDBFiles>         dump arrays holding debugged files;
6977     I<DumpPackages>         dump symbol tables of packages;
6978     I<DumpReused>             dump contents of \"reused\" addresses;
6979     I<quote>, I<HighBit>, I<undefPrint>     change style of string dump;
6980     I<bareStringify>         Do not print the overload-stringified value;
6981   Other options include:
6982     I<PrintRet>        affects printing of return value after B<r> command,
6983     I<frame>        affects printing messages on subroutine entry/exit.
6984     I<AutoTrace>    affects printing messages on possible breaking points.
6985     I<maxTraceLen>    gives max length of evals/args listed in stack trace.
6986     I<ornaments>     affects screen appearance of the command line.
6987     I<CreateTTY>     bits control attempts to create a new TTY on events:
6988             1: on fork()    2: debugger is started inside debugger
6989             4: on startup
6990     During startup options are initialized from \$ENV{PERLDB_OPTS}.
6991     You can put additional initialization options I<TTY>, I<noTTY>,
6992     I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use
6993     `B<R>' after you set them).
6994
6995 B<q> or B<^D>        Quit. Set B<\$DB::finished = 0> to debug global destruction.
6996 B<h>        Summary of debugger commands.
6997 B<h> [I<db_command>]    Get help [on a specific debugger command], enter B<|h> to page.
6998 B<h h>        Long help for debugger commands
6999 B<$doccmd> I<manpage>    Runs the external doc viewer B<$doccmd> command on the
7000         named Perl I<manpage>, or on B<$doccmd> itself if omitted.
7001         Set B<\$DB::doccmd> to change viewer.
7002
7003 Type `|h h' for a paged display if this was too hard to read.
7004
7005 "; # Fix balance of vi % matching: }}}}
7006
7007     #  note: tabs in the following section are not-so-helpful
7008     $summary = <<"END_SUM";
7009 I<List/search source lines:>               I<Control script execution:>
7010   B<l> [I<ln>|I<sub>]  List source code            B<T>           Stack trace
7011   B<-> or B<.>      List previous/current line  B<s> [I<expr>]    Single step [in expr]
7012   B<v> [I<line>]    View around line            B<n> [I<expr>]    Next, steps over subs
7013   B<f> I<filename>  View source in file         <B<CR>/B<Enter>>  Repeat last B<n> or B<s>
7014   B</>I<pattern>B</> B<?>I<patt>B<?>   Search forw/backw    B<r>           Return from subroutine
7015   B<M>           Show module versions        B<c> [I<ln>|I<sub>]  Continue until position
7016 I<Debugger controls:>                        B<L>           List break/watch/actions
7017   B<o> [...]     Set debugger options        B<t> [I<expr>]    Toggle trace [trace expr]
7018   B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I<cmd>] Do pre/post-prompt B<b> [I<ln>|I<event>|I<sub>] [I<cnd>] Set breakpoint
7019   B<$prc> [I<N>|I<pat>]   Redo a previous command     B<B> I<ln|*>      Delete a/all breakpoints
7020   B<H> [I<-num>]    Display last num commands   B<a> [I<ln>] I<cmd>  Do cmd before line
7021   B<=> [I<a> I<val>]   Define/list an alias        B<A> I<ln|*>      Delete a/all actions
7022   B<h> [I<db_cmd>]  Get help on command         B<w> I<expr>      Add a watch expression
7023   B<h h>         Complete help page          B<W> I<expr|*>    Delete a/all watch exprs
7024   B<|>[B<|>]I<db_cmd>  Send output to pager        B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
7025   B<q> or B<^D>     Quit                        B<R>           Attempt a restart
7026 I<Data Examination:>     B<expr>     Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
7027   B<x>|B<m> I<expr>       Evals expr in list context, dumps the result or lists methods.
7028   B<p> I<expr>         Print expression (uses script's current package).
7029   B<S> [[B<!>]I<pat>]     List subroutine names [not] matching pattern
7030   B<V> [I<Pk> [I<Vars>]]  List Variables in Package.  Vars can be ~pattern or !pattern.
7031   B<X> [I<Vars>]       Same as \"B<V> I<current_package> [I<Vars>]\".  B<i> I<class> inheritance tree.
7032   B<y> [I<n> [I<Vars>]]   List lexicals in higher scope <n>.  Vars same as B<V>.
7033 For more help, type B<h> I<cmd_letter>, or run B<$doccmd perldebug> for all docs.
7034 END_SUM
7035     # ')}}; # Fix balance of vi % matching
7036
7037     # and this is really numb...
7038     $pre580_help = "
7039 B<T>        Stack trace.
7040 B<s> [I<expr>]    Single step [in I<expr>].
7041 B<n> [I<expr>]    Next, steps over subroutine calls [in I<expr>].
7042 <B<CR>>        Repeat last B<n> or B<s> command.
7043 B<r>        Return from current subroutine.
7044 B<c> [I<line>|I<sub>]    Continue; optionally inserts a one-time-only breakpoint
7045         at the specified position.
7046 B<l> I<min>B<+>I<incr>    List I<incr>+1 lines starting at I<min>.
7047 B<l> I<min>B<->I<max>    List lines I<min> through I<max>.
7048 B<l> I<line>        List single I<line>.
7049 B<l> I<subname>    List first window of lines from subroutine.
7050 B<l> I<\$var>        List first window of lines from subroutine referenced by I<\$var>.
7051 B<l>        List next window of lines.
7052 B<->        List previous window of lines.
7053 B<w> [I<line>]    List window around I<line>.
7054 B<.>        Return to the executed line.
7055 B<f> I<filename>    Switch to viewing I<filename>. File must be already loaded.
7056         I<filename> may be either the full name of the file, or a regular
7057         expression matching the full file name:
7058         B<f> I</home/me/foo.pl> and B<f> I<oo\\.> may access the same file.
7059         Evals (with saved bodies) are considered to be filenames:
7060         B<f> I<(eval 7)> and B<f> I<eval 7\\b> access the body of the 7th eval
7061         (in the order of execution).
7062 B</>I<pattern>B</>    Search forwards for I<pattern>; final B</> is optional.
7063 B<?>I<pattern>B<?>    Search backwards for I<pattern>; final B<?> is optional.
7064 B<L>        List all breakpoints and actions.
7065 B<S> [[B<!>]I<pattern>]    List subroutine names [not] matching I<pattern>.
7066 B<t>        Toggle trace mode.
7067 B<t> I<expr>        Trace through execution of I<expr>.
7068 B<b> [I<line>] [I<condition>]
7069         Set breakpoint; I<line> defaults to the current execution line;
7070         I<condition> breaks if it evaluates to true, defaults to '1'.
7071 B<b> I<subname> [I<condition>]
7072         Set breakpoint at first line of subroutine.
7073 B<b> I<\$var>        Set breakpoint at first line of subroutine referenced by I<\$var>.
7074 B<b> B<load> I<filename> Set breakpoint on `require'ing the given file.
7075 B<b> B<postpone> I<subname> [I<condition>]
7076         Set breakpoint at first line of subroutine after
7077         it is compiled.
7078 B<b> B<compile> I<subname>
7079         Stop after the subroutine is compiled.
7080 B<d> [I<line>]    Delete the breakpoint for I<line>.
7081 B<D>        Delete all breakpoints.
7082 B<a> [I<line>] I<command>
7083         Set an action to be done before the I<line> is executed;
7084         I<line> defaults to the current execution line.
7085         Sequence is: check for breakpoint/watchpoint, print line
7086         if necessary, do action, prompt user if necessary,
7087         execute line.
7088 B<a> [I<line>]    Delete the action for I<line>.
7089 B<A>        Delete all actions.
7090 B<W> I<expr>        Add a global watch-expression.
7091 B<W>        Delete all watch-expressions.
7092 B<V> [I<pkg> [I<vars>]]    List some (default all) variables in package (default current).
7093         Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
7094 B<X> [I<vars>]    Same as \"B<V> I<currentpackage> [I<vars>]\".
7095 B<x> I<expr>        Evals expression in list context, dumps the result.
7096 B<m> I<expr>        Evals expression in list context, prints methods callable
7097         on the first element of the result.
7098 B<m> I<class>        Prints methods callable via the given class.
7099
7100 B<<> ?            List Perl commands to run before each prompt.
7101 B<<> I<expr>        Define Perl command to run before each prompt.
7102 B<<<> I<expr>        Add to the list of Perl commands to run before each prompt.
7103 B<>> ?            List Perl commands to run after each prompt.
7104 B<>> I<expr>        Define Perl command to run after each prompt.
7105 B<>>B<>> I<expr>        Add to the list of Perl commands to run after each prompt.
7106 B<{> I<db_command>    Define debugger command to run before each prompt.
7107 B<{> ?            List debugger commands to run before each prompt.
7108 B<{{> I<db_command>    Add to the list of debugger commands to run before each prompt.
7109 B<$prc> I<number>    Redo a previous command (default previous command).
7110 B<$prc> I<-number>    Redo number'th-to-last command.
7111 B<$prc> I<pattern>    Redo last command that started with I<pattern>.
7112         See 'B<O> I<recallCommand>' too.
7113 B<$psh$psh> I<cmd>      Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
7114   . (
7115     $rc eq $sh
7116     ? ""
7117     : "
7118 B<$psh> [I<cmd>]     Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")."
7119     ) .
7120     "
7121         See 'B<O> I<shellBang>' too.
7122 B<source> I<file>        Execute I<file> containing debugger commands (may nest).
7123 B<H> I<-number>    Display last number commands (default all).
7124 B<p> I<expr>        Same as \"I<print {DB::OUT} expr>\" in current package.
7125 B<|>I<dbcmd>        Run debugger command, piping DB::OUT to current pager.
7126 B<||>I<dbcmd>        Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
7127 B<\=> [I<alias> I<value>]    Define a command alias, or list current aliases.
7128 I<command>        Execute as a perl statement in current package.
7129 B<v>        Show versions of loaded modules.
7130 B<R>        Pure-man-restart of debugger, some of debugger state
7131         and command-line options may be lost.
7132         Currently the following settings are preserved:
7133         history, breakpoints and actions, debugger B<O>ptions
7134         and the following command-line options: I<-w>, I<-I>, I<-e>.
7135
7136 B<O> [I<opt>] ...    Set boolean option to true
7137 B<O> [I<opt>B<?>]    Query options
7138 B<O> [I<opt>B<=>I<val>] [I<opt>=B<\">I<val>B<\">] ...
7139         Set options.  Use quotes in spaces in value.
7140     I<recallCommand>, I<ShellBang>    chars used to recall command or spawn shell;
7141     I<pager>            program for output of \"|cmd\";
7142     I<tkRunning>            run Tk while prompting (with ReadLine);
7143     I<signalLevel> I<warnLevel> I<dieLevel>    level of verbosity;
7144     I<inhibit_exit>        Allows stepping off the end of the script.
7145     I<ImmediateStop>        Debugger should stop as early as possible.
7146     I<RemotePort>            Remote hostname:port for remote debugging
7147   The following options affect what happens with B<V>, B<X>, and B<x> commands:
7148     I<arrayDepth>, I<hashDepth>     print only first N elements ('' for all);
7149     I<compactDump>, I<veryCompact>     change style of array and hash dump;
7150     I<globPrint>             whether to print contents of globs;
7151     I<DumpDBFiles>         dump arrays holding debugged files;
7152     I<DumpPackages>         dump symbol tables of packages;
7153     I<DumpReused>             dump contents of \"reused\" addresses;
7154     I<quote>, I<HighBit>, I<undefPrint>     change style of string dump;
7155     I<bareStringify>         Do not print the overload-stringified value;
7156   Other options include:
7157     I<PrintRet>        affects printing of return value after B<r> command,
7158     I<frame>        affects printing messages on subroutine entry/exit.
7159     I<AutoTrace>    affects printing messages on possible breaking points.
7160     I<maxTraceLen>    gives max length of evals/args listed in stack trace.
7161     I<ornaments>     affects screen appearance of the command line.
7162     I<CreateTTY>     bits control attempts to create a new TTY on events:
7163             1: on fork()    2: debugger is started inside debugger
7164             4: on startup
7165     During startup options are initialized from \$ENV{PERLDB_OPTS}.
7166     You can put additional initialization options I<TTY>, I<noTTY>,
7167     I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use
7168     `B<R>' after you set them).
7169
7170 B<q> or B<^D>        Quit. Set B<\$DB::finished = 0> to debug global destruction.
7171 B<h> [I<db_command>]    Get help [on a specific debugger command], enter B<|h> to page.
7172 B<h h>        Summary of debugger commands.
7173 B<$doccmd> I<manpage>    Runs the external doc viewer B<$doccmd> command on the
7174         named Perl I<manpage>, or on B<$doccmd> itself if omitted.
7175         Set B<\$DB::doccmd> to change viewer.
7176
7177 Type `|h' for a paged display if this was too hard to read.
7178
7179 "; # Fix balance of vi % matching: }}}}
7180
7181     #  note: tabs in the following section are not-so-helpful
7182     $pre580_summary = <<"END_SUM";
7183 I<List/search source lines:>               I<Control script execution:>
7184   B<l> [I<ln>|I<sub>]  List source code            B<T>           Stack trace
7185   B<-> or B<.>      List previous/current line  B<s> [I<expr>]    Single step [in expr]
7186   B<w> [I<line>]    List around line            B<n> [I<expr>]    Next, steps over subs
7187   B<f> I<filename>  View source in file         <B<CR>/B<Enter>>  Repeat last B<n> or B<s>
7188   B</>I<pattern>B</> B<?>I<patt>B<?>   Search forw/backw    B<r>           Return from subroutine
7189   B<v>           Show versions of modules    B<c> [I<ln>|I<sub>]  Continue until position
7190 I<Debugger controls:>                        B<L>           List break/watch/actions
7191   B<O> [...]     Set debugger options        B<t> [I<expr>]    Toggle trace [trace expr]
7192   B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I<cmd>] Do pre/post-prompt B<b> [I<ln>|I<event>|I<sub>] [I<cnd>] Set breakpoint
7193   B<$prc> [I<N>|I<pat>]   Redo a previous command     B<d> [I<ln>] or B<D> Delete a/all breakpoints
7194   B<H> [I<-num>]    Display last num commands   B<a> [I<ln>] I<cmd>  Do cmd before line
7195   B<=> [I<a> I<val>]   Define/list an alias        B<W> I<expr>      Add a watch expression
7196   B<h> [I<db_cmd>]  Get help on command         B<A> or B<W>      Delete all actions/watch
7197   B<|>[B<|>]I<db_cmd>  Send output to pager        B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
7198   B<q> or B<^D>     Quit                        B<R>           Attempt a restart
7199 I<Data Examination:>     B<expr>     Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
7200   B<x>|B<m> I<expr>       Evals expr in list context, dumps the result or lists methods.
7201   B<p> I<expr>         Print expression (uses script's current package).
7202   B<S> [[B<!>]I<pat>]     List subroutine names [not] matching pattern
7203   B<V> [I<Pk> [I<Vars>]]  List Variables in Package.  Vars can be ~pattern or !pattern.
7204   B<X> [I<Vars>]       Same as \"B<V> I<current_package> [I<Vars>]\".
7205   B<y> [I<n> [I<Vars>]]   List lexicals in higher scope <n>.  Vars same as B<V>.
7206 For more help, type B<h> I<cmd_letter>, or run B<$doccmd perldebug> for all docs.
7207 END_SUM
7208
7209                 # ')}}; # Fix balance of vi % matching
7210
7211 } ## end sub sethelp
7212
7213 =head2 C<print_help()>
7214
7215 Most of what C<print_help> does is just text formatting. It finds the
7216 C<B> and C<I> ornaments, cleans them off, and substitutes the proper
7217 terminal control characters to simulate them (courtesy of
7218 <Term::ReadLine::TermCap>).
7219
7220 =cut
7221
7222 sub print_help {
7223     local $_ = shift;
7224
7225     # Restore proper alignment destroyed by eeevil I<> and B<>
7226     # ornaments: A pox on both their houses!
7227     #
7228     # A help command will have everything up to and including
7229     # the first tab sequence padded into a field 16 (or if indented 20)
7230     # wide.  If it's wider than that, an extra space will be added.
7231     s{
7232     ^                 # only matters at start of line
7233       ( \040{4} | \t )*    # some subcommands are indented
7234       ( < ?         # so <CR> works
7235         [BI] < [^\t\n] + )  # find an eeevil ornament
7236       ( \t+ )        # original separation, discarded
7237       ( .* )        # this will now start (no earlier) than
7238                 # column 16
7239     } {
7240     my($leadwhite, $command, $midwhite, $text) = ($1, $2, $3, $4);
7241     my $clean = $command;
7242     $clean =~ s/[BI]<([^>]*)>/$1/g;
7243
7244     # replace with this whole string:
7245     ($leadwhite ? " " x 4 : "")
7246       . $command
7247       . ((" " x (16 + ($leadwhite ? 4 : 0) - length($clean))) || " ")
7248       . $text;
7249
7250     }mgex;
7251
7252     s{                # handle bold ornaments
7253     B < ( [^>] + | > ) >
7254     } {
7255       $Term::ReadLine::TermCap::rl_term_set[2]
7256     . $1
7257     . $Term::ReadLine::TermCap::rl_term_set[3]
7258     }gex;
7259
7260     s{                # handle italic ornaments
7261     I < ( [^>] + | > ) >
7262     } {
7263       $Term::ReadLine::TermCap::rl_term_set[0]
7264     . $1
7265     . $Term::ReadLine::TermCap::rl_term_set[1]
7266     }gex;
7267
7268     local $\ = '';
7269     print $OUT $_;
7270 } ## end sub print_help
7271
7272 =head2 C<fix_less>
7273
7274 This routine does a lot of gyrations to be sure that the pager is C<less>.
7275 It checks for C<less> masquerading as C<more> and records the result in
7276 C<$ENV{LESS}> so we don't have to go through doing the stats again.
7277
7278 =cut
7279
7280 sub fix_less {
7281
7282     # We already know if this is set.
7283     return if defined $ENV{LESS} && $ENV{LESS} =~ /r/;
7284
7285     # Pager is less for sure.
7286     my $is_less = $pager =~ /\bless\b/;
7287     if ($pager =~ /\bmore\b/) {
7288         # Nope, set to more. See what's out there.
7289     my @st_more = stat('/usr/bin/more');
7290     my @st_less = stat('/usr/bin/less');
7291
7292         # is it really less, pretending to be more?
7293     $is_less = @st_more    && @st_less
7294         && $st_more[0] == $st_less[0]
7295         && $st_more[1] == $st_less[1];
7296     } ## end if ($pager =~ /\bmore\b/)
7297
7298     # changes environment!
7299     # 'r' added so we don't do (slow) stats again.
7300     # changes environment!
7301     $ENV{LESS} .= 'r'     if $is_less;
7302 } ## end sub fix_less
7303
7304 =head1 DIE AND WARN MANAGEMENT
7305
7306 =head2 C<diesignal>
7307
7308 C<diesignal> is a just-drop-dead C<die> handler. It's most useful when trying
7309 to debug a debugger problem.
7310
7311 It does its best to report the error that occurred, and then forces the
7312 program, debugger, and everything to die.
7313
7314 =cut
7315
7316 sub diesignal {
7317     # No entry/exit messages.
7318     local $frame = 0;
7319
7320     # No return value prints.
7321     local $doret = -2;
7322
7323     # set the abort signal handling to the default (just terminate).
7324     $SIG{'ABRT'} = 'DEFAULT';
7325
7326     # If we enter the signal handler recursively, kill myself with an
7327     # abort signal (so we just terminate).
7328     kill 'ABRT', $$ if $panic++;
7329
7330     # If we can show detailed info, do so.
7331     if (defined &Carp::longmess) {
7332         # Don't recursively enter the warn handler, since we're carping.
7333     local $SIG{__WARN__} = '';
7334
7335         # Skip two levels before reporting traceback: we're skipping
7336         # mydie and confess.
7337     local $Carp::CarpLevel = 2;        # mydie + confess
7338
7339         # Tell us all about it.
7340     &warn(Carp::longmess("Signal @_"));
7341     }
7342
7343     # No Carp. Tell us about the signal as best we can.
7344     else {
7345         local $\ = '';
7346         print $DB::OUT "Got signal @_\n";
7347     }
7348
7349     # Drop dead.
7350     kill 'ABRT', $$;
7351 } ## end sub diesignal
7352
7353 =head2 C<dbwarn>
7354
7355 The debugger's own default C<$SIG{__WARN__}> handler. We load C<Carp> to
7356 be able to get a stack trace, and output the warning message vi C<DB::dbwarn()>.
7357
7358 =cut
7359
7360
7361 sub dbwarn {
7362     # No entry/exit trace.
7363   local $frame = 0;
7364
7365     # No return value printing.
7366   local $doret = -2;
7367
7368     # Turn off warn and die handling to prevent recursive entries to this
7369     # routine.
7370   local $SIG{__WARN__} = '';
7371   local $SIG{__DIE__} = '';
7372
7373     # Load Carp if we can. If $^S is false (current thing being compiled isn't
7374     # done yet), we may not be able to do a require.
7375   eval { require Carp }
7376     if defined $^S;    # If error/warning during compilation,
7377                        # require may be broken.
7378
7379     # Use the core warn() unless Carp loaded OK.
7380   CORE::warn(@_,
7381         "\nCannot print stack trace, load with -MCarp option to see stack"),
7382     return
7383     unless defined &Carp::longmess;
7384
7385     # Save the current values of $single and $trace, and then turn them off.
7386   my ($mysingle, $mytrace) = ($single, $trace);
7387   $single = 0;
7388   $trace = 0;
7389
7390     # We can call Carp::longmess without its being "debugged" (which we
7391     # don't want - we just want to use it!). Capture this for later.
7392   my $mess = Carp::longmess(@_);
7393
7394     # Restore $single and $trace to their original values.
7395   ($single,$trace) = ($mysingle,$mytrace);
7396
7397     # Use the debugger's own special way of printing warnings to print
7398     # the stack trace message.
7399   &warn($mess);
7400 } ## end sub dbwarn
7401
7402 =head2 C<dbdie>
7403
7404 The debugger's own C<$SIG{__DIE__}> handler. Handles providing a stack trace
7405 by loading C<Carp> and calling C<Carp::longmess()> to get it. We turn off
7406 single stepping and tracing during the call to C<Carp::longmess> to avoid
7407 debugging it - we just want to use it.
7408
7409 If C<dieLevel> is zero, we let the program being debugged handle the
7410 exceptions. If it's 1, you get backtraces for any exception. If it's 2,
7411 the debugger takes over all exception handling, printing a backtrace and
7412 displaying the exception via its C<dbwarn()> routine.
7413
7414 =cut
7415
7416
7417 sub dbdie {
7418   local $frame = 0;
7419   local $doret = -2;
7420   local $SIG{__DIE__} = '';
7421   local $SIG{__WARN__} = '';
7422   my $i = 0; my $ineval = 0; my $sub;
7423   if ($dieLevel > 2) {
7424       local $SIG{__WARN__} = \&dbwarn;
7425       &warn(@_);        # Yell no matter what
7426       return;
7427   }
7428   if ($dieLevel < 2) {
7429     die @_ if $^S;        # in eval propagate
7430   }
7431
7432     # The code used to check $^S to see if compiliation of the current thing
7433     # hadn't finished. We don't do it anymore, figuring eval is pretty stable.
7434   # No need to check $^S, eval is much more robust nowadays
7435   eval { require Carp }; #if defined $^S;# If error/warning during compilation,
7436                                     # require may be broken.
7437
7438   die(@_, "\nCannot print stack trace, load with -MCarp option to see stack")
7439     unless defined &Carp::longmess;
7440
7441     # We do not want to debug this chunk (automatic disabling works
7442     # inside DB::DB, but not in Carp). Save $single and $trace, turn them off,
7443     # get the stack trace from Carp::longmess (if possible), restore $signal
7444     # and $trace, and then die with the stack trace.
7445   my ($mysingle, $mytrace) = ($single, $trace);
7446   $single = 0;
7447   $trace  = 0;
7448   my $mess = "@_";
7449   {
7450
7451     package Carp;    # Do not include us in the list
7452     eval { $mess = Carp::longmess(@_); };
7453   }
7454   ($single, $trace) = ($mysingle, $mytrace);
7455   die $mess;
7456 } ## end sub dbdie
7457
7458 =head2 C<warnlevel()>
7459
7460 Set the C<$DB::warnLevel> variable that stores the value of the
7461 C<warnLevel> option. Calling C<warnLevel()> with a positive value
7462 results in the debugger taking over all warning handlers. Setting
7463 C<warnLevel> to zero leaves any warning handlers set up by the program
7464 being debugged in place.
7465
7466 =cut
7467
7468 sub warnLevel {
7469   if (@_) {
7470     $prevwarn = $SIG{__WARN__} unless $warnLevel;
7471     $warnLevel = shift;
7472     if ($warnLevel) {
7473       $SIG{__WARN__} = \&DB::dbwarn;
7474     }
7475     elsif ($prevwarn) {
7476       $SIG{__WARN__} = $prevwarn;
7477     }
7478     } ## end if (@_)
7479   $warnLevel;
7480 } ## end sub warnLevel
7481
7482 =head2 C<dielevel>
7483
7484 Similar to C<warnLevel>. Non-zero values for C<dieLevel> result in the
7485 C<DB::dbdie()> function overriding any other C<die()> handler. Setting it to
7486 zero lets you use your own C<die()> handler.
7487
7488 =cut
7489
7490 sub dieLevel {
7491   local $\ = '';
7492   if (@_) {
7493     $prevdie = $SIG{__DIE__} unless $dieLevel;
7494     $dieLevel = shift;
7495     if ($dieLevel) {
7496             # Always set it to dbdie() for non-zero values.
7497       $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
7498
7499            # No longer exists, so don't try  to use it.
7500       #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
7501
7502             # If we've finished initialization, mention that stack dumps
7503             # are enabled, If dieLevel is 1, we won't stack dump if we die
7504             # in an eval().
7505       print $OUT "Stack dump during die enabled",
7506         ($dieLevel == 1 ? " outside of evals" : ""), ".\n"
7507       if $I_m_init;
7508
7509             # XXX This is probably obsolete, given that diehard() is gone.
7510       print $OUT "Dump printed too.\n" if $dieLevel > 2;
7511         } ## end if ($dieLevel)
7512
7513         # Put the old one back if there was one.
7514     elsif ($prevdie) {
7515       $SIG{__DIE__} = $prevdie;
7516       print $OUT "Default die handler restored.\n";
7517     }
7518     } ## end if (@_)
7519   $dieLevel;
7520 } ## end sub dieLevel
7521
7522 =head2 C<signalLevel>
7523
7524 Number three in a series: set C<signalLevel> to zero to keep your own
7525 signal handler for C<SIGSEGV> and/or C<SIGBUS>. Otherwise, the debugger
7526 takes over and handles them with C<DB::diesignal()>.
7527
7528 =cut
7529
7530 sub signalLevel {
7531   if (@_) {
7532     $prevsegv = $SIG{SEGV} unless $signalLevel;
7533     $prevbus  = $SIG{BUS}  unless $signalLevel;
7534     $signalLevel = shift;
7535     if ($signalLevel) {
7536       $SIG{SEGV} = \&DB::diesignal;
7537       $SIG{BUS}  = \&DB::diesignal;
7538     }
7539     else {
7540       $SIG{SEGV} = $prevsegv;
7541       $SIG{BUS}  = $prevbus;
7542     }
7543     } ## end if (@_)
7544   $signalLevel;
7545 } ## end sub signalLevel
7546
7547 =head1 SUBROUTINE DECODING SUPPORT
7548
7549 These subroutines are used during the C<x> and C<X> commands to try to
7550 produce as much information as possible about a code reference. They use
7551 L<Devel::Peek> to try to find the glob in which this code reference lives
7552 (if it does) - this allows us to actually code references which correspond
7553 to named subroutines (including those aliased via glob assignment).
7554
7555 =head2 C<CvGV_name()>
7556
7557 Wrapper for X<CvGV_name_or_bust>; tries to get the name of a reference
7558 via that routine. If this fails, return the reference again (when the
7559 reference is stringified, it'll come out as "SOMETHING(0X...)").
7560
7561 =cut
7562
7563 sub CvGV_name {
7564   my $in = shift;
7565   my $name = CvGV_name_or_bust($in);
7566   defined $name ? $name : $in;
7567 }
7568
7569 =head2 C<CvGV_name_or_bust> I<coderef>
7570
7571 Calls L<Devel::Peek> to try to find the glob the ref lives in; returns
7572 C<undef> if L<Devel::Peek> can't be loaded, or if C<Devel::Peek::CvGV> can't
7573 find a glob for this ref.
7574
7575 Returns "I<package>::I<glob name>" if the code ref is found in a glob.
7576
7577 =cut
7578
7579 sub CvGV_name_or_bust {
7580   my $in = shift;
7581   return if $skipCvGV;    # Backdoor to avoid problems if XS broken...
7582   return unless ref $in;
7583   $in = \&$in;            # Hard reference...
7584   eval { require Devel::Peek; 1 } or return;
7585   my $gv = Devel::Peek::CvGV($in) or return;
7586   *$gv{PACKAGE} . '::' . *$gv{NAME};
7587 } ## end sub CvGV_name_or_bust
7588
7589 =head2 C<find_sub>
7590
7591 A utility routine used in various places; finds the file where a subroutine
7592 was defined, and returns that filename and a line-number range.
7593
7594 Tries to use X<@sub> first; if it can't find it there, it tries building a
7595 reference to the subroutine and uses X<CvGV_name_or_bust> to locate it,
7596 loading it into X<@sub> as a side effect (XXX I think). If it can't find it
7597 this way, it brute-force searches X<%sub>, checking for identical references.
7598
7599 =cut
7600
7601 sub find_sub {
7602   my $subr = shift;
7603   $sub{$subr} or do {
7604     return unless defined &$subr;
7605     my $name = CvGV_name_or_bust($subr);
7606     my $data;
7607     $data = $sub{$name} if defined $name;
7608     return $data if defined $data;
7609
7610     # Old stupid way...
7611     $subr = \&$subr;        # Hard reference
7612     my $s;
7613     for (keys %sub) {
7614       $s = $_, last if $subr eq \&$_;
7615     }
7616     $sub{$s} if $s;
7617       } ## end do
7618 } ## end sub find_sub
7619
7620 =head2 C<methods>
7621
7622 A subroutine that uses the utility function X<methods_via> to find all the
7623 methods in the class corresponding to the current reference and in
7624 C<UNIVERSAL>.
7625
7626 =cut
7627
7628 sub methods {
7629
7630     # Figure out the class - either this is the class or it's a reference
7631     # to something blessed into that class.
7632   my $class = shift;
7633   $class = ref $class if ref $class;
7634
7635   local %seen;
7636   local %packs;
7637
7638     # Show the methods that this class has.
7639   methods_via($class, '', 1);
7640   methods_via('UNIVERSAL', 'UNIVERSAL', 0);
7641 } ## end sub methods
7642
7643 =head2 C<methods_via($class, $prefix, $crawl_upward)>
7644
7645 C<methods_via> does the work of crawling up the C<@ISA> tree and reporting
7646 all the parent class methods. C<$class> is the name of the next class to
7647 try; C<$prefix> is the message prefix, which gets built up as we go up the
7648 C<@ISA> tree to show parentage; C<$crawl_upward> is 1 if we should try to go
7649 higher in the C<@ISA> tree, 0 if we should stop.
7650
7651 =cut
7652
7653 sub methods_via {
7654     # If we've processed this class already, just quit.
7655   my $class = shift;
7656   return if $packs{$class}++;
7657
7658     # This is a package that is contributing the methods we're about to print.
7659   my $prefix = shift;
7660   my $prepend = $prefix ? "via $prefix: " : '';
7661
7662   my $name;
7663   for $name (
7664         # Keep if this is a defined subroutine in this class.
7665         grep {defined &{${"${class}::"}{$_}}}
7666              # Extract from all the symbols in this class.
7667              sort keys %{"${class}::"}
7668     ) {
7669         # If we printed this already, skip it.
7670     next if $seen{ $name }++;
7671
7672         # Print the new method name.
7673     local $\ = '';
7674     local $, = '';
7675     print $DB::OUT "$prepend$name\n";
7676     } ## end for $name (grep { defined...
7677
7678     # If the $crawl_upward argument is false, just quit here.
7679   return unless shift;        # Recurse?
7680
7681     # $crawl_upward true: keep going up the tree.
7682     # Find all the classes this one is a subclass of.
7683   for $name (@{"${class}::ISA"}) {
7684         # Set up the new prefix.
7685     $prepend = $prefix ? $prefix . " -> $name" : $name;
7686         # Crawl up the tree and keep trying to crawl up.
7687     methods_via($name, $prepend, 1);
7688   }
7689 } ## end sub methods_via
7690
7691 =head2 C<setman> - figure out which command to use to show documentation
7692
7693 Just checks the contents of C<$^O> and sets the C<$doccmd> global accordingly.
7694
7695 =cut
7696
7697 sub setman {
7698     $doccmd = $^O !~ /^(?:MSWin32|VMS|os2|dos|amigaos|riscos|MacOS|NetWare)\z/s
7699         ? "man"             # O Happy Day!
7700         : "perldoc";        # Alas, poor unfortunates
7701 } ## end sub setman
7702
7703 =head2 C<runman> - run the appropriate command to show documentation
7704
7705 Accepts a man page name; runs the appropriate command to display it (set up
7706 during debugger initialization). Uses C<DB::system> to avoid mucking up the
7707 program's STDIN and STDOUT.
7708
7709 =cut
7710
7711
7712 sub runman {
7713     my $page = shift;
7714     unless ($page) {
7715         &system("$doccmd $doccmd");
7716         return;
7717     }
7718
7719     # this way user can override, like with $doccmd="man -Mwhatever"
7720     # or even just "man " to disable the path check.
7721     unless ($doccmd eq 'man') {
7722         &system("$doccmd $page");
7723         return;
7724     }
7725
7726     $page = 'perl' if lc($page) eq 'help';
7727
7728     require Config;
7729     my $man1dir = $Config::Config{'man1dir'};
7730     my $man3dir = $Config::Config{'man3dir'};
7731     for ($man1dir, $man3dir) { s#/[^/]*\z## if /\S/ }
7732     my $manpath = '';
7733     $manpath .= "$man1dir:" if $man1dir =~ /\S/;
7734     $manpath .= "$man3dir:" if $man3dir =~ /\S/ && $man1dir ne $man3dir;
7735     chop $manpath if $manpath;
7736
7737     # harmless if missing, I figure
7738     my $oldpath = $ENV{MANPATH};
7739     $ENV{MANPATH} = $manpath if $manpath;
7740     my $nopathopt = $^O =~ /dunno what goes here/;
7741     if (
7742         CORE::system(
7743             $doccmd,
7744
7745         # I just *know* there are men without -M
7746         (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),
7747         split ' ', $page
7748         )
7749     )
7750     {
7751     unless ($page =~ /^perl\w/) {
7752         if (
7753             grep { $page eq $_ }
7754             qw{
7755         5004delta 5005delta amiga api apio book boot bot call compile
7756         cygwin data dbmfilter debug debguts delta diag doc dos dsc embed
7757         faq faq1 faq2 faq3 faq4 faq5 faq6 faq7 faq8 faq9 filter fork
7758         form func guts hack hist hpux intern ipc lexwarn locale lol mod
7759         modinstall modlib number obj op opentut os2 os390 pod port
7760         ref reftut run sec style sub syn thrtut tie toc todo toot tootc
7761         trap unicode var vms win32 xs xstut
7762           }
7763         )
7764         {
7765         $page =~ s/^/perl/;
7766         CORE::system($doccmd,
7767             (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),
7768             $page);
7769             } ## end if (grep { $page eq $_...
7770         } ## end unless ($page =~ /^perl\w/)
7771     } ## end if (CORE::system($doccmd...
7772     if (defined $oldpath) {
7773     $ENV{MANPATH} = $manpath;
7774     }
7775     else {
7776     delete $ENV{MANPATH};
7777     }
7778 } ## end sub runman
7779
7780 #use Carp;                          # This did break, left for debugging
7781
7782 =head1 DEBUGGER INITIALIZATION - THE SECOND BEGIN BLOCK
7783
7784 Because of the way the debugger interface to the Perl core is designed, any
7785 debugger package globals that C<DB::sub()> requires have to be defined before
7786 any subroutines can be called. These are defined in the second C<BEGIN> block.
7787
7788 This block sets things up so that (basically) the world is sane
7789 before the debugger starts executing. We set up various variables that the
7790 debugger has to have set up before the Perl core starts running:
7791
7792 =over 4
7793
7794 =item * The debugger's own filehandles (copies of STD and STDOUT for now).
7795
7796 =item * Characters for shell escapes, the recall command, and the history command.
7797
7798 =item * The maximum recursion depth.
7799
7800 =item * The size of a C<w> command's window.
7801
7802 =item * The before-this-line context to be printed in a C<v> (view a window around this line) command.
7803
7804 =item * The fact that we're not in a sub at all right now.
7805
7806 =item * The default SIGINT handler for the debugger.
7807
7808 =item * The appropriate value of the flag in C<$^D> that says the debugger is running
7809
7810 =item * The current debugger recursion level
7811
7812 =item * The list of postponed (XXX define) items and the C<$single> stack
7813
7814 =item * That we want no return values and no subroutine entry/exit trace.
7815
7816 =back
7817
7818 =cut
7819
7820 # The following BEGIN is very handy if debugger goes havoc, debugging debugger?
7821
7822 BEGIN {            # This does not compile, alas.
7823   $IN = \*STDIN;        # For bugs before DB::OUT has been opened
7824   $OUT = \*STDERR;        # For errors before DB::OUT has been opened
7825
7826     # Define characters used by command parsing.
7827     $sh      = '!';         # Shell escape (does not work)
7828     $rc      = ',';         # Recall command (does not work)
7829     @hist    = ('?');       # Show history (does not work)
7830     @truehist=();           # Can be saved for replay (per session)
7831
7832     # This defines the point at which you get the 'deep recursion'
7833     # warning. It MUST be defined or the debugger will not load.
7834   $deep = 100;
7835
7836     # Number of lines around the current one that are shown in the
7837     # 'w' command.
7838   $window = 10;
7839
7840     # How much before-the-current-line context the 'v' command should
7841     # use in calculating the start of the window it will display.
7842   $preview = 3;
7843
7844     # We're not in any sub yet, but we need this to be a defined value.
7845   $sub = '';
7846
7847     # Set up the debugger's interrupt handler. It simply sets a flag
7848     # ($signal) that DB::DB() will check before each command is executed.
7849   $SIG{INT} = \&DB::catch;
7850
7851     # The following lines supposedly, if uncommented, allow the debugger to
7852     # debug itself. Perhaps we can try that someday.
7853     # This may be enabled to debug debugger:
7854   #$warnLevel = 1 unless defined $warnLevel;
7855   #$dieLevel = 1 unless defined $dieLevel;
7856   #$signalLevel = 1 unless defined $signalLevel;
7857
7858     # This is the flag that says "a debugger is running, please call
7859     # DB::DB and DB::sub". We will turn it on forcibly before we try to
7860     # execute anything in the user's context, because we always want to
7861     # get control back.
7862   $db_stop = 0;            # Compiler warning
7863   $db_stop = 1 << 30;
7864
7865     # This variable records how many levels we're nested in debugging. Used
7866     # Used in the debugger prompt, and in determining whether it's all over or
7867     # not.
7868   $level = 0;           # Level of recursive debugging
7869
7870     # "Triggers bug (?) in perl if we postpone this until runtime."
7871     # XXX No details on this yet, or whether we should fix the bug instead
7872     # of work around it. Stay tuned.
7873   @postponed = @stack = (0);
7874
7875     # Used to track the current stack depth using the auto-stacked-variable
7876     # trick.
7877     $stack_depth = 0;    # Localized repeatedly; simple way to track $#stack
7878
7879     # Don't print return values on exiting a subroutine.
7880   $doret = -2;
7881
7882     # No extry/exit tracing.
7883   $frame = 0;
7884
7885 } ## end BEGIN
7886
7887 BEGIN { $^W = $ini_warn; }    # Switch warnings back
7888
7889 =head1 READLINE SUPPORT - COMPLETION FUNCTION
7890
7891 =head2 db_complete
7892
7893 C<readline> support - adds command completion to basic C<readline>.
7894
7895 Returns a list of possible completions to C<readline> when invoked. C<readline>
7896 will print the longest common substring following the text already entered.
7897
7898 If there is only a single possible completion, C<readline> will use it in full.
7899
7900 This code uses C<map> and C<grep> heavily to create lists of possible
7901 completion. Think LISP in this section.
7902
7903 =cut
7904
7905 sub db_complete {
7906
7907     # Specific code for b c l V m f O, &blah, $blah, @blah, %blah
7908     # $text is the text to be completed.
7909     # $line is the incoming line typed by the user.
7910     # $start is the start of the text to be completed in the incoming line.
7911   my ($text, $line, $start) = @_;
7912
7913     # Save the initial text.
7914     # The search pattern is current package, ::, extract the next qualifier
7915     # Prefix and pack are set to undef.
7916   my ($itext, $search, $prefix, $pack) =
7917     ($text, "^\Q${'package'}::\E([^:]+)\$");
7918
7919 =head3 C<b postpone|compile>
7920
7921 =over 4
7922
7923 =item * Find all the subroutines that might match in this package
7924
7925 =item * Add "postpone", "load", and "compile" as possibles (we may be completing the keyword itself
7926
7927 =item * Include all the rest of the subs that are known
7928
7929 =item * C<grep> out the ones that match the text we have so far
7930
7931 =item * Return this as the list of possible completions
7932
7933 =back
7934
7935 =cut
7936
7937   return sort grep /^\Q$text/, (keys %sub),
7938     qw(postpone load compile), # subroutines
7939       (map { /$search/ ? ($1) : () } keys %sub)
7940       if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/;
7941
7942 =head3 C<b load>
7943
7944 Get all the possible files from @INC as it currently stands and
7945 select the ones that match the text so far.
7946
7947 =cut
7948
7949   return sort grep /^\Q$text/, values %INC # files
7950     if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/;
7951
7952 =head3  C<V> (list variable) and C<m> (list modules)
7953
7954 There are two entry points for these commands:
7955
7956 =head4 Unqualified package names
7957
7958 Get the top-level packages and grab everything that matches the text
7959 so far. For each match, recursively complete the partial packages to
7960 get all possible matching packages. Return this sorted list.
7961
7962 =cut
7963
7964   return sort map {($_, db_complete($_ . "::", "V ", 2))}
7965     grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # top-packages
7966       if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/;
7967
7968 =head4 Qualified package names
7969
7970 Take a partially-qualified package and find all subpackages for it
7971 by getting all the subpackages for the package so far, matching all
7972 the subpackages against the text, and discarding all of them which
7973 start with 'main::'. Return this list.
7974
7975 =cut
7976
7977   return sort map { ($_, db_complete($_ . "::", "V ", 2))}
7978     grep !/^main::/, grep /^\Q$text/,
7979         map { /^(.*)::$/ ? ($prefix . "::$1") : () } keys %{ $prefix . '::' }
7980           if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/
7981               and $text =~ /^(.*[^:])::?(\w*)$/
7982             and $prefix = $1;
7983
7984 =head3 C<f> - switch files
7985
7986 Here, we want to get a fully-qualified filename for the C<f> command.
7987 Possibilities are:
7988
7989 =over 4
7990
7991 =item 1. The original source file itself
7992
7993 =item 2. A file from C<@INC>
7994
7995 =item 3. An C<eval> (the debugger gets a C<(eval N)> fake file for each C<eval>).
7996
7997 =back
7998
7999 =cut
8000
8001   if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files
8002         # We might possibly want to switch to an eval (which has a "filename"
8003         # like '(eval 9)'), so we may need to clean up the completion text
8004         # before proceeding.
8005     $prefix = length($1) - length($text);
8006     $text = $1;
8007
8008 =pod
8009
8010 Under the debugger, source files are represented as C<_E<lt>/fullpath/to/file>
8011 (C<eval>s are C<_E<lt>(eval NNN)>) keys in C<%main::>. We pull all of these
8012 out of C<%main::>, add the initial source file, and extract the ones that
8013 match the completion text so far.
8014
8015 =cut
8016
8017     return sort
8018         map { substr $_, 2 + $prefix } grep /^_<\Q$text/, (keys %main::),
8019         $0;
8020     } ## end if ($line =~ /^\|*f\s+(.*)/)
8021
8022 =head3 Subroutine name completion
8023
8024 We look through all of the defined subs (the keys of C<%sub>) and
8025 return both all the possible matches to the subroutine name plus
8026 all the matches qualified to the current package.
8027
8028 =cut
8029
8030   if ((substr $text, 0, 1) eq '&') { # subroutines
8031     $text = substr $text, 1;
8032     $prefix = "&";
8033     return sort map "$prefix$_", grep /^\Q$text/, (keys %sub),
8034           (
8035             map { /$search/ ? ($1) : () }
8036             keys %sub
8037             );
8038     } ## end if ((substr $text, 0, ...
8039
8040 =head3  Scalar, array, and hash completion: partially qualified package
8041
8042 Much like the above, except we have to do a little more cleanup:
8043
8044 =cut
8045
8046   if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
8047
8048 =pod
8049
8050 =over 4
8051
8052 =item * Determine the package that the symbol is in. Put it in C<::> (effectively C<main::>) if no package is specified.
8053
8054 =cut
8055
8056     $pack = ($1 eq 'main' ? '' : $1) . '::';
8057
8058 =pod
8059
8060 =item * Figure out the prefix vs. what needs completing.
8061
8062 =cut
8063
8064     $prefix = (substr $text, 0, 1) . $1 . '::';
8065     $text = $2;
8066
8067 =pod
8068
8069 =item * Look through all the symbols in the package. C<grep> out all the possible hashes/arrays/scalars, and then C<grep> the possible matches out of those. C<map> the prefix onto all the possibilities.
8070
8071 =cut
8072
8073     my @out = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/,
8074         keys %$pack;
8075
8076 =pod
8077
8078 =item * If there's only one hit, and it's a package qualifier, and it's not equal to the initial text, re-complete it using the symbol we actually found.
8079
8080 =cut
8081
8082     if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
8083       return db_complete($out[0], $line, $start);
8084     }
8085
8086         # Return the list of possibles.
8087    return sort @out;
8088
8089     } ## end if ($text =~ /^[\$@%](.*)::(.*)/)
8090
8091 =pod
8092
8093 =back
8094
8095 =head3 Symbol completion: current package or package C<main>.
8096
8097 =cut
8098
8099
8100   if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
8101
8102 =pod
8103
8104 =over 4
8105
8106 =item * If it's C<main>, delete main to just get C<::> leading.
8107
8108 =cut
8109
8110     $pack = ($package eq 'main' ? '' : $package) . '::';
8111
8112 =pod
8113
8114 =item * We set the prefix to the item's sigil, and trim off the sigil to get the text to be completed.
8115
8116 =cut
8117
8118     $prefix = substr $text, 0, 1;
8119     $text = substr $text, 1;
8120
8121 =pod
8122
8123 =item * If the package is C<::> (C<main>), create an empty list; if it's something else, create a list of all the packages known.  Append whichever list to a list of all the possible symbols in the current package. C<grep> out the matches to the text entered so far, then C<map> the prefix back onto the symbols.
8124
8125 =cut
8126
8127     my @out = map "$prefix$_", grep /^\Q$text/,
8128        (grep /^_?[a-zA-Z]/, keys %$pack),
8129        ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ;
8130
8131 =item * If there's only one hit, it's a package qualifier, and it's not equal to the initial text, recomplete using this symbol.
8132
8133 =back
8134
8135 =cut
8136
8137     if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
8138       return db_complete($out[0], $line, $start);
8139     }
8140
8141         # Return the list of possibles.
8142     return sort @out;
8143     } ## end if ($text =~ /^[\$@%]/)
8144
8145 =head3 Options
8146
8147 We use C<option_val()> to look up the current value of the option. If there's
8148 only a single value, we complete the command in such a way that it is a
8149 complete command for setting the option in question. If there are multiple
8150 possible values, we generate a command consisting of the option plus a trailing
8151 question mark, which, if executed, will list the current value of the option.
8152
8153 =cut
8154
8155
8156   if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space
8157         # We look for the text to be matched in the list of possible options,
8158         # and fetch the current value.
8159     my @out = grep /^\Q$text/, @options;
8160     my $val = option_val($out[0], undef);
8161
8162         # Set up a 'query option's value' command.
8163     my $out = '? ';
8164     if (not defined $val or $val =~ /[\n\r]/) {
8165            # There's really nothing else we can do.
8166     }
8167
8168         # We have a value. Create a proper option-setting command.
8169     elsif ($val =~ /\s/) {
8170             # XXX This may be an extraneous variable.
8171       my $found;
8172
8173             # We'll want to quote the string (because of the embedded
8174             # whtespace), but we want to make sure we don't end up with
8175             # mismatched quote characters. We try several possibilities.
8176       foreach $l (split //, qq/\"\'\#\|/) {
8177                 # If we didn't find this quote character in the value,
8178                 # quote it using this quote character.
8179     $out = "$l$val$l ", last if (index $val, $l) == -1;
8180       }
8181         } ## end elsif ($val =~ /\s/)
8182
8183         # Don't need any quotes.
8184     else {
8185       $out = "=$val ";
8186     }
8187
8188         # If there were multiple possible values, return '? ', which
8189         # makes the command into a query command. If there was just one,
8190         # have readline append that.
8191     $rl_attribs->{completer_terminator_character} =
8192         (@out == 1 ? $out : '? ');
8193
8194         # Return list of possibilities.
8195     return sort @out;
8196     } ## end if ((substr $line, 0, ...
8197
8198 =head3 Filename completion
8199
8200 For entering filenames. We simply call C<readline>'s C<filename_list()>
8201 method with the completion text to get the possible completions.
8202
8203 =cut
8204
8205   return $term->filename_list($text); # filenames
8206
8207 } ## end sub db_complete
8208
8209 =head1 MISCELLANEOUS SUPPORT FUNCTIONS
8210
8211 Functions that possibly ought to be somewhere else.
8212
8213 =head2 end_report
8214
8215 Say we're done.
8216
8217 =cut
8218
8219 sub end_report {
8220   local $\ = '';
8221   print $OUT "Use `q' to quit or `R' to restart.  `h q' for details.\n"
8222 }
8223
8224 =head2 clean_ENV
8225
8226 If we have $ini_pids, save it in the environment; else remove it from the
8227 environment. Used by the C<R> (restart) command.
8228
8229 =cut
8230
8231 sub clean_ENV {
8232     if (defined($ini_pids)) {
8233         $ENV{PERLDB_PIDS} = $ini_pids;
8234     }
8235     else {
8236         delete($ENV{PERLDB_PIDS});
8237     }
8238 } ## end sub clean_ENV
8239
8240 # PERLDBf_... flag names from perl.h
8241 our (%DollarCaretP_flags, %DollarCaretP_flags_r);
8242 BEGIN {
8243   %DollarCaretP_flags =
8244     ( PERLDBf_SUB =>        0x01, # Debug sub enter/exit
8245       PERLDBf_LINE =>       0x02, # Keep line #
8246       PERLDBf_NOOPT =>      0x04, # Switch off optimizations
8247       PERLDBf_INTER =>      0x08, # Preserve more data
8248       PERLDBf_SUBLINE =>    0x10, # Keep subr source lines
8249       PERLDBf_SINGLE =>     0x20, # Start with single-step on
8250       PERLDBf_NONAME =>     0x40, # For _SUB: no name of the subr
8251       PERLDBf_GOTO =>       0x80, # Report goto: call DB::goto
8252       PERLDBf_NAMEEVAL =>  0x100, # Informative names for evals
8253       PERLDBf_NAMEANON =>  0x200, # Informative names for anon subs
8254       PERLDBf_ASSERTION => 0x400, # Debug assertion subs enter/exit
8255       PERLDB_ALL =>        0x33f, # No _NONAME, _GOTO, _ASSERTION
8256     );
8257
8258   %DollarCaretP_flags_r=reverse %DollarCaretP_flags;
8259 }
8260
8261 sub parse_DollarCaretP_flags {
8262     my $flags=shift;
8263     $flags=~s/^\s+//;
8264     $flags=~s/\s+$//;
8265     my $acu=0;
8266     foreach my $f (split /\s*\|\s*/, $flags) {
8267       my $value;
8268       if ($f=~/^0x([[:xdigit:]]+)$/) {
8269     $value=hex $1;
8270       }
8271       elsif ($f=~/^(\d+)$/) {
8272     $value=int $1;
8273       }
8274       elsif ($f=~/^DEFAULT$/i) {
8275     $value=$DollarCaretP_flags{PERLDB_ALL};
8276       }
8277       else {
8278     $f=~/^(?:PERLDBf_)?(.*)$/i;
8279     $value=$DollarCaretP_flags{'PERLDBf_'.uc($1)};
8280     unless (defined $value) {
8281       print $OUT ("Unrecognized \$^P flag '$f'!\n",
8282               "Acceptable flags are: ".
8283               join(', ', sort keys %DollarCaretP_flags),
8284               ", and hexadecimal and decimal numbers.\n");
8285       return undef;
8286     }
8287       }
8288       $acu|=$value;
8289     }
8290     $acu;
8291 }
8292
8293 sub expand_DollarCaretP_flags {
8294   my $DollarCaretP=shift;
8295   my @bits= ( map { my $n=(1<<$_);
8296             ($DollarCaretP & $n)
8297               ? ($DollarCaretP_flags_r{$n}
8298              || sprintf('0x%x', $n))
8299             : () } 0..31 );
8300   return @bits ? join('|', @bits) : 0;
8301 }
8302
8303 =head1 END PROCESSING - THE C<END> BLOCK
8304
8305 Come here at the very end of processing. We want to go into a
8306 loop where we allow the user to enter commands and interact with the
8307 debugger, but we don't want anything else to execute.
8308
8309 First we set the C<$finished> variable, so that some commands that
8310 shouldn't be run after the end of program quit working.
8311
8312 We then figure out whether we're truly done (as in the user entered a C<q>
8313 command, or we finished execution while running nonstop). If we aren't,
8314 we set C<$single> to 1 (causing the debugger to get control again).
8315
8316 We then call C<DB::fake::at_exit()>, which returns the C<Use 'q' to quit ...">
8317 message and returns control to the debugger. Repeat.
8318
8319 When the user finally enters a C<q> command, C<$fall_off_end> is set to
8320 1 and the C<END> block simply exits with C<$single> set to 0 (don't
8321 break, run to completion.).
8322
8323 =cut
8324
8325 END {
8326   $finished = 1 if $inhibit_exit;      # So that some keys may be disabled.
8327   $fall_off_end = 1 unless $inhibit_exit;
8328
8329   # Do not stop in at_exit() and destructors on exit:
8330   $DB::single = !$fall_off_end && !$runnonstop;
8331   DB::fake::at_exit() unless $fall_off_end or $runnonstop;
8332 } ## end END
8333
8334 =head1 PRE-5.8 COMMANDS
8335
8336 Some of the commands changed function quite a bit in the 5.8 command
8337 realignment, so much so that the old code had to be replaced completely.
8338 Because we wanted to retain the option of being able to go back to the
8339 former command set, we moved the old code off to this section.
8340
8341 There's an awful lot of duplicated code here. We've duplicated the
8342 comments to keep things clear.
8343
8344 =head2 Null command
8345
8346 Does nothing. Used to 'turn off' commands.
8347
8348 =cut
8349
8350 sub cmd_pre580_null {
8351
8352     # do nothing...
8353 }
8354
8355 =head2 Old C<a> command.
8356
8357 This version added actions if you supplied them, and deleted them
8358 if you didn't.
8359
8360 =cut
8361
8362 sub cmd_pre580_a {
8363     my $xcmd = shift;
8364     my $cmd  = shift;
8365
8366     # Argument supplied. Add the action.
8367     if ($cmd =~ /^(\d*)\s*(.*)/) {
8368
8369         # If the line isn't there, use the current line.
8370         $i = $1 || $line;
8371         $j = $2;
8372
8373         # If there is an action ...
8374         if (length $j) {
8375
8376             # ... but the line isn't breakable, skip it.
8377             if ($dbline[$i] == 0) {
8378                 print $OUT "Line $i may not have an action.\n";
8379             }
8380             else {
8381                 # ... and the line is breakable:
8382                 # Mark that there's an action in this file.
8383                 $had_breakpoints{$filename} |= 2;
8384
8385                 # Delete any current action.
8386                 $dbline{$i} =~ s/\0[^\0]*//;
8387
8388                 # Add the new action, continuing the line as needed.
8389                 $dbline{$i} .= "\0" . action($j);
8390             }
8391         } ## end if (length $j)
8392
8393         # No action supplied.
8394         else {
8395             # Delete the action.
8396             $dbline{$i} =~ s/\0[^\0]*//;
8397             delete $dbline{$i} if $dbline{$i} eq '';
8398         }
8399     } ## end if ($cmd =~ /^(\d*)\s*(.*)/)
8400 } ## end sub cmd_pre580_a
8401
8402 =head2 Old C<b> command
8403
8404 Add breakpoints.
8405
8406 =cut
8407
8408 sub cmd_pre580_b {
8409     my $xcmd    = shift;
8410     my $cmd    = shift;
8411     my $dbline = shift;
8412
8413     # Break on load.
8414     if ($cmd =~ /^load\b\s*(.*)/) {
8415         my $file = $1;
8416         $file =~ s/\s+$//;
8417         &cmd_b_load($file);
8418     }
8419
8420     # b compile|postpone <some sub> [<condition>]
8421     # The interpreter actually traps this one for us; we just put the
8422     # necessary condition in the %postponed hash.
8423     elsif ($cmd =~ /^(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/) {
8424         # Capture the condition if there is one. Make it true if none.
8425         my $cond = length $3 ? $3 : '1';
8426
8427         # Save the sub name and set $break to 1 if $1 was 'postpone', 0
8428         # if it was 'compile'.
8429         my ($subname, $break) = ($2, $1 eq 'postpone');
8430
8431         # De-Perl4-ify the name - ' separators to ::.
8432         $subname =~ s/\'/::/g;
8433
8434         # Qualify it into the current package unless it's already qualified.
8435         $subname = "${'package'}::" . $subname
8436         unless $subname =~ /::/;
8437
8438         # Add main if it starts with ::.
8439         $subname = "main" . $subname if substr($subname,0,2) eq "::";
8440
8441         # Save the break type for this sub.
8442         $postponed{$subname} = $break ? "break +0 if $cond" : "compile";
8443     } ## end elsif ($cmd =~ ...
8444
8445     # b <sub name> [<condition>]
8446     elsif ($cmd =~ /^([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/) {
8447         my $subname = $1;
8448         my $cond = length $2 ? $2 : '1';
8449         &cmd_b_sub($subname, $cond);
8450     }
8451
8452     # b <line> [<condition>].
8453     elsif ($cmd =~ /^(\d*)\s*(.*)/) {
8454         my $i = $1 || $dbline;
8455         my $cond = length $2 ? $2 : '1';
8456         &cmd_b_line($i, $cond);
8457     }
8458 } ## end sub cmd_pre580_b
8459
8460 =head2 Old C<D> command.
8461
8462 Delete all breakpoints unconditionally.
8463
8464 =cut
8465
8466 sub cmd_pre580_D {
8467     my $xcmd = shift;
8468     my $cmd  = shift;
8469     if ($cmd =~ /^\s*$/) {
8470         print $OUT "Deleting all breakpoints...\n";
8471
8472         # %had_breakpoints lists every file that had at least one
8473         # breakpoint in it.
8474         my $file;
8475         for $file (keys %had_breakpoints) {
8476             # Switch to the desired file temporarily.
8477             local *dbline = $main::{'_<' . $file};
8478
8479             my $max = $#dbline;
8480             my $was;
8481
8482             # For all lines in this file ...
8483             for ($i = 1; $i <= $max ; $i++) {
8484                 # If there's a breakpoint or action on this line ...
8485                 if (defined $dbline{$i}) {
8486                     # ... remove the breakpoint.
8487                     $dbline{$i} =~ s/^[^\0]+//;
8488                     if ($dbline{$i} =~ s/^\0?$//) {
8489                         # Remove the entry altogether if no action is there.
8490                         delete $dbline{$i};
8491                     }
8492                 } ## end if (defined $dbline{$i...
8493             } ## end for ($i = 1 ; $i <= $max...
8494
8495             # If, after we turn off the "there were breakpoints in this file"
8496             # bit, the entry in %had_breakpoints for this file is zero,
8497             # we should remove this file from the hash.
8498             if (not $had_breakpoints{$file} &= ~1) {
8499                 delete $had_breakpoints{$file};
8500             }
8501         } ## end for $file (keys %had_breakpoints)
8502
8503         # Kill off all the other breakpoints that are waiting for files that
8504         # haven't been loaded yet.
8505         undef %postponed;
8506         undef %postponed_file;
8507         undef %break_on_load;
8508     } ## end if ($cmd =~ /^\s*$/)
8509 } ## end sub cmd_pre580_D
8510
8511 =head2 Old C<h> command
8512
8513 Print help. Defaults to printing the long-form help; the 5.8 version
8514 prints the summary by default.
8515
8516 =cut
8517
8518 sub cmd_pre580_h {
8519     my $xcmd = shift;
8520     my $cmd  = shift;
8521
8522     # Print the *right* help, long format.
8523     if ($cmd =~ /^\s*$/) {
8524         print_help($pre580_help);
8525     }
8526
8527     # 'h h' - explicitly-requested summary.
8528     elsif ($cmd =~ /^h\s*/) {
8529         print_help($pre580_summary);
8530     }
8531
8532     # Find and print a command's help.
8533     elsif ($cmd =~ /^h\s+(\S.*)$/) {
8534         my $asked = $1;                 # for proper errmsg
8535         my $qasked = quotemeta($asked); # for searching
8536                                         # XXX: finds CR but not <CR>
8537         if ($pre580_help =~ /^
8538                               <?           # Optional '<'
8539                               (?:[IB]<)    # Optional markup
8540                               $qasked      # The command name
8541                             /mx) {
8542
8543             while (
8544                 $pre580_help =~ /^
8545                                   (             # The command help:
8546                                    <?           # Optional '<'
8547                                    (?:[IB]<)    # Optional markup
8548                                    $qasked      # The command name
8549                                    ([\s\S]*?)   # Lines starting with tabs
8550                                    \n           # Final newline
8551                                   )
8552                                   (?!\s)/mgx)   # Line not starting with space
8553                                                 # (Next command's help)
8554             {
8555                 print_help($1);
8556             }
8557         } ## end if ($pre580_help =~ /^<?(?:[IB]<)$qasked/m)
8558
8559         # Help not found.
8560         else {
8561             print_help("B<$asked> is not a debugger command.\n");
8562         }
8563     } ## end elsif ($cmd =~ /^h\s+(\S.*)$/)
8564 } ## end sub cmd_pre580_h
8565
8566 =head2 Old C<W> command
8567
8568 C<W E<lt>exprE<gt>> adds a watch expression, C<W> deletes them all.
8569
8570 =cut
8571
8572 sub cmd_pre580_W {
8573     my $xcmd = shift;
8574     my $cmd  = shift;
8575
8576     # Delete all watch expressions.
8577     if ($cmd =~ /^$/) {
8578         # No watching is going on.
8579         $trace &= ~2;
8580         # Kill all the watch expressions and values.
8581         @to_watch = @old_watch = ();
8582     }
8583
8584     # Add a watch expression.
8585     elsif ($cmd =~ /^(.*)/s) {
8586         # add it to the list to be watched.
8587         push @to_watch, $1;
8588
8589         # Get the current value of the expression.
8590         # Doesn't handle expressions returning list values!
8591         $evalarg = $1;
8592         my ($val) = &eval;
8593         $val = (defined $val) ? "'$val'" : 'undef';
8594
8595         # Save it.
8596         push @old_watch, $val;
8597
8598         # We're watching stuff.
8599         $trace |= 2;
8600
8601     } ## end elsif ($cmd =~ /^(.*)/s)
8602 } ## end sub cmd_pre580_W
8603
8604 =head1 PRE-AND-POST-PROMPT COMMANDS AND ACTIONS
8605
8606 The debugger used to have a bunch of nearly-identical code to handle
8607 the pre-and-post-prompt action commands. C<cmd_pre590_prepost> and
8608 C<cmd_prepost> unify all this into one set of code to handle the
8609 appropriate actions.
8610
8611 =head2 C<cmd_pre590_prepost>
8612
8613 A small wrapper around C<cmd_prepost>; it makes sure that the default doesn't
8614 do something destructive. In pre 5.8 debuggers, the default action was to
8615 delete all the actions.
8616
8617 =cut
8618
8619 sub cmd_pre590_prepost {
8620     my $cmd    = shift;
8621     my $line   = shift || '*';
8622     my $dbline = shift;
8623
8624     return &cmd_prepost( $cmd, $line, $dbline );
8625 } ## end sub cmd_pre590_prepost
8626
8627 =head2 C<cmd_prepost>
8628
8629 Actually does all the handling foe C<E<lt>>, C<E<gt>>, C<{{>, C<{>, etc.
8630 Since the lists of actions are all held in arrays that are pointed to by
8631 references anyway, all we have to do is pick the right array reference and
8632 then use generic code to all, delete, or list actions.
8633
8634 =cut
8635
8636 sub cmd_prepost {
8637
8638     my $cmd    = shift;
8639
8640     # No action supplied defaults to 'list'.
8641     my $line   = shift || '?';
8642     my $which = '';
8643
8644     # Make sure we have some array or another to address later.
8645     # This means that if ssome reason the tests fail, we won't be
8646     # trying to stash actions or delete them from the wrong place.
8647     my $aref  = [];
8648
8649    # < - Perl code to run before prompt.
8650     if ( $cmd =~ /^\</o ) {
8651         $which = 'pre-perl';
8652         $aref  = $pre;
8653     }
8654
8655     # > - Perl code to run after prompt.
8656     elsif ( $cmd =~ /^\>/o ) {
8657         $which = 'post-perl';
8658         $aref  = $post;
8659     }
8660
8661     # { - first check for properly-balanced braces.
8662     elsif ( $cmd =~ /^\{/o ) {
8663         if ( $cmd =~ /^\{.*\}$/o && unbalanced( substr( $cmd, 1 ) ) ) {
8664             print $OUT
8665 "$cmd is now a debugger command\nuse `;$cmd' if you mean Perl code\n";
8666         }
8667
8668         # Properly balanced. Pre-prompt debugger actions.
8669         else {
8670             $which = 'pre-debugger';
8671             $aref  = $pretype;
8672         }
8673     } ## end elsif ( $cmd =~ /^\{/o )
8674
8675     # Did we find something that makes sense?
8676     unless ($which) {
8677         print $OUT "Confused by command: $cmd\n";
8678     }
8679
8680     # Yes.
8681     else {
8682         # List actions.
8683         if ( $line =~ /^\s*\?\s*$/o ) {
8684             unless (@$aref) {
8685                 # Nothing there. Complain.
8686                 print $OUT "No $which actions.\n";
8687             }
8688             else {
8689                 # List the actions in the selected list.
8690                 print $OUT "$which commands:\n";
8691                 foreach my $action (@$aref) {
8692                     print $OUT "\t$cmd -- $action\n";
8693                 }
8694             } ## end else
8695         } ## end if ( $line =~ /^\s*\?\s*$/o)
8696
8697         # Might be a delete.
8698         else {
8699             if ( length($cmd) == 1 ) {
8700                 if ( $line =~ /^\s*\*\s*$/o ) {
8701                     # It's a delete. Get rid of the old actions in the
8702                     # selected list..
8703                     @$aref = ();
8704                     print $OUT "All $cmd actions cleared.\n";
8705                 }
8706                 else {
8707                     # Replace all the actions. (This is a <, >, or {).
8708                     @$aref = action($line);
8709                 }
8710             } ## end if ( length($cmd) == 1)
8711             elsif ( length($cmd) == 2 ) {
8712                 # Add the action to the line. (This is a <<, >>, or {{).
8713                 push @$aref, action($line);
8714             }
8715             else {
8716                 # <<<, >>>>, {{{{{{ ... something not a command.
8717                 print $OUT
8718                   "Confused by strange length of $which command($cmd)...\n";
8719             }
8720         } ## end else [ if ( $line =~ /^\s*\?\s*$/o)
8721     } ## end else
8722 } ## end sub cmd_prepost
8723
8724
8725 =head1 C<DB::fake>
8726
8727 Contains the C<at_exit> routine that the debugger uses to issue the
8728 C<Debugged program terminated ...> message after the program completes. See
8729 the C<END> block documentation for more details.
8730
8731 =cut
8732
8733 package DB::fake;
8734
8735 sub at_exit {
8736   "Debugged program terminated.  Use `q' to quit or `R' to restart.";
8737 }
8738
8739 package DB;    # Do not trace this 1; below!
8740
8741 1;
8742