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