This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Allow debugger aliases that start with '-' and '.'
[perl5.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 See L<perldebug> for an overview of how to use the debugger.
18
19 =head1 GENERAL NOTES
20
21 The debugger can look pretty forbidding to many Perl programmers. There are
22 a number of reasons for this, many stemming out of the debugger's history.
23
24 When the debugger was first written, Perl didn't have a lot of its nicer
25 features - no references, no lexical variables, no closures, no object-oriented
26 programming. So a lot of the things one would normally have done using such
27 features was done using global variables, globs and the C<local()> operator
28 in creative ways.
29
30 Some of these have survived into the current debugger; a few of the more
31 interesting and still-useful idioms are noted in this section, along with notes
32 on the comments themselves.
33
34 =head2 Why not use more lexicals?
35
36 Experienced Perl programmers will note that the debugger code tends to use
37 mostly package globals rather than lexically-scoped variables. This is done
38 to allow a significant amount of control of the debugger from outside the
39 debugger itself.
40
41 Unfortunately, though the variables are accessible, they're not well
42 documented, so it's generally been a decision that hasn't made a lot of
43 difference to most users. Where appropriate, comments have been added to
44 make variables more accessible and usable, with the understanding that these
45 I<are> debugger internals, and are therefore subject to change. Future
46 development should probably attempt to replace the globals with a well-defined
47 API, but for now, the variables are what we've got.
48
49 =head2 Automated variable stacking via C<local()>
50
51 As you may recall from reading C<perlfunc>, the C<local()> operator makes a
52 temporary copy of a variable in the current scope. When the scope ends, the
53 old copy is restored. This is often used in the debugger to handle the
54 automatic stacking of variables during recursive calls:
55
56      sub foo {
57         local $some_global++;
58
59         # Do some stuff, then ...
60         return;
61      }
62
63 What happens is that on entry to the subroutine, C<$some_global> is localized,
64 then altered. When the subroutine returns, Perl automatically undoes the
65 localization, restoring the previous value. Voila, automatic stack management.
66
67 The debugger uses this trick a I<lot>. Of particular note is C<DB::eval>,
68 which lets the debugger get control inside of C<eval>'ed code. The debugger
69 localizes a saved copy of C<$@> inside the subroutine, which allows it to
70 keep C<$@> safe until it C<DB::eval> returns, at which point the previous
71 value of C<$@> is restored. This makes it simple (well, I<simpler>) to keep
72 track of C<$@> inside C<eval>s which C<eval> other C<eval's>.
73
74 In any case, watch for this pattern. It occurs fairly often.
75
76 =head2 The C<^> trick
77
78 This is used to cleverly reverse the sense of a logical test depending on
79 the value of an auxiliary variable. For instance, the debugger's C<S>
80 (search for subroutines by pattern) allows you to negate the pattern
81 like this:
82
83    # Find all non-'foo' subs:
84    S !/foo/
85
86 Boolean algebra states that the truth table for XOR looks like this:
87
88 =over 4
89
90 =item * 0 ^ 0 = 0
91
92 (! not present and no match) --> false, don't print
93
94 =item * 0 ^ 1 = 1
95
96 (! not present and matches) --> true, print
97
98 =item * 1 ^ 0 = 1
99
100 (! present and no match) --> true, print
101
102 =item * 1 ^ 1 = 0
103
104 (! present and matches) --> false, don't print
105
106 =back
107
108 As you can see, the first pair applies when C<!> isn't supplied, and
109 the second pair applies when it is. The XOR simply allows us to
110 compact a more complicated if-then-elseif-else into a more elegant
111 (but perhaps overly clever) single test. After all, it needed this
112 explanation...
113
114 =head2 FLAGS, FLAGS, FLAGS
115
116 There is a certain C programming legacy in the debugger. Some variables,
117 such as C<$single>, C<$trace>, and C<$frame>, have I<magical> values composed
118 of 1, 2, 4, etc. (powers of 2) OR'ed together. This allows several pieces
119 of state to be stored independently in a single scalar.
120
121 A test like
122
123     if ($scalar & 4) ...
124
125 is checking to see if the appropriate bit is on. Since each bit can be
126 "addressed" independently in this way, C<$scalar> is acting sort of like
127 an array of bits. Obviously, since the contents of C<$scalar> are just a
128 bit-pattern, we can save and restore it easily (it will just look like
129 a number).
130
131 The problem, is of course, that this tends to leave magic numbers scattered
132 all over your program whenever a bit is set, cleared, or checked. So why do
133 it?
134
135 =over 4
136
137 =item *
138
139 First, doing an arithmetical or bitwise operation on a scalar is
140 just about the fastest thing you can do in Perl: C<use constant> actually
141 creates a subroutine call, and array and hash lookups are much slower. Is
142 this over-optimization at the expense of readability? Possibly, but the
143 debugger accesses these  variables a I<lot>. Any rewrite of the code will
144 probably have to benchmark alternate implementations and see which is the
145 best balance of readability and speed, and then document how it actually
146 works.
147
148 =item *
149
150 Second, it's very easy to serialize a scalar number. This is done in
151 the restart code; the debugger state variables are saved in C<%ENV> and then
152 restored when the debugger is restarted. Having them be just numbers makes
153 this trivial.
154
155 =item *
156
157 Third, some of these variables are being shared with the Perl core
158 smack in the middle of the interpreter's execution loop. It's much faster for
159 a C program (like the interpreter) to check a bit in a scalar than to access
160 several different variables (or a Perl array).
161
162 =back
163
164 =head2 What are those C<XXX> comments for?
165
166 Any comment containing C<XXX> means that the comment is either somewhat
167 speculative - it's not exactly clear what a given variable or chunk of
168 code is doing, or that it is incomplete - the basics may be clear, but the
169 subtleties are not completely documented.
170
171 Send in a patch if you can clear up, fill out, or clarify an C<XXX>.
172
173 =head1 DATA STRUCTURES MAINTAINED BY CORE
174
175 There are a number of special data structures provided to the debugger by
176 the Perl interpreter.
177
178 The array C<@{$main::{'_<'.$filename}}> (aliased locally to C<@dbline>
179 via glob assignment) contains the text from C<$filename>, with each
180 element corresponding to a single line of C<$filename>. Additionally,
181 breakable lines will be dualvars with the numeric component being the
182 memory address of a COP node. Non-breakable lines are dualvar to 0.
183
184 The hash C<%{'_<'.$filename}> (aliased locally to C<%dbline> via glob
185 assignment) contains breakpoints and actions.  The keys are line numbers;
186 you can set individual values, but not the whole hash. The Perl interpreter
187 uses this hash to determine where breakpoints have been set. Any true value is
188 considered to be a breakpoint; C<perl5db.pl> uses C<$break_condition\0$action>.
189 Values are magical in numeric context: 1 if the line is breakable, 0 if not.
190
191 The scalar C<${"_<$filename"}> simply contains the string C<$filename>.
192 This is also the case for evaluated strings that contain subroutines, or
193 which are currently being executed.  The $filename for C<eval>ed strings looks
194 like C<(eval 34)>.
195
196 =head1 DEBUGGER STARTUP
197
198 When C<perl5db.pl> starts, it reads an rcfile (C<perl5db.ini> for
199 non-interactive sessions, C<.perldb> for interactive ones) that can set a number
200 of options. In addition, this file may define a subroutine C<&afterinit>
201 that will be executed (in the debugger's context) after the debugger has
202 initialized itself.
203
204 Next, it checks the C<PERLDB_OPTS> environment variable and treats its
205 contents as the argument of a C<o> command in the debugger.
206
207 =head2 STARTUP-ONLY OPTIONS
208
209 The following options can only be specified at startup.
210 To set them in your rcfile, add a call to
211 C<&parse_options("optionName=new_value")>.
212
213 =over 4
214
215 =item * TTY
216
217 the TTY to use for debugging i/o.
218
219 =item * noTTY
220
221 if set, goes in NonStop mode.  On interrupt, if TTY is not set,
222 uses the value of noTTY or F<$HOME/.perldbtty$$> to find TTY using
223 Term::Rendezvous.  Current variant is to have the name of TTY in this
224 file.
225
226 =item * ReadLine
227
228 if false, a dummy ReadLine is used, so you can debug
229 ReadLine applications.
230
231 =item * NonStop
232
233 if true, no i/o is performed until interrupt.
234
235 =item * LineInfo
236
237 file or pipe to print line number info to.  If it is a
238 pipe, a short "emacs like" message is used.
239
240 =item * RemotePort
241
242 host:port to connect to on remote host for remote debugging.
243
244 =item * HistFile
245
246 file to store session history to. There is no default and so no
247 history file is written unless this variable is explicitly set.
248
249 =item * HistSize
250
251 number of commands to store to the file specified in C<HistFile>.
252 Default is 100.
253
254 =back
255
256 =head3 SAMPLE RCFILE
257
258  &parse_options("NonStop=1 LineInfo=db.out");
259   sub afterinit { $trace = 1; }
260
261 The script will run without human intervention, putting trace
262 information into C<db.out>.  (If you interrupt it, you had better
263 reset C<LineInfo> to something I<interactive>!)
264
265 =head1 INTERNALS DESCRIPTION
266
267 =head2 DEBUGGER INTERFACE VARIABLES
268
269 Perl supplies the values for C<%sub>.  It effectively inserts
270 a C<&DB::DB();> in front of each place that can have a
271 breakpoint. At each subroutine call, it calls C<&DB::sub> with
272 C<$DB::sub> set to the called subroutine. It also inserts a C<BEGIN
273 {require 'perl5db.pl'}> before the first line.
274
275 After each C<require>d file is compiled, but before it is executed, a
276 call to C<&DB::postponed($main::{'_<'.$filename})> is done. C<$filename>
277 is the expanded name of the C<require>d file (as found via C<%INC>).
278
279 =head3 IMPORTANT INTERNAL VARIABLES
280
281 =head4 C<$CreateTTY>
282
283 Used to control when the debugger will attempt to acquire another TTY to be
284 used for input.
285
286 =over
287
288 =item * 1 -  on C<fork()>
289
290 =item * 2 - debugger is started inside debugger
291
292 =item * 4 -  on startup
293
294 =back
295
296 =head4 C<$doret>
297
298 The value -2 indicates that no return value should be printed.
299 Any other positive value causes C<DB::sub> to print return values.
300
301 =head4 C<$evalarg>
302
303 The item to be eval'ed by C<DB::eval>. Used to prevent messing with the current
304 contents of C<@_> when C<DB::eval> is called.
305
306 =head4 C<$frame>
307
308 Determines what messages (if any) will get printed when a subroutine (or eval)
309 is entered or exited.
310
311 =over 4
312
313 =item * 0 -  No enter/exit messages
314
315 =item * 1 - Print I<entering> messages on subroutine entry
316
317 =item * 2 - Adds exit messages on subroutine exit. If no other flag is on, acts like 1+2.
318
319 =item * 4 - Extended messages: C<< <in|out> I<context>=I<fully-qualified sub name> from I<file>:I<line> >>. If no other flag is on, acts like 1+4.
320
321 =item * 8 - Adds parameter information to messages, and overloaded stringify and tied FETCH is enabled on the printed arguments. Ignored if C<4> is not on.
322
323 =item * 16 - Adds C<I<context> return from I<subname>: I<value>> messages on subroutine/eval exit. Ignored if C<4> is not on.
324
325 =back
326
327 To get everything, use C<$frame=30> (or C<o f=30> as a debugger command).
328 The debugger internally juggles the value of C<$frame> during execution to
329 protect external modules that the debugger uses from getting traced.
330
331 =head4 C<$level>
332
333 Tracks current debugger nesting level. Used to figure out how many
334 C<E<lt>E<gt>> pairs to surround the line number with when the debugger
335 outputs a prompt. Also used to help determine if the program has finished
336 during command parsing.
337
338 =head4 C<$onetimeDump>
339
340 Controls what (if anything) C<DB::eval()> will print after evaluating an
341 expression.
342
343 =over 4
344
345 =item * C<undef> - don't print anything
346
347 =item * C<dump> - use C<dumpvar.pl> to display the value returned
348
349 =item * C<methods> - print the methods callable on the first item returned
350
351 =back
352
353 =head4 C<$onetimeDumpDepth>
354
355 Controls how far down C<dumpvar.pl> will go before printing C<...> while
356 dumping a structure. Numeric. If C<undef>, print all levels.
357
358 =head4 C<$signal>
359
360 Used to track whether or not an C<INT> signal has been detected. C<DB::DB()>,
361 which is called before every statement, checks this and puts the user into
362 command mode if it finds C<$signal> set to a true value.
363
364 =head4 C<$single>
365
366 Controls behavior during single-stepping. Stacked in C<@stack> on entry to
367 each subroutine; popped again at the end of each subroutine.
368
369 =over 4
370
371 =item * 0 - run continuously.
372
373 =item * 1 - single-step, go into subs. The C<s> command.
374
375 =item * 2 - single-step, don't go into subs. The C<n> command.
376
377 =item * 4 - print current sub depth (turned on to force this when C<too much
378 recursion> occurs.
379
380 =back
381
382 =head4 C<$trace>
383
384 Controls the output of trace information.
385
386 =over 4
387
388 =item * 1 - The C<t> command was entered to turn on tracing (every line executed is printed)
389
390 =item * 2 - watch expressions are active
391
392 =item * 4 - user defined a C<watchfunction()> in C<afterinit()>
393
394 =back
395
396 =head4 C<$slave_editor>
397
398 1 if C<LINEINFO> was directed to a pipe; 0 otherwise.
399
400 =head4 C<@cmdfhs>
401
402 Stack of filehandles that C<DB::readline()> will read commands from.
403 Manipulated by the debugger's C<source> command and C<DB::readline()> itself.
404
405 =head4 C<@dbline>
406
407 Local alias to the magical line array, C<@{$main::{'_<'.$filename}}> ,
408 supplied by the Perl interpreter to the debugger. Contains the source.
409
410 =head4 C<@old_watch>
411
412 Previous values of watch expressions. First set when the expression is
413 entered; reset whenever the watch expression changes.
414
415 =head4 C<@saved>
416
417 Saves important globals (C<$@>, C<$!>, C<$^E>, C<$,>, C<$/>, C<$\>, C<$^W>)
418 so that the debugger can substitute safe values while it's running, and
419 restore them when it returns control.
420
421 =head4 C<@stack>
422
423 Saves the current value of C<$single> on entry to a subroutine.
424 Manipulated by the C<c> command to turn off tracing in all subs above the
425 current one.
426
427 =head4 C<@to_watch>
428
429 The 'watch' expressions: to be evaluated before each line is executed.
430
431 =head4 C<@typeahead>
432
433 The typeahead buffer, used by C<DB::readline>.
434
435 =head4 C<%alias>
436
437 Command aliases. Stored as character strings to be substituted for a command
438 entered.
439
440 =head4 C<%break_on_load>
441
442 Keys are file names, values are 1 (break when this file is loaded) or undef
443 (don't break when it is loaded).
444
445 =head4 C<%dbline>
446
447 Keys are line numbers, values are C<condition\0action>. If used in numeric
448 context, values are 0 if not breakable, 1 if breakable, no matter what is
449 in the actual hash entry.
450
451 =head4 C<%had_breakpoints>
452
453 Keys are file names; values are bitfields:
454
455 =over 4
456
457 =item * 1 - file has a breakpoint in it.
458
459 =item * 2 - file has an action in it.
460
461 =back
462
463 A zero or undefined value means this file has neither.
464
465 =head4 C<%option>
466
467 Stores the debugger options. These are character string values.
468
469 =head4 C<%postponed>
470
471 Saves breakpoints for code that hasn't been compiled yet.
472 Keys are subroutine names, values are:
473
474 =over 4
475
476 =item * C<compile> - break when this sub is compiled
477
478 =item * C<< break +0 if <condition> >> - break (conditionally) at the start of this routine. The condition will be '1' if no condition was specified.
479
480 =back
481
482 =head4 C<%postponed_file>
483
484 This hash keeps track of breakpoints that need to be set for files that have
485 not yet been compiled. Keys are filenames; values are references to hashes.
486 Each of these hashes is keyed by line number, and its values are breakpoint
487 definitions (C<condition\0action>).
488
489 =head1 DEBUGGER INITIALIZATION
490
491 The debugger's initialization actually jumps all over the place inside this
492 package. This is because there are several BEGIN blocks (which of course
493 execute immediately) spread through the code. Why is that?
494
495 The debugger needs to be able to change some things and set some things up
496 before the debugger code is compiled; most notably, the C<$deep> variable that
497 C<DB::sub> uses to tell when a program has recursed deeply. In addition, the
498 debugger has to turn off warnings while the debugger code is compiled, but then
499 restore them to their original setting before the program being debugged begins
500 executing.
501
502 The first C<BEGIN> block simply turns off warnings by saving the current
503 setting of C<$^W> and then setting it to zero. The second one initializes
504 the debugger variables that are needed before the debugger begins executing.
505 The third one puts C<$^X> back to its former value.
506
507 We'll detail the second C<BEGIN> block later; just remember that if you need
508 to initialize something before the debugger starts really executing, that's
509 where it has to go.
510
511 =cut
512
513 package DB;
514
515 use strict;
516
517 use Cwd ();
518
519 my $_initial_cwd;
520
521 BEGIN {eval 'use IO::Handle'}; # Needed for flush only? breaks under miniperl
522
523 BEGIN {
524     require feature;
525     $^V =~ /^v(\d+\.\d+)/;
526     feature->import(":$1");
527     $_initial_cwd = Cwd::getcwd();
528 }
529
530 # Debugger for Perl 5.00x; perl5db.pl patch level:
531 use vars qw($VERSION $header);
532
533 # bump to X.XX in blead, only use X.XX_XX in maint
534 $VERSION = '1.59';
535
536 $header = "perl5db.pl version $VERSION";
537
538 =head1 DEBUGGER ROUTINES
539
540 =head2 C<DB::eval()>
541
542 This function replaces straight C<eval()> inside the debugger; it simplifies
543 the process of evaluating code in the user's context.
544
545 The code to be evaluated is passed via the package global variable
546 C<$DB::evalarg>; this is done to avoid fiddling with the contents of C<@_>.
547
548 Before we do the C<eval()>, we preserve the current settings of C<$trace>,
549 C<$single>, C<$^D> and C<$usercontext>.  The latter contains the
550 preserved values of C<$@>, C<$!>, C<$^E>, C<$,>, C<$/>, C<$\>, C<$^W> and the
551 user's current package, grabbed when C<DB::DB> got control.  This causes the
552 proper context to be used when the eval is actually done.  Afterward, we
553 restore C<$trace>, C<$single>, and C<$^D>.
554
555 Next we need to handle C<$@> without getting confused. We save C<$@> in a
556 local lexical, localize C<$saved[0]> (which is where C<save()> will put
557 C<$@>), and then call C<save()> to capture C<$@>, C<$!>, C<$^E>, C<$,>,
558 C<$/>, C<$\>, and C<$^W>) and set C<$,>, C<$/>, C<$\>, and C<$^W> to values
559 considered sane by the debugger. If there was an C<eval()> error, we print
560 it on the debugger's output. If C<$onetimedump> is defined, we call
561 C<dumpit> if it's set to 'dump', or C<methods> if it's set to
562 'methods'. Setting it to something else causes the debugger to do the eval
563 but not print the result - handy if you want to do something else with it
564 (the "watch expressions" code does this to get the value of the watch
565 expression but not show it unless it matters).
566
567 In any case, we then return the list of output from C<eval> to the caller,
568 and unwinding restores the former version of C<$@> in C<@saved> as well
569 (the localization of C<$saved[0]> goes away at the end of this scope).
570
571 =head3 Parameters and variables influencing execution of DB::eval()
572
573 C<DB::eval> isn't parameterized in the standard way; this is to keep the
574 debugger's calls to C<DB::eval()> from mucking with C<@_>, among other things.
575 The variables listed below influence C<DB::eval()>'s execution directly.
576
577 =over 4
578
579 =item C<$evalarg> - the thing to actually be eval'ed
580
581 =item C<$trace> - Current state of execution tracing
582
583 =item C<$single> - Current state of single-stepping
584
585 =item C<$onetimeDump> - what is to be displayed after the evaluation
586
587 =item C<$onetimeDumpDepth> - how deep C<dumpit()> should go when dumping results
588
589 =back
590
591 The following variables are altered by C<DB::eval()> during its execution. They
592 are "stacked" via C<local()>, enabling recursive calls to C<DB::eval()>.
593
594 =over 4
595
596 =item C<@res> - used to capture output from actual C<eval>.
597
598 =item C<$otrace> - saved value of C<$trace>.
599
600 =item C<$osingle> - saved value of C<$single>.
601
602 =item C<$od> - saved value of C<$^D>.
603
604 =item C<$saved[0]> - saved value of C<$@>.
605
606 =item $\ - for output of C<$@> if there is an evaluation error.
607
608 =back
609
610 =head3 The problem of lexicals
611
612 The context of C<DB::eval()> presents us with some problems. Obviously,
613 we want to be 'sandboxed' away from the debugger's internals when we do
614 the eval, but we need some way to control how punctuation variables and
615 debugger globals are used.
616
617 We can't use local, because the code inside C<DB::eval> can see localized
618 variables; and we can't use C<my> either for the same reason. The code
619 in this routine compromises and uses C<my>.
620
621 After this routine is over, we don't have user code executing in the debugger's
622 context, so we can use C<my> freely.
623
624 =cut
625
626 ############################################## Begin lexical danger zone
627
628 # 'my' variables used here could leak into (that is, be visible in)
629 # the context that the code being evaluated is executing in. This means that
630 # the code could modify the debugger's variables.
631 #
632 # Fiddling with the debugger's context could be Bad. We insulate things as
633 # much as we can.
634
635 use vars qw(
636     @args
637     %break_on_load
638     $CommandSet
639     $CreateTTY
640     $DBGR
641     @dbline
642     $dbline
643     %dbline
644     $dieLevel
645     $filename
646     $histfile
647     $histsize
648     $histitemminlength
649     $IN
650     $inhibit_exit
651     @ini_INC
652     $ini_warn
653     $maxtrace
654     $od
655     @options
656     $osingle
657     $otrace
658     $pager
659     $post
660     %postponed
661     $prc
662     $pre
663     $pretype
664     $psh
665     @RememberOnROptions
666     $remoteport
667     @res
668     $rl
669     @saved
670     $signalLevel
671     $sub
672     $term
673     $usercontext
674     $warnLevel
675 );
676
677 our (
678     @cmdfhs,
679     $evalarg,
680     $frame,
681     $hist,
682     $ImmediateStop,
683     $line,
684     $onetimeDump,
685     $onetimedumpDepth,
686     %option,
687     $OUT,
688     $packname,
689     $signal,
690     $single,
691     $start,
692     %sub,
693     $subname,
694     $trace,
695     $window,
696 );
697
698 # Used to save @ARGV and extract any debugger-related flags.
699 use vars qw(@ARGS);
700
701 # Used to prevent multiple entries to diesignal()
702 # (if for instance diesignal() itself dies)
703 use vars qw($panic);
704
705 # Used to prevent the debugger from running nonstop
706 # after a restart
707 our ($second_time);
708
709 sub _calc_usercontext {
710     my ($package) = @_;
711
712     # Cancel strict completely for the evaluated code, so the code
713     # the user evaluates won't be affected by it. (Shlomi Fish)
714     return 'no strict; ($@, $!, $^E, $,, $/, $\, $^W) = @DB::saved;'
715     . "package $package;";    # this won't let them modify, alas
716 }
717
718 sub eval {
719
720     # 'my' would make it visible from user code
721     #    but so does local! --tchrist
722     # Remember: this localizes @DB::res, not @main::res.
723     local @res;
724     {
725
726         # Try to keep the user code from messing  with us. Save these so that
727         # even if the eval'ed code changes them, we can put them back again.
728         # Needed because the user could refer directly to the debugger's
729         # package globals (and any 'my' variables in this containing scope)
730         # inside the eval(), and we want to try to stay safe.
731         local $otrace  = $trace;
732         local $osingle = $single;
733         local $od      = $^D;
734
735         # Untaint the incoming eval() argument.
736         { ($evalarg) = $evalarg =~ /(.*)/s; }
737
738         # $usercontext built in DB::DB near the comment
739         # "set up the context for DB::eval ..."
740         # Evaluate and save any results.
741         @res = eval "$usercontext $evalarg;\n";  # '\n' for nice recursive debug
742
743         # Restore those old values.
744         $trace  = $otrace;
745         $single = $osingle;
746         $^D     = $od;
747     }
748
749     # Save the current value of $@, and preserve it in the debugger's copy
750     # of the saved precious globals.
751     my $at = $@;
752
753     # Since we're only saving $@, we only have to localize the array element
754     # that it will be stored in.
755     local $saved[0];    # Preserve the old value of $@
756     eval { &DB::save };
757
758     # Now see whether we need to report an error back to the user.
759     if ($at) {
760         local $\ = '';
761         print $OUT $at;
762     }
763
764     # Display as required by the caller. $onetimeDump and $onetimedumpDepth
765     # are package globals.
766     elsif ($onetimeDump) {
767         if ( $onetimeDump eq 'dump' ) {
768             local $option{dumpDepth} = $onetimedumpDepth
769               if defined $onetimedumpDepth;
770             dumpit( $OUT, \@res );
771         }
772         elsif ( $onetimeDump eq 'methods' ) {
773             methods( $res[0] );
774         }
775     } ## end elsif ($onetimeDump)
776     @res;
777 } ## end sub eval
778
779 ############################################## End lexical danger zone
780
781 # After this point it is safe to introduce lexicals.
782 # The code being debugged will be executing in its own context, and
783 # can't see the inside of the debugger.
784 #
785 # However, one should not overdo it: leave as much control from outside as
786 # possible. If you make something a lexical, it's not going to be addressable
787 # from outside the debugger even if you know its name.
788
789 # This file is automatically included if you do perl -d.
790 # It's probably not useful to include this yourself.
791 #
792 # Before venturing further into these twisty passages, it is
793 # wise to read the perldebguts man page or risk the ire of dragons.
794 #
795 # (It should be noted that perldebguts will tell you a lot about
796 # the underlying mechanics of how the debugger interfaces into the
797 # Perl interpreter, but not a lot about the debugger itself. The new
798 # comments in this code try to address this problem.)
799
800 # Note that no subroutine call is possible until &DB::sub is defined
801 # (for subroutines defined outside of the package DB). In fact the same is
802 # true if $deep is not defined.
803
804 # Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich)
805
806 # modified Perl debugger, to be run from Emacs in perldb-mode
807 # Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990
808 # Johan Vromans -- upgrade to 4.0 pl 10
809 # Ilya Zakharevich -- patches after 5.001 (and some before ;-)
810 ########################################################################
811
812 =head1 DEBUGGER INITIALIZATION
813
814 The debugger starts up in phases.
815
816 =head2 BASIC SETUP
817
818 First, it initializes the environment it wants to run in: turning off
819 warnings during its own compilation, defining variables which it will need
820 to avoid warnings later, setting itself up to not exit when the program
821 terminates, and defaulting to printing return values for the C<r> command.
822
823 =cut
824
825 # Needed for the statement after exec():
826 #
827 # This BEGIN block is simply used to switch off warnings during debugger
828 # compilation. Probably it would be better practice to fix the warnings,
829 # but this is how it's done at the moment.
830
831 BEGIN {
832     $ini_warn = $^W;
833     $^W       = 0;
834 }    # Switch compilation warnings off until another BEGIN.
835
836 local ($^W) = 0;    # Switch run-time warnings off during init.
837
838 =head2 THREADS SUPPORT
839
840 If we are running under a threaded Perl, we require threads and threads::shared
841 if the environment variable C<PERL5DB_THREADED> is set, to enable proper
842 threaded debugger control.  C<-dt> can also be used to set this.
843
844 Each new thread will be announced and the debugger prompt will always inform
845 you of each new thread created.  It will also indicate the thread id in which
846 we are currently running within the prompt like this:
847
848     [tid] DB<$i>
849
850 Where C<[tid]> is an integer thread id and C<$i> is the familiar debugger
851 command prompt.  The prompt will show: C<[0]> when running under threads, but
852 not actually in a thread.  C<[tid]> is consistent with C<gdb> usage.
853
854 While running under threads, when you set or delete a breakpoint (etc.), this
855 will apply to all threads, not just the currently running one.  When you are
856 in a currently executing thread, you will stay there until it completes.  With
857 the current implementation it is not currently possible to hop from one thread
858 to another.
859
860 The C<e> and C<E> commands are currently fairly minimal - see C<h e> and C<h E>.
861
862 Note that threading support was built into the debugger as of Perl version
863 C<5.8.6> and debugger version C<1.2.8>.
864
865 =cut
866
867 BEGIN {
868     # ensure we can share our non-threaded variables or no-op
869     if ($ENV{PERL5DB_THREADED}) {
870         require threads;
871         require threads::shared;
872         import threads::shared qw(share);
873         $DBGR;
874         share(\$DBGR);
875         lock($DBGR);
876         print "Threads support enabled\n";
877     } else {
878         *lock = sub(*) {};
879         *share = sub(\[$@%]) {};
880     }
881 }
882
883 # These variables control the execution of 'dumpvar.pl'.
884 {
885     package dumpvar;
886     use vars qw(
887     $hashDepth
888     $arrayDepth
889     $dumpDBFiles
890     $dumpPackages
891     $quoteHighBit
892     $printUndef
893     $globPrint
894     $usageOnly
895     );
896 }
897
898 # used to control die() reporting in diesignal()
899 {
900     package Carp;
901     use vars qw($CarpLevel);
902 }
903
904 # without threads, $filename is not defined until DB::DB is called
905 share($main::{'_<'.$filename}) if defined $filename;
906
907 # Command-line + PERLLIB:
908 # Save the contents of @INC before they are modified elsewhere.
909 @ini_INC = @INC;
910
911 # This was an attempt to clear out the previous values of various
912 # trapped errors. Apparently it didn't help. XXX More info needed!
913 # $prevwarn = $prevdie = $prevbus = $prevsegv = ''; # Does not help?!
914
915 # We set these variables to safe values. We don't want to blindly turn
916 # off warnings, because other packages may still want them.
917 $trace = $signal = $single = 0;    # Uninitialized warning suppression
918                                    # (local $^W cannot help - other packages!).
919
920 # Default to not exiting when program finishes; print the return
921 # value when the 'r' command is used to return from a subroutine.
922 $inhibit_exit = $option{PrintRet} = 1;
923
924 use vars qw($trace_to_depth);
925
926 # Default to 1E9 so it won't be limited to a certain recursion depth.
927 $trace_to_depth = 1E9;
928
929 =head1 OPTION PROCESSING
930
931 The debugger's options are actually spread out over the debugger itself and
932 C<dumpvar.pl>; some of these are variables to be set, while others are
933 subs to be called with a value. To try to make this a little easier to
934 manage, the debugger uses a few data structures to define what options
935 are legal and how they are to be processed.
936
937 First, the C<@options> array defines the I<names> of all the options that
938 are to be accepted.
939
940 =cut
941
942 @options = qw(
943   CommandSet   HistFile      HistSize
944   HistItemMinLength
945   hashDepth    arrayDepth    dumpDepth
946   DumpDBFiles  DumpPackages  DumpReused
947   compactDump  veryCompact   quote
948   HighBit      undefPrint    globPrint
949   PrintRet     UsageOnly     frame
950   AutoTrace    TTY           noTTY
951   ReadLine     NonStop       LineInfo
952   maxTraceLen  recallCommand ShellBang
953   pager        tkRunning     ornaments
954   signalLevel  warnLevel     dieLevel
955   inhibit_exit ImmediateStop bareStringify
956   CreateTTY    RemotePort    windowSize
957   DollarCaretP
958 );
959
960 @RememberOnROptions = qw(DollarCaretP);
961
962 =pod
963
964 Second, C<optionVars> lists the variables that each option uses to save its
965 state.
966
967 =cut
968
969 use vars qw(%optionVars);
970
971 %optionVars = (
972     hashDepth     => \$dumpvar::hashDepth,
973     arrayDepth    => \$dumpvar::arrayDepth,
974     CommandSet    => \$CommandSet,
975     DumpDBFiles   => \$dumpvar::dumpDBFiles,
976     DumpPackages  => \$dumpvar::dumpPackages,
977     DumpReused    => \$dumpvar::dumpReused,
978     HighBit       => \$dumpvar::quoteHighBit,
979     undefPrint    => \$dumpvar::printUndef,
980     globPrint     => \$dumpvar::globPrint,
981     UsageOnly     => \$dumpvar::usageOnly,
982     CreateTTY     => \$CreateTTY,
983     bareStringify => \$dumpvar::bareStringify,
984     frame         => \$frame,
985     AutoTrace     => \$trace,
986     inhibit_exit  => \$inhibit_exit,
987     maxTraceLen   => \$maxtrace,
988     ImmediateStop => \$ImmediateStop,
989     RemotePort    => \$remoteport,
990     windowSize    => \$window,
991     HistFile      => \$histfile,
992     HistSize      => \$histsize,
993     HistItemMinLength => \$histitemminlength
994 );
995
996 =pod
997
998 Third, C<%optionAction> defines the subroutine to be called to process each
999 option.
1000
1001 =cut
1002
1003 use vars qw(%optionAction);
1004
1005 %optionAction = (
1006     compactDump   => \&dumpvar::compactDump,
1007     veryCompact   => \&dumpvar::veryCompact,
1008     quote         => \&dumpvar::quote,
1009     TTY           => \&TTY,
1010     noTTY         => \&noTTY,
1011     ReadLine      => \&ReadLine,
1012     NonStop       => \&NonStop,
1013     LineInfo      => \&LineInfo,
1014     recallCommand => \&recallCommand,
1015     ShellBang     => \&shellBang,
1016     pager         => \&pager,
1017     signalLevel   => \&signalLevel,
1018     warnLevel     => \&warnLevel,
1019     dieLevel      => \&dieLevel,
1020     tkRunning     => \&tkRunning,
1021     ornaments     => \&ornaments,
1022     RemotePort    => \&RemotePort,
1023     DollarCaretP  => \&DollarCaretP,
1024 );
1025
1026 =pod
1027
1028 Last, the C<%optionRequire> notes modules that must be C<require>d if an
1029 option is used.
1030
1031 =cut
1032
1033 # Note that this list is not complete: several options not listed here
1034 # actually require that dumpvar.pl be loaded for them to work, but are
1035 # not in the table. A subsequent patch will correct this problem; for
1036 # the moment, we're just recommenting, and we are NOT going to change
1037 # function.
1038 use vars qw(%optionRequire);
1039
1040 %optionRequire = (
1041     compactDump => 'dumpvar.pl',
1042     veryCompact => 'dumpvar.pl',
1043     quote       => 'dumpvar.pl',
1044 );
1045
1046 =pod
1047
1048 There are a number of initialization-related variables which can be set
1049 by putting code to set them in a BEGIN block in the C<PERL5DB> environment
1050 variable. These are:
1051
1052 =over 4
1053
1054 =item C<$rl> - readline control XXX needs more explanation
1055
1056 =item C<$warnLevel> - whether or not debugger takes over warning handling
1057
1058 =item C<$dieLevel> - whether or not debugger takes over die handling
1059
1060 =item C<$signalLevel> - whether or not debugger takes over signal handling
1061
1062 =item C<$pre> - preprompt actions (array reference)
1063
1064 =item C<$post> - postprompt actions (array reference)
1065
1066 =item C<$pretype>
1067
1068 =item C<$CreateTTY> - whether or not to create a new TTY for this debugger
1069
1070 =item C<$CommandSet> - which command set to use (defaults to new, documented set)
1071
1072 =back
1073
1074 =cut
1075
1076 # These guys may be defined in $ENV{PERL5DB} :
1077 $rl          = 1     unless defined $rl;
1078 $warnLevel   = 1     unless defined $warnLevel;
1079 $dieLevel    = 1     unless defined $dieLevel;
1080 $signalLevel = 1     unless defined $signalLevel;
1081 $pre         = []    unless defined $pre;
1082 $post        = []    unless defined $post;
1083 $pretype     = []    unless defined $pretype;
1084 $CreateTTY   = 3     unless defined $CreateTTY;
1085 $CommandSet  = '580' unless defined $CommandSet;
1086
1087 share($rl);
1088 share($warnLevel);
1089 share($dieLevel);
1090 share($signalLevel);
1091 share($pre);
1092 share($post);
1093 share($pretype);
1094 share($CreateTTY);
1095 share($CommandSet);
1096
1097 =pod
1098
1099 The default C<die>, C<warn>, and C<signal> handlers are set up.
1100
1101 =cut
1102
1103 warnLevel($warnLevel);
1104 dieLevel($dieLevel);
1105 signalLevel($signalLevel);
1106
1107 =pod
1108
1109 The pager to be used is needed next. We try to get it from the
1110 environment first.  If it's not defined there, we try to find it in
1111 the Perl C<Config.pm>.  If it's not there, we default to C<more>. We
1112 then call the C<pager()> function to save the pager name.
1113
1114 =cut
1115
1116 # This routine makes sure $pager is set up so that '|' can use it.
1117 pager(
1118
1119     # If PAGER is defined in the environment, use it.
1120     defined $ENV{PAGER}
1121     ? $ENV{PAGER}
1122
1123       # If not, see if Config.pm defines it.
1124     : eval { require Config }
1125       && defined $Config::Config{pager}
1126     ? $Config::Config{pager}
1127
1128       # If not, fall back to 'more'.
1129     : 'more'
1130   )
1131   unless defined $pager;
1132
1133 =pod
1134
1135 We set up the command to be used to access the man pages, the command
1136 recall character (C<!> unless otherwise defined) and the shell escape
1137 character (C<!> unless otherwise defined). Yes, these do conflict, and
1138 neither works in the debugger at the moment.
1139
1140 =cut
1141
1142 setman();
1143
1144 # Set up defaults for command recall and shell escape (note:
1145 # these currently don't work in linemode debugging).
1146 recallCommand("!") unless defined $prc;
1147 shellBang("!")     unless defined $psh;
1148
1149 =pod
1150
1151 We then set up the gigantic string containing the debugger help.
1152 We also set the limit on the number of arguments we'll display during a
1153 trace.
1154
1155 =cut
1156
1157 sethelp();
1158
1159 # If we didn't get a default for the length of eval/stack trace args,
1160 # set it here.
1161 $maxtrace = 400 unless defined $maxtrace;
1162
1163 =head2 SETTING UP THE DEBUGGER GREETING
1164
1165 The debugger I<greeting> helps to inform the user how many debuggers are
1166 running, and whether the current debugger is the primary or a child.
1167
1168 If we are the primary, we just hang onto our pid so we'll have it when
1169 or if we start a child debugger. If we are a child, we'll set things up
1170 so we'll have a unique greeting and so the parent will give us our own
1171 TTY later.
1172
1173 We save the current contents of the C<PERLDB_PIDS> environment variable
1174 because we mess around with it. We'll also need to hang onto it because
1175 we'll need it if we restart.
1176
1177 Child debuggers make a label out of the current PID structure recorded in
1178 PERLDB_PIDS plus the new PID. They also mark themselves as not having a TTY
1179 yet so the parent will give them one later via C<resetterm()>.
1180
1181 =cut
1182
1183 # Save the current contents of the environment; we're about to
1184 # much with it. We'll need this if we have to restart.
1185 use vars qw($ini_pids);
1186 $ini_pids = $ENV{PERLDB_PIDS};
1187
1188 use vars qw ($pids $term_pid);
1189
1190 if ( defined $ENV{PERLDB_PIDS} ) {
1191
1192     # We're a child. Make us a label out of the current PID structure
1193     # recorded in PERLDB_PIDS plus our (new) PID. Mark us as not having
1194     # a term yet so the parent will give us one later via resetterm().
1195
1196     my $env_pids = $ENV{PERLDB_PIDS};
1197     $pids = "[$env_pids]";
1198
1199     # Unless we are on OpenVMS, all programs under the DCL shell run under
1200     # the same PID.
1201
1202     if (($^O eq 'VMS') && ($env_pids =~ /\b$$\b/)) {
1203         $term_pid         = $$;
1204     }
1205     else {
1206         $ENV{PERLDB_PIDS} .= "->$$";
1207         $term_pid = -1;
1208     }
1209
1210 } ## end if (defined $ENV{PERLDB_PIDS...
1211 else {
1212
1213     # We're the parent PID. Initialize PERLDB_PID in case we end up with a
1214     # child debugger, and mark us as the parent, so we'll know to set up
1215     # more TTY's is we have to.
1216     $ENV{PERLDB_PIDS} = "$$";
1217     $pids             = "[pid=$$]";
1218     $term_pid         = $$;
1219 }
1220
1221 use vars qw($pidprompt);
1222 $pidprompt = '';
1223
1224 # Sets up $emacs as a synonym for $slave_editor.
1225 our ($slave_editor);
1226 *emacs = $slave_editor if $slave_editor;    # May be used in afterinit()...
1227
1228 =head2 READING THE RC FILE
1229
1230 The debugger will read a file of initialization options if supplied. If
1231 running interactively, this is C<.perldb>; if not, it's C<perldb.ini>.
1232
1233 =cut
1234
1235 # As noted, this test really doesn't check accurately that the debugger
1236 # is running at a terminal or not.
1237
1238 use vars qw($rcfile);
1239 {
1240     my $dev_tty = (($^O eq 'VMS') ? 'TT:' : '/dev/tty');
1241     # this is the wrong metric!
1242     $rcfile = ((-e $dev_tty) ? ".perldb" : "perldb.ini");
1243 }
1244
1245 =pod
1246
1247 The debugger does a safety test of the file to be read. It must be owned
1248 either by the current user or root, and must only be writable by the owner.
1249
1250 =cut
1251
1252 # This wraps a safety test around "do" to read and evaluate the init file.
1253 #
1254 # This isn't really safe, because there's a race
1255 # between checking and opening.  The solution is to
1256 # open and fstat the handle, but then you have to read and
1257 # eval the contents.  But then the silly thing gets
1258 # your lexical scope, which is unfortunate at best.
1259 sub safe_do {
1260     my $file = shift;
1261
1262     # Just exactly what part of the word "CORE::" don't you understand?
1263     local $SIG{__WARN__};
1264     local $SIG{__DIE__};
1265
1266     unless ( is_safe_file($file) ) {
1267         CORE::warn <<EO_GRIPE;
1268 perldb: Must not source insecure rcfile $file.
1269         You or the superuser must be the owner, and it must not
1270         be writable by anyone but its owner.
1271 EO_GRIPE
1272         return;
1273     } ## end unless (is_safe_file($file...
1274
1275     do $file;
1276     CORE::warn("perldb: couldn't parse $file: $@") if $@;
1277 } ## end sub safe_do
1278
1279 # This is the safety test itself.
1280 #
1281 # Verifies that owner is either real user or superuser and that no
1282 # one but owner may write to it.  This function is of limited use
1283 # when called on a path instead of upon a handle, because there are
1284 # no guarantees that filename (by dirent) whose file (by ino) is
1285 # eventually accessed is the same as the one tested.
1286 # Assumes that the file's existence is not in doubt.
1287 sub is_safe_file {
1288     my $path = shift;
1289     stat($path) || return;    # mysteriously vaporized
1290     my ( $dev, $ino, $mode, $nlink, $uid, $gid ) = stat(_);
1291
1292     return 0 if $uid != 0 && $uid != $<;
1293     return 0 if $mode & 022;
1294     return 1;
1295 } ## end sub is_safe_file
1296
1297 # If the rcfile (whichever one we decided was the right one to read)
1298 # exists, we safely do it.
1299 if ( -f $rcfile ) {
1300     safe_do("./$rcfile");
1301 }
1302
1303 # If there isn't one here, try the user's home directory.
1304 elsif ( defined $ENV{HOME} && -f "$ENV{HOME}/$rcfile" ) {
1305     safe_do("$ENV{HOME}/$rcfile");
1306 }
1307
1308 # Else try the login directory.
1309 elsif ( defined $ENV{LOGDIR} && -f "$ENV{LOGDIR}/$rcfile" ) {
1310     safe_do("$ENV{LOGDIR}/$rcfile");
1311 }
1312
1313 # If the PERLDB_OPTS variable has options in it, parse those out next.
1314 if ( defined $ENV{PERLDB_OPTS} ) {
1315     parse_options( $ENV{PERLDB_OPTS} );
1316 }
1317
1318 =pod
1319
1320 The last thing we do during initialization is determine which subroutine is
1321 to be used to obtain a new terminal when a new debugger is started. Right now,
1322 the debugger only handles TCP sockets, X11, OS/2, amd Mac OS X
1323 (darwin).
1324
1325 =cut
1326
1327 # Set up the get_fork_TTY subroutine to be aliased to the proper routine.
1328 # Works if you're running an xterm or xterm-like window, or you're on
1329 # OS/2, or on Mac OS X. This may need some expansion.
1330
1331 if (not defined &get_fork_TTY)       # only if no routine exists
1332 {
1333     if ( defined $remoteport ) {
1334                                                  # Expect an inetd-like server
1335         *get_fork_TTY = \&socket_get_fork_TTY;   # to listen to us
1336     }
1337     elsif (defined $ENV{TERM}                    # If we know what kind
1338                                                  # of terminal this is,
1339         and $ENV{TERM} eq 'xterm'                # and it's an xterm,
1340         and defined $ENV{DISPLAY}                # and what display it's on,
1341       )
1342     {
1343         *get_fork_TTY = \&xterm_get_fork_TTY;    # use the xterm version
1344     }
1345     elsif ( $ENV{TMUX} ) {
1346         *get_fork_TTY = \&tmux_get_fork_TTY;
1347     }
1348     elsif ( $^O eq 'os2' ) {                     # If this is OS/2,
1349         *get_fork_TTY = \&os2_get_fork_TTY;      # use the OS/2 version
1350     }
1351     elsif ( $^O eq 'darwin'                      # If this is Mac OS X
1352             and defined $ENV{TERM_PROGRAM}       # and we're running inside
1353             and $ENV{TERM_PROGRAM}
1354                 eq 'Apple_Terminal'              # Terminal.app
1355             )
1356     {
1357         *get_fork_TTY = \&macosx_get_fork_TTY;   # use the Mac OS X version
1358     }
1359 } ## end if (not defined &get_fork_TTY...
1360
1361 # untaint $^O, which may have been tainted by the last statement.
1362 # see bug [perl #24674]
1363 $^O =~ m/^(.*)\z/;
1364 $^O = $1;
1365
1366 # Here begin the unreadable code.  It needs fixing.
1367
1368 =head2 RESTART PROCESSING
1369
1370 This section handles the restart command. When the C<R> command is invoked, it
1371 tries to capture all of the state it can into environment variables, and
1372 then sets C<PERLDB_RESTART>. When we start executing again, we check to see
1373 if C<PERLDB_RESTART> is there; if so, we reload all the information that
1374 the R command stuffed into the environment variables.
1375
1376   PERLDB_RESTART   - flag only, contains no restart data itself.
1377   PERLDB_HIST      - command history, if it's available
1378   PERLDB_ON_LOAD   - breakpoints set by the rc file
1379   PERLDB_POSTPONE  - subs that have been loaded/not executed,
1380                      and have actions
1381   PERLDB_VISITED   - files that had breakpoints
1382   PERLDB_FILE_...  - breakpoints for a file
1383   PERLDB_OPT       - active options
1384   PERLDB_INC       - the original @INC
1385   PERLDB_PRETYPE   - preprompt debugger actions
1386   PERLDB_PRE       - preprompt Perl code
1387   PERLDB_POST      - post-prompt Perl code
1388   PERLDB_TYPEAHEAD - typeahead captured by readline()
1389
1390 We chug through all these variables and plug the values saved in them
1391 back into the appropriate spots in the debugger.
1392
1393 =cut
1394
1395 use vars qw(%postponed_file @typeahead);
1396
1397 our (@hist, @truehist);
1398
1399 sub _restore_shared_globals_after_restart
1400 {
1401     @hist          = get_list('PERLDB_HIST');
1402     %break_on_load = get_list("PERLDB_ON_LOAD");
1403     %postponed     = get_list("PERLDB_POSTPONE");
1404
1405     share(@hist);
1406     share(@truehist);
1407     share(%break_on_load);
1408     share(%postponed);
1409 }
1410
1411 sub _restore_breakpoints_and_actions {
1412
1413     my @had_breakpoints = get_list("PERLDB_VISITED");
1414
1415     for my $file_idx ( 0 .. $#had_breakpoints ) {
1416         my $filename = $had_breakpoints[$file_idx];
1417         my %pf = get_list("PERLDB_FILE_$file_idx");
1418         $postponed_file{ $filename } = \%pf if %pf;
1419         my @lines = sort {$a <=> $b} keys(%pf);
1420         my @enabled_statuses = get_list("PERLDB_FILE_ENABLED_$file_idx");
1421         for my $line_idx (0 .. $#lines) {
1422             _set_breakpoint_enabled_status(
1423                 $filename,
1424                 $lines[$line_idx],
1425                 ($enabled_statuses[$line_idx] ? 1 : ''),
1426             );
1427         }
1428     }
1429
1430     return;
1431 }
1432
1433 sub _restore_options_after_restart
1434 {
1435     my %options_map = get_list("PERLDB_OPT");
1436
1437     while ( my ( $opt, $val ) = each %options_map ) {
1438         $val =~ s/[\\\']/\\$1/g;
1439         parse_options("$opt'$val'");
1440     }
1441
1442     return;
1443 }
1444
1445 sub _restore_globals_after_restart
1446 {
1447     # restore original @INC
1448     @INC     = get_list("PERLDB_INC");
1449     @ini_INC = @INC;
1450
1451     # return pre/postprompt actions and typeahead buffer
1452     $pretype   = [ get_list("PERLDB_PRETYPE") ];
1453     $pre       = [ get_list("PERLDB_PRE") ];
1454     $post      = [ get_list("PERLDB_POST") ];
1455     @typeahead = get_list( "PERLDB_TYPEAHEAD", @typeahead );
1456
1457     return;
1458 }
1459
1460
1461 if ( exists $ENV{PERLDB_RESTART} ) {
1462
1463     # We're restarting, so we don't need the flag that says to restart anymore.
1464     delete $ENV{PERLDB_RESTART};
1465
1466     # $restart = 1;
1467     _restore_shared_globals_after_restart();
1468
1469     _restore_breakpoints_and_actions();
1470
1471     # restore options
1472     _restore_options_after_restart();
1473
1474     _restore_globals_after_restart();
1475 } ## end if (exists $ENV{PERLDB_RESTART...
1476
1477 =head2 SETTING UP THE TERMINAL
1478
1479 Now, we'll decide how the debugger is going to interact with the user.
1480 If there's no TTY, we set the debugger to run non-stop; there's not going
1481 to be anyone there to enter commands.
1482
1483 =cut
1484
1485 use vars qw($notty $console $tty $LINEINFO);
1486 use vars qw($lineinfo $doccmd);
1487
1488 our ($runnonstop);
1489
1490 # Local autoflush to avoid rt#116769,
1491 # as calling IO::File methods causes an unresolvable loop
1492 # that results in debugger failure.
1493 sub _autoflush {
1494     my $o = select($_[0]);
1495     $|++;
1496     select($o);
1497 }
1498
1499 if ($notty) {
1500     $runnonstop = 1;
1501     share($runnonstop);
1502 }
1503
1504 =pod
1505
1506 If there is a TTY, we have to determine who it belongs to before we can
1507 proceed. If this is a slave editor or graphical debugger (denoted by
1508 the first command-line switch being '-emacs'), we shift this off and
1509 set C<$rl> to 0 (XXX ostensibly to do straight reads).
1510
1511 =cut
1512
1513 else {
1514
1515     # Is Perl being run from a slave editor or graphical debugger?
1516     # If so, don't use readline, and set $slave_editor = 1.
1517     if ($slave_editor = ( @main::ARGV && ( $main::ARGV[0] eq '-emacs' ) )) {
1518         $rl = 0;
1519         shift(@main::ARGV);
1520     }
1521
1522     #require Term::ReadLine;
1523
1524 =pod
1525
1526 We then determine what the console should be on various systems:
1527
1528 =over 4
1529
1530 =item * Cygwin - We use C<stdin> instead of a separate device.
1531
1532 =cut
1533
1534     if ( $^O eq 'cygwin' ) {
1535
1536         # /dev/tty is binary. use stdin for textmode
1537         undef $console;
1538     }
1539
1540 =item * Windows or MSDOS - use C<con>.
1541
1542 =cut
1543
1544     elsif ( $^O eq 'dos' or -e "con" or $^O eq 'MSWin32' ) {
1545         $console = "con";
1546     }
1547
1548 =item * AmigaOS - use C<CONSOLE:>.
1549
1550 =cut
1551
1552     elsif ( $^O eq 'amigaos' ) {
1553         $console = "CONSOLE:";
1554     }
1555
1556 =item * VMS - use C<sys$command>.
1557
1558 =cut
1559
1560     elsif ($^O eq 'VMS') {
1561         $console = 'sys$command';
1562     }
1563
1564 # Keep this penultimate, on the grounds that it satisfies a wide variety of
1565 # Unix-like systems that would otherwise need to be identified individually.
1566
1567 =item * Unix - use F</dev/tty>.
1568
1569 =cut
1570
1571     elsif ( -e "/dev/tty" ) {
1572         $console = "/dev/tty";
1573     }
1574
1575 # Keep this last.
1576
1577     else {
1578         _db_warn("Can't figure out your console, using stdin");
1579         undef $console;
1580     }
1581
1582 =pod
1583
1584 =back
1585
1586 Several other systems don't use a specific console. We C<undef $console>
1587 for those (Windows using a slave editor/graphical debugger, NetWare, OS/2
1588 with a slave editor).
1589
1590 =cut
1591
1592     if ( ( $^O eq 'MSWin32' ) and ( $slave_editor or defined $ENV{EMACS} ) ) {
1593
1594         # /dev/tty is binary. use stdin for textmode
1595         $console = undef;
1596     }
1597
1598     if ( $^O eq 'NetWare' ) {
1599
1600         # /dev/tty is binary. use stdin for textmode
1601         $console = undef;
1602     }
1603
1604     # In OS/2, we need to use STDIN to get textmode too, even though
1605     # it pretty much looks like Unix otherwise.
1606     if ( defined $ENV{OS2_SHELL} and ( $slave_editor or $ENV{WINDOWID} ) )
1607     {    # In OS/2
1608         $console = undef;
1609     }
1610
1611 =pod
1612
1613 If there is a TTY hanging around from a parent, we use that as the console.
1614
1615 =cut
1616
1617     $console = $tty if defined $tty;
1618
1619 =head2 SOCKET HANDLING
1620
1621 The debugger is capable of opening a socket and carrying out a debugging
1622 session over the socket.
1623
1624 If C<RemotePort> was defined in the options, the debugger assumes that it
1625 should try to start a debugging session on that port. It builds the socket
1626 and then tries to connect the input and output filehandles to it.
1627
1628 =cut
1629
1630     # Handle socket stuff.
1631
1632     if ( defined $remoteport ) {
1633
1634         # If RemotePort was defined in the options, connect input and output
1635         # to the socket.
1636         $IN = $OUT = connect_remoteport();
1637     } ## end if (defined $remoteport)
1638
1639 =pod
1640
1641 If no C<RemotePort> was defined, and we want to create a TTY on startup,
1642 this is probably a situation where multiple debuggers are running (for example,
1643 a backticked command that starts up another debugger). We create a new IN and
1644 OUT filehandle, and do the necessary mojo to create a new TTY if we know how
1645 and if we can.
1646
1647 =cut
1648
1649     # Non-socket.
1650     else {
1651
1652         # Two debuggers running (probably a system or a backtick that invokes
1653         # the debugger itself under the running one). create a new IN and OUT
1654         # filehandle, and do the necessary mojo to create a new tty if we
1655         # know how, and we can.
1656         create_IN_OUT(4) if $CreateTTY & 4;
1657         if ($console) {
1658
1659             # If we have a console, check to see if there are separate ins and
1660             # outs to open. (They are assumed identical if not.)
1661
1662             my ( $i, $o ) = split /,/, $console;
1663             $o = $i unless defined $o;
1664
1665             # read/write on in, or just read, or read on STDIN.
1666                  open( IN, '+<', $i )
1667               || open( IN, '<',  $i )
1668               || open( IN, "<&STDIN" );
1669
1670             # read/write/create/clobber out, or write/create/clobber out,
1671             # or merge with STDERR, or merge with STDOUT.
1672                  open( OUT, '+>', $o )
1673               || open( OUT, '>',  $o )
1674               || open( OUT, ">&STDERR" )
1675               || open( OUT, ">&STDOUT" );    # so we don't dongle stdout
1676
1677         } ## end if ($console)
1678         elsif ( not defined $console ) {
1679
1680             # No console. Open STDIN.
1681             open( IN, "<&STDIN" );
1682
1683             # merge with STDERR, or with STDOUT.
1684             open( OUT,      ">&STDERR" )
1685               || open( OUT, ">&STDOUT" );    # so we don't dongle stdout
1686             $console = 'STDIN/OUT';
1687         } ## end elsif (not defined $console)
1688
1689         # Keep copies of the filehandles so that when the pager runs, it
1690         # can close standard input without clobbering ours.
1691         if ($console or (not defined($console))) {
1692             $IN = \*IN;
1693             $OUT = \*OUT;
1694         }
1695     } ## end elsif (from if(defined $remoteport))
1696
1697     # Unbuffer DB::OUT. We need to see responses right away.
1698     _autoflush($OUT);
1699
1700     # Line info goes to debugger output unless pointed elsewhere.
1701     # Pointing elsewhere makes it possible for slave editors to
1702     # keep track of file and position. We have both a filehandle
1703     # and a I/O description to keep track of.
1704     $LINEINFO = $OUT     unless defined $LINEINFO;
1705     $lineinfo = $console unless defined $lineinfo;
1706     # share($LINEINFO); # <- unable to share globs
1707     share($lineinfo);   #
1708
1709 =pod
1710
1711 To finish initialization, we show the debugger greeting,
1712 and then call the C<afterinit()> subroutine if there is one.
1713
1714 =cut
1715
1716     # Show the debugger greeting.
1717     $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
1718     unless ($runnonstop) {
1719         local $\ = '';
1720         local $, = '';
1721         if ( $term_pid eq '-1' ) {
1722             print $OUT "\nDaughter DB session started...\n";
1723         }
1724         else {
1725             print $OUT "\nLoading DB routines from $header\n";
1726             print $OUT (
1727                 "Editor support ",
1728                 $slave_editor ? "enabled" : "available", ".\n"
1729             );
1730             print $OUT
1731 "\nEnter h or 'h h' for help, or '$doccmd perldebug' for more help.\n\n";
1732         } ## end else [ if ($term_pid eq '-1')
1733     } ## end unless ($runnonstop)
1734 } ## end else [ if ($notty)
1735
1736 # XXX This looks like a bug to me.
1737 # Why copy to @ARGS and then futz with @args?
1738 @ARGS = @ARGV;
1739 # for (@args) {
1740     # Make sure backslashes before single quotes are stripped out, and
1741     # keep args unless they are numeric (XXX why?)
1742     # s/\'/\\\'/g;                      # removed while not justified understandably
1743     # s/(.*)/'$1'/ unless /^-?[\d.]+$/; # ditto
1744 # }
1745
1746 # If there was an afterinit() sub defined, call it. It will get
1747 # executed in our scope, so it can fiddle with debugger globals.
1748 if ( defined &afterinit ) {    # May be defined in $rcfile
1749     afterinit();
1750 }
1751
1752 # Inform us about "Stack dump during die enabled ..." in dieLevel().
1753 use vars qw($I_m_init);
1754
1755 $I_m_init = 1;
1756
1757 ############################################################ Subroutines
1758
1759 =head1 SUBROUTINES
1760
1761 =head2 DB
1762
1763 This gigantic subroutine is the heart of the debugger. Called before every
1764 statement, its job is to determine if a breakpoint has been reached, and
1765 stop if so; read commands from the user, parse them, and execute
1766 them, and then send execution off to the next statement.
1767
1768 Note that the order in which the commands are processed is very important;
1769 some commands earlier in the loop will actually alter the C<$cmd> variable
1770 to create other commands to be executed later. This is all highly I<optimized>
1771 but can be confusing. Check the comments for each C<$cmd ... && do {}> to
1772 see what's happening in any given command.
1773
1774 =cut
1775
1776 # $cmd cannot be an our() variable unfortunately (possible perl bug?).
1777
1778 use vars qw(
1779     $action
1780     $cmd
1781     $file
1782     $filename_ini
1783     $finished
1784     %had_breakpoints
1785     $level
1786     $max
1787     $package
1788     $try
1789 );
1790
1791 our (
1792     %alias,
1793     $doret,
1794     $end,
1795     $fall_off_end,
1796     $incr,
1797     $laststep,
1798     $rc,
1799     $sh,
1800     $stack_depth,
1801     @stack,
1802     @to_watch,
1803     @old_watch,
1804 );
1805
1806 sub _DB__determine_if_we_should_break
1807 {
1808     # if we have something here, see if we should break.
1809     # $stop is lexical and local to this block - $action on the other hand
1810     # is global.
1811     my $stop;
1812
1813     if ( $dbline{$line}
1814         && _is_breakpoint_enabled($filename, $line)
1815         && (( $stop, $action ) = split( /\0/, $dbline{$line} ) ) )
1816     {
1817
1818         # Stop if the stop criterion says to just stop.
1819         if ( $stop eq '1' ) {
1820             $signal |= 1;
1821         }
1822
1823         # It's a conditional stop; eval it in the user's context and
1824         # see if we should stop. If so, remove the one-time sigil.
1825         elsif ($stop) {
1826             $evalarg = "\$DB::signal |= 1 if do {$stop}";
1827             # The &-call is here to ascertain the mutability of @_.
1828             &DB::eval;
1829             # If the breakpoint is temporary, then delete its enabled status.
1830             if ($dbline{$line} =~ s/;9($|\0)/$1/) {
1831                 _cancel_breakpoint_temp_enabled_status($filename, $line);
1832             }
1833         }
1834     } ## end if ($dbline{$line} && ...
1835 }
1836
1837 sub _DB__is_finished {
1838     if ($finished and $level <= 1) {
1839         end_report();
1840         return 1;
1841     }
1842     else {
1843         return;
1844     }
1845 }
1846
1847 sub _DB__read_next_cmd
1848 {
1849     my ($tid) = @_;
1850
1851     # We have a terminal, or can get one ...
1852     if (!$term) {
1853         setterm();
1854     }
1855
1856     # ... and it belongs to this PID or we get one for this PID ...
1857     if ($term_pid != $$) {
1858         resetterm(1);
1859     }
1860
1861     # ... and we got a line of command input ...
1862     $cmd = DB::readline(
1863         "$pidprompt $tid DB"
1864         . ( '<' x $level )
1865         . ( $#hist + 1 )
1866         . ( '>' x $level ) . " "
1867     );
1868
1869     return defined($cmd);
1870 }
1871
1872 sub _DB__trim_command_and_return_first_component {
1873     my ($obj) = @_;
1874
1875     $cmd =~ s/\A\s+//s;    # trim annoying leading whitespace
1876     $cmd =~ s/\s+\z//s;    # trim annoying trailing whitespace
1877
1878     # A single-character debugger command can be immediately followed by its
1879     # argument if they aren't both alphanumeric; otherwise require space
1880     # between commands and arguments:
1881     my ($verb, $args) = $cmd =~ m{\A([^\.-]\b|\S*)\s*(.*)}s;
1882
1883     $obj->cmd_verb($verb);
1884     $obj->cmd_args($args);
1885
1886     return;
1887 }
1888
1889 sub _DB__handle_f_command {
1890     my ($obj) = @_;
1891
1892     if ($file = $obj->cmd_args) {
1893         # help for no arguments (old-style was return from sub).
1894         if ( !$file ) {
1895             print $OUT
1896             "The old f command is now the r command.\n";    # hint
1897             print $OUT "The new f command switches filenames.\n";
1898             next CMD;
1899         } ## end if (!$file)
1900
1901         # if not in magic file list, try a close match.
1902         if ( !defined $main::{ '_<' . $file } ) {
1903             if ( ($try) = grep( m#^_<.*$file#, keys %main:: ) ) {
1904                 {
1905                     $try = substr( $try, 2 );
1906                     print $OUT "Choosing $try matching '$file':\n";
1907                     $file = $try;
1908                 }
1909             } ## end if (($try) = grep(m#^_<.*$file#...
1910         } ## end if (!defined $main::{ ...
1911
1912         # If not successfully switched now, we failed.
1913         if ( !defined $main::{ '_<' . $file } ) {
1914             print $OUT "No file matching '$file' is loaded.\n";
1915             next CMD;
1916         }
1917
1918         # We switched, so switch the debugger internals around.
1919         elsif ( $file ne $filename ) {
1920             *dbline   = $main::{ '_<' . $file };
1921             $max      = $#dbline;
1922             $filename = $file;
1923             $start    = 1;
1924             $cmd      = "l";
1925         } ## end elsif ($file ne $filename)
1926
1927         # We didn't switch; say we didn't.
1928         else {
1929             print $OUT "Already in $file.\n";
1930             next CMD;
1931         }
1932     }
1933
1934     return;
1935 }
1936
1937 sub _DB__handle_dot_command {
1938     my ($obj) = @_;
1939
1940     # . command.
1941     if ($obj->_is_full('.')) {
1942         $incr = -1;    # stay at current line
1943
1944         # Reset everything to the old location.
1945         $start    = $line;
1946         $filename = $filename_ini;
1947         *dbline   = $main::{ '_<' . $filename };
1948         $max      = $#dbline;
1949
1950         # Now where are we?
1951         print_lineinfo($obj->position());
1952         next CMD;
1953     }
1954
1955     return;
1956 }
1957
1958 sub _DB__handle_y_command {
1959     my ($obj) = @_;
1960
1961     if (my ($match_level, $match_vars)
1962         = $obj->cmd_args =~ /\A(?:(\d*)\s*(.*))?\z/) {
1963
1964         # See if we've got the necessary support.
1965         if (!eval {
1966             local @INC = @INC;
1967             pop @INC if $INC[-1] eq '.';
1968             require PadWalker; PadWalker->VERSION(0.08) }) {
1969             my $Err = $@;
1970             _db_warn(
1971                 $Err =~ /locate/
1972                 ? "PadWalker module not found - please install\n"
1973                 : $Err
1974             );
1975             next CMD;
1976         }
1977
1978         # Load up dumpvar if we don't have it. If we can, that is.
1979         do 'dumpvar.pl' || die $@ unless defined &main::dumpvar;
1980         defined &main::dumpvar
1981             or print $OUT "dumpvar.pl not available.\n"
1982             and next CMD;
1983
1984         # Got all the modules we need. Find them and print them.
1985         my @vars = split( ' ', $match_vars || '' );
1986
1987         # Find the pad.
1988         my $h = eval { PadWalker::peek_my( ( $match_level || 0 ) + 2 ) };
1989
1990         # Oops. Can't find it.
1991         if (my $Err = $@) {
1992             $Err =~ s/ at .*//;
1993             _db_warn($Err);
1994             next CMD;
1995         }
1996
1997         # Show the desired vars with dumplex().
1998         my $savout = select($OUT);
1999
2000         # Have dumplex dump the lexicals.
2001         foreach my $key (sort keys %$h) {
2002             dumpvar::dumplex( $key, $h->{$key},
2003                 defined $option{dumpDepth} ? $option{dumpDepth} : -1,
2004                 @vars );
2005         }
2006         select($savout);
2007         next CMD;
2008     }
2009 }
2010
2011 sub _DB__handle_c_command {
2012     my ($obj) = @_;
2013
2014     my $i = $obj->cmd_args;
2015
2016     if ($i =~ m#\A[\w:]*\z#) {
2017
2018         # Hey, show's over. The debugged program finished
2019         # executing already.
2020         next CMD if _DB__is_finished();
2021
2022         # Capture the place to put a one-time break.
2023         $subname = $i;
2024
2025         #  Probably not needed, since we finish an interactive
2026         #  sub-session anyway...
2027         # local $filename = $filename;
2028         # local *dbline = *dbline; # XXX Would this work?!
2029         #
2030         # The above question wonders if localizing the alias
2031         # to the magic array works or not. Since it's commented
2032         # out, we'll just leave that to speculation for now.
2033
2034         # If the "subname" isn't all digits, we'll assume it
2035         # is a subroutine name, and try to find it.
2036         if ( $subname =~ /\D/ ) {    # subroutine name
2037             # Qualify it to the current package unless it's
2038             # already qualified.
2039             $subname = $package . "::" . $subname
2040             unless $subname =~ /::/;
2041
2042             # find_sub will return "file:line_number" corresponding
2043             # to where the subroutine is defined; we call find_sub,
2044             # break up the return value, and assign it in one
2045             # operation.
2046             ( $file, $i ) = ( find_sub($subname) =~ /^(.*):(.*)$/ );
2047
2048             # Force the line number to be numeric.
2049             $i = $i + 0;
2050
2051             # If we got a line number, we found the sub.
2052             if ($i) {
2053
2054                 # Switch all the debugger's internals around so
2055                 # we're actually working with that file.
2056                 $filename = $file;
2057                 *dbline   = $main::{ '_<' . $filename };
2058
2059                 # Mark that there's a breakpoint in this file.
2060                 $had_breakpoints{$filename} |= 1;
2061
2062                 # Scan forward to the first executable line
2063                 # after the 'sub whatever' line.
2064                 $max = $#dbline;
2065                 my $_line_num = $i;
2066                 while ($dbline[$_line_num] == 0 && $_line_num< $max)
2067                 {
2068                     $_line_num++;
2069                 }
2070                 $i = $_line_num;
2071             } ## end if ($i)
2072
2073             # We didn't find a sub by that name.
2074             else {
2075                 print $OUT "Subroutine $subname not found.\n";
2076                 next CMD;
2077             }
2078         } ## end if ($subname =~ /\D/)
2079
2080         # At this point, either the subname was all digits (an
2081         # absolute line-break request) or we've scanned through
2082         # the code following the definition of the sub, looking
2083         # for an executable, which we may or may not have found.
2084         #
2085         # If $i (which we set $subname from) is non-zero, we
2086         # got a request to break at some line somewhere. On
2087         # one hand, if there wasn't any real subroutine name
2088         # involved, this will be a request to break in the current
2089         # file at the specified line, so we have to check to make
2090         # sure that the line specified really is breakable.
2091         #
2092         # On the other hand, if there was a subname supplied, the
2093         # preceding block has moved us to the proper file and
2094         # location within that file, and then scanned forward
2095         # looking for the next executable line. We have to make
2096         # sure that one was found.
2097         #
2098         # On the gripping hand, we can't do anything unless the
2099         # current value of $i points to a valid breakable line.
2100         # Check that.
2101         if ($i) {
2102
2103             # Breakable?
2104             if ( $dbline[$i] == 0 ) {
2105                 print $OUT "Line $i not breakable.\n";
2106                 next CMD;
2107             }
2108
2109             # Yes. Set up the one-time-break sigil.
2110             $dbline{$i} =~ s/($|\0)/;9$1/;  # add one-time-only b.p.
2111             _enable_breakpoint_temp_enabled_status($filename, $i);
2112         } ## end if ($i)
2113
2114         # Turn off stack tracing from here up.
2115         for my $j (0 .. $stack_depth) {
2116             $stack[ $j ] &= ~1;
2117         }
2118         last CMD;
2119     }
2120
2121     return;
2122 }
2123
2124 sub _DB__handle_forward_slash_command {
2125     my ($obj) = @_;
2126
2127     # The pattern as a string.
2128     use vars qw($inpat);
2129
2130     if (($inpat) = $cmd =~ m#\A/(.*)\z#) {
2131
2132         # Remove the final slash.
2133         $inpat =~ s:([^\\])/$:$1:;
2134
2135         # If the pattern isn't null ...
2136         if ( $inpat ne "" ) {
2137
2138             # Turn off warn and die processing for a bit.
2139             local $SIG{__DIE__};
2140             local $SIG{__WARN__};
2141
2142             # Create the pattern.
2143             eval 'no strict q/vars/; $inpat =~ m' . "\a$inpat\a";
2144             if ( $@ ne "" ) {
2145
2146                 # Oops. Bad pattern. No biscuit.
2147                 # Print the eval error and go back for more
2148                 # commands.
2149                 print {$OUT} "$@";
2150                 next CMD;
2151             }
2152             $obj->pat($inpat);
2153         } ## end if ($inpat ne "")
2154
2155         # Set up to stop on wrap-around.
2156         $end = $start;
2157
2158         # Don't move off the current line.
2159         $incr = -1;
2160
2161         my $pat = $obj->pat;
2162
2163         # Done in eval so nothing breaks if the pattern
2164         # does something weird.
2165         eval
2166         {
2167             no strict q/vars/;
2168             for (;;) {
2169                 # Move ahead one line.
2170                 ++$start;
2171
2172                 # Wrap if we pass the last line.
2173                 if ($start > $max) {
2174                     $start = 1;
2175                 }
2176
2177                 # Stop if we have gotten back to this line again,
2178                 last if ($start == $end);
2179
2180                 # A hit! (Note, though, that we are doing
2181                 # case-insensitive matching. Maybe a qr//
2182                 # expression would be better, so the user could
2183                 # do case-sensitive matching if desired.
2184                 if ($dbline[$start] =~ m/$pat/i) {
2185                     if ($slave_editor) {
2186                         # Handle proper escaping in the slave.
2187                         print {$OUT} "\032\032$filename:$start:0\n";
2188                     }
2189                     else {
2190                         # Just print the line normally.
2191                         print {$OUT} "$start:\t",$dbline[$start],"\n";
2192                     }
2193                     # And quit since we found something.
2194                     last;
2195                 }
2196             }
2197         };
2198
2199         if ($@) {
2200             warn $@;
2201         }
2202
2203         # If we wrapped, there never was a match.
2204         if ( $start == $end ) {
2205             print {$OUT} "/$pat/: not found\n";
2206         }
2207         next CMD;
2208     }
2209
2210     return;
2211 }
2212
2213 sub _DB__handle_question_mark_command {
2214     my ($obj) = @_;
2215
2216     # ? - backward pattern search.
2217     if (my ($inpat) = $cmd =~ m#\A\?(.*)\z#) {
2218
2219         # Get the pattern, remove trailing question mark.
2220         $inpat =~ s:([^\\])\?$:$1:;
2221
2222         # If we've got one ...
2223         if ( $inpat ne "" ) {
2224
2225             # Turn off die & warn handlers.
2226             local $SIG{__DIE__};
2227             local $SIG{__WARN__};
2228             eval '$inpat =~ m' . "\a$inpat\a";
2229
2230             if ( $@ ne "" ) {
2231
2232                 # Ouch. Not good. Print the error.
2233                 print $OUT $@;
2234                 next CMD;
2235             }
2236             $obj->pat($inpat);
2237         } ## end if ($inpat ne "")
2238
2239         # Where we are now is where to stop after wraparound.
2240         $end = $start;
2241
2242         # Don't move away from this line.
2243         $incr = -1;
2244
2245         my $pat = $obj->pat;
2246         # Search inside the eval to prevent pattern badness
2247         # from killing us.
2248         eval {
2249             no strict q/vars/;
2250             for (;;) {
2251                 # Back up a line.
2252                 --$start;
2253
2254                 # Wrap if we pass the first line.
2255
2256                 $start = $max if ($start <= 0);
2257
2258                 # Quit if we get back where we started,
2259                 last if ($start == $end);
2260
2261                 # Match?
2262                 if ($dbline[$start] =~ m/$pat/i) {
2263                     if ($slave_editor) {
2264                         # Yep, follow slave editor requirements.
2265                         print $OUT "\032\032$filename:$start:0\n";
2266                     }
2267                     else {
2268                         # Yep, just print normally.
2269                         print $OUT "$start:\t",$dbline[$start],"\n";
2270                     }
2271
2272                     # Found, so done.
2273                     last;
2274                 }
2275             }
2276         };
2277
2278         # Say we failed if the loop never found anything,
2279         if ( $start == $end ) {
2280             print {$OUT} "?$pat?: not found\n";
2281         }
2282         next CMD;
2283     }
2284
2285     return;
2286 }
2287
2288 sub _DB__handle_restart_and_rerun_commands {
2289     my ($obj) = @_;
2290
2291     my $cmd_cmd = $obj->cmd_verb;
2292     my $cmd_params = $obj->cmd_args;
2293     # R - restart execution.
2294     # rerun - controlled restart execution.
2295     if ($cmd_cmd eq 'rerun' or $cmd_params eq '') {
2296
2297         # Change directory to the initial current working directory on
2298         # the script startup, so if the debugged program changed the
2299         # directory, then we will still be able to find the path to the
2300         # program. (perl 5 RT #121509 ).
2301         chdir ($_initial_cwd);
2302
2303         my @args = ($cmd_cmd eq 'R' ? restart() : rerun($cmd_params));
2304
2305         # Close all non-system fds for a clean restart.  A more
2306         # correct method would be to close all fds that were not
2307         # open when the process started, but this seems to be
2308         # hard.  See "debugger 'R'estart and open database
2309         # connections" on p5p.
2310
2311         my $max_fd = 1024; # default if POSIX can't be loaded
2312         if (eval { require POSIX }) {
2313             eval { $max_fd = POSIX::sysconf(POSIX::_SC_OPEN_MAX()) };
2314         }
2315
2316         if (defined $max_fd) {
2317             foreach ($^F+1 .. $max_fd-1) {
2318                 next unless open FD_TO_CLOSE, "<&=$_";
2319                 close(FD_TO_CLOSE);
2320             }
2321         }
2322
2323         # And run Perl again.  We use exec() to keep the
2324         # PID stable (and that way $ini_pids is still valid).
2325         exec(@args) or print {$OUT} "exec failed: $!\n";
2326
2327         last CMD;
2328     }
2329
2330     return;
2331 }
2332
2333 sub _DB__handle_run_command_in_pager_command {
2334     my ($obj) = @_;
2335
2336     if ($cmd =~ m#\A\|\|?\s*[^|]#) {
2337         if ( $pager =~ /^\|/ ) {
2338
2339             # Default pager is into a pipe. Redirect I/O.
2340             open( SAVEOUT, ">&STDOUT" )
2341             || _db_warn("Can't save STDOUT");
2342             open( STDOUT, ">&OUT" )
2343             || _db_warn("Can't redirect STDOUT");
2344         } ## end if ($pager =~ /^\|/)
2345         else {
2346
2347             # Not into a pipe. STDOUT is safe.
2348             open( SAVEOUT, ">&OUT" ) || _db_warn("Can't save DB::OUT");
2349         }
2350
2351         # Fix up environment to record we have less if so.
2352         fix_less();
2353
2354         unless ( $obj->piped(scalar ( open( OUT, $pager ) ) ) ) {
2355
2356             # Couldn't open pipe to pager.
2357             _db_warn("Can't pipe output to '$pager'");
2358             if ( $pager =~ /^\|/ ) {
2359
2360                 # Redirect I/O back again.
2361                 open( OUT, ">&STDOUT" )    # XXX: lost message
2362                 || _db_warn("Can't restore DB::OUT");
2363                 open( STDOUT, ">&SAVEOUT" )
2364                 || _db_warn("Can't restore STDOUT");
2365                 close(SAVEOUT);
2366             } ## end if ($pager =~ /^\|/)
2367             else {
2368
2369                 # Redirect I/O. STDOUT already safe.
2370                 open( OUT, ">&STDOUT" )    # XXX: lost message
2371                 || _db_warn("Can't restore DB::OUT");
2372             }
2373             next CMD;
2374         } ## end unless ($piped = open(OUT,...
2375
2376         # Set up broken-pipe handler if necessary.
2377         $SIG{PIPE} = \&DB::catch
2378         if $pager =~ /^\|/
2379         && ( "" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE} );
2380
2381         _autoflush(\*OUT);
2382         # Save current filehandle, and put it back.
2383         $obj->selected(scalar( select(OUT) ));
2384         # Don't put it back if pager was a pipe.
2385         if ($cmd !~ /\A\|\|/)
2386         {
2387             select($obj->selected());
2388             $obj->selected("");
2389         }
2390
2391         # Trim off the pipe symbols and run the command now.
2392         $cmd =~ s#\A\|+\s*##;
2393         redo PIPE;
2394     }
2395
2396     return;
2397 }
2398
2399 sub _DB__handle_m_command {
2400     my ($obj) = @_;
2401
2402     if ($cmd =~ s#\Am\s+([\w:]+)\s*\z# #) {
2403         methods($1);
2404         next CMD;
2405     }
2406
2407     # m expr - set up DB::eval to do the work
2408     if ($cmd =~ s#\Am\b# #) {    # Rest gets done by DB::eval()
2409         $onetimeDump = 'methods';   #  method output gets used there
2410     }
2411
2412     return;
2413 }
2414
2415 sub _DB__at_end_of_every_command {
2416     my ($obj) = @_;
2417
2418     # At the end of every command:
2419     if ($obj->piped) {
2420
2421         # Unhook the pipe mechanism now.
2422         if ( $pager =~ /^\|/ ) {
2423
2424             # No error from the child.
2425             $? = 0;
2426
2427             # we cannot warn here: the handle is missing --tchrist
2428             close(OUT) || print SAVEOUT "\nCan't close DB::OUT\n";
2429
2430             # most of the $? crud was coping with broken cshisms
2431             # $? is explicitly set to 0, so this never runs.
2432             if ($?) {
2433                 print SAVEOUT "Pager '$pager' failed: ";
2434                 if ( $? == -1 ) {
2435                     print SAVEOUT "shell returned -1\n";
2436                 }
2437                 elsif ( $? >> 8 ) {
2438                     print SAVEOUT ( $? & 127 )
2439                     ? " (SIG#" . ( $? & 127 ) . ")"
2440                     : "", ( $? & 128 ) ? " -- core dumped" : "", "\n";
2441                 }
2442                 else {
2443                     print SAVEOUT "status ", ( $? >> 8 ), "\n";
2444                 }
2445             } ## end if ($?)
2446
2447             # Reopen filehandle for our output (if we can) and
2448             # restore STDOUT (if we can).
2449             open( OUT, ">&STDOUT" ) || _db_warn("Can't restore DB::OUT");
2450             open( STDOUT, ">&SAVEOUT" )
2451             || _db_warn("Can't restore STDOUT");
2452
2453             # Turn off pipe exception handler if necessary.
2454             $SIG{PIPE} = "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
2455
2456             # Will stop ignoring SIGPIPE if done like nohup(1)
2457             # does SIGINT but Perl doesn't give us a choice.
2458         } ## end if ($pager =~ /^\|/)
2459         else {
2460
2461             # Non-piped "pager". Just restore STDOUT.
2462             open( OUT, ">&SAVEOUT" ) || _db_warn("Can't restore DB::OUT");
2463         }
2464
2465         # Let Readline know about the new filehandles.
2466         reset_IN_OUT( \*IN, \*OUT );
2467
2468         # Close filehandle pager was using, restore the normal one
2469         # if necessary,
2470         close(SAVEOUT);
2471
2472         if ($obj->selected() ne "") {
2473             select($obj->selected);
2474             $obj->selected("");
2475         }
2476
2477         # No pipes now.
2478         $obj->piped("");
2479     } ## end if ($piped)
2480
2481     return;
2482 }
2483
2484 sub _DB__handle_watch_expressions
2485 {
2486     my $self = shift;
2487
2488     if ( $DB::trace & 2 ) {
2489         for my $n (0 .. $#DB::to_watch) {
2490             $DB::evalarg = $DB::to_watch[$n];
2491             local $DB::onetimeDump;    # Tell DB::eval() to not output results
2492
2493             # Fix context DB::eval() wants to return an array, but
2494             # we need a scalar here.
2495             my ($val) = join( "', '", DB::eval(@_) );
2496             $val = ( ( defined $val ) ? "'$val'" : 'undef' );
2497
2498             # Did it change?
2499             if ( $val ne $DB::old_watch[$n] ) {
2500
2501                 # Yep! Show the difference, and fake an interrupt.
2502                 $DB::signal = 1;
2503                 print {$DB::OUT} <<EOP;
2504 Watchpoint $n:\t$DB::to_watch[$n] changed:
2505     old value:\t$DB::old_watch[$n]
2506     new value:\t$val
2507 EOP
2508                 $DB::old_watch[$n] = $val;
2509             } ## end if ($val ne $old_watch...
2510         } ## end for my $n (0 ..
2511     } ## end if ($trace & 2)
2512
2513     return;
2514 }
2515
2516 =head3 C<_DB__handle_i_command> - inheritance display
2517
2518 Display the (nested) parentage of the module or object given.
2519
2520 =cut
2521
2522 sub _DB__handle_i_command {
2523     my $self = shift;
2524
2525     my $line = $self->cmd_args;
2526     require mro;
2527     foreach my $isa ( split( /\s+/, $line ) ) {
2528         $evalarg = "$isa";
2529         # The &-call is here to ascertain the mutability of @_.
2530         ($isa) = &DB::eval;
2531         no strict 'refs';
2532         print join(
2533             ', ',
2534             map {
2535                 "$_"
2536                   . (
2537                     defined( ${"$_\::VERSION"} )
2538                     ? ' ' . ${"$_\::VERSION"}
2539                     : undef )
2540               } @{mro::get_linear_isa(ref($isa) || $isa)}
2541         );
2542         print "\n";
2543     }
2544     next CMD;
2545 }
2546
2547 =head3 C<cmd_l> - list lines (command)
2548
2549 Most of the command is taken up with transforming all the different line
2550 specification syntaxes into 'start-stop'. After that is done, the command
2551 runs a loop over C<@dbline> for the specified range of lines. It handles
2552 the printing of each line and any markers (C<==E<gt>> for current line,
2553 C<b> for break on this line, C<a> for action on this line, C<:> for this
2554 line breakable).
2555
2556 We save the last line listed in the C<$start> global for further listing
2557 later.
2558
2559 =cut
2560
2561 sub _min {
2562     my $min = shift;
2563     foreach my $v (@_) {
2564         if ($min > $v) {
2565             $min = $v;
2566         }
2567     }
2568     return $min;
2569 }
2570
2571 sub _max {
2572     my $max = shift;
2573     foreach my $v (@_) {
2574         if ($max < $v) {
2575             $max = $v;
2576         }
2577     }
2578     return $max;
2579 }
2580
2581 sub _minify_to_max {
2582     my $ref = shift;
2583
2584     $$ref = _min($$ref, $max);
2585
2586     return;
2587 }
2588
2589 sub _cmd_l_handle_var_name {
2590     my $var_name = shift;
2591
2592     $evalarg = $var_name;
2593
2594     my ($s) = DB::eval();
2595
2596     # Ooops. Bad scalar.
2597     if ($@) {
2598         print {$OUT} "Error: $@\n";
2599         next CMD;
2600     }
2601
2602     # Good scalar. If it's a reference, find what it points to.
2603     $s = CvGV_name($s);
2604     print {$OUT} "Interpreted as: $1 $s\n";
2605     $line = "$1 $s";
2606
2607     # Call self recursively to really do the command.
2608     return _cmd_l_main( $s );
2609 }
2610
2611 sub _cmd_l_handle_subname {
2612
2613     my $s = $subname;
2614
2615     # De-Perl4.
2616     $subname =~ s/\'/::/;
2617
2618     # Put it in this package unless it starts with ::.
2619     $subname = $package . "::" . $subname unless $subname =~ /::/;
2620
2621     # Put it in CORE::GLOBAL if t doesn't start with :: and
2622     # it doesn't live in this package and it lives in CORE::GLOBAL.
2623     $subname = "CORE::GLOBAL::$s"
2624     if not defined &$subname
2625         and $s !~ /::/
2626         and defined &{"CORE::GLOBAL::$s"};
2627
2628     # Put leading '::' names into 'main::'.
2629     $subname = "main" . $subname if substr( $subname, 0, 2 ) eq "::";
2630
2631     # Get name:start-stop from find_sub, and break this up at
2632     # colons.
2633     my @pieces = split( /:/, find_sub($subname) || $sub{$subname} );
2634
2635     # Pull off start-stop.
2636     my $subrange = pop @pieces;
2637
2638     # If the name contained colons, the split broke it up.
2639     # Put it back together.
2640     $file = join( ':', @pieces );
2641
2642     # If we're not in that file, switch over to it.
2643     if ( $file ne $filename ) {
2644         if (! $slave_editor) {
2645             print {$OUT} "Switching to file '$file'.\n";
2646         }
2647
2648         # Switch debugger's magic structures.
2649         *dbline   = $main::{ '_<' . $file };
2650         $max      = $#dbline;
2651         $filename = $file;
2652     } ## end if ($file ne $filename)
2653
2654     # Subrange is 'start-stop'. If this is less than a window full,
2655     # swap it to 'start+', which will list a window from the start point.
2656     if ($subrange) {
2657         if ( eval($subrange) < -$window ) {
2658             $subrange =~ s/-.*/+/;
2659         }
2660
2661         # Call self recursively to list the range.
2662         return _cmd_l_main( $subrange );
2663     } ## end if ($subrange)
2664
2665     # Couldn't find it.
2666     else {
2667         print {$OUT} "Subroutine $subname not found.\n";
2668         return;
2669     }
2670 }
2671
2672 sub _cmd_l_empty {
2673     # Compute new range to list.
2674     $incr = $window - 1;
2675
2676     # Recurse to do it.
2677     return _cmd_l_main( $start . '-' . ( $start + $incr ) );
2678 }
2679
2680 sub _cmd_l_plus {
2681     my ($new_start, $new_incr) = @_;
2682
2683     # Don't reset start for 'l +nnn'.
2684     $start = $new_start if $new_start;
2685
2686     # Increment for list. Use window size if not specified.
2687     # (Allows 'l +' to work.)
2688     $incr = $new_incr || ($window - 1);
2689
2690     # Create a line range we'll understand, and recurse to do it.
2691     return _cmd_l_main( $start . '-' . ( $start + $incr ) );
2692 }
2693
2694 sub _cmd_l_calc_initial_end_and_i {
2695     my ($spec, $start_match, $end_match) = @_;
2696
2697     # Determine end point; use end of file if not specified.
2698     my $end = ( !defined $start_match ) ? $max :
2699     ( $end_match ? $end_match : $start_match );
2700
2701     # Go on to the end, and then stop.
2702     _minify_to_max(\$end);
2703
2704     # Determine start line.
2705     my $i = $start_match;
2706
2707     if ($i eq '.') {
2708         $i = $spec;
2709     }
2710
2711     $i = _max($i, 1);
2712
2713     $incr = $end - $i;
2714
2715     return ($end, $i);
2716 }
2717
2718 sub _cmd_l_range {
2719     my ($spec, $current_line, $start_match, $end_match) = @_;
2720
2721     my ($end, $i) =
2722         _cmd_l_calc_initial_end_and_i($spec, $start_match, $end_match);
2723
2724     # If we're running under a slave editor, force it to show the lines.
2725     if ($slave_editor) {
2726         print {$OUT} "\032\032$filename:$i:0\n";
2727         $i = $end;
2728     }
2729     # We're doing it ourselves. We want to show the line and special
2730     # markers for:
2731     # - the current line in execution
2732     # - whether a line is breakable or not
2733     # - whether a line has a break or not
2734     # - whether a line has an action or not
2735     else {
2736         I_TO_END:
2737         for ( ; $i <= $end ; $i++ ) {
2738
2739             # Check for breakpoints and actions.
2740             my ( $stop, $action );
2741             if ($dbline{$i}) {
2742                 ( $stop, $action ) = split( /\0/, $dbline{$i} );
2743             }
2744
2745             # ==> if this is the current line in execution,
2746             # : if it's breakable.
2747             my $arrow =
2748             ( $i == $current_line and $filename eq $filename_ini )
2749             ? '==>'
2750             : ( $dbline[$i] + 0 ? ':' : ' ' );
2751
2752             # Add break and action indicators.
2753             $arrow .= 'b' if $stop;
2754             $arrow .= 'a' if $action;
2755
2756             # Print the line.
2757             print {$OUT} "$i$arrow\t", $dbline[$i];
2758
2759             # Move on to the next line. Drop out on an interrupt.
2760             if ($signal) {
2761                 $i++;
2762                 last I_TO_END;
2763             }
2764         } ## end for (; $i <= $end ; $i++)
2765
2766         # Line the prompt up; print a newline if the last line listed
2767         # didn't have a newline.
2768         if ($dbline[ $i - 1 ] !~ /\n\z/) {
2769             print {$OUT} "\n";
2770         }
2771     } ## end else [ if ($slave_editor)
2772
2773     # Save the point we last listed to in case another relative 'l'
2774     # command is desired. Don't let it run off the end.
2775     $start = $i;
2776     _minify_to_max(\$start);
2777
2778     return;
2779 }
2780
2781 sub _cmd_l_main {
2782     my $spec = shift;
2783
2784     # If this is '-something', delete any spaces after the dash.
2785     $spec =~ s/\A-\s*\z/-/;
2786
2787     # If the line is '$something', assume this is a scalar containing a
2788     # line number.
2789     # Set up for DB::eval() - evaluate in *user* context.
2790     if ( my ($var_name) = $spec =~ /\A(\$.*)/s ) {
2791         return _cmd_l_handle_var_name($var_name);
2792     }
2793     # l name. Try to find a sub by that name.
2794     elsif ( ($subname) = $spec =~ /\A([\':A-Za-z_][\':\w]*(?:\[.*\])?)/s ) {
2795         return _cmd_l_handle_subname();
2796     }
2797     # Bare 'l' command.
2798     elsif ( $spec !~ /\S/ ) {
2799         return _cmd_l_empty();
2800     }
2801     # l [start]+number_of_lines
2802     elsif ( my ($new_start, $new_incr) = $spec =~ /\A(\d*)\+(\d*)\z/ ) {
2803         return _cmd_l_plus($new_start, $new_incr);
2804     }
2805     # l start-stop or l start,stop
2806     elsif (my ($s, $e) = $spec =~ /^(?:(-?[\d\$\.]+)(?:[-,]([\d\$\.]+))?)?/ ) {
2807         return _cmd_l_range($spec, $line, $s, $e);
2808     }
2809
2810     return;
2811 } ## end sub cmd_l
2812
2813 sub _DB__handle_l_command {
2814     my $self = shift;
2815
2816     _cmd_l_main($self->cmd_args);
2817     next CMD;
2818 }
2819
2820
2821 # 't' is type.
2822 # 'm' is method.
2823 # 'v' is the value (i.e: method name or subroutine ref).
2824 # 's' is subroutine.
2825 my %cmd_lookup;
2826
2827 BEGIN
2828 {
2829     %cmd_lookup =
2830 (
2831     '-' => { t => 'm', v => '_handle_dash_command', },
2832     '.' => { t => 's', v => \&_DB__handle_dot_command, },
2833     '=' => { t => 'm', v => '_handle_equal_sign_command', },
2834     'H' => { t => 'm', v => '_handle_H_command', },
2835     'S' => { t => 'm', v => '_handle_S_command', },
2836     'T' => { t => 'm', v => '_handle_T_command', },
2837     'W' => { t => 'm', v => '_handle_W_command', },
2838     'c' => { t => 's', v => \&_DB__handle_c_command, },
2839     'f' => { t => 's', v => \&_DB__handle_f_command, },
2840     'i' => { t => 's', v => \&_DB__handle_i_command, },
2841     'l' => { t => 's', v => \&_DB__handle_l_command, },
2842     'm' => { t => 's', v => \&_DB__handle_m_command, },
2843     'n' => { t => 'm', v => '_handle_n_command', },
2844     'p' => { t => 'm', v => '_handle_p_command', },
2845     'q' => { t => 'm', v => '_handle_q_command', },
2846     'r' => { t => 'm', v => '_handle_r_command', },
2847     's' => { t => 'm', v => '_handle_s_command', },
2848     'save' => { t => 'm', v => '_handle_save_command', },
2849     'source' => { t => 'm', v => '_handle_source_command', },
2850     't' => { t => 'm', v => '_handle_t_command', },
2851     'w' => { t => 'm', v => '_handle_w_command', },
2852     'x' => { t => 'm', v => '_handle_x_command', },
2853     'y' => { t => 's', v => \&_DB__handle_y_command, },
2854     (map { $_ => { t => 'm', v => '_handle_V_command_and_X_command', }, }
2855         ('X', 'V')),
2856     (map { $_ => { t => 'm', v => '_handle_enable_disable_commands', }, }
2857         qw(enable disable)),
2858     (map { $_ =>
2859         { t => 's', v => \&_DB__handle_restart_and_rerun_commands, },
2860         } qw(R rerun)),
2861     (map { $_ => {t => 'm', v => '_handle_cmd_wrapper_commands' }, }
2862         qw(a A b B e E h L M o O v w W)),
2863 );
2864 };
2865
2866 sub DB {
2867
2868     # lock the debugger and get the thread id for the prompt
2869     lock($DBGR);
2870     my $tid;
2871     my $position;
2872     my ($prefix, $after, $infix);
2873     my $pat;
2874     my $explicit_stop;
2875     my $piped;
2876     my $selected;
2877
2878     if ($ENV{PERL5DB_THREADED}) {
2879         $tid = eval { "[".threads->tid."]" };
2880     }
2881
2882     my $cmd_verb;
2883     my $cmd_args;
2884
2885     my $obj = DB::Obj->new(
2886         {
2887             position => \$position,
2888             prefix => \$prefix,
2889             after => \$after,
2890             explicit_stop => \$explicit_stop,
2891             infix => \$infix,
2892             cmd_args => \$cmd_args,
2893             cmd_verb => \$cmd_verb,
2894             pat => \$pat,
2895             piped => \$piped,
2896             selected => \$selected,
2897         },
2898     );
2899
2900     $obj->_DB_on_init__initialize_globals(@_);
2901
2902     # Preserve current values of $@, $!, $^E, $,, $/, $\, $^W.
2903     # The code being debugged may have altered them.
2904     DB::save();
2905
2906     # Since DB::DB gets called after every line, we can use caller() to
2907     # figure out where we last were executing. Sneaky, eh? This works because
2908     # caller is returning all the extra information when called from the
2909     # debugger.
2910     local ( $package, $filename, $line ) = caller;
2911     $filename_ini = $filename;
2912
2913     # set up the context for DB::eval, so it can properly execute
2914     # code on behalf of the user. We add the package in so that the
2915     # code is eval'ed in the proper package (not in the debugger!).
2916     local $usercontext = _calc_usercontext($package);
2917
2918     # Create an alias to the active file magical array to simplify
2919     # the code here.
2920     local (*dbline) = $main::{ '_<' . $filename };
2921
2922     # Last line in the program.
2923     $max = $#dbline;
2924
2925     # The &-call is here to ascertain the mutability of @_.
2926     &_DB__determine_if_we_should_break;
2927
2928     # Preserve the current stop-or-not, and see if any of the W
2929     # (watch expressions) has changed.
2930     my $was_signal = $signal;
2931
2932     # If we have any watch expressions ...
2933     _DB__handle_watch_expressions($obj);
2934
2935 =head2 C<watchfunction()>
2936
2937 C<watchfunction()> is a function that can be defined by the user; it is a
2938 function which will be run on each entry to C<DB::DB>; it gets the
2939 current package, filename, and line as its parameters.
2940
2941 The watchfunction can do anything it likes; it is executing in the
2942 debugger's context, so it has access to all of the debugger's internal
2943 data structures and functions.
2944
2945 C<watchfunction()> can control the debugger's actions. Any of the following
2946 will cause the debugger to return control to the user's program after
2947 C<watchfunction()> executes:
2948
2949 =over 4
2950
2951 =item *
2952
2953 Returning a false value from the C<watchfunction()> itself.
2954
2955 =item *
2956
2957 Altering C<$single> to a false value.
2958
2959 =item *
2960
2961 Altering C<$signal> to a false value.
2962
2963 =item *
2964
2965 Turning off the C<4> bit in C<$trace> (this also disables the
2966 check for C<watchfunction()>. This can be done with
2967
2968     $trace &= ~4;
2969
2970 =back
2971
2972 =cut
2973
2974     # If there's a user-defined DB::watchfunction, call it with the
2975     # current package, filename, and line. The function executes in
2976     # the DB:: package.
2977     if ( $trace & 4 ) {    # User-installed watch
2978         return
2979           if watchfunction( $package, $filename, $line )
2980           and not $single
2981           and not $was_signal
2982           and not( $trace & ~4 );
2983     } ## end if ($trace & 4)
2984
2985     # Pick up any alteration to $signal in the watchfunction, and
2986     # turn off the signal now.
2987     $was_signal = $signal;
2988     $signal     = 0;
2989
2990 =head2 GETTING READY TO EXECUTE COMMANDS
2991
2992 The debugger decides to take control if single-step mode is on, the
2993 C<t> command was entered, or the user generated a signal. If the program
2994 has fallen off the end, we set things up so that entering further commands
2995 won't cause trouble, and we say that the program is over.
2996
2997 =cut
2998
2999     # Make sure that we always print if asked for explicitly regardless
3000     # of $trace_to_depth .
3001     $explicit_stop = ($single || $was_signal);
3002
3003     # Check to see if we should grab control ($single true,
3004     # trace set appropriately, or we got a signal).
3005     if ( $explicit_stop || ( $trace & 1 ) ) {
3006         $obj->_DB__grab_control(@_);
3007     } ## end if ($single || ($trace...
3008
3009 =pod
3010
3011 If there's an action to be executed for the line we stopped at, execute it.
3012 If there are any preprompt actions, execute those as well.
3013
3014 =cut
3015
3016     # If there's an action, do it now.
3017     if ($action) {
3018         $evalarg = $action;
3019         # The &-call is here to ascertain the mutability of @_.
3020         &DB::eval;
3021     }
3022     undef $action;
3023
3024     # Are we nested another level (e.g., did we evaluate a function
3025     # that had a breakpoint in it at the debugger prompt)?
3026     if ( $single || $was_signal ) {
3027
3028         # Yes, go down a level.
3029         local $level = $level + 1;
3030
3031         # Do any pre-prompt actions.
3032         foreach $evalarg (@$pre) {
3033             # The &-call is here to ascertain the mutability of @_.
3034             &DB::eval;
3035         }
3036
3037         # Complain about too much recursion if we passed the limit.
3038         if ($single & 4) {
3039             print $OUT $stack_depth . " levels deep in subroutine calls!\n";
3040         }
3041
3042         # The line we're currently on. Set $incr to -1 to stay here
3043         # until we get a command that tells us to advance.
3044         $start = $line;
3045         $incr  = -1;      # for backward motion.
3046
3047         # Tack preprompt debugger actions ahead of any actual input.
3048         @typeahead = ( @$pretype, @typeahead );
3049
3050 =head2 WHERE ARE WE?
3051
3052 XXX Relocate this section?
3053
3054 The debugger normally shows the line corresponding to the current line of
3055 execution. Sometimes, though, we want to see the next line, or to move elsewhere
3056 in the file. This is done via the C<$incr>, C<$start>, and C<$max> variables.
3057
3058 C<$incr> controls by how many lines the I<current> line should move forward
3059 after a command is executed. If set to -1, this indicates that the I<current>
3060 line shouldn't change.
3061
3062 C<$start> is the I<current> line. It is used for things like knowing where to
3063 move forwards or backwards from when doing an C<L> or C<-> command.
3064
3065 C<$max> tells the debugger where the last line of the current file is. It's
3066 used to terminate loops most often.
3067
3068 =head2 THE COMMAND LOOP
3069
3070 Most of C<DB::DB> is actually a command parsing and dispatch loop. It comes
3071 in two parts:
3072
3073 =over 4
3074
3075 =item *
3076
3077 The outer part of the loop, starting at the C<CMD> label. This loop
3078 reads a command and then executes it.
3079
3080 =item *
3081
3082 The inner part of the loop, starting at the C<PIPE> label. This part
3083 is wholly contained inside the C<CMD> block and only executes a command.
3084 Used to handle commands running inside a pager.
3085
3086 =back
3087
3088 So why have two labels to restart the loop? Because sometimes, it's easier to
3089 have a command I<generate> another command and then re-execute the loop to do
3090 the new command. This is faster, but perhaps a bit more convoluted.
3091
3092 =cut
3093
3094         # The big command dispatch loop. It keeps running until the
3095         # user yields up control again.
3096         #
3097         # If we have a terminal for input, and we get something back
3098         # from readline(), keep on processing.
3099
3100       CMD:
3101         while (_DB__read_next_cmd($tid))
3102         {
3103
3104             share($cmd);
3105             # ... try to execute the input as debugger commands.
3106
3107             # Don't stop running.
3108             $single = 0;
3109
3110             # No signal is active.
3111             $signal = 0;
3112
3113             # Handle continued commands (ending with \):
3114             if ($cmd =~ s/\\\z/\n/) {
3115                 $cmd .= DB::readline("  cont: ");
3116                 redo CMD;
3117             }
3118
3119 =head4 The null command
3120
3121 A newline entered by itself means I<re-execute the last command>. We grab the
3122 command out of C<$laststep> (where it was recorded previously), and copy it
3123 back into C<$cmd> to be executed below. If there wasn't any previous command,
3124 we'll do nothing below (no command will match). If there was, we also save it
3125 in the command history and fall through to allow the command parsing to pick
3126 it up.
3127
3128 =cut
3129
3130             # Empty input means repeat the last command.
3131             if ($cmd eq '') {
3132                 $cmd = $laststep;
3133             }
3134             chomp($cmd);    # get rid of the annoying extra newline
3135             if (length($cmd) >= option_val('HistItemMinLength', 2)) {
3136                 push( @hist, $cmd );
3137             }
3138             push( @truehist, $cmd );
3139             share(@hist);
3140             share(@truehist);
3141
3142             # This is a restart point for commands that didn't arrive
3143             # via direct user input. It allows us to 'redo PIPE' to
3144             # re-execute command processing without reading a new command.
3145           PIPE: {
3146                 _DB__trim_command_and_return_first_component($obj);
3147
3148 =head3 COMMAND ALIASES
3149
3150 The debugger can create aliases for commands (these are stored in the
3151 C<%alias> hash). Before a command is executed, the command loop looks it up
3152 in the alias hash and substitutes the contents of the alias for the command,
3153 completely replacing it.
3154
3155 =cut
3156
3157                 # See if there's an alias for the command, and set it up if so.
3158                 if ( $alias{$cmd_verb} ) {
3159
3160                     # Squelch signal handling; we want to keep control here
3161                     # if something goes loco during the alias eval.
3162                     local $SIG{__DIE__};
3163                     local $SIG{__WARN__};
3164
3165                     # This is a command, so we eval it in the DEBUGGER's
3166                     # scope! Otherwise, we can't see the special debugger
3167                     # variables, or get to the debugger's subs. (Well, we
3168                     # _could_, but why make it even more complicated?)
3169                     eval "\$cmd =~ $alias{$cmd_verb}";
3170                     if ($@) {
3171                         local $\ = '';
3172                         print $OUT "Couldn't evaluate '$cmd_verb' alias: $@";
3173                         next CMD;
3174                     }
3175                     _DB__trim_command_and_return_first_component($obj);
3176                 } ## end if ($alias{$cmd_verb})
3177
3178 =head3 MAIN-LINE COMMANDS
3179
3180 All of these commands work up to and after the program being debugged has
3181 terminated.
3182
3183 =head4 C<q> - quit
3184
3185 Quit the debugger. This entails setting the C<$fall_off_end> flag, so we don't
3186 try to execute further, cleaning any restart-related stuff out of the
3187 environment, and executing with the last value of C<$?>.
3188
3189 =cut
3190
3191                 # All of these commands were remapped in perl 5.8.0;
3192                 # we send them off to the secondary dispatcher (see below).
3193                 $obj->_handle_special_char_cmd_wrapper_commands;
3194                 _DB__trim_command_and_return_first_component($obj);
3195
3196                 if (my $cmd_rec = $cmd_lookup{$cmd_verb}) {
3197                     my $type = $cmd_rec->{t};
3198                     my $val = $cmd_rec->{v};
3199                     if ($type eq 'm') {
3200                         $obj->$val();
3201                     }
3202                     elsif ($type eq 's') {
3203                         $val->($obj);
3204                     }
3205                 }
3206
3207 =head4 C<t> - trace [n]
3208
3209 Turn tracing on or off. Inverts the appropriate bit in C<$trace> (q.v.).
3210 If level is specified, set C<$trace_to_depth>.
3211
3212 =head4 C<S> - list subroutines matching/not matching a pattern
3213
3214 Walks through C<%sub>, checking to see whether or not to print the name.
3215
3216 =head4 C<X> - list variables in current package
3217
3218 Since the C<V> command actually processes this, just change this to the
3219 appropriate C<V> command and fall through.
3220
3221 =head4 C<V> - list variables
3222
3223 Uses C<dumpvar.pl> to dump out the current values for selected variables.
3224
3225 =head4 C<x> - evaluate and print an expression
3226
3227 Hands the expression off to C<DB::eval>, setting it up to print the value
3228 via C<dumpvar.pl> instead of just printing it directly.
3229
3230 =head4 C<m> - print methods
3231
3232 Just uses C<DB::methods> to determine what methods are available.
3233
3234 =head4 C<f> - switch files
3235
3236 Switch to a different filename.
3237
3238 =head4 C<.> - return to last-executed line.
3239
3240 We set C<$incr> to -1 to indicate that the debugger shouldn't move ahead,
3241 and then we look up the line in the magical C<%dbline> hash.
3242
3243 =head4 C<-> - back one window
3244
3245 We change C<$start> to be one window back; if we go back past the first line,
3246 we set it to be the first line. We set C<$incr> to put us back at the
3247 currently-executing line, and then put a C<l $start +> (list one window from
3248 C<$start>) in C<$cmd> to be executed later.
3249
3250 =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>>
3251
3252 In Perl 5.8.0, a realignment of the commands was done to fix up a number of
3253 problems, most notably that the default case of several commands destroying
3254 the user's work in setting watchpoints, actions, etc. We wanted, however, to
3255 retain the old commands for those who were used to using them or who preferred
3256 them. At this point, we check for the new commands and call C<cmd_wrapper> to
3257 deal with them instead of processing them in-line.
3258
3259 =head4 C<y> - List lexicals in higher scope
3260
3261 Uses C<PadWalker> to find the lexicals supplied as arguments in a scope
3262 above the current one and then displays then using C<dumpvar.pl>.
3263
3264 =head3 COMMANDS NOT WORKING AFTER PROGRAM ENDS
3265
3266 All of the commands below this point don't work after the program being
3267 debugged has ended. All of them check to see if the program has ended; this
3268 allows the commands to be relocated without worrying about a 'line of
3269 demarcation' above which commands can be entered anytime, and below which
3270 they can't.
3271
3272 =head4 C<n> - single step, but don't trace down into subs
3273
3274 Done by setting C<$single> to 2, which forces subs to execute straight through
3275 when entered (see C<DB::sub>). We also save the C<n> command in C<$laststep>,
3276 so a null command knows what to re-execute.
3277
3278 =head4 C<s> - single-step, entering subs
3279
3280 Sets C<$single> to 1, which causes C<DB::sub> to continue tracing inside
3281 subs. Also saves C<s> as C<$lastcmd>.
3282
3283 =head4 C<c> - run continuously, setting an optional breakpoint
3284
3285 Most of the code for this command is taken up with locating the optional
3286 breakpoint, which is either a subroutine name or a line number. We set
3287 the appropriate one-time-break in C<@dbline> and then turn off single-stepping
3288 in this and all call levels above this one.
3289
3290 =head4 C<r> - return from a subroutine
3291
3292 For C<r> to work properly, the debugger has to stop execution again
3293 immediately after the return is executed. This is done by forcing
3294 single-stepping to be on in the call level above the current one. If
3295 we are printing return values when a C<r> is executed, set C<$doret>
3296 appropriately, and force us out of the command loop.
3297
3298 =head4 C<T> - stack trace
3299
3300 Just calls C<DB::print_trace>.
3301
3302 =head4 C<w> - List window around current line.
3303
3304 Just calls C<DB::cmd_w>.
3305
3306 =head4 C<W> - watch-expression processing.
3307
3308 Just calls C<DB::cmd_W>.
3309
3310 =head4 C</> - search forward for a string in the source
3311
3312 We take the argument and treat it as a pattern. If it turns out to be a
3313 bad one, we return the error we got from trying to C<eval> it and exit.
3314 If not, we create some code to do the search and C<eval> it so it can't
3315 mess us up.
3316
3317 =cut
3318
3319                 _DB__handle_forward_slash_command($obj);
3320
3321 =head4 C<?> - search backward for a string in the source
3322
3323 Same as for C</>, except the loop runs backwards.
3324
3325 =cut
3326
3327                 _DB__handle_question_mark_command($obj);
3328
3329 =head4 C<$rc> - Recall command
3330
3331 Manages the commands in C<@hist> (which is created if C<Term::ReadLine> reports
3332 that the terminal supports history). It finds the command required, puts it
3333 into C<$cmd>, and redoes the loop to execute it.
3334
3335 =cut
3336
3337                 # $rc - recall command.
3338                 $obj->_handle_rc_recall_command;
3339
3340 =head4 C<$sh$sh> - C<system()> command
3341
3342 Calls the C<_db_system()> to handle the command. This keeps the C<STDIN> and
3343 C<STDOUT> from getting messed up.
3344
3345 =cut
3346
3347                 $obj->_handle_sh_command;
3348
3349 =head4 C<$rc I<pattern> $rc> - Search command history
3350
3351 Another command to manipulate C<@hist>: this one searches it with a pattern.
3352 If a command is found, it is placed in C<$cmd> and executed via C<redo>.
3353
3354 =cut
3355
3356                 $obj->_handle_rc_search_history_command;
3357
3358 =head4 C<$sh> - Invoke a shell
3359
3360 Uses C<_db_system()> to invoke a shell.
3361
3362 =cut
3363
3364 =head4 C<$sh I<command>> - Force execution of a command in a shell
3365
3366 Like the above, but the command is passed to the shell. Again, we use
3367 C<_db_system()> to avoid problems with C<STDIN> and C<STDOUT>.
3368
3369 =head4 C<H> - display commands in history
3370
3371 Prints the contents of C<@hist> (if any).
3372
3373 =head4 C<man, doc, perldoc> - look up documentation
3374
3375 Just calls C<runman()> to print the appropriate document.
3376
3377 =cut
3378
3379                 $obj->_handle_doc_command;
3380
3381 =head4 C<p> - print
3382
3383 Builds a C<print EXPR> expression in the C<$cmd>; this will get executed at
3384 the bottom of the loop.
3385
3386 =head4 C<=> - define command alias
3387
3388 Manipulates C<%alias> to add or list command aliases.
3389
3390 =head4 C<source> - read commands from a file.
3391
3392 Opens a lexical filehandle and stacks it on C<@cmdfhs>; C<DB::readline> will
3393 pick it up.
3394
3395 =head4 C<enable> C<disable> - enable or disable breakpoints
3396
3397 This enables or disables breakpoints.
3398
3399 =head4 C<save> - send current history to a file
3400
3401 Takes the complete history, (not the shrunken version you see with C<H>),
3402 and saves it to the given filename, so it can be replayed using C<source>.
3403
3404 Note that all C<^(save|source)>'s are commented out with a view to minimise recursion.
3405
3406 =head4 C<R> - restart
3407
3408 Restart the debugger session.
3409
3410 =head4 C<rerun> - rerun the current session
3411
3412 Return to any given position in the B<true>-history list
3413
3414 =head4 C<|, ||> - pipe output through the pager.
3415
3416 For C<|>, we save C<OUT> (the debugger's output filehandle) and C<STDOUT>
3417 (the program's standard output). For C<||>, we only save C<OUT>. We open a
3418 pipe to the pager (restoring the output filehandles if this fails). If this
3419 is the C<|> command, we also set up a C<SIGPIPE> handler which will simply
3420 set C<$signal>, sending us back into the debugger.
3421
3422 We then trim off the pipe symbols and C<redo> the command loop at the
3423 C<PIPE> label, causing us to evaluate the command in C<$cmd> without
3424 reading another.
3425
3426 =cut
3427
3428                 # || - run command in the pager, with output to DB::OUT.
3429                 _DB__handle_run_command_in_pager_command($obj);
3430
3431 =head3 END OF COMMAND PARSING
3432
3433 Anything left in C<$cmd> at this point is a Perl expression that we want to
3434 evaluate. We'll always evaluate in the user's context, and fully qualify
3435 any variables we might want to address in the C<DB> package.
3436
3437 =cut
3438
3439             }    # PIPE:
3440
3441             # trace an expression
3442             $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
3443
3444             # Make sure the flag that says "the debugger's running" is
3445             # still on, to make sure we get control again.
3446             $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd";
3447
3448             # Run *our* eval that executes in the caller's context.
3449             # The &-call is here to ascertain the mutability of @_.
3450             &DB::eval;
3451
3452             # Turn off the one-time-dump stuff now.
3453             if ($onetimeDump) {
3454                 $onetimeDump      = undef;
3455                 $onetimedumpDepth = undef;
3456             }
3457             elsif ( $term_pid == $$ ) {
3458                 eval { # May run under miniperl, when not available...
3459                     STDOUT->flush();
3460                     STDERR->flush();
3461                 };
3462
3463                 # XXX If this is the master pid, print a newline.
3464                 print {$OUT} "\n";
3465             }
3466         } ## end while (($term || &setterm...
3467
3468 =head3 POST-COMMAND PROCESSING
3469
3470 After each command, we check to see if the command output was piped anywhere.
3471 If so, we go through the necessary code to unhook the pipe and go back to
3472 our standard filehandles for input and output.
3473
3474 =cut
3475
3476         continue {    # CMD:
3477             _DB__at_end_of_every_command($obj);
3478         }    # CMD:
3479
3480 =head3 COMMAND LOOP TERMINATION
3481
3482 When commands have finished executing, we come here. If the user closed the
3483 input filehandle, we turn on C<$fall_off_end> to emulate a C<q> command. We
3484 evaluate any post-prompt items. We restore C<$@>, C<$!>, C<$^E>, C<$,>, C<$/>,
3485 C<$\>, and C<$^W>, and return a null list as expected by the Perl interpreter.
3486 The interpreter will then execute the next line and then return control to us
3487 again.
3488
3489 =cut
3490
3491         # No more commands? Quit.
3492         $fall_off_end = 1 unless defined $cmd;    # Emulate 'q' on EOF
3493
3494         # Evaluate post-prompt commands.
3495         foreach $evalarg (@$post) {
3496             # The &-call is here to ascertain the mutability of @_.
3497             &DB::eval;
3498         }
3499     }    # if ($single || $signal)
3500
3501     # Put the user's globals back where you found them.
3502     ( $@, $!, $^E, $,, $/, $\, $^W ) = @saved;
3503     ();
3504 } ## end sub DB
3505
3506 # Because DB::Obj is used above,
3507 #
3508 #   my $obj = DB::Obj->new(
3509 #
3510 # The following package declaration must come before that,
3511 # or else runtime errors will occur with
3512 #
3513 #   PERLDB_OPTS="autotrace nonstop"
3514 #
3515 # ( rt#116771 )
3516 BEGIN {
3517
3518 package DB::Obj;
3519
3520 sub new {
3521     my $class = shift;
3522
3523     my $self = bless {}, $class;
3524
3525     $self->_init(@_);
3526
3527     return $self;
3528 }
3529
3530 sub _init {
3531     my ($self, $args) = @_;
3532
3533     %{$self} = (%$self, %$args);
3534
3535     return;
3536 }
3537
3538 {
3539     no strict 'refs';
3540     foreach my $slot_name (qw(
3541         after explicit_stop infix pat piped position prefix selected cmd_verb
3542         cmd_args
3543         )) {
3544         my $slot = $slot_name;
3545         *{$slot} = sub {
3546             my $self = shift;
3547
3548             if (@_) {
3549                 ${ $self->{$slot} } = shift;
3550             }
3551
3552             return ${ $self->{$slot} };
3553         };
3554
3555         *{"append_to_$slot"} = sub {
3556             my $self = shift;
3557             my $s = shift;
3558
3559             return $self->$slot($self->$slot . $s);
3560         };
3561     }
3562 }
3563
3564 sub _DB_on_init__initialize_globals
3565 {
3566     my $self = shift;
3567
3568     # Check for whether we should be running continuously or not.
3569     # _After_ the perl program is compiled, $single is set to 1:
3570     if ( $single and not $second_time++ ) {
3571
3572         # Options say run non-stop. Run until we get an interrupt.
3573         if ($runnonstop) {    # Disable until signal
3574                 # If there's any call stack in place, turn off single
3575                 # stepping into subs throughout the stack.
3576             for my $i (0 .. $stack_depth) {
3577                 $stack[ $i ] &= ~1;
3578             }
3579
3580             # And we are now no longer in single-step mode.
3581             $single = 0;
3582
3583             # If we simply returned at this point, we wouldn't get
3584             # the trace info. Fall on through.
3585             # return;
3586         } ## end if ($runnonstop)
3587
3588         elsif ($ImmediateStop) {
3589
3590             # We are supposed to stop here; XXX probably a break.
3591             $ImmediateStop = 0;    # We've processed it; turn it off
3592             $signal        = 1;    # Simulate an interrupt to force
3593                                    # us into the command loop
3594         }
3595     } ## end if ($single and not $second_time...
3596
3597     # If we're in single-step mode, or an interrupt (real or fake)
3598     # has occurred, turn off non-stop mode.
3599     $runnonstop = 0 if $single or $signal;
3600
3601     return;
3602 }
3603
3604 sub _my_print_lineinfo
3605 {
3606     my ($self, $i, $incr_pos) = @_;
3607
3608     if ($frame) {
3609         # Print it indented if tracing is on.
3610         DB::print_lineinfo( ' ' x $stack_depth,
3611             "$i:\t$DB::dbline[$i]" . $self->after );
3612     }
3613     else {
3614         DB::depth_print_lineinfo($self->explicit_stop, $incr_pos);
3615     }
3616 }
3617
3618 sub _curr_line {
3619     return $DB::dbline[$line];
3620 }
3621
3622 sub _is_full {
3623     my ($self, $letter) = @_;
3624
3625     return ($DB::cmd eq $letter);
3626 }
3627
3628 sub _DB__grab_control
3629 {
3630     my $self = shift;
3631
3632     # Yes, grab control.
3633     if ($slave_editor) {
3634
3635         # Tell the editor to update its position.
3636         $self->position("\032\032${DB::filename}:$line:0\n");
3637         DB::print_lineinfo($self->position());
3638     }
3639
3640 =pod
3641
3642 Special check: if we're in package C<DB::fake>, we've gone through the
3643 C<END> block at least once. We set up everything so that we can continue
3644 to enter commands and have a valid context to be in.
3645
3646 =cut
3647
3648     elsif ( $DB::package eq 'DB::fake' ) {
3649
3650         # Fallen off the end already.
3651         if (!$DB::term) {
3652             DB::setterm();
3653         }
3654
3655         DB::print_help(<<EOP);
3656 Debugged program terminated.  Use B<q> to quit or B<R> to restart,
3657 use B<o> I<inhibit_exit> to avoid stopping after program termination,
3658 B<h q>, B<h R> or B<h o> to get additional info.
3659 EOP
3660
3661         $DB::package     = 'main';
3662         $DB::usercontext = DB::_calc_usercontext($DB::package);
3663     } ## end elsif ($package eq 'DB::fake')
3664
3665 =pod
3666
3667 If the program hasn't finished executing, we scan forward to the
3668 next executable line, print that out, build the prompt from the file and line
3669 number information, and print that.
3670
3671 =cut
3672
3673     else {
3674
3675
3676         # Still somewhere in the midst of execution. Set up the
3677         #  debugger prompt.
3678         $DB::sub =~ s/\'/::/;    # Swap Perl 4 package separators (') to
3679                              # Perl 5 ones (sorry, we don't print Klingon
3680                              #module names)
3681
3682         $self->prefix($DB::sub =~ /::/ ? "" : ($DB::package . '::'));
3683         $self->append_to_prefix( "$DB::sub(${DB::filename}:" );
3684         $self->after( $self->_curr_line =~ /\n$/ ? '' : "\n" );
3685
3686         # Break up the prompt if it's really long.
3687         if ( length($self->prefix()) > 30 ) {
3688             $self->position($self->prefix . "$line):\n$line:\t" . $self->_curr_line . $self->after);
3689             $self->prefix("");
3690             $self->infix(":\t");
3691         }
3692         else {
3693             $self->infix("):\t");
3694             $self->position(
3695                 $self->prefix . $line. $self->infix
3696                 . $self->_curr_line . $self->after
3697             );
3698         }
3699
3700         # Print current line info, indenting if necessary.
3701         $self->_my_print_lineinfo($line, $self->position);
3702
3703         my $i;
3704         my $line_i = sub { return $DB::dbline[$i]; };
3705
3706         # Scan forward, stopping at either the end or the next
3707         # unbreakable line.
3708         for ( $i = $line + 1 ; $i <= $DB::max && $line_i->() == 0 ; ++$i )
3709         {    #{ vi
3710
3711             # Drop out on null statements, block closers, and comments.
3712             last if $line_i->() =~ /^\s*[\;\}\#\n]/;
3713
3714             # Drop out if the user interrupted us.
3715             last if $signal;
3716
3717             # Append a newline if the line doesn't have one. Can happen
3718             # in eval'ed text, for instance.
3719             $self->after( $line_i->() =~ /\n$/ ? '' : "\n" );
3720
3721             # Next executable line.
3722             my $incr_pos = $self->prefix . $i . $self->infix . $line_i->()
3723                 . $self->after;
3724             $self->append_to_position($incr_pos);
3725             $self->_my_print_lineinfo($i, $incr_pos);
3726         } ## end for ($i = $line + 1 ; $i...
3727     } ## end else [ if ($slave_editor)
3728
3729     return;
3730 }
3731
3732 sub _handle_t_command {
3733     my $self = shift;
3734
3735     my $levels = $self->cmd_args();
3736
3737     if ((!length($levels)) or ($levels !~ /\D/)) {
3738         $trace ^= 1;
3739         local $\ = '';
3740         $DB::trace_to_depth = $levels ? $stack_depth + $levels : 1E9;
3741         print {$OUT} "Trace = "
3742         . ( ( $trace & 1 )
3743             ? ( $levels ? "on (to level $DB::trace_to_depth)" : "on" )
3744             : "off" ) . "\n";
3745         next CMD;
3746     }
3747
3748     return;
3749 }
3750
3751
3752 sub _handle_S_command {
3753     my $self = shift;
3754
3755     if (my ($print_all_subs, $should_reverse, $Spatt)
3756         = $self->cmd_args =~ /\A((!)?(.+))?\z/) {
3757         # $Spatt is the pattern (if any) to use.
3758         # Reverse scan?
3759         my $Srev     = defined $should_reverse;
3760         # No args - print all subs.
3761         my $Snocheck = !defined $print_all_subs;
3762
3763         # Need to make these sane here.
3764         local $\ = '';
3765         local $, = '';
3766
3767         # Search through the debugger's magical hash of subs.
3768         # If $nocheck is true, just print the sub name.
3769         # Otherwise, check it against the pattern. We then use
3770         # the XOR trick to reverse the condition as required.
3771         foreach $subname ( sort( keys %sub ) ) {
3772             if ( $Snocheck or $Srev ^ ( $subname =~ /$Spatt/ ) ) {
3773                 print $OUT $subname, "\n";
3774             }
3775         }
3776         next CMD;
3777     }
3778
3779     return;
3780 }
3781
3782 sub _handle_V_command_and_X_command {
3783     my $self = shift;
3784
3785     $DB::cmd =~ s/^X\b/V $DB::package/;
3786
3787     # Bare V commands get the currently-being-debugged package
3788     # added.
3789     if ($self->_is_full('V')) {
3790         $DB::cmd = "V $DB::package";
3791     }
3792
3793     # V - show variables in package.
3794     if (my ($new_packname, $new_vars_str) =
3795         $DB::cmd =~ /\AV\b\s*(\S+)\s*(.*)/) {
3796
3797         # Save the currently selected filehandle and
3798         # force output to debugger's filehandle (dumpvar
3799         # just does "print" for output).
3800         my $savout = select($OUT);
3801
3802         # Grab package name and variables to dump.
3803         $packname = $new_packname;
3804         my @vars     = split( ' ', $new_vars_str );
3805
3806         # If main::dumpvar isn't here, get it.
3807         do 'dumpvar.pl' || die $@ unless defined &main::dumpvar;
3808         if ( defined &main::dumpvar ) {
3809
3810             # We got it. Turn off subroutine entry/exit messages
3811             # for the moment, along with return values.
3812             local $frame = 0;
3813             local $doret = -2;
3814
3815             # must detect sigpipe failures  - not catching
3816             # then will cause the debugger to die.
3817             eval {
3818                 main::dumpvar(
3819                     $packname,
3820                     defined $option{dumpDepth}
3821                     ? $option{dumpDepth}
3822                     : -1,    # assume -1 unless specified
3823                     @vars
3824                 );
3825             };
3826
3827             # The die doesn't need to include the $@, because
3828             # it will automatically get propagated for us.
3829             if ($@) {
3830                 die unless $@ =~ /dumpvar print failed/;
3831             }
3832         } ## end if (defined &main::dumpvar)
3833         else {
3834
3835             # Couldn't load dumpvar.
3836             print $OUT "dumpvar.pl not available.\n";
3837         }
3838
3839         # Restore the output filehandle, and go round again.
3840         select($savout);
3841         next CMD;
3842     }
3843
3844     return;
3845 }
3846
3847 sub _handle_dash_command {
3848     my $self = shift;
3849
3850     if ($self->_is_full('-')) {
3851
3852         # back up by a window; go to 1 if back too far.
3853         $start -= $incr + $window + 1;
3854         $start = 1 if $start <= 0;
3855         $incr  = $window - 1;
3856
3857         # Generate and execute a "l +" command (handled below).
3858         $DB::cmd = 'l ' . ($start) . '+';
3859         redo CMD;
3860     }
3861     return;
3862 }
3863
3864 sub _n_or_s_commands_generic {
3865     my ($self, $new_val) = @_;
3866     # n - next
3867     next CMD if DB::_DB__is_finished();
3868
3869     # Single step, but don't enter subs.
3870     $single = $new_val;
3871
3872     # Save for empty command (repeat last).
3873     $laststep = $DB::cmd;
3874     last CMD;
3875 }
3876
3877 sub _n_or_s {
3878     my ($self, $letter, $new_val) = @_;
3879
3880     if ($self->_is_full($letter)) {
3881         $self->_n_or_s_commands_generic($new_val);
3882     }
3883     else {
3884         $self->_n_or_s_and_arg_commands_generic($letter, $new_val);
3885     }
3886
3887     return;
3888 }
3889
3890 sub _handle_n_command {
3891     my $self = shift;
3892
3893     return $self->_n_or_s('n', 2);
3894 }
3895
3896 sub _handle_s_command {
3897     my $self = shift;
3898
3899     return $self->_n_or_s('s', 1);
3900 }
3901
3902 sub _handle_r_command {
3903     my $self = shift;
3904
3905     # r - return from the current subroutine.
3906     if ($self->_is_full('r')) {
3907
3908         # Can't do anything if the program's over.
3909         next CMD if DB::_DB__is_finished();
3910
3911         # Turn on stack trace.
3912         $stack[$stack_depth] |= 1;
3913
3914         # Print return value unless the stack is empty.
3915         $doret = $option{PrintRet} ? $stack_depth - 1 : -2;
3916         last CMD;
3917     }
3918
3919     return;
3920 }
3921
3922 sub _handle_T_command {
3923     my $self = shift;
3924
3925     if ($self->_is_full('T')) {
3926         DB::print_trace( $OUT, 1 );    # skip DB
3927         next CMD;
3928     }
3929
3930     return;
3931 }
3932
3933 sub _handle_w_command {
3934     my $self = shift;
3935
3936     DB::cmd_w( 'w', $self->cmd_args() );
3937     next CMD;
3938
3939     return;
3940 }
3941
3942 sub _handle_W_command {
3943     my $self = shift;
3944
3945     if (my $arg = $self->cmd_args) {
3946         DB::cmd_W( 'W', $arg );
3947         next CMD;
3948     }
3949
3950     return;
3951 }
3952
3953 sub _handle_rc_recall_command {
3954     my $self = shift;
3955
3956     # $rc - recall command.
3957     if (my ($minus, $arg) = $DB::cmd =~ m#\A$rc+\s*(-)?(\d+)?\z#) {
3958
3959         # No arguments, take one thing off history.
3960         pop(@hist) if length($DB::cmd) > 1;
3961
3962         # Relative (- found)?
3963         #  Y - index back from most recent (by 1 if bare minus)
3964         #  N - go to that particular command slot or the last
3965         #      thing if nothing following.
3966
3967         $self->cmd_verb(
3968             scalar($minus ? ( $#hist - ( $arg || 1 ) ) : ( $arg || $#hist ))
3969         );
3970
3971         # Pick out the command desired.
3972         $DB::cmd = $hist[$self->cmd_verb];
3973
3974         # Print the command to be executed and restart the loop
3975         # with that command in the buffer.
3976         print {$OUT} $DB::cmd, "\n";
3977         redo CMD;
3978     }
3979
3980     return;
3981 }
3982
3983 sub _handle_rc_search_history_command {
3984     my $self = shift;
3985
3986     # $rc pattern $rc - find a command in the history.
3987     if (my ($arg) = $DB::cmd =~ /\A$rc([^$rc].*)\z/) {
3988
3989         # Create the pattern to use.
3990         my $pat = "^$arg";
3991         $self->pat($pat);
3992
3993         # Toss off last entry if length is >1 (and it always is).
3994         pop(@hist) if length($DB::cmd) > 1;
3995
3996         my $i;
3997
3998         # Look backward through the history.
3999         SEARCH_HIST:
4000         for ( $i = $#hist ; $i ; --$i ) {
4001             # Stop if we find it.
4002             last SEARCH_HIST if $hist[$i] =~ /$pat/;
4003         }
4004
4005         if ( !$i ) {
4006
4007             # Never found it.
4008             print $OUT "No such command!\n\n";
4009             next CMD;
4010         }
4011
4012         # Found it. Put it in the buffer, print it, and process it.
4013         $DB::cmd = $hist[$i];
4014         print $OUT $DB::cmd, "\n";
4015         redo CMD;
4016     }
4017
4018     return;
4019 }
4020
4021 sub _handle_H_command {
4022     my $self = shift;
4023
4024     if ($self->cmd_args =~ m#\A\*#) {
4025         @hist = @truehist = ();
4026         print $OUT "History cleansed\n";
4027         next CMD;
4028     }
4029
4030     if (my ($num) = $self->cmd_args =~ /\A(?:-(\d+))?/) {
4031
4032         # Anything other than negative numbers is ignored by
4033         # the (incorrect) pattern, so this test does nothing.
4034         $end = $num ? ( $#hist - $num ) : 0;
4035
4036         # Set to the minimum if less than zero.
4037         $hist = 0 if $hist < 0;
4038
4039         # Start at the end of the array.
4040         # Stay in while we're still above the ending value.
4041         # Tick back by one each time around the loop.
4042         my $i;
4043
4044         for ( $i = $#hist ; $i > $end ; $i-- ) {
4045             print $OUT "$i: ", $hist[$i], "\n";
4046         }
4047
4048         next CMD;
4049     }
4050
4051     return;
4052 }
4053
4054 sub _handle_doc_command {
4055     my $self = shift;
4056
4057     # man, perldoc, doc - show manual pages.
4058     if (my ($man_page)
4059         = $DB::cmd =~ /\A(?:man|(?:perl)?doc)\b(?:\s+([^(]*))?\z/) {
4060         DB::runman($man_page);
4061         next CMD;
4062     }
4063
4064     return;
4065 }
4066
4067 sub _handle_p_command {
4068     my $self = shift;
4069
4070     my $print_cmd = 'print {$DB::OUT} ';
4071     # p - print (no args): print $_.
4072     if ($self->_is_full('p')) {
4073         $DB::cmd = $print_cmd . '$_';
4074     }
4075     else {
4076         # p - print the given expression.
4077         $DB::cmd =~ s/\Ap\b/$print_cmd /;
4078     }
4079
4080     return;
4081 }
4082
4083 sub _handle_equal_sign_command {
4084     my $self = shift;
4085
4086     if ($DB::cmd =~ s/\A=\s*//) {
4087         my @keys;
4088         if ( length $DB::cmd == 0 ) {
4089
4090             # No args, get current aliases.
4091             @keys = sort keys %alias;
4092         }
4093         elsif ( my ( $k, $v ) = ( $DB::cmd =~ /^(\S+)\s+(\S.*)/ ) ) {
4094
4095             # Creating a new alias. $k is alias name, $v is
4096             # alias value.
4097
4098             # can't use $_ or kill //g state
4099             for my $x ( $k, $v ) {
4100
4101                 # Escape "alarm" characters.
4102                 $x =~ s/\a/\\a/g;
4103             }
4104
4105             # Substitute key for value, using alarm chars
4106             # as separators (which is why we escaped them in
4107             # the command).
4108             $alias{$k} = "s\a$k\a$v\a";
4109
4110             # Turn off standard warn and die behavior.
4111             local $SIG{__DIE__};
4112             local $SIG{__WARN__};
4113
4114             # Is it valid Perl?
4115             unless ( eval "sub { s\a$k\a$v\a }; 1" ) {
4116
4117                 # Nope. Bad alias. Say so and get out.
4118                 print $OUT "Can't alias $k to $v: $@\n";
4119                 delete $alias{$k};
4120                 next CMD;
4121             }
4122
4123             # We'll only list the new one.
4124             @keys = ($k);
4125         } ## end elsif (my ($k, $v) = ($DB::cmd...
4126
4127         # The argument is the alias to list.
4128         else {
4129             @keys = ($DB::cmd);
4130         }
4131
4132         # List aliases.
4133         for my $k (@keys) {
4134
4135             # Messy metaquoting: Trim the substitution code off.
4136             # We use control-G as the delimiter because it's not
4137             # likely to appear in the alias.
4138             if ( ( my $v = $alias{$k} ) =~ s\as\a$k\a(.*)\a$\a1\a ) {
4139
4140                 # Print the alias.
4141                 print $OUT "$k\t= $1\n";
4142             }
4143             elsif ( defined $alias{$k} ) {
4144
4145                 # Couldn't trim it off; just print the alias code.
4146                 print $OUT "$k\t$alias{$k}\n";
4147             }
4148             else {
4149
4150                 # No such, dude.
4151                 print "No alias for $k\n";
4152             }
4153         } ## end for my $k (@keys)
4154         next CMD;
4155     }
4156
4157     return;
4158 }
4159
4160 sub _handle_source_command {
4161     my $self = shift;
4162
4163     # source - read commands from a file (or pipe!) and execute.
4164     if (my $sourced_fn = $self->cmd_args) {
4165         if ( open my $fh, $sourced_fn ) {
4166
4167             # Opened OK; stick it in the list of file handles.
4168             push @cmdfhs, $fh;
4169         }
4170         else {
4171
4172             # Couldn't open it.
4173             DB::_db_warn("Can't execute '$sourced_fn': $!\n");
4174         }
4175         next CMD;
4176     }
4177
4178     return;
4179 }
4180
4181 sub _handle_enable_disable_commands {
4182     my $self = shift;
4183
4184     my $which_cmd = $self->cmd_verb;
4185     my $position = $self->cmd_args;
4186
4187     if ($position !~ /\s/) {
4188         my ($fn, $line_num);
4189         if ($position =~ m{\A\d+\z})
4190         {
4191             $fn = $DB::filename;
4192             $line_num = $position;
4193         }
4194         elsif (my ($new_fn, $new_line_num)
4195             = $position =~ m{\A(.*):(\d+)\z}) {
4196             ($fn, $line_num) = ($new_fn, $new_line_num);
4197         }
4198         else
4199         {
4200             DB::_db_warn("Wrong spec for enable/disable argument.\n");
4201         }
4202
4203         if (defined($fn)) {
4204             if (DB::_has_breakpoint_data_ref($fn, $line_num)) {
4205                 DB::_set_breakpoint_enabled_status($fn, $line_num,
4206                     ($which_cmd eq 'enable' ? 1 : '')
4207                 );
4208             }
4209             else {
4210                 DB::_db_warn("No breakpoint set at ${fn}:${line_num}\n");
4211             }
4212         }
4213
4214         next CMD;
4215     }
4216
4217     return;
4218 }
4219
4220 sub _handle_save_command {
4221     my $self = shift;
4222
4223     if (my $new_fn = $self->cmd_args) {
4224         my $filename = $new_fn || '.perl5dbrc';    # default?
4225         if ( open my $fh, '>', $filename ) {
4226
4227             # chomp to remove extraneous newlines from source'd files
4228             chomp( my @truelist =
4229                 map { m/\A\s*(save|source)/ ? "#$_" : $_ }
4230                 @truehist );
4231             print {$fh} join( "\n", @truelist );
4232             print "commands saved in $filename\n";
4233         }
4234         else {
4235             DB::_db_warn("Can't save debugger commands in '$new_fn': $!\n");
4236         }
4237         next CMD;
4238     }
4239
4240     return;
4241 }
4242
4243 sub _n_or_s_and_arg_commands_generic {
4244     my ($self, $letter, $new_val) = @_;
4245
4246     # s - single-step. Remember the last command was 's'.
4247     if ($DB::cmd =~ s#\A\Q$letter\E\s#\$DB::single = $new_val;\n#) {
4248         $laststep = $letter;
4249     }
4250
4251     return;
4252 }
4253
4254 sub _handle_sh_command {
4255     my $self = shift;
4256
4257     # $sh$sh - run a shell command (if it's all ASCII).
4258     # Can't run shell commands with Unicode in the debugger, hmm.
4259     my $my_cmd = $DB::cmd;
4260     if ($my_cmd =~ m#\A$sh#gms) {
4261
4262         if ($my_cmd =~ m#\G\z#cgms) {
4263             # Run the user's shell. If none defined, run Bourne.
4264             # We resume execution when the shell terminates.
4265             DB::_db_system( $ENV{SHELL} || "/bin/sh" );
4266             next CMD;
4267         }
4268         elsif ($my_cmd =~ m#\G$sh\s*(.*)#cgms) {
4269             # System it.
4270             DB::_db_system($1);
4271             next CMD;
4272         }
4273         elsif ($my_cmd =~ m#\G\s*(.*)#cgms) {
4274             DB::_db_system( $ENV{SHELL} || "/bin/sh", "-c", $1 );
4275             next CMD;
4276         }
4277     }
4278 }
4279
4280 sub _handle_x_command {
4281     my $self = shift;
4282
4283     if ($DB::cmd =~ s#\Ax\b# #) {    # Remainder gets done by DB::eval()
4284         $onetimeDump = 'dump';    # main::dumpvar shows the output
4285
4286         # handle special  "x 3 blah" syntax XXX propagate
4287         # doc back to special variables.
4288         if ( $DB::cmd =~ s#\A\s*(\d+)(?=\s)# #) {
4289             $onetimedumpDepth = $1;
4290         }
4291     }
4292
4293     return;
4294 }
4295
4296 sub _handle_q_command {
4297     my $self = shift;
4298
4299     if ($self->_is_full('q')) {
4300         $fall_off_end = 1;
4301         DB::clean_ENV();
4302         exit $?;
4303     }
4304
4305     return;
4306 }
4307
4308 sub _handle_cmd_wrapper_commands {
4309     my $self = shift;
4310
4311     DB::cmd_wrapper( $self->cmd_verb, $self->cmd_args, $line );
4312     next CMD;
4313 }
4314
4315 sub _handle_special_char_cmd_wrapper_commands {
4316     my $self = shift;
4317
4318     # All of these commands were remapped in perl 5.8.0;
4319     # we send them off to the secondary dispatcher (see below).
4320     if (my ($cmd_letter, $my_arg) = $DB::cmd =~ /\A([<>\{]{1,2})\s*(.*)/so) {
4321         DB::cmd_wrapper( $cmd_letter, $my_arg, $line );
4322         next CMD;
4323     }
4324
4325     return;
4326 }
4327
4328 } ## end DB::Obj
4329
4330 package DB;
4331
4332 # The following code may be executed now:
4333 # BEGIN {warn 4}
4334
4335 =head2 sub
4336
4337 C<sub> is called whenever a subroutine call happens in the program being
4338 debugged. The variable C<$DB::sub> contains the name of the subroutine
4339 being called.
4340
4341 The core function of this subroutine is to actually call the sub in the proper
4342 context, capturing its output. This of course causes C<DB::DB> to get called
4343 again, repeating until the subroutine ends and returns control to C<DB::sub>
4344 again. Once control returns, C<DB::sub> figures out whether or not to dump the
4345 return value, and returns its captured copy of the return value as its own
4346 return value. The value then feeds back into the program being debugged as if
4347 C<DB::sub> hadn't been there at all.
4348
4349 C<sub> does all the work of printing the subroutine entry and exit messages
4350 enabled by setting C<$frame>. It notes what sub the autoloader got called for,
4351 and also prints the return value if needed (for the C<r> command and if
4352 the 16 bit is set in C<$frame>).
4353
4354 It also tracks the subroutine call depth by saving the current setting of
4355 C<$single> in the C<@stack> package global; if this exceeds the value in
4356 C<$deep>, C<sub> automatically turns on printing of the current depth by
4357 setting the C<4> bit in C<$single>. In any case, it keeps the current setting
4358 of stop/don't stop on entry to subs set as it currently is set.
4359
4360 =head3 C<caller()> support
4361
4362 If C<caller()> is called from the package C<DB>, it provides some
4363 additional data, in the following order:
4364
4365 =over 4
4366
4367 =item * C<$package>
4368
4369 The package name the sub was in
4370
4371 =item * C<$filename>
4372
4373 The filename it was defined in
4374
4375 =item * C<$line>
4376
4377 The line number it was defined on
4378
4379 =item * C<$subroutine>
4380
4381 The subroutine name; C<(eval)> if an C<eval>().
4382
4383 =item * C<$hasargs>
4384
4385 1 if it has arguments, 0 if not
4386
4387 =item * C<$wantarray>
4388
4389 1 if array context, 0 if scalar context
4390
4391 =item * C<$evaltext>
4392
4393 The C<eval>() text, if any (undefined for C<eval BLOCK>)
4394
4395 =item * C<$is_require>
4396
4397 frame was created by a C<use> or C<require> statement
4398
4399 =item * C<$hints>
4400
4401 pragma information; subject to change between versions
4402
4403 =item * C<$bitmask>
4404
4405 pragma information; subject to change between versions
4406
4407 =item * C<@DB::args>
4408
4409 arguments with which the subroutine was invoked
4410
4411 =back
4412
4413 =cut
4414
4415 use vars qw($deep);
4416
4417 # We need to fully qualify the name ("DB::sub") to make "use strict;"
4418 # happy. -- Shlomi Fish
4419
4420 sub _indent_print_line_info {
4421     my ($offset, $str) = @_;
4422
4423     print_lineinfo( ' ' x ($stack_depth - $offset), $str);
4424
4425     return;
4426 }
4427
4428 sub _print_frame_message {
4429     my ($al) = @_;
4430
4431     if ($frame) {
4432         if ($frame & 4) {   # Extended frame entry message
4433             _indent_print_line_info(-1, "in  ");
4434
4435             # Why -1? But it works! :-(
4436             # Because print_trace will call add 1 to it and then call
4437             # dump_trace; this results in our skipping -1+1 = 0 stack frames
4438             # in dump_trace.
4439             #
4440             # Now it's 0 because we extracted a function.
4441             print_trace( $LINEINFO, 0, 1, 1, "$sub$al" );
4442         }
4443         else {
4444             _indent_print_line_info(-1, "entering $sub$al\n" );
4445         }
4446     }
4447
4448     return;
4449 }
4450
4451 sub DB::sub {
4452     my ( $al, $ret, @ret ) = "";
4453
4454     # We stack the stack pointer and then increment it to protect us
4455     # from a situation that might unwind a whole bunch of call frames
4456     # at once. Localizing the stack pointer means that it will automatically
4457     # unwind the same amount when multiple stack frames are unwound.
4458     local $stack_depth = $stack_depth + 1;    # Protect from non-local exits
4459
4460     {
4461         # lock ourselves under threads
4462         # While lock() permits recursive locks, there's two cases where it's bad
4463         # that we keep a hold on the lock while we call the sub:
4464         #  - during cloning, Package::CLONE might be called in the context of the new
4465         #    thread, which will deadlock if we hold the lock across the threads::new call
4466         #  - for any function that waits any significant time
4467         # This also deadlocks if the parent thread joins(), since holding the lock
4468         # will prevent any child threads passing this point.
4469         # So release the lock for the function call.
4470         lock($DBGR);
4471
4472         # Whether or not the autoloader was running, a scalar to put the
4473         # sub's return value in (if needed), and an array to put the sub's
4474         # return value in (if needed).
4475         if ($sub eq 'threads::new' && $ENV{PERL5DB_THREADED}) {
4476             print "creating new thread\n";
4477         }
4478
4479         # If the last ten characters are '::AUTOLOAD', note we've traced
4480         # into AUTOLOAD for $sub.
4481         if ( length($sub) > 10 && substr( $sub, -10, 10 ) eq '::AUTOLOAD' ) {
4482             no strict 'refs';
4483             $al = " for $$sub" if defined $$sub;
4484         }
4485
4486         # Expand @stack.
4487         $#stack = $stack_depth;
4488
4489         # Save current single-step setting.
4490         $stack[-1] = $single;
4491
4492         # Turn off all flags except single-stepping.
4493         $single &= 1;
4494
4495         # If we've gotten really deeply recursed, turn on the flag that will
4496         # make us stop with the 'deep recursion' message.
4497         $single |= 4 if $stack_depth == $deep;
4498
4499         # If frame messages are on ...
4500
4501         _print_frame_message($al);
4502     }
4503
4504     # Determine the sub's return type, and capture appropriately.
4505     if (wantarray) {
4506
4507         # Called in array context. call sub and capture output.
4508         # DB::DB will recursively get control again if appropriate; we'll come
4509         # back here when the sub is finished.
4510         no strict 'refs';
4511         @ret = &$sub;
4512     }
4513     elsif ( defined wantarray ) {
4514         no strict 'refs';
4515         # Save the value if it's wanted at all.
4516         $ret = &$sub;
4517     }
4518     else {
4519         no strict 'refs';
4520         # Void return, explicitly.
4521         &$sub;
4522         undef $ret;
4523     }
4524
4525     {
4526         lock($DBGR);
4527
4528         # Pop the single-step value back off the stack.
4529         $single |= $stack[ $stack_depth-- ];
4530
4531         if ($frame & 2) {
4532             if ($frame & 4) {   # Extended exit message
4533                 _indent_print_line_info(0, "out ");
4534                 print_trace( $LINEINFO, -1, 1, 1, "$sub$al" );
4535             }
4536             else {
4537                 _indent_print_line_info(0, "exited $sub$al\n" );
4538             }
4539         }
4540
4541         if (wantarray) {
4542             # Print the return info if we need to.
4543             if ( $doret eq $stack_depth or $frame & 16 ) {
4544
4545                 # Turn off output record separator.
4546                 local $\ = '';
4547                 my $fh = ( $doret eq $stack_depth ? $OUT : $LINEINFO );
4548
4549                 # Indent if we're printing because of $frame tracing.
4550                 if ($frame & 16)
4551                   {
4552                       print {$fh} ' ' x $stack_depth;
4553                   }
4554
4555                 # Print the return value.
4556                 print {$fh} "list context return from $sub:\n";
4557                 dumpit( $fh, \@ret );
4558
4559                 # And don't print it again.
4560                 $doret = -2;
4561             } ## end if ($doret eq $stack_depth...
4562             # And we have to return the return value now.
4563             @ret;
4564         } ## end if (wantarray)
4565         # Scalar context.
4566         else {
4567             # If we are supposed to show the return value... same as before.
4568             if ( $doret eq $stack_depth or $frame & 16 and defined wantarray ) {
4569                 local $\ = '';
4570                 my $fh = ( $doret eq $stack_depth ? $OUT : $LINEINFO );
4571                 print $fh ( ' ' x $stack_depth ) if $frame & 16;
4572                 print $fh (
4573                            defined wantarray
4574                            ? "scalar context return from $sub: "
4575                            : "void context return from $sub\n"
4576                           );
4577                 dumpit( $fh, $ret ) if defined wantarray;
4578                 $doret = -2;
4579             } ## end if ($doret eq $stack_depth...
4580
4581             # Return the appropriate scalar value.
4582             $ret;
4583         } ## end else [ if (wantarray)
4584     }
4585 } ## end sub _sub
4586
4587 sub lsub : lvalue {
4588
4589     # We stack the stack pointer and then increment it to protect us
4590     # from a situation that might unwind a whole bunch of call frames
4591     # at once. Localizing the stack pointer means that it will automatically
4592     # unwind the same amount when multiple stack frames are unwound.
4593     local $stack_depth = $stack_depth + 1;    # Protect from non-local exits
4594
4595     # Expand @stack.
4596     $#stack = $stack_depth;
4597
4598     # Save current single-step setting.
4599     $stack[-1] = $single;
4600
4601     # Turn off all flags except single-stepping.
4602     # Use local so the single-step value is popped back off the
4603     # stack for us.
4604     local $single = $single & 1;
4605
4606     no strict 'refs';
4607     {
4608         # lock ourselves under threads
4609         lock($DBGR);
4610
4611         # Whether or not the autoloader was running, a scalar to put the
4612         # sub's return value in (if needed), and an array to put the sub's
4613         # return value in (if needed).
4614         my ( $al, $ret, @ret ) = "";
4615         if ($sub =~ /^threads::new$/ && $ENV{PERL5DB_THREADED}) {
4616             print "creating new thread\n";
4617         }
4618
4619         # If the last ten characters are C'::AUTOLOAD', note we've traced
4620         # into AUTOLOAD for $sub.
4621         if ( length($sub) > 10 && substr( $sub, -10, 10 ) eq '::AUTOLOAD' ) {
4622             $al = " for $$sub";
4623         }
4624
4625         # If we've gotten really deeply recursed, turn on the flag that will
4626         # make us stop with the 'deep recursion' message.
4627         $single |= 4 if $stack_depth == $deep;
4628
4629         # If frame messages are on ...
4630         _print_frame_message($al);
4631     }
4632
4633     # call the original lvalue sub.
4634     &$sub;
4635 }
4636
4637 # Abstracting common code from multiple places elsewhere:
4638 sub depth_print_lineinfo {
4639     my $always_print = shift;
4640
4641     print_lineinfo( @_ ) if ($always_print or $stack_depth < $trace_to_depth);
4642 }
4643
4644 =head1 EXTENDED COMMAND HANDLING AND THE COMMAND API
4645
4646 In Perl 5.8.0, there was a major realignment of the commands and what they did,
4647 Most of the changes were to systematize the command structure and to eliminate
4648 commands that threw away user input without checking.
4649
4650 The following sections describe the code added to make it easy to support
4651 multiple command sets with conflicting command names. This section is a start
4652 at unifying all command processing to make it simpler to develop commands.
4653
4654 Note that all the cmd_[a-zA-Z] subroutines require the command name, a line
4655 number, and C<$dbline> (the current line) as arguments.
4656
4657 Support functions in this section which have multiple modes of failure C<die>
4658 on error; the rest simply return a false value.
4659
4660 The user-interface functions (all of the C<cmd_*> functions) just output
4661 error messages.
4662
4663 =head2 C<%set>
4664
4665 The C<%set> hash defines the mapping from command letter to subroutine
4666 name suffix.
4667
4668 C<%set> is a two-level hash, indexed by set name and then by command name.
4669 Note that trying to set the CommandSet to C<foobar> simply results in the
4670 5.8.0 command set being used, since there's no top-level entry for C<foobar>.
4671
4672 =cut
4673
4674 ### The API section
4675
4676 my %set = (    #
4677     'pre580' => {
4678         'a' => 'pre580_a',
4679         'A' => 'pre580_null',
4680         'b' => 'pre580_b',
4681         'B' => 'pre580_null',
4682         'd' => 'pre580_null',
4683         'D' => 'pre580_D',
4684         'h' => 'pre580_h',
4685         'M' => 'pre580_null',
4686         'O' => 'o',
4687         'o' => 'pre580_null',
4688         'v' => 'M',
4689         'w' => 'v',
4690         'W' => 'pre580_W',
4691     },
4692     'pre590' => {
4693         '<'  => 'pre590_prepost',
4694         '<<' => 'pre590_prepost',
4695         '>'  => 'pre590_prepost',
4696         '>>' => 'pre590_prepost',
4697         '{'  => 'pre590_prepost',
4698         '{{' => 'pre590_prepost',
4699     },
4700 );
4701
4702 my %breakpoints_data;
4703
4704 sub _has_breakpoint_data_ref {
4705     my ($filename, $line) = @_;
4706
4707     return (
4708         exists( $breakpoints_data{$filename} )
4709             and
4710         exists( $breakpoints_data{$filename}{$line} )
4711     );
4712 }
4713
4714 sub _get_breakpoint_data_ref {
4715     my ($filename, $line) = @_;
4716
4717     return ($breakpoints_data{$filename}{$line} ||= +{});
4718 }
4719
4720 sub _delete_breakpoint_data_ref {
4721     my ($filename, $line) = @_;
4722
4723     delete($breakpoints_data{$filename}{$line});
4724     if (! scalar(keys( %{$breakpoints_data{$filename}} )) ) {
4725         delete($breakpoints_data{$filename});
4726     }
4727
4728     return;
4729 }
4730
4731 sub _set_breakpoint_enabled_status {
4732     my ($filename, $line, $status) = @_;
4733
4734     _get_breakpoint_data_ref($filename, $line)->{'enabled'} =
4735         ($status ? 1 : '')
4736         ;
4737
4738     return;
4739 }
4740
4741 sub _enable_breakpoint_temp_enabled_status {
4742     my ($filename, $line) = @_;
4743
4744     _get_breakpoint_data_ref($filename, $line)->{'temp_enabled'} = 1;
4745
4746     return;
4747 }
4748
4749 sub _cancel_breakpoint_temp_enabled_status {
4750     my ($filename, $line) = @_;
4751
4752     my $ref = _get_breakpoint_data_ref($filename, $line);
4753
4754     delete ($ref->{'temp_enabled'});
4755
4756     if (! %$ref) {
4757         _delete_breakpoint_data_ref($filename, $line);
4758     }
4759
4760     return;
4761 }
4762
4763 sub _is_breakpoint_enabled {
4764     my ($filename, $line) = @_;
4765
4766     my $data_ref = _get_breakpoint_data_ref($filename, $line);
4767     return ($data_ref->{'enabled'} || $data_ref->{'temp_enabled'});
4768 }
4769
4770 =head2 C<cmd_wrapper()> (API)
4771
4772 C<cmd_wrapper()> allows the debugger to switch command sets
4773 depending on the value of the C<CommandSet> option.
4774
4775 It tries to look up the command in the C<%set> package-level I<lexical>
4776 (which means external entities can't fiddle with it) and create the name of
4777 the sub to call based on the value found in the hash (if it's there). I<All>
4778 of the commands to be handled in a set have to be added to C<%set>; if they
4779 aren't found, the 5.8.0 equivalent is called (if there is one).
4780
4781 This code uses symbolic references.
4782
4783 =cut
4784
4785 sub cmd_wrapper {
4786     my $cmd      = shift;
4787     my $line     = shift;
4788     my $dblineno = shift;
4789
4790     # Assemble the command subroutine's name by looking up the
4791     # command set and command name in %set. If we can't find it,
4792     # default to the older version of the command.
4793     my $call = 'cmd_'
4794       . ( $set{$CommandSet}{$cmd}
4795           || ( $cmd =~ /\A[<>{]+/o ? 'prepost' : $cmd ) );
4796
4797     # Call the command subroutine, call it by name.
4798     return __PACKAGE__->can($call)->( $cmd, $line, $dblineno );
4799 } ## end sub cmd_wrapper
4800
4801 =head3 C<cmd_a> (command)
4802
4803 The C<a> command handles pre-execution actions. These are associated with a
4804 particular line, so they're stored in C<%dbline>. We default to the current
4805 line if none is specified.
4806
4807 =cut
4808
4809 sub cmd_a {
4810     my $cmd    = shift;
4811     my $line   = shift || '';    # [.|line] expr
4812     my $dbline = shift;
4813
4814     # If it's dot (here), or not all digits,  use the current line.
4815     $line =~ s/\A\./$dbline/;
4816
4817     # Should be a line number followed by an expression.
4818     if ( my ($lineno, $expr) = $line =~ /^\s*(\d*)\s*(\S.+)/ ) {
4819
4820         if (! length($lineno)) {
4821             $lineno = $dbline;
4822         }
4823
4824         # If we have an expression ...
4825         if ( length $expr ) {
4826
4827             # ... but the line isn't breakable, complain.
4828             if ( $dbline[$lineno] == 0 ) {
4829                 print $OUT
4830                   "Line $lineno($dbline[$lineno]) does not have an action?\n";
4831             }
4832             else {
4833
4834                 # It's executable. Record that the line has an action.
4835                 $had_breakpoints{$filename} |= 2;
4836
4837                 # Remove any action, temp breakpoint, etc.
4838                 $dbline{$lineno} =~ s/\0[^\0]*//;
4839
4840                 # Add the action to the line.
4841                 $dbline{$lineno} .= "\0" . action($expr);
4842
4843                 _set_breakpoint_enabled_status($filename, $lineno, 1);
4844             }
4845         } ## end if (length $expr)
4846     } ## end if ($line =~ /^\s*(\d*)\s*(\S.+)/)
4847     else {
4848
4849         # Syntax wrong.
4850         print $OUT
4851           "Adding an action requires an optional lineno and an expression\n"
4852           ;    # hint
4853     }
4854 } ## end sub cmd_a