lib/perl5db.pl

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