[perl #123737] Fix assertion failure with 0$#{
[perl.git] / 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 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 =head1 GENERAL NOTES
18
19 The debugger can look pretty forbidding to many Perl programmers. There are
20 a number of reasons for this, many stemming out of the debugger's history.
21
22 When the debugger was first written, Perl didn't have a lot of its nicer
23 features - no references, no lexical variables, no closures, no object-oriented
24 programming. So a lot of the things one would normally have done using such
25 features was done using global variables, globs and the C<local()> operator
26 in creative ways.
27
28 Some of these have survived into the current debugger; a few of the more
29 interesting and still-useful idioms are noted in this section, along with notes
30 on the comments themselves.
31
32 =head2 Why not use more lexicals?
33
34 Experienced Perl programmers will note that the debugger code tends to use
35 mostly package globals rather than lexically-scoped variables. This is done
36 to allow a significant amount of control of the debugger from outside the
37 debugger itself.
38
39 Unfortunately, though the variables are accessible, they're not well
40 documented, so it's generally been a decision that hasn't made a lot of
41 difference to most users. Where appropriate, comments have been added to
42 make variables more accessible and usable, with the understanding that these
43 I<are> debugger internals, and are therefore subject to change. Future
44 development should probably attempt to replace the globals with a well-defined
45 API, but for now, the variables are what we've got.
46
47 =head2 Automated variable stacking via C<local()>
48
49 As you may recall from reading C<perlfunc>, the C<local()> operator makes a
50 temporary copy of a variable in the current scope. When the scope ends, the
51 old copy is restored. This is often used in the debugger to handle the
52 automatic stacking of variables during recursive calls:
53
54      sub foo {
55         local $some_global++;
56
57         # Do some stuff, then ...
58         return;
59      }
60
61 What happens is that on entry to the subroutine, C<$some_global> is localized,
62 then altered. When the subroutine returns, Perl automatically undoes the
63 localization, restoring the previous value. Voila, automatic stack management.
64
65 The debugger uses this trick a I<lot>. Of particular note is C<DB::eval>,
66 which lets the debugger get control inside of C<eval>'ed code. The debugger
67 localizes a saved copy of C<$@> inside the subroutine, which allows it to
68 keep C<$@> safe until it C<DB::eval> returns, at which point the previous
69 value of C<$@> is restored. This makes it simple (well, I<simpler>) to keep
70 track of C<$@> inside C<eval>s which C<eval> other C<eval's>.
71
72 In any case, watch for this pattern. It occurs fairly often.
73
74 =head2 The C<^> trick
75
76 This is used to cleverly reverse the sense of a logical test depending on
77 the value of an auxiliary variable. For instance, the debugger's C<S>
78 (search for subroutines by pattern) allows you to negate the pattern
79 like this:
80
81    # Find all non-'foo' subs:
82    S !/foo/
83
84 Boolean algebra states that the truth table for XOR looks like this:
85
86 =over 4
87
88 =item * 0 ^ 0 = 0
89
90 (! not present and no match) --> false, don't print
91
92 =item * 0 ^ 1 = 1
93
94 (! not present and matches) --> true, print
95
96 =item * 1 ^ 0 = 1
97
98 (! present and no match) --> true, print
99
100 =item * 1 ^ 1 = 0
101
102 (! present and matches) --> false, don't print
103
104 =back
105
106 As you can see, the first pair applies when C<!> isn't supplied, and
107 the second pair applies when it is. The XOR simply allows us to
108 compact a more complicated if-then-elseif-else into a more elegant
109 (but perhaps overly clever) single test. After all, it needed this
110 explanation...
111
112 =head2 FLAGS, FLAGS, FLAGS
113
114 There is a certain C programming legacy in the debugger. Some variables,
115 such as C<$single>, C<$trace>, and C<$frame>, have I<magical> values composed
116 of 1, 2, 4, etc. (powers of 2) OR'ed together. This allows several pieces
117 of state to be stored independently in a single scalar.
118
119 A test like
120
121     if ($scalar & 4) ...
122
123 is checking to see if the appropriate bit is on. Since each bit can be
124 "addressed" independently in this way, C<$scalar> is acting sort of like
125 an array of bits. Obviously, since the contents of C<$scalar> are just a
126 bit-pattern, we can save and restore it easily (it will just look like
127 a number).
128
129 The problem, is of course, that this tends to leave magic numbers scattered
130 all over your program whenever a bit is set, cleared, or checked. So why do
131 it?
132
133 =over 4
134
135 =item *
136
137 First, doing an arithmetical or bitwise operation on a scalar is
138 just about the fastest thing you can do in Perl: C<use constant> actually
139 creates a subroutine call, and array and hash lookups are much slower. Is
140 this over-optimization at the expense of readability? Possibly, but the
141 debugger accesses these  variables a I<lot>. Any rewrite of the code will
142 probably have to benchmark alternate implementations and see which is the
143 best balance of readability and speed, and then document how it actually
144 works.
145
146 =item *
147
148 Second, it's very easy to serialize a scalar number. This is done in
149 the restart code; the debugger state variables are saved in C<%ENV> and then
150 restored when the debugger is restarted. Having them be just numbers makes
151 this trivial.
152
153 =item *
154
155 Third, some of these variables are being shared with the Perl core
156 smack in the middle of the interpreter's execution loop. It's much faster for
157 a C program (like the interpreter) to check a bit in a scalar than to access
158 several different variables (or a Perl array).
159
160 =back
161
162 =head2 What are those C<XXX> comments for?
163
164 Any comment containing C<XXX> means that the comment is either somewhat
165 speculative - it's not exactly clear what a given variable or chunk of
166 code is doing, or that it is incomplete - the basics may be clear, but the
167 subtleties are not completely documented.
168
169 Send in a patch if you can clear up, fill out, or clarify an C<XXX>.
170
171 =head1 DATA STRUCTURES MAINTAINED BY CORE
172
173 There are a number of special data structures provided to the debugger by
174 the Perl interpreter.
175
176 The array C<@{$main::{'_<'.$filename}}> (aliased locally to C<@dbline>
177 via glob assignment) contains the text from C<$filename>, with each
178 element corresponding to a single line of C<$filename>. Additionally,
179 breakable lines will be dualvars with the numeric component being the
180 memory address of a COP node. Non-breakable lines are dualvar to 0.
181
182 The hash C<%{'_<'.$filename}> (aliased locally to C<%dbline> via glob
183 assignment) contains breakpoints and actions.  The keys are line numbers;
184 you can set individual values, but not the whole hash. The Perl interpreter
185 uses this hash to determine where breakpoints have been set. Any true value is
186 considered to be a breakpoint; C<perl5db.pl> uses C<$break_condition\0$action>.
187 Values are magical in numeric context: 1 if the line is breakable, 0 if not.
188
189 The scalar C<${"_<$filename"}> simply contains the string C<$filename>.
190 This is also the case for evaluated strings that contain subroutines, or
191 which are currently being executed.  The $filename for C<eval>ed strings looks
192 like C<(eval 34).
193
194 =head1 DEBUGGER STARTUP
195
196 When C<perl5db.pl> starts, it reads an rcfile (C<perl5db.ini> for
197 non-interactive sessions, C<.perldb> for interactive ones) that can set a number
198 of options. In addition, this file may define a subroutine C<&afterinit>
199 that will be executed (in the debugger's context) after the debugger has
200 initialized itself.
201
202 Next, it checks the C<PERLDB_OPTS> environment variable and treats its
203 contents as the argument of a C<o> command in the debugger.
204
205 =head2 STARTUP-ONLY OPTIONS
206
207 The following options can only be specified at startup.
208 To set them in your rcfile, add a call to
209 C<&parse_options("optionName=new_value")>.
210
211 =over 4
212
213 =item * TTY
214
215 the TTY to use for debugging i/o.
216
217 =item * noTTY
218
219 if set, goes in NonStop mode.  On interrupt, if TTY is not set,
220 uses the value of noTTY or F<$HOME/.perldbtty$$> to find TTY using
221 Term::Rendezvous.  Current variant is to have the name of TTY in this
222 file.
223
224 =item * ReadLine
225
226 if false, a dummy ReadLine is used, so you can debug
227 ReadLine applications.
228
229 =item * NonStop
230
231 if true, no i/o is performed until interrupt.
232
233 =item * LineInfo
234
235 file or pipe to print line number info to.  If it is a
236 pipe, a short "emacs like" message is used.
237
238 =item * RemotePort
239
240 host:port to connect to on remote host for remote debugging.
241
242 =item * HistFile
243
244 file to store session history to. There is no default and so no
245 history file is written unless this variable is explicitly set.
246
247 =item * HistSize
248
249 number of commands to store to the file specified in C<HistFile>.
250 Default is 100.
251
252 =back
253
254 =head3 SAMPLE RCFILE
255
256  &parse_options("NonStop=1 LineInfo=db.out");
257   sub afterinit { $trace = 1; }
258
259 The script will run without human intervention, putting trace
260 information into C<db.out>.  (If you interrupt it, you had better
261 reset C<LineInfo> to something I<interactive>!)
262
263 =head1 INTERNALS DESCRIPTION
264
265 =head2 DEBUGGER INTERFACE VARIABLES
266
267 Perl supplies the values for C<%sub>.  It effectively inserts
268 a C<&DB::DB();> in front of each place that can have a
269 breakpoint. At each subroutine call, it calls C<&DB::sub> with
270 C<$DB::sub> set to the called subroutine. It also inserts a C<BEGIN
271 {require 'perl5db.pl'}> before the first line.
272
273 After each C<require>d file is compiled, but before it is executed, a
274 call to C<&DB::postponed($main::{'_<'.$filename})> is done. C<$filename>
275 is the expanded name of the C<require>d file (as found via C<%INC>).
276
277 =head3 IMPORTANT INTERNAL VARIABLES
278
279 =head4 C<$CreateTTY>
280
281 Used to control when the debugger will attempt to acquire another TTY to be
282 used for input.
283
284 =over
285
286 =item * 1 -  on C<fork()>
287
288 =item * 2 - debugger is started inside debugger
289
290 =item * 4 -  on startup
291
292 =back
293
294 =head4 C<$doret>
295
296 The value -2 indicates that no return value should be printed.
297 Any other positive value causes C<DB::sub> to print return values.
298
299 =head4 C<$evalarg>
300
301 The item to be eval'ed by C<DB::eval>. Used to prevent messing with the current
302 contents of C<@_> when C<DB::eval> is called.
303
304 =head4 C<$frame>
305
306 Determines what messages (if any) will get printed when a subroutine (or eval)
307 is entered or exited.
308
309 =over 4
310
311 =item * 0 -  No enter/exit messages
312
313 =item * 1 - Print I<entering> messages on subroutine entry
314
315 =item * 2 - Adds exit messages on subroutine exit. If no other flag is on, acts like 1+2.
316
317 =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.
318
319 =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.
320
321 =item * 16 - Adds C<I<context> return from I<subname>: I<value>> messages on subroutine/eval exit. Ignored if C<4> is not on.
322
323 =back
324
325 To get everything, use C<$frame=30> (or C<o f=30> as a debugger command).
326 The debugger internally juggles the value of C<$frame> during execution to
327 protect external modules that the debugger uses from getting traced.
328
329 =head4 C<$level>
330
331 Tracks current debugger nesting level. Used to figure out how many
332 C<E<lt>E<gt>> pairs to surround the line number with when the debugger
333 outputs a prompt. Also used to help determine if the program has finished
334 during command parsing.
335
336 =head4 C<$onetimeDump>
337
338 Controls what (if anything) C<DB::eval()> will print after evaluating an
339 expression.
340
341 =over 4
342
343 =item * C<undef> - don't print anything
344
345 =item * C<dump> - use C<dumpvar.pl> to display the value returned
346
347 =item * C<methods> - print the methods callable on the first item returned
348
349 =back
350
351 =head4 C<$onetimeDumpDepth>
352
353 Controls how far down C<dumpvar.pl> will go before printing C<...> while
354 dumping a structure. Numeric. If C<undef>, print all levels.
355
356 =head4 C<$signal>
357
358 Used to track whether or not an C<INT> signal has been detected. C<DB::DB()>,
359 which is called before every statement, checks this and puts the user into
360 command mode if it finds C<$signal> set to a true value.
361
362 =head4 C<$single>
363
364 Controls behavior during single-stepping. Stacked in C<@stack> on entry to
365 each subroutine; popped again at the end of each subroutine.
366
367 =over 4
368
369 =item * 0 - run continuously.
370
371 =item * 1 - single-step, go into subs. The C<s> command.
372
373 =item * 2 - single-step, don't go into subs. The C<n> command.
374
375 =item * 4 - print current sub depth (turned on to force this when C<too much
376 recursion> occurs.
377
378 =back
379
380 =head4 C<$trace>
381
382 Controls the output of trace information.
383
384 =over 4
385
386 =item * 1 - The C<t> command was entered to turn on tracing (every line executed is printed)
387
388 =item * 2 - watch expressions are active
389
390 =item * 4 - user defined a C<watchfunction()> in C<afterinit()>
391
392 =back
393
394 =head4 C<$slave_editor>
395
396 1 if C<LINEINFO> was directed to a pipe; 0 otherwise.
397
398 =head4 C<@cmdfhs>
399
400 Stack of filehandles that C<DB::readline()> will read commands from.
401 Manipulated by the debugger's C<source> command and C<DB::readline()> itself.
402
403 =head4 C<@dbline>
404
405 Local alias to the magical line array, C<@{$main::{'_<'.$filename}}> ,
406 supplied by the Perl interpreter to the debugger. Contains the source.
407
408 =head4 C<@old_watch>
409
410 Previous values of watch expressions. First set when the expression is
411 entered; reset whenever the watch expression changes.
412
413 =head4 C<@saved>
414
415 Saves important globals (C<$@>, C<$!>, C<$^E>, C<$,>, C<$/>, C<$\>, C<$^W>)
416 so that the debugger can substitute safe values while it's running, and
417 restore them when it returns control.
418
419 =head4 C<@stack>
420
421 Saves the current value of C<$single> on entry to a subroutine.
422 Manipulated by the C<c> command to turn off tracing in all subs above the
423 current one.
424
425 =head4 C<@to_watch>
426
427 The 'watch' expressions: to be evaluated before each line is executed.
428
429 =head4 C<@typeahead>
430
431 The typeahead buffer, used by C<DB::readline>.
432
433 =head4 C<%alias>
434
435 Command aliases. Stored as character strings to be substituted for a command
436 entered.
437
438 =head4 C<%break_on_load>
439
440 Keys are file names, values are 1 (break when this file is loaded) or undef
441 (don't break when it is loaded).
442
443 =head4 C<%dbline>
444
445 Keys are line numbers, values are C<condition\0action>. If used in numeric
446 context, values are 0 if not breakable, 1 if breakable, no matter what is
447 in the actual hash entry.
448
449 =head4 C<%had_breakpoints>
450
451 Keys are file names; values are bitfields:
452
453 =over 4
454
455 =item * 1 - file has a breakpoint in it.
456
457 =item * 2 - file has an action in it.
458
459 =back
460
461 A zero or undefined value means this file has neither.
462
463 =head4 C<%option>
464
465 Stores the debugger options. These are character string values.
466
467 =head4 C<%postponed>
468
469 Saves breakpoints for code that hasn't been compiled yet.
470 Keys are subroutine names, values are:
471
472 =over 4
473
474 =item * C<compile> - break when this sub is compiled
475
476 =item * C<< break +0 if <condition> >> - break (conditionally) at the start of this routine. The condition will be '1' if no condition was specified.
477
478 =back
479
480 =head4 C<%postponed_file>
481
482 This hash keeps track of breakpoints that need to be set for files that have
483 not yet been compiled. Keys are filenames; values are references to hashes.
484 Each of these hashes is keyed by line number, and its values are breakpoint
485 definitions (C<condition\0action>).
486
487 =head1 DEBUGGER INITIALIZATION
488
489 The debugger's initialization actually jumps all over the place inside this
490 package. This is because there are several BEGIN blocks (which of course
491 execute immediately) spread through the code. Why is that?
492
493 The debugger needs to be able to change some things and set some things up
494 before the debugger code is compiled; most notably, the C<$deep> variable that
495 C<DB::sub> uses to tell when a program has recursed deeply. In addition, the
496 debugger has to turn off warnings while the debugger code is compiled, but then
497 restore them to their original setting before the program being debugged begins
498 executing.
499
500 The first C<BEGIN> block simply turns off warnings by saving the current
501 setting of C<$^W> and then setting it to zero. The second one initializes
502 the debugger variables that are needed before the debugger begins executing.
503 The third one puts C<$^X> back to its former value.
504
505 We'll detail the second C<BEGIN> block later; just remember that if you need
506 to initialize something before the debugger starts really executing, that's
507 where it has to go.
508
509 =cut
510
511 package DB;
512
513 use strict;
514
515 use Cwd ();
516
517 my $_initial_cwd;
518
519 BEGIN {eval 'use IO::Handle'}; # Needed for flush only? breaks under miniperl
520
521 BEGIN {
522     require feature;
523     $^V =~ /^v(\d+\.\d+)/;
524     feature->import(":$1");
525     $_initial_cwd = Cwd::getcwd();
526 }
527
528 # Debugger for Perl 5.00x; perl5db.pl patch level:
529 use vars qw($VERSION $header);
530
531 $VERSION = '1.49';
532
533 $header = "perl5db.pl version $VERSION";
534
535 =head1 DEBUGGER ROUTINES
536
537 =head2 C<DB::eval()>
538
539 This function replaces straight C<eval()> inside the debugger; it simplifies
540 the process of evaluating code in the user's context.
541
542 The code to be evaluated is passed via the package global variable
543 C<$DB::evalarg>; this is done to avoid fiddling with the contents of C<@_>.
544
545 Before we do the C<eval()>, we preserve the current settings of C<$trace>,
546 C<$single>, C<$^D> and C<$usercontext>.  The latter contains the
547 preserved values of C<$@>, C<$!>, C<$^E>, C<$,>, C<$/>, C<$\>, C<$^W> and the
548 user's current package, grabbed when C<DB::DB> got control.  This causes the
549 proper context to be used when the eval is actually done.  Afterward, we
550 restore C<$trace>, C<$single>, and C<$^D>.
551
552 Next we need to handle C<$@> without getting confused. We save C<$@> in a
553 local lexical, localize C<$saved[0]> (which is where C<save()> will put
554 C<$@>), and then call C<save()> to capture C<$@>, C<$!>, C<$^E>, C<$,>,
555 C<$/>, C<$\>, and C<$^W>) and set C<$,>, C<$/>, C<$\>, and C<$^W> to values
556 considered sane by the debugger. If there was an C<eval()> error, we print
557 it on the debugger's output. If C<$onetimedump> is defined, we call
558 C<dumpit> if it's set to 'dump', or C<methods> if it's set to
559 'methods'. Setting it to something else causes the debugger to do the eval
560 but not print the result - handy if you want to do something else with it
561 (the "watch expressions" code does this to get the value of the watch
562 expression but not show it unless it matters).
563
564 In any case, we then return the list of output from C<eval> to the caller,
565 and unwinding restores the former version of C<$@> in C<@saved> as well
566 (the localization of C<$saved[0]> goes away at the end of this scope).
567
568 =head3 Parameters and variables influencing execution of DB::eval()
569
570 C<DB::eval> isn't parameterized in the standard way; this is to keep the
571 debugger's calls to C<DB::eval()> from mucking with C<@_>, among other things.
572 The variables listed below influence C<DB::eval()>'s execution directly.
573
574 =over 4
575
576 =item C<$evalarg> - the thing to actually be eval'ed
577
578 =item C<$trace> - Current state of execution tracing
579
580 =item C<$single> - Current state of single-stepping
581
582 =item C<$onetimeDump> - what is to be displayed after the evaluation
583
584 =item C<$onetimeDumpDepth> - how deep C<dumpit()> should go when dumping results
585
586 =back
587
588 The following variables are altered by C<DB::eval()> during its execution. They
589 are "stacked" via C<local()>, enabling recursive calls to C<DB::eval()>.
590
591 =over 4
592
593 =item C<@res> - used to capture output from actual C<eval>.
594
595 =item C<$otrace> - saved value of C<$trace>.
596
597 =item C<$osingle> - saved value of C<$single>.
598
599 =item C<$od> - saved value of C<$^D>.
600
601 =item C<$saved[0]> - saved value of C<$@>.
602
603 =item $\ - for output of C<$@> if there is an evaluation error.
604
605 =back
606
607 =head3 The problem of lexicals
608
609 The context of C<DB::eval()> presents us with some problems. Obviously,
610 we want to be 'sandboxed' away from the debugger's internals when we do
611 the eval, but we need some way to control how punctuation variables and
612 debugger globals are used.
613
614 We can't use local, because the code inside C<DB::eval> can see localized
615 variables; and we can't use C<my> either for the same reason. The code
616 in this routine compromises and uses C<my>.
617
618 After this routine is over, we don't have user code executing in the debugger's
619 context, so we can use C<my> freely.
620
621 =cut
622
623 ############################################## Begin lexical danger zone
624
625 # 'my' variables used here could leak into (that is, be visible in)
626 # the context that the code being evaluated is executing in. This means that
627 # the code could modify the debugger's variables.
628 #
629 # Fiddling with the debugger's context could be Bad. We insulate things as
630 # much as we can.
631
632 use vars qw(
633     @args
634     %break_on_load
635     $CommandSet
636     $CreateTTY
637     $DBGR
638     @dbline
639     $dbline
640     %dbline
641     $dieLevel
642     $filename
643     $histfile
644     $histsize
645     $IN
646     $inhibit_exit
647     @ini_INC
648     $ini_warn
649     $maxtrace
650     $od
651     @options
652     $osingle
653     $otrace
654     $pager
655     $post
656     %postponed
657     $prc
658     $pre
659     $pretype
660     $psh
661     @RememberOnROptions
662     $remoteport
663     @res
664     $rl
665     @saved
666     $signalLevel
667     $sub
668     $term
669     $usercontext
670     $warnLevel
671 );
672
673 our (
674     @cmdfhs,
675     $evalarg,
676     $frame,
677     $hist,
678     $ImmediateStop,
679     $line,
680     $onetimeDump,
681     $onetimedumpDepth,
682     %option,
683     $OUT,
684     $packname,
685     $signal,
686     $single,
687     $start,
688     %sub,
689     $subname,
690     $trace,
691     $window,
692 );
693
694 # Used to save @ARGV and extract any debugger-related flags.
695 use vars qw(@ARGS);
696
697 # Used to prevent multiple entries to diesignal()
698 # (if for instance diesignal() itself dies)
699 use vars qw($panic);
700
701 # Used to prevent the debugger from running nonstop
702 # after a restart
703 our ($second_time);
704
705 sub _calc_usercontext {
706     my ($package) = @_;
707
708     # Cancel strict completely for the evaluated code, so the code
709     # the user evaluates won't be affected by it. (Shlomi Fish)
710     return 'no strict; ($@, $!, $^E, $,, $/, $\, $^W) = @DB::saved;'
711     . "package $package;";    # this won't let them modify, alas
712 }
713
714 sub eval {
715
716     # 'my' would make it visible from user code
717     #    but so does local! --tchrist
718     # Remember: this localizes @DB::res, not @main::res.
719     local @res;
720     {
721
722         # Try to keep the user code from messing  with us. Save these so that
723         # even if the eval'ed code changes them, we can put them back again.
724         # Needed because the user could refer directly to the debugger's
725         # package globals (and any 'my' variables in this containing scope)
726         # inside the eval(), and we want to try to stay safe.
727         local $otrace  = $trace;
728         local $osingle = $single;
729         local $od      = $^D;
730
731         # Untaint the incoming eval() argument.
732         { ($evalarg) = $evalarg =~ /(.*)/s; }
733
734         # $usercontext built in DB::DB near the comment
735         # "set up the context for DB::eval ..."
736         # Evaluate and save any results.
737         @res = eval "$usercontext $evalarg;\n";  # '\n' for nice recursive debug
738
739         # Restore those old values.
740         $trace  = $otrace;
741         $single = $osingle;
742         $^D     = $od;
743     }
744
745     # Save the current value of $@, and preserve it in the debugger's copy
746     # of the saved precious globals.
747     my $at = $@;
748
749     # Since we're only saving $@, we only have to localize the array element
750     # that it will be stored in.
751     local $saved[0];    # Preserve the old value of $@
752     eval { &DB::save };
753
754     # Now see whether we need to report an error back to the user.
755     if ($at) {
756         local $\ = '';
757         print $OUT $at;
758     }
759
760     # Display as required by the caller. $onetimeDump and $onetimedumpDepth
761     # are package globals.
762     elsif ($onetimeDump) {
763         if ( $onetimeDump eq 'dump' ) {
764             local $option{dumpDepth} = $onetimedumpDepth
765               if defined $onetimedumpDepth;
766             dumpit( $OUT, \@res );
767         }
768         elsif ( $onetimeDump eq 'methods' ) {
769             methods( $res[0] );
770         }
771     } ## end elsif ($onetimeDump)
772     @res;
773 } ## end sub eval
774
775 ############################################## End lexical danger zone
776
777 # After this point it is safe to introduce lexicals.
778 # The code being debugged will be executing in its own context, and
779 # can't see the inside of the debugger.
780 #
781 # However, one should not overdo it: leave as much control from outside as
782 # possible. If you make something a lexical, it's not going to be addressable
783 # from outside the debugger even if you know its name.
784
785 # This file is automatically included if you do perl -d.
786 # It's probably not useful to include this yourself.
787 #
788 # Before venturing further into these twisty passages, it is
789 # wise to read the perldebguts man page or risk the ire of dragons.
790 #
791 # (It should be noted that perldebguts will tell you a lot about
792 # the underlying mechanics of how the debugger interfaces into the
793 # Perl interpreter, but not a lot about the debugger itself. The new
794 # comments in this code try to address this problem.)
795
796 # Note that no subroutine call is possible until &DB::sub is defined
797 # (for subroutines defined outside of the package DB). In fact the same is
798 # true if $deep is not defined.
799
800 # Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich)
801
802 # modified Perl debugger, to be run from Emacs in perldb-mode
803 # Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990
804 # Johan Vromans -- upgrade to 4.0 pl 10
805 # Ilya Zakharevich -- patches after 5.001 (and some before ;-)
806 ########################################################################
807
808 =head1 DEBUGGER INITIALIZATION
809
810 The debugger starts up in phases.
811
812 =head2 BASIC SETUP
813
814 First, it initializes the environment it wants to run in: turning off
815 warnings during its own compilation, defining variables which it will need
816 to avoid warnings later, setting itself up to not exit when the program
817 terminates, and defaulting to printing return values for the C<r> command.
818
819 =cut
820
821 # Needed for the statement after exec():
822 #
823 # This BEGIN block is simply used to switch off warnings during debugger
824 # compilation. Probably it would be better practice to fix the warnings,
825 # but this is how it's done at the moment.
826
827 BEGIN {
828     $ini_warn = $^W;
829     $^W       = 0;
830 }    # Switch compilation warnings off until another BEGIN.
831
832 local ($^W) = 0;    # Switch run-time warnings off during init.
833
834 =head2 THREADS SUPPORT
835
836 If we are running under a threaded Perl, we require threads and threads::shared
837 if the environment variable C<PERL5DB_THREADED> is set, to enable proper
838 threaded debugger control.  C<-dt> can also be used to set this.
839
840 Each new thread will be announced and the debugger prompt will always inform
841 you of each new thread created.  It will also indicate the thread id in which
842 we are currently running within the prompt like this:
843
844     [tid] DB<$i>
845
846 Where C<[tid]> is an integer thread id and C<$i> is the familiar debugger
847 command prompt.  The prompt will show: C<[0]> when running under threads, but
848 not actually in a thread.  C<[tid]> is consistent with C<gdb> usage.
849
850 While running under threads, when you set or delete a breakpoint (etc.), this
851 will apply to all threads, not just the currently running one.  When you are
852 in a currently executing thread, you will stay there until it completes.  With
853 the current implementation it is not currently possible to hop from one thread
854 to another.
855
856 The C<e> and C<E> commands are currently fairly minimal - see C<h e> and C<h E>.
857
858 Note that threading support was built into the debugger as of Perl version
859 C<5.8.6> and debugger version C<1.2.8>.
860
861 =cut
862
863 BEGIN {
864     # ensure we can share our non-threaded variables or no-op
865     if ($ENV{PERL5DB_THREADED}) {
866         require threads;
867         require threads::shared;
868         import threads::shared qw(share);
869         $DBGR;
870         share(\$DBGR);
871         lock($DBGR);
872         print "Threads support enabled\n";
873     } else {
874         *lock = sub(*) {};
875         *share = sub(\[$@%]) {};
876     }
877 }
878
879 # These variables control the execution of 'dumpvar.pl'.
880 {
881     package dumpvar;
882     use vars qw(
883     $hashDepth
884     $arrayDepth
885     $dumpDBFiles
886     $dumpPackages
887     $quoteHighBit
888     $printUndef
889     $globPrint
890     $usageOnly
891     );
892 }
893
894 # used to control die() reporting in diesignal()
895 {
896     package Carp;
897     use vars qw($CarpLevel);
898 }
899
900 # without threads, $filename is not defined until DB::DB is called
901 share($main::{'_<'.$filename}) if defined $filename;
902
903 # Command-line + PERLLIB:
904 # Save the contents of @INC before they are modified elsewhere.
905 @ini_INC = @INC;
906
907 # This was an attempt to clear out the previous values of various
908 # trapped errors. Apparently it didn't help. XXX More info needed!
909 # $prevwarn = $prevdie = $prevbus = $prevsegv = ''; # Does not help?!
910
911 # We set these variables to safe values. We don't want to blindly turn
912 # off warnings, because other packages may still want them.
913 $trace = $signal = $single = 0;    # Uninitialized warning suppression
914                                    # (local $^W cannot help - other packages!).
915
916 # Default to not exiting when program finishes; print the return
917 # value when the 'r' command is used to return from a subroutine.
918 $inhibit_exit = $option{PrintRet} = 1;
919
920 use vars qw($trace_to_depth);
921
922 # Default to 1E9 so it won't be limited to a certain recursion depth.
923 $trace_to_depth = 1E9;
924
925 =head1 OPTION PROCESSING
926
927 The debugger's options are actually spread out over the debugger itself and
928 C<dumpvar.pl>; some of these are variables to be set, while others are
929 subs to be called with a value. To try to make this a little easier to
930 manage, the debugger uses a few data structures to define what options
931 are legal and how they are to be processed.
932
933 First, the C<@options> array defines the I<names> of all the options that
934 are to be accepted.
935
936 =cut
937
938 @options = qw(
939   CommandSet   HistFile      HistSize
940   hashDepth    arrayDepth    dumpDepth
941   DumpDBFiles  DumpPackages  DumpReused
942   compactDump  veryCompact   quote
943   HighBit      undefPrint    globPrint
944   PrintRet     UsageOnly     frame
945   AutoTrace    TTY           noTTY
946   ReadLine     NonStop       LineInfo
947   maxTraceLen  recallCommand ShellBang
948   pager        tkRunning     ornaments
949   signalLevel  warnLevel     dieLevel
950   inhibit_exit ImmediateStop bareStringify
951   CreateTTY    RemotePort    windowSize
952   DollarCaretP
953 );
954
955 @RememberOnROptions = qw(DollarCaretP);
956
957 =pod
958
959 Second, C<optionVars> lists the variables that each option uses to save its
960 state.
961
962 =cut
963
964 use vars qw(%optionVars);
965
966 %optionVars = (
967     hashDepth     => \$dumpvar::hashDepth,
968     arrayDepth    => \$dumpvar::arrayDepth,
969     CommandSet    => \$CommandSet,
970     DumpDBFiles   => \$dumpvar::dumpDBFiles,
971     DumpPackages  => \$dumpvar::dumpPackages,
972     DumpReused    => \$dumpvar::dumpReused,
973     HighBit       => \$dumpvar::quoteHighBit,
974     undefPrint    => \$dumpvar::printUndef,
975     globPrint     => \$dumpvar::globPrint,
976     UsageOnly     => \$dumpvar::usageOnly,
977     CreateTTY     => \$CreateTTY,
978     bareStringify => \$dumpvar::bareStringify,
979     frame         => \$frame,
980     AutoTrace     => \$trace,
981     inhibit_exit  => \$inhibit_exit,
982     maxTraceLen   => \$maxtrace,
983     ImmediateStop => \$ImmediateStop,
984     RemotePort    => \$remoteport,
985     windowSize    => \$window,
986     HistFile      => \$histfile,
987     HistSize      => \$histsize,
988 );
989
990 =pod
991
992 Third, C<%optionAction> defines the subroutine to be called to process each
993 option.
994
995 =cut
996
997 use vars qw(%optionAction);
998
999 %optionAction = (
1000     compactDump   => \&dumpvar::compactDump,
1001     veryCompact   => \&dumpvar::veryCompact,
1002     quote         => \&dumpvar::quote,
1003     TTY           => \&TTY,
1004     noTTY         => \&noTTY,
1005     ReadLine      => \&ReadLine,
1006     NonStop       => \&NonStop,
1007     LineInfo      => \&LineInfo,
1008     recallCommand => \&recallCommand,
1009     ShellBang     => \&shellBang,
1010     pager         => \&pager,
1011     signalLevel   => \&signalLevel,
1012     warnLevel     => \&warnLevel,
1013     dieLevel      => \&dieLevel,
1014     tkRunning     => \&tkRunning,
1015     ornaments     => \&ornaments,
1016     RemotePort    => \&RemotePort,
1017     DollarCaretP  => \&DollarCaretP,
1018 );
1019
1020 =pod
1021
1022 Last, the C<%optionRequire> notes modules that must be C<require>d if an
1023 option is used.
1024
1025 =cut
1026
1027 # Note that this list is not complete: several options not listed here
1028 # actually require that dumpvar.pl be loaded for them to work, but are
1029 # not in the table. A subsequent patch will correct this problem; for
1030 # the moment, we're just recommenting, and we are NOT going to change
1031 # function.
1032 use vars qw(%optionRequire);
1033
1034 %optionRequire = (
1035     compactDump => 'dumpvar.pl',
1036     veryCompact => 'dumpvar.pl',
1037     quote       => 'dumpvar.pl',
1038 );
1039
1040 =pod
1041
1042 There are a number of initialization-related variables which can be set
1043 by putting code to set them in a BEGIN block in the C<PERL5DB> environment
1044 variable. These are:
1045
1046 =over 4
1047
1048 =item C<$rl> - readline control XXX needs more explanation
1049
1050 =item C<$warnLevel> - whether or not debugger takes over warning handling
1051
1052 =item C<$dieLevel> - whether or not debugger takes over die handling
1053
1054 =item C<$signalLevel> - whether or not debugger takes over signal handling
1055
1056 =item C<$pre> - preprompt actions (array reference)
1057
1058 =item C<$post> - postprompt actions (array reference)
1059
1060 =item C<$pretype>
1061
1062 =item C<$CreateTTY> - whether or not to create a new TTY for this debugger
1063
1064 =item C<$CommandSet> - which command set to use (defaults to new, documented set)
1065
1066 =back
1067
1068 =cut
1069
1070 # These guys may be defined in $ENV{PERL5DB} :
1071 $rl          = 1     unless defined $rl;
1072 $warnLevel   = 1     unless defined $warnLevel;
1073 $dieLevel    = 1     unless defined $dieLevel;
1074 $signalLevel = 1     unless defined $signalLevel;
1075 $pre         = []    unless defined $pre;
1076 $post        = []    unless defined $post;
1077 $pretype     = []    unless defined $pretype;
1078 $CreateTTY   = 3     unless defined $CreateTTY;
1079 $CommandSet  = '580' unless defined $CommandSet;
1080
1081 share($rl);
1082 share($warnLevel);
1083 share($dieLevel);
1084 share($signalLevel);
1085 share($pre);
1086 share($post);
1087 share($pretype);
1088 share($rl);
1089 share($CreateTTY);
1090 share($CommandSet);
1091
1092 =pod
1093
1094 The default C<die>, C<warn>, and C<signal> handlers are set up.
1095
1096 =cut
1097
1098 warnLevel($warnLevel);
1099 dieLevel($dieLevel);
1100 signalLevel($signalLevel);
1101
1102 =pod
1103
1104 The pager to be used is needed next. We try to get it from the
1105 environment first.  If it's not defined there, we try to find it in
1106 the Perl C<Config.pm>.  If it's not there, we default to C<more>. We
1107 then call the C<pager()> function to save the pager name.
1108
1109 =cut
1110
1111 # This routine makes sure $pager is set up so that '|' can use it.
1112 pager(
1113
1114     # If PAGER is defined in the environment, use it.
1115     defined $ENV{PAGER}
1116     ? $ENV{PAGER}
1117
1118       # If not, see if Config.pm defines it.
1119     : eval { require Config }
1120       && defined $Config::Config{pager}
1121     ? $Config::Config{pager}
1122
1123       # If not, fall back to 'more'.
1124     : 'more'
1125   )
1126   unless defined $pager;
1127
1128 =pod
1129
1130 We set up the command to be used to access the man pages, the command
1131 recall character (C<!> unless otherwise defined) and the shell escape
1132 character (C<!> unless otherwise defined). Yes, these do conflict, and
1133 neither works in the debugger at the moment.
1134
1135 =cut
1136
1137 setman();
1138
1139 # Set up defaults for command recall and shell escape (note:
1140 # these currently don't work in linemode debugging).
1141 recallCommand("!") unless defined $prc;
1142 shellBang("!")     unless defined $psh;
1143
1144 =pod
1145
1146 We then set up the gigantic string containing the debugger help.
1147 We also set the limit on the number of arguments we'll display during a
1148 trace.
1149
1150 =cut
1151
1152 sethelp();
1153
1154 # If we didn't get a default for the length of eval/stack trace args,
1155 # set it here.
1156 $maxtrace = 400 unless defined $maxtrace;
1157
1158 =head2 SETTING UP THE DEBUGGER GREETING
1159
1160 The debugger I<greeting> helps to inform the user how many debuggers are
1161 running, and whether the current debugger is the primary or a child.
1162
1163 If we are the primary, we just hang onto our pid so we'll have it when
1164 or if we start a child debugger. If we are a child, we'll set things up
1165 so we'll have a unique greeting and so the parent will give us our own
1166 TTY later.
1167
1168 We save the current contents of the C<PERLDB_PIDS> environment variable
1169 because we mess around with it. We'll also need to hang onto it because
1170 we'll need it if we restart.
1171
1172 Child debuggers make a label out of the current PID structure recorded in
1173 PERLDB_PIDS plus the new PID. They also mark themselves as not having a TTY
1174 yet so the parent will give them one later via C<resetterm()>.
1175
1176 =cut
1177
1178 # Save the current contents of the environment; we're about to
1179 # much with it. We'll need this if we have to restart.
1180 use vars qw($ini_pids);
1181 $ini_pids = $ENV{PERLDB_PIDS};
1182
1183 use vars qw ($pids $term_pid);
1184
1185 if ( defined $ENV{PERLDB_PIDS} ) {
1186
1187     # We're a child. Make us a label out of the current PID structure
1188     # recorded in PERLDB_PIDS plus our (new) PID. Mark us as not having
1189     # a term yet so the parent will give us one later via resetterm().
1190
1191     my $env_pids = $ENV{PERLDB_PIDS};
1192     $pids = "[$env_pids]";
1193
1194     # Unless we are on OpenVMS, all programs under the DCL shell run under
1195     # the same PID.
1196
1197     if (($^O eq 'VMS') && ($env_pids =~ /\b$$\b/)) {
1198         $term_pid         = $$;
1199     }
1200     else {
1201         $ENV{PERLDB_PIDS} .= "->$$";
1202         $term_pid = -1;
1203     }
1204
1205 } ## end if (defined $ENV{PERLDB_PIDS...
1206 else {
1207
1208     # We're the parent PID. Initialize PERLDB_PID in case we end up with a
1209     # child debugger, and mark us as the parent, so we'll know to set up
1210     # more TTY's is we have to.
1211     $ENV{PERLDB_PIDS} = "$$";
1212     $pids             = "[pid=$$]";
1213     $term_pid         = $$;
1214 }
1215
1216 use vars qw($pidprompt);
1217 $pidprompt = '';
1218
1219 # Sets up $emacs as a synonym for $slave_editor.
1220 our ($slave_editor);
1221 *emacs = $slave_editor if $slave_editor;    # May be used in afterinit()...
1222
1223 =head2 READING THE RC FILE
1224
1225 The debugger will read a file of initialization options if supplied. If
1226 running interactively, this is C<.perldb>; if not, it's C<perldb.ini>.
1227
1228 =cut
1229
1230 # As noted, this test really doesn't check accurately that the debugger
1231 # is running at a terminal or not.
1232
1233 use vars qw($rcfile);
1234 {
1235     my $dev_tty = (($^O eq 'VMS') ? 'TT:' : '/dev/tty');
1236     # this is the wrong metric!
1237     $rcfile = ((-e $dev_tty) ? ".perldb" : "perldb.ini");
1238 }
1239
1240 =pod
1241
1242 The debugger does a safety test of the file to be read. It must be owned
1243 either by the current user or root, and must only be writable by the owner.
1244
1245 =cut
1246
1247 # This wraps a safety test around "do" to read and evaluate the init file.
1248 #
1249 # This isn't really safe, because there's a race
1250 # between checking and opening.  The solution is to
1251 # open and fstat the handle, but then you have to read and
1252 # eval the contents.  But then the silly thing gets
1253 # your lexical scope, which is unfortunate at best.
1254 sub safe_do {
1255     my $file = shift;
1256
1257     # Just exactly what part of the word "CORE::" don't you understand?
1258     local $SIG{__WARN__};
1259     local $SIG{__DIE__};
1260
1261     unless ( is_safe_file($file) ) {
1262         CORE::warn <<EO_GRIPE;
1263 perldb: Must not source insecure rcfile $file.
1264         You or the superuser must be the owner, and it must not
1265         be writable by anyone but its owner.
1266 EO_GRIPE
1267         return;
1268     } ## end unless (is_safe_file($file...
1269
1270     do $file;
1271     CORE::warn("perldb: couldn't parse $file: $@") if $@;
1272 } ## end sub safe_do
1273
1274 # This is the safety test itself.
1275 #
1276 # Verifies that owner is either real user or superuser and that no
1277 # one but owner may write to it.  This function is of limited use
1278 # when called on a path instead of upon a handle, because there are
1279 # no guarantees that filename (by dirent) whose file (by ino) is
1280 # eventually accessed is the same as the one tested.
1281 # Assumes that the file's existence is not in doubt.
1282 sub is_safe_file {
1283     my $path = shift;
1284     stat($path) || return;    # mysteriously vaporized
1285     my ( $dev, $ino, $mode, $nlink, $uid, $gid ) = stat(_);
1286
1287     return 0 if $uid != 0 && $uid != $<;
1288     return 0 if $mode & 022;
1289     return 1;
1290 } ## end sub is_safe_file
1291
1292 # If the rcfile (whichever one we decided was the right one to read)
1293 # exists, we safely do it.
1294 if ( -f $rcfile ) {
1295     safe_do("./$rcfile");
1296 }
1297
1298 # If there isn't one here, try the user's home directory.
1299 elsif ( defined $ENV{HOME} && -f "$ENV{HOME}/$rcfile" ) {
1300     safe_do("$ENV{HOME}/$rcfile");
1301 }
1302
1303 # Else try the login directory.
1304 elsif ( defined $ENV{LOGDIR} && -f "$ENV{LOGDIR}/$rcfile" ) {
1305     safe_do("$ENV{LOGDIR}/$rcfile");
1306 }
1307
1308 # If the PERLDB_OPTS variable has options in it, parse those out next.
1309 if ( defined $ENV{PERLDB_OPTS} ) {
1310     parse_options( $ENV{PERLDB_OPTS} );
1311 }
1312
1313 =pod
1314
1315 The last thing we do during initialization is determine which subroutine is
1316 to be used to obtain a new terminal when a new debugger is started. Right now,
1317 the debugger only handles TCP sockets, X11, OS/2, amd Mac OS X
1318 (darwin).
1319
1320 =cut
1321
1322 # Set up the get_fork_TTY subroutine to be aliased to the proper routine.
1323 # Works if you're running an xterm or xterm-like window, or you're on
1324 # OS/2, or on Mac OS X. This may need some expansion.
1325
1326 if (not defined &get_fork_TTY)       # only if no routine exists
1327 {
1328     if ( defined $remoteport ) {
1329                                                  # Expect an inetd-like server
1330         *get_fork_TTY = \&socket_get_fork_TTY;   # to listen to us
1331     }
1332     elsif (defined $ENV{TERM}                    # If we know what kind
1333                                                  # of terminal this is,
1334         and $ENV{TERM} eq 'xterm'                # and it's an xterm,
1335         and defined $ENV{DISPLAY}                # and what display it's on,
1336       )
1337     {
1338         *get_fork_TTY = \&xterm_get_fork_TTY;    # use the xterm version
1339     }
1340     elsif ( $ENV{TMUX} ) {
1341         *get_fork_TTY = \&tmux_get_fork_TTY;
1342     }
1343     elsif ( $^O eq 'os2' ) {                     # If this is OS/2,
1344         *get_fork_TTY = \&os2_get_fork_TTY;      # use the OS/2 version
1345     }
1346     elsif ( $^O eq 'darwin'                      # If this is Mac OS X
1347             and defined $ENV{TERM_PROGRAM}       # and we're running inside
1348             and $ENV{TERM_PROGRAM}
1349                 eq 'Apple_Terminal'              # Terminal.app
1350             )
1351     {
1352         *get_fork_TTY = \&macosx_get_fork_TTY;   # use the Mac OS X version
1353     }
1354 } ## end if (not defined &get_fork_TTY...
1355
1356 # untaint $^O, which may have been tainted by the last statement.
1357 # see bug [perl #24674]
1358 $^O =~ m/^(.*)\z/;
1359 $^O = $1;
1360
1361 # Here begin the unreadable code.  It needs fixing.
1362
1363 =head2 RESTART PROCESSING
1364
1365 This section handles the restart command. When the C<R> command is invoked, it
1366 tries to capture all of the state it can into environment variables, and
1367 then sets C<PERLDB_RESTART>. When we start executing again, we check to see
1368 if C<PERLDB_RESTART> is there; if so, we reload all the information that
1369 the R command stuffed into the environment variables.
1370
1371   PERLDB_RESTART   - flag only, contains no restart data itself.
1372   PERLDB_HIST      - command history, if it's available
1373   PERLDB_ON_LOAD   - breakpoints set by the rc file
1374   PERLDB_POSTPONE  - subs that have been loaded/not executed,
1375                      and have actions
1376   PERLDB_VISITED   - files that had breakpoints
1377   PERLDB_FILE_...  - breakpoints for a file
1378   PERLDB_OPT       - active options
1379   PERLDB_INC       - the original @INC
1380   PERLDB_PRETYPE   - preprompt debugger actions
1381   PERLDB_PRE       - preprompt Perl code
1382   PERLDB_POST      - post-prompt Perl code
1383   PERLDB_TYPEAHEAD - typeahead captured by readline()
1384
1385 We chug through all these variables and plug the values saved in them
1386 back into the appropriate spots in the debugger.
1387
1388 =cut
1389
1390 use vars qw(%postponed_file @typeahead);
1391
1392 our (@hist, @truehist);
1393
1394 sub _restore_shared_globals_after_restart
1395 {
1396     @hist          = get_list('PERLDB_HIST');
1397     %break_on_load = get_list("PERLDB_ON_LOAD");
1398     %postponed     = get_list("PERLDB_POSTPONE");
1399
1400     share(@hist);
1401     share(@truehist);
1402     share(%break_on_load);
1403     share(%postponed);
1404 }
1405
1406 sub _restore_breakpoints_and_actions {
1407
1408     my @had_breakpoints = get_list("PERLDB_VISITED");
1409
1410     for my $file_idx ( 0 .. $#had_breakpoints ) {
1411         my $filename = $had_breakpoints[$file_idx];
1412         my %pf = get_list("PERLDB_FILE_$file_idx");
1413         $postponed_file{ $filename } = \%pf if %pf;
1414         my @lines = sort {$a <=> $b} keys(%pf);
1415         my @enabled_statuses = get_list("PERLDB_FILE_ENABLED_$file_idx");
1416         for my $line_idx (0 .. $#lines) {
1417             _set_breakpoint_enabled_status(
1418                 $filename,
1419                 $lines[$line_idx],
1420                 ($enabled_statuses[$line_idx] ? 1 : ''),
1421             );
1422         }
1423     }
1424
1425     return;
1426 }
1427
1428 sub _restore_options_after_restart
1429 {
1430     my %options_map = get_list("PERLDB_OPT");
1431
1432     while ( my ( $opt, $val ) = each %options_map ) {
1433         $val =~ s/[\\\']/\\$1/g;
1434         parse_options("$opt'$val'");
1435     }
1436
1437     return;
1438 }
1439
1440 sub _restore_globals_after_restart
1441 {
1442     # restore original @INC
1443     @INC     = get_list("PERLDB_INC");
1444     @ini_INC = @INC;
1445
1446     # return pre/postprompt actions and typeahead buffer
1447     $pretype   = [ get_list("PERLDB_PRETYPE") ];
1448     $pre       = [ get_list("PERLDB_PRE") ];
1449     $post      = [ get_list("PERLDB_POST") ];
1450     @typeahead = get_list( "PERLDB_TYPEAHEAD", @typeahead );
1451
1452     return;
1453 }
1454
1455
1456 if ( exists $ENV{PERLDB_RESTART} ) {
1457
1458     # We're restarting, so we don't need the flag that says to restart anymore.
1459     delete $ENV{PERLDB_RESTART};
1460
1461     # $restart = 1;
1462     _restore_shared_globals_after_restart();
1463
1464     _restore_breakpoints_and_actions();
1465
1466     # restore options
1467     _restore_options_after_restart();
1468
1469     _restore_globals_after_restart();
1470 } ## end if (exists $ENV{PERLDB_RESTART...
1471
1472 =head2 SETTING UP THE TERMINAL
1473
1474 Now, we'll decide how the debugger is going to interact with the user.
1475 If there's no TTY, we set the debugger to run non-stop; there's not going
1476 to be anyone there to enter commands.
1477
1478 =cut
1479
1480 use vars qw($notty $console $tty $LINEINFO);
1481 use vars qw($lineinfo $doccmd);
1482
1483 our ($runnonstop);
1484
1485 # Local autoflush to avoid rt#116769,
1486 # as calling IO::File methods causes an unresolvable loop
1487 # that results in debugger failure.
1488 sub _autoflush {
1489     my $o = select($_[0]);
1490     $|++;
1491     select($o);
1492 }
1493
1494 if ($notty) {
1495     $runnonstop = 1;
1496     share($runnonstop);
1497 }
1498
1499 =pod
1500
1501 If there is a TTY, we have to determine who it belongs to before we can
1502 proceed. If this is a slave editor or graphical debugger (denoted by
1503 the first command-line switch being '-emacs'), we shift this off and
1504 set C<$rl> to 0 (XXX ostensibly to do straight reads).
1505
1506 =cut
1507
1508 else {
1509
1510     # Is Perl being run from a slave editor or graphical debugger?
1511     # If so, don't use readline, and set $slave_editor = 1.
1512     if ($slave_editor = ( @main::ARGV && ( $main::ARGV[0] eq '-emacs' ) )) {
1513         $rl = 0;
1514         shift(@main::ARGV);
1515     }
1516
1517     #require Term::ReadLine;
1518
1519 =pod
1520
1521 We then determine what the console should be on various systems:
1522
1523 =over 4
1524
1525 =item * Cygwin - We use C<stdin> instead of a separate device.
1526
1527 =cut
1528
1529     if ( $^O eq 'cygwin' ) {
1530
1531         # /dev/tty is binary. use stdin for textmode
1532         undef $console;
1533     }
1534
1535 =item * Unix - use F</dev/tty>.
1536
1537 =cut
1538
1539     elsif ( -e "/dev/tty" ) {
1540         $console = "/dev/tty";
1541     }
1542
1543 =item * Windows or MSDOS - use C<con>.
1544
1545 =cut
1546
1547     elsif ( $^O eq 'dos' or -e "con" or $^O eq 'MSWin32' ) {
1548         $console = "con";
1549     }
1550
1551 =item * VMS - use C<sys$command>.
1552
1553 =cut
1554
1555     else {
1556
1557         # everything else is ...
1558         $console = "sys\$command";
1559     }
1560
1561 =pod
1562
1563 =back
1564
1565 Several other systems don't use a specific console. We C<undef $console>
1566 for those (Windows using a slave editor/graphical debugger, NetWare, OS/2
1567 with a slave editor).
1568
1569 =cut
1570
1571     if ( ( $^O eq 'MSWin32' ) and ( $slave_editor or defined $ENV{EMACS} ) ) {
1572
1573         # /dev/tty is binary. use stdin for textmode
1574         $console = undef;
1575     }
1576
1577     if ( $^O eq 'NetWare' ) {
1578
1579         # /dev/tty is binary. use stdin for textmode
1580         $console = undef;
1581     }
1582
1583     # In OS/2, we need to use STDIN to get textmode too, even though
1584     # it pretty much looks like Unix otherwise.
1585     if ( defined $ENV{OS2_SHELL} and ( $slave_editor or $ENV{WINDOWID} ) )
1586     {    # In OS/2
1587         $console = undef;
1588     }
1589
1590 =pod
1591
1592 If there is a TTY hanging around from a parent, we use that as the console.
1593
1594 =cut
1595
1596     $console = $tty if defined $tty;
1597
1598 =head2 SOCKET HANDLING
1599
1600 The debugger is capable of opening a socket and carrying out a debugging
1601 session over the socket.
1602
1603 If C<RemotePort> was defined in the options, the debugger assumes that it
1604 should try to start a debugging session on that port. It builds the socket
1605 and then tries to connect the input and output filehandles to it.
1606
1607 =cut
1608
1609     # Handle socket stuff.
1610
1611     if ( defined $remoteport ) {
1612
1613         # If RemotePort was defined in the options, connect input and output
1614         # to the socket.
1615         $IN = $OUT = connect_remoteport();
1616     } ## end if (defined $remoteport)
1617
1618 =pod
1619
1620 If no C<RemotePort> was defined, and we want to create a TTY on startup,
1621 this is probably a situation where multiple debuggers are running (for example,
1622 a backticked command that starts up another debugger). We create a new IN and
1623 OUT filehandle, and do the necessary mojo to create a new TTY if we know how
1624 and if we can.
1625
1626 =cut
1627
1628     # Non-socket.
1629     else {
1630
1631         # Two debuggers running (probably a system or a backtick that invokes
1632         # the debugger itself under the running one). create a new IN and OUT
1633         # filehandle, and do the necessary mojo to create a new tty if we
1634         # know how, and we can.
1635         create_IN_OUT(4) if $CreateTTY & 4;
1636         if ($console) {
1637
1638             # If we have a console, check to see if there are separate ins and
1639             # outs to open. (They are assumed identical if not.)
1640
1641             my ( $i, $o ) = split /,/, $console;
1642             $o = $i unless defined $o;
1643
1644             # read/write on in, or just read, or read on STDIN.
1645             open( IN,      "+<$i" )
1646               || open( IN, "<$i" )
1647               || open( IN, "<&STDIN" );
1648
1649             # read/write/create/clobber out, or write/create/clobber out,
1650             # or merge with STDERR, or merge with STDOUT.
1651                  open( OUT, "+>$o" )
1652               || open( OUT, ">$o" )
1653               || open( OUT, ">&STDERR" )
1654               || open( OUT, ">&STDOUT" );    # so we don't dongle stdout
1655
1656         } ## end if ($console)
1657         elsif ( not defined $console ) {
1658
1659             # No console. Open STDIN.
1660             open( IN, "<&STDIN" );
1661
1662             # merge with STDERR, or with STDOUT.
1663             open( OUT,      ">&STDERR" )
1664               || open( OUT, ">&STDOUT" );    # so we don't dongle stdout
1665             $console = 'STDIN/OUT';
1666         } ## end elsif (not defined $console)
1667
1668         # Keep copies of the filehandles so that when the pager runs, it
1669         # can close standard input without clobbering ours.
1670         if ($console or (not defined($console))) {
1671             $IN = \*IN;
1672             $OUT = \*OUT;
1673         }
1674     } ## end elsif (from if(defined $remoteport))
1675
1676     # Unbuffer DB::OUT. We need to see responses right away.
1677     _autoflush($OUT);
1678
1679     # Line info goes to debugger output unless pointed elsewhere.
1680     # Pointing elsewhere makes it possible for slave editors to
1681     # keep track of file and position. We have both a filehandle
1682     # and a I/O description to keep track of.
1683     $LINEINFO = $OUT     unless defined $LINEINFO;
1684     $lineinfo = $console unless defined $lineinfo;
1685     # share($LINEINFO); # <- unable to share globs
1686     share($lineinfo);   #
1687
1688 =pod
1689
1690 To finish initialization, we show the debugger greeting,
1691 and then call the C<afterinit()> subroutine if there is one.
1692
1693 =cut
1694
1695     # Show the debugger greeting.
1696     $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
1697     unless ($runnonstop) {
1698         local $\ = '';
1699         local $, = '';
1700         if ( $term_pid eq '-1' ) {
1701             print $OUT "\nDaughter DB session started...\n";
1702         }
1703         else {
1704             print $OUT "\nLoading DB routines from $header\n";
1705             print $OUT (
1706                 "Editor support ",
1707                 $slave_editor ? "enabled" : "available", ".\n"
1708             );
1709             print $OUT
1710 "\nEnter h or 'h h' for help, or '$doccmd perldebug' for more help.\n\n";
1711         } ## end else [ if ($term_pid eq '-1')
1712     } ## end unless ($runnonstop)
1713 } ## end else [ if ($notty)
1714
1715 # XXX This looks like a bug to me.
1716 # Why copy to @ARGS and then futz with @args?
1717 @ARGS = @ARGV;
1718 # for (@args) {
1719     # Make sure backslashes before single quotes are stripped out, and
1720     # keep args unless they are numeric (XXX why?)
1721     # s/\'/\\\'/g;                      # removed while not justified understandably
1722     # s/(.*)/'$1'/ unless /^-?[\d.]+$/; # ditto
1723 # }
1724
1725 # If there was an afterinit() sub defined, call it. It will get
1726 # executed in our scope, so it can fiddle with debugger globals.
1727 if ( defined &afterinit ) {    # May be defined in $rcfile
1728     afterinit();
1729 }
1730
1731 # Inform us about "Stack dump during die enabled ..." in dieLevel().
1732 use vars qw($I_m_init);
1733
1734 $I_m_init = 1;
1735
1736 ############################################################ Subroutines
1737
1738 =head1 SUBROUTINES
1739
1740 =head2 DB
1741
1742 This gigantic subroutine is the heart of the debugger. Called before every
1743 statement, its job is to determine if a breakpoint has been reached, and
1744 stop if so; read commands from the user, parse them, and execute
1745 them, and then send execution off to the next statement.
1746
1747 Note that the order in which the commands are processed is very important;
1748 some commands earlier in the loop will actually alter the C<$cmd> variable
1749 to create other commands to be executed later. This is all highly I<optimized>
1750 but can be confusing. Check the comments for each C<$cmd ... && do {}> to
1751 see what's happening in any given command.
1752
1753 =cut
1754
1755 # $cmd cannot be an our() variable unfortunately (possible perl bug?).
1756
1757 use vars qw(
1758     $action
1759     $cmd
1760     $file
1761     $filename_ini
1762     $finished
1763     %had_breakpoints
1764     $level
1765     $max
1766     $package
1767     $try
1768 );
1769
1770 our (
1771     %alias,
1772     $doret,
1773     $end,
1774     $fall_off_end,
1775     $incr,
1776     $laststep,
1777     $rc,
1778     $sh,
1779     $stack_depth,
1780     @stack,
1781     @to_watch,
1782     @old_watch,
1783 );
1784
1785 sub _DB__determine_if_we_should_break
1786 {
1787     # if we have something here, see if we should break.
1788     # $stop is lexical and local to this block - $action on the other hand
1789     # is global.
1790     my $stop;
1791
1792     if ( $dbline{$line}
1793         && _is_breakpoint_enabled($filename, $line)
1794         && (( $stop, $action ) = split( /\0/, $dbline{$line} ) ) )
1795     {
1796
1797         # Stop if the stop criterion says to just stop.
1798         if ( $stop eq '1' ) {
1799             $signal |= 1;
1800         }
1801
1802         # It's a conditional stop; eval it in the user's context and
1803         # see if we should stop. If so, remove the one-time sigil.
1804         elsif ($stop) {
1805             $evalarg = "\$DB::signal |= 1 if do {$stop}";
1806             # The &-call is here to ascertain the mutability of @_.
1807             &DB::eval;
1808             # If the breakpoint is temporary, then delete its enabled status.
1809             if ($dbline{$line} =~ s/;9($|\0)/$1/) {
1810                 _cancel_breakpoint_temp_enabled_status($filename, $line);
1811             }
1812         }
1813     } ## end if ($dbline{$line} && ...
1814 }
1815
1816 sub _DB__is_finished {
1817     if ($finished and $level <= 1) {
1818         end_report();
1819         return 1;
1820     }
1821     else {
1822         return;
1823     }
1824 }
1825
1826 sub _DB__read_next_cmd
1827 {
1828     my ($tid) = @_;
1829
1830     # We have a terminal, or can get one ...
1831     if (!$term) {
1832         setterm();
1833     }
1834
1835     # ... and it belongs to this PID or we get one for this PID ...
1836     if ($term_pid != $$) {
1837         resetterm(1);
1838     }
1839
1840     # ... and we got a line of command input ...
1841     $cmd = DB::readline(
1842         "$pidprompt $tid DB"
1843         . ( '<' x $level )
1844         . ( $#hist + 1 )
1845         . ( '>' x $level ) . " "
1846     );
1847
1848     return defined($cmd);
1849 }
1850
1851 sub _DB__trim_command_and_return_first_component {
1852     my ($obj) = @_;
1853
1854     $cmd =~ s/\A\s+//s;    # trim annoying leading whitespace
1855     $cmd =~ s/\s+\z//s;    # trim annoying trailing whitespace
1856
1857     my ($verb, $args) = $cmd =~ m{\A(\S*)\s*(.*)}s;
1858
1859     $obj->cmd_verb($verb);
1860     $obj->cmd_args($args);
1861
1862     return;
1863 }
1864
1865 sub _DB__handle_f_command {
1866     my ($obj) = @_;
1867
1868     if ($file = $obj->cmd_args) {
1869         # help for no arguments (old-style was return from sub).
1870         if ( !$file ) {
1871             print $OUT
1872             "The old f command is now the r command.\n";    # hint
1873             print $OUT "The new f command switches filenames.\n";
1874             next CMD;
1875         } ## end if (!$file)
1876
1877         # if not in magic file list, try a close match.
1878         if ( !defined $main::{ '_<' . $file } ) {
1879             if ( ($try) = grep( m#^_<.*$file#, keys %main:: ) ) {
1880                 {
1881                     $try = substr( $try, 2 );
1882                     print $OUT "Choosing $try matching '$file':\n";
1883                     $file = $try;
1884                 }
1885             } ## end if (($try) = grep(m#^_<.*$file#...
1886         } ## end if (!defined $main::{ ...
1887
1888         # If not successfully switched now, we failed.
1889         if ( !defined $main::{ '_<' . $file } ) {
1890             print $OUT "No file matching '$file' is loaded.\n";
1891             next CMD;
1892         }
1893
1894         # We switched, so switch the debugger internals around.
1895         elsif ( $file ne $filename ) {
1896             *dbline   = $main::{ '_<' . $file };
1897             $max      = $#dbline;
1898             $filename = $file;
1899             $start    = 1;
1900             $cmd      = "l";
1901         } ## end elsif ($file ne $filename)
1902
1903         # We didn't switch; say we didn't.
1904         else {
1905             print $OUT "Already in $file.\n";
1906             next CMD;
1907         }
1908     }
1909
1910     return;
1911 }
1912
1913 sub _DB__handle_dot_command {
1914     my ($obj) = @_;
1915
1916     # . command.
1917     if ($obj->_is_full('.')) {
1918         $incr = -1;    # stay at current line
1919
1920         # Reset everything to the old location.
1921         $start    = $line;
1922         $filename = $filename_ini;
1923         *dbline   = $main::{ '_<' . $filename };
1924         $max      = $#dbline;
1925
1926         # Now where are we?
1927         print_lineinfo($obj->position());
1928         next CMD;
1929     }
1930
1931     return;
1932 }
1933
1934 sub _DB__handle_y_command {
1935     my ($obj) = @_;
1936
1937     if (my ($match_level, $match_vars)
1938         = $obj->cmd_args =~ /\A(?:(\d*)\s*(.*))?\z/) {
1939
1940         # See if we've got the necessary support.
1941         if (!eval { require PadWalker; PadWalker->VERSION(0.08) }) {
1942             my $Err = $@;
1943             _db_warn(
1944                 $Err =~ /locate/
1945                 ? "PadWalker module not found - please install\n"
1946                 : $Err
1947             );
1948             next CMD;
1949         }
1950
1951         # Load up dumpvar if we don't have it. If we can, that is.
1952         do 'dumpvar.pl' || die $@ unless defined &main::dumpvar;
1953         defined &main::dumpvar
1954             or print $OUT "dumpvar.pl not available.\n"
1955             and next CMD;
1956
1957         # Got all the modules we need. Find them and print them.
1958         my @vars = split( ' ', $match_vars || '' );
1959
1960         # Find the pad.
1961         my $h = eval { PadWalker::peek_my( ( $match_level || 0 ) + 2 ) };
1962
1963         # Oops. Can't find it.
1964         if (my $Err = $@) {
1965             $Err =~ s/ at .*//;
1966             _db_warn($Err);
1967             next CMD;
1968         }
1969
1970         # Show the desired vars with dumplex().
1971         my $savout = select($OUT);
1972
1973         # Have dumplex dump the lexicals.
1974         foreach my $key (sort keys %$h) {
1975             dumpvar::dumplex( $key, $h->{$key},
1976                 defined $option{dumpDepth} ? $option{dumpDepth} : -1,
1977                 @vars );
1978         }
1979         select($savout);
1980         next CMD;
1981     }
1982 }
1983
1984 sub _DB__handle_c_command {
1985     my ($obj) = @_;
1986
1987     my $i = $obj->cmd_args;
1988
1989     if ($i =~ m#\A[\w:]*\z#) {
1990
1991         # Hey, show's over. The debugged program finished
1992         # executing already.
1993         next CMD if _DB__is_finished();
1994
1995         # Capture the place to put a one-time break.
1996         $subname = $i;
1997
1998         #  Probably not needed, since we finish an interactive
1999         #  sub-session anyway...
2000         # local $filename = $filename;
2001         # local *dbline = *dbline; # XXX Would this work?!
2002         #
2003         # The above question wonders if localizing the alias
2004         # to the magic array works or not. Since it's commented
2005         # out, we'll just leave that to speculation for now.
2006
2007         # If the "subname" isn't all digits, we'll assume it
2008         # is a subroutine name, and try to find it.
2009         if ( $subname =~ /\D/ ) {    # subroutine name
2010             # Qualify it to the current package unless it's
2011             # already qualified.
2012             $subname = $package . "::" . $subname
2013             unless $subname =~ /::/;
2014
2015             # find_sub will return "file:line_number" corresponding
2016             # to where the subroutine is defined; we call find_sub,
2017             # break up the return value, and assign it in one
2018             # operation.
2019             ( $file, $i ) = ( find_sub($subname) =~ /^(.*):(.*)$/ );
2020
2021             # Force the line number to be numeric.
2022             $i = $i + 0;
2023
2024             # If we got a line number, we found the sub.
2025             if ($i) {
2026
2027                 # Switch all the debugger's internals around so
2028                 # we're actually working with that file.
2029                 $filename = $file;
2030                 *dbline   = $main::{ '_<' . $filename };
2031
2032                 # Mark that there's a breakpoint in this file.
2033                 $had_breakpoints{$filename} |= 1;
2034
2035                 # Scan forward to the first executable line
2036                 # after the 'sub whatever' line.
2037                 $max = $#dbline;
2038                 my $_line_num = $i;
2039                 while ($dbline[$_line_num] == 0 && $_line_num< $max)
2040                 {
2041                     $_line_num++;
2042                 }
2043                 $i = $_line_num;
2044             } ## end if ($i)
2045
2046             # We didn't find a sub by that name.
2047             else {
2048                 print $OUT "Subroutine $subname not found.\n";
2049                 next CMD;
2050             }
2051         } ## end if ($subname =~ /\D/)
2052
2053         # At this point, either the subname was all digits (an
2054         # absolute line-break request) or we've scanned through
2055         # the code following the definition of the sub, looking
2056         # for an executable, which we may or may not have found.
2057         #
2058         # If $i (which we set $subname from) is non-zero, we
2059         # got a request to break at some line somewhere. On
2060         # one hand, if there wasn't any real subroutine name
2061         # involved, this will be a request to break in the current
2062         # file at the specified line, so we have to check to make
2063         # sure that the line specified really is breakable.
2064         #
2065         # On the other hand, if there was a subname supplied, the
2066         # preceding block has moved us to the proper file and
2067         # location within that file, and then scanned forward
2068         # looking for the next executable line. We have to make
2069         # sure that one was found.
2070         #
2071         # On the gripping hand, we can't do anything unless the
2072         # current value of $i points to a valid breakable line.
2073         # Check that.
2074         if ($i) {
2075
2076             # Breakable?
2077             if ( $dbline[$i] == 0 ) {
2078                 print $OUT "Line $i not breakable.\n";
2079                 next CMD;
2080             }
2081
2082             # Yes. Set up the one-time-break sigil.
2083             $dbline{$i} =~ s/($|\0)/;9$1/;  # add one-time-only b.p.
2084             _enable_breakpoint_temp_enabled_status($filename, $i);
2085         } ## end if ($i)
2086
2087         # Turn off stack tracing from here up.
2088         for my $j (0 .. $stack_depth) {
2089             $stack[ $j ] &= ~1;
2090         }
2091         last CMD;
2092     }
2093
2094     return;
2095 }
2096
2097 sub _DB__handle_forward_slash_command {
2098     my ($obj) = @_;
2099
2100     # The pattern as a string.
2101     use vars qw($inpat);
2102
2103     if (($inpat) = $cmd =~ m#\A/(.*)\z#) {
2104
2105         # Remove the final slash.
2106         $inpat =~ s:([^\\])/$:$1:;
2107
2108         # If the pattern isn't null ...
2109         if ( $inpat ne "" ) {
2110
2111             # Turn off warn and die processing for a bit.
2112             local $SIG{__DIE__};
2113             local $SIG{__WARN__};
2114
2115             # Create the pattern.
2116             eval 'no strict q/vars/; $inpat =~ m' . "\a$inpat\a";
2117             if ( $@ ne "" ) {
2118
2119                 # Oops. Bad pattern. No biscuit.
2120                 # Print the eval error and go back for more
2121                 # commands.
2122                 print {$OUT} "$@";
2123                 next CMD;
2124             }
2125             $obj->pat($inpat);
2126         } ## end if ($inpat ne "")
2127
2128         # Set up to stop on wrap-around.
2129         $end = $start;
2130
2131         # Don't move off the current line.
2132         $incr = -1;
2133
2134         my $pat = $obj->pat;
2135
2136         # Done in eval so nothing breaks if the pattern
2137         # does something weird.
2138         eval
2139         {
2140             no strict q/vars/;
2141             for (;;) {
2142                 # Move ahead one line.
2143                 ++$start;
2144
2145                 # Wrap if we pass the last line.
2146                 if ($start > $max) {
2147                     $start = 1;
2148                 }
2149
2150                 # Stop if we have gotten back to this line again,
2151                 last if ($start == $end);
2152
2153                 # A hit! (Note, though, that we are doing
2154                 # case-insensitive matching. Maybe a qr//
2155                 # expression would be better, so the user could
2156                 # do case-sensitive matching if desired.
2157                 if ($dbline[$start] =~ m/$pat/i) {
2158                     if ($slave_editor) {
2159                         # Handle proper escaping in the slave.
2160                         print {$OUT} "\032\032$filename:$start:0\n";
2161                     }
2162                     else {
2163                         # Just print the line normally.
2164                         print {$OUT} "$start:\t",$dbline[$start],"\n";
2165                     }
2166                     # And quit since we found something.
2167                     last;
2168                 }
2169             }
2170         };
2171
2172         if ($@) {
2173             warn $@;
2174         }
2175
2176         # If we wrapped, there never was a match.
2177         if ( $start == $end ) {
2178             print {$OUT} "/$pat/: not found\n";
2179         }
2180         next CMD;
2181     }
2182
2183     return;
2184 }
2185
2186 sub _DB__handle_question_mark_command {
2187     my ($obj) = @_;
2188
2189     # ? - backward pattern search.
2190     if (my ($inpat) = $cmd =~ m#\A\?(.*)\z#) {
2191
2192         # Get the pattern, remove trailing question mark.
2193         $inpat =~ s:([^\\])\?$:$1:;
2194
2195         # If we've got one ...
2196         if ( $inpat ne "" ) {
2197
2198             # Turn off die & warn handlers.
2199             local $SIG{__DIE__};
2200             local $SIG{__WARN__};
2201             eval '$inpat =~ m' . "\a$inpat\a";
2202
2203             if ( $@ ne "" ) {
2204
2205                 # Ouch. Not good. Print the error.
2206                 print $OUT $@;
2207                 next CMD;
2208             }
2209             $obj->pat($inpat);
2210         } ## end if ($inpat ne "")
2211
2212         # Where we are now is where to stop after wraparound.
2213         $end = $start;
2214
2215         # Don't move away from this line.
2216         $incr = -1;
2217
2218         my $pat = $obj->pat;
2219         # Search inside the eval to prevent pattern badness
2220         # from killing us.
2221         eval {
2222             no strict q/vars/;
2223             for (;;) {
2224                 # Back up a line.
2225                 --$start;
2226
2227                 # Wrap if we pass the first line.
2228
2229                 $start = $max if ($start <= 0);
2230
2231                 # Quit if we get back where we started,
2232                 last if ($start == $end);
2233
2234                 # Match?
2235                 if ($dbline[$start] =~ m/$pat/i) {
2236                     if ($slave_editor) {
2237                         # Yep, follow slave editor requirements.
2238                         print $OUT "\032\032$filename:$start:0\n";
2239                     }
2240                     else {
2241                         # Yep, just print normally.
2242                         print $OUT "$start:\t",$dbline[$start],"\n";
2243                     }
2244
2245                     # Found, so done.
2246                     last;
2247                 }
2248             }
2249         };
2250
2251         # Say we failed if the loop never found anything,
2252         if ( $start == $end ) {
2253             print {$OUT} "?$pat?: not found\n";
2254         }
2255         next CMD;
2256     }
2257
2258     return;
2259 }
2260
2261 sub _DB__handle_restart_and_rerun_commands {
2262     my ($obj) = @_;
2263
2264     my $cmd_cmd = $obj->cmd_verb;
2265     my $cmd_params = $obj->cmd_args;
2266     # R - restart execution.
2267     # rerun - controlled restart execution.
2268     if ($cmd_cmd eq 'rerun' or $cmd_params eq '') {
2269
2270         # Change directory to the initial current working directory on
2271         # the script startup, so if the debugged program changed the
2272         # directory, then we will still be able to find the path to the
2273         # the program. (perl 5 RT #121509 ).
2274         chdir ($_initial_cwd);
2275
2276         my @args = ($cmd_cmd eq 'R' ? restart() : rerun($cmd_params));
2277
2278         # Close all non-system fds for a clean restart.  A more
2279         # correct method would be to close all fds that were not
2280         # open when the process started, but this seems to be
2281         # hard.  See "debugger 'R'estart and open database
2282         # connections" on p5p.
2283
2284         my $max_fd = 1024; # default if POSIX can't be loaded
2285         if (eval { require POSIX }) {
2286             eval { $max_fd = POSIX::sysconf(POSIX::_SC_OPEN_MAX()) };
2287         }
2288
2289         if (defined $max_fd) {
2290             foreach ($^F+1 .. $max_fd-1) {
2291                 next unless open FD_TO_CLOSE, "<&=$_";
2292                 close(FD_TO_CLOSE);
2293             }
2294         }
2295
2296         # And run Perl again.  We use exec() to keep the
2297         # PID stable (and that way $ini_pids is still valid).
2298         exec(@args) or print {$OUT} "exec failed: $!\n";
2299
2300         last CMD;
2301     }
2302
2303     return;
2304 }
2305
2306 sub _DB__handle_run_command_in_pager_command {
2307     my ($obj) = @_;
2308
2309     if ($cmd =~ m#\A\|\|?\s*[^|]#) {
2310         if ( $pager =~ /^\|/ ) {
2311
2312             # Default pager is into a pipe. Redirect I/O.
2313             open( SAVEOUT, ">&STDOUT" )
2314             || _db_warn("Can't save STDOUT");
2315             open( STDOUT, ">&OUT" )
2316             || _db_warn("Can't redirect STDOUT");
2317         } ## end if ($pager =~ /^\|/)
2318         else {
2319
2320             # Not into a pipe. STDOUT is safe.
2321             open( SAVEOUT, ">&OUT" ) || _db_warn("Can't save DB::OUT");
2322         }
2323
2324         # Fix up environment to record we have less if so.
2325         fix_less();
2326
2327         unless ( $obj->piped(scalar ( open( OUT, $pager ) ) ) ) {
2328
2329             # Couldn't open pipe to pager.
2330             _db_warn("Can't pipe output to '$pager'");
2331             if ( $pager =~ /^\|/ ) {
2332
2333                 # Redirect I/O back again.
2334                 open( OUT, ">&STDOUT" )    # XXX: lost message
2335                 || _db_warn("Can't restore DB::OUT");
2336                 open( STDOUT, ">&SAVEOUT" )
2337                 || _db_warn("Can't restore STDOUT");
2338                 close(SAVEOUT);
2339             } ## end if ($pager =~ /^\|/)
2340             else {
2341
2342                 # Redirect I/O. STDOUT already safe.
2343                 open( OUT, ">&STDOUT" )    # XXX: lost message
2344                 || _db_warn("Can't restore DB::OUT");
2345             }
2346             next CMD;
2347         } ## end unless ($piped = open(OUT,...
2348
2349         # Set up broken-pipe handler if necessary.
2350         $SIG{PIPE} = \&DB::catch
2351         if $pager =~ /^\|/
2352         && ( "" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE} );
2353
2354         _autoflush(\*OUT);
2355         # Save current filehandle, and put it back.
2356         $obj->selected(scalar( select(OUT) ));
2357         # Don't put it back if pager was a pipe.
2358         if ($cmd !~ /\A\|\|/)
2359         {
2360             select($obj->selected());
2361             $obj->selected("");
2362         }
2363
2364         # Trim off the pipe symbols and run the command now.
2365         $cmd =~ s#\A\|+\s*##;
2366         redo PIPE;
2367     }
2368
2369     return;
2370 }
2371
2372 sub _DB__handle_m_command {
2373     my ($obj) = @_;
2374
2375     if ($cmd =~ s#\Am\s+([\w:]+)\s*\z# #) {
2376         methods($1);
2377         next CMD;
2378     }
2379
2380     # m expr - set up DB::eval to do the work
2381     if ($cmd =~ s#\Am\b# #) {    # Rest gets done by DB::eval()
2382         $onetimeDump = 'methods';   #  method output gets used there
2383     }
2384
2385     return;
2386 }
2387
2388 sub _DB__at_end_of_every_command {
2389     my ($obj) = @_;
2390
2391     # At the end of every command:
2392     if ($obj->piped) {
2393
2394         # Unhook the pipe mechanism now.
2395         if ( $pager =~ /^\|/ ) {
2396
2397             # No error from the child.
2398             $? = 0;
2399
2400             # we cannot warn here: the handle is missing --tchrist
2401             close(OUT) || print SAVEOUT "\nCan't close DB::OUT\n";
2402
2403             # most of the $? crud was coping with broken cshisms
2404             # $? is explicitly set to 0, so this never runs.
2405             if ($?) {
2406                 print SAVEOUT "Pager '$pager' failed: ";
2407                 if ( $? == -1 ) {
2408                     print SAVEOUT "shell returned -1\n";
2409                 }
2410                 elsif ( $? >> 8 ) {
2411                     print SAVEOUT ( $? & 127 )
2412                     ? " (SIG#" . ( $? & 127 ) . ")"
2413                     : "", ( $? & 128 ) ? " -- core dumped" : "", "\n";
2414                 }
2415                 else {
2416                     print SAVEOUT "status ", ( $? >> 8 ), "\n";
2417                 }
2418             } ## end if ($?)
2419
2420             # Reopen filehandle for our output (if we can) and
2421             # restore STDOUT (if we can).
2422             open( OUT, ">&STDOUT" ) || _db_warn("Can't restore DB::OUT");
2423             open( STDOUT, ">&SAVEOUT" )
2424             || _db_warn("Can't restore STDOUT");
2425
2426             # Turn off pipe exception handler if necessary.
2427             $SIG{PIPE} = "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
2428
2429             # Will stop ignoring SIGPIPE if done like nohup(1)
2430             # does SIGINT but Perl doesn't give us a choice.
2431         } ## end if ($pager =~ /^\|/)
2432         else {
2433
2434             # Non-piped "pager". Just restore STDOUT.
2435             open( OUT, ">&SAVEOUT" ) || _db_warn("Can't restore DB::OUT");
2436         }
2437
2438         # Let Readline know about the new filehandles.
2439         reset_IN_OUT( \*IN, \*OUT );
2440
2441         # Close filehandle pager was using, restore the normal one
2442         # if necessary,
2443         close(SAVEOUT);
2444
2445         if ($obj->selected() ne "") {
2446             select($obj->selected);
2447             $obj->selected("");
2448         }
2449
2450         # No pipes now.
2451         $obj->piped("");
2452     } ## end if ($piped)
2453
2454     return;
2455 }
2456
2457 sub _DB__handle_watch_expressions
2458 {
2459     my $self = shift;
2460
2461     if ( $DB::trace & 2 ) {
2462         for my $n (0 .. $#DB::to_watch) {
2463             $DB::evalarg = $DB::to_watch[$n];
2464             local $DB::onetimeDump;    # Tell DB::eval() to not output results
2465
2466             # Fix context DB::eval() wants to return an array, but
2467             # we need a scalar here.
2468             my ($val) = join( "', '", DB::eval(@_) );
2469             $val = ( ( defined $val ) ? "'$val'" : 'undef' );
2470
2471             # Did it change?
2472             if ( $val ne $DB::old_watch[$n] ) {
2473
2474                 # Yep! Show the difference, and fake an interrupt.
2475                 $DB::signal = 1;
2476                 print {$DB::OUT} <<EOP;
2477 Watchpoint $n:\t$DB::to_watch[$n] changed:
2478     old value:\t$DB::old_watch[$n]
2479     new value:\t$val
2480 EOP
2481                 $DB::old_watch[$n] = $val;
2482             } ## end if ($val ne $old_watch...
2483         } ## end for my $n (0 ..
2484     } ## end if ($trace & 2)
2485
2486     return;
2487 }
2488
2489 # 't' is type.
2490 # 'm' is method.
2491 # 'v' is the value (i.e: method name or subroutine ref).
2492 # 's' is subroutine.
2493 my %cmd_lookup =
2494 (
2495     '-' => { t => 'm', v => '_handle_dash_command', },
2496     '.' => { t => 's', v => \&_DB__handle_dot_command, },
2497     '=' => { t => 'm', v => '_handle_equal_sign_command', },
2498     'H' => { t => 'm', v => '_handle_H_command', },
2499     'S' => { t => 'm', v => '_handle_S_command', },
2500     'T' => { t => 'm', v => '_handle_T_command', },
2501     'W' => { t => 'm', v => '_handle_W_command', },
2502     'c' => { t => 's', v => \&_DB__handle_c_command, },
2503     'f' => { t => 's', v => \&_DB__handle_f_command, },
2504     'm' => { t => 's', v => \&_DB__handle_m_command, },
2505     'n' => { t => 'm', v => '_handle_n_command', },
2506     'p' => { t => 'm', v => '_handle_p_command', },
2507     'q' => { t => 'm', v => '_handle_q_command', },
2508     'r' => { t => 'm', v => '_handle_r_command', },
2509     's' => { t => 'm', v => '_handle_s_command', },
2510     'save' => { t => 'm', v => '_handle_save_command', },
2511     'source' => { t => 'm', v => '_handle_source_command', },
2512     't' => { t => 'm', v => '_handle_t_command', },
2513     'w' => { t => 'm', v => '_handle_w_command', },
2514     'x' => { t => 'm', v => '_handle_x_command', },
2515     'y' => { t => 's', v => \&_DB__handle_y_command, },
2516     (map { $_ => { t => 'm', v => '_handle_V_command_and_X_command', }, }
2517         ('X', 'V')),
2518     (map { $_ => { t => 'm', v => '_handle_enable_disable_commands', }, }
2519         qw(enable disable)),
2520     (map { $_ =>
2521         { t => 's', v => \&_DB__handle_restart_and_rerun_commands, },
2522         } qw(R rerun)),
2523     (map { $_ => {t => 'm', v => '_handle_cmd_wrapper_commands' }, }
2524         qw(a A b B e E h i l L M o O v w W)),
2525 );
2526
2527 sub DB {
2528
2529     # lock the debugger and get the thread id for the prompt
2530     lock($DBGR);
2531     my $tid;
2532     my $position;
2533     my ($prefix, $after, $infix);
2534     my $pat;
2535     my $explicit_stop;
2536     my $piped;
2537     my $selected;
2538
2539     if ($ENV{PERL5DB_THREADED}) {
2540         $tid = eval { "[".threads->tid."]" };
2541     }
2542
2543     my $cmd_verb;
2544     my $cmd_args;
2545
2546     my $obj = DB::Obj->new(
2547         {
2548             position => \$position,
2549             prefix => \$prefix,
2550             after => \$after,
2551             explicit_stop => \$explicit_stop,
2552             infix => \$infix,
2553             cmd_args => \$cmd_args,
2554             cmd_verb => \$cmd_verb,
2555             pat => \$pat,
2556             piped => \$piped,
2557             selected => \$selected,
2558         },
2559     );
2560
2561     $obj->_DB_on_init__initialize_globals(@_);
2562
2563     # Preserve current values of $@, $!, $^E, $,, $/, $\, $^W.
2564     # The code being debugged may have altered them.
2565     DB::save();
2566
2567     # Since DB::DB gets called after every line, we can use caller() to
2568     # figure out where we last were executing. Sneaky, eh? This works because
2569     # caller is returning all the extra information when called from the
2570     # debugger.
2571     local ( $package, $filename, $line ) = caller;
2572     $filename_ini = $filename;
2573
2574     # set up the context for DB::eval, so it can properly execute
2575     # code on behalf of the user. We add the package in so that the
2576     # code is eval'ed in the proper package (not in the debugger!).
2577     local $usercontext = _calc_usercontext($package);
2578
2579     # Create an alias to the active file magical array to simplify
2580     # the code here.
2581     local (*dbline) = $main::{ '_<' . $filename };
2582
2583     # Last line in the program.
2584     $max = $#dbline;
2585
2586     # The &-call is here to ascertain the mutability of @_.
2587     &_DB__determine_if_we_should_break;
2588
2589     # Preserve the current stop-or-not, and see if any of the W
2590     # (watch expressions) has changed.
2591     my $was_signal = $signal;
2592
2593     # If we have any watch expressions ...
2594     _DB__handle_watch_expressions($obj);
2595
2596 =head2 C<watchfunction()>
2597
2598 C<watchfunction()> is a function that can be defined by the user; it is a
2599 function which will be run on each entry to C<DB::DB>; it gets the
2600 current package, filename, and line as its parameters.
2601
2602 The watchfunction can do anything it likes; it is executing in the
2603 debugger's context, so it has access to all of the debugger's internal
2604 data structures and functions.
2605
2606 C<watchfunction()> can control the debugger's actions. Any of the following
2607 will cause the debugger to return control to the user's program after
2608 C<watchfunction()> executes:
2609
2610 =over 4
2611
2612 =item *
2613
2614 Returning a false value from the C<watchfunction()> itself.
2615
2616 =item *
2617
2618 Altering C<$single> to a false value.
2619
2620 =item *
2621
2622 Altering C<$signal> to a false value.
2623
2624 =item *
2625
2626 Turning off the C<4> bit in C<$trace> (this also disables the
2627 check for C<watchfunction()>. This can be done with
2628
2629     $trace &= ~4;
2630
2631 =back
2632
2633 =cut
2634
2635     # If there's a user-defined DB::watchfunction, call it with the
2636     # current package, filename, and line. The function executes in
2637     # the DB:: package.
2638     if ( $trace & 4 ) {    # User-installed watch
2639         return
2640           if watchfunction( $package, $filename, $line )
2641           and not $single
2642           and not $was_signal
2643           and not( $trace & ~4 );
2644     } ## end if ($trace & 4)
2645
2646     # Pick up any alteration to $signal in the watchfunction, and
2647     # turn off the signal now.
2648     $was_signal = $signal;
2649     $signal     = 0;
2650
2651 =head2 GETTING READY TO EXECUTE COMMANDS
2652
2653 The debugger decides to take control if single-step mode is on, the
2654 C<t> command was entered, or the user generated a signal. If the program
2655 has fallen off the end, we set things up so that entering further commands
2656 won't cause trouble, and we say that the program is over.
2657
2658 =cut
2659
2660     # Make sure that we always print if asked for explicitly regardless
2661     # of $trace_to_depth .
2662     $explicit_stop = ($single || $was_signal);
2663
2664     # Check to see if we should grab control ($single true,
2665     # trace set appropriately, or we got a signal).
2666     if ( $explicit_stop || ( $trace & 1 ) ) {
2667         $obj->_DB__grab_control(@_);
2668     } ## end if ($single || ($trace...
2669
2670 =pod
2671
2672 If there's an action to be executed for the line we stopped at, execute it.
2673 If there are any preprompt actions, execute those as well.
2674
2675 =cut
2676
2677     # If there's an action, do it now.
2678     if ($action) {
2679         $evalarg = $action;
2680         # The &-call is here to ascertain the mutability of @_.
2681         &DB::eval;
2682     }
2683
2684     # Are we nested another level (e.g., did we evaluate a function
2685     # that had a breakpoint in it at the debugger prompt)?
2686     if ( $single || $was_signal ) {
2687
2688         # Yes, go down a level.
2689         local $level = $level + 1;
2690
2691         # Do any pre-prompt actions.
2692         foreach $evalarg (@$pre) {
2693             # The &-call is here to ascertain the mutability of @_.
2694             &DB::eval;
2695         }
2696
2697         # Complain about too much recursion if we passed the limit.
2698         if ($single & 4) {
2699             print $OUT $stack_depth . " levels deep in subroutine calls!\n";
2700         }
2701
2702         # The line we're currently on. Set $incr to -1 to stay here
2703         # until we get a command that tells us to advance.
2704         $start = $line;
2705         $incr  = -1;      # for backward motion.
2706
2707         # Tack preprompt debugger actions ahead of any actual input.
2708         @typeahead = ( @$pretype, @typeahead );
2709
2710 =head2 WHERE ARE WE?
2711
2712 XXX Relocate this section?
2713
2714 The debugger normally shows the line corresponding to the current line of
2715 execution. Sometimes, though, we want to see the next line, or to move elsewhere
2716 in the file. This is done via the C<$incr>, C<$start>, and C<$max> variables.
2717
2718 C<$incr> controls by how many lines the I<current> line should move forward
2719 after a command is executed. If set to -1, this indicates that the I<current>
2720 line shouldn't change.
2721
2722 C<$start> is the I<current> line. It is used for things like knowing where to
2723 move forwards or backwards from when doing an C<L> or C<-> command.
2724
2725 C<$max> tells the debugger where the last line of the current file is. It's
2726 used to terminate loops most often.
2727
2728 =head2 THE COMMAND LOOP
2729
2730 Most of C<DB::DB> is actually a command parsing and dispatch loop. It comes
2731 in two parts:
2732
2733 =over 4
2734
2735 =item *
2736
2737 The outer part of the loop, starting at the C<CMD> label. This loop
2738 reads a command and then executes it.
2739
2740 =item *
2741
2742 The inner part of the loop, starting at the C<PIPE> label. This part
2743 is wholly contained inside the C<CMD> block and only executes a command.
2744 Used to handle commands running inside a pager.
2745
2746 =back
2747
2748 So why have two labels to restart the loop? Because sometimes, it's easier to
2749 have a command I<generate> another command and then re-execute the loop to do
2750 the new command. This is faster, but perhaps a bit more convoluted.
2751
2752 =cut
2753
2754         # The big command dispatch loop. It keeps running until the
2755         # user yields up control again.
2756         #
2757         # If we have a terminal for input, and we get something back
2758         # from readline(), keep on processing.
2759
2760       CMD:
2761         while (_DB__read_next_cmd($tid))
2762         {
2763
2764             share($cmd);
2765             # ... try to execute the input as debugger commands.
2766
2767             # Don't stop running.
2768             $single = 0;
2769
2770             # No signal is active.
2771             $signal = 0;
2772
2773             # Handle continued commands (ending with \):
2774             if ($cmd =~ s/\\\z/\n/) {
2775                 $cmd .= DB::readline("  cont: ");
2776                 redo CMD;
2777             }
2778
2779 =head4 The null command
2780
2781 A newline entered by itself means I<re-execute the last command>. We grab the
2782 command out of C<$laststep> (where it was recorded previously), and copy it
2783 back into C<$cmd> to be executed below. If there wasn't any previous command,
2784 we'll do nothing below (no command will match). If there was, we also save it
2785 in the command history and fall through to allow the command parsing to pick
2786 it up.
2787
2788 =cut
2789
2790             # Empty input means repeat the last command.
2791             if ($cmd eq '') {
2792                 $cmd = $laststep;
2793             }
2794             chomp($cmd);    # get rid of the annoying extra newline
2795             if (length($cmd) >= 2) {
2796                 push( @hist, $cmd );
2797             }
2798             push( @truehist, $cmd );
2799             share(@hist);
2800             share(@truehist);
2801
2802             # This is a restart point for commands that didn't arrive
2803             # via direct user input. It allows us to 'redo PIPE' to
2804             # re-execute command processing without reading a new command.
2805           PIPE: {
2806                 _DB__trim_command_and_return_first_component($obj);
2807
2808 =head3 COMMAND ALIASES
2809
2810 The debugger can create aliases for commands (these are stored in the
2811 C<%alias> hash). Before a command is executed, the command loop looks it up
2812 in the alias hash and substitutes the contents of the alias for the command,
2813 completely replacing it.
2814
2815 =cut
2816
2817                 # See if there's an alias for the command, and set it up if so.
2818                 if ( $alias{$cmd_verb} ) {
2819
2820                     # Squelch signal handling; we want to keep control here
2821                     # if something goes loco during the alias eval.
2822                     local $SIG{__DIE__};
2823                     local $SIG{__WARN__};
2824
2825                     # This is a command, so we eval it in the DEBUGGER's
2826                     # scope! Otherwise, we can't see the special debugger
2827                     # variables, or get to the debugger's subs. (Well, we
2828                     # _could_, but why make it even more complicated?)
2829                     eval "\$cmd =~ $alias{$cmd_verb}";
2830                     if ($@) {
2831                         local $\ = '';
2832                         print $OUT "Couldn't evaluate '$cmd_verb' alias: $@";
2833                         next CMD;
2834                     }
2835                     _DB__trim_command_and_return_first_component($obj);
2836                 } ## end if ($alias{$cmd_verb})
2837
2838 =head3 MAIN-LINE COMMANDS
2839
2840 All of these commands work up to and after the program being debugged has
2841 terminated.
2842
2843 =head4 C<q> - quit
2844
2845 Quit the debugger. This entails setting the C<$fall_off_end> flag, so we don't
2846 try to execute further, cleaning any restart-related stuff out of the
2847 environment, and executing with the last value of C<$?>.
2848
2849 =cut
2850
2851                 # All of these commands were remapped in perl 5.8.0;
2852                 # we send them off to the secondary dispatcher (see below).
2853                 $obj->_handle_special_char_cmd_wrapper_commands;
2854                 _DB__trim_command_and_return_first_component($obj);
2855
2856                 if (my $cmd_rec = $cmd_lookup{$cmd_verb}) {
2857                     my $type = $cmd_rec->{t};
2858                     my $val = $cmd_rec->{v};
2859                     if ($type eq 'm') {
2860                         $obj->$val();
2861                     }
2862                     elsif ($type eq 's') {
2863                         $val->($obj);
2864                     }
2865                 }
2866
2867 =head4 C<t> - trace [n]
2868
2869 Turn tracing on or off. Inverts the appropriate bit in C<$trace> (q.v.).
2870 If level is specified, set C<$trace_to_depth>.
2871
2872 =head4 C<S> - list subroutines matching/not matching a pattern
2873
2874 Walks through C<%sub>, checking to see whether or not to print the name.
2875
2876 =head4 C<X> - list variables in current package
2877
2878 Since the C<V> command actually processes this, just change this to the
2879 appropriate C<V> command and fall through.
2880
2881 =head4 C<V> - list variables
2882
2883 Uses C<dumpvar.pl> to dump out the current values for selected variables.
2884
2885 =head4 C<x> - evaluate and print an expression
2886
2887 Hands the expression off to C<DB::eval>, setting it up to print the value
2888 via C<dumpvar.pl> instead of just printing it directly.
2889
2890 =head4 C<m> - print methods
2891
2892 Just uses C<DB::methods> to determine what methods are available.
2893
2894 =head4 C<f> - switch files
2895
2896 Switch to a different filename.
2897
2898 =head4 C<.> - return to last-executed line.
2899
2900 We set C<$incr> to -1 to indicate that the debugger shouldn't move ahead,
2901 and then we look up the line in the magical C<%dbline> hash.
2902
2903 =head4 C<-> - back one window
2904
2905 We change C<$start> to be one window back; if we go back past the first line,
2906 we set it to be the first line. We ser C<$incr> to put us back at the
2907 currently-executing line, and then put a C<l $start +> (list one window from
2908 C<$start>) in C<$cmd> to be executed later.
2909
2910 =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>>
2911
2912 In Perl 5.8.0, a realignment of the commands was done to fix up a number of
2913 problems, most notably that the default case of several commands destroying
2914 the user's work in setting watchpoints, actions, etc. We wanted, however, to
2915 retain the old commands for those who were used to using them or who preferred
2916 them. At this point, we check for the new commands and call C<cmd_wrapper> to
2917 deal with them instead of processing them in-line.
2918
2919 =head4 C<y> - List lexicals in higher scope
2920
2921 Uses C<PadWalker> to find the lexicals supplied as arguments in a scope
2922 above the current one and then displays then using C<dumpvar.pl>.
2923
2924 =head3 COMMANDS NOT WORKING AFTER PROGRAM ENDS
2925
2926 All of the commands below this point don't work after the program being
2927 debugged has ended. All of them check to see if the program has ended; this
2928 allows the commands to be relocated without worrying about a 'line of
2929 demarcation' above which commands can be entered anytime, and below which
2930 they can't.
2931
2932 =head4 C<n> - single step, but don't trace down into subs
2933
2934 Done by setting C<$single> to 2, which forces subs to execute straight through
2935 when entered (see C<DB::sub>). We also save the C<n> command in C<$laststep>,
2936 so a null command knows what to re-execute.
2937
2938 =head4 C<s> - single-step, entering subs
2939
2940 Sets C<$single> to 1, which causes C<DB::sub> to continue tracing inside
2941 subs. Also saves C<s> as C<$lastcmd>.
2942
2943 =head4 C<c> - run continuously, setting an optional breakpoint
2944
2945 Most of the code for this command is taken up with locating the optional
2946 breakpoint, which is either a subroutine name or a line number. We set
2947 the appropriate one-time-break in C<@dbline> and then turn off single-stepping
2948 in this and all call levels above this one.
2949
2950 =head4 C<r> - return from a subroutine
2951
2952 For C<r> to work properly, the debugger has to stop execution again
2953 immediately after the return is executed. This is done by forcing
2954 single-stepping to be on in the call level above the current one. If
2955 we are printing return values when a C<r> is executed, set C<$doret>
2956 appropriately, and force us out of the command loop.
2957
2958 =head4 C<T> - stack trace
2959
2960 Just calls C<DB::print_trace>.
2961
2962 =head4 C<w> - List window around current line.
2963
2964 Just calls C<DB::cmd_w>.
2965
2966 =head4 C<W> - watch-expression processing.
2967
2968 Just calls C<DB::cmd_W>.
2969
2970 =head4 C</> - search forward for a string in the source
2971
2972 We take the argument and treat it as a pattern. If it turns out to be a
2973 bad one, we return the error we got from trying to C<eval> it and exit.
2974 If not, we create some code to do the search and C<eval> it so it can't
2975 mess us up.
2976
2977 =cut
2978
2979                 _DB__handle_forward_slash_command($obj);
2980
2981 =head4 C<?> - search backward for a string in the source
2982
2983 Same as for C</>, except the loop runs backwards.
2984
2985 =cut
2986
2987                 _DB__handle_question_mark_command($obj);
2988
2989 =head4 C<$rc> - Recall command
2990
2991 Manages the commands in C<@hist> (which is created if C<Term::ReadLine> reports
2992 that the terminal supports history). It finds the command required, puts it
2993 into C<$cmd>, and redoes the loop to execute it.
2994
2995 =cut
2996
2997                 # $rc - recall command.
2998                 $obj->_handle_rc_recall_command;
2999
3000 =head4 C<$sh$sh> - C<system()> command
3001
3002 Calls the C<_db_system()> to handle the command. This keeps the C<STDIN> and
3003 C<STDOUT> from getting messed up.
3004
3005 =cut
3006
3007                 $obj->_handle_sh_command;
3008
3009 =head4 C<$rc I<pattern> $rc> - Search command history
3010
3011 Another command to manipulate C<@hist>: this one searches it with a pattern.
3012 If a command is found, it is placed in C<$cmd> and executed via C<redo>.
3013
3014 =cut
3015
3016                 $obj->_handle_rc_search_history_command;
3017
3018 =head4 C<$sh> - Invoke a shell
3019
3020 Uses C<_db_system()> to invoke a shell.
3021
3022 =cut
3023
3024 =head4 C<$sh I<command>> - Force execution of a command in a shell
3025
3026 Like the above, but the command is passed to the shell. Again, we use
3027 C<_db_system()> to avoid problems with C<STDIN> and C<STDOUT>.
3028
3029 =head4 C<H> - display commands in history
3030
3031 Prints the contents of C<@hist> (if any).
3032
3033 =head4 C<man, doc, perldoc> - look up documentation
3034
3035 Just calls C<runman()> to print the appropriate document.
3036
3037 =cut
3038
3039                 $obj->_handle_doc_command;
3040
3041 =head4 C<p> - print
3042
3043 Builds a C<print EXPR> expression in the C<$cmd>; this will get executed at
3044 the bottom of the loop.
3045
3046 =head4 C<=> - define command alias
3047
3048 Manipulates C<%alias> to add or list command aliases.
3049
3050 =head4 C<source> - read commands from a file.
3051
3052 Opens a lexical filehandle and stacks it on C<@cmdfhs>; C<DB::readline> will
3053 pick it up.
3054
3055 =head4 C<enable> C<disable> - enable or disable breakpoints
3056
3057 This enables or disables breakpoints.
3058
3059 =head4 C<save> - send current history to a file
3060
3061 Takes the complete history, (not the shrunken version you see with C<H>),
3062 and saves it to the given filename, so it can be replayed using C<source>.
3063
3064 Note that all C<^(save|source)>'s are commented out with a view to minimise recursion.
3065
3066 =head4 C<R> - restart
3067
3068 Restart the debugger session.
3069
3070 =head4 C<rerun> - rerun the current session
3071
3072 Return to any given position in the B<true>-history list
3073
3074 =head4 C<|, ||> - pipe output through the pager.
3075
3076 For C<|>, we save C<OUT> (the debugger's output filehandle) and C<STDOUT>
3077 (the program's standard output). For C<||>, we only save C<OUT>. We open a
3078 pipe to the pager (restoring the output filehandles if this fails). If this
3079 is the C<|> command, we also set up a C<SIGPIPE> handler which will simply
3080 set C<$signal>, sending us back into the debugger.
3081
3082 We then trim off the pipe symbols and C<redo> the command loop at the
3083 C<PIPE> label, causing us to evaluate the command in C<$cmd> without
3084 reading another.
3085
3086 =cut
3087
3088                 # || - run command in the pager, with output to DB::OUT.
3089                 _DB__handle_run_command_in_pager_command($obj);
3090
3091 =head3 END OF COMMAND PARSING
3092
3093 Anything left in C<$cmd> at this point is a Perl expression that we want to
3094 evaluate. We'll always evaluate in the user's context, and fully qualify
3095 any variables we might want to address in the C<DB> package.
3096
3097 =cut
3098
3099             }    # PIPE:
3100
3101             # trace an expression
3102             $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
3103
3104             # Make sure the flag that says "the debugger's running" is
3105             # still on, to make sure we get control again.
3106             $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd";
3107
3108             # Run *our* eval that executes in the caller's context.
3109             # The &-call is here to ascertain the mutability of @_.
3110             &DB::eval;
3111
3112             # Turn off the one-time-dump stuff now.
3113             if ($onetimeDump) {
3114                 $onetimeDump      = undef;
3115                 $onetimedumpDepth = undef;
3116             }
3117             elsif ( $term_pid == $$ ) {
3118                 eval { # May run under miniperl, when not available...
3119                     STDOUT->flush();
3120                     STDERR->flush();
3121                 };
3122
3123                 # XXX If this is the master pid, print a newline.
3124                 print {$OUT} "\n";
3125             }
3126         } ## end while (($term || &setterm...
3127
3128 =head3 POST-COMMAND PROCESSING
3129
3130 After each command, we check to see if the command output was piped anywhere.
3131 If so, we go through the necessary code to unhook the pipe and go back to
3132 our standard filehandles for input and output.
3133
3134 =cut
3135
3136         continue {    # CMD:
3137             _DB__at_end_of_every_command($obj);
3138         }    # CMD:
3139
3140 =head3 COMMAND LOOP TERMINATION
3141
3142 When commands have finished executing, we come here. If the user closed the
3143 input filehandle, we turn on C<$fall_off_end> to emulate a C<q> command. We
3144 evaluate any post-prompt items. We restore C<$@>, C<$!>, C<$^E>, C<$,>, C<$/>,
3145 C<$\>, and C<$^W>, and return a null list as expected by the Perl interpreter.
3146 The interpreter will then execute the next line and then return control to us
3147 again.
3148
3149 =cut
3150
3151         # No more commands? Quit.
3152         $fall_off_end = 1 unless defined $cmd;    # Emulate 'q' on EOF
3153
3154         # Evaluate post-prompt commands.
3155         foreach $evalarg (@$post) {
3156             # The &-call is here to ascertain the mutability of @_.
3157             &DB::eval;
3158         }
3159     }    # if ($single || $signal)
3160
3161     # Put the user's globals back where you found them.
3162     ( $@, $!, $^E, $,, $/, $\, $^W ) = @saved;
3163     ();
3164 } ## end sub DB
3165
3166 # Because DB::Obj is used above,
3167 #
3168 #   my $obj = DB::Obj->new(
3169 #
3170 # The following package declaration must come before that,
3171 # or else runtime errors will occur with
3172 #
3173 #   PERLDB_OPTS="autotrace nonstop"
3174 #
3175 # ( rt#116771 )
3176 BEGIN {
3177
3178 package DB::Obj;
3179
3180 sub new {
3181     my $class = shift;
3182
3183     my $self = bless {}, $class;
3184
3185     $self->_init(@_);
3186
3187     return $self;
3188 }
3189
3190 sub _init {
3191     my ($self, $args) = @_;
3192
3193     %{$self} = (%$self, %$args);
3194
3195     return;
3196 }
3197
3198 {
3199     no strict 'refs';
3200     foreach my $slot_name (qw(
3201         after explicit_stop infix pat piped position prefix selected cmd_verb
3202         cmd_args
3203         )) {
3204         my $slot = $slot_name;
3205         *{$slot} = sub {
3206             my $self = shift;
3207
3208             if (@_) {
3209                 ${ $self->{$slot} } = shift;
3210             }
3211
3212             return ${ $self->{$slot} };
3213         };
3214
3215         *{"append_to_$slot"} = sub {
3216             my $self = shift;
3217             my $s = shift;
3218
3219             return $self->$slot($self->$slot . $s);
3220         };
3221     }
3222 }
3223
3224 sub _DB_on_init__initialize_globals
3225 {
3226     my $self = shift;
3227
3228     # Check for whether we should be running continuously or not.
3229     # _After_ the perl program is compiled, $single is set to 1:
3230     if ( $single and not $second_time++ ) {
3231
3232         # Options say run non-stop. Run until we get an interrupt.
3233         if ($runnonstop) {    # Disable until signal
3234                 # If there's any call stack in place, turn off single
3235                 # stepping into subs throughout the stack.
3236             for my $i (0 .. $stack_depth) {
3237                 $stack[ $i ] &= ~1;
3238             }
3239
3240             # And we are now no longer in single-step mode.
3241             $single = 0;
3242
3243             # If we simply returned at this point, we wouldn't get
3244             # the trace info. Fall on through.
3245             # return;
3246         } ## end if ($runnonstop)
3247
3248         elsif ($ImmediateStop) {
3249
3250             # We are supposed to stop here; XXX probably a break.
3251             $ImmediateStop = 0;    # We've processed it; turn it off
3252             $signal        = 1;    # Simulate an interrupt to force
3253                                    # us into the command loop
3254         }
3255     } ## end if ($single and not $second_time...
3256
3257     # If we're in single-step mode, or an interrupt (real or fake)
3258     # has occurred, turn off non-stop mode.
3259     $runnonstop = 0 if $single or $signal;
3260
3261     return;
3262 }
3263
3264 sub _my_print_lineinfo
3265 {
3266     my ($self, $i, $incr_pos) = @_;
3267
3268     if ($frame) {
3269         # Print it indented if tracing is on.
3270         DB::print_lineinfo( ' ' x $stack_depth,
3271             "$i:\t$DB::dbline[$i]" . $self->after );
3272     }
3273     else {
3274         DB::depth_print_lineinfo($self->explicit_stop, $incr_pos);
3275     }
3276 }
3277
3278 sub _curr_line {
3279     return $DB::dbline[$line];
3280 }
3281
3282 sub _is_full {
3283     my ($self, $letter) = @_;
3284
3285     return ($DB::cmd eq $letter);
3286 }
3287
3288 sub _DB__grab_control
3289 {
3290     my $self = shift;
3291
3292     # Yes, grab control.
3293     if ($slave_editor) {
3294
3295         # Tell the editor to update its position.
3296         $self->position("\032\032${DB::filename}:$line:0\n");
3297         DB::print_lineinfo($self->position());
3298     }
3299
3300 =pod
3301
3302 Special check: if we're in package C<DB::fake>, we've gone through the
3303 C<END> block at least once. We set up everything so that we can continue
3304 to enter commands and have a valid context to be in.
3305
3306 =cut
3307
3308     elsif ( $DB::package eq 'DB::fake' ) {
3309
3310         # Fallen off the end already.
3311         if (!$DB::term) {
3312             DB::setterm();
3313         }
3314
3315         DB::print_help(<<EOP);
3316 Debugged program terminated.  Use B<q> to quit or B<R> to restart,
3317 use B<o> I<inhibit_exit> to avoid stopping after program termination,
3318 B<h q>, B<h R> or B<h o> to get additional info.
3319 EOP
3320
3321         # Set the DB::eval context appropriately.
3322         $DB::package     = 'main';
3323         $DB::usercontext = DB::_calc_usercontext($DB::package);
3324     } ## end elsif ($package eq 'DB::fake')
3325
3326 =pod
3327
3328 If the program hasn't finished executing, we scan forward to the
3329 next executable line, print that out, build the prompt from the file and line
3330 number information, and print that.
3331
3332 =cut
3333
3334     else {
3335
3336
3337         # Still somewhere in the midst of execution. Set up the
3338         #  debugger prompt.
3339         $DB::sub =~ s/\'/::/;    # Swap Perl 4 package separators (') to
3340                              # Perl 5 ones (sorry, we don't print Klingon
3341                              #module names)
3342
3343         $self->prefix($DB::sub =~ /::/ ? "" : ($DB::package . '::'));
3344         $self->append_to_prefix( "$DB::sub(${DB::filename}:" );
3345         $self->after( $self->_curr_line =~ /\n$/ ? '' : "\n" );
3346
3347         # Break up the prompt if it's really long.
3348         if ( length($self->prefix()) > 30 ) {
3349             $self->position($self->prefix . "$line):\n$line:\t" . $self->_curr_line . $self->after);
3350             $self->prefix("");
3351             $self->infix(":\t");
3352         }
3353         else {
3354             $self->infix("):\t");
3355             $self->position(
3356                 $self->prefix . $line. $self->infix
3357                 . $self->_curr_line . $self->after
3358             );
3359         }
3360
3361         # Print current line info, indenting if necessary.
3362         $self->_my_print_lineinfo($line, $self->position);
3363
3364         my $i;
3365         my $line_i = sub { return $DB::dbline[$i]; };
3366
3367         # Scan forward, stopping at either the end or the next
3368         # unbreakable line.
3369         for ( $i = $line + 1 ; $i <= $DB::max && $line_i->() == 0 ; ++$i )
3370         {    #{ vi
3371
3372             # Drop out on null statements, block closers, and comments.
3373             last if $line_i->() =~ /^\s*[\;\}\#\n]/;
3374
3375             # Drop out if the user interrupted us.
3376             last if $signal;
3377
3378             # Append a newline if the line doesn't have one. Can happen
3379             # in eval'ed text, for instance.
3380             $self->after( $line_i->() =~ /\n$/ ? '' : "\n" );
3381
3382             # Next executable line.
3383             my $incr_pos = $self->prefix . $i . $self->infix . $line_i->()
3384                 . $self->after;
3385             $self->append_to_position($incr_pos);
3386             $self->_my_print_lineinfo($i, $incr_pos);
3387         } ## end for ($i = $line + 1 ; $i...
3388     } ## end else [ if ($slave_editor)
3389
3390     return;
3391 }
3392
3393 sub _handle_t_command {
3394     my $self = shift;
3395
3396     my $levels = $self->cmd_args();
3397
3398     if ((!length($levels)) or ($levels !~ /\D/)) {
3399         $trace ^= 1;
3400         local $\ = '';
3401         $DB::trace_to_depth = $levels ? $stack_depth + $levels : 1E9;
3402         print {$OUT} "Trace = "
3403         . ( ( $trace & 1 )
3404             ? ( $levels ? "on (to level $DB::trace_to_depth)" : "on" )
3405             : "off" ) . "\n";
3406         next CMD;
3407     }
3408
3409     return;
3410 }
3411
3412
3413 sub _handle_S_command {
3414     my $self = shift;
3415
3416     if (my ($print_all_subs, $should_reverse, $Spatt)
3417         = $self->cmd_args =~ /\A((!)?(.+))?\z/) {
3418         # $Spatt is the pattern (if any) to use.
3419         # Reverse scan?
3420         my $Srev     = defined $should_reverse;
3421         # No args - print all subs.
3422         my $Snocheck = !defined $print_all_subs;
3423
3424         # Need to make these sane here.
3425         local $\ = '';
3426         local $, = '';
3427
3428         # Search through the debugger's magical hash of subs.
3429         # If $nocheck is true, just print the sub name.
3430         # Otherwise, check it against the pattern. We then use
3431         # the XOR trick to reverse the condition as required.
3432         foreach $subname ( sort( keys %sub ) ) {
3433             if ( $Snocheck or $Srev ^ ( $subname =~ /$Spatt/ ) ) {
3434                 print $OUT $subname, "\n";
3435             }
3436         }
3437         next CMD;
3438     }
3439
3440     return;
3441 }
3442
3443 sub _handle_V_command_and_X_command {
3444     my $self = shift;
3445
3446     $DB::cmd =~ s/^X\b/V $DB::package/;
3447
3448     # Bare V commands get the currently-being-debugged package
3449     # added.
3450     if ($self->_is_full('V')) {
3451         $DB::cmd = "V $DB::package";
3452     }
3453
3454     # V - show variables in package.
3455     if (my ($new_packname, $new_vars_str) =
3456         $DB::cmd =~ /\AV\b\s*(\S+)\s*(.*)/) {
3457
3458         # Save the currently selected filehandle and
3459         # force output to debugger's filehandle (dumpvar
3460         # just does "print" for output).
3461         my $savout = select($OUT);
3462
3463         # Grab package name and variables to dump.
3464         $packname = $new_packname;
3465         my @vars     = split( ' ', $new_vars_str );
3466
3467         # If main::dumpvar isn't here, get it.
3468         do 'dumpvar.pl' || die $@ unless defined &main::dumpvar;
3469         if ( defined &main::dumpvar ) {
3470
3471             # We got it. Turn off subroutine entry/exit messages
3472             # for the moment, along with return values.
3473             local $frame = 0;
3474             local $doret = -2;
3475
3476             # must detect sigpipe failures  - not catching
3477             # then will cause the debugger to die.
3478             eval {
3479                 main::dumpvar(
3480                     $packname,
3481                     defined $option{dumpDepth}
3482                     ? $option{dumpDepth}
3483                     : -1,    # assume -1 unless specified
3484                     @vars
3485                 );
3486             };
3487
3488             # The die doesn't need to include the $@, because
3489             # it will automatically get propagated for us.
3490             if ($@) {
3491                 die unless $@ =~ /dumpvar print failed/;
3492             }
3493         } ## end if (defined &main::dumpvar)
3494         else {
3495
3496             # Couldn't load dumpvar.
3497             print $OUT "dumpvar.pl not available.\n";
3498         }
3499
3500         # Restore the output filehandle, and go round again.
3501         select($savout);
3502         next CMD;
3503     }
3504
3505     return;
3506 }
3507
3508 sub _handle_dash_command {
3509     my $self = shift;
3510
3511     if ($self->_is_full('-')) {
3512
3513         # back up by a window; go to 1 if back too far.
3514         $start -= $incr + $window + 1;
3515         $start = 1 if $start <= 0;
3516         $incr  = $window - 1;
3517
3518         # Generate and execute a "l +" command (handled below).
3519         $DB::cmd = 'l ' . ($start) . '+';
3520         redo CMD;
3521     }
3522     return;
3523 }
3524
3525 sub _n_or_s_commands_generic {
3526     my ($self, $new_val) = @_;
3527     # n - next
3528     next CMD if DB::_DB__is_finished();
3529
3530     # Single step, but don't enter subs.
3531     $single = $new_val;
3532
3533     # Save for empty command (repeat last).
3534     $laststep = $DB::cmd;
3535     last CMD;
3536 }
3537
3538 sub _n_or_s {
3539     my ($self, $letter, $new_val) = @_;
3540
3541     if ($self->_is_full($letter)) {
3542         $self->_n_or_s_commands_generic($new_val);
3543     }
3544     else {
3545         $self->_n_or_s_and_arg_commands_generic($letter, $new_val);
3546     }
3547
3548     return;
3549 }
3550
3551 sub _handle_n_command {
3552     my $self = shift;
3553
3554     return $self->_n_or_s('n', 2);
3555 }
3556
3557 sub _handle_s_command {
3558     my $self = shift;
3559
3560     return $self->_n_or_s('s', 1);
3561 }
3562
3563 sub _handle_r_command {
3564     my $self = shift;
3565
3566     # r - return from the current subroutine.
3567     if ($self->_is_full('r')) {
3568
3569         # Can't do anything if the program's over.
3570         next CMD if DB::_DB__is_finished();
3571
3572         # Turn on stack trace.
3573         $stack[$stack_depth] |= 1;
3574
3575         # Print return value unless the stack is empty.
3576         $doret = $option{PrintRet} ? $stack_depth - 1 : -2;
3577         last CMD;
3578     }
3579
3580     return;
3581 }
3582
3583 sub _handle_T_command {
3584     my $self = shift;
3585
3586     if ($self->_is_full('T')) {
3587         DB::print_trace( $OUT, 1 );    # skip DB
3588         next CMD;
3589     }
3590
3591     return;
3592 }
3593
3594 sub _handle_w_command {
3595     my $self = shift;
3596
3597     DB::cmd_w( 'w', $self->cmd_args() );
3598     next CMD;
3599
3600     return;
3601 }
3602
3603 sub _handle_W_command {
3604     my $self = shift;
3605
3606     if (my $arg = $self->cmd_args) {
3607         DB::cmd_W( 'W', $arg );
3608         next CMD;
3609     }
3610
3611     return;
3612 }
3613
3614 sub _handle_rc_recall_command {
3615     my $self = shift;
3616
3617     # $rc - recall command.
3618     if (my ($minus, $arg) = $DB::cmd =~ m#\A$rc+\s*(-)?(\d+)?\z#) {
3619
3620         # No arguments, take one thing off history.
3621         pop(@hist) if length($DB::cmd) > 1;
3622
3623         # Relative (- found)?
3624         #  Y - index back from most recent (by 1 if bare minus)
3625         #  N - go to that particular command slot or the last
3626         #      thing if nothing following.
3627
3628         $self->cmd_verb(
3629             scalar($minus ? ( $#hist - ( $arg || 1 ) ) : ( $arg || $#hist ))
3630         );
3631
3632         # Pick out the command desired.
3633         $DB::cmd = $hist[$self->cmd_verb];
3634
3635         # Print the command to be executed and restart the loop
3636         # with that command in the buffer.
3637         print {$OUT} $DB::cmd, "\n";
3638         redo CMD;
3639     }
3640
3641     return;
3642 }
3643
3644 sub _handle_rc_search_history_command {
3645     my $self = shift;
3646
3647     # $rc pattern $rc - find a command in the history.
3648     if (my ($arg) = $DB::cmd =~ /\A$rc([^$rc].*)\z/) {
3649
3650         # Create the pattern to use.
3651         my $pat = "^$arg";
3652         $self->pat($pat);
3653
3654         # Toss off last entry if length is >1 (and it always is).
3655         pop(@hist) if length($DB::cmd) > 1;
3656
3657         my $i;
3658
3659         # Look backward through the history.
3660         SEARCH_HIST:
3661         for ( $i = $#hist ; $i ; --$i ) {
3662             # Stop if we find it.
3663             last SEARCH_HIST if $hist[$i] =~ /$pat/;
3664         }
3665
3666         if ( !$i ) {
3667
3668             # Never found it.
3669             print $OUT "No such command!\n\n";
3670             next CMD;
3671         }
3672
3673         # Found it. Put it in the buffer, print it, and process it.
3674         $DB::cmd = $hist[$i];
3675         print $OUT $DB::cmd, "\n";
3676         redo CMD;
3677     }
3678
3679     return;
3680 }
3681
3682 sub _handle_H_command {
3683     my $self = shift;
3684
3685     if ($self->cmd_args =~ m#\A\*#) {
3686         @hist = @truehist = ();
3687         print $OUT "History cleansed\n";
3688         next CMD;
3689     }
3690
3691     if (my ($num) = $self->cmd_args =~ /\A(?:-(\d+))?/) {
3692
3693         # Anything other than negative numbers is ignored by
3694         # the (incorrect) pattern, so this test does nothing.
3695         $end = $num ? ( $#hist - $num ) : 0;
3696
3697         # Set to the minimum if less than zero.
3698         $hist = 0 if $hist < 0;
3699
3700         # Start at the end of the array.
3701         # Stay in while we're still above the ending value.
3702         # Tick back by one each time around the loop.
3703         my $i;
3704
3705         for ( $i = $#hist ; $i > $end ; $i-- ) {
3706
3707             # Print the command  unless it has no arguments.
3708             print $OUT "$i: ", $hist[$i], "\n"
3709             unless $hist[$i] =~ /^.?$/;
3710         }
3711
3712         next CMD;
3713     }
3714
3715     return;
3716 }
3717
3718 sub _handle_doc_command {
3719     my $self = shift;
3720
3721     # man, perldoc, doc - show manual pages.
3722     if (my ($man_page)
3723         = $DB::cmd =~ /\A(?:man|(?:perl)?doc)\b(?:\s+([^(]*))?\z/) {
3724         DB::runman($man_page);
3725         next CMD;
3726     }
3727
3728     return;
3729 }
3730
3731 sub _handle_p_command {
3732     my $self = shift;
3733
3734     my $print_cmd = 'print {$DB::OUT} ';
3735     # p - print (no args): print $_.
3736     if ($self->_is_full('p')) {
3737         $DB::cmd = $print_cmd . '$_';
3738     }
3739     else {
3740         # p - print the given expression.
3741         $DB::cmd =~ s/\Ap\b/$print_cmd /;
3742     }
3743
3744     return;
3745 }
3746
3747 sub _handle_equal_sign_command {
3748     my $self = shift;
3749
3750     if ($DB::cmd =~ s/\A=\s*//) {
3751         my @keys;
3752         if ( length $DB::cmd == 0 ) {
3753
3754             # No args, get current aliases.
3755             @keys = sort keys %alias;
3756         }
3757         elsif ( my ( $k, $v ) = ( $DB::cmd =~ /^(\S+)\s+(\S.*)/ ) ) {
3758
3759             # Creating a new alias. $k is alias name, $v is
3760             # alias value.
3761
3762             # can't use $_ or kill //g state
3763             for my $x ( $k, $v ) {
3764
3765                 # Escape "alarm" characters.
3766                 $x =~ s/\a/\\a/g;
3767             }
3768
3769             # Substitute key for value, using alarm chars
3770             # as separators (which is why we escaped them in
3771             # the command).
3772             $alias{$k} = "s\a$k\a$v\a";
3773
3774             # Turn off standard warn and die behavior.
3775             local $SIG{__DIE__};
3776             local $SIG{__WARN__};
3777
3778             # Is it valid Perl?
3779             unless ( eval "sub { s\a$k\a$v\a }; 1" ) {
3780
3781                 # Nope. Bad alias. Say so and get out.
3782                 print $OUT "Can't alias $k to $v: $@\n";
3783                 delete $alias{$k};
3784                 next CMD;
3785             }
3786
3787             # We'll only list the new one.
3788             @keys = ($k);
3789         } ## end elsif (my ($k, $v) = ($DB::cmd...
3790
3791         # The argument is the alias to list.
3792         else {
3793             @keys = ($DB::cmd);
3794         }
3795
3796         # List aliases.
3797         for my $k (@keys) {
3798
3799             # Messy metaquoting: Trim the substitution code off.
3800             # We use control-G as the delimiter because it's not
3801             # likely to appear in the alias.
3802             if ( ( my $v = $alias{$k} ) =~ s\as\a$k\a(.*)\a$\a1\a ) {
3803
3804                 # Print the alias.
3805                 print $OUT "$k\t= $1\n";
3806             }
3807             elsif ( defined $alias{$k} ) {
3808
3809                 # Couldn't trim it off; just print the alias code.
3810                 print $OUT "$k\t$alias{$k}\n";
3811             }
3812             else {
3813
3814                 # No such, dude.
3815                 print "No alias for $k\n";
3816             }
3817         } ## end for my $k (@keys)
3818         next CMD;
3819     }
3820
3821     return;
3822 }
3823
3824 sub _handle_source_command {
3825     my $self = shift;
3826
3827     # source - read commands from a file (or pipe!) and execute.
3828     if (my $sourced_fn = $self->cmd_args) {
3829         if ( open my $fh, $sourced_fn ) {
3830
3831             # Opened OK; stick it in the list of file handles.
3832             push @cmdfhs, $fh;
3833         }
3834         else {
3835
3836             # Couldn't open it.
3837             DB::_db_warn("Can't execute '$sourced_fn': $!\n");
3838         }
3839         next CMD;
3840     }
3841
3842     return;
3843 }
3844
3845 sub _handle_enable_disable_commands {
3846     my $self = shift;
3847
3848     my $which_cmd = $self->cmd_verb;
3849     my $position = $self->cmd_args;
3850
3851     if ($position !~ /\s/) {
3852         my ($fn, $line_num);
3853         if ($position =~ m{\A\d+\z})
3854         {
3855             $fn = $DB::filename;
3856             $line_num = $position;
3857         }
3858         elsif (my ($new_fn, $new_line_num)
3859             = $position =~ m{\A(.*):(\d+)\z}) {
3860             ($fn, $line_num) = ($new_fn, $new_line_num);
3861         }
3862         else
3863         {
3864             DB::_db_warn("Wrong spec for enable/disable argument.\n");
3865         }
3866
3867         if (defined($fn)) {
3868             if (DB::_has_breakpoint_data_ref($fn, $line_num)) {
3869                 DB::_set_breakpoint_enabled_status($fn, $line_num,
3870                     ($which_cmd eq 'enable' ? 1 : '')
3871                 );
3872             }
3873             else {
3874                 DB::_db_warn("No breakpoint set at ${fn}:${line_num}\n");
3875             }
3876         }
3877
3878         next CMD;
3879     }
3880
3881     return;
3882 }
3883
3884 sub _handle_save_command {
3885     my $self = shift;
3886
3887     if (my $new_fn = $self->cmd_args) {
3888         my $filename = $new_fn || '.perl5dbrc';    # default?
3889         if ( open my $fh, '>', $filename ) {
3890
3891             # chomp to remove extraneous newlines from source'd files
3892             chomp( my @truelist =
3893                 map { m/\A\s*(save|source)/ ? "#$_" : $_ }
3894                 @truehist );
3895             print {$fh} join( "\n", @truelist );
3896             print "commands saved in $filename\n";
3897         }
3898         else {
3899             DB::_db_warn("Can't save debugger commands in '$new_fn': $!\n");
3900         }
3901         next CMD;
3902     }
3903
3904     return;
3905 }
3906
3907 sub _n_or_s_and_arg_commands_generic {
3908     my ($self, $letter, $new_val) = @_;
3909
3910     # s - single-step. Remember the last command was 's'.
3911     if ($DB::cmd =~ s#\A\Q$letter\E\s#\$DB::single = $new_val;\n#) {
3912         $laststep = $letter;
3913     }
3914
3915     return;
3916 }
3917
3918 sub _handle_sh_command {
3919     my $self = shift;
3920
3921     # $sh$sh - run a shell command (if it's all ASCII).
3922     # Can't run shell commands with Unicode in the debugger, hmm.
3923     my $my_cmd = $DB::cmd;
3924     if ($my_cmd =~ m#\A$sh#gms) {
3925
3926         if ($my_cmd =~ m#\G\z#cgms) {
3927             # Run the user's shell. If none defined, run Bourne.
3928             # We resume execution when the shell terminates.
3929             DB::_db_system( $ENV{SHELL} || "/bin/sh" );
3930             next CMD;
3931         }
3932         elsif ($my_cmd =~ m#\G$sh\s*(.*)#cgms) {
3933             # System it.
3934             DB::_db_system($1);
3935             next CMD;
3936         }
3937         elsif ($my_cmd =~ m#\G\s*(.*)#cgms) {
3938             DB::_db_system( $ENV{SHELL} || "/bin/sh", "-c", $1 );
3939             next CMD;
3940         }
3941     }
3942 }
3943
3944 sub _handle_x_command {
3945     my $self = shift;
3946
3947     if ($DB::cmd =~ s#\Ax\b# #) {    # Remainder gets done by DB::eval()
3948         $onetimeDump = 'dump';    # main::dumpvar shows the output
3949
3950         # handle special  "x 3 blah" syntax XXX propagate
3951         # doc back to special variables.
3952         if ( $DB::cmd =~ s#\A\s*(\d+)(?=\s)# #) {
3953             $onetimedumpDepth = $1;
3954         }
3955     }
3956
3957     return;
3958 }
3959
3960 sub _handle_q_command {
3961     my $self = shift;
3962
3963     if ($self->_is_full('q')) {
3964         $fall_off_end = 1;
3965         DB::clean_ENV();
3966         exit $?;
3967     }
3968
3969     return;
3970 }
3971
3972 sub _handle_cmd_wrapper_commands {
3973     my $self = shift;
3974
3975     DB::cmd_wrapper( $self->cmd_verb, $self->cmd_args, $line );
3976     next CMD;
3977 }
3978
3979 sub _handle_special_char_cmd_wrapper_commands {
3980     my $self = shift;
3981
3982     # All of these commands were remapped in perl 5.8.0;
3983     # we send them off to the secondary dispatcher (see below).
3984     if (my ($cmd_letter, $my_arg) = $DB::cmd =~ /\A([<>\{]{1,2})\s*(.*)/so) {
3985         DB::cmd_wrapper( $cmd_letter, $my_arg, $line );
3986         next CMD;
3987     }
3988
3989     return;
3990 }
3991
3992 } ## end DB::Obj
3993
3994 package DB;
3995
3996 # The following code may be executed now:
3997 # BEGIN {warn 4}
3998
3999 =head2 sub
4000
4001 C<sub> is called whenever a subroutine call happens in the program being
4002 debugged. The variable C<$DB::sub> contains the name of the subroutine
4003 being called.
4004
4005 The core function of this subroutine is to actually call the sub in the proper
4006 context, capturing its output. This of course causes C<DB::DB> to get called
4007 again, repeating until the subroutine ends and returns control to C<DB::sub>
4008 again. Once control returns, C<DB::sub> figures out whether or not to dump the
4009 return value, and returns its captured copy of the return value as its own
4010 return value. The value then feeds back into the program being debugged as if
4011 C<DB::sub> hadn't been there at all.
4012
4013 C<sub> does all the work of printing the subroutine entry and exit messages
4014 enabled by setting C<$frame>. It notes what sub the autoloader got called for,
4015 and also prints the return value if needed (for the C<r> command and if
4016 the 16 bit is set in C<$frame>).
4017
4018 It also tracks the subroutine call depth by saving the current setting of
4019 C<$single> in the C<@stack> package global; if this exceeds the value in
4020 C<$deep>, C<sub> automatically turns on printing of the current depth by
4021 setting the C<4> bit in C<$single>. In any case, it keeps the current setting
4022 of stop/don't stop on entry to subs set as it currently is set.
4023
4024 =head3 C<caller()> support
4025
4026 If C<caller()> is called from the package C<DB>, it provides some
4027 additional data, in the following order:
4028
4029 =over 4
4030
4031 =item * C<$package>
4032
4033 The package name the sub was in
4034
4035 =item * C<$filename>
4036
4037 The filename it was defined in
4038
4039 =item * C<$line>
4040
4041 The line number it was defined on
4042
4043 =item * C<$subroutine>
4044
4045 The subroutine name; C<(eval)> if an C<eval>().
4046
4047 =item * C<$hasargs>
4048
4049 1 if it has arguments, 0 if not
4050
4051 =item * C<$wantarray>
4052
4053 1 if array context, 0 if scalar context
4054
4055 =item * C<$evaltext>
4056
4057 The C<eval>() text, if any (undefined for C<eval BLOCK>)
4058
4059 =item * C<$is_require>
4060
4061 frame was created by a C<use> or C<require> statement
4062
4063 =item * C<$hints>
4064
4065 pragma information; subject to change between versions
4066
4067 =item * C<$bitmask>
4068
4069 pragma information; subject to change between versions
4070
4071 =item * C<@DB::args>
4072
4073 arguments with which the subroutine was invoked
4074
4075 =back
4076
4077 =cut
4078
4079 use vars qw($deep);
4080
4081 # We need to fully qualify the name ("DB::sub") to make "use strict;"
4082 # happy. -- Shlomi Fish
4083
4084 sub _indent_print_line_info {
4085     my ($offset, $str) = @_;
4086
4087     print_lineinfo( ' ' x ($stack_depth - $offset), $str);
4088
4089     return;
4090 }
4091
4092 sub _print_frame_message {
4093     my ($al) = @_;
4094
4095     if ($frame) {
4096         if ($frame & 4) {   # Extended frame entry message
4097             _indent_print_line_info(-1, "in  ");
4098
4099             # Why -1? But it works! :-(
4100             # Because print_trace will call add 1 to it and then call
4101             # dump_trace; this results in our skipping -1+1 = 0 stack frames
4102             # in dump_trace.
4103             #
4104             # Now it's 0 because we extracted a function.
4105             print_trace( $LINEINFO, 0, 1, 1, "$sub$al" );
4106         }
4107         else {
4108             _indent_print_line_info(-1, "entering $sub$al\n" );
4109         }
4110     }
4111
4112     return;
4113 }
4114
4115 sub DB::sub {
4116     # lock ourselves under threads
4117     lock($DBGR);
4118
4119     # Whether or not the autoloader was running, a scalar to put the
4120     # sub's return value in (if needed), and an array to put the sub's
4121     # return value in (if needed).
4122     my ( $al, $ret, @ret ) = "";
4123     if ($sub eq 'threads::new' && $ENV{PERL5DB_THREADED}) {
4124         print "creating new thread\n";
4125     }
4126
4127     # If the last ten characters are '::AUTOLOAD', note we've traced
4128     # into AUTOLOAD for $sub.
4129     if ( length($sub) > 10 && substr( $sub, -10, 10 ) eq '::AUTOLOAD' ) {
4130         no strict 'refs';
4131         $al = " for $$sub" if defined $$sub;
4132     }
4133
4134     # We stack the stack pointer and then increment it to protect us
4135     # from a situation that might unwind a whole bunch of call frames
4136     # at once. Localizing the stack pointer means that it will automatically
4137     # unwind the same amount when multiple stack frames are unwound.
4138     local $stack_depth = $stack_depth + 1;    # Protect from non-local exits
4139
4140     # Expand @stack.
4141     $#stack = $stack_depth;
4142
4143     # Save current single-step setting.
4144     $stack[-1] = $single;
4145
4146     # Turn off all flags except single-stepping.
4147     $single &= 1;
4148
4149     # If we've gotten really deeply recursed, turn on the flag that will
4150     # make us stop with the 'deep recursion' message.
4151     $single |= 4 if $stack_depth == $deep;
4152
4153     # If frame messages are on ...
4154
4155     _print_frame_message($al);
4156     # standard frame entry message
4157
4158     my $print_exit_msg = sub {
4159         # Check for exit trace messages...
4160         if ($frame & 2)
4161         {
4162             if ($frame & 4)    # Extended exit message
4163             {
4164                 _indent_print_line_info(0, "out ");
4165                 print_trace( $LINEINFO, 0, 1, 1, "$sub$al" );
4166             }
4167             else
4168             {
4169                 _indent_print_line_info(0, "exited $sub$al\n" );
4170             }
4171         }
4172         return;
4173     };
4174
4175     # Determine the sub's return type, and capture appropriately.
4176     if (wantarray) {
4177
4178         # Called in array context. call sub and capture output.
4179         # DB::DB will recursively get control again if appropriate; we'll come
4180         # back here when the sub is finished.
4181         {
4182             no strict 'refs';
4183             @ret = &$sub;
4184         }
4185
4186         # Pop the single-step value back off the stack.
4187         $single |= $stack[ $stack_depth-- ];
4188
4189         $print_exit_msg->();
4190
4191         # Print the return info if we need to.
4192         if ( $doret eq $stack_depth or $frame & 16 ) {
4193
4194             # Turn off output record separator.
4195             local $\ = '';
4196             my $fh = ( $doret eq $stack_depth ? $OUT : $LINEINFO );
4197
4198             # Indent if we're printing because of $frame tracing.
4199             if ($frame & 16)
4200             {
4201                 print {$fh} ' ' x $stack_depth;
4202             }
4203
4204             # Print the return value.
4205             print {$fh} "list context return from $sub:\n";
4206             dumpit( $fh, \@ret );
4207
4208             # And don't print it again.
4209             $doret = -2;
4210         } ## end if ($doret eq $stack_depth...
4211             # And we have to return the return value now.
4212         @ret;
4213     } ## end if (wantarray)
4214
4215     # Scalar context.
4216     else {
4217         if ( defined wantarray ) {
4218             no strict 'refs';
4219             # Save the value if it's wanted at all.
4220             $ret = &$sub;
4221         }
4222         else {
4223             no strict 'refs';
4224             # Void return, explicitly.
4225             &$sub;
4226             undef $ret;
4227         }
4228
4229         # Pop the single-step value off the stack.
4230         $single |= $stack[ $stack_depth-- ];
4231
4232         # If we're doing exit messages...
4233         $print_exit_msg->();
4234
4235         # If we are supposed to show the return value... same as before.
4236         if ( $doret eq $stack_depth or $frame & 16 and defined wantarray ) {
4237             local $\ = '';
4238             my $fh = ( $doret eq $stack_depth ? $OUT : $LINEINFO );
4239             print $fh ( ' ' x $stack_depth ) if $frame & 16;
4240             print $fh (
4241                 defined wantarray
4242                 ? "scalar context return from $sub: "
4243                 : "void context return from $sub\n"
4244             );
4245             dumpit( $fh, $ret ) if defined wantarray;
4246             $doret = -2;
4247         } ## end if ($doret eq $stack_depth...
4248
4249         # Return the appropriate scalar value.
4250         $ret;
4251     } ## end else [ if (wantarray)
4252 } ## end sub _sub
4253
4254 sub lsub : lvalue {
4255
4256     no strict 'refs';
4257
4258     # lock ourselves under threads
4259     lock($DBGR);
4260
4261     # Whether or not the autoloader was running, a scalar to put the
4262     # sub's return value in (if needed), and an array to put the sub's
4263     # return value in (if needed).
4264     my ( $al, $ret, @ret ) = "";
4265     if ($sub =~ /^threads::new$/ && $ENV{PERL5DB_THREADED}) {
4266         print "creating new thread\n";
4267     }
4268
4269     # If the last ten characters are C'::AUTOLOAD', note we've traced
4270     # into AUTOLOAD for $sub.
4271     if ( length($sub) > 10 && substr( $sub, -10, 10 ) eq '::AUTOLOAD' ) {
4272         $al = " for $$sub";
4273     }
4274
4275     # We stack the stack pointer and then increment it to protect us
4276     # from a situation that might unwind a whole bunch of call frames
4277     # at once. Localizing the stack pointer means that it will automatically
4278     # unwind the same amount when multiple stack frames are unwound.
4279     local $stack_depth = $stack_depth + 1;    # Protect from non-local exits
4280
4281     # Expand @stack.
4282     $#stack = $stack_depth;
4283
4284     # Save current single-step setting.
4285     $stack[-1] = $single;
4286
4287     # Turn off all flags except single-stepping.
4288     # Use local so the single-step value is popped back off the
4289     # stack for us.
4290     local $single = $single & 1;
4291
4292     # If we've gotten really deeply recursed, turn on the flag that will
4293     # make us stop with the 'deep recursion' message.
4294     $single |= 4 if $stack_depth == $deep;
4295
4296     # If frame messages are on ...
4297     _print_frame_message($al);
4298
4299     # call the original lvalue sub.
4300     &$sub;
4301 }
4302
4303 # Abstracting common code from multiple places elsewhere:
4304 sub depth_print_lineinfo {
4305     my $always_print = shift;
4306
4307     print_lineinfo( @_ ) if ($always_print or $stack_depth < $trace_to_depth);
4308 }
4309
4310 =head1 EXTENDED COMMAND HANDLING AND THE COMMAND API
4311
4312 In Perl 5.8.0, there was a major realignment of the commands and what they did,
4313 Most of the changes were to systematize the command structure and to eliminate
4314 commands that threw away user input without checking.
4315
4316 The following sections describe the code added to make it easy to support
4317 multiple command sets with conflicting command names. This section is a start
4318 at unifying all command processing to make it simpler to develop commands.
4319
4320 Note that all the cmd_[a-zA-Z] subroutines require the command name, a line
4321 number, and C<$dbline> (the current line) as arguments.
4322
4323 Support functions in this section which have multiple modes of failure C<die>
4324 on error; the rest simply return a false value.
4325
4326 The user-interface functions (all of the C<cmd_*> functions) just output
4327 error messages.
4328
4329 =head2 C<%set>
4330
4331 The C<%set> hash defines the mapping from command letter to subroutine
4332 name suffix.
4333
4334 C<%set> is a two-level hash, indexed by set name and then by command name.
4335 Note that trying to set the CommandSet to C<foobar> simply results in the
4336 5.8.0 command set being used, since there's no top-level entry for C<foobar>.
4337
4338 =cut
4339
4340 ### The API section
4341
4342 my %set = (    #
4343     'pre580' => {
4344         'a' => 'pre580_a',
4345         'A' => 'pre580_null',
4346         'b' => 'pre580_b',
4347         'B' => 'pre580_null',
4348         'd' => 'pre580_null',
4349         'D' => 'pre580_D',
4350         'h' => 'pre580_h',
4351         'M' => 'pre580_null',
4352         'O' => 'o',
4353         'o' => 'pre580_null',
4354         'v' => 'M',
4355         'w' => 'v',
4356         'W' => 'pre580_W',
4357     },
4358     'pre590' => {
4359         '<'  => 'pre590_prepost',
4360         '<<' => 'pre590_prepost',
4361         '>'  => 'pre590_prepost',
4362         '>>' => 'pre590_prepost',
4363         '{'  => 'pre590_prepost',
4364         '{{' => 'pre590_prepost',
4365     },
4366 );
4367
4368 my %breakpoints_data;
4369
4370 sub _has_breakpoint_data_ref {
4371     my ($filename, $line) = @_;
4372
4373     return (
4374         exists( $breakpoints_data{$filename} )
4375             and
4376         exists( $breakpoints_data{$filename}{$line} )
4377     );
4378 }
4379
4380 sub _get_breakpoint_data_ref {
4381     my ($filename, $line) = @_;
4382
4383     return ($breakpoints_data{$filename}{$line} ||= +{});
4384 }
4385
4386 sub _delete_breakpoint_data_ref {
4387     my ($filename, $line) = @_;
4388
4389     delete($breakpoints_data{$filename}{$line});
4390     if (! scalar(keys( %{$breakpoints_data{$filename}} )) ) {
4391         delete($breakpoints_data{$filename});
4392     }
4393
4394     return;
4395 }
4396
4397 sub _set_breakpoint_enabled_status {
4398     my ($filename, $line, $status) = @_;
4399
4400     _get_breakpoint_data_ref($filename, $line)->{'enabled'} =
4401         ($status ? 1 : '')
4402         ;
4403
4404     return;
4405 }
4406
4407 sub _enable_breakpoint_temp_enabled_status {
4408     my ($filename, $line) = @_;
4409
4410     _get_breakpoint_data_ref($filename, $line)->{'temp_enabled'} = 1;
4411
4412     return;
4413 }
4414
4415 sub _cancel_breakpoint_temp_enabled_status {
4416     my ($filename, $line) = @_;
4417
4418     my $ref = _get_breakpoint_data_ref($filename, $line);
4419
4420     delete ($ref->{'temp_enabled'});
4421
4422     if (! %$ref) {
4423         _delete_breakpoint_data_ref($filename, $line);
4424     }
4425
4426     return;
4427 }
4428
4429 sub _is_breakpoint_enabled {
4430     my ($filename, $line) = @_;
4431
4432     my $data_ref = _get_breakpoint_data_ref($filename, $line);
4433     return ($data_ref->{'enabled'} || $data_ref->{'temp_enabled'});
4434 }
4435
4436 =head2 C<cmd_wrapper()> (API)
4437
4438 C<cmd_wrapper()> allows the debugger to switch command sets
4439 depending on the value of the C<CommandSet> option.
4440
4441 It tries to look up the command in the C<%set> package-level I<lexical>
4442 (which means external entities can't fiddle with it) and create the name of
4443 the sub to call based on the value found in the hash (if it's there). I<All>
4444 of the commands to be handled in a set have to be added to C<%set>; if they
4445 aren't found, the 5.8.0 equivalent is called (if there is one).
4446
4447 This code uses symbolic references.
4448
4449 =cut
4450
4451 sub cmd_wrapper {
4452     my $cmd      = shift;
4453     my $line     = shift;
4454     my $dblineno = shift;
4455
4456     # Assemble the command subroutine's name by looking up the
4457     # command set and command name in %set. If we can't find it,
4458     # default to the older version of the command.
4459     my $call = 'cmd_'
4460       . ( $set{$CommandSet}{$cmd}
4461           || ( $cmd =~ /\A[<>{]+/o ? 'prepost' : $cmd ) );
4462
4463     # Call the command subroutine, call it by name.
4464     return __PACKAGE__->can($call)->( $cmd, $line, $dblineno );
4465 } ## end sub cmd_wrapper
4466
4467 =head3 C<cmd_a> (command)
4468
4469 The C<a> command handles pre-execution actions. These are associated with a
4470 particular line, so they're stored in C<%dbline>. We default to the current
4471 line if none is specified.
4472
4473 =cut
4474
4475 sub cmd_a {
4476     my $cmd    = shift;
4477     my $line   = shift || '';    # [.|line] expr
4478     my $dbline = shift;
4479
4480     # If it's dot (here), or not all digits,  use the current line.
4481     $line =~ s/\A\./$dbline/;
4482
4483     # Should be a line number followed by an expression.
4484     if ( my ($lineno, $expr) = $line =~ /^\s*(\d*)\s*(\S.+)/ ) {
4485
4486         if (! length($lineno)) {
4487             $lineno = $dbline;
4488         }
4489
4490         # If we have an expression ...
4491         if ( length $expr ) {
4492
4493             # ... but the line isn't breakable, complain.
4494             if ( $dbline[$lineno] == 0 ) {
4495                 print $OUT
4496                   "Line $lineno($dbline[$lineno]) does not have an action?\n";
4497             }
4498             else {
4499
4500                 # It's executable. Record that the line has an action.
4501                 $had_breakpoints{$filename} |= 2;
4502
4503                 # Remove any action, temp breakpoint, etc.
4504                 $dbline{$lineno} =~ s/\0[^\0]*//;
4505
4506                 # Add the action to the line.
4507                 $dbline{$lineno} .= "\0" . action($expr);
4508
4509                 _set_breakpoint_enabled_status($filename, $lineno, 1);
4510             }
4511         } ## end if (length $expr)
4512     } ## end if ($line =~ /^\s*(\d*)\s*(\S.+)/)
4513     else {
4514
4515         # Syntax wrong.
4516         print $OUT
4517           "Adding an action requires an optional lineno and an expression\n"
4518           ;    # hint
4519     }
4520 } ## end sub cmd_a
4521
4522 =head3 C<cmd_A> (command)
4523
4524 Delete actions. Similar to above, except the delete code is in a separate
4525 subroutine, C<delete_action>.
4526
4527 =cut
4528
4529 sub cmd_A {
4530     my $cmd    = shift;
4531     my $line   = shift || '';
4532     my $dbline = shift;
4533
4534     # Dot is this line.
4535     $line =~ s/^\./$dbline/;
4536
4537     # Call delete_action with a null param to delete them all.
4538     # The '1' forces the eval to be true. It'll be false only
4539     # if delete_action blows up for some reason, in which case
4540     # we print $@ and get out.
4541     if ( $line eq '*' ) {
4542         if (! eval { _delete_all_actions(); 1 }) {
4543             print {$OUT} $@;
4544             return;
4545         }
4546     }
4547
4548     # There's a real line  number. Pass it to delete_action.
4549     # Error trapping is as above.
4550     elsif ( $line =~ /^(\S.*)/ ) {
4551         if (! eval { delete_action($1); 1 }) {
4552             print {$OUT} $@;
4553             return;
4554         }
4555     }
4556
4557     # Swing and a miss. Bad syntax.
4558     else {
4559         print $OUT
4560           "Deleting an action requires a line number, or '*' for all\n" ; # hint
4561     }
4562 } ## end sub cmd_A
4563
4564 =head3 C<delete_action> (API)
4565
4566 C<delete_action> accepts either a line number or C<undef>. If a line number
4567 is specified, we check for the line being executable (if it's not, it
4568 couldn't have had an  action). If it is, we just take the action off (this
4569 will get any kind of an action, including breakpoints).
4570
4571 =cut
4572
4573 sub _remove_action_from_dbline {
4574     my $i = shift;
4575
4576     $dbline{$i} =~ s/\0[^\0]*//;    # \^a
4577     delete $dbline{$i} if $dbline{$i} eq '';
4578
4579     return;
4580 }
4581
4582 sub _delete_all_actions {
4583     print {$OUT} "Deleting all actions...\n";
4584
4585     for my $file ( keys %had_breakpoints ) {
4586         local *dbline = $main::{ '_<' . $file };
4587         $max = $#dbline;
4588         my $was;
4589         for my $i (1 .. $max) {
4590             if ( defined $dbline{$i} ) {
4591                 _remove_action_from_dbline($i);
4592             }
4593         }
4594
4595         unless ( $had_breakpoints{$file} &= ~2 ) {
4596             delete $had_breakpoints{$file};
4597         }
4598     }
4599
4600     return;
4601 }
4602
4603 sub delete_action {
4604     my $i = shift;
4605
4606     if ( defined($i) ) {
4607         # Can there be one?
4608         die "Line $i has no action .\n" if $dbline[$i] == 0;
4609
4610         # Nuke whatever's there.
4611         _remove_action_from_dbline($i);
4612     }
4613     else {
4614         _delete_all_actions();
4615     }
4616 }
4617
4618 =head3 C<cmd_b> (command)
4619
4620 Set breakpoints. Since breakpoints can be set in so many places, in so many
4621 ways, conditionally or not, the breakpoint code is kind of complex. Mostly,
4622 we try to parse the command type, and then shuttle it off to an appropriate
4623 subroutine to actually do the work of setting the breakpoint in the right
4624 place.
4625
4626 =cut
4627
4628 sub cmd_b {
4629     my $cmd    = shift;
4630     my $line   = shift;    # [.|line] [cond]
4631     my $dbline = shift;
4632
4633     my $default_cond = sub {
4634         my $cond = shift;
4635         return length($cond) ? $cond : '1';
4636     };
4637
4638     # Make . the current line number if it's there..
4639     $line =~ s/^\.(\s|\z)/$dbline$1/;
4640
4641     # No line number, no condition. Simple break on current line.
4642     if ( $line =~ /^\s*$/ ) {
4643         cmd_b_line( $dbline, 1 );
4644     }
4645
4646     # Break on load for a file.
4647     elsif ( my ($file) = $line =~ /^load\b\s*(.*)/ ) {
4648         $file =~ s/\s+\z//;
4649         cmd_b_load($file);
4650     }
4651
4652     # b compile|postpone <some sub> [<condition>]
4653     # The interpreter actually traps this one for us; we just put the
4654     # necessary condition in the %postponed hash.
4655     elsif ( my ($action, $subname, $cond)
4656         = $line =~ /^(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ ) {
4657
4658         # De-Perl4-ify the name - ' separators to ::.
4659         $subname =~ s/'/::/g;
4660
4661         # Qualify it into the current package unless it's already qualified.
4662         $subname = "${package}::" . $subname unless $subname =~ /::/;
4663
4664         # Add main if it starts with ::.
4665         $subname = "main" . $subname if substr( $subname, 0, 2 ) eq "::";
4666
4667         # Save the break type for this sub.
4668         $postponed{$subname} = (($action eq 'postpone')
4669             ? ( "break +0 if " . $default_cond->($cond) )
4670             : "compile");
4671     } ## end elsif ($line =~ ...
4672     # b <filename>:<line> [<condition>]
4673     elsif (my ($filename, $line_num, $cond)
4674         = $line =~ /\A(\S+[^:]):(\d+)\s*(.*)/ms) {
4675         cmd_b_filename_line(
4676             $filename,
4677             $line_num,
4678             (length($cond) ? $cond : '1'),
4679         );
4680     }
4681     # b <sub name> [<condition>]
4682     elsif ( my ($new_subname, $new_cond) =
4683         $line =~ /^([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/ ) {
4684
4685         #
4686         $subname = $new_subname;
4687         cmd_b_sub( $subname, $default_cond->($new_cond) );
4688     }
4689
4690     # b <line> [<condition>].
4691     elsif ( my ($line_n, $cond) = $line =~ /^(\d*)\s*(.*)/ ) {
4692
4693         # Capture the line. If none, it's the current line.
4694         $line = $line_n || $dbline;
4695
4696         # Break on line.
4697         cmd_b_line( $line, $default_cond->($cond) );
4698     }
4699
4700     # Line didn't make sense.
4701     else {
4702         print "confused by line($line)?\n";
4703     }
4704
4705     return;
4706 } ## end sub cmd_b
4707
4708 =head3 C<break_on_load> (API)
4709
4710 We want to break when this file is loaded. Mark this file in the
4711 C<%break_on_load> hash, and note that it has a breakpoint in
4712 C<%had_breakpoints>.
4713
4714 =cut
4715
4716 sub break_on_load {
4717     my $file = shift;
4718     $break_on_load{$file} = 1;
4719     $had_breakpoints{$file} |= 1;
4720 }
4721
4722 =head3 C<report_break_on_load> (API)
4723
4724 Gives us an array of filenames that are set to break on load. Note that
4725 only files with break-on-load are in here, so simply showing the keys
4726 suffices.
4727
4728 =cut
4729
4730 sub report_break_on_load {
4731     sort keys %break_on_load;
4732 }
4733
4734 =head3 C<cmd_b_load> (command)
4735
4736 We take the file passed in and try to find it in C<%INC> (which maps modules
4737 to files they came from). We mark those files for break-on-load via
4738 C<break_on_load> and then report that it was done.
4739
4740 =cut
4741
4742 sub cmd_b_load {
4743     my $file = shift;
4744     my @files;
4745
4746     # This is a block because that way we can use a redo inside it
4747     # even without there being any looping structure at all outside it.
4748     {
4749
4750         # Save short name and full path if found.
4751         push @files, $file;
4752         push @files, $::INC{$file} if $::INC{$file};
4753
4754         # Tack on .pm and do it again unless there was a '.' in the name
4755         # already.
4756         $file .= '.pm', redo unless $file =~ /\./;
4757     }
4758
4759     # Do the real work here.
4760     break_on_load($_) for @files;
4761
4762     # All the files that have break-on-load breakpoints.
4763     @files = report_break_on_load;
4764
4765     # Normalize for the purposes of our printing this.
4766     local $\ = '';
4767     local $" = ' ';
4768     print $OUT "Will stop on load of '@files'.\n";
4769 } ## end sub cmd_b_load
4770
4771 =head3 C<$filename_error> (API package global)
4772
4773 Several of the functions we need to implement in the API need to work both
4774 on the current file and on other files. We don't want to duplicate code, so
4775 C<$filename_error> is used to contain the name of the file that's being
4776 worked on (if it's not the current one).
4777
4778 We can now build functions in pairs: the basic function works on the current
4779 file, and uses C<$filename_error> as part of its error message. Since this is
4780 initialized to C<"">, no filename will appear when we are working on the
4781 current file.
4782
4783 The second function is a wrapper which does the following:
4784
4785 =over 4
4786
4787 =item *
4788
4789 Localizes C<$filename_error> and sets it to the name of the file to be processed.
4790
4791 =item *
4792
4793 Localizes the C<*dbline> glob and reassigns it to point to the file we want to process.
4794
4795 =item *
4796
4797 Calls the first function.
4798
4799 The first function works on the I<current> file (i.e., the one we changed to),
4800 and prints C<$filename_error> in the error message (the name of the other file)
4801 if it needs to. When the functions return, C<*dbline> is restored to point
4802 to the actual current file (the one we're executing in) and
4803 C<$filename_error> is restored to C<"">. This restores everything to
4804 the way it was before the second function was called at all.
4805
4806 See the comments in C<breakable_line> and C<breakable_line_in_file> for more
4807 details.
4808
4809 =back
4810
4811 =cut
4812
4813 use vars qw($filename_error);
4814 $filename_error = '';
4815
4816 =head3 breakable_line(from, to) (API)
4817
4818 The subroutine decides whether or not a line in the current file is breakable.
4819 It walks through C<@dbline> within the range of lines specified, looking for
4820 the first line that is breakable.
4821
4822 If C<$to> is greater than C<$from>, the search moves forwards, finding the
4823 first line I<after> C<$to> that's breakable, if there is one.
4824
4825 If C<$from> is greater than C<$to>, the search goes I<backwards>, finding the
4826 first line I<before> C<$to> that's breakable, if there is one.
4827
4828 =cut
4829
4830 sub breakable_line {
4831
4832     my ( $from, $to ) = @_;
4833
4834     # $i is the start point. (Where are the FORTRAN programs of yesteryear?)
4835     my $i = $from;
4836
4837     # If there are at least 2 arguments, we're trying to search a range.
4838     if ( @_ >= 2 ) {
4839
4840         # $delta is positive for a forward search, negative for a backward one.
4841         my $delta = $from < $to ? +1 : -1;
4842
4843         # Keep us from running off the ends of the file.
4844         my $limit = $delta > 0 ? $#dbline : 1;
4845
4846         # Clever test. If you're a mathematician, it's obvious why this
4847         # test works. If not:
4848         # If $delta is positive (going forward), $limit will be $#dbline.
4849         #    If $to is less than $limit, ($limit - $to) will be positive, times
4850         #    $delta of 1 (positive), so the result is > 0 and we should use $to
4851         #    as the stopping point.
4852         #
4853         #    If $to is greater than $limit, ($limit - $to) is negative,
4854         #    times $delta of 1 (positive), so the result is < 0 and we should
4855         #    use $limit ($#dbline) as the stopping point.
4856         #
4857         # If $delta is negative (going backward), $limit will be 1.
4858         #    If $to is zero, ($limit - $to) will be 1, times $delta of -1
4859         #    (negative) so the result is > 0, and we use $to as the stopping
4860         #    point.
4861         #
4862         #    If $to is less than zero, ($limit - $to) will be positive,
4863         #    times $delta of -1 (negative), so the result is not > 0, and
4864         #    we use $limit (1) as the stopping point.
4865         #
4866         #    If $to is 1, ($limit - $to) will zero, times $delta of -1
4867         #    (negative), still giving zero; the result is not > 0, and
4868         #    we use $limit (1) as the stopping point.
4869         #
4870         #    if $to is >1, ($limit - $to) will be negative, times $delta of -1
4871         #    (negative), giving a positive (>0) value, so we'll set $limit to
4872         #    $to.
4873
4874         $limit = $to if ( $limit - $to ) * $delta > 0;
4875
4876         # The real search loop.
4877         # $i starts at $from (the point we want to start searching from).
4878         # We move through @dbline in the appropriate direction (determined
4879         # by $delta: either -1 (back) or +1 (ahead).
4880         # We stay in as long as we haven't hit an executable line
4881         # ($dbline[$i] == 0 means not executable) and we haven't reached
4882         # the limit yet (test similar to the above).
4883         $i += $delta while $dbline[$i] == 0 and ( $limit - $i ) * $delta > 0;
4884
4885     } ## end if (@_ >= 2)
4886
4887     # If $i points to a line that is executable, return that.
4888     return $i unless $dbline[$i] == 0;
4889
4890     # Format the message and print it: no breakable lines in range.
4891     my ( $pl, $upto ) = ( '', '' );
4892     ( $pl, $upto ) = ( 's', "..$to" ) if @_ >= 2 and $from != $to;
4893
4894     # If there's a filename in filename_error, we'll see it.
4895     # If not, not.
4896     die "Line$pl $from$upto$filename_error not breakable\n";
4897 } ## end sub breakable_line
4898
4899 =head3 breakable_line_in_filename(file, from, to) (API)
4900
4901 Like C<breakable_line>, but look in another file.
4902
4903 =cut
4904
4905 sub breakable_line_in_filename {
4906
4907     # Capture the file name.
4908     my ($f) = shift;
4909
4910     # Swap the magic line array over there temporarily.
4911     local *dbline = $main::{ '_<' . $f };
4912
4913     # If there's an error, it's in this other file.
4914     local $filename_error = " of '$f'";
4915
4916     # Find the breakable line.
4917     breakable_line(@_);
4918
4919     # *dbline and $filename_error get restored when this block ends.
4920
4921 } ## end sub breakable_line_in_filename
4922
4923 =head3 break_on_line(lineno, [condition]) (API)
4924
4925 Adds a breakpoint with the specified condition (or 1 if no condition was
4926 specified) to the specified line. Dies if it can't.
4927
4928 =cut
4929
4930 sub break_on_line {
4931     my $i = shift;
4932     my $cond = @_ ? shift(@_) : 1;
4933
4934     my $inii  = $i;
4935     my $after = '';
4936     my $pl    = '';
4937
4938     # Woops, not a breakable line. $filename_error allows us to say
4939     # if it was in a different file.
4940     die "Line $i$filename_error not breakable.\n" if $dbline[$i] == 0;
4941
4942     # Mark this file as having breakpoints in it.
4943     $had_breakpoints{$filename} |= 1;
4944
4945     # If there is an action or condition here already ...
4946     if ( $dbline{$i} ) {
4947
4948         # ... swap this condition for the existing one.
4949         $dbline{$i} =~ s/^[^\0]*/$cond/;
4950     }
4951     else {
4952
4953         # Nothing here - just add the condition.
4954         $dbline{$i} = $cond;
4955
4956         _set_breakpoint_enabled_status($filename, $i, 1);
4957     }
4958
4959     return;
4960 } ## end sub break_on_line
4961
4962 =head3 cmd_b_line(line, [condition]) (command)
4963
4964 Wrapper for C<break_on_line>. Prints the failure message if it
4965 doesn't work.
4966
4967 =cut
4968
4969 sub cmd_b_line {
4970     if (not eval { break_on_line(@_); 1 }) {
4971         local $\ = '';
4972         print $OUT $@ and return;
4973     }
4974
4975     return;
4976 } ## end sub cmd_b_line
4977
4978 =head3 cmd_b_filename_line(line, [condition]) (command)
4979
4980 Wrapper for C<break_on_filename_line>. Prints the failure message if it
4981 doesn't work.
4982
4983 =cut
4984
4985 sub cmd_b_filename_line {
4986     if (not eval { break_on_filename_line(@_); 1 }) {
4987         local $\ = '';
4988         print $OUT $@ and return;
4989     }
4990
4991     return;
4992 }
4993
4994 =head3 break_on_filename_line(file, line, [condition]) (API)
4995
4996 Switches to the file specified and then calls C<break_on_line> to set
4997 the breakpoint.
4998
4999 =cut
5000
5001 sub break_on_filename_line {
5002     my $f = shift;
5003     my $i = shift;
5004     my $cond = @_ ? shift(@_) : 1;
5005
5006     # Switch the magical hash temporarily.
5007     local *dbline = $main::{ '_<' . $f };
5008
5009     # Localize the variables that break_on_line uses to make its message.
5010     local $filename_error = " of '$f'";
5011     local $filename       = $f;
5012
5013     # Add the breakpoint.
5014     break_on_line( $i, $cond );
5015
5016     return;
5017 } ## end sub break_on_filename_line
5018
5019 =head3 break_on_filename_line_range(file, from, to, [condition]) (API)
5020
5021 Switch to another file, search the range of lines specified for an
5022 executable one, and put a breakpoint on the first one you find.
5023
5024 =cut
5025
5026 sub break_on_filename_line_range {
5027     my $f = shift;
5028     my $from = shift;
5029     my $to = shift;
5030     my $cond = @_ ? shift(@_) : 1;
5031
5032     # Find a breakable line if there is one.
5033     my $i = breakable_line_in_filename( $f, $from, $to );
5034
5035     # Add the breakpoint.
5036     break_on_filename_line( $f, $i, $cond );
5037
5038     return;
5039 } ## end sub break_on_filename_line_range
5040
5041 =head3 subroutine_filename_lines(subname, [condition]) (API)
5042
5043 Search for a subroutine within a given file. The condition is ignored.
5044 Uses C<find_sub> to locate the desired subroutine.
5045
5046 =cut
5047
5048 sub subroutine_filename_lines {
5049     my ( $subname ) = @_;
5050
5051     # Returned value from find_sub() is fullpathname:startline-endline.
5052     # The match creates the list (fullpathname, start, end).
5053     return (find_sub($subname) =~ /^(.*):(\d+)-(\d+)$/);
5054 } ## end sub subroutine_filename_lines
5055
5056 =head3 break_subroutine(subname) (API)
5057
5058 Places a break on the first line possible in the specified subroutine. Uses
5059 C<subroutine_filename_lines> to find the subroutine, and
5060 C<break_on_filename_line_range> to place the break.
5061
5062 =cut
5063
5064 sub break_subroutine {
5065     my $subname = shift;
5066
5067     # Get filename, start, and end.
5068     my ( $file, $s, $e ) = subroutine_filename_lines($subname)
5069       or die "Subroutine $subname not found.\n";
5070
5071
5072     # Null condition changes to '1' (always true).
5073     my $cond = @_ ? shift(@_) : 1;
5074
5075     # Put a break the first place possible in the range of lines
5076     # that make up this subroutine.
5077     break_on_filename_line_range( $file, $s, $e, $cond );
5078
5079     return;
5080 } ## end sub break_subroutine
5081
5082 =head3 cmd_b_sub(subname, [condition]) (command)
5083
5084 We take the incoming subroutine name and fully-qualify it as best we can.
5085
5086 =over 4
5087
5088 =item 1. If it's already fully-qualified, leave it alone.
5089
5090 =item 2. Try putting it in the current package.
5091
5092 =item 3. If it's not there, try putting it in CORE::GLOBAL if it exists there.
5093
5094 =item 4. If it starts with '::', put it in 'main::'.
5095
5096 =back
5097
5098 After all this cleanup, we call C<break_subroutine> to try to set the
5099 breakpoint.
5100
5101 =cut
5102
5103 sub cmd_b_sub {
5104     my $subname = shift;
5105     my $cond = @_ ? shift : 1;
5106
5107     # If the subname isn't a code reference, qualify it so that
5108     # break_subroutine() will work right.
5109     if ( ref($subname) ne 'CODE' ) {
5110
5111         # Not Perl 4.
5112         $subname =~ s/'/::/g;
5113         my $s = $subname;
5114
5115         # Put it in this package unless it's already qualified.
5116         if ($subname !~ /::/)
5117         {
5118             $subname = $package . '::' . $subname;
5119         };
5120
5121         # Requalify it into CORE::GLOBAL if qualifying it into this
5122         # package resulted in its not being defined, but only do so
5123         # if it really is in CORE::GLOBAL.
5124         my $core_name = "CORE::GLOBAL::$s";
5125         if ((!defined(&$subname))
5126                 and ($s !~ /::/)
5127                 and (defined &{$core_name}))
5128         {
5129             $subname = $core_name;
5130         }
5131
5132         # Put it in package 'main' if it has a leading ::.
5133         if ($subname =~ /\A::/)
5134         {
5135             $subname = "main" . $subname;
5136         }
5137     } ## end if ( ref($subname) ne 'CODE' ) {
5138
5139     # Try to set the breakpoint.
5140     if (not eval { break_subroutine( $subname, $cond ); 1 }) {
5141         local $\ = '';
5142         print {$OUT} $@;
5143         return;
5144     }
5145
5146     return;
5147 } ## end sub cmd_b_sub
5148
5149 =head3 C<cmd_B> - delete breakpoint(s) (command)
5150
5151 The command mostly parses the command line and tries to turn the argument
5152 into a line spec. If it can't, it uses the current line. It then calls
5153 C<delete_breakpoint> to actually do the work.
5154
5155 If C<*> is  specified, C<cmd_B> calls C<delete_breakpoint> with no arguments,
5156 thereby deleting all the breakpoints.
5157
5158 =cut
5159
5160 sub cmd_B {
5161     my $cmd = shift;
5162
5163     # No line spec? Use dbline.
5164     # If there is one, use it if it's non-zero, or wipe it out if it is.
5165     my $line   = ( $_[0] =~ /\A\./ ) ? $dbline : (shift || '');
5166     my $dbline = shift;
5167
5168     # If the line was dot, make the line the current one.
5169     $line =~ s/^\./$dbline/;
5170
5171     # If it's * we're deleting all the breakpoints.
5172     if ( $line eq '*' ) {
5173         if (not eval { delete_breakpoint(); 1 }) {
5174             print {$OUT} $@;
5175         }
5176     }
5177
5178     # If there is a line spec, delete the breakpoint on that line.
5179     elsif ( $line =~ /\A(\S.*)/ ) {
5180         if (not eval { delete_breakpoint( $line || $dbline ); 1 }) {
5181             local $\ = '';
5182             print {$OUT} $@;
5183         }
5184     } ## end elsif ($line =~ /^(\S.*)/)
5185
5186     # No line spec.
5187     else {
5188         print {$OUT}
5189           "Deleting a breakpoint requires a line number, or '*' for all\n"
5190           ;    # hint
5191     }
5192
5193     return;
5194 } ## end sub cmd_B
5195
5196 =head3 delete_breakpoint([line]) (API)
5197
5198 This actually does the work of deleting either a single breakpoint, or all
5199 of them.
5200
5201 For a single line, we look for it in C<@dbline>. If it's nonbreakable, we
5202 just drop out with a message saying so. If it is, we remove the condition
5203 part of the 'condition\0action' that says there's a breakpoint here. If,
5204 after we've done that, there's nothing left, we delete the corresponding
5205 line in C<%dbline> to signal that no action needs to be taken for this line.
5206
5207 For all breakpoints, we iterate through the keys of C<%had_breakpoints>,
5208 which lists all currently-loaded files which have breakpoints. We then look
5209 at each line in each of these files, temporarily switching the C<%dbline>
5210 and C<@dbline> structures to point to the files in question, and do what
5211 we did in the single line case: delete the condition in C<@dbline>, and
5212 delete the key in C<%dbline> if nothing's left.
5213
5214 We then wholesale delete C<%postponed>, C<%postponed_file>, and
5215 C<%break_on_load>, because these structures contain breakpoints for files
5216 and code that haven't been loaded yet. We can just kill these off because there
5217 are no magical debugger structures associated with them.
5218
5219 =cut
5220
5221 sub _remove_breakpoint_entry {
5222     my ($fn, $i) = @_;
5223
5224     delete $dbline{$i};
5225     _delete_breakpoint_data_ref($fn, $i);
5226
5227     return;
5228 }
5229
5230 sub _delete_all_breakpoints {
5231     print {$OUT} "Deleting all breakpoints...\n";
5232
5233     # %had_breakpoints lists every file that had at least one
5234     # breakpoint in it.
5235     for my $fn ( keys %had_breakpoints ) {
5236
5237         # Switch to the desired file temporarily.
5238         local *dbline = $main::{ '_<' . $fn };
5239
5240         $max = $#dbline;
5241
5242         # For all lines in this file ...
5243         for my $i (1 .. $max) {
5244
5245             # If there's a breakpoint or action on this line ...
5246             if ( defined $dbline{$i} ) {
5247
5248                 # ... remove the breakpoint.
5249                 $dbline{$i} =~ s/\A[^\0]+//;
5250                 if ( $dbline{$i} =~ s/\A\0?\z// ) {
5251                     # Remove the entry altogether if no action is there.
5252                     _remove_breakpoint_entry($fn, $i);
5253                 }
5254             } ## end if (defined $dbline{$i...
5255         } ## end for $i (1 .. $max)
5256
5257         # If, after we turn off the "there were breakpoints in this file"
5258         # bit, the entry in %had_breakpoints for this file is zero,
5259         # we should remove this file from the hash.
5260         if ( not $had_breakpoints{$fn} &= (~1) ) {
5261             delete $had_breakpoints{$fn};
5262         }
5263     } ## end for my $fn (keys %had_breakpoints)
5264
5265     # Kill off all the other breakpoints that are waiting for files that
5266     # haven't been loaded yet.
5267     undef %postponed;
5268     undef %postponed_file;
5269     undef %break_on_load;
5270
5271     return;
5272 }
5273
5274 sub _delete_breakpoint_from_line {
5275     my ($i) = @_;
5276
5277     # Woops. This line wasn't breakable at all.
5278     die "Line $i not breakable.\n" if $dbline[$i] == 0;
5279
5280     # Kill the condition, but leave any action.
5281     $dbline{$i} =~ s/\A[^\0]*//;
5282
5283     # Remove the entry entirely if there's no action left.
5284     if ($dbline{$i} eq '') {
5285         _remove_breakpoint_entry($filename, $i);
5286     }
5287
5288     return;
5289 }
5290
5291 sub delete_breakpoint {
5292     my $i = shift;
5293
5294     # If we got a line, delete just that one.
5295     if ( defined($i) ) {
5296         _delete_breakpoint_from_line($i);
5297     }
5298     # No line; delete them all.
5299     else {
5300         _delete_all_breakpoints();
5301     }
5302
5303     return;
5304 }
5305
5306 =head3 cmd_stop (command)
5307
5308 This is meant to be part of the new command API, but it isn't called or used
5309 anywhere else in the debugger. XXX It is probably meant for use in development
5310 of new commands.
5311
5312 =cut
5313
5314 sub cmd_stop {    # As on ^C, but not signal-safy.
5315     $signal = 1;
5316 }
5317
5318 =head3 C<cmd_e> - threads
5319
5320 Display the current thread id:
5321
5322     e
5323
5324 This could be how (when implemented) to send commands to this thread id (e cmd)
5325 or that thread id (e tid cmd).
5326
5327 =cut
5328
5329 sub cmd_e {
5330     my $cmd  = shift;
5331     my $line = shift;
5332     unless (exists($INC{'threads.pm'})) {
5333         print "threads not loaded($ENV{PERL5DB_THREADED})
5334         please run the debugger with PERL5DB_THREADED=1 set in the environment\n";
5335     } else {
5336         my $tid = threads->tid;
5337         print "thread id: $tid\n";
5338     }
5339 } ## end sub cmd_e
5340
5341 =head3 C<cmd_E> - list of thread ids
5342
5343 Display the list of available thread ids:
5344
5345     E
5346
5347 This could be used (when implemented) to send commands to all threads (E cmd).
5348
5349 =cut
5350
5351 sub cmd_E {
5352     my $cmd  = shift;
5353     my $line = shift;
5354     unless (exists($INC{'threads.pm'})) {
5355         print "threads not loaded($ENV{PERL5DB_THREADED})
5356         please run the debugger with PERL5DB_THREADED=1 set in the environment\n";
5357     } else {
5358         my $tid = threads->tid;
5359         print "thread ids: ".join(', ',
5360             map { ($tid == $_->tid ? '<'.$_->tid.'>' : $_->tid) } threads->list
5361         )."\n";
5362     }
5363 } ## end sub cmd_E
5364
5365 =head3 C<cmd_h> - help command (command)
5366
5367 Does the work of either
5368
5369 =over 4
5370
5371 =item *
5372
5373 Showing all the debugger help
5374
5375 =item *
5376
5377 Showing help for a specific command
5378
5379 =back
5380
5381 =cut
5382
5383 use vars qw($help);
5384 use vars qw($summary);
5385
5386 sub cmd_h {
5387     my $cmd = shift;
5388
5389     # If we have no operand, assume null.
5390     my $line = shift || '';
5391
5392     # 'h h'. Print the long-format help.
5393     if ( $line =~ /\Ah\s*\z/ ) {
5394         print_help($help);
5395     }
5396
5397     # 'h <something>'. Search for the command and print only its help.
5398     elsif ( my ($asked) = $line =~ /\A(\S.*)\z/ ) {
5399
5400         # support long commands; otherwise bogus errors
5401         # happen when you ask for h on <CR> for example
5402         my $qasked = quotemeta($asked);    # for searching; we don't
5403                                            # want to use it as a pattern.
5404                                            # XXX: finds CR but not <CR>
5405
5406         # Search the help string for the command.
5407         if (
5408             $help =~ /^                    # Start of a line
5409                       <?                   # Optional '<'
5410                       (?:[IB]<)            # Optional markup
5411                       $qasked              # The requested command
5412                      /mx
5413           )
5414         {
5415
5416             # It's there; pull it out and print it.
5417             while (
5418                 $help =~ /^
5419                               (<?            # Optional '<'
5420                                  (?:[IB]<)   # Optional markup
5421                                  $qasked     # The command
5422                                  ([\s\S]*?)  # Description line(s)
5423                               \n)            # End of last description line
5424                               (?!\s)         # Next line not starting with
5425                                              # whitespace
5426                              /mgx
5427               )
5428             {
5429                 print_help($1);
5430             }
5431         }
5432
5433         # Not found; not a debugger command.
5434         else {
5435             print_help("B<$asked> is not a debugger command.\n");
5436         }
5437     } ## end elsif ($line =~ /^(\S.*)$/)
5438
5439     # 'h' - print the summary help.
5440     else {
5441         print_help($summary);
5442     }
5443 } ## end sub cmd_h
5444
5445 =head3 C<cmd_i> - inheritance display
5446
5447 Display the (nested) parentage of the module or object given.
5448
5449 =cut
5450
5451 sub cmd_i {
5452     my $cmd  = shift;
5453     my $line = shift;
5454     foreach my $isa ( split( /\s+/, $line ) ) {
5455         $evalarg = $isa;
5456         # The &-call is here to ascertain the mutability of @_.
5457         ($isa) = &DB::eval;
5458         no strict 'refs';
5459         print join(
5460             ', ',
5461             map {
5462                 "$_"
5463                   . (
5464                     defined( ${"$_\::VERSION"} )
5465                     ? ' ' . ${"$_\::VERSION"}
5466                     : undef )
5467               } @{mro::get_linear_isa(ref($isa) || $isa)}
5468         );
5469         print "\n";
5470     }
5471 } ## end sub cmd_i
5472
5473 =head3 C<cmd_l> - list lines (command)
5474
5475 Most of the command is taken up with transforming all the different line
5476 specification syntaxes into 'start-stop'. After that is done, the command
5477 runs a loop over C<@dbline> for the specified range of lines. It handles
5478 the printing of each line and any markers (C<==E<gt>> for current line,
5479 C<b> for break on this line, C<a> for action on this line, C<:> for this
5480 line breakable).
5481
5482 We save the last line listed in the C<$start> global for further listing
5483 later.
5484
5485 =cut
5486
5487 sub _min {
5488     my $min = shift;
5489     foreach my $v (@_) {
5490         if ($min > $v) {
5491             $min = $v;
5492         }
5493     }
5494     return $min;
5495 }
5496
5497 sub _max {
5498     my $max = shift;
5499     foreach my $v (@_) {
5500         if ($max < $v) {
5501             $max = $v;
5502         }
5503     }
5504     return $max;
5505 }
5506
5507 sub _minify_to_max {
5508     my $ref = shift;
5509
5510     $$ref = _min($$ref, $max);
5511
5512     return;
5513 }
5514
5515 sub _cmd_l_handle_var_name {
5516     my $var_name = shift;
5517
5518     $evalarg = $var_name;
5519
5520     my ($s) = DB::eval();
5521
5522     # Ooops. Bad scalar.
5523     if ($@) {
5524         print {$OUT} "Error: $@\n";
5525         next CMD;
5526     }
5527
5528     # Good scalar. If it's a reference, find what it points to.
5529     $s = CvGV_name($s);
5530     print {$OUT} "Interpreted as: $1 $s\n";
5531     $line = "$1 $s";
5532
5533     # Call self recursively to really do the command.
5534     return _cmd_l_main( $s );
5535 }
5536
5537 sub _cmd_l_handle_subname {
5538
5539     my $s = $subname;
5540
5541     # De-Perl4.
5542     $subname =~ s/\'/::/;
5543
5544     # Put it in this package unless it starts with ::.
5545     $subname = $package . "::" . $subname unless $subname =~ /::/;
5546
5547     # Put it in CORE::GLOBAL if t doesn't start with :: and
5548     # it doesn't live in this package and it lives in CORE::GLOBAL.
5549     $subname = "CORE::GLOBAL::$s"
5550     if not defined &$subname
5551         and $s !~ /::/
5552         and defined &{"CORE::GLOBAL::$s"};
5553
5554     # Put leading '::' names into 'main::'.
5555     $subname = "main" . $subname if substr( $subname, 0, 2 ) eq "::";
5556
5557     # Get name:start-stop from find_sub, and break this up at
5558     # colons.
5559     my @pieces = split( /:/, find_sub($subname) || $sub{$subname} );
5560
5561     # Pull off start-stop.
5562     my $subrange = pop @pieces;
5563
5564     # If the name contained colons, the split broke it up.
5565     # Put it back together.
5566     $file = join( ':', @pieces );
5567
5568     # If we're not in that file, switch over to it.
5569     if ( $file ne $filename ) {
5570         if (! $slave_editor) {
5571             print {$OUT} "Switching to file '$file'.\n";
5572         }
5573
5574         # Switch debugger's magic structures.
5575         *dbline   = $main::{ '_<' . $file };
5576         $max      = $#dbline;
5577         $filename = $file;
5578     } ## end if ($file ne $filename)
5579
5580     # Subrange is 'start-stop'. If this is less than a window full,
5581     # swap it to 'start+', which will list a window from the start point.
5582     if ($subrange) {
5583         if ( eval($subrange) < -$window ) {
5584             $subrange =~ s/-.*/+/;
5585         }
5586
5587         # Call self recursively to list the range.
5588         return _cmd_l_main( $subrange );
5589     } ## end if ($subrange)
5590
5591     # Couldn't find it.
5592     else {
5593         print {$OUT} "Subroutine $subname not found.\n";
5594         return;
5595     }
5596 }
5597
5598 sub _cmd_l_empty {
5599     # Compute new range to list.
5600     $incr = $window - 1;
5601
5602     # Recurse to do it.
5603     return _cmd_l_main( $start . '-' . ( $start + $incr ) );
5604 }
5605
5606 sub _cmd_l_plus {
5607     my ($new_start, $new_incr) = @_;
5608
5609     # Don't reset start for 'l +nnn'.
5610     $start = $new_start if $new_start;
5611
5612     # Increment for list. Use window size if not specified.
5613     # (Allows 'l +' to work.)
5614     $incr = $new_incr || ($window - 1);
5615
5616     # Create a line range we'll understand, and recurse to do it.
5617     return _cmd_l_main( $start . '-' . ( $start + $incr ) );
5618 }
5619
5620 sub _cmd_l_calc_initial_end_and_i {
5621     my ($spec, $start_match, $end_match) = @_;
5622
5623     # Determine end point; use end of file if not specified.
5624     my $end = ( !defined $start_match ) ? $max :
5625     ( $end_match ? $end_match : $start_match );
5626
5627     # Go on to the end, and then stop.
5628     _minify_to_max(\$end);
5629
5630     # Determine start line.
5631     my $i = $start_match;
5632
5633     if ($i eq '.') {
5634         $i = $spec;
5635     }
5636
5637     $i = _max($i, 1);
5638
5639     $incr = $end - $i;
5640
5641     return ($end, $i);
5642 }
5643
5644 sub _cmd_l_range {
5645     my ($spec, $current_line, $start_match, $end_match) = @_;
5646
5647     my ($end, $i) =
5648         _cmd_l_calc_initial_end_and_i($spec, $start_match, $end_match);
5649
5650     # If we're running under a slave editor, force it to show the lines.
5651     if ($slave_editor) {
5652         print {$OUT} "\032\032$filename:$i:0\n";
5653         $i = $end;
5654     }
5655     # We're doing it ourselves. We want to show the line and special
5656     # markers for:
5657     # - the current line in execution
5658     # - whether a line is breakable or not
5659     # - whether a line has a break or not
5660     # - whether a line has an action or not
5661     else {
5662         I_TO_END:
5663         for ( ; $i <= $end ; $i++ ) {
5664
5665             # Check for breakpoints and actions.
5666             my ( $stop, $action );
5667             if ($dbline{$i}) {
5668                 ( $stop, $action ) = split( /\0/, $dbline{$i} );
5669             }
5670
5671             # ==> if this is the current line in execution,
5672             # : if it's breakable.
5673             my $arrow =
5674             ( $i == $current_line and $filename eq $filename_ini )
5675             ? '==>'
5676             : ( $dbline[$i] + 0 ? ':' : ' ' );
5677
5678             # Add break and action indicators.
5679             $arrow .= 'b' if $stop;
5680             $arrow .= 'a' if $action;
5681
5682             # Print the line.
5683             print {$OUT} "$i$arrow\t", $dbline[$i];
5684
5685             # Move on to the next line. Drop out on an interrupt.
5686             if ($signal) {
5687                 $i++;
5688                 last I_TO_END;
5689             }
5690         } ## end for (; $i <= $end ; $i++)
5691
5692         # Line the prompt up; print a newline if the last line listed
5693         # didn't have a newline.
5694         if ($dbline[ $i - 1 ] !~ /\n\z/) {
5695             print {$OUT} "\n";
5696         }
5697     } ## end else [ if ($slave_editor)
5698
5699     # Save the point we last listed to in case another relative 'l'
5700     # command is desired. Don't let it run off the end.
5701     $start = $i;
5702     _minify_to_max(\$start);
5703
5704     return;
5705 }
5706
5707 sub _cmd_l_main {
5708     my $spec = shift;
5709
5710     # If this is '-something', delete any spaces after the dash.
5711     $spec =~ s/\A-\s*\z/-/;
5712
5713     # If the line is '$something', assume this is a scalar containing a
5714     # line number.
5715     # Set up for DB::eval() - evaluate in *user* context.
5716     if ( my ($var_name) = $spec =~ /\A(\$.*)/s ) {
5717         return _cmd_l_handle_var_name($var_name);
5718     }
5719     # l name. Try to find a sub by that name.
5720     elsif ( ($subname) = $spec =~ /\A([\':A-Za-z_][\':\w]*(?:\[.*\])?)/s ) {
5721         return _cmd_l_handle_subname();
5722     }
5723     # Bare 'l' command.
5724     elsif ( $spec !~ /\S/ ) {
5725         return _cmd_l_empty();
5726     }
5727     # l [start]+number_of_lines
5728     elsif ( my ($new_start, $new_incr) = $spec =~ /\A(\d*)\+(\d*)\z/ ) {
5729         return _cmd_l_plus($new_start, $new_incr);
5730     }
5731     # l start-stop or l start,stop
5732     elsif (my ($s, $e) = $spec =~ /^(?:(-?[\d\$\.]+)(?:[-,]([\d\$\.]+))?)?/ ) {
5733         return _cmd_l_range($spec, $line, $s, $e);
5734     }
5735
5736     return;
5737 } ## end sub cmd_l
5738
5739 sub cmd_l {
5740     my (undef, $line) = @_;
5741
5742     return _cmd_l_main($line);
5743 }
5744
5745 =head3 C<cmd_L> - list breakpoints, actions, and watch expressions (command)
5746
5747 To list breakpoints, the command has to look determine where all of them are
5748 first. It starts a C<%had_breakpoints>, which tells us what all files have
5749 breakpoints and/or actions. For each file, we switch the C<*dbline> glob (the
5750 magic source and breakpoint data structures) to the file, and then look
5751 through C<%dbline> for lines with breakpoints and/or actions, listing them
5752 out. We look through C<%postponed> not-yet-compiled subroutines that have
5753 breakpoints, and through C<%postponed_file> for not-yet-C<require>'d files
5754 that have breakpoints.
5755
5756 Watchpoints are simpler: we just list the entries in C<@to_watch>.
5757
5758 =cut
5759
5760 sub _cmd_L_calc_arg {
5761     # If no argument, list everything. Pre-5.8.0 version always lists
5762     # everything
5763     my $arg = shift || 'abw';
5764     if ($CommandSet ne '580')
5765     {
5766         $arg = 'abw';
5767     }
5768
5769     return $arg;
5770 }
5771
5772 sub _cmd_L_calc_wanted_flags {
5773     my $arg = _cmd_L_calc_arg(shift);
5774
5775     return (map { index($arg, $_) >= 0 ? 1 : 0 } qw(a b w));
5776 }
5777
5778
5779 sub _cmd_L_handle_breakpoints {
5780     my ($handle_db_line) = @_;
5781
5782     BREAKPOINTS_SCAN:
5783     # Look in all the files with breakpoints...
5784     for my $file ( keys %had_breakpoints ) {
5785
5786         # Temporary switch to this file.
5787         local *dbline = $main::{ '_<' . $file };
5788
5789         # Set up to look through the whole file.
5790         $max = $#dbline;
5791         my $was;    # Flag: did we print something
5792         # in this file?
5793
5794         # For each line in the file ...
5795         for my $i (1 .. $max) {
5796
5797             # We've got something on this line.
5798             if ( defined $dbline{$i} ) {
5799
5800                 # Print the header if we haven't.
5801                 if (not $was++) {
5802                     print {$OUT} "$file:\n";
5803                 }
5804
5805                 # Print the line.
5806                 print {$OUT} " $i:\t", $dbline[$i];
5807
5808                 $handle_db_line->($dbline{$i});
5809
5810                 # Quit if the user hit interrupt.
5811                 if ($signal) {
5812                     last BREAKPOINTS_SCAN;
5813                 }
5814             } ## end if (defined $dbline{$i...
5815         } ## end for my $i (1 .. $max)
5816     } ## end for my $file (keys %had_breakpoints)
5817
5818     return;
5819 }
5820
5821 sub _cmd_L_handle_postponed_breakpoints {
5822     my ($handle_db_line) = @_;
5823
5824     print {$OUT} "Postponed breakpoints in files:\n";
5825
5826     POSTPONED_SCANS:
5827     for my $file ( keys %postponed_file ) {
5828         my $db = $postponed_file{$file};
5829         print {$OUT} " $file:\n";
5830         for my $line ( sort { $a <=> $b } keys %$db ) {
5831             print {$OUT} "  $line:\n";
5832
5833             $handle_db_line->($db->{$line});
5834
5835             if ($signal) {
5836                 last POSTPONED_SCANS;
5837             }
5838         }
5839         if ($signal) {
5840             last POSTPONED_SCANS;
5841         }
5842     }
5843
5844     return;
5845 }
5846
5847
5848 sub cmd_L {
5849     my $cmd = shift;
5850
5851     my ($action_wanted, $break_wanted, $watch_wanted) =
5852         _cmd_L_calc_wanted_flags(shift);
5853
5854     my $handle_db_line = sub {
5855         my ($l) = @_;
5856
5857         my ( $stop, $action ) = split( /\0/, $l );
5858
5859         if ($stop and $break_wanted) {
5860             print {$OUT} "    break if (", $stop, ")\n"
5861         }
5862
5863         if ($action && $action_wanted) {
5864             print {$OUT} "    action:  ", $action, "\n"
5865         }
5866
5867         return;
5868     };
5869
5870     # Breaks and actions are found together, so we look in the same place
5871     # for both.
5872     if ( $break_wanted or $action_wanted ) {
5873         _cmd_L_handle_breakpoints($handle_db_line);
5874     }
5875
5876     # Look for breaks in not-yet-compiled subs:
5877     if ( %postponed and $break_wanted ) {
5878         print {$OUT} "Postponed breakpoints in subroutines:\n";
5879         my $subname;
5880         SUBS_SCAN:
5881         for $subname ( keys %postponed ) {
5882             print {$OUT} " $subname\t$postponed{$subname}\n";
5883             if ($signal) {
5884                 last SUBS_SCAN;
5885             }
5886         }
5887     } ## end if (%postponed and $break_wanted)
5888
5889     # Find files that have not-yet-loaded breaks:
5890     my @have = map {    # Combined keys
5891         keys %{ $postponed_file{$_} }
5892     } keys %postponed_file;
5893
5894     # If there are any, list them.
5895     if ( @have and ( $break_wanted or $action_wanted ) ) {
5896         _cmd_L_handle_postponed_breakpoints($handle_db_line);
5897     } ## end if (@have and ($break_wanted...
5898
5899     if ( %break_on_load and $break_wanted ) {
5900         print {$OUT} "Breakpoints on load:\n";
5901         BREAK_ON_LOAD: for my $filename ( keys %break_on_load ) {
5902             print {$OUT} " $filename\n";
5903             last BREAK_ON_LOAD if $signal;
5904         }
5905     } ## end if (%break_on_load and...
5906
5907     if ($watch_wanted and ( $trace & 2 )) {
5908         print {$OUT} "Watch-expressions:\n" if @to_watch;
5909         TO_WATCH: for my $expr (@to_watch) {
5910             print {$OUT} " $expr\n";
5911             last TO_WATCH if $signal;
5912         }
5913     }
5914
5915     return;
5916 } ## end sub cmd_L
5917
5918 =head3 C<cmd_M> - list modules (command)
5919
5920 Just call C<list_modules>.
5921
5922 =cut
5923
5924 sub cmd_M {
5925     list_modules();
5926
5927     return;
5928 }
5929
5930 =head3 C<cmd_o> - options (command)
5931
5932 If this is just C<o> by itself, we list the current settings via
5933 C<dump_option>. If there's a nonblank value following it, we pass that on to
5934 C<parse_options> for processing.
5935
5936 =cut
5937
5938 sub cmd_o {
5939     my $cmd = shift;
5940     my $opt = shift || '';    # opt[=val]
5941
5942     # Nonblank. Try to parse and process.
5943     if ( $opt =~ /^(\S.*)/ ) {
5944         parse_options($1);
5945     }
5946
5947     # Blank. List the current option settings.
5948     else {
5949         for (@options) {
5950             dump_option($_);
5951         }
5952     }
5953 } ## end sub cmd_o
5954
5955 =head3 C<cmd_O> - nonexistent in 5.8.x (command)
5956
5957 Advises the user that the O command has been renamed.
5958
5959 =cut
5960
5961 sub cmd_O {
5962     print $OUT "The old O command is now the o command.\n";             # hint
5963     print $OUT "Use 'h' to get current command help synopsis or\n";     #
5964     print $OUT "use 'o CommandSet=pre580' to revert to old usage\n";    #
5965 }
5966
5967 =head3 C<cmd_v> - view window (command)
5968
5969 Uses the C<$preview> variable set in the second C<BEGIN> block (q.v.) to
5970 move back a few lines to list the selected line in context. Uses C<cmd_l>
5971 to do the actual listing after figuring out the range of line to request.
5972
5973 =cut
5974
5975 use vars qw($preview);
5976
5977 sub cmd_v {
5978     my $cmd  = shift;
5979     my $line = shift;
5980
5981     # Extract the line to list around. (Astute readers will have noted that
5982     # this pattern will match whether or not a numeric line is specified,
5983     # which means that we'll always enter this loop (though a non-numeric
5984     # argument results in no action at all)).
5985     if ( $line =~ /^(\d*)$/ ) {
5986
5987         # Total number of lines to list (a windowful).
5988         $incr = $window - 1;
5989
5990         # Set the start to the argument given (if there was one).
5991         $start = $1 if $1;
5992
5993         # Back up by the context amount.
5994         $start -= $preview;
5995
5996         # Put together a linespec that cmd_l will like.
5997         $line = $start . '-' . ( $start + $incr );
5998
5999         # List the lines.
6000         cmd_l( 'l', $line );
6001     } ## end if ($line =~ /^(\d*)$/)
6002 } ## end sub cmd_v
6003
6004 =head3 C<cmd_w> - add a watch expression (command)
6005
6006 The 5.8 version of this command adds a watch expression if one is specified;
6007 it does nothing if entered with no operands.
6008
6009 We extract the expression, save it, evaluate it in the user's context, and
6010 save the value. We'll re-evaluate it each time the debugger passes a line,
6011 and will stop (see the code at the top of the command loop) if the value
6012 of any of the expressions changes.
6013
6014 =cut
6015
6016 sub _add_watch_expr {
6017     my $expr = shift;
6018
6019     # ... save it.
6020     push @to_watch, $expr;
6021
6022     # Parameterize DB::eval and call it to get the expression's value
6023     # in the user's context. This version can handle expressions which
6024     # return a list value.
6025     $evalarg = $expr;
6026     # The &-call is here to ascertain the mutability of @_.
6027     my ($val) = join( ' ', &DB::eval);
6028     $val = ( defined $val ) ? "'$val'" : 'undef';
6029
6030     # Save the current value of the expression.
6031     push @old_watch, $val;
6032
6033     # We are now watching expressions.
6034     $trace |= 2;
6035
6036     return;
6037 }
6038
6039 sub cmd_w {
6040     my $cmd = shift;
6041
6042     # Null expression if no arguments.
6043     my $expr = shift || '';
6044
6045     # If expression is not null ...
6046     if ( $expr =~ /\A\S/ ) {
6047         _add_watch_expr($expr);
6048     } ## end if ($expr =~ /^(\S.*)/)
6049
6050     # You have to give one to get one.
6051     else {
6052         print $OUT "Adding a watch-expression requires an expression\n";  # hint
6053     }
6054
6055     return;
6056 }
6057
6058 =head3 C<cmd_W> - delete watch expressions (command)
6059
6060 This command accepts either a watch expression to be removed from the list
6061 of watch expressions, or C<*> to delete them all.
6062
6063 If C<*> is specified, we simply empty the watch expression list and the
6064 watch expression value list. We also turn off the bit that says we've got
6065 watch expressions.
6066
6067 If an expression (or partial expression) is specified, we pattern-match
6068 through the expressions and remove the ones that match. We also discard
6069 the corresponding values. If no watch expressions are left, we turn off
6070 the I<watching expressions> bit.
6071
6072 =cut
6073
6074 sub cmd_W {
6075     my $cmd  = shift;
6076     my $expr = shift || '';
6077
6078     # Delete them all.
6079     if ( $expr eq '*' ) {
6080
6081         # Not watching now.
6082         $trace &= ~2;
6083
6084         print $OUT "Deleting all watch expressions ...\n";
6085
6086         # And all gone.
6087         @to_watch = @old_watch = ();
6088     }
6089
6090     # Delete one of them.
6091     elsif ( $expr =~ /^(\S.*)/ ) {
6092
6093         # Where we are in the list.
6094         my $i_cnt = 0;
6095
6096         # For each expression ...
6097         foreach (@to_watch) {
6098             my $val = $to_watch[$i_cnt];
6099
6100             # Does this one match the command argument?
6101             if ( $val eq $expr ) {    # =~ m/^\Q$i$/) {
6102                                       # Yes. Turn it off, and its value too.
6103                 splice( @to_watch,  $i_cnt, 1 );
6104                 splice( @old_watch, $i_cnt, 1 );
6105             }
6106             $i_cnt++;
6107         } ## end foreach (@to_watch)
6108
6109         # We don't bother to turn watching off because
6110         #  a) we don't want to stop calling watchfunction() if it exists
6111         #  b) foreach over a null list doesn't do anything anyway
6112
6113     } ## end elsif ($expr =~ /^(\S.*)/)
6114
6115     # No command arguments entered.
6116     else {
6117         print $OUT
6118           "Deleting a watch-expression requires an expression, or '*' for all\n"
6119           ;    # hint
6120     }
6121 } ## end sub cmd_W
6122
6123 ### END of the API section
6124
6125 =head1 SUPPORT ROUTINES
6126
6127 These are general support routines that are used in a number of places
6128 throughout the debugger.
6129
6130 =head2 save
6131
6132 save() saves the user's versions of globals that would mess us up in C<@saved>,
6133 and installs the versions we like better.
6134
6135 =cut
6136
6137 sub save {
6138
6139     # Save eval failure, command failure, extended OS error, output field
6140     # separator, input record separator, output record separator and
6141     # the warning setting.
6142     @saved = ( $@, $!, $^E, $,, $/, $\, $^W );
6143
6144     $,  = "";      # output field separator is null string
6145     $/  = "\n";    # input record separator is newline
6146     $\  = "";      # output record separator is null string
6147     $^W = 0;       # warnings are off
6148 } ## end sub save
6149
6150 =head2 C<print_lineinfo> - show where we are now
6151
6152 print_lineinfo prints whatever it is that it is handed; it prints it to the
6153 C<$LINEINFO> filehandle instead of just printing it to STDOUT. This allows
6154 us to feed line information to a slave editor without messing up the
6155 debugger output.
6156
6157 =cut
6158
6159 sub print_lineinfo {
6160
6161     # Make the terminal sensible if we're not the primary debugger.
6162     resetterm(1) if $LINEINFO eq $OUT and $term_pid != $$;
6163     local $\ = '';
6164     local $, = '';
6165     # $LINEINFO may be undef if $noTTY is set or some other issue.
6166     if ($LINEINFO)
6167     {
6168         print {$LINEINFO} @_;
6169     }
6170 } ## end sub print_lineinfo
6171
6172 =head2 C<postponed_sub>
6173
6174 Handles setting postponed breakpoints in subroutines once they're compiled.
6175 For breakpoints, we use C<DB::find_sub> to locate the source file and line
6176 range for the subroutine, then mark the file as having a breakpoint,
6177 temporarily switch the C<*dbline> glob over to the source file, and then
6178 search the given range of lines to find a breakable line. If we find one,
6179 we set the breakpoint on it, deleting the breakpoint from C<%postponed>.
6180
6181 =cut
6182
6183 # The following takes its argument via $evalarg to preserve current @_
6184
6185 sub postponed_sub {
6186
6187     # Get the subroutine name.
6188     my $subname = shift;
6189
6190     # If this is a 'break +<n> if <condition>' ...
6191     if ( $postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s// ) {
6192
6193         # If there's no offset, use '+0'.
6194         my $offset = $1 || 0;
6195
6196         # find_sub's value is 'fullpath-filename:start-stop'. It's
6197         # possible that the filename might have colons in it too.
6198         my ( $file, $i ) = ( find_sub($subname) =~ /^(.*):(\d+)-.*$/ );
6199         if ($i) {
6200
6201             # We got the start line. Add the offset '+<n>' from
6202             # $postponed{subname}.
6203             $i += $offset;
6204
6205             # Switch to the file this sub is in, temporarily.
6206             local *dbline = $main::{ '_<' . $file };
6207
6208             # No warnings, please.
6209             local $^W = 0;    # != 0 is magical below
6210
6211             # This file's got a breakpoint in it.
6212             $had_breakpoints{$file} |= 1;
6213
6214             # Last line in file.
6215             $max = $#dbline;
6216
6217             # Search forward until we hit a breakable line or get to
6218             # the end of the file.
6219             ++$i until $dbline[$i] != 0 or $i >= $max;
6220
6221             # Copy the breakpoint in and delete it from %postponed.
6222             $dbline{$i} = delete $postponed{$subname};
6223         } ## end if ($i)
6224
6225         # find_sub didn't find the sub.
6226         else {
6227             local $\ = '';
6228             print $OUT "Subroutine $subname not found.\n";
6229         }
6230         return;
6231     } ## end if ($postponed{$subname...
6232     elsif ( $postponed{$subname} eq 'compile' ) { $signal = 1 }
6233
6234     #print $OUT "In postponed_sub for '$subname'.\n";
6235 } ## end sub postponed_sub
6236
6237 =head2 C<postponed>
6238
6239 Called after each required file is compiled, but before it is executed;
6240 also called if the name of a just-compiled subroutine is a key of
6241 C<%postponed>. Propagates saved breakpoints (from C<b compile>, C<b load>,
6242 etc.) into the just-compiled code.
6243
6244 If this is a C<require>'d file, the incoming parameter is the glob
6245 C<*{"_<$filename"}>, with C<$filename> the name of the C<require>'d file.
6246
6247 If it's a subroutine, the incoming parameter is the subroutine name.
6248
6249 =cut
6250
6251 sub postponed {
6252
6253     # If there's a break, process it.
6254     if ($ImmediateStop) {
6255
6256         # Right, we've stopped. Turn it off.
6257         $ImmediateStop = 0;
6258
6259         # Enter the command loop when DB::DB gets called.
6260         $signal = 1;
6261     }
6262
6263     # If this is a subroutine, let postponed_sub() deal with it.
6264     if (ref(\$_[0]) ne 'GLOB') {
6265         return postponed_sub(@_);
6266     }
6267
6268     # Not a subroutine. Deal with the file.
6269     local *dbline = shift;
6270     my $filename = $dbline;
6271     $filename =~ s/^_<//;
6272     local $\ = '';
6273     $signal = 1, print $OUT "'$filename' loaded...\n"
6274       if $break_on_load{$filename};
6275     print_lineinfo( ' ' x $stack_depth, "Package $filename.\n" ) if $frame;
6276
6277     # Do we have any breakpoints to put in this file?
6278     return unless $postponed_file{$filename};
6279
6280     # Yes. Mark this file as having breakpoints.
6281     $had_breakpoints{$filename} |= 1;
6282
6283     # "Cannot be done: insufficient magic" - we can't just put the
6284     # breakpoints saved in %postponed_file into %dbline by assigning
6285     # the whole hash; we have to do it one item at a time for the
6286     # breakpoints to be set properly.
6287     #%dbline = %{$postponed_file{$filename}};
6288
6289     # Set the breakpoints, one at a time.
6290     my $key;
6291
6292     for $key ( keys %{ $postponed_file{$filename} } ) {
6293
6294         # Stash the saved breakpoint into the current file's magic line array.
6295         $dbline{$key} = ${ $postponed_file{$filename} }{$key};
6296     }
6297
6298     # This file's been compiled; discard the stored breakpoints.
6299     delete $postponed_file{$filename};
6300
6301 } ## end sub postponed
6302
6303 =head2 C<dumpit>
6304
6305 C<dumpit> is the debugger's wrapper around dumpvar.pl.
6306
6307 It gets a filehandle (to which C<dumpvar.pl>'s output will be directed) and
6308 a reference to a variable (the thing to be dumped) as its input.
6309
6310 The incoming filehandle is selected for output (C<dumpvar.pl> is printing to
6311 the currently-selected filehandle, thank you very much). The current
6312 values of the package globals C<$single> and C<$trace> are backed up in
6313 lexicals, and they are turned off (this keeps the debugger from trying
6314 to single-step through C<dumpvar.pl> (I think.)). C<$frame> is localized to
6315 preserve its current value and it is set to zero to prevent entry/exit
6316 messages from printing, and C<$doret> is localized as well and set to -2 to
6317 prevent return values from being shown.
6318
6319 C<dumpit()> then checks to see if it needs to load C<dumpvar.pl> and
6320 tries to load it (note: if you have a C<dumpvar.pl>  ahead of the
6321 installed version in C<@INC>, yours will be used instead. Possible security
6322 problem?).
6323
6324 It then checks to see if the subroutine C<main::dumpValue> is now defined
6325 it should have been defined by C<dumpvar.pl>). If it has, C<dumpit()>
6326 localizes the globals necessary for things to be sane when C<main::dumpValue()>
6327 is called, and picks up the variable to be dumped from the parameter list.
6328
6329 It checks the package global C<%options> to see if there's a C<dumpDepth>
6330 specified. If not, -1 is assumed; if so, the supplied value gets passed on to
6331 C<dumpvar.pl>. This tells C<dumpvar.pl> where to leave off when dumping a
6332 structure: -1 means dump everything.
6333
6334 C<dumpValue()> is then called if possible; if not, C<dumpit()>just prints a
6335 warning.
6336
6337 In either case, C<$single>, C<$trace>, C<$frame>, and C<$doret> are restored
6338 and we then return to the caller.
6339
6340 =cut
6341
6342 sub dumpit {
6343
6344     # Save the current output filehandle and switch to the one
6345     # passed in as the first parameter.
6346     my $savout = select(shift);
6347
6348     # Save current settings of $single and $trace, and then turn them off.
6349     my $osingle = $single;
6350     my $otrace  = $trace;
6351     $single = $trace = 0;
6352
6353     # XXX Okay, what do $frame and $doret do, again?
6354     local $frame = 0;
6355     local $doret = -2;
6356
6357     # Load dumpvar.pl unless we've already got the sub we need from it.
6358     unless ( defined &main::dumpValue ) {
6359         do 'dumpvar.pl' or die $@;
6360     }
6361
6362     # If the load succeeded (or we already had dumpvalue()), go ahead
6363     # and dump things.
6364     if ( defined &main::dumpValue ) {
6365         local $\ = '';
6366         local $, = '';
6367         local $" = ' ';
6368         my $v = shift;
6369         my $maxdepth = shift || $option{dumpDepth};
6370         $maxdepth = -1 unless defined $maxdepth;    # -1 means infinite depth
6371         main::dumpValue( $v, $maxdepth );
6372     } ## end if (defined &main::dumpValue)
6373
6374     # Oops, couldn't load dumpvar.pl.
6375     else {
6376         local $\ = '';
6377         print $OUT "dumpvar.pl not available.\n";
6378     }
6379
6380     # Reset $single and $trace to their old values.
6381     $single = $osingle;
6382     $trace  = $otrace;
6383
6384     # Restore the old filehandle.
6385     select($savout);
6386 } ## end sub dumpit
6387
6388 =head2 C<print_trace>
6389
6390 C<print_trace>'s job is to print a stack trace. It does this via the
6391 C<dump_trace> routine, which actually does all the ferreting-out of the
6392 stack trace data. C<print_trace> takes care of formatting it nicely and
6393 printing it to the proper filehandle.
6394
6395 Parameters:
6396
6397 =over 4
6398
6399 =item *
6400
6401 The filehandle to print to.
6402
6403 =item *
6404
6405 How many frames to skip before starting trace.
6406
6407 =item *
6408
6409 How many frames to print.
6410
6411 =item *
6412
6413 A flag: if true, print a I<short> trace without filenames, line numbers, or arguments
6414
6415 =back
6416
6417 The original comment below seems to be noting that the traceback may not be
6418 correct if this routine is called in a tied method.
6419
6420 =cut
6421
6422 # Tied method do not create a context, so may get wrong message:
6423
6424 sub print_trace {
6425     local $\ = '';
6426     my $fh = shift;
6427
6428     # If this is going to a slave editor, but we're not the primary
6429     # debugger, reset it first.
6430     resetterm(1)
6431       if $fh        eq $LINEINFO    # slave editor
6432       and $LINEINFO eq $OUT         # normal output
6433       and $term_pid != $$;          # not the primary
6434
6435     # Collect the actual trace information to be formatted.
6436     # This is an array of hashes of subroutine call info.
6437     my @sub = dump_trace( $_[0] + 1, $_[1] );
6438
6439     # Grab the "short report" flag from @_.
6440     my $short = $_[2];              # Print short report, next one for sub name
6441
6442     # Run through the traceback info, format it, and print it.
6443     my $s;
6444     for my $i (0 .. $#sub) {
6445
6446         # Drop out if the user has lost interest and hit control-C.
6447         last if $signal;
6448
6449         # Set the separator so arrays print nice.
6450         local $" = ', ';
6451
6452         # Grab and stringify the arguments if they are there.
6453         my $args =
6454           defined $sub[$i]{args}
6455           ? "(@{ $sub[$i]{args} })"
6456           : '';
6457
6458         # Shorten them up if $maxtrace says they're too long.
6459         $args = ( substr $args, 0, $maxtrace - 3 ) . '...'
6460           if length $args > $maxtrace;
6461
6462         # Get the file name.
6463         my $file = $sub[$i]{file};
6464
6465         # Put in a filename header if short is off.
6466         $file = $file eq '-e' ? $file : "file '$file'" unless $short;
6467
6468         # Get the actual sub's name, and shorten to $maxtrace's requirement.
6469         $s = $sub[$i]{'sub'};
6470         $s = ( substr $s, 0, $maxtrace - 3 ) . '...' if length $s > $maxtrace;
6471
6472         # Short report uses trimmed file and sub names.
6473         if ($short) {
6474             my $sub = @_ >= 4 ? $_[3] : $s;
6475             print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
6476         } ## end if ($short)
6477
6478         # Non-short report includes full names.
6479         else {
6480             print $fh "$sub[$i]{context} = $s$args"
6481               . " called from $file"
6482               . " line $sub[$i]{line}\n";
6483         }
6484     } ## end for my $i (0 .. $#sub)
6485 } ## end sub print_trace
6486
6487 =head2 dump_trace(skip[,count])
6488
6489 Actually collect the traceback information available via C<caller()>. It does
6490 some filtering and cleanup of the data, but mostly it just collects it to
6491 make C<print_trace()>'s job easier.
6492
6493 C<skip> defines the number of stack frames to be skipped, working backwards
6494 from the most current. C<count> determines the total number of frames to
6495 be returned; all of them (well, the first 10^9) are returned if C<count>
6496 is omitted.
6497
6498 This routine returns a list of hashes, from most-recent to least-recent
6499 stack frame. Each has the following keys and values:
6500
6501 =over 4
6502
6503 =item * C<context> - C<.> (null), C<$> (scalar), or C<@> (array)
6504
6505 =item * C<sub> - subroutine name, or C<eval> information
6506
6507 =item * C<args> - undef, or a reference to an array of arguments
6508
6509 =item * C<file> - the file in which this item was defined (if any)
6510
6511 =item * C<line> - the line on which it was defined
6512
6513 =back
6514
6515 =cut
6516
6517 sub _dump_trace_calc_saved_single_arg
6518 {
6519     my ($nothard, $arg) = @_;
6520
6521     my $type;
6522     if ( not defined $arg ) {    # undefined parameter
6523         return "undef";
6524     }
6525
6526     elsif ( $nothard and tied $arg ) {    # tied parameter
6527         return "tied";
6528     }
6529     elsif ( $nothard and $type = ref $arg ) {    # reference
6530         return "ref($type)";
6531     }
6532     else {                                       # can be stringified
6533         local $_ =
6534         "$arg";    # Safe to stringify now - should not call f().
6535
6536         # Backslash any single-quotes or backslashes.
6537         s/([\'\\])/\\$1/g;
6538
6539         # Single-quote it unless it's a number or a colon-separated
6540         # name.
6541         s/(.*)/'$1'/s
6542         unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
6543
6544         # Turn high-bit characters into meta-whatever, and controls into like
6545         # '^D'.
6546         require 'meta_notation.pm';
6547         $_ = _meta_notation($_) if /[[:^print:]]/a;
6548
6549         return $_;
6550     }
6551 }
6552
6553 sub _dump_trace_calc_save_args {
6554     my ($nothard) = @_;
6555
6556     return [
6557         map { _dump_trace_calc_saved_single_arg($nothard, $_) } @args
6558     ];
6559 }
6560
6561 sub dump_trace {
6562
6563     # How many levels to skip.
6564     my $skip = shift;
6565
6566     # How many levels to show. (1e9 is a cheap way of saying "all of them";
6567     # it's unlikely that we'll have more than a billion stack frames. If you
6568     # do, you've got an awfully big machine...)
6569     my $count = shift || 1e9;
6570
6571     # We increment skip because caller(1) is the first level *back* from
6572     # the current one.  Add $skip to the count of frames so we have a
6573     # simple stop criterion, counting from $skip to $count+$skip.
6574     $skip++;
6575     $count += $skip;
6576
6577     # These variables are used to capture output from caller();
6578     my ( $p, $file, $line, $sub, $h, $context );
6579
6580     my ( $e, $r, @sub, $args );
6581
6582     # XXX Okay... why'd we do that?
6583     my $nothard = not $frame & 8;
6584     local $frame = 0;
6585
6586     # Do not want to trace this.
6587     my $otrace = $trace;
6588     $trace = 0;
6589
6590     # Start out at the skip count.
6591     # If we haven't reached the number of frames requested, and caller() is
6592     # still returning something, stay in the loop. (If we pass the requested
6593     # number of stack frames, or we run out - caller() returns nothing - we
6594     # quit.
6595     # Up the stack frame index to go back one more level each time.
6596     for (
6597         my $i = $skip ;
6598         $i < $count
6599         and ( $p, $file, $line, $sub, $h, $context, $e, $r ) = caller($i) ;
6600         $i++
6601     )
6602     {
6603
6604         # Go through the arguments and save them for later.
6605         my $save_args = _dump_trace_calc_save_args($nothard);
6606
6607         # If context is true, this is array (@)context.
6608         # If context is false, this is scalar ($) context.
6609         # If neither, context isn't defined. (This is apparently a 'can't
6610         # happen' trap.)
6611         $context = $context ? '@' : ( defined $context ? "\$" : '.' );
6612
6613         # if the sub has args ($h true), make an anonymous array of the
6614         # dumped args.
6615         $args = $h ? $save_args : undef;
6616
6617         # remove trailing newline-whitespace-semicolon-end of line sequence
6618         # from the eval text, if any.
6619         $e =~ s/\n\s*\;\s*\Z// if $e;
6620
6621         # Escape backslashed single-quotes again if necessary.
6622         $e =~ s/([\\\'])/\\$1/g if $e;
6623
6624         # if the require flag is true, the eval text is from a require.
6625         if ($r) {
6626             $sub = "require '$e'";
6627         }
6628
6629         # if it's false, the eval text is really from an eval.
6630         elsif ( defined $r ) {
6631             $sub = "eval '$e'";
6632         }
6633
6634         # If the sub is '(eval)', this is a block eval, meaning we don't
6635         # know what the eval'ed text actually was.
6636         elsif ( $sub eq '(eval)' ) {
6637             $sub = "eval {...}";
6638         }
6639
6640         # Stick the collected information into @sub as an anonymous hash.
6641         push(
6642             @sub,
6643             {
6644                 context => $context,
6645                 sub     => $sub,
6646                 args    => $args,
6647                 file    => $file,
6648                 line    => $line
6649             }
6650         );
6651
6652         # Stop processing frames if the user hit control-C.
6653         last if $signal;
6654     } ## end for ($i = $skip ; $i < ...
6655
6656     # Restore the trace value again.
6657     $trace = $otrace;
6658     @sub;
6659 } ## end sub dump_trace
6660
6661 =head2 C<action()>
6662
6663 C<action()> takes input provided as the argument to an add-action command,
6664 either pre- or post-, and makes sure it's a complete command. It doesn't do
6665 any fancy parsing; it just keeps reading input until it gets a string
6666 without a trailing backslash.
6667
6668 =cut
6669
6670 sub action {
6671     my $action = shift;
6672
6673     while ( $action =~ s/\\$// ) {
6674
6675         # We have a backslash on the end. Read more.
6676         $action .= gets();
6677     } ## end while ($action =~ s/\\$//)
6678
6679     # Return the assembled action.
6680     $action;
6681 } ## end sub action
6682
6683 =head2 unbalanced
6684
6685 This routine mostly just packages up a regular expression to be used
6686 to check that the thing it's being matched against has properly-matched
6687 curly braces.
6688
6689 Of note is the definition of the C<$balanced_brace_re> global via C<||=>, which
6690 speeds things up by only creating the qr//'ed expression once; if it's
6691 already defined, we don't try to define it again. A speed hack.
6692
6693 =cut
6694
6695 use vars qw($balanced_brace_re);
6696
6697 sub unbalanced {
6698
6699     # I hate using globals!
6700     $balanced_brace_re ||= qr{
6701         ^ \{
6702              (?:
6703                  (?> [^{}] + )              # Non-parens without backtracking
6704                 |
6705                  (??{ $balanced_brace_re }) # Group with matching parens
6706               ) *
6707           \} $
6708    }x;
6709     return $_[0] !~ m/$balanced_brace_re/;
6710 } ## end sub unbalanced
6711
6712 =head2 C<gets()>
6713
6714 C<gets()> is a primitive (very primitive) routine to read continuations.
6715 It was devised for reading continuations for actions.
6716 it just reads more input with C<readline()> and returns it.
6717
6718 =cut
6719
6720 sub gets {
6721     return DB::readline("cont: ");
6722 }
6723
6724 =head2 C<_db_system()> - handle calls to<system()> without messing up the debugger
6725
6726 The C<system()> function assumes that it can just go ahead and use STDIN and
6727 STDOUT, but under the debugger, we want it to use the debugger's input and
6728 outout filehandles.
6729
6730 C<_db_system()> socks away the program's STDIN and STDOUT, and then substitutes
6731 the debugger's IN and OUT filehandles for them. It does the C<system()> call,
6732 and then puts everything back again.
6733
6734 =cut
6735
6736 sub _db_system {
6737
6738     # We save, change, then restore STDIN and STDOUT to avoid fork() since
6739     # some non-Unix systems can do system() but have problems with fork().
6740     open( SAVEIN,  "<&STDIN" )  || _db_warn("Can't save STDIN");
6741     open( SAVEOUT, ">&STDOUT" ) || _db_warn("Can't save STDOUT");
6742     open( STDIN,   "<&IN" )     || _db_warn("Can't redirect STDIN");
6743     open( STDOUT,  ">&OUT" )    || _db_warn("Can't redirect STDOUT");
6744
6745     # XXX: using csh or tcsh destroys sigint retvals!
6746     system(@_);
6747     open( STDIN,  "<&SAVEIN" )  || _db_warn("Can't restore STDIN");
6748     open( STDOUT, ">&SAVEOUT" ) || _db_warn("Can't restore STDOUT");
6749     close(SAVEIN);
6750     close(SAVEOUT);
6751
6752     # most of the $? crud was coping with broken cshisms
6753     if ( $? >> 8 ) {
6754         _db_warn( "(Command exited ", ( $? >> 8 ), ")\n" );
6755     }
6756     elsif ($?) {
6757         _db_warn(
6758             "(Command died of SIG#",
6759             ( $? & 127 ),
6760             ( ( $? & 128 ) ? " -- core dumped" : "" ),
6761             ")", "\n"
6762         );
6763     } ## end elsif ($?)
6764
6765     return $?;
6766
6767 } ## end sub system
6768
6769 *system = \&_db_system;
6770
6771 =head1 TTY MANAGEMENT
6772
6773 The subs here do some of the terminal management for multiple debuggers.
6774
6775 =head2 setterm
6776
6777 Top-level function called when we want to set up a new terminal for use
6778 by the debugger.
6779
6780 If the C<noTTY> debugger option was set, we'll either use the terminal
6781 supplied (the value of the C<noTTY> option), or we'll use C<Term::Rendezvous>
6782 to find one. If we're a forked debugger, we call C<resetterm> to try to
6783 get a whole new terminal if we can.
6784
6785 In either case, we set up the terminal next. If the C<ReadLine> option was
6786 true, we'll get a C<Term::ReadLine> object for the current terminal and save
6787 the appropriate attributes. We then
6788
6789 =cut
6790
6791 use vars qw($ornaments);
6792 use vars qw($rl_attribs);
6793
6794 sub setterm {
6795
6796     # Load Term::Readline, but quietly; don't debug it and don't trace it.
6797     local $frame = 0;
6798     local $doret = -2;
6799     require Term::ReadLine;
6800
6801     # If noTTY is set, but we have a TTY name, go ahead and hook up to it.
6802     if ($notty) {
6803         if ($tty) {
6804             my ( $i, $o ) = split $tty, /,/;
6805             $o = $i unless defined $o;
6806             open( IN,  "<$i" ) or die "Cannot open TTY '$i' for read: $!";
6807             open( OUT, ">$o" ) or die "Cannot open TTY '$o' for write: $!";
6808             $IN  = \*IN;
6809             $OUT = \*OUT;
6810             _autoflush($OUT);
6811         } ## end if ($tty)
6812
6813         # We don't have a TTY - try to find one via Term::Rendezvous.
6814         else {
6815             require Term::Rendezvous;
6816
6817             # See if we have anything to pass to Term::Rendezvous.
6818             # Use $HOME/.perldbtty$$ if not.
6819             my $rv = $ENV{PERLDB_NOTTY} || "$ENV{HOME}/.perldbtty$$";
6820
6821             # Rendezvous and get the filehandles.
6822             my $term_rv = Term::Rendezvous->new( $rv );
6823             $IN  = $term_rv->IN;
6824             $OUT = $term_rv->OUT;
6825         } ## end else [ if ($tty)
6826     } ## end if ($notty)
6827
6828     # We're a daughter debugger. Try to fork off another TTY.
6829     if ( $term_pid eq '-1' ) {    # In a TTY with another debugger
6830         resetterm(2);
6831     }
6832
6833     # If we shouldn't use Term::ReadLine, don't.
6834     if ( !$rl ) {
6835         $term = Term::ReadLine::Stub->new( 'perldb', $IN, $OUT );
6836     }
6837
6838     # We're using Term::ReadLine. Get all the attributes for this terminal.
6839     else {
6840         $term = Term::ReadLine->new( 'perldb', $IN, $OUT );
6841
6842         $rl_attribs = $term->Attribs;
6843         $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}'
6844           if defined $rl_attribs->{basic_word_break_characters}
6845           and index( $rl_attribs->{basic_word_break_characters}, ":" ) == -1;
6846         $rl_attribs->{special_prefixes} = '$@&%';
6847         $rl_attribs->{completer_word_break_characters} .= '$@&%';
6848         $rl_attribs->{completion_function} = \&db_complete;
6849     } ## end else [ if (!$rl)
6850
6851     # Set up the LINEINFO filehandle.
6852     $LINEINFO = $OUT     unless defined $LINEINFO;
6853     $lineinfo = $console unless defined $lineinfo;
6854
6855     $term->MinLine(2);
6856
6857     load_hist();
6858
6859     if ( $term->Features->{setHistory} and "@hist" ne "?" ) {
6860         $term->SetHistory(@hist);
6861     }
6862
6863     # XXX Ornaments are turned on unconditionally, which is not
6864     # always a good thing.
6865     ornaments($ornaments) if defined $ornaments;
6866     $term_pid = $$;
6867 } ## end sub setterm
6868
6869 sub load_hist {
6870     $histfile //= option_val("HistFile", undef);
6871     return unless defined $histfile;
6872     open my $fh, "<", $histfile or return;
6873     local $/ = "\n";
6874     @hist = ();
6875     while (<$fh>) {
6876         chomp;
6877         push @hist, $_;
6878     }
6879     close $fh;
6880 }
6881
6882 sub save_hist {
6883     return unless defined $histfile;
6884     eval { require File::Path } or return;
6885     eval { require File::Basename } or return;
6886     File::Path::mkpath(File::Basename::dirname($histfile));
6887     open my $fh, ">", $histfile or die "Could not open '$histfile': $!";
6888     $histsize //= option_val("HistSize",100);
6889     my @copy = grep { $_ ne '?' } @hist;
6890     my $start = scalar(@copy) > $histsize ? scalar(@copy)-$histsize : 0;
6891     for ($start .. $#copy) {
6892         print $fh "$copy[$_]\n";
6893     }
6894     close $fh or die "Could not write '$histfile': $!";
6895 }
6896
6897 =head1 GET_FORK_TTY EXAMPLE FUNCTIONS
6898
6899 When the process being debugged forks, or the process invokes a command
6900 via C<system()> which starts a new debugger, we need to be able to get a new
6901 C<IN> and C<OUT> filehandle for the new debugger. Otherwise, the two processes
6902 fight over the terminal, and you can never quite be sure who's going to get the
6903 input you're typing.
6904
6905 C<get_fork_TTY> is a glob-aliased function which calls the real function that
6906 is tasked with doing all the necessary operating system mojo to get a new
6907 TTY (and probably another window) and to direct the new debugger to read and
6908 write there.
6909
6910 The debugger provides C<get_fork_TTY> functions which work for TCP
6911 socket servers, X11, OS/2, and Mac OS X. Other systems are not
6912 supported. You are encouraged to write C<get_fork_TTY> functions which
6913 work for I<your> platform and contribute them.
6914
6915 =head3 C<socket_get_fork_TTY>
6916
6917 =cut
6918
6919 sub connect_remoteport {
6920     require IO::Socket;
6921
6922     my $socket = IO::Socket::INET->new(
6923         Timeout  => '10',
6924         PeerAddr => $remoteport,
6925         Proto    => 'tcp',
6926     );
6927     if ( ! $socket ) {
6928         die "Unable to connect to remote host: $remoteport\n";
6929     }
6930     return $socket;
6931 }
6932
6933 sub socket_get_fork_TTY {
6934     $tty = $LINEINFO = $IN = $OUT = connect_remoteport();
6935
6936     # Do I need to worry about setting $term?
6937
6938     reset_IN_OUT( $IN, $OUT );
6939     return '';
6940 }
6941
6942 =head3 C<xterm_get_fork_TTY>
6943
6944 This function provides the C<get_fork_TTY> function for X11. If a
6945 program running under the debugger forks, a new <xterm> window is opened and
6946 the subsidiary debugger is directed there.
6947
6948 The C<open()> call is of particular note here. We have the new C<xterm>
6949 we're spawning route file number 3 to STDOUT, and then execute the C<tty>
6950 command (which prints the device name of the TTY we'll want to use for input
6951 and output to STDOUT, then C<sleep> for a very long time, routing this output
6952 to file number 3. This way we can simply read from the <XT> filehandle (which
6953 is STDOUT from the I<commands> we ran) to get the TTY we want to use.
6954
6955 Only works if C<xterm> is in your path and C<$ENV{DISPLAY}>, etc. are
6956 properly set up.
6957
6958 =cut
6959
6960 sub xterm_get_fork_TTY {
6961     ( my $name = $0 ) =~ s,^.*[/\\],,s;
6962     open XT,
6963 qq[3>&1 xterm -title "Daughter Perl debugger $pids $name" -e sh -c 'tty 1>&3;\
6964  sleep 10000000' |];
6965
6966     # Get the output from 'tty' and clean it up a little.
6967     my $tty = <XT>;
6968     chomp $tty;
6969
6970     $pidprompt = '';    # Shown anyway in titlebar
6971
6972     # We need $term defined or we can not switch to the newly created xterm
6973     if ($tty ne '' && !defined $term) {
6974         require Term::ReadLine;
6975         if ( !$rl ) {
6976             $term = Term::ReadLine::Stub->new( 'perldb', $IN, $OUT );
6977         }
6978         else {
6979             $term = Term::ReadLine->new( 'perldb', $IN, $OUT );
6980         }
6981     }
6982     # There's our new TTY.
6983     return $tty;
6984 } ## end sub xterm_get_fork_TTY
6985
6986 =head3 C<os2_get_fork_TTY>
6987
6988 XXX It behooves an OS/2 expert to write the necessary documentation for this!
6989
6990 =cut
6991
6992 # This example function resets $IN, $OUT itself
6993 my $c_pipe = 0;
6994 sub os2_get_fork_TTY { # A simplification of the following (and works without):
6995     local $\  = '';
6996     ( my $name = $0 ) =~ s,^.*[/\\],,s;
6997     my %opt = ( title => "Daughter Perl debugger $pids $name",
6998         ($rl ? (read_by_key => 1) : ()) );
6999     require OS2::Process;
7000     my ($in, $out, $pid) = eval { OS2::Process::io_term(related => 0, %opt) }
7001       or return;
7002     $pidprompt = '';    # Shown anyway in titlebar
7003     reset_IN_OUT($in, $out);
7004     $tty = '*reset*';
7005     return '';          # Indicate that reset_IN_OUT is called
7006 } ## end sub os2_get_fork_TTY
7007
7008 =head3 C<macosx_get_fork_TTY>
7009
7010 The Mac OS X version uses AppleScript to tell Terminal.app to create
7011 a new window.
7012
7013 =cut
7014
7015 # Notes about Terminal.app's AppleScript support,
7016 # (aka things that might break in future OS versions).
7017 #
7018 # The "do script" command doesn't return a reference to the new window
7019 # it creates, but since it appears frontmost and windows are enumerated
7020 # front to back, we can use "first window" === "window 1".
7021 #
7022 # Since "do script" is implemented by supplying the argument (plus a
7023 # return character) as terminal input, there's a potential race condition
7024 # where the debugger could beat the shell to reading the command.
7025 # To prevent this, we wait for the screen to clear before proceeding.
7026 #
7027 # 10.3 and 10.4:
7028 # There's no direct accessor for the tty device name, so we fiddle
7029 # with the window title options until it says what we want.
7030 #
7031 # 10.5:
7032 # There _is_ a direct accessor for the tty device name, _and_ there's
7033 # a new possible component of the window title (the name of the settings
7034 # set).  A separate version is needed.
7035
7036 my @script_versions=
7037
7038     ([237, <<'__LEOPARD__'],
7039 tell application "Terminal"
7040     do script "clear;exec sleep 100000"
7041     tell first tab of first window
7042         copy tty to thetty
7043         set custom title to "forked perl debugger"
7044         set title displays custom title to true
7045         repeat while (length of first paragraph of (get contents)) > 0
7046             delay 0.1
7047         end repeat
7048     end tell
7049 end tell
7050 thetty
7051 __LEOPARD__
7052
7053      [100, <<'__JAGUAR_TIGER__'],
7054 tell application "Terminal"
7055     do script "clear;exec sleep 100000"
7056     tell first window
7057         set title displays shell path to false
7058         set title displays window size to false
7059         set title displays file name to false
7060         set title displays device name to true
7061         set title displays custom title to true
7062         set custom title to ""
7063         copy "/dev/" & name to thetty
7064         set custom title to "forked perl debugger"
7065         repeat while (length of first paragraph of (get contents)) > 0
7066             delay 0.1
7067         end repeat
7068     end tell
7069 end tell
7070 thetty
7071 __JAGUAR_TIGER__
7072
7073 );
7074
7075 sub macosx_get_fork_TTY
7076 {
7077     my($version,$script,$pipe,$tty);
7078
7079     return unless $version=$ENV{TERM_PROGRAM_VERSION};
7080     foreach my $entry (@script_versions) {
7081         if ($version>=$entry->[0]) {
7082             $script=$entry->[1];
7083             last;
7084         }
7085     }
7086     return unless defined($script);
7087     return unless open($pipe,'-|','/usr/bin/osascript','-e',$script);
7088     $tty=readline($pipe);
7089     close($pipe);
7090     return unless defined($tty) && $tty =~ m(^/dev/);
7091     chomp $tty;
7092     return $tty;
7093 }
7094
7095 =head3 C<tmux_get_fork_TTY>
7096
7097 Creates a split window for subprocesses when a process running under the
7098 perl debugger in Tmux forks.
7099
7100 =cut
7101
7102 sub tmux_get_fork_TTY {
7103     return unless $ENV{TMUX};
7104
7105     my $pipe;
7106
7107     my $status = open $pipe, '-|', 'tmux', 'split-window',
7108         '-P', '-F', '#{pane_tty}', 'sleep 100000';
7109
7110     if ( !$status ) {
7111         return;
7112     }
7113
7114     my $tty = <$pipe>;
7115     close $pipe;
7116
7117     if ( $tty ) {
7118         chomp $tty;
7119
7120         if ( !defined $term ) {
7121             require Term::ReadLine;
7122             if ( !$rl ) {
7123                 $term = Term::ReadLine::Stub->new( 'perldb', $IN, $OUT );
7124             }
7125             else {
7126                 $term = Term::ReadLine->new( 'perldb', $IN, $OUT );
7127             }
7128         }
7129     }
7130
7131     return $tty;
7132 }
7133
7134 =head2 C<create_IN_OUT($flags)>
7135
7136 Create a new pair of filehandles, pointing to a new TTY. If impossible,
7137 try to diagnose why.
7138
7139 Flags are:
7140
7141 =over 4
7142
7143 =item * 1 - Don't know how to create a new TTY.
7144
7145 =item * 2 - Debugger has forked, but we can't get a new TTY.
7146
7147 =item * 4 - standard debugger startup is happening.
7148
7149 =back
7150
7151 =cut
7152
7153 use vars qw($fork_TTY);
7154
7155 sub create_IN_OUT {    # Create a window with IN/OUT handles redirected there
7156
7157     # If we know how to get a new TTY, do it! $in will have
7158     # the TTY name if get_fork_TTY works.
7159     my $in = get_fork_TTY(@_) if defined &get_fork_TTY;
7160
7161     # It used to be that
7162     $in = $fork_TTY if defined $fork_TTY;    # Backward compatibility
7163
7164     if ( not defined $in ) {
7165         my $why = shift;
7166
7167         # We don't know how.
7168         print_help(<<EOP) if $why == 1;
7169 I<#########> Forked, but do not know how to create a new B<TTY>. I<#########>
7170 EOP
7171
7172         # Forked debugger.
7173         print_help(<<EOP) if $why == 2;
7174 I<#########> Daughter session, do not know how to change a B<TTY>. I<#########>
7175   This may be an asynchronous session, so the parent debugger may be active.
7176 EOP
7177
7178         # Note that both debuggers are fighting over the same input.
7179         print_help(<<EOP) if $why != 4;
7180   Since two debuggers fight for the same TTY, input is severely entangled.
7181
7182 EOP
7183         print_help(<<EOP);
7184   I know how to switch the output to a different window in xterms, OS/2
7185   consoles, and Mac OS X Terminal.app only.  For a manual switch, put the name
7186   of the created I<TTY> in B<\$DB::fork_TTY>, or define a function
7187   B<DB::get_fork_TTY()> returning this.
7188
7189   On I<UNIX>-like systems one can get the name of a I<TTY> for the given window
7190   by typing B<tty>, and disconnect the I<shell> from I<TTY> by B<sleep 1000000>.
7191
7192 EOP
7193     } ## end if (not defined $in)
7194     elsif ( $in ne '' ) {
7195         TTY($in);
7196     }
7197     else {
7198         $console = '';    # Indicate no need to open-from-the-console
7199     }
7200     undef $fork_TTY;
7201 } ## end sub create_IN_OUT
7202
7203 =head2 C<resetterm>
7204
7205 Handles rejiggering the prompt when we've forked off a new debugger.
7206
7207 If the new debugger happened because of a C<system()> that invoked a
7208 program under the debugger, the arrow between the old pid and the new
7209 in the prompt has I<two> dashes instead of one.
7210
7211 We take the current list of pids and add this one to the end. If there
7212 isn't any list yet, we make one up out of the initial pid associated with
7213 the terminal and our new pid, sticking an arrow (either one-dashed or
7214 two dashed) in between them.
7215
7216 If C<CreateTTY> is off, or C<resetterm> was called with no arguments,
7217 we don't try to create a new IN and OUT filehandle. Otherwise, we go ahead
7218 and try to do that.
7219
7220 =cut
7221
7222 sub resetterm {    # We forked, so we need a different TTY
7223
7224     # Needs to be passed to create_IN_OUT() as well.
7225     my $in = shift;
7226
7227     # resetterm(2): got in here because of a system() starting a debugger.
7228     # resetterm(1): just forked.
7229     my $systemed = $in > 1 ? '-' : '';
7230
7231     # If there's already a list of pids, add this to the end.
7232     if ($pids) {
7233         $pids =~ s/\]/$systemed->$$]/;
7234     }
7235
7236     # No pid list. Time to make one.
7237     else {
7238         $pids = "[$term_pid->$$]";
7239     }
7240
7241     # The prompt we're going to be using for this debugger.
7242     $pidprompt = $pids;
7243
7244     # We now 0wnz this terminal.
7245     $term_pid = $$;
7246
7247     # Just return if we're not supposed to try to create a new TTY.
7248     return unless $CreateTTY & $in;
7249
7250     # Try to create a new IN/OUT pair.
7251     create_IN_OUT($in);
7252 } ## end sub resetterm
7253
7254 =head2 C<readline>
7255
7256 First, we handle stuff in the typeahead buffer. If there is any, we shift off
7257 the next line, print a message saying we got it, add it to the terminal
7258 history (if possible), and return it.
7259
7260 If there's nothing in the typeahead buffer, check the command filehandle stack.
7261 If there are any filehandles there, read from the last one, and return the line
7262 if we got one. If not, we pop the filehandle off and close it, and try the
7263 next one up the stack.
7264
7265 If we've emptied the filehandle stack, we check to see if we've got a socket
7266 open, and we read that and return it if we do. If we don't, we just call the
7267 core C<readline()> and return its value.
7268
7269 =cut
7270
7271 sub readline {
7272
7273     # Localize to prevent it from being smashed in the program being debugged.
7274     local $.;
7275
7276     # If there are stacked filehandles to read from ...
7277     # (Handle it before the typeahead, because we may call source/etc. from
7278     # the typeahead.)
7279     while (@cmdfhs) {
7280
7281         # Read from the last one in the stack.
7282         my $line = CORE::readline( $cmdfhs[-1] );
7283
7284         # If we got a line ...
7285         defined $line
7286           ? ( print $OUT ">> $line" and return $line )    # Echo and return
7287           : close pop @cmdfhs;                            # Pop and close
7288     } ## end while (@cmdfhs)
7289
7290     # Pull a line out of the typeahead if there's stuff there.
7291     if (@typeahead) {
7292
7293         # How many lines left.
7294         my $left = @typeahead;
7295
7296         # Get the next line.
7297         my $got = shift @typeahead;
7298
7299         # Print a message saying we got input from the typeahead.
7300         local $\ = '';
7301         print $OUT "auto(-$left)", shift, $got, "\n";
7302
7303         # Add it to the terminal history (if possible).
7304         $term->AddHistory($got)
7305           if length($got) > 1
7306           and defined $term->Features->{addHistory};
7307         return $got;
7308     } ## end if (@typeahead)
7309
7310     # We really need to read some input. Turn off entry/exit trace and
7311     # return value printing.
7312     local $frame = 0;
7313     local $doret = -2;
7314
7315     # Nothing on the filehandle stack. Socket?
7316     if ( ref $OUT and UNIVERSAL::isa( $OUT, 'IO::Socket::INET' ) ) {
7317
7318         # Send anything we have to send.
7319         $OUT->write( join( '', @_ ) );
7320
7321         # Receive anything there is to receive.
7322  &nb