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