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