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
CommitLineData
69893cff
RGS
1=head1 NAME
2
3C<perl5db.pl> - the perl debugger
4
5=head1 SYNOPSIS
6
7 perl -d your_Perl_script
8
9=head1 DESCRIPTION
10
11C<perl5db.pl> is the perl debugger. It is loaded automatically by Perl when
12you invoke a script with C<perl -d>. This documentation tries to outline the
13structure and services provided by C<perl5db.pl>, and to describe how you
14can use them.
15
16=head1 GENERAL NOTES
17
18The debugger can look pretty forbidding to many Perl programmers. There are
19a number of reasons for this, many stemming out of the debugger's history.
20
21When the debugger was first written, Perl didn't have a lot of its nicer
22features - no references, no lexical variables, no closures, no object-oriented
23programming. So a lot of the things one would normally have done using such
24features was done using global variables, globs and the C<local()> operator
25in creative ways.
26
27Some of these have survived into the current debugger; a few of the more
28interesting and still-useful idioms are noted in this section, along with notes
29on the comments themselves.
30
31=head2 Why not use more lexicals?
32
33Experienced Perl programmers will note that the debugger code tends to use
34mostly package globals rather than lexically-scoped variables. This is done
35to allow a significant amount of control of the debugger from outside the
36debugger itself.
37
38Unfortunately, though the variables are accessible, they're not well
39documented, so it's generally been a decision that hasn't made a lot of
40difference to most users. Where appropriate, comments have been added to
41make variables more accessible and usable, with the understanding that these
42i<are> debugger internals, and are therefore subject to change. Future
43development should probably attempt to replace the globals with a well-defined
44API, but for now, the variables are what we've got.
45
46=head2 Automated variable stacking via C<local()>
47
48As you may recall from reading C<perlfunc>, the C<local()> operator makes a
49temporary copy of a variable in the current scope. When the scope ends, the
50old copy is restored. This is often used in the debugger to handle the
51automatic stacking of variables during recursive calls:
52
53 sub foo {
54 local $some_global++;
55
56 # Do some stuff, then ...
57 return;
58 }
59
60What happens is that on entry to the subroutine, C<$some_global> is localized,
61then altered. When the subroutine returns, Perl automatically undoes the
62localization, restoring the previous value. Voila, automatic stack management.
63
64The debugger uses this trick a I<lot>. Of particular note is C<DB::eval>,
65which lets the debugger get control inside of C<eval>'ed code. The debugger
66localizes a saved copy of C<$@> inside the subroutine, which allows it to
67keep C<$@> safe until it C<DB::eval> returns, at which point the previous
68value of C<$@> is restored. This makes it simple (well, I<simpler>) to keep
69track of C<$@> inside C<eval>s which C<eval> other C<eval's>.
70
71In any case, watch for this pattern. It occurs fairly often.
72
73=head2 The C<^> trick
74
75This is used to cleverly reverse the sense of a logical test depending on
76the value of an auxiliary variable. For instance, the debugger's C<S>
77(search for subroutines by pattern) allows you to negate the pattern
78like this:
79
80 # Find all non-'foo' subs:
81 S !/foo/
82
83Boolean 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
105As you can see, the first pair applies when C<!> isn't supplied, and
106the second pair applies when it isn't. The XOR simply allows us to
107compact a more complicated if-then-elseif-else into a more elegant
108(but perhaps overly clever) single test. After all, it needed this
109explanation...
110
111=head2 FLAGS, FLAGS, FLAGS
112
113There is a certain C programming legacy in the debugger. Some variables,
114such as C<$single>, C<$trace>, and C<$frame>, have "magical" values composed
115of 1, 2, 4, etc. (powers of 2) OR'ed together. This allows several pieces
116of state to be stored independently in a single scalar.
117
118A test like
119
120 if ($scalar & 4) ...
121
122is 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
124an array of bits. Obviously, since the contents of C<$scalar> are just a
125bit-pattern, we can save and restore it easily (it will just look like
126a number).
127
128The problem, is of course, that this tends to leave magic numbers scattered
129all over your program whenever a bit is set, cleared, or checked. So why do
130it?
131
132=over 4
133
134
135=item * First, doing an arithmetical or bitwise operation on a scalar is
136just about the fastest thing you can do in Perl: C<use constant> actually
137creates a subroutine call, and array hand hash lookups are much slower. Is
138this over-optimization at the expense of readability? Possibly, but the
139debugger accesses these variables a I<lot>. Any rewrite of the code will
140probably have to benchmark alternate implementations and see which is the
141best balance of readability and speed, and then document how it actually
142works.
143
144=item * Second, it's very easy to serialize a scalar number. This is done in
145the restart code; the debugger state variables are saved in C<%ENV> and then
146restored when the debugger is restarted. Having them be just numbers makes
147this trivial.
148
149=item * Third, some of these variables are being shared with the Perl core
150smack in the middle of the interpreter's execution loop. It's much faster for
151a C program (like the interpreter) to check a bit in a scalar than to access
152several different variables (or a Perl array).
153
154=back
155
156=head2 What are those C<XXX> comments for?
157
158Any comment containing C<XXX> means that the comment is either somewhat
159speculative - it's not exactly clear what a given variable or chunk of
160code is doing, or that it is incomplete - the basics may be clear, but the
161subtleties are not completely documented.
162
163Send in a patch if you can clear up, fill out, or clarify an C<XXX>.
164
165=head1 DATA STRUCTURES MAINTAINED BY CORE
166
167There are a number of special data structures provided to the debugger by
168the Perl interpreter.
169
170The array C<@{$main::{'_<'.$filename}}> (aliased locally to C<@dbline> via glob
171assignment) contains the text from C<$filename>, with each element
172corresponding to a single line of C<$filename>.
173
174The hash C<%{'_<'.$filename}> (aliased locally to C<%dbline> via glob
175assignment) contains breakpoints and actions. The keys are line numbers;
176you can set individual values, but not the whole hash. The Perl interpreter
177uses this hash to determine where breakpoints have been set. Any true value is
178considered to be a breakpoint; C<perl5db.pl> uses "$break_condition\0$action".
179Values are magical in numeric context: 1 if the line is breakable, 0 if not.
180
181The scalar ${'_<'.$filename} contains $filename XXX What?
182
183=head1 DEBUGGER STARTUP
184
185When C<perl5db.pl> starts, it reads an rcfile (C<perl5db.ini> for
186non-interactive sessions, C<.perldb> for interactive ones) that can set a number
187of options. In addition, this file may define a subroutine C<&afterinit>
188that will be executed (in the debugger's context) after the debugger has
189initialized itself.
190
191Next, it checks the C<PERLDB_OPTS> environment variable and treats its
192contents as the argument of a debugger <C<o> command.
193
194=head2 STARTUP-ONLY OPTIONS
195
196The following options can only be specified at startup.
197To set them in your rcfile, add a call to
198C<&parse_options("optionName=new_value")>.
199
200=over 4
201
202=item * TTY
203
204the TTY to use for debugging i/o.
205
206=item * noTTY
207
208if set, goes in NonStop mode. On interrupt, if TTY is not set,
209uses the value of noTTY or "/tmp/perldbtty$$" to find TTY using
210Term::Rendezvous. Current variant is to have the name of TTY in this
211file.
212
213=item * ReadLine
214
215If false, a dummy ReadLine is used, so you can debug
216ReadLine applications.
217
218=item * NonStop
219
220if true, no i/o is performed until interrupt.
221
222=item * LineInfo
223
224file or pipe to print line number info to. If it is a
225pipe, a short "emacs like" message is used.
226
227=item * RemotePort
228
229host: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
238The script will run without human intervention, putting trace
239information into C<db.out>. (If you interrupt it, you had better
240reset C<LineInfo> to something "interactive"!)
241
242=head1 INTERNALS DESCRIPTION
243
244=head2 DEBUGGER INTERFACE VARIABLES
245
246Perl supplies the values for C<%sub>. It effectively inserts
247a C<&DB'DB();> in front of each place that can have a
248breakpoint. At each subroutine call, it calls C<&DB::sub> with
249C<$DB::sub> set to the called subroutine. It also inserts a C<BEGIN
250{require 'perl5db.pl'}> before the first line.
251
252After each C<require>d file is compiled, but before it is executed, a
253call to C<&DB::postponed($main::{'_<'.$filename})> is done. C<$filename>
254is 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
260Used to control when the debugger will attempt to acquire another TTY to be
261used 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
275The value -2 indicates that no return value should be printed.
276Any other positive value causes C<DB::sub> to print return values.
277
278=head4 C<$evalarg>
279
280The item to be eval'ed by C<DB::eval>. Used to prevent messing with the current
281contents of C<@_> when C<DB::eval> is called.
282
283=head4 C<$frame>
284
285Determines what messages (if any) will get printed when a subroutine (or eval)
286is 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
304To get everything, use C<$frame=30> (or C<o f-30> as a debugger command).
305The debugger internally juggles the value of C<$frame> during execution to
306protect external modules that the debugger uses from getting traced.
307
308=head4 C<$level>
309
310Tracks current debugger nesting level. Used to figure out how many
311C<E<lt>E<gt>> pairs to surround the line number with when the debugger
312outputs a prompt. Also used to help determine if the program has finished
313during command parsing.
314
315=head4 C<$onetimeDump>
316
317Controls what (if anything) C<DB::eval()> will print after evaluating an
318expression.
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
332Controls how far down C<dumpvar.pl> will go before printing '...' while
333dumping a structure. Numeric. If C<undef>, print all levels.
334
335=head4 C<$signal>
336
337Used to track whether or not an C<INT> signal has been detected. C<DB::DB()>,
338which is called before every statement, checks this and puts the user into
339command mode if it finds C<$signal> set to a true value.
340
341=head4 C<$single>
342
343Controls behavior during single-stepping. Stacked in C<@stack> on entry to
344each 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
355recursion" occurs.
356
357=back
358
359=head4 C<$trace>
360
361Controls 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
3751 if C<LINEINFO> was directed to a pipe; 0 otherwise.
376
377=head4 C<@cmdfhs>
378
379Stack of filehandles that C<DB::readline()> will read commands from.
380Manipulated by the debugger's C<source> command and C<DB::readline()> itself.
381
382=head4 C<@dbline>
383
384Local alias to the magical line array, C<@{$main::{'_<'.$filename}}> ,
385supplied by the Perl interpreter to the debugger. Contains the source.
386
387=head4 C<@old_watch>
388
389Previous values of watch expressions. First set when the expression is
390entered; reset whenever the watch expression changes.
391
392=head4 C<@saved>
393
394Saves important globals (C<$@>, C<$!>, C<$^E>, C<$,>, C<$/>, C<$\>, C<$^W>)
395so that the debugger can substitute safe values while it's running, and
396restore them when it returns control.
397
398=head4 C<@stack>
399
400Saves the current value of C<$single> on entry to a subroutine.
401Manipulated by the C<c> command to turn off tracing in all subs above the
402current one.
403
404=head4 C<@to_watch>
405
406The 'watch' expressions: to be evaluated before each line is executed.
407
408=head4 C<@typeahead>
409
410The typeahead buffer, used by C<DB::readline>.
411
412=head4 C<%alias>
413
414Command aliases. Stored as character strings to be substituted for a command
415entered.
416
417=head4 C<%break_on_load>
418
419Keys 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
424Keys are line numbers, values are "condition\0action". If used in numeric
425context, values are 0 if not breakable, 1 if breakable, no matter what is
426in the actual hash entry.
427
428=head4 C<%had_breakpoints>
429
430Keys 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
440A zero or undefined value means this file has neither.
441
442=head4 C<%option>
443
444Stores the debugger options. These are character string values.
445
446=head4 C<%postponed>
447
448Saves breakpoints for code that hasn't been compiled yet.
449Keys 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
461This hash keeps track of breakpoints that need to be set for files that have
462not yet been compiled. Keys are filenames; values are references to hashes.
463Each of these hashes is keyed by line number, and its values are breakpoint
464definitions ("condition\0action").
465
466=head1 DEBUGGER INITIALIZATION
467
468The debugger's initialization actually jumps all over the place inside this
469package. This is because there are several BEGIN blocks (which of course
470execute immediately) spread through the code. Why is that?
471
472The debugger needs to be able to change some things and set some things up
473before the debugger code is compiled; most notably, the C<$deep> variable that
474C<DB::sub> uses to tell when a program has recursed deeply. In addition, the
475debugger has to turn off warnings while the debugger code is compiled, but then
476restore them to their original setting before the program being debugged begins
477executing.
478
479The first C<BEGIN> block simply turns off warnings by saving the current
480setting of C<$^W> and then setting it to zero. The second one initializes
481the debugger variables that are needed before the debugger begins executing.
482The third one puts C<$^X> back to its former value.
483
484We'll detail the second C<BEGIN> block later; just remember that if you need
485to initialize something before the debugger starts really executing, that's
486where it has to go.
487
488=cut
489
a687059c
LW
490package DB;
491
9eba6a4e
AV
492use IO::Handle;
493
54d04a52 494# Debugger for Perl 5.00x; perl5db.pl patch level:
69893cff
RGS
495$VERSION = 1.25;
496
492652be 497$header = "perl5db.pl version $VERSION";
d338d6fe 498
69893cff
RGS
499=head1 DEBUGGER ROUTINES
500
501=head2 C<DB::eval()>
502
503This function replaces straight C<eval()> inside the debugger; it simplifies
504the process of evaluating code in the user's context.
505
506The code to be evaluated is passed via the package global variable
507C<$DB::evalarg>; this is done to avoid fiddling with the contents of C<@_>.
508
509We preserve the current settings of X<C<$trace>>, X<C<$single>>, and X<C<$^D>>;
510add the X<C<$usercontext>> (that's the preserved values of C<$@>, C<$!>,
511C<$^E>, C<$,>, C<$/>, C<$\>, and C<$^W>, grabbed when C<DB::DB> got control,
512and the user's current package) and a add a newline before we do the C<eval()>.
513This causes the proper context to be used when the eval is actually done.
514Afterward, we restore C<$trace>, C<$single>, and C<$^D>.
515
516Next we need to handle C<$@> without getting confused. We save C<$@> in a
517local lexical, localize C<$saved[0]> (which is where C<save()> will put
518C<$@>), and then call C<save()> to capture C<$@>, C<$!>, C<$^E>, C<$,>,
519C<$/>, C<$\>, and C<$^W>) and set C<$,>, C<$/>, C<$\>, and C<$^W> to values
520considered sane by the debugger. If there was an C<eval()> error, we print
521it on the debugger's output. If X<C<$onetimedump>> is defined, we call
522X<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
524but 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
526expression but not show it unless it matters).
527
528In any case, we then return the list of output from C<eval> to the caller,
529and 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
534C<DB::eval> isn't parameterized in the standard way; this is to keep the
535debugger's calls to C<DB::eval()> from mucking with C<@_>, among other things.
536The 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
552The following variables are altered by C<DB::eval()> during its execution. They
553are "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
573The context of C<DB::eval()> presents us with some problems. Obviously,
574we want to be 'sandboxed' away from the debugger's internals when we do
575the eval, but we need some way to control how punctuation variables and
576debugger globals are used.
577
578We can't use local, because the code inside C<DB::eval> can see localized
579variables; and we can't use C<my> either for the same reason. The code
580in this routine compromises and uses C<my>.
581
582After this routine is over, we don't have user code executing in the debugger's
583context, 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
c1051fcf 596sub eval {
69893cff 597
c1051fcf 598 # 'my' would make it visible from user code
69893cff
RGS
599 # but so does local! --tchrist
600 # Remember: this localizes @DB::res, not @main::res.
c1051fcf
IZ
601 local @res;
602 {
69893cff
RGS
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;
c1051fcf 625 }
69893cff
RGS
626
627 # Save the current value of $@, and preserve it in the debugger's copy
628 # of the saved precious globals.
c1051fcf 629 my $at = $@;
69893cff
RGS
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 $@
c1051fcf 634 eval { &DB::save };
69893cff
RGS
635
636 # Now see whether we need to report an error back to the user.
c1051fcf 637 if ($at) {
69893cff
RGS
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
d12a4851 647 if defined $onetimedumpDepth;
69893cff 648 dumpit($OUT, \@res);
d12a4851 649 }
69893cff
RGS
650 elsif ($onetimeDump eq 'methods') {
651 methods($res[0]);
652 }
653 } ## end elsif ($onetimeDump)
c1051fcf 654 @res;
69893cff
RGS
655} ## end sub eval
656
657############################################## End lexical danger zone
c1051fcf 658
d12a4851 659# After this point it is safe to introduce lexicals
69893cff
RGS
660# The code being debugged will be executing in its own context, and
661# can't see the inside of the debugger.
d338d6fe 662#
69893cff
RGS
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
d338d6fe
PP
667# This file is automatically included if you do perl -d.
668# It's probably not useful to include this yourself.
669#
2f7e9187
MS
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#
69893cff
RGS
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
d338d6fe 678# Note that no subroutine call is possible until &DB::sub is defined
36477c24 679# (for subroutines defined outside of the package DB). In fact the same is
d338d6fe
PP
680# true if $deep is not defined.
681#
69893cff 682# $Log: perldb.pl,v $
055fd3a9
GS
683
684# Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich)
055fd3a9
GS
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
69893cff
RGS
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#
36477c24 731# Changes: 0.97: NonStop will not stop in at_exit().
69893cff
RGS
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.
1d06cb2d 736# Changes: 0.98: New command `m' for printing possible methods
69893cff
RGS
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.
477ea2b1 748# Changes: 0.99: Completion for `f', `m'.
69893cff
RGS
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').
055fd3a9
GS
753# Changes: 1.07: Many fixed by tchrist 13-March-2000
754# BUG FIXES:
04e43a21 755# + Added bare minimal security checks on perldb rc files, plus
055fd3a9
GS
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,
04e43a21 763# and needs a lot of work at restructuring. It's also misindented
055fd3a9
GS
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,
04e43a21 772# tricking Perl into thinking you weren't calling a debugger command!
055fd3a9
GS
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.
04e43a21
DL
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>
69893cff
RGS
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_*():
04e43a21
DL
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
492652be 828# cmd_d($lineno) # d lineno (B)
04e43a21
DL
829# The cmd_*() API returns FALSE on failure; in this case it outputs
830# the error message to the debugging output.
69893cff 831# + Low-level debugger API
04e43a21
DL
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
69893cff
RGS
837# # to $from, and may be less than
838# # $to
04e43a21
DL
839# breakable_line($from [, $to]) # Same for the current file
840# break_on_filename_line($name, $lineno [, $cond])
69893cff
RGS
841# # Set breakpoint,$cond defaults to
842# # 1
04e43a21
DL
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
600d99fa
DL
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)
6f891d7d
SM
864# Changes: 1.13: Jun 19, 2001 Scott.L.Miller@compaq.com
865# + Added windowSize option
2f7e9187
MS
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
492652be 876# Changes: 1.16: Feb 15, 2002 Mark-Jason Dominus <mjd@plover.com>
69893cff 877# + $onetimeDump improvements
492652be
RF
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)
69893cff
RGS
885# + w(add), W(del) # watch expr (was W,W)
886# # added del by expr
492652be
RF
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)
aef14ef9
RF
891# Changes: 1.18: Mar 17, 2002 Richard Foley <richard.foley@rfi.net>
892# + fixed missing cmd_O bug
471505cc 893# Changes: 1.19: Mar 29, 2002 Spider Boardman
894# + Added missing local()s -- DB::DB is called recursively.
35408c4e
RF
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()
69893cff
RGS
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
de5e1a3d 904# + Fix a side-effect of bug #24674 in the perl debugger ("odd taint bug")
e219e2fb
RF
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.
69893cff
RGS
909# Changes: 1.25 (again :)
910# + unfork the 5.8.x and 5.9.x debuggers.
911# + Richard Foley and Joe McMahon
ee971a18 912####################################################################
d338d6fe 913
69893cff
RGS
914=head1 DEBUGGER INITIALIZATION
915
916The debugger starts up in phases.
917
918=head2 BASIC SETUP
919
920First, it initializes the environment it wants to run in: turning off
921warnings during its own compilation, defining variables which it will need
922to avoid warnings later, setting itself up to not exit when the program
923terminates, and defaulting to printing return values for the C<r> command.
924
925=cut
926
eda6e075 927# Needed for the statement after exec():
69893cff
RGS
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.
eda6e075 932
69893cff
RGS
933
934BEGIN {
935 $ini_warn = $^W;
936 $^W = 0;
937} # Switch compilation warnings off until another BEGIN.
d12a4851
JH
938
939# test if assertions are supported and actived:
eda6e075 940BEGIN {
d12a4851 941 $ini_assertion=
69893cff 942 eval "sub asserting_test : assertion {1}; 1";
d12a4851
JH
943 # $ini_assertion = undef => assertions unsupported,
944 # " = 1 => assertions suported
945 # print "\$ini_assertion=$ini_assertion\n";
946}
947
69893cff
RGS
948local ($^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.
954warn( # 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;
d338d6fe 980
54d04a52 981# Command-line + PERLLIB:
69893cff 982# Save the contents of @INC before they are modified elsewhere.
54d04a52
IZ
983@ini_INC = @INC;
984
69893cff
RGS
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!
d338d6fe
PP
987# $prevwarn = $prevdie = $prevbus = $prevsegv = ''; # Does not help?!
988
69893cff
RGS
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.
55497cff 996$inhibit_exit = $option{PrintRet} = 1;
d338d6fe 997
69893cff
RGS
998=head1 OPTION PROCESSING
999
1000The debugger's options are actually spread out over the debugger itself and
1001C<dumpvar.pl>; some of these are variables to be set, while others are
1002subs to be called with a value. To try to make this a little easier to
1003manage, the debugger uses a few data structures to define what options
1004are legal and how they are to be processed.
1005
1006First, the C<@options> array defines the I<names> of all the options that
1007are 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 );
d12a4851
JH
1027
1028@RememberOnROptions = qw(DollarCaretP OnlyAssertions);
1029
69893cff
RGS
1030=pod
1031
1032Second, C<optionVars> lists the variables that each option uses to save its
1033state.
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
1062Third, C<%optionAction> defines the subroutine to be called to process each
1063option.
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,
d12a4851
JH
1087);
1088
69893cff
RGS
1089=pod
1090
1091Last, the C<%optionRequire> notes modules that must be C<require>d if an
1092option is used.
1093
1094=cut
d338d6fe 1095
69893cff
RGS
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.
eda6e075 1101%optionRequire = (
69893cff
RGS
1102 compactDump => 'dumpvar.pl',
1103 veryCompact => 'dumpvar.pl',
1104 quote => 'dumpvar.pl',
1105 );
1106
1107=pod
1108
1109There are a number of initialization-related variables which can be set
1110by putting code to set them in a BEGIN block in the C<PERL5DB> environment
1111variable. 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
d338d6fe
PP
1136
1137# These guys may be defined in $ENV{PERL5DB} :
69893cff
RGS
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
1150The default C<die>, C<warn>, and C<signal> handlers are set up.
1151
1152=cut
055fd3a9 1153
d338d6fe
PP
1154warnLevel($warnLevel);
1155dieLevel($dieLevel);
1156signalLevel($signalLevel);
055fd3a9 1157
69893cff
RGS
1158=pod
1159
1160The pager to be used is needed next. We try to get it from the
1161environment first. if it's not defined there, we try to find it in
1162the Perl C<Config.pm>. If it's not there, we default to C<more>. We
1163then 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.
4865a36d 1168pager(
69893cff
RGS
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
1184We set up the command to be used to access the man pages, the command
1185recall character ("!" unless otherwise defined) and the shell escape
1186character ("!" unless otherwise defined). Yes, these do conflict, and
1187neither works in the debugger at the moment.
1188
1189=cut
1190
055fd3a9 1191setman();
69893cff
RGS
1192
1193# Set up defaults for command recall and shell escape (note:
1194# these currently don't work in linemode debugging).
d338d6fe 1195&recallCommand("!") unless defined $prc;
69893cff
RGS
1196&shellBang("!") unless defined $psh;
1197
1198=pod
1199
1200We then set up the gigantic string containing the debugger help.
1201We also set the limit on the number of arguments we'll display during a
1202trace.
1203
1204=cut
1205
04e43a21 1206sethelp();
69893cff
RGS
1207
1208# If we didn't get a default for the length of eval/stack trace args,
1209# set it here.
1d06cb2d 1210$maxtrace = 400 unless defined $maxtrace;
69893cff
RGS
1211
1212=head2 SETTING UP THE DEBUGGER GREETING
1213
1214The debugger 'greeting' helps to inform the user how many debuggers are
1215running, and whether the current debugger is the primary or a child.
1216
1217If we are the primary, we just hang onto our pid so we'll have it when
1218or if we start a child debugger. If we are a child, we'll set things up
1219so we'll have a unique greeting and so the parent will give us our own
1220TTY later.
1221
1222We save the current contents of the C<PERLDB_PIDS> environment variable
1223because we mess around with it. We'll also need to hang onto it because
1224we'll need it if we restart.
1225
1226Child debuggers make a label out of the current PID structure recorded in
1227PERLDB_PIDS plus the new PID. They also mark themselves as not having a TTY
1228yet 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.
f1583d8f 1234$ini_pids = $ENV{PERLDB_PIDS};
69893cff
RGS
1235
1236if (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().
d12a4851
JH
1240 $pids = "[$ENV{PERLDB_PIDS}]";
1241 $ENV{PERLDB_PIDS} .= "->$$";
1242 $term_pid = -1;
69893cff
RGS
1243} ## end if (defined $ENV{PERLDB_PIDS...
1244else {
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 = $$;
f1583d8f 1251}
69893cff 1252
f1583d8f 1253$pidprompt = '';
69893cff
RGS
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
1260The debugger will read a file of initialization options if supplied. If
1261running 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.
d338d6fe 1267
d12a4851
JH
1268if (-e "/dev/tty") { # this is the wrong metric!
1269 $rcfile=".perldb";
69893cff
RGS
1270}
1271else {
1272 $rcfile = "perldb.ini";
d338d6fe
PP
1273}
1274
69893cff
RGS
1275=pod
1276
1277The debugger does a safety test of the file to be read. It must be owned
1278either 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#
055fd3a9
GS
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
69893cff
RGS
1288# your lexical scope, which is unfortunate at best.
1289sub safe_do {
055fd3a9
GS
1290 my $file = shift;
1291
1292 # Just exactly what part of the word "CORE::" don't you understand?
69893cff
RGS
1293 local $SIG{__WARN__};
1294 local $SIG{__DIE__};
055fd3a9
GS
1295
1296 unless (is_safe_file($file)) {
69893cff 1297 CORE::warn <<EO_GRIPE;
055fd3a9
GS
1298perldb: Must not source insecure rcfile $file.
1299 You or the superuser must be the owner, and it must not
69893cff 1300 be writable by anyone but its owner.
055fd3a9 1301EO_GRIPE
69893cff
RGS
1302 return;
1303 } ## end unless (is_safe_file($file...
055fd3a9
GS
1304
1305 do $file;
1306 CORE::warn("perldb: couldn't parse $file: $@") if $@;
69893cff 1307} ## end sub safe_do
055fd3a9 1308
69893cff
RGS
1309# This is the safety test itself.
1310#
055fd3a9
GS
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.
1317sub is_safe_file {
1318 my $path = shift;
69893cff
RGS
1319 stat($path) || return; # mysteriously vaporized
1320 my ($dev, $ino, $mode, $nlink, $uid, $gid) = stat(_);
055fd3a9
GS
1321
1322 return 0 if $uid != 0 && $uid != $<;
1323 return 0 if $mode & 022;
1324 return 1;
69893cff 1325} ## end sub is_safe_file
055fd3a9 1326
69893cff
RGS
1327# If the rcfile (whichever one we decided was the right one to read)
1328# exists, we safely do it.
d338d6fe 1329if (-f $rcfile) {
055fd3a9 1330 safe_do("./$rcfile");
69893cff
RGS
1331}
1332# If there isn't one here, try the user's home directory.
055fd3a9
GS
1333elsif (defined $ENV{HOME} && -f "$ENV{HOME}/$rcfile") {
1334 safe_do("$ENV{HOME}/$rcfile");
1335}
69893cff 1336# Else try the login directory.
055fd3a9
GS
1337elsif (defined $ENV{LOGDIR} && -f "$ENV{LOGDIR}/$rcfile") {
1338 safe_do("$ENV{LOGDIR}/$rcfile");
d338d6fe
PP
1339}
1340
69893cff 1341# If the PERLDB_OPTS variable has options in it, parse those out next.
d338d6fe 1342if (defined $ENV{PERLDB_OPTS}) {
69893cff 1343 parse_options($ENV{PERLDB_OPTS});
d338d6fe
PP
1344}
1345
69893cff
RGS
1346=pod
1347
1348The last thing we do during initialization is determine which subroutine is
1349to be used to obtain a new terminal when a new debugger is started. Right now,
1350the 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
1360if (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{
d12a4851 1368 *get_fork_TTY = \&xterm_get_fork_TTY;
69893cff
RGS
1369} ## end if (not defined &get_fork_TTY...
1370elsif ($^O eq 'os2') {
d12a4851 1371 *get_fork_TTY = \&os2_get_fork_TTY;
f1583d8f 1372}
dbb46cec
DQ
1373# untaint $^O, which may have been tainted by the last statement.
1374# see bug [perl #24674]
1375$^O =~ m/^(.*)\z/; $^O = $1;
f1583d8f 1376
d12a4851 1377# Here begin the unreadable code. It needs fixing.
055fd3a9 1378
69893cff
RGS
1379=head2 RESTART PROCESSING
1380
1381This section handles the restart command. When the C<R> command is invoked, it
1382tries to capture all of the state it can into environment variables, and
1383then sets C<PERLDB_RESTART>. When we start executing again, we check to see
1384if C<PERLDB_RESTART> is there; if so, we reload all the information that
1385the 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
1400We chug through all these variables and plug the values saved in them
1401back into the appropriate spots in the debugger.
1402
1403=cut
1404
54d04a52 1405if (exists $ENV{PERLDB_RESTART}) {
69893cff 1406 # We're restarting, so we don't need the flag that says to restart anymore.
d12a4851
JH
1407 delete $ENV{PERLDB_RESTART};
1408 # $restart = 1;
69893cff 1409 @hist = get_list('PERLDB_HIST');
d12a4851 1410 %break_on_load = get_list("PERLDB_ON_LOAD");
69893cff
RGS
1411 %postponed = get_list("PERLDB_POSTPONE");
1412
1413 # restore breakpoints/actions
1414 my @had_breakpoints = get_list("PERLDB_VISITED");
d12a4851
JH
1415 for (0 .. $#had_breakpoints) {
1416 my %pf = get_list("PERLDB_FILE_$_");
69893cff 1417 $postponed_file{ $had_breakpoints[$_] } = \%pf if %pf;
d12a4851 1418 }
69893cff
RGS
1419
1420 # restore options
d12a4851 1421 my %opt = get_list("PERLDB_OPT");
69893cff
RGS
1422 my ($opt, $val);
1423 while (($opt, $val) = each %opt) {
d12a4851
JH
1424 $val =~ s/[\\\']/\\$1/g;
1425 parse_options("$opt'$val'");
1426 }
69893cff
RGS
1427
1428 # restore original @INC
1429 @INC = get_list("PERLDB_INC");
d12a4851 1430 @ini_INC = @INC;
69893cff
RGS
1431
1432 # return pre/postprompt actions and typeahead buffer
d12a4851 1433 $pretype = [get_list("PERLDB_PRETYPE")];
69893cff
RGS
1434 $pre = [get_list("PERLDB_PRE")];
1435 $post = [get_list("PERLDB_POST")];
d12a4851 1436 @typeahead = get_list("PERLDB_TYPEAHEAD", @typeahead);
69893cff
RGS
1437} ## end if (exists $ENV{PERLDB_RESTART...
1438
1439=head2 SETTING UP THE TERMINAL
1440
1441Now, we'll decide how the debugger is going to interact with the user.
1442If there's no TTY, we set the debugger to run non-stop; there's not going
1443to be anyone there to enter commands.
1444
1445=cut
54d04a52 1446
d338d6fe 1447if ($notty) {
69893cff
RGS
1448 $runnonstop = 1;
1449}
d12a4851 1450
69893cff
RGS
1451=pod
1452
1453If there is a TTY, we have to determine who it belongs to before we can
1454proceed. If this is a slave editor or graphical debugger (denoted by
1455the first command-line switch being '-emacs'), we shift this off and
1456set C<$rl> to 0 (XXX ostensibly to do straight reads).
1457
1458=cut
1459
1460else {
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;
d12a4851
JH
1466 #require Term::ReadLine;
1467
69893cff
RGS
1468=pod
1469
1470We 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:
1500Console> 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";
d12a4851 1521 }
69893cff
RGS
1522
1523=pod
1524
1525=back
1526
1527Several other systems don't use a specific console. We C<undef $console>
1528for those (Windows using a slave editor/graphical debugger, NetWare, OS/2
1529with a slave editor, Epoc).
1530
1531=cut
d12a4851
JH
1532
1533 if (($^O eq 'MSWin32') and ($slave_editor or defined $ENV{EMACS})) {
69893cff 1534 # /dev/tty is binary. use stdin for textmode
d12a4851
JH
1535 $console = undef;
1536 }
1537
69893cff
RGS
1538 if ($^O eq 'NetWare') {
1539 # /dev/tty is binary. use stdin for textmode
1540 $console = undef;
1541 }
d12a4851 1542
69893cff
RGS
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
d12a4851
JH
1547 $console = undef;
1548 }
69893cff 1549 # EPOC also falls into the 'got to use STDIN' camp.
d12a4851
JH
1550 if ($^O eq 'epoc') {
1551 $console = undef;
1552 }
1553
69893cff
RGS
1554=pod
1555
1556If there is a TTY hanging around from a parent, we use that as the console.
1557
1558=cut
1559
d12a4851
JH
1560 $console = $tty if defined $tty;
1561
69893cff
RGS
1562=head2 SOCKET HANDLING
1563
1564The debugger is capable of opening a socket and carrying out a debugging
1565session over the socket.
1566
1567If C<RemotePort> was defined in the options, the debugger assumes that it
1568should try to start a debugging session on that port. It builds the socket
1569and then tries to connect the input and output filehandles to it.
1570
1571=cut
1572
1573 # Handle socket stuff.
1574
d12a4851 1575 if (defined $remoteport) {
69893cff
RGS
1576 # If RemotePort was defined in the options, connect input and output
1577 # to the socket.
d12a4851 1578 require IO::Socket;
69893cff
RGS
1579 $OUT = new IO::Socket::INET(
1580 Timeout => '10',
1581 PeerAddr => $remoteport,
1582 Proto => 'tcp',
1583 );
d12a4851
JH
1584 if (!$OUT) { die "Unable to connect to remote host: $remoteport\n"; }
1585 $IN = $OUT;
69893cff
RGS
1586 } ## end if (defined $remoteport)
1587
1588=pod
1589
1590If no C<RemotePort> was defined, and we want to create a TTY on startup,
1591this is probably a situation where multiple debuggers are running (for example,
1592a backticked command that starts up another debugger). We create a new IN and
1593OUT filehandle, and do the necessary mojo to create a new TTY if we know how
1594and 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.
d12a4851
JH
1604 create_IN_OUT(4) if $CreateTTY & 4;
1605 if ($console) {
69893cff
RGS
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
d12a4851
JH
1611 my ($i, $o) = split /,/, $console;
1612 $o = $i unless defined $o;
69893cff
RGS
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
d12a4851 1632 $console = 'STDIN/OUT';
69893cff
RGS
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.
d12a4851 1637 $IN = \*IN, $OUT = \*OUT if $console or not defined $console;
69893cff
RGS
1638 } ## end elsif (from if(defined $remoteport))
1639
1640 # Unbuffer DB::OUT. We need to see responses right away.
d12a4851 1641 my $previous = select($OUT);
69893cff 1642 $| = 1; # for DB::OUT
d12a4851
JH
1643 select($previous);
1644
69893cff
RGS
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.
d12a4851
JH
1649 $LINEINFO = $OUT unless defined $LINEINFO;
1650 $lineinfo = $console unless defined $lineinfo;
69893cff
RGS
1651=pod
1652
1653To finish initialization, we show the debugger greeting,
1654and then call the C<afterinit()> subroutine if there is one.
1655
1656=cut
d12a4851 1657
69893cff 1658 # Show the debugger greeting.
d12a4851
JH
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";
d12a4851 1665 }
69893cff
RGS
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?
d338d6fe
PP
1680@ARGS = @ARGV;
1681for (@args) {
69893cff
RGS
1682 # Make sure backslashes before single quotes are stripped out, and
1683 # keep args unless they are numeric (XXX why?)
d338d6fe
PP
1684 s/\'/\\\'/g;
1685 s/(.*)/'$1'/ unless /^-?[\d.]+$/;
1686}
1687
69893cff
RGS
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.
1690if (defined &afterinit) { # May be defined in $rcfile
1691 &afterinit();
d338d6fe 1692}
69893cff 1693# Inform us about "Stack dump during die enabled ..." in dieLevel().
43aed9ee
IZ
1694$I_m_init = 1;
1695
d338d6fe
PP
1696############################################################ Subroutines
1697
69893cff
RGS
1698=head1 SUBROUTINES
1699
1700=head2 DB
1701
1702This gigantic subroutine is the heart of the debugger. Called before every
1703statement, its job is to determine if a breakpoint has been reached, and
1704stop if so; read commands from the user, parse them, and execute
1705them, and hen send execution off to the next statement.
1706
1707Note that the order in which the commands are processed is very important;
1708some commands earlier in the loop will actually alter the C<$cmd> variable
1709to create other commands to be executed later. This is all highly "optimized"
1710but can be confusing. Check the comments for each C<$cmd ... && do {}> to
1711see what's happening in any given command.
1712
1713=cut
1714
d338d6fe 1715sub DB {
69893cff
RGS
1716
1717 # Check for whether we should be running continuously or not.
36477c24
PP
1718 # _After_ the perl program is compiled, $single is set to 1:
1719 if ($single and not $second_time++) {
69893cff
RGS
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;
d12a4851 1726 }
69893cff
RGS
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.
d338d6fe 1749 &save;
69893cff
RGS
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.
d12a4851 1755 local($package, $filename, $line) = caller;
471505cc 1756 local $filename_ini = $filename;
69893cff
RGS
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.
d12a4851 1767 local(*dbline) = $main::{'_<' . $filename};
aa057b67
CN
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) {
69893cff
RGS
1772 $filename_ini = $filename = 'Dev:Pseudo';
1773 *dbline = $main::{'_<' . $filename};
aa057b67
CN
1774 }
1775
69893cff 1776 # Last line in the program.
471505cc 1777 local $max = $#dbline;
69893cff
RGS
1778
1779 # if we have something here, see if we should break.
d12a4851 1780 if ($dbline{$line} && (($stop,$action) = split(/\0/,$dbline{$line}))) {
69893cff
RGS
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.
36477c24 1796 my $was_signal = $signal;
69893cff
RGS
1797
1798 # If we have any watch expressions ...
6027b9a3 1799 if ($trace & 2) {
d12a4851 1800 for (my $n = 0; $n <= $#to_watch; $n++) {
69893cff
RGS
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;
405ff068 1815Watchpoint $n:\t$to_watch[$n] changed:
69893cff
RGS
1816 old value:\t$old_watch[$n]
1817 new value:\t$val
6027b9a3 1818EOP
69893cff
RGS
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
1826C<watchfunction()> is a function that can be defined by the user; it is a
1827function which will be run on each entry to C<DB::DB>; it gets the
1828current package, filename, and line as its parameters.
1829
1830The watchfunction can do anything it likes; it is executing in the
1831debugger's context, so it has access to all of the debugger's internal
1832data structures and functions.
1833
1834C<watchfunction()> can control the debugger's actions. Any of the following
1835will cause the debugger to return control to the user's program after
1836C<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
1847check 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.
6027b9a3 1868 $was_signal = $signal;
69893cff
RGS
1869 $signal = 0;
1870
1871=head2 GETTING READY TO EXECUTE COMMANDS
1872
1873The debugger decides to take control if single-step mode is on, the
1874C<t> command was entered, or the user generated a signal. If the program
1875has fallen off the end, we set things up so that entering further commands
1876won'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).
6027b9a3 1882 if ($single || ($trace & 1) || $was_signal) {
69893cff
RGS
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
1892Special check: if we're in package C<DB::fake>, we've gone through the
1893C<END> block at least once. We set up everything so that we can continue
1894to 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);
405ff068
IZ
1903Debugged 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.
1906EOP
69893cff
RGS
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')
e219e2fb 1913
69893cff 1914=pod
e219e2fb 1915
69893cff
RGS
1916If the program hasn't finished executing, we scan forward to the
1917next executable line, print that out, build the prompt from the file and line
1918number information, and print that.
e219e2fb 1919
69893cff
RGS
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
1985If there's an action to be executed for the line we stopped at, execute it.
1986If there are any preprompt actions, execute those as well.
e219e2fb
RF
1987
1988=cut
1989
69893cff
RGS
1990 # If there's an action, do it now.
1991 $evalarg = $action, &eval if $action;
e219e2fb 1992
69893cff
RGS
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
2018XXX Relocate this section?
2019
2020The debugger normally shows the line corresponding to the current line of
2021execution. Sometimes, though, we want to see the next line, or to move elsewhere
2022in the file. This is done via the C<$incr>, C<$start>, and C<$max> variables.
2023
2024C<$incr> controls by how many lines the "current" line should move forward
2025after a command is executed. If set to -1, this indicates that the "current"
2026line shouldn't change.
2027
2028C<$start> is the "current" line. It is used for things like knowing where to
2029move forwards or backwards from when doing an C<L> or C<-> command.
2030
2031C<$max> tells the debugger where the last line of the current file is. It's
2032used to terminate loops most often.
2033
2034=head2 THE COMMAND LOOP
2035
2036Most of C<DB::DB> is actually a command parsing and dispatch loop. It comes
2037in two parts:
2038
2039=over 4
2040
2041=item * The outer part of the loop, starting at the C<CMD> label. This loop
2042reads a command and then executes it.
2043
2044=item * The inner part of the loop, starting at the C<PIPE> label. This part
2045is wholly contained inside the C<CMD> block and only executes a command.
2046Used to handle commands running inside a pager.
2047
2048=back
2049
2050So why have two labels to restart the loop? Because sometimes, it's easier to
2051have a command I<generate> another command and then re-execute the loop to do
2052the 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
2092A newline entered by itself means "re-execute the last command". We grab the
2093command out of C<$laststep> (where it was recorded previously), and copy it
2094back into C<$cmd> to be executed below. If there wasn't any previous command,
2095we'll do nothing below (no command will match). If there was, we also save it
2096in the command history and fall through to allow the command parsing to pick
2097it 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
2117The debugger can create aliases for commands (these are stored in the
2118C<%alias> hash). Before a command is executed, the command loop looks it up
2119in the alias hash and substitutes the contents of the alias for the command,
2120completely 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
2145All of these commands work up to and after the program being debugged has
2146terminated.
2147
2148=head4 C<q> - quit
2149
2150Quit the debugger. This entails setting the C<$fall_off_end> flag, so we don't
2151try to execute further, cleaning any restart-related stuff out of the
2152environment, 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
2164Turn 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
2178Walks 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
2206Since the C<V> command actually processes this, just change this to the
2207appropriate 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
2215Uses 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
2273Hands the expression off to C<DB::eval>, setting it up to print the value
2274via 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
2290Just 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
2355We set C<$incr> to -1 to indicate that the debugger shouldn't move ahead,
2356and 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
2377We change C<$start> to be one window back; if we go back past the first line,
2378we set it to be the first line. We ser C<$incr> to put us back at the
2379currently-executing line, and then put a C<l $start +> (list one window from
2380C<$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
2397In Perl 5.8.0, a realignment of the commands was done to fix up a number of
2398problems, most notably that the default case of several commands destroying
2399the user's work in setting watchpoints, actions, etc. We wanted, however, to
2400retain the old commands for those who were used to using them or who preferred
2401them. At this point, we check for the new commands and call C<cmd_wrapper> to
2402deal 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
2415Uses C<PadWalker> to find the lexicals supplied as arguments in a scope
2416above 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
2462All of the commands below this point don't work after the program being
2463debugged has ended. All of them check to see if the program has ended; this
2464allows the commands to be relocated without worrying about a 'line of
2465demarcation' above which commands can be entered anytime, and below which
2466they can't.
2467
2468=head4 C<n> - single step, but don't trace down into subs
2469
2470Done by setting C<$single> to 2, which forces subs to execute straight through
2471when entered (see X<DB::sub>). We also save the C<n> command in C<$laststep>,
2472so 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
2488Sets C<$single> to 1, which causes X<DB::sub> to continue tracing inside
2489subs. 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
2507Most of the code for this command is taken up with locating the optional
2508breakpoint, which is either a subroutine name or a line number. We set
2509the appropriate one-time-break in C<@dbline> and then turn off single-stepping
2510in 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
2610For C<r> to work properly, the debugger has to stop execution again
2611immediately after the return is executed. This is done by forcing
2612single-stepping to be on in the call level above the current one. If
2613we are printing return values when a C<r> is executed, set C<$doret>
2614appropriately, 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
2631Restarting the debugger is a complex operation that occurs in several phases.
2632First, we try to reconstruct the command line that was used to invoke Perl
2633and 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
2684After the command line has been reconstructed, the next step is to save
2685the debugger's status in environment variables. The C<DB::set_list> routine
2686is used to save aggregate variables (both hashes and arrays); scalars are
2687just 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
2711The most complex part of this is the saving of all of the breakpoints. They
2712can live in an awful lot of places, and we have to go through all of them,
2713find the breakpoints, and then save them in the appropriate environment
2714variable 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
2803After all the debugger status has been saved, we take the command we built
2804up and then C<exec()> it. The debugger will spot the C<PERLDB_RESTART>
2805environment variable and realize it needs to reload its state from the
2806environment.
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
2822Just 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
2833Just 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
2841Just 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
2849We take the argument and treat it as a pattern. If it turns out to be a
2850bad one, we return the error we got from trying to C<eval> it and exit.
2851If not, we create some code to do the search and C<eval> it so it can't
2852mess 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
2926Same 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
2992Manages the commands in C<@hist> (which is created if C<Term::ReadLine> reports
2993that the terminal supports history). It find the the command required, puts it
2994into 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
3021Calls the C<DB::system()> to handle the command. This keeps the C<STDIN> and
3022C<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
3036Another command to manipulate C<@hist>: this one searches it with a pattern.
3037If 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
3069Uses 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
3083Like the above, but the command is passed to the shell. Again, we use
3084C<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
3100Prints 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
3126Just 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
3138Builds a C<print EXPR> expression in the C<$cmd>; this will get executed at
3139the 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
3151Manipulates 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
3219Opens a lexical filehandle and stacks it on C<@cmdfhs>; C<DB::readline> will
3220pick 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
3239Takes the complete history, (not the shrunken version you see with C<H>),
3240and saves it to the given filename, so it can be replayed using C<source>.
3241
3242Note 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
3262FOR 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
3264pipe to the pager (restoring the output filehandles if this fails). If this
3265is the C<|> command, we also set up a C<SIGPIPE> handler which will simply
3266set C<$signal>, sending us back into the debugger.
3267
3268We then trim off the pipe symbols and C<redo> the command loop at the
3269C<PIPE> label, causing us to evaluate the command in C<$cmd> without
3270reading 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
3329Anything left in C<$cmd> at this point is a Perl expression that we want to
3330evaluate. We'll always evaluate in the user's context, and fully qualify
3331any 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
3368After each command, we check to see if the command output was piped anywhere.
3369If so, we go through the necessary code to unhook the pipe and go back to
3370our 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
3432When commands have finished executing, we come here. If the user closed the
3433input filehandle, we turn on C<$fall_off_end> to emulate a C<q> command. We
3434evaluate any post-prompt items. We restore C<$@>, C<$!>, C<$^E>, C<$,>, C<$/>,
3435C<$\>, and C<$^W>, and return a null list as expected by the Perl interpreter.
3436The interpreter will then execute the next line and then return control to us
3437again.
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
3460C<sub> is called whenever a subroutine call happens in the program being
3461debugged. The variable C<$DB::sub> contains the name of the subroutine
3462being called.
3463
3464The core function of this subroutine is to actually call the sub in the proper
3465context, capturing its output. This of course causes C<DB::DB> to get called
3466again, repeating until the subroutine ends and returns control to C<DB::sub>
3467again. Once control returns, C<DB::sub> figures out whether or not to dump the
3468return value, and returns its captured copy of the return value as its own
3469return value. The value then feeds back into the program being debugged as if
3470C<DB::sub> hadn't been there at all.
3471
3472C<sub> does all the work of printing the subroutine entry and exit messages
3473enabled by setting C<$frame>. It notes what sub the autoloader got called for,
3474and also prints the return value if needed (for the C<r> command and if
3475the 16 bit is set in C<$frame>).
3476
3477It also tracks the subroutine call depth by saving the current setting of
3478C<$single> in the C<@stack> package global; if this exceeds the value in
3479C<$deep>, C<sub> automatically turns on printing of the current depth by
3480setting the 4 bit in C<$single>. In any case, it keeps the current setting
3481of stop/don't stop on entry to subs set as it currently is set.
3482
3483=head3 C<caller()> support
3484
3485If C<caller()> is called from the package C<DB>, it provides some
3486additional data, in the following order:
3487
3488=over 4
3489
3490=item * C<$package>
3491
3492The package name the sub was in
3493
3494=item * C<$filename>
3495
3496The filename it was defined in
3497
3498=item * C<$line>
3499
3500The line number it was defined on
3501
3502=item * C<$subroutine>
3503
3504The subroutine name; C<'(eval)'> if an C<eval>().
3505
3506=item * C<$hasargs>
3507
35081 if it has arguments, 0 if not
3509
3510=item * C<$wantarray>
3511
35121 if array context, 0 if scalar context
3513
3514=item * C<$evaltext>
3515
3516The C<eval>() text, if any (undefined for C<eval BLOCK>)
3517
3518=item * C<$is_require>
3519
3520frame was created by a C<use> or C<require> statement
3521
3522=item * C<$hints>
3523
3524pragma information; subject to change between versions
3525
3526=item * C<$bitmask>
3527
3528pragma information: subject to change between versions
3529
3530=item * C<@DB::args>
3531
3532arguments with which the subroutine was invoked
3533
3534=back
3535
3536=cut
d338d6fe 3537
d338d6fe 3538
d12a4851 3539sub sub {
69893cff
RGS
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).
d12a4851 3544 my ($al, $ret, @ret) = "";
69893cff
RGS
3545
3546 # If the last ten characters are C'::AUTOLOAD', note we've traced
3547 # into AUTOLOAD for $sub.
d12a4851 3548 if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') {
69893cff 3549 $al = " for $$sub";
d12a4851 3550 }
69893cff
RGS
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.
d12a4851 3556 local $stack_depth = $stack_depth + 1; # Protect from non-local exits
69893cff
RGS
3557
3558 # Expand @stack.
d12a4851 3559 $#stack = $stack_depth;
69893cff
RGS
3560
3561 # Save current single-step setting.
d12a4851 3562 $stack[-1] = $single;
69893cff
RGS
3563
3564 # Turn off all flags except single-stepping.
d12a4851 3565 $single &= 1;
69893cff
RGS
3566
3567 # If we've gotten really deeply recursed, turn on the flag that will
3568 # make us stop with the 'deep recursion' message.
d12a4851 3569 $single |= 4 if $stack_depth == $deep;
69893cff
RGS
3570
3571 # If frame messages are on ...
3572 (
3573 $frame & 4 # Extended frame entry message
d12a4851 3574 ? ( print_lineinfo(' ' x ($stack_depth - 1), "in "),
69893cff
RGS
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.
d12a4851 3588 if (wantarray) {
69893cff
RGS
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.
d12a4851
JH
3592 if ($assertion) {
3593 $assertion=0;
69893cff
RGS
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 $\ = '';
d12a4851 3624 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
69893cff
RGS
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 {
d12a4851 3642 if ($assertion) {
69893cff
RGS
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;
d12a4851 3653 }
69893cff
RGS
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
3701In Perl 5.8.0, there was a major realignment of the commands and what they did,
3702Most of the changes were to systematize the command structure and to eliminate
3703commands that threw away user input without checking.
3704
3705The following sections describe the code added to make it easy to support
3706multiple command sets with conflicting command names. This section is a start
3707at unifying all command processing to make it simpler to develop commands.
3708
3709Note that all the cmd_[a-zA-Z] subroutines require the command name, a line
3710number, and C<$dbline> (the current line) as arguments.
3711
3712Support functions in this section which have multiple modes of failure C<die>
3713on error; the rest simply return a false value.
3714
3715The user-interface functions (all of the C<cmd_*> functions) just output
3716error messages.
3717
3718=head2 C<%set>
3719
3720The C<%set> hash defines the mapping from command letter to subroutine
3721name suffix.
3722
3723C<%set> is a two-level hash, indexed by set name and then by command name.
3724Note that trying to set the CommandSet to 'foobar' simply results in the
37255.8.0 command set being used, since there's no top-level entry for 'foobar'.
3726
3727=cut
d338d6fe 3728
d12a4851 3729### The API section
f1583d8f 3730
d12a4851
JH
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
3737my %set = ( #
69893cff
RGS
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 },
d12a4851 3761);
492652be 3762
69893cff
RGS
3763=head2 C<cmd_wrapper()> (API)
3764
3765C<cmd_wrapper()> allows the debugger to switch command sets
3766depending on the value of the C<CommandSet> option.
3767
3768It 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
3770the sub to call based on the value found in the hash (if it's there). I<All>
3771of the commands to be handled in a set have to be added to C<%set>; if they
3772aren't found, the 5.8.0 equivalent is called (if there is one).
3773
3774This code uses symbolic references.
3775
3776=cut
3777
d12a4851 3778sub cmd_wrapper {
69893cff
RGS
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);
d12a4851 3793}
492652be 3794
69893cff
RGS
3795=head3 C<cmd_a> (command)
3796
3797The C<a> command handles pre-execution actions. These are associated with a
3798particular line, so they're stored in C<%dbline>. We default to the current
3799line if none is specified.
3800
3801=cut
3802
d12a4851 3803sub cmd_a {
69893cff
RGS
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
3844Delete actions. Similar to above, except the delete code is in a separate
3845subroutine, C<delete_action>.
3846
3847=cut
492652be 3848
d12a4851 3849sub cmd_A {
69893cff
RGS
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
3881C<delete_action> accepts either a line number or C<undef>. If a line number
3882is specified, we check for the line being executable (if it's not, it
3883couldn't have had an action). If it is, we just take the action off (this
3884will get any kind of an action, including breakpoints).
3885
3886=cut
492652be 3887
d12a4851
JH
3888sub delete_action {
3889 my $i = shift;
3890 if (defined($i)) {
69893cff
RGS
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
3919Set breakpoints. Since breakpoints can be set in so many places, in so many
3920ways, conditionally or not, the breakpoint code is kind of complex. Mostly,
3921we try to parse the command type, and then shuttle it off to an appropriate
3922subroutine to actually do the work of setting the breakpoint in the right
3923place.
3924
3925=cut
492652be 3926
d12a4851 3927sub cmd_b {
69893cff
RGS
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
3999We want to break when this file is loaded. Mark this file in the
4000C<%break_on_load> hash, and note that it has a breakpoint in
4001C<%had_breakpoints>.
4002
4003=cut
4004
4005
492652be 4006
d12a4851
JH
4007sub break_on_load {
4008 my $file = shift;
4009 $break_on_load{$file} = 1;
4010 $had_breakpoints{$file} |= 1;
4011}
f1583d8f 4012
69893cff
RGS
4013=head3 C<report_break_on_load> (API)
4014
4015Gives us an array of filenames that are set to break on load. Note that
4016only files with break-on-load are in here, so simply showing the keys
4017suffices.
4018
4019=cut
4020
d12a4851
JH
4021sub report_break_on_load {
4022 sort keys %break_on_load;
4023}
f1583d8f 4024
69893cff
RGS
4025=head3 C<cmd_b_load> (command)
4026
4027We take the file passed in and try to find it in C<%INC> (which maps modules
4028to files they came from). We mark those files for break-on-load via
4029C<break_on_load> and then report that it was done.
4030
4031=cut
4032
d12a4851
JH
4033sub cmd_b_load {
4034 my $file = shift;
4035 my @files;
69893cff
RGS
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.
d12a4851 4039 {
69893cff 4040 # Save short name and full path if found.
d12a4851
JH
4041 push @files, $file;
4042 push @files, $::INC{$file} if $::INC{$file};
69893cff
RGS
4043
4044 # Tack on .pm and do it again unless there was a '.' in the name
4045 # already.
d12a4851
JH
4046 $file .= '.pm', redo unless $file =~ /\./;
4047 }
69893cff
RGS
4048
4049 # Do the real work here.
d12a4851 4050 break_on_load($_) for @files;
69893cff
RGS
4051
4052 # All the files that have break-on-load breakpoints.
d12a4851 4053 @files = report_break_on_load;
69893cff
RGS
4054
4055 # Normalize for the purposes of our printing this.
d12a4851
JH
4056 local $\ = '';
4057 local $" = ' ';
4058 print $OUT "Will stop on load of `@files'.\n";
4059}
f1583d8f 4060
69893cff
RGS
4061=head3 C<$filename_error> (API package global)
4062
4063Several of the functions we need to implement in the API need to work both
4064on the current file and on other files. We don't want to duplicate code, so
4065C<$filename_error> is used to contain the name of the file that's being
4066worked on (if it's not the current one).
4067
4068We can now build functions in pairs: the basic function works on the current
4069file, and uses C<$filename_error> as part of its error message. Since this is
4070initialized to C<''>, no filename will appear when we are working on the
4071current file.
4072
4073The 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
4083The first function works on the "current" (i.e., the one we changed to) file,
4084and prints C<$filename_error> in the error message (the name of the other file)
4085if 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
4086restored to C<''>. This restores everything to the way it was before the
4087second function was called at all.
4088
4089See the comments in C<breakable_line> and C<breakable_line_in_file> for more
4090details.
4091
4092=back
4093
4094=cut
4095
d12a4851 4096$filename_error = '';
f1583d8f 4097
69893cff
RGS
4098=head3 breakable_line($from, $to) (API)
4099
4100The subroutine decides whether or not a line in the current file is breakable.
4101It walks through C<@dbline> within the range of lines specified, looking for
4102the first line that is breakable.
4103
4104If C<$to> is greater than C<$from>, the search moves forwards, finding the
4105first line I<after> C<$to> that's breakable, if there is one.
4106
4107If C<$from> is greater than C<$to>, the search goes I<backwards>, finding the
4108first line I<before> C<$to> that's breakable, if there is one.
4109
4110=cut
4111
d12a4851 4112sub breakable_line {
69893cff 4113
d12a4851 4114 my ($from, $to) = @_;
69893cff
RGS
4115
4116 # $i is the start point. (Where are the FORTRAN programs of yesteryear?)
d12a4851 4117 my $i = $from;
69893cff
RGS
4118
4119 # If there are at least 2 arguments, we're trying to search a range.
d12a4851 4120 if (@_ >= 2) {
69893cff
RGS
4121
4122 # $delta is positive for a forward search, negative for a backward one.
d12a4851 4123 my $delta = $from < $to ? +1 : -1;
69893cff
RGS
4124
4125 # Keep us from running off the ends of the file.
d12a4851 4126 my $limit = $delta > 0 ? $#dbline : 1;
69893cff
RGS
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
d12a4851 4156 $limit = $to if ($limit - $to) * $delta > 0;
69893cff
RGS
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).
d12a4851 4165 $i += $delta while $dbline[$i] == 0 and ($limit - $i) * $delta > 0;
69893cff
RGS
4166 } ## end if (@_ >= 2)
4167
4168 # If $i points to a line that is executable, return that.
d12a4851 4169 return $i unless $dbline[$i] == 0;
69893cff
RGS
4170
4171 # Format the message and print it: no breakable lines in range.
4172 my ($pl, $upto) = ('', '');
d12a4851
JH
4173 my ($pl, $upto) = ('', '');
4174 ($pl, $upto) = ('s', "..$to") if @_ >=2 and $from != $to;
69893cff
RGS
4175
4176 # If there's a filename in filename_error, we'll see it.
4177 # If not, not.
d12a4851 4178 die "Line$pl $from$upto$filename_error not breakable\n";
69893cff
RGS
4179} ## end sub breakable_line
4180
4181=head3 breakable_line_in_filename($file, $from, $to) (API)
4182
4183Like C<breakable_line>, but look in another file.
4184
4185=cut
f1583d8f 4186
d12a4851 4187sub breakable_line_in_filename {
69893cff 4188 # Capture the file name.
d12a4851 4189 my ($f) = shift;
69893cff
RGS
4190
4191 # Swap the magic line array over there temporarily.
d12a4851 4192 local *dbline = $main::{'_<' . $f};
69893cff
RGS
4193
4194 # If there's an error, it's in this other file.
d12a4851 4195 local $filename_error = " of `$f'";
69893cff
RGS
4196
4197 # Find the breakable line.
d12a4851 4198 breakable_line(@_);
69893cff
RGS
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
4206Adds a breakpoint with the specified condition (or 1 if no condition was
4207specified) to the specified line. Dies if it can't.
4208
4209=cut
f1583d8f 4210
d12a4851
JH
4211sub break_on_line {
4212 my ($i, $cond) = @_;
69893cff
RGS
4213
4214 # Always true if no condition supplied.
d12a4851