This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
bump perl5db.pl's $VERSION
[perl5.git] / lib / perl5db.pl
CommitLineData
e22ea7cc 1
b570d64b 2=head1 NAME
69893cff 3
be9a9b1d 4perl5db.pl - the perl debugger
69893cff
RGS
5
6=head1 SYNOPSIS
7
8 perl -d your_Perl_script
9
10=head1 DESCRIPTION
11
12C<perl5db.pl> is the perl debugger. It is loaded automatically by Perl when
13you invoke a script with C<perl -d>. This documentation tries to outline the
14structure and services provided by C<perl5db.pl>, and to describe how you
15can use them.
16
65ac759c
DB
17See L<perldebug> for an overview of how to use the debugger.
18
69893cff
RGS
19=head1 GENERAL NOTES
20
21The debugger can look pretty forbidding to many Perl programmers. There are
22a number of reasons for this, many stemming out of the debugger's history.
23
24When the debugger was first written, Perl didn't have a lot of its nicer
25features - no references, no lexical variables, no closures, no object-oriented
26programming. So a lot of the things one would normally have done using such
b570d64b 27features was done using global variables, globs and the C<local()> operator
69893cff
RGS
28in creative ways.
29
30Some of these have survived into the current debugger; a few of the more
31interesting and still-useful idioms are noted in this section, along with notes
32on the comments themselves.
33
34=head2 Why not use more lexicals?
35
36Experienced Perl programmers will note that the debugger code tends to use
37mostly package globals rather than lexically-scoped variables. This is done
38to allow a significant amount of control of the debugger from outside the
b570d64b 39debugger itself.
69893cff
RGS
40
41Unfortunately, though the variables are accessible, they're not well
42documented, so it's generally been a decision that hasn't made a lot of
43difference to most users. Where appropriate, comments have been added to
44make variables more accessible and usable, with the understanding that these
be9a9b1d 45I<are> debugger internals, and are therefore subject to change. Future
69893cff
RGS
46development should probably attempt to replace the globals with a well-defined
47API, but for now, the variables are what we've got.
48
49=head2 Automated variable stacking via C<local()>
50
b570d64b 51As you may recall from reading C<perlfunc>, the C<local()> operator makes a
69893cff 52temporary copy of a variable in the current scope. When the scope ends, the
b570d64b 53old copy is restored. This is often used in the debugger to handle the
69893cff
RGS
54automatic stacking of variables during recursive calls:
55
56 sub foo {
57 local $some_global++;
58
59 # Do some stuff, then ...
60 return;
61 }
62
63What happens is that on entry to the subroutine, C<$some_global> is localized,
b570d64b 64then altered. When the subroutine returns, Perl automatically undoes the
69893cff
RGS
65localization, restoring the previous value. Voila, automatic stack management.
66
b570d64b 67The debugger uses this trick a I<lot>. Of particular note is C<DB::eval>,
69893cff
RGS
68which lets the debugger get control inside of C<eval>'ed code. The debugger
69localizes a saved copy of C<$@> inside the subroutine, which allows it to
70keep C<$@> safe until it C<DB::eval> returns, at which point the previous
b570d64b 71value of C<$@> is restored. This makes it simple (well, I<simpler>) to keep
69893cff
RGS
72track of C<$@> inside C<eval>s which C<eval> other C<eval's>.
73
74In any case, watch for this pattern. It occurs fairly often.
75
76=head2 The C<^> trick
77
b570d64b 78This is used to cleverly reverse the sense of a logical test depending on
69893cff 79the value of an auxiliary variable. For instance, the debugger's C<S>
b570d64b 80(search for subroutines by pattern) allows you to negate the pattern
69893cff
RGS
81like this:
82
83 # Find all non-'foo' subs:
b570d64b 84 S !/foo/
69893cff
RGS
85
86Boolean algebra states that the truth table for XOR looks like this:
87
88=over 4
89
b570d64b 90=item * 0 ^ 0 = 0
69893cff
RGS
91
92(! not present and no match) --> false, don't print
93
b570d64b 94=item * 0 ^ 1 = 1
69893cff
RGS
95
96(! not present and matches) --> true, print
97
b570d64b 98=item * 1 ^ 0 = 1
69893cff
RGS
99
100(! present and no match) --> true, print
101
b570d64b 102=item * 1 ^ 1 = 0
69893cff
RGS
103
104(! present and matches) --> false, don't print
105
106=back
107
108As you can see, the first pair applies when C<!> isn't supplied, and
be9a9b1d 109the second pair applies when it is. The XOR simply allows us to
b570d64b 110compact a more complicated if-then-elseif-else into a more elegant
69893cff
RGS
111(but perhaps overly clever) single test. After all, it needed this
112explanation...
113
114=head2 FLAGS, FLAGS, FLAGS
115
116There is a certain C programming legacy in the debugger. Some variables,
be9a9b1d 117such as C<$single>, C<$trace>, and C<$frame>, have I<magical> values composed
69893cff 118of 1, 2, 4, etc. (powers of 2) OR'ed together. This allows several pieces
b570d64b 119of state to be stored independently in a single scalar.
69893cff
RGS
120
121A test like
122
123 if ($scalar & 4) ...
124
b570d64b 125is checking to see if the appropriate bit is on. Since each bit can be
69893cff 126"addressed" independently in this way, C<$scalar> is acting sort of like
b570d64b 127an array of bits. Obviously, since the contents of C<$scalar> are just a
69893cff
RGS
128bit-pattern, we can save and restore it easily (it will just look like
129a number).
130
131The problem, is of course, that this tends to leave magic numbers scattered
b570d64b 132all over your program whenever a bit is set, cleared, or checked. So why do
69893cff
RGS
133it?
134
135=over 4
136
be9a9b1d 137=item *
69893cff 138
be9a9b1d 139First, doing an arithmetical or bitwise operation on a scalar is
69893cff 140just about the fastest thing you can do in Perl: C<use constant> actually
be9a9b1d 141creates a subroutine call, and array and hash lookups are much slower. Is
b570d64b 142this over-optimization at the expense of readability? Possibly, but the
69893cff
RGS
143debugger accesses these variables a I<lot>. Any rewrite of the code will
144probably have to benchmark alternate implementations and see which is the
b570d64b 145best balance of readability and speed, and then document how it actually
69893cff
RGS
146works.
147
be9a9b1d
AT
148=item *
149
b570d64b 150Second, it's very easy to serialize a scalar number. This is done in
69893cff
RGS
151the restart code; the debugger state variables are saved in C<%ENV> and then
152restored when the debugger is restarted. Having them be just numbers makes
b570d64b 153this trivial.
69893cff 154
be9a9b1d
AT
155=item *
156
b570d64b
SF
157Third, some of these variables are being shared with the Perl core
158smack in the middle of the interpreter's execution loop. It's much faster for
159a C program (like the interpreter) to check a bit in a scalar than to access
69893cff
RGS
160several different variables (or a Perl array).
161
162=back
163
164=head2 What are those C<XXX> comments for?
165
166Any comment containing C<XXX> means that the comment is either somewhat
b570d64b 167speculative - it's not exactly clear what a given variable or chunk of
69893cff
RGS
168code is doing, or that it is incomplete - the basics may be clear, but the
169subtleties are not completely documented.
170
171Send in a patch if you can clear up, fill out, or clarify an C<XXX>.
172
b570d64b 173=head1 DATA STRUCTURES MAINTAINED BY CORE
69893cff
RGS
174
175There are a number of special data structures provided to the debugger by
176the Perl interpreter.
177
7e17a74c
JJ
178The array C<@{$main::{'_<'.$filename}}> (aliased locally to C<@dbline>
179via glob assignment) contains the text from C<$filename>, with each
180element corresponding to a single line of C<$filename>. Additionally,
181breakable lines will be dualvars with the numeric component being the
182memory address of a COP node. Non-breakable lines are dualvar to 0.
69893cff 183
b570d64b
SF
184The hash C<%{'_<'.$filename}> (aliased locally to C<%dbline> via glob
185assignment) contains breakpoints and actions. The keys are line numbers;
186you can set individual values, but not the whole hash. The Perl interpreter
69893cff 187uses this hash to determine where breakpoints have been set. Any true value is
be9a9b1d 188considered to be a breakpoint; C<perl5db.pl> uses C<$break_condition\0$action>.
69893cff
RGS
189Values are magical in numeric context: 1 if the line is breakable, 0 if not.
190
da052516 191The scalar C<${"_<$filename"}> simply contains the string C<$filename>.
be9a9b1d
AT
192This is also the case for evaluated strings that contain subroutines, or
193which are currently being executed. The $filename for C<eval>ed strings looks
ee59ac17 194like C<(eval 34)>.
69893cff
RGS
195
196=head1 DEBUGGER STARTUP
197
198When C<perl5db.pl> starts, it reads an rcfile (C<perl5db.ini> for
199non-interactive sessions, C<.perldb> for interactive ones) that can set a number
200of options. In addition, this file may define a subroutine C<&afterinit>
b570d64b 201that will be executed (in the debugger's context) after the debugger has
69893cff
RGS
202initialized itself.
203
b570d64b 204Next, it checks the C<PERLDB_OPTS> environment variable and treats its
be9a9b1d 205contents as the argument of a C<o> command in the debugger.
69893cff
RGS
206
207=head2 STARTUP-ONLY OPTIONS
208
209The following options can only be specified at startup.
210To set them in your rcfile, add a call to
211C<&parse_options("optionName=new_value")>.
212
213=over 4
214
b570d64b 215=item * TTY
69893cff
RGS
216
217the TTY to use for debugging i/o.
218
b570d64b 219=item * noTTY
69893cff
RGS
220
221if set, goes in NonStop mode. On interrupt, if TTY is not set,
b0e77abc 222uses the value of noTTY or F<$HOME/.perldbtty$$> to find TTY using
69893cff
RGS
223Term::Rendezvous. Current variant is to have the name of TTY in this
224file.
225
b570d64b 226=item * ReadLine
69893cff 227
5561b870 228if false, a dummy ReadLine is used, so you can debug
69893cff
RGS
229ReadLine applications.
230
b570d64b 231=item * NonStop
69893cff
RGS
232
233if true, no i/o is performed until interrupt.
234
b570d64b 235=item * LineInfo
69893cff
RGS
236
237file or pipe to print line number info to. If it is a
238pipe, a short "emacs like" message is used.
239
b570d64b 240=item * RemotePort
69893cff
RGS
241
242host:port to connect to on remote host for remote debugging.
243
5561b870
AK
244=item * HistFile
245
246file to store session history to. There is no default and so no
247history file is written unless this variable is explicitly set.
248
249=item * HistSize
250
251number of commands to store to the file specified in C<HistFile>.
252Default is 100.
253
69893cff
RGS
254=back
255
256=head3 SAMPLE RCFILE
257
258 &parse_options("NonStop=1 LineInfo=db.out");
259 sub afterinit { $trace = 1; }
260
261The script will run without human intervention, putting trace
262information into C<db.out>. (If you interrupt it, you had better
be9a9b1d 263reset C<LineInfo> to something I<interactive>!)
69893cff
RGS
264
265=head1 INTERNALS DESCRIPTION
266
267=head2 DEBUGGER INTERFACE VARIABLES
268
269Perl supplies the values for C<%sub>. It effectively inserts
be9a9b1d 270a C<&DB::DB();> in front of each place that can have a
69893cff
RGS
271breakpoint. At each subroutine call, it calls C<&DB::sub> with
272C<$DB::sub> set to the called subroutine. It also inserts a C<BEGIN
273{require 'perl5db.pl'}> before the first line.
274
275After each C<require>d file is compiled, but before it is executed, a
276call to C<&DB::postponed($main::{'_<'.$filename})> is done. C<$filename>
277is the expanded name of the C<require>d file (as found via C<%INC>).
278
279=head3 IMPORTANT INTERNAL VARIABLES
280
281=head4 C<$CreateTTY>
282
283Used to control when the debugger will attempt to acquire another TTY to be
b570d64b 284used for input.
69893cff 285
b570d64b 286=over
69893cff
RGS
287
288=item * 1 - on C<fork()>
289
290=item * 2 - debugger is started inside debugger
291
292=item * 4 - on startup
293
294=back
295
296=head4 C<$doret>
297
298The value -2 indicates that no return value should be printed.
299Any other positive value causes C<DB::sub> to print return values.
300
301=head4 C<$evalarg>
302
303The item to be eval'ed by C<DB::eval>. Used to prevent messing with the current
304contents of C<@_> when C<DB::eval> is called.
305
306=head4 C<$frame>
307
308Determines what messages (if any) will get printed when a subroutine (or eval)
b570d64b 309is entered or exited.
69893cff
RGS
310
311=over 4
312
313=item * 0 - No enter/exit messages
314
be9a9b1d 315=item * 1 - Print I<entering> messages on subroutine entry
69893cff
RGS
316
317=item * 2 - Adds exit messages on subroutine exit. If no other flag is on, acts like 1+2.
318
be9a9b1d 319=item * 4 - Extended messages: C<< <in|out> I<context>=I<fully-qualified sub name> from I<file>:I<line> >>. If no other flag is on, acts like 1+4.
69893cff
RGS
320
321=item * 8 - Adds parameter information to messages, and overloaded stringify and tied FETCH is enabled on the printed arguments. Ignored if C<4> is not on.
322
7e3426ea 323=item * 16 - Adds C<I<context> return from I<subname>: I<value>> messages on subroutine/eval exit. Ignored if C<4> is not on.
69893cff
RGS
324
325=back
326
be9a9b1d 327To get everything, use C<$frame=30> (or C<o f=30> as a debugger command).
69893cff
RGS
328The debugger internally juggles the value of C<$frame> during execution to
329protect external modules that the debugger uses from getting traced.
330
331=head4 C<$level>
332
b570d64b
SF
333Tracks current debugger nesting level. Used to figure out how many
334C<E<lt>E<gt>> pairs to surround the line number with when the debugger
69893cff
RGS
335outputs a prompt. Also used to help determine if the program has finished
336during command parsing.
337
338=head4 C<$onetimeDump>
339
340Controls what (if anything) C<DB::eval()> will print after evaluating an
341expression.
342
343=over 4
344
345=item * C<undef> - don't print anything
346
347=item * C<dump> - use C<dumpvar.pl> to display the value returned
348
349=item * C<methods> - print the methods callable on the first item returned
350
351=back
352
353=head4 C<$onetimeDumpDepth>
354
be9a9b1d 355Controls how far down C<dumpvar.pl> will go before printing C<...> while
69893cff
RGS
356dumping a structure. Numeric. If C<undef>, print all levels.
357
358=head4 C<$signal>
359
360Used to track whether or not an C<INT> signal has been detected. C<DB::DB()>,
361which is called before every statement, checks this and puts the user into
362command mode if it finds C<$signal> set to a true value.
363
364=head4 C<$single>
365
366Controls behavior during single-stepping. Stacked in C<@stack> on entry to
367each subroutine; popped again at the end of each subroutine.
368
b570d64b 369=over 4
69893cff
RGS
370
371=item * 0 - run continuously.
372
be9a9b1d 373=item * 1 - single-step, go into subs. The C<s> command.
69893cff 374
be9a9b1d 375=item * 2 - single-step, don't go into subs. The C<n> command.
69893cff 376
be9a9b1d
AT
377=item * 4 - print current sub depth (turned on to force this when C<too much
378recursion> occurs.
69893cff
RGS
379
380=back
381
382=head4 C<$trace>
383
b570d64b 384Controls the output of trace information.
69893cff
RGS
385
386=over 4
387
388=item * 1 - The C<t> command was entered to turn on tracing (every line executed is printed)
389
390=item * 2 - watch expressions are active
391
392=item * 4 - user defined a C<watchfunction()> in C<afterinit()>
393
394=back
395
396=head4 C<$slave_editor>
397
3981 if C<LINEINFO> was directed to a pipe; 0 otherwise.
399
400=head4 C<@cmdfhs>
401
402Stack of filehandles that C<DB::readline()> will read commands from.
403Manipulated by the debugger's C<source> command and C<DB::readline()> itself.
404
405=head4 C<@dbline>
406
b570d64b 407Local alias to the magical line array, C<@{$main::{'_<'.$filename}}> ,
69893cff
RGS
408supplied by the Perl interpreter to the debugger. Contains the source.
409
410=head4 C<@old_watch>
411
412Previous values of watch expressions. First set when the expression is
413entered; reset whenever the watch expression changes.
414
415=head4 C<@saved>
416
417Saves important globals (C<$@>, C<$!>, C<$^E>, C<$,>, C<$/>, C<$\>, C<$^W>)
418so that the debugger can substitute safe values while it's running, and
419restore them when it returns control.
420
421=head4 C<@stack>
422
423Saves the current value of C<$single> on entry to a subroutine.
424Manipulated by the C<c> command to turn off tracing in all subs above the
425current one.
426
427=head4 C<@to_watch>
428
429The 'watch' expressions: to be evaluated before each line is executed.
430
431=head4 C<@typeahead>
432
433The typeahead buffer, used by C<DB::readline>.
434
435=head4 C<%alias>
436
437Command aliases. Stored as character strings to be substituted for a command
438entered.
439
440=head4 C<%break_on_load>
441
442Keys are file names, values are 1 (break when this file is loaded) or undef
443(don't break when it is loaded).
444
445=head4 C<%dbline>
446
be9a9b1d 447Keys are line numbers, values are C<condition\0action>. If used in numeric
69893cff
RGS
448context, values are 0 if not breakable, 1 if breakable, no matter what is
449in the actual hash entry.
450
451=head4 C<%had_breakpoints>
452
453Keys are file names; values are bitfields:
454
b570d64b 455=over 4
69893cff
RGS
456
457=item * 1 - file has a breakpoint in it.
458
459=item * 2 - file has an action in it.
460
461=back
462
463A zero or undefined value means this file has neither.
464
465=head4 C<%option>
466
467Stores the debugger options. These are character string values.
468
469=head4 C<%postponed>
470
471Saves breakpoints for code that hasn't been compiled yet.
472Keys are subroutine names, values are:
473
474=over 4
475
be9a9b1d 476=item * C<compile> - break when this sub is compiled
69893cff 477
be9a9b1d 478=item * C<< break +0 if <condition> >> - break (conditionally) at the start of this routine. The condition will be '1' if no condition was specified.
69893cff
RGS
479
480=back
481
482=head4 C<%postponed_file>
483
484This hash keeps track of breakpoints that need to be set for files that have
485not yet been compiled. Keys are filenames; values are references to hashes.
486Each of these hashes is keyed by line number, and its values are breakpoint
be9a9b1d 487definitions (C<condition\0action>).
69893cff
RGS
488
489=head1 DEBUGGER INITIALIZATION
490
491The debugger's initialization actually jumps all over the place inside this
b570d64b
SF
492package. This is because there are several BEGIN blocks (which of course
493execute immediately) spread through the code. Why is that?
69893cff 494
b570d64b 495The debugger needs to be able to change some things and set some things up
69893cff
RGS
496before the debugger code is compiled; most notably, the C<$deep> variable that
497C<DB::sub> uses to tell when a program has recursed deeply. In addition, the
498debugger has to turn off warnings while the debugger code is compiled, but then
499restore them to their original setting before the program being debugged begins
500executing.
501
502The first C<BEGIN> block simply turns off warnings by saving the current
503setting of C<$^W> and then setting it to zero. The second one initializes
504the debugger variables that are needed before the debugger begins executing.
b570d64b 505The third one puts C<$^X> back to its former value.
69893cff
RGS
506
507We'll detail the second C<BEGIN> block later; just remember that if you need
508to initialize something before the debugger starts really executing, that's
509where it has to go.
510
511=cut
512
a687059c
LW
513package DB;
514
6b24a4b7
SF
515use strict;
516
c59f1e04
SF
517use Cwd ();
518
519my $_initial_cwd;
520
2dbd01ad 521BEGIN {eval 'use IO::Handle'}; # Needed for flush only? breaks under miniperl
9eba6a4e 522
e56c1e8d
SF
523BEGIN {
524 require feature;
525 $^V =~ /^v(\d+\.\d+)/;
526 feature->import(":$1");
c59f1e04 527 $_initial_cwd = Cwd::getcwd();
e56c1e8d
SF
528}
529
54d04a52 530# Debugger for Perl 5.00x; perl5db.pl patch level:
6b24a4b7
SF
531use vars qw($VERSION $header);
532
dcfbcce2 533# bump to X.XX in blead, only use X.XX_XX in maint
18ac9f3d 534$VERSION = '1.60';
69893cff 535
e22ea7cc 536$header = "perl5db.pl version $VERSION";
d338d6fe 537
69893cff
RGS
538=head1 DEBUGGER ROUTINES
539
540=head2 C<DB::eval()>
541
542This function replaces straight C<eval()> inside the debugger; it simplifies
543the process of evaluating code in the user's context.
544
b570d64b 545The code to be evaluated is passed via the package global variable
69893cff
RGS
546C<$DB::evalarg>; this is done to avoid fiddling with the contents of C<@_>.
547
be9a9b1d
AT
548Before we do the C<eval()>, we preserve the current settings of C<$trace>,
549C<$single>, C<$^D> and C<$usercontext>. The latter contains the
550preserved values of C<$@>, C<$!>, C<$^E>, C<$,>, C<$/>, C<$\>, C<$^W> and the
551user's current package, grabbed when C<DB::DB> got control. This causes the
552proper context to be used when the eval is actually done. Afterward, we
553restore C<$trace>, C<$single>, and C<$^D>.
69893cff
RGS
554
555Next we need to handle C<$@> without getting confused. We save C<$@> in a
b570d64b
SF
556local lexical, localize C<$saved[0]> (which is where C<save()> will put
557C<$@>), and then call C<save()> to capture C<$@>, C<$!>, C<$^E>, C<$,>,
69893cff 558C<$/>, C<$\>, and C<$^W>) and set C<$,>, C<$/>, C<$\>, and C<$^W> to values
b570d64b
SF
559considered sane by the debugger. If there was an C<eval()> error, we print
560it on the debugger's output. If C<$onetimedump> is defined, we call
561C<dumpit> if it's set to 'dump', or C<methods> if it's set to
562'methods'. Setting it to something else causes the debugger to do the eval
563but not print the result - handy if you want to do something else with it
69893cff
RGS
564(the "watch expressions" code does this to get the value of the watch
565expression but not show it unless it matters).
566
b570d64b
SF
567In any case, we then return the list of output from C<eval> to the caller,
568and unwinding restores the former version of C<$@> in C<@saved> as well
69893cff
RGS
569(the localization of C<$saved[0]> goes away at the end of this scope).
570
571=head3 Parameters and variables influencing execution of DB::eval()
572
573C<DB::eval> isn't parameterized in the standard way; this is to keep the
574debugger's calls to C<DB::eval()> from mucking with C<@_>, among other things.
b570d64b 575The variables listed below influence C<DB::eval()>'s execution directly.
69893cff
RGS
576
577=over 4
578
579=item C<$evalarg> - the thing to actually be eval'ed
580
be9a9b1d 581=item C<$trace> - Current state of execution tracing
69893cff 582
be9a9b1d 583=item C<$single> - Current state of single-stepping
69893cff 584
b570d64b 585=item C<$onetimeDump> - what is to be displayed after the evaluation
69893cff
RGS
586
587=item C<$onetimeDumpDepth> - how deep C<dumpit()> should go when dumping results
588
589=back
590
591The following variables are altered by C<DB::eval()> during its execution. They
b570d64b 592are "stacked" via C<local()>, enabling recursive calls to C<DB::eval()>.
69893cff
RGS
593
594=over 4
595
596=item C<@res> - used to capture output from actual C<eval>.
597
598=item C<$otrace> - saved value of C<$trace>.
599
b570d64b 600=item C<$osingle> - saved value of C<$single>.
69893cff
RGS
601
602=item C<$od> - saved value of C<$^D>.
603
604=item C<$saved[0]> - saved value of C<$@>.
605
b570d64b 606=item $\ - for output of C<$@> if there is an evaluation error.
69893cff
RGS
607
608=back
609
610=head3 The problem of lexicals
611
612The context of C<DB::eval()> presents us with some problems. Obviously,
613we want to be 'sandboxed' away from the debugger's internals when we do
614the eval, but we need some way to control how punctuation variables and
b570d64b 615debugger globals are used.
69893cff
RGS
616
617We can't use local, because the code inside C<DB::eval> can see localized
618variables; and we can't use C<my> either for the same reason. The code
619in this routine compromises and uses C<my>.
620
621After this routine is over, we don't have user code executing in the debugger's
622context, so we can use C<my> freely.
623
624=cut
625
626############################################## Begin lexical danger zone
627
628# 'my' variables used here could leak into (that is, be visible in)
629# the context that the code being evaluated is executing in. This means that
630# the code could modify the debugger's variables.
631#
632# Fiddling with the debugger's context could be Bad. We insulate things as
633# much as we can.
634
6b24a4b7
SF
635use vars qw(
636 @args
637 %break_on_load
6b24a4b7
SF
638 $CommandSet
639 $CreateTTY
640 $DBGR
641 @dbline
642 $dbline
643 %dbline
644 $dieLevel
6b24a4b7 645 $filename
6b24a4b7
SF
646 $histfile
647 $histsize
015b02fd 648 $histitemminlength
6b24a4b7
SF
649 $IN
650 $inhibit_exit
651 @ini_INC
652 $ini_warn
6b24a4b7
SF
653 $maxtrace
654 $od
6b24a4b7
SF
655 @options
656 $osingle
657 $otrace
6b24a4b7
SF
658 $pager
659 $post
660 %postponed
661 $prc
662 $pre
663 $pretype
664 $psh
665 @RememberOnROptions
666 $remoteport
667 @res
668 $rl
669 @saved
6b24a4b7 670 $signalLevel
6b24a4b7 671 $sub
6b24a4b7 672 $term
6b24a4b7
SF
673 $usercontext
674 $warnLevel
6b24a4b7
SF
675);
676
0b83f3d9 677our (
2ef1dcdb 678 @cmdfhs,
0b83f3d9
SF
679 $evalarg,
680 $frame,
0664c09a 681 $hist,
0b83f3d9
SF
682 $ImmediateStop,
683 $line,
684 $onetimeDump,
b8d11fe0 685 $onetimedumpDepth,
1ce985d2 686 %option,
0b83f3d9 687 $OUT,
1ce985d2 688 $packname,
0b83f3d9
SF
689 $signal,
690 $single,
d1450c23 691 $start,
9d0b71b3
SF
692 %sub,
693 $subname,
0b83f3d9 694 $trace,
d1450c23 695 $window,
18b5b545 696);
931ac036 697
6b24a4b7
SF
698# Used to save @ARGV and extract any debugger-related flags.
699use vars qw(@ARGS);
700
701# Used to prevent multiple entries to diesignal()
702# (if for instance diesignal() itself dies)
703use vars qw($panic);
704
705# Used to prevent the debugger from running nonstop
706# after a restart
ebd0282e 707our ($second_time);
6b24a4b7
SF
708
709sub _calc_usercontext {
710 my ($package) = @_;
711
712 # Cancel strict completely for the evaluated code, so the code
713 # the user evaluates won't be affected by it. (Shlomi Fish)
22fc883d 714 return 'no strict; ($@, $!, $^E, $,, $/, $\, $^W) = @DB::saved;'
6b24a4b7
SF
715 . "package $package;"; # this won't let them modify, alas
716}
717
c1051fcf 718sub eval {
69893cff 719
c1051fcf 720 # 'my' would make it visible from user code
e22ea7cc 721 # but so does local! --tchrist
69893cff 722 # Remember: this localizes @DB::res, not @main::res.
c1051fcf
IZ
723 local @res;
724 {
e22ea7cc
RF
725
726 # Try to keep the user code from messing with us. Save these so that
727 # even if the eval'ed code changes them, we can put them back again.
728 # Needed because the user could refer directly to the debugger's
69893cff
RGS
729 # package globals (and any 'my' variables in this containing scope)
730 # inside the eval(), and we want to try to stay safe.
e22ea7cc 731 local $otrace = $trace;
69893cff
RGS
732 local $osingle = $single;
733 local $od = $^D;
734
735 # Untaint the incoming eval() argument.
736 { ($evalarg) = $evalarg =~ /(.*)/s; }
737
e22ea7cc 738 # $usercontext built in DB::DB near the comment
69893cff
RGS
739 # "set up the context for DB::eval ..."
740 # Evaluate and save any results.
e22ea7cc 741 @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
69893cff
RGS
742
743 # Restore those old values.
744 $trace = $otrace;
745 $single = $osingle;
746 $^D = $od;
c1051fcf 747 }
69893cff
RGS
748
749 # Save the current value of $@, and preserve it in the debugger's copy
750 # of the saved precious globals.
c1051fcf 751 my $at = $@;
69893cff
RGS
752
753 # Since we're only saving $@, we only have to localize the array element
754 # that it will be stored in.
e22ea7cc 755 local $saved[0]; # Preserve the old value of $@
e3d167f6 756 eval { &DB::save };
69893cff
RGS
757
758 # Now see whether we need to report an error back to the user.
c1051fcf 759 if ($at) {
69893cff
RGS
760 local $\ = '';
761 print $OUT $at;
762 }
763
764 # Display as required by the caller. $onetimeDump and $onetimedumpDepth
765 # are package globals.
766 elsif ($onetimeDump) {
e22ea7cc
RF
767 if ( $onetimeDump eq 'dump' ) {
768 local $option{dumpDepth} = $onetimedumpDepth
769 if defined $onetimedumpDepth;
770 dumpit( $OUT, \@res );
771 }
772 elsif ( $onetimeDump eq 'methods' ) {
773 methods( $res[0] );
774 }
69893cff 775 } ## end elsif ($onetimeDump)
c1051fcf 776 @res;
69893cff
RGS
777} ## end sub eval
778
779############################################## End lexical danger zone
c1051fcf 780
e22ea7cc
RF
781# After this point it is safe to introduce lexicals.
782# The code being debugged will be executing in its own context, and
69893cff 783# can't see the inside of the debugger.
d338d6fe 784#
e22ea7cc 785# However, one should not overdo it: leave as much control from outside as
69893cff
RGS
786# possible. If you make something a lexical, it's not going to be addressable
787# from outside the debugger even if you know its name.
788
d338d6fe
PP
789# This file is automatically included if you do perl -d.
790# It's probably not useful to include this yourself.
791#
e22ea7cc 792# Before venturing further into these twisty passages, it is
2f7e9187
MS
793# wise to read the perldebguts man page or risk the ire of dragons.
794#
69893cff
RGS
795# (It should be noted that perldebguts will tell you a lot about
796# the underlying mechanics of how the debugger interfaces into the
797# Perl interpreter, but not a lot about the debugger itself. The new
798# comments in this code try to address this problem.)
799
d338d6fe 800# Note that no subroutine call is possible until &DB::sub is defined
36477c24 801# (for subroutines defined outside of the package DB). In fact the same is
d338d6fe 802# true if $deep is not defined.
055fd3a9
GS
803
804# Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich)
055fd3a9
GS
805
806# modified Perl debugger, to be run from Emacs in perldb-mode
807# Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990
808# Johan Vromans -- upgrade to 4.0 pl 10
809# Ilya Zakharevich -- patches after 5.001 (and some before ;-)
6fae1ad7 810########################################################################
d338d6fe 811
69893cff
RGS
812=head1 DEBUGGER INITIALIZATION
813
814The debugger starts up in phases.
815
816=head2 BASIC SETUP
817
818First, it initializes the environment it wants to run in: turning off
819warnings during its own compilation, defining variables which it will need
820to avoid warnings later, setting itself up to not exit when the program
821terminates, and defaulting to printing return values for the C<r> command.
822
823=cut
824
eda6e075 825# Needed for the statement after exec():
69893cff
RGS
826#
827# This BEGIN block is simply used to switch off warnings during debugger
98dc9551 828# compilation. Probably it would be better practice to fix the warnings,
69893cff 829# but this is how it's done at the moment.
eda6e075 830
e22ea7cc
RF
831BEGIN {
832 $ini_warn = $^W;
833 $^W = 0;
834} # Switch compilation warnings off until another BEGIN.
d12a4851 835
69893cff
RGS
836local ($^W) = 0; # Switch run-time warnings off during init.
837
2cbb2ee1
RGS
838=head2 THREADS SUPPORT
839
840If we are running under a threaded Perl, we require threads and threads::shared
841if the environment variable C<PERL5DB_THREADED> is set, to enable proper
842threaded debugger control. C<-dt> can also be used to set this.
843
844Each new thread will be announced and the debugger prompt will always inform
845you of each new thread created. It will also indicate the thread id in which
846we are currently running within the prompt like this:
847
2dbd01ad 848 [tid] DB<$i>
2cbb2ee1
RGS
849
850Where C<[tid]> is an integer thread id and C<$i> is the familiar debugger
851command prompt. The prompt will show: C<[0]> when running under threads, but
852not actually in a thread. C<[tid]> is consistent with C<gdb> usage.
853
854While running under threads, when you set or delete a breakpoint (etc.), this
b570d64b 855will apply to all threads, not just the currently running one. When you are
2cbb2ee1
RGS
856in a currently executing thread, you will stay there until it completes. With
857the current implementation it is not currently possible to hop from one thread
858to another.
859
860The C<e> and C<E> commands are currently fairly minimal - see C<h e> and C<h E>.
861
862Note that threading support was built into the debugger as of Perl version
863C<5.8.6> and debugger version C<1.2.8>.
864
865=cut
866
867BEGIN {
2dbd01ad
SF
868 # ensure we can share our non-threaded variables or no-op
869 if ($ENV{PERL5DB_THREADED}) {
870 require threads;
871 require threads::shared;
872 import threads::shared qw(share);
873 $DBGR;
874 share(\$DBGR);
875 lock($DBGR);
876 print "Threads support enabled\n";
877 } else {
41ef2c66 878 *lock = sub(*) {};
cde405a6 879 *share = sub(\[$@%]) {};
2dbd01ad 880 }
2cbb2ee1
RGS
881}
882
2218c045
SF
883# These variables control the execution of 'dumpvar.pl'.
884{
885 package dumpvar;
886 use vars qw(
887 $hashDepth
888 $arrayDepth
889 $dumpDBFiles
890 $dumpPackages
891 $quoteHighBit
892 $printUndef
893 $globPrint
894 $usageOnly
895 );
896}
69893cff 897
2218c045
SF
898# used to control die() reporting in diesignal()
899{
900 package Carp;
901 use vars qw($CarpLevel);
902}
d338d6fe 903
422c59bf 904# without threads, $filename is not defined until DB::DB is called
cde405a6 905share($main::{'_<'.$filename}) if defined $filename;
2cbb2ee1 906
54d04a52 907# Command-line + PERLLIB:
69893cff 908# Save the contents of @INC before they are modified elsewhere.
54d04a52
IZ
909@ini_INC = @INC;
910
69893cff
RGS
911# This was an attempt to clear out the previous values of various
912# trapped errors. Apparently it didn't help. XXX More info needed!
d338d6fe
PP
913# $prevwarn = $prevdie = $prevbus = $prevsegv = ''; # Does not help?!
914
69893cff
RGS
915# We set these variables to safe values. We don't want to blindly turn
916# off warnings, because other packages may still want them.
e22ea7cc
RF
917$trace = $signal = $single = 0; # Uninitialized warning suppression
918 # (local $^W cannot help - other packages!).
69893cff
RGS
919
920# Default to not exiting when program finishes; print the return
921# value when the 'r' command is used to return from a subroutine.
55497cff 922$inhibit_exit = $option{PrintRet} = 1;
d338d6fe 923
6b24a4b7
SF
924use vars qw($trace_to_depth);
925
5e2b42dd
SF
926# Default to 1E9 so it won't be limited to a certain recursion depth.
927$trace_to_depth = 1E9;
bdba49ad 928
69893cff
RGS
929=head1 OPTION PROCESSING
930
b570d64b
SF
931The debugger's options are actually spread out over the debugger itself and
932C<dumpvar.pl>; some of these are variables to be set, while others are
69893cff
RGS
933subs to be called with a value. To try to make this a little easier to
934manage, the debugger uses a few data structures to define what options
935are legal and how they are to be processed.
936
937First, the C<@options> array defines the I<names> of all the options that
938are to be accepted.
939
940=cut
941
942@options = qw(
5561b870 943 CommandSet HistFile HistSize
015b02fd 944 HistItemMinLength
e22ea7cc
RF
945 hashDepth arrayDepth dumpDepth
946 DumpDBFiles DumpPackages DumpReused
947 compactDump veryCompact quote
948 HighBit undefPrint globPrint
949 PrintRet UsageOnly frame
950 AutoTrace TTY noTTY
951 ReadLine NonStop LineInfo
952 maxTraceLen recallCommand ShellBang
953 pager tkRunning ornaments
954 signalLevel warnLevel dieLevel
955 inhibit_exit ImmediateStop bareStringify
956 CreateTTY RemotePort windowSize
584420f0 957 DollarCaretP
e22ea7cc 958);
d12a4851 959
584420f0 960@RememberOnROptions = qw(DollarCaretP);
d12a4851 961
69893cff
RGS
962=pod
963
964Second, C<optionVars> lists the variables that each option uses to save its
965state.
966
967=cut
968
6b24a4b7
SF
969use vars qw(%optionVars);
970
69893cff 971%optionVars = (
e22ea7cc
RF
972 hashDepth => \$dumpvar::hashDepth,
973 arrayDepth => \$dumpvar::arrayDepth,
974 CommandSet => \$CommandSet,
975 DumpDBFiles => \$dumpvar::dumpDBFiles,
976 DumpPackages => \$dumpvar::dumpPackages,
977 DumpReused => \$dumpvar::dumpReused,
978 HighBit => \$dumpvar::quoteHighBit,
979 undefPrint => \$dumpvar::printUndef,
980 globPrint => \$dumpvar::globPrint,
981 UsageOnly => \$dumpvar::usageOnly,
982 CreateTTY => \$CreateTTY,
983 bareStringify => \$dumpvar::bareStringify,
984 frame => \$frame,
985 AutoTrace => \$trace,
986 inhibit_exit => \$inhibit_exit,
987 maxTraceLen => \$maxtrace,
988 ImmediateStop => \$ImmediateStop,
989 RemotePort => \$remoteport,
990 windowSize => \$window,
5561b870
AK
991 HistFile => \$histfile,
992 HistSize => \$histsize,
015b02fd 993 HistItemMinLength => \$histitemminlength
69893cff
RGS
994);
995
996=pod
997
998Third, C<%optionAction> defines the subroutine to be called to process each
999option.
1000
b570d64b 1001=cut
69893cff 1002
6b24a4b7
SF
1003use vars qw(%optionAction);
1004
69893cff
RGS
1005%optionAction = (
1006 compactDump => \&dumpvar::compactDump,
1007 veryCompact => \&dumpvar::veryCompact,
1008 quote => \&dumpvar::quote,
1009 TTY => \&TTY,
1010 noTTY => \&noTTY,
1011 ReadLine => \&ReadLine,
1012 NonStop => \&NonStop,
1013 LineInfo => \&LineInfo,
1014 recallCommand => \&recallCommand,
1015 ShellBang => \&shellBang,
1016 pager => \&pager,
1017 signalLevel => \&signalLevel,
1018 warnLevel => \&warnLevel,
1019 dieLevel => \&dieLevel,
1020 tkRunning => \&tkRunning,
1021 ornaments => \&ornaments,
1022 RemotePort => \&RemotePort,
1023 DollarCaretP => \&DollarCaretP,
d12a4851
JH
1024);
1025
69893cff
RGS
1026=pod
1027
1028Last, the C<%optionRequire> notes modules that must be C<require>d if an
1029option is used.
1030
1031=cut
d338d6fe 1032
69893cff
RGS
1033# Note that this list is not complete: several options not listed here
1034# actually require that dumpvar.pl be loaded for them to work, but are
1035# not in the table. A subsequent patch will correct this problem; for
1036# the moment, we're just recommenting, and we are NOT going to change
1037# function.
6b24a4b7
SF
1038use vars qw(%optionRequire);
1039
eda6e075 1040%optionRequire = (
69893cff
RGS
1041 compactDump => 'dumpvar.pl',
1042 veryCompact => 'dumpvar.pl',
1043 quote => 'dumpvar.pl',
e22ea7cc 1044);
69893cff
RGS
1045
1046=pod
1047
1048There are a number of initialization-related variables which can be set
1049by putting code to set them in a BEGIN block in the C<PERL5DB> environment
1050variable. These are:
1051
1052=over 4
1053
1054=item C<$rl> - readline control XXX needs more explanation
1055
1056=item C<$warnLevel> - whether or not debugger takes over warning handling
1057
1058=item C<$dieLevel> - whether or not debugger takes over die handling
1059
1060=item C<$signalLevel> - whether or not debugger takes over signal handling
1061
1062=item C<$pre> - preprompt actions (array reference)
1063
1064=item C<$post> - postprompt actions (array reference)
1065
1066=item C<$pretype>
1067
1068=item C<$CreateTTY> - whether or not to create a new TTY for this debugger
1069
1070=item C<$CommandSet> - which command set to use (defaults to new, documented set)
1071
1072=back
1073
1074=cut
d338d6fe
PP
1075
1076# These guys may be defined in $ENV{PERL5DB} :
69893cff
RGS
1077$rl = 1 unless defined $rl;
1078$warnLevel = 1 unless defined $warnLevel;
1079$dieLevel = 1 unless defined $dieLevel;
1080$signalLevel = 1 unless defined $signalLevel;
1081$pre = [] unless defined $pre;
1082$post = [] unless defined $post;
1083$pretype = [] unless defined $pretype;
1084$CreateTTY = 3 unless defined $CreateTTY;
1085$CommandSet = '580' unless defined $CommandSet;
1086
2cbb2ee1
RGS
1087share($rl);
1088share($warnLevel);
1089share($dieLevel);
1090share($signalLevel);
1091share($pre);
1092share($post);
1093share($pretype);
2cbb2ee1
RGS
1094share($CreateTTY);
1095share($CommandSet);
1096
69893cff
RGS
1097=pod
1098
1099The default C<die>, C<warn>, and C<signal> handlers are set up.
1100
1101=cut
055fd3a9 1102
d338d6fe
PP
1103warnLevel($warnLevel);
1104dieLevel($dieLevel);
1105signalLevel($signalLevel);
055fd3a9 1106
69893cff
RGS
1107=pod
1108
1109The pager to be used is needed next. We try to get it from the
5561b870 1110environment first. If it's not defined there, we try to find it in
69893cff
RGS
1111the Perl C<Config.pm>. If it's not there, we default to C<more>. We
1112then call the C<pager()> function to save the pager name.
1113
1114=cut
1115
1116# This routine makes sure $pager is set up so that '|' can use it.
4865a36d 1117pager(
e22ea7cc 1118
69893cff 1119 # If PAGER is defined in the environment, use it.
e22ea7cc
RF
1120 defined $ENV{PAGER}
1121 ? $ENV{PAGER}
69893cff
RGS
1122
1123 # If not, see if Config.pm defines it.
e22ea7cc
RF
1124 : eval { require Config }
1125 && defined $Config::Config{pager}
1126 ? $Config::Config{pager}
69893cff
RGS
1127
1128 # If not, fall back to 'more'.
e22ea7cc
RF
1129 : 'more'
1130 )
1131 unless defined $pager;
69893cff
RGS
1132
1133=pod
1134
1135We set up the command to be used to access the man pages, the command
be9a9b1d
AT
1136recall character (C<!> unless otherwise defined) and the shell escape
1137character (C<!> unless otherwise defined). Yes, these do conflict, and
69893cff
RGS
1138neither works in the debugger at the moment.
1139
1140=cut
1141
055fd3a9 1142setman();
69893cff
RGS
1143
1144# Set up defaults for command recall and shell escape (note:
1145# these currently don't work in linemode debugging).
2218c045
SF
1146recallCommand("!") unless defined $prc;
1147shellBang("!") unless defined $psh;
69893cff
RGS
1148
1149=pod
1150
1151We then set up the gigantic string containing the debugger help.
1152We also set the limit on the number of arguments we'll display during a
1153trace.
1154
1155=cut
1156
04e43a21 1157sethelp();
69893cff
RGS
1158
1159# If we didn't get a default for the length of eval/stack trace args,
1160# set it here.
1d06cb2d 1161$maxtrace = 400 unless defined $maxtrace;
69893cff
RGS
1162
1163=head2 SETTING UP THE DEBUGGER GREETING
1164
be9a9b1d 1165The debugger I<greeting> helps to inform the user how many debuggers are
69893cff
RGS
1166running, and whether the current debugger is the primary or a child.
1167
1168If we are the primary, we just hang onto our pid so we'll have it when
1169or if we start a child debugger. If we are a child, we'll set things up
1170so we'll have a unique greeting and so the parent will give us our own
1171TTY later.
1172
1173We save the current contents of the C<PERLDB_PIDS> environment variable
1174because we mess around with it. We'll also need to hang onto it because
1175we'll need it if we restart.
1176
1177Child debuggers make a label out of the current PID structure recorded in
1178PERLDB_PIDS plus the new PID. They also mark themselves as not having a TTY
1179yet so the parent will give them one later via C<resetterm()>.
1180
1181=cut
1182
e22ea7cc 1183# Save the current contents of the environment; we're about to
69893cff 1184# much with it. We'll need this if we have to restart.
6b24a4b7 1185use vars qw($ini_pids);
f1583d8f 1186$ini_pids = $ENV{PERLDB_PIDS};
69893cff 1187
6b24a4b7
SF
1188use vars qw ($pids $term_pid);
1189
e22ea7cc
RF
1190if ( defined $ENV{PERLDB_PIDS} ) {
1191
69893cff 1192 # We're a child. Make us a label out of the current PID structure
e22ea7cc 1193 # recorded in PERLDB_PIDS plus our (new) PID. Mark us as not having
69893cff 1194 # a term yet so the parent will give us one later via resetterm().
55f4245e
JM
1195
1196 my $env_pids = $ENV{PERLDB_PIDS};
1197 $pids = "[$env_pids]";
1198
1199 # Unless we are on OpenVMS, all programs under the DCL shell run under
1200 # the same PID.
1201
1202 if (($^O eq 'VMS') && ($env_pids =~ /\b$$\b/)) {
1203 $term_pid = $$;
1204 }
1205 else {
1206 $ENV{PERLDB_PIDS} .= "->$$";
1207 $term_pid = -1;
1208 }
1209
69893cff
RGS
1210} ## end if (defined $ENV{PERLDB_PIDS...
1211else {
e22ea7cc
RF
1212
1213 # We're the parent PID. Initialize PERLDB_PID in case we end up with a
69893cff
RGS
1214 # child debugger, and mark us as the parent, so we'll know to set up
1215 # more TTY's is we have to.
1216 $ENV{PERLDB_PIDS} = "$$";
619a0444 1217 $pids = "[pid=$$]";
e22ea7cc 1218 $term_pid = $$;
f1583d8f 1219}
69893cff 1220
6b24a4b7 1221use vars qw($pidprompt);
f1583d8f 1222$pidprompt = '';
69893cff
RGS
1223
1224# Sets up $emacs as a synonym for $slave_editor.
7793e5c2 1225our ($slave_editor);
69893cff
RGS
1226*emacs = $slave_editor if $slave_editor; # May be used in afterinit()...
1227
1228=head2 READING THE RC FILE
1229
b570d64b 1230The debugger will read a file of initialization options if supplied. If
69893cff
RGS
1231running interactively, this is C<.perldb>; if not, it's C<perldb.ini>.
1232
b570d64b 1233=cut
69893cff
RGS
1234
1235# As noted, this test really doesn't check accurately that the debugger
1236# is running at a terminal or not.
d338d6fe 1237
6b24a4b7 1238use vars qw($rcfile);
fb4d8a6c
SF
1239{
1240 my $dev_tty = (($^O eq 'VMS') ? 'TT:' : '/dev/tty');
1241 # this is the wrong metric!
1242 $rcfile = ((-e $dev_tty) ? ".perldb" : "perldb.ini");
d338d6fe
PP
1243}
1244
69893cff
RGS
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
1251
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
69893cff
RGS
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?
69893cff
RGS
1263 local $SIG{__WARN__};
1264 local $SIG{__DIE__};
055fd3a9 1265
e22ea7cc 1266 unless ( is_safe_file($file) ) {
69893cff 1267 CORE::warn <<EO_GRIPE;
055fd3a9 1268perldb: Must not source insecure rcfile $file.
b570d64b 1269 You or the superuser must be the owner, and it must not
69893cff 1270 be writable by anyone but its owner.
055fd3a9 1271EO_GRIPE
69893cff
RGS
1272 return;
1273 } ## end unless (is_safe_file($file...
055fd3a9
GS
1274
1275 do $file;
1276 CORE::warn("perldb: couldn't parse $file: $@") if $@;
69893cff 1277} ## end sub safe_do
055fd3a9 1278
69893cff
RGS
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
e22ea7cc 1285# eventually accessed is the same as the one tested.
055fd3a9
GS
1286# Assumes that the file's existence is not in doubt.
1287sub is_safe_file {
1288 my $path = shift;
69893cff 1289 stat($path) || return; # mysteriously vaporized
e22ea7cc 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;
69893cff 1295} ## end sub is_safe_file
055fd3a9 1296
69893cff 1297# If the rcfile (whichever one we decided was the right one to read)
e22ea7cc
RF
1298# exists, we safely do it.
1299if ( -f $rcfile ) {
055fd3a9 1300 safe_do("./$rcfile");
69893cff 1301}
e22ea7cc 1302
69893cff 1303# If there isn't one here, try the user's home directory.
e22ea7cc 1304elsif ( defined $ENV{HOME} && -f "$ENV{HOME}/$rcfile" ) {
055fd3a9
GS
1305 safe_do("$ENV{HOME}/$rcfile");
1306}
e22ea7cc 1307
69893cff 1308# Else try the login directory.
e22ea7cc 1309elsif ( defined $ENV{LOGDIR} && -f "$ENV{LOGDIR}/$rcfile" ) {
055fd3a9 1310 safe_do("$ENV{LOGDIR}/$rcfile");
d338d6fe
PP
1311}
1312
69893cff 1313# If the PERLDB_OPTS variable has options in it, parse those out next.
e22ea7cc
RF
1314if ( defined $ENV{PERLDB_OPTS} ) {
1315 parse_options( $ENV{PERLDB_OPTS} );
d338d6fe
PP
1316}
1317
69893cff
RGS
1318=pod
1319
1320The last thing we do during initialization is determine which subroutine is
1321to be used to obtain a new terminal when a new debugger is started. Right now,
b0b54b5e 1322the debugger only handles TCP sockets, X11, OS/2, amd Mac OS X
11653f7f 1323(darwin).
69893cff
RGS
1324
1325=cut
1326
1327# Set up the get_fork_TTY subroutine to be aliased to the proper routine.
1328# Works if you're running an xterm or xterm-like window, or you're on
6fae1ad7
RF
1329# OS/2, or on Mac OS X. This may need some expansion.
1330
1331if (not defined &get_fork_TTY) # only if no routine exists
69893cff 1332{
b570d64b 1333 if ( defined $remoteport ) {
11653f7f
JJ
1334 # Expect an inetd-like server
1335 *get_fork_TTY = \&socket_get_fork_TTY; # to listen to us
1336 }
1337 elsif (defined $ENV{TERM} # If we know what kind
6fae1ad7
RF
1338 # of terminal this is,
1339 and $ENV{TERM} eq 'xterm' # and it's an xterm,
1340 and defined $ENV{DISPLAY} # and what display it's on,
1341 )
1342 {
1343 *get_fork_TTY = \&xterm_get_fork_TTY; # use the xterm version
1344 }
babb663a
RH
1345 elsif ( $ENV{TMUX} ) {
1346 *get_fork_TTY = \&tmux_get_fork_TTY;
1347 }
6fae1ad7
RF
1348 elsif ( $^O eq 'os2' ) { # If this is OS/2,
1349 *get_fork_TTY = \&os2_get_fork_TTY; # use the OS/2 version
1350 }
1351 elsif ( $^O eq 'darwin' # If this is Mac OS X
1352 and defined $ENV{TERM_PROGRAM} # and we're running inside
1353 and $ENV{TERM_PROGRAM}
1354 eq 'Apple_Terminal' # Terminal.app
1355 )
1356 {
1357 *get_fork_TTY = \&macosx_get_fork_TTY; # use the Mac OS X version
1358 }
69893cff 1359} ## end if (not defined &get_fork_TTY...
e22ea7cc 1360
dbb46cec
DQ
1361# untaint $^O, which may have been tainted by the last statement.
1362# see bug [perl #24674]
e22ea7cc
RF
1363$^O =~ m/^(.*)\z/;
1364$^O = $1;
f1583d8f 1365
d12a4851 1366# Here begin the unreadable code. It needs fixing.
055fd3a9 1367
69893cff
RGS
1368=head2 RESTART PROCESSING
1369
1370This section handles the restart command. When the C<R> command is invoked, it
1371tries to capture all of the state it can into environment variables, and
1372then sets C<PERLDB_RESTART>. When we start executing again, we check to see
1373if C<PERLDB_RESTART> is there; if so, we reload all the information that
1374the R command stuffed into the environment variables.
1375
b570d64b 1376 PERLDB_RESTART - flag only, contains no restart data itself.
69893cff
RGS
1377 PERLDB_HIST - command history, if it's available
1378 PERLDB_ON_LOAD - breakpoints set by the rc file
555bd962
BG
1379 PERLDB_POSTPONE - subs that have been loaded/not executed,
1380 and have actions
69893cff
RGS
1381 PERLDB_VISITED - files that had breakpoints
1382 PERLDB_FILE_... - breakpoints for a file
1383 PERLDB_OPT - active options
1384 PERLDB_INC - the original @INC
1385 PERLDB_PRETYPE - preprompt debugger actions
1386 PERLDB_PRE - preprompt Perl code
1387 PERLDB_POST - post-prompt Perl code
1388 PERLDB_TYPEAHEAD - typeahead captured by readline()
1389
1390We chug through all these variables and plug the values saved in them
1391back into the appropriate spots in the debugger.
1392
1393=cut
1394
0664c09a 1395use vars qw(%postponed_file @typeahead);
14f38b27 1396
0664c09a 1397our (@hist, @truehist);
6b24a4b7 1398
fb0fb5f4
SF
1399sub _restore_shared_globals_after_restart
1400{
1401 @hist = get_list('PERLDB_HIST');
1402 %break_on_load = get_list("PERLDB_ON_LOAD");
1403 %postponed = get_list("PERLDB_POSTPONE");
1404
1405 share(@hist);
1406 share(@truehist);
1407 share(%break_on_load);
1408 share(%postponed);
1409}
1410
e18a02a6 1411sub _restore_breakpoints_and_actions {
e22ea7cc 1412
e22ea7cc 1413 my @had_breakpoints = get_list("PERLDB_VISITED");
e18a02a6 1414
bdba49ad
SF
1415 for my $file_idx ( 0 .. $#had_breakpoints ) {
1416 my $filename = $had_breakpoints[$file_idx];
1417 my %pf = get_list("PERLDB_FILE_$file_idx");
1418 $postponed_file{ $filename } = \%pf if %pf;
1419 my @lines = sort {$a <=> $b} keys(%pf);
1420 my @enabled_statuses = get_list("PERLDB_FILE_ENABLED_$file_idx");
1421 for my $line_idx (0 .. $#lines) {
1422 _set_breakpoint_enabled_status(
1423 $filename,
1424 $lines[$line_idx],
1425 ($enabled_statuses[$line_idx] ? 1 : ''),
1426 );
1427 }
e22ea7cc 1428 }
69893cff 1429
e18a02a6
SF
1430 return;
1431}
1432
ca50076b
SF
1433sub _restore_options_after_restart
1434{
1435 my %options_map = get_list("PERLDB_OPT");
1436
1437 while ( my ( $opt, $val ) = each %options_map ) {
1438 $val =~ s/[\\\']/\\$1/g;
1439 parse_options("$opt'$val'");
1440 }
1441
1442 return;
1443}
1444
18580168
SF
1445sub _restore_globals_after_restart
1446{
1447 # restore original @INC
1448 @INC = get_list("PERLDB_INC");
1449 @ini_INC = @INC;
1450
1451 # return pre/postprompt actions and typeahead buffer
1452 $pretype = [ get_list("PERLDB_PRETYPE") ];
1453 $pre = [ get_list("PERLDB_PRE") ];
1454 $post = [ get_list("PERLDB_POST") ];
1455 @typeahead = get_list( "PERLDB_TYPEAHEAD", @typeahead );
1456
1457 return;
1458}
1459
fb0fb5f4 1460
e18a02a6
SF
1461if ( exists $ENV{PERLDB_RESTART} ) {
1462
1463 # We're restarting, so we don't need the flag that says to restart anymore.
1464 delete $ENV{PERLDB_RESTART};
1465
1466 # $restart = 1;
fb0fb5f4 1467 _restore_shared_globals_after_restart();
e18a02a6
SF
1468
1469 _restore_breakpoints_and_actions();
1470
69893cff 1471 # restore options
ca50076b 1472 _restore_options_after_restart();
69893cff 1473
18580168 1474 _restore_globals_after_restart();
69893cff
RGS
1475} ## end if (exists $ENV{PERLDB_RESTART...
1476
1477=head2 SETTING UP THE TERMINAL
1478
1479Now, we'll decide how the debugger is going to interact with the user.
1480If there's no TTY, we set the debugger to run non-stop; there's not going
1481to be anyone there to enter commands.
1482
1483=cut
54d04a52 1484
ebd0282e 1485use vars qw($notty $console $tty $LINEINFO);
6b24a4b7
SF
1486use vars qw($lineinfo $doccmd);
1487
ebd0282e
SF
1488our ($runnonstop);
1489
e0047406
KF
1490# Local autoflush to avoid rt#116769,
1491# as calling IO::File methods causes an unresolvable loop
1492# that results in debugger failure.
1493sub _autoflush {
1494 my $o = select($_[0]);
1495 $|++;
1496 select($o);
1497}
1498
d338d6fe 1499if ($notty) {
69893cff 1500 $runnonstop = 1;
2dbd01ad 1501 share($runnonstop);
69893cff 1502}
d12a4851 1503
69893cff
RGS
1504=pod
1505
1506If there is a TTY, we have to determine who it belongs to before we can
1507proceed. If this is a slave editor or graphical debugger (denoted by
1508the first command-line switch being '-emacs'), we shift this off and
1509set C<$rl> to 0 (XXX ostensibly to do straight reads).
1510
1511=cut
1512
1513else {
e22ea7cc 1514
69893cff
RGS
1515 # Is Perl being run from a slave editor or graphical debugger?
1516 # If so, don't use readline, and set $slave_editor = 1.
2b0b9dd1
SF
1517 if ($slave_editor = ( @main::ARGV && ( $main::ARGV[0] eq '-emacs' ) )) {
1518 $rl = 0;
1519 shift(@main::ARGV);
1520 }
e22ea7cc
RF
1521
1522 #require Term::ReadLine;
d12a4851 1523
69893cff
RGS
1524=pod
1525
1526We then determine what the console should be on various systems:
1527
1528=over 4
1529
1530=item * Cygwin - We use C<stdin> instead of a separate device.
1531
1532=cut
1533
e22ea7cc
RF
1534 if ( $^O eq 'cygwin' ) {
1535
69893cff
RGS
1536 # /dev/tty is binary. use stdin for textmode
1537 undef $console;
1538 }
1539
69893cff
RGS
1540=item * Windows or MSDOS - use C<con>.
1541
1542=cut
1543
e22ea7cc 1544 elsif ( $^O eq 'dos' or -e "con" or $^O eq 'MSWin32' ) {
69893cff
RGS
1545 $console = "con";
1546 }
1547
cf412c92
AB
1548=item * AmigaOS - use C<CONSOLE:>.
1549
1550=cut
1551
1552 elsif ( $^O eq 'amigaos' ) {
1553 $console = "CONSOLE:";
1554 }
1555
69893cff
RGS
1556=item * VMS - use C<sys$command>.
1557
1558=cut
1559
c9cc5940
JH
1560 elsif ($^O eq 'VMS') {
1561 $console = 'sys$command';
1562 }
1563
f1cba945
JK
1564# Keep this penultimate, on the grounds that it satisfies a wide variety of
1565# Unix-like systems that would otherwise need to be identified individually.
1566
1567=item * Unix - use F</dev/tty>.
1568
1569=cut
1570
1571 elsif ( -e "/dev/tty" ) {
1572 $console = "/dev/tty";
1573 }
1574
c9cc5940 1575# Keep this last.
e22ea7cc 1576
c9cc5940
JH
1577 else {
1578 _db_warn("Can't figure out your console, using stdin");
1579 undef $console;
d12a4851 1580 }
69893cff
RGS
1581
1582=pod
1583
1584=back
1585
1586Several other systems don't use a specific console. We C<undef $console>
1587for those (Windows using a slave editor/graphical debugger, NetWare, OS/2
739a0b84 1588with a slave editor).
69893cff
RGS
1589
1590=cut
d12a4851 1591
e22ea7cc
RF
1592 if ( ( $^O eq 'MSWin32' ) and ( $slave_editor or defined $ENV{EMACS} ) ) {
1593
69893cff 1594 # /dev/tty is binary. use stdin for textmode
e22ea7cc
RF
1595 $console = undef;
1596 }
1597
1598 if ( $^O eq 'NetWare' ) {
d12a4851 1599
69893cff
RGS
1600 # /dev/tty is binary. use stdin for textmode
1601 $console = undef;
1602 }
d12a4851 1603
69893cff
RGS
1604 # In OS/2, we need to use STDIN to get textmode too, even though
1605 # it pretty much looks like Unix otherwise.
e22ea7cc
RF
1606 if ( defined $ENV{OS2_SHELL} and ( $slave_editor or $ENV{WINDOWID} ) )
1607 { # In OS/2
1608 $console = undef;
1609 }
1610
69893cff
RGS
1611=pod
1612
1613If there is a TTY hanging around from a parent, we use that as the console.
1614
1615=cut
1616
e22ea7cc 1617 $console = $tty if defined $tty;
d12a4851 1618
b570d64b 1619=head2 SOCKET HANDLING
69893cff
RGS
1620
1621The debugger is capable of opening a socket and carrying out a debugging
1622session over the socket.
1623
1624If C<RemotePort> was defined in the options, the debugger assumes that it
1625should try to start a debugging session on that port. It builds the socket
1626and then tries to connect the input and output filehandles to it.
1627
1628=cut
1629
1630 # Handle socket stuff.
e22ea7cc
RF
1631
1632 if ( defined $remoteport ) {
1633
69893cff
RGS
1634 # If RemotePort was defined in the options, connect input and output
1635 # to the socket.
11653f7f 1636 $IN = $OUT = connect_remoteport();
69893cff
RGS
1637 } ## end if (defined $remoteport)
1638
1639=pod
1640
1641If no C<RemotePort> was defined, and we want to create a TTY on startup,
1642this is probably a situation where multiple debuggers are running (for example,
1643a backticked command that starts up another debugger). We create a new IN and
1644OUT filehandle, and do the necessary mojo to create a new TTY if we know how
1645and if we can.
1646
1647=cut
1648
1649 # Non-socket.
1650 else {
e22ea7cc 1651
69893cff
RGS
1652 # Two debuggers running (probably a system or a backtick that invokes
1653 # the debugger itself under the running one). create a new IN and OUT
e22ea7cc 1654 # filehandle, and do the necessary mojo to create a new tty if we
69893cff 1655 # know how, and we can.
e22ea7cc
RF
1656 create_IN_OUT(4) if $CreateTTY & 4;
1657 if ($console) {
1658
69893cff 1659 # If we have a console, check to see if there are separate ins and
cd1191f1 1660 # outs to open. (They are assumed identical if not.)
69893cff 1661
e22ea7cc
RF
1662 my ( $i, $o ) = split /,/, $console;
1663 $o = $i unless defined $o;
69893cff 1664
69893cff 1665 # read/write on in, or just read, or read on STDIN.
1ae6ead9
JL
1666 open( IN, '+<', $i )
1667 || open( IN, '<', $i )
e22ea7cc
RF
1668 || open( IN, "<&STDIN" );
1669
69893cff
RGS
1670 # read/write/create/clobber out, or write/create/clobber out,
1671 # or merge with STDERR, or merge with STDOUT.
1ae6ead9
JL
1672 open( OUT, '+>', $o )
1673 || open( OUT, '>', $o )
e22ea7cc
RF
1674 || open( OUT, ">&STDERR" )
1675 || open( OUT, ">&STDOUT" ); # so we don't dongle stdout
1676
1677 } ## end if ($console)
1678 elsif ( not defined $console ) {
1679
1680 # No console. Open STDIN.
1681 open( IN, "<&STDIN" );
1682
1683 # merge with STDERR, or with STDOUT.
1684 open( OUT, ">&STDERR" )
1685 || open( OUT, ">&STDOUT" ); # so we don't dongle stdout
1686 $console = 'STDIN/OUT';
69893cff
RGS
1687 } ## end elsif (not defined $console)
1688
1689 # Keep copies of the filehandles so that when the pager runs, it
1690 # can close standard input without clobbering ours.
2b0b9dd1
SF
1691 if ($console or (not defined($console))) {
1692 $IN = \*IN;
1693 $OUT = \*OUT;
1694 }
e22ea7cc
RF
1695 } ## end elsif (from if(defined $remoteport))
1696
1697 # Unbuffer DB::OUT. We need to see responses right away.
e0047406 1698 _autoflush($OUT);
e22ea7cc
RF
1699
1700 # Line info goes to debugger output unless pointed elsewhere.
1701 # Pointing elsewhere makes it possible for slave editors to
1702 # keep track of file and position. We have both a filehandle
1703 # and a I/O description to keep track of.
1704 $LINEINFO = $OUT unless defined $LINEINFO;
1705 $lineinfo = $console unless defined $lineinfo;
2dbd01ad
SF
1706 # share($LINEINFO); # <- unable to share globs
1707 share($lineinfo); #
e22ea7cc 1708
69893cff
RGS
1709=pod
1710
1711To finish initialization, we show the debugger greeting,
1712and then call the C<afterinit()> subroutine if there is one.
1713
1714=cut
d12a4851 1715
e22ea7cc
RF
1716 # Show the debugger greeting.
1717 $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
1718 unless ($runnonstop) {
1719 local $\ = '';
1720 local $, = '';
1721 if ( $term_pid eq '-1' ) {
1722 print $OUT "\nDaughter DB session started...\n";
1723 }
1724 else {
1725 print $OUT "\nLoading DB routines from $header\n";
1726 print $OUT (
1727 "Editor support ",
1728 $slave_editor ? "enabled" : "available", ".\n"
1729 );
1730 print $OUT
1f874cb6 1731"\nEnter h or 'h h' for help, or '$doccmd perldebug' for more help.\n\n";
69893cff
RGS
1732 } ## end else [ if ($term_pid eq '-1')
1733 } ## end unless ($runnonstop)
1734} ## end else [ if ($notty)
1735
1736# XXX This looks like a bug to me.
1737# Why copy to @ARGS and then futz with @args?
d338d6fe 1738@ARGS = @ARGV;
6b24a4b7 1739# for (@args) {
69893cff
RGS
1740 # Make sure backslashes before single quotes are stripped out, and
1741 # keep args unless they are numeric (XXX why?)
e22ea7cc
RF
1742 # s/\'/\\\'/g; # removed while not justified understandably
1743 # s/(.*)/'$1'/ unless /^-?[\d.]+$/; # ditto
6b24a4b7 1744# }
d338d6fe 1745
e22ea7cc 1746# If there was an afterinit() sub defined, call it. It will get
69893cff 1747# executed in our scope, so it can fiddle with debugger globals.
e22ea7cc 1748if ( defined &afterinit ) { # May be defined in $rcfile
2b0b9dd1 1749 afterinit();
d338d6fe 1750}
e22ea7cc 1751
69893cff 1752# Inform us about "Stack dump during die enabled ..." in dieLevel().
6b24a4b7
SF
1753use vars qw($I_m_init);
1754
43aed9ee
IZ
1755$I_m_init = 1;
1756
d338d6fe
PP
1757############################################################ Subroutines
1758
69893cff
RGS
1759=head1 SUBROUTINES
1760
1761=head2 DB
1762
1763This gigantic subroutine is the heart of the debugger. Called before every
1764statement, its job is to determine if a breakpoint has been reached, and
1765stop if so; read commands from the user, parse them, and execute
b468dcb6 1766them, and then send execution off to the next statement.
69893cff
RGS
1767
1768Note that the order in which the commands are processed is very important;
1769some commands earlier in the loop will actually alter the C<$cmd> variable
be9a9b1d 1770to create other commands to be executed later. This is all highly I<optimized>
69893cff
RGS
1771but can be confusing. Check the comments for each C<$cmd ... && do {}> to
1772see what's happening in any given command.
1773
1774=cut
1775
136ae23d
SF
1776# $cmd cannot be an our() variable unfortunately (possible perl bug?).
1777
6b24a4b7
SF
1778use vars qw(
1779 $action
6b24a4b7 1780 $cmd
6b24a4b7
SF
1781 $file
1782 $filename_ini
1783 $finished
1784 %had_breakpoints
6b24a4b7
SF
1785 $level
1786 $max
6b24a4b7 1787 $package
6b24a4b7
SF
1788 $try
1789);
1790
1ce985d2 1791our (
bdb3f37d 1792 %alias,
1ce985d2 1793 $doret,
0664c09a 1794 $end,
4d0e1f38 1795 $fall_off_end,
d1450c23 1796 $incr,
73c5e526 1797 $laststep,
14f38b27 1798 $rc,
ddf4cf26 1799 $sh,
1ce985d2
SF
1800 $stack_depth,
1801 @stack,
1802 @to_watch,
1803 @old_watch,
1804);
8ad70697 1805
6791e41b
SF
1806sub _DB__determine_if_we_should_break
1807{
1808 # if we have something here, see if we should break.
1809 # $stop is lexical and local to this block - $action on the other hand
1810 # is global.
1811 my $stop;
1812
1813 if ( $dbline{$line}
1814 && _is_breakpoint_enabled($filename, $line)
1815 && (( $stop, $action ) = split( /\0/, $dbline{$line} ) ) )
1816 {
1817
1818 # Stop if the stop criterion says to just stop.
1819 if ( $stop eq '1' ) {
1820 $signal |= 1;
1821 }
1822
1823 # It's a conditional stop; eval it in the user's context and
1824 # see if we should stop. If so, remove the one-time sigil.
1825 elsif ($stop) {
1826 $evalarg = "\$DB::signal |= 1 if do {$stop}";
e0cd3692
SF
1827 # The &-call is here to ascertain the mutability of @_.
1828 &DB::eval;
6791e41b
SF
1829 # If the breakpoint is temporary, then delete its enabled status.
1830 if ($dbline{$line} =~ s/;9($|\0)/$1/) {
1831 _cancel_breakpoint_temp_enabled_status($filename, $line);
1832 }
1833 }
1834 } ## end if ($dbline{$line} && ...
1835}
1836
8481f647
SF
1837sub _DB__is_finished {
1838 if ($finished and $level <= 1) {
1839 end_report();
1840 return 1;
1841 }
1842 else {
1843 return;
1844 }
1845}
1846
32bbadc6
SF
1847sub _DB__read_next_cmd
1848{
1849 my ($tid) = @_;
1850
1851 # We have a terminal, or can get one ...
1852 if (!$term) {
1853 setterm();
1854 }
1855
7e3426ea 1856 # ... and it belongs to this PID or we get one for this PID ...
32bbadc6
SF
1857 if ($term_pid != $$) {
1858 resetterm(1);
1859 }
1860
1861 # ... and we got a line of command input ...
1862 $cmd = DB::readline(
1863 "$pidprompt $tid DB"
1864 . ( '<' x $level )
1865 . ( $#hist + 1 )
1866 . ( '>' x $level ) . " "
1867 );
1868
1869 return defined($cmd);
1870}
1871
7013f40c 1872sub _DB__trim_command_and_return_first_component {
af84fb69
SF
1873 my ($obj) = @_;
1874
7013f40c
SF
1875 $cmd =~ s/\A\s+//s; # trim annoying leading whitespace
1876 $cmd =~ s/\s+\z//s; # trim annoying trailing whitespace
1877
7fdd4f08
S
1878 # A single-character debugger command can be immediately followed by its
1879 # argument if they aren't both alphanumeric; otherwise require space
1880 # between commands and arguments:
0e91c879 1881 my ($verb, $args) = $cmd =~ m{\A([^\.-]\b|\S*)\s*(.*)}s;
af84fb69 1882
3249b113
SF
1883 $obj->cmd_verb($verb);
1884 $obj->cmd_args($args);
af84fb69
SF
1885
1886 return;
7013f40c
SF
1887}
1888
2a802473 1889sub _DB__handle_f_command {
a30f63cd 1890 my ($obj) = @_;
2a802473 1891
a30f63cd 1892 if ($file = $obj->cmd_args) {
2a802473
SF
1893 # help for no arguments (old-style was return from sub).
1894 if ( !$file ) {
1895 print $OUT
1896 "The old f command is now the r command.\n"; # hint
1897 print $OUT "The new f command switches filenames.\n";
1898 next CMD;
1899 } ## end if (!$file)
1900
1901 # if not in magic file list, try a close match.
1902 if ( !defined $main::{ '_<' . $file } ) {
1903 if ( ($try) = grep( m#^_<.*$file#, keys %main:: ) ) {
1904 {
1905 $try = substr( $try, 2 );
1906 print $OUT "Choosing $try matching '$file':\n";
1907 $file = $try;
1908 }
1909 } ## end if (($try) = grep(m#^_<.*$file#...
1910 } ## end if (!defined $main::{ ...
1911
1912 # If not successfully switched now, we failed.
1913 if ( !defined $main::{ '_<' . $file } ) {
1914 print $OUT "No file matching '$file' is loaded.\n";
1915 next CMD;
1916 }
1917
1918 # We switched, so switch the debugger internals around.
1919 elsif ( $file ne $filename ) {
1920 *dbline = $main::{ '_<' . $file };
1921 $max = $#dbline;
1922 $filename = $file;
1923 $start = 1;
1924 $cmd = "l";
1925 } ## end elsif ($file ne $filename)
1926
1927 # We didn't switch; say we didn't.
1928 else {
1929 print $OUT "Already in $file.\n";
1930 next CMD;
1931 }
1932 }
1933
1934 return;
1935}
1936
6115a173
SF
1937sub _DB__handle_dot_command {
1938 my ($obj) = @_;
1939
1940 # . command.
601c6a23 1941 if ($obj->_is_full('.')) {
6115a173
SF
1942 $incr = -1; # stay at current line
1943
1944 # Reset everything to the old location.
1945 $start = $line;
1946 $filename = $filename_ini;
1947 *dbline = $main::{ '_<' . $filename };
1948 $max = $#dbline;
1949
1950 # Now where are we?
1951 print_lineinfo($obj->position());
1952 next CMD;
1953 }
1954
1955 return;
1956}
1957
5c2b78e7
SF
1958sub _DB__handle_y_command {
1959 my ($obj) = @_;
1960
1961 if (my ($match_level, $match_vars)
9875a6d2 1962 = $obj->cmd_args =~ /\A(?:(\d*)\s*(.*))?\z/) {
5c2b78e7
SF
1963
1964 # See if we've got the necessary support.
db79bf92
TC
1965 if (!eval {
1966 local @INC = @INC;
1967 pop @INC if $INC[-1] eq '.';
1968 require PadWalker; PadWalker->VERSION(0.08) }) {
84e7f475 1969 my $Err = $@;
b5679dc0 1970 _db_warn(
84e7f475
SF
1971 $Err =~ /locate/
1972 ? "PadWalker module not found - please install\n"
1973 : $Err
1974 );
1975 next CMD;
1976 }
5c2b78e7
SF
1977
1978 # Load up dumpvar if we don't have it. If we can, that is.
1979 do 'dumpvar.pl' || die $@ unless defined &main::dumpvar;
1980 defined &main::dumpvar
1981 or print $OUT "dumpvar.pl not available.\n"
1982 and next CMD;
1983
1984 # Got all the modules we need. Find them and print them.
1985 my @vars = split( ' ', $match_vars || '' );
1986
1987 # Find the pad.
496f5ba5 1988 my $h = eval { PadWalker::peek_my( ( $match_level || 0 ) + 2 ) };
5c2b78e7
SF
1989
1990 # Oops. Can't find it.
84e7f475
SF
1991 if (my $Err = $@) {
1992 $Err =~ s/ at .*//;
b5679dc0 1993 _db_warn($Err);
84e7f475
SF
1994 next CMD;
1995 }
5c2b78e7
SF
1996
1997 # Show the desired vars with dumplex().
1998 my $savout = select($OUT);
1999
2000 # Have dumplex dump the lexicals.
84e7f475
SF
2001 foreach my $key (sort keys %$h) {
2002 dumpvar::dumplex( $key, $h->{$key},
2003 defined $option{dumpDepth} ? $option{dumpDepth} : -1,
2004 @vars );
2005 }
5c2b78e7
SF
2006 select($savout);
2007 next CMD;
2008 }
2009}
2010
35cd713a
SF
2011sub _DB__handle_c_command {
2012 my ($obj) = @_;
2013
a523ec7c 2014 my $i = $obj->cmd_args;
35cd713a 2015
a523ec7c 2016 if ($i =~ m#\A[\w:]*\z#) {
35cd713a
SF
2017
2018 # Hey, show's over. The debugged program finished
2019 # executing already.
2020 next CMD if _DB__is_finished();
2021
2022 # Capture the place to put a one-time break.
a523ec7c 2023 $subname = $i;
35cd713a
SF
2024
2025 # Probably not needed, since we finish an interactive
2026 # sub-session anyway...
2027 # local $filename = $filename;
2028 # local *dbline = *dbline; # XXX Would this work?!
2029 #
2030 # The above question wonders if localizing the alias
2031 # to the magic array works or not. Since it's commented
2032 # out, we'll just leave that to speculation for now.
2033
2034 # If the "subname" isn't all digits, we'll assume it
2035 # is a subroutine name, and try to find it.
2036 if ( $subname =~ /\D/ ) { # subroutine name
2037 # Qualify it to the current package unless it's
2038 # already qualified.
2039 $subname = $package . "::" . $subname
2040 unless $subname =~ /::/;
2041
2042 # find_sub will return "file:line_number" corresponding
2043 # to where the subroutine is defined; we call find_sub,
2044 # break up the return value, and assign it in one
2045 # operation.
a523ec7c 2046 ( $file, $i ) = ( find_sub($subname) =~ /^(.*):(.*)$/ );
35cd713a
SF
2047
2048 # Force the line number to be numeric.
a523ec7c 2049 $i = $i + 0;
35cd713a
SF
2050
2051 # If we got a line number, we found the sub.
a523ec7c 2052 if ($i) {
35cd713a
SF
2053
2054 # Switch all the debugger's internals around so
2055 # we're actually working with that file.
2056 $filename = $file;
2057 *dbline = $main::{ '_<' . $filename };
2058
2059 # Mark that there's a breakpoint in this file.
2060 $had_breakpoints{$filename} |= 1;
2061
2062 # Scan forward to the first executable line
2063 # after the 'sub whatever' line.
2064 $max = $#dbline;
a523ec7c 2065 my $_line_num = $i;
9c6fceaf
SF
2066 while ($dbline[$_line_num] == 0 && $_line_num< $max)
2067 {
2068 $_line_num++;
2069 }
a523ec7c 2070 $i = $_line_num;
35cd713a
SF
2071 } ## end if ($i)
2072
2073 # We didn't find a sub by that name.
2074 else {
2075 print $OUT "Subroutine $subname not found.\n";
2076 next CMD;
2077 }
2078 } ## end if ($subname =~ /\D/)
2079
2080 # At this point, either the subname was all digits (an
2081 # absolute line-break request) or we've scanned through
2082 # the code following the definition of the sub, looking
2083 # for an executable, which we may or may not have found.
2084 #
2085 # If $i (which we set $subname from) is non-zero, we
2086 # got a request to break at some line somewhere. On
2087 # one hand, if there wasn't any real subroutine name
2088 # involved, this will be a request to break in the current
2089 # file at the specified line, so we have to check to make
2090 # sure that the line specified really is breakable.
2091 #
2092 # On the other hand, if there was a subname supplied, the
2093 # preceding block has moved us to the proper file and
2094 # location within that file, and then scanned forward
2095 # looking for the next executable line. We have to make
2096 # sure that one was found.
2097 #
2098 # On the gripping hand, we can't do anything unless the
2099 # current value of $i points to a valid breakable line.
2100 # Check that.
a523ec7c 2101 if ($i) {
35cd713a
SF
2102
2103 # Breakable?
a523ec7c
SF
2104 if ( $dbline[$i] == 0 ) {
2105 print $OUT "Line $i not breakable.\n";
35cd713a
SF
2106 next CMD;
2107 }
2108
2109 # Yes. Set up the one-time-break sigil.
a523ec7c
SF
2110 $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
2111 _enable_breakpoint_temp_enabled_status($filename, $i);
35cd713a
SF
2112 } ## end if ($i)
2113
2114 # Turn off stack tracing from here up.
a523ec7c
SF
2115 for my $j (0 .. $stack_depth) {
2116 $stack[ $j ] &= ~1;
35cd713a
SF
2117 }
2118 last CMD;
2119 }
2120
2121 return;
2122}
2123
a4d311a3
SF
2124sub _DB__handle_forward_slash_command {
2125 my ($obj) = @_;
2126
2127 # The pattern as a string.
2128 use vars qw($inpat);
2129
2130 if (($inpat) = $cmd =~ m#\A/(.*)\z#) {
2131
2132 # Remove the final slash.
2133 $inpat =~ s:([^\\])/$:$1:;
2134
2135 # If the pattern isn't null ...
2136 if ( $inpat ne "" ) {
2137
7e3426ea 2138 # Turn off warn and die processing for a bit.
a4d311a3
SF
2139 local $SIG{__DIE__};
2140 local $SIG{__WARN__};
2141
2142 # Create the pattern.
2143 eval 'no strict q/vars/; $inpat =~ m' . "\a$inpat\a";
2144 if ( $@ ne "" ) {
2145
2146 # Oops. Bad pattern. No biscuit.
2147 # Print the eval error and go back for more
2148 # commands.
72c017e3 2149 print {$OUT} "$@";
a4d311a3
SF
2150 next CMD;
2151 }
2152 $obj->pat($inpat);
2153 } ## end if ($inpat ne "")
2154
2155 # Set up to stop on wrap-around.
2156 $end = $start;
2157
2158 # Don't move off the current line.
2159 $incr = -1;
2160
2161 my $pat = $obj->pat;
2162
2163 # Done in eval so nothing breaks if the pattern
2164 # does something weird.
2165 eval
2166 {
2167 no strict q/vars/;
2168 for (;;) {
2169 # Move ahead one line.
2170 ++$start;
2171
2172 # Wrap if we pass the last line.
72c017e3
SF
2173 if ($start > $max) {
2174 $start = 1;
2175 }
a4d311a3
SF
2176
2177 # Stop if we have gotten back to this line again,
2178 last if ($start == $end);
2179
2180 # A hit! (Note, though, that we are doing
2181 # case-insensitive matching. Maybe a qr//
2182 # expression would be better, so the user could
2183 # do case-sensitive matching if desired.
2184 if ($dbline[$start] =~ m/$pat/i) {
2185 if ($slave_editor) {
2186 # Handle proper escaping in the slave.
72c017e3 2187 print {$OUT} "\032\032$filename:$start:0\n";
a4d311a3
SF
2188 }
2189 else {
2190 # Just print the line normally.
72c017e3 2191 print {$OUT} "$start:\t",$dbline[$start],"\n";
a4d311a3
SF
2192 }
2193 # And quit since we found something.
2194 last;
2195 }
2196 }
2197 };
2198
2199 if ($@) {
2200 warn $@;
2201 }
2202
2203 # If we wrapped, there never was a match.
2204 if ( $start == $end ) {
2205 print {$OUT} "/$pat/: not found\n";
2206 }
2207 next CMD;
2208 }
2209
2210 return;
2211}
2212
11f0f050
SF
2213sub _DB__handle_question_mark_command {
2214 my ($obj) = @_;
2215
2216 # ? - backward pattern search.
2217 if (my ($inpat) = $cmd =~ m#\A\?(.*)\z#) {
2218
2219 # Get the pattern, remove trailing question mark.
2220 $inpat =~ s:([^\\])\?$:$1:;
2221
2222 # If we've got one ...
2223 if ( $inpat ne "" ) {
2224
2225 # Turn off die & warn handlers.
2226 local $SIG{__DIE__};
2227 local $SIG{__WARN__};
2228 eval '$inpat =~ m' . "\a$inpat\a";
2229
2230 if ( $@ ne "" ) {
2231
2232 # Ouch. Not good. Print the error.
2233 print $OUT $@;
2234 next CMD;
2235 }
2236 $obj->pat($inpat);
2237 } ## end if ($inpat ne "")
2238
2239 # Where we are now is where to stop after wraparound.
2240 $end = $start;
2241
2242 # Don't move away from this line.
2243 $incr = -1;
2244
2245 my $pat = $obj->pat;
2246 # Search inside the eval to prevent pattern badness
2247 # from killing us.
2248 eval {
2249 no strict q/vars/;
2250 for (;;) {
2251 # Back up a line.
2252 --$start;
2253
2254 # Wrap if we pass the first line.
2255
2256 $start = $max if ($start <= 0);
2257
2258 # Quit if we get back where we started,
2259 last if ($start == $end);
2260
2261 # Match?
2262 if ($dbline[$start] =~ m/$pat/i) {
2263 if ($slave_editor) {
2264 # Yep, follow slave editor requirements.
2265 print $OUT "\032\032$filename:$start:0\n";
2266 }
2267 else {
2268 # Yep, just print normally.
2269 print $OUT "$start:\t",$dbline[$start],"\n";
2270 }
2271
2272 # Found, so done.
2273 last;
2274 }
2275 }
2276 };
2277
2278 # Say we failed if the loop never found anything,
2279 if ( $start == $end ) {
2280 print {$OUT} "?$pat?: not found\n";
2281 }
2282 next CMD;
2283 }
2284
2285 return;
2286}
2287
5f166812
SF
2288sub _DB__handle_restart_and_rerun_commands {
2289 my ($obj) = @_;
2290
b9920278
SF
2291 my $cmd_cmd = $obj->cmd_verb;
2292 my $cmd_params = $obj->cmd_args;
5f166812
SF
2293 # R - restart execution.
2294 # rerun - controlled restart execution.
b9920278 2295 if ($cmd_cmd eq 'rerun' or $cmd_params eq '') {
c59f1e04
SF
2296
2297 # Change directory to the initial current working directory on
2298 # the script startup, so if the debugged program changed the
2299 # directory, then we will still be able to find the path to the
a3815e44 2300 # program. (perl 5 RT #121509 ).
c59f1e04
SF
2301 chdir ($_initial_cwd);
2302
5f166812
SF
2303 my @args = ($cmd_cmd eq 'R' ? restart() : rerun($cmd_params));
2304
2305 # Close all non-system fds for a clean restart. A more
2306 # correct method would be to close all fds that were not
2307 # open when the process started, but this seems to be
2308 # hard. See "debugger 'R'estart and open database
2309 # connections" on p5p.
2310
2311 my $max_fd = 1024; # default if POSIX can't be loaded
2312 if (eval { require POSIX }) {
2313 eval { $max_fd = POSIX::sysconf(POSIX::_SC_OPEN_MAX()) };
2314 }
2315
2316 if (defined $max_fd) {
2317 foreach ($^F+1 .. $max_fd-1) {
2318 next unless open FD_TO_CLOSE, "<&=$_";
2319 close(FD_TO_CLOSE);
2320 }
2321 }
2322
2323 # And run Perl again. We use exec() to keep the
2324 # PID stable (and that way $ini_pids is still valid).
2325 exec(@args) or print {$OUT} "exec failed: $!\n";
2326
2327 last CMD;
2328 }
2329
2330 return;
2331}
2332
33f361f5
SF
2333sub _DB__handle_run_command_in_pager_command {
2334 my ($obj) = @_;
2335
2336 if ($cmd =~ m#\A\|\|?\s*[^|]#) {
2337 if ( $pager =~ /^\|/ ) {
2338
2339 # Default pager is into a pipe. Redirect I/O.
2340 open( SAVEOUT, ">&STDOUT" )
b5679dc0 2341 || _db_warn("Can't save STDOUT");
33f361f5 2342 open( STDOUT, ">&OUT" )
b5679dc0 2343 || _db_warn("Can't redirect STDOUT");
33f361f5
SF
2344 } ## end if ($pager =~ /^\|/)
2345 else {
2346
2347 # Not into a pipe. STDOUT is safe.
b5679dc0 2348 open( SAVEOUT, ">&OUT" ) || _db_warn("Can't save DB::OUT");
33f361f5
SF
2349 }
2350
2351 # Fix up environment to record we have less if so.
2352 fix_less();
2353
2354 unless ( $obj->piped(scalar ( open( OUT, $pager ) ) ) ) {
2355
2356 # Couldn't open pipe to pager.
b5679dc0 2357 _db_warn("Can't pipe output to '$pager'");
33f361f5
SF
2358 if ( $pager =~ /^\|/ ) {
2359
2360 # Redirect I/O back again.
2361 open( OUT, ">&STDOUT" ) # XXX: lost message
b5679dc0 2362 || _db_warn("Can't restore DB::OUT");
33f361f5 2363 open( STDOUT, ">&SAVEOUT" )
b5679dc0 2364 || _db_warn("Can't restore STDOUT");
33f361f5
SF
2365 close(SAVEOUT);
2366 } ## end if ($pager =~ /^\|/)
2367 else {
2368
2369 # Redirect I/O. STDOUT already safe.
2370 open( OUT, ">&STDOUT" ) # XXX: lost message
b5679dc0 2371 || _db_warn("Can't restore DB::OUT");
33f361f5
SF
2372 }
2373 next CMD;
2374 } ## end unless ($piped = open(OUT,...
2375
2376 # Set up broken-pipe handler if necessary.
2377 $SIG{PIPE} = \&DB::catch
2378 if $pager =~ /^\|/
2379 && ( "" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE} );
2380
e0047406 2381 _autoflush(\*OUT);
33f361f5
SF
2382 # Save current filehandle, and put it back.
2383 $obj->selected(scalar( select(OUT) ));
2384 # Don't put it back if pager was a pipe.
2385 if ($cmd !~ /\A\|\|/)
2386 {
2387 select($obj->selected());
2388 $obj->selected("");
2389 }
2390
2391 # Trim off the pipe symbols and run the command now.
2392 $cmd =~ s#\A\|+\s*##;
2393 redo PIPE;
2394 }
2395
2396 return;
2397}
2398
321095c5
SF
2399sub _DB__handle_m_command {
2400 my ($obj) = @_;
2401
2402 if ($cmd =~ s#\Am\s+([\w:]+)\s*\z# #) {
2403 methods($1);
2404 next CMD;
2405 }
2406
2407 # m expr - set up DB::eval to do the work
2408 if ($cmd =~ s#\Am\b# #) { # Rest gets done by DB::eval()
2409 $onetimeDump = 'methods'; # method output gets used there
2410 }
2411
2412 return;
2413}
33f361f5 2414
8e4cceb9
SF
2415sub _DB__at_end_of_every_command {
2416 my ($obj) = @_;
2417
2418 # At the end of every command:
2419 if ($obj->piped) {
2420
2421 # Unhook the pipe mechanism now.
2422 if ( $pager =~ /^\|/ ) {
2423
2424 # No error from the child.
2425 $? = 0;
2426
2427 # we cannot warn here: the handle is missing --tchrist
2428 close(OUT) || print SAVEOUT "\nCan't close DB::OUT\n";
2429
2430 # most of the $? crud was coping with broken cshisms
2431 # $? is explicitly set to 0, so this never runs.
2432 if ($?) {
2433 print SAVEOUT "Pager '$pager' failed: ";
2434 if ( $? == -1 ) {
2435 print SAVEOUT "shell returned -1\n";
2436 }
2437 elsif ( $? >> 8 ) {
2438 print SAVEOUT ( $? & 127 )
2439 ? " (SIG#" . ( $? & 127 ) . ")"
2440 : "", ( $? & 128 ) ? " -- core dumped" : "", "\n";
2441 }
2442 else {
2443 print SAVEOUT "status ", ( $? >> 8 ), "\n";
2444 }
2445 } ## end if ($?)
2446
2447 # Reopen filehandle for our output (if we can) and
2448 # restore STDOUT (if we can).
b5679dc0 2449 open( OUT, ">&STDOUT" ) || _db_warn("Can't restore DB::OUT");
8e4cceb9 2450 open( STDOUT, ">&SAVEOUT" )
b5679dc0 2451 || _db_warn("Can't restore STDOUT");
8e4cceb9
SF
2452
2453 # Turn off pipe exception handler if necessary.
2454 $SIG{PIPE} = "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
2455
2456 # Will stop ignoring SIGPIPE if done like nohup(1)
2457 # does SIGINT but Perl doesn't give us a choice.
2458 } ## end if ($pager =~ /^\|/)
2459 else {
2460
2461 # Non-piped "pager". Just restore STDOUT.
b5679dc0 2462 open( OUT, ">&SAVEOUT" ) || _db_warn("Can't restore DB::OUT");
8e4cceb9
SF
2463 }
2464
9b534162
HH
2465 # Let Readline know about the new filehandles.
2466 reset_IN_OUT( \*IN, \*OUT );
2467
8e4cceb9
SF
2468 # Close filehandle pager was using, restore the normal one
2469 # if necessary,
2470 close(SAVEOUT);
2471
2472 if ($obj->selected() ne "") {
2473 select($obj->selected);
2474 $obj->selected("");
2475 }
2476
2477 # No pipes now.
2478 $obj->piped("");
2479 } ## end if ($piped)
2480
2481 return;
2482}
2483
5f5eab52
SF
2484sub _DB__handle_watch_expressions
2485{
2486 my $self = shift;
2487
2488 if ( $DB::trace & 2 ) {
2489 for my $n (0 .. $#DB::to_watch) {
2490 $DB::evalarg = $DB::to_watch[$n];
2491 local $DB::onetimeDump; # Tell DB::eval() to not output results
2492
2493 # Fix context DB::eval() wants to return an array, but
2494 # we need a scalar here.
2495 my ($val) = join( "', '", DB::eval(@_) );
2496 $val = ( ( defined $val ) ? "'$val'" : 'undef' );
2497
2498 # Did it change?
2499 if ( $val ne $DB::old_watch[$n] ) {
2500
2501 # Yep! Show the difference, and fake an interrupt.
2502 $DB::signal = 1;
2503 print {$DB::OUT} <<EOP;
2504Watchpoint $n:\t$DB::to_watch[$n] changed:
2505 old value:\t$DB::old_watch[$n]
2506 new value:\t$val
2507EOP
2508 $DB::old_watch[$n] = $val;
2509 } ## end if ($val ne $old_watch...
2510 } ## end for my $n (0 ..
2511 } ## end if ($trace & 2)
2512
2513 return;
2514}
2515
b334474a
TC
2516=head3 C<_DB__handle_i_command> - inheritance display
2517
2518Display the (nested) parentage of the module or object given.
2519
2520=cut
2521
2522sub _DB__handle_i_command {
2523 my $self = shift;
2524
2525 my $line = $self->cmd_args;
2526 require mro;
2527 foreach my $isa ( split( /\s+/, $line ) ) {
2528 $evalarg = "$isa";
2529 # The &-call is here to ascertain the mutability of @_.
2530 ($isa) = &DB::eval;
2531 no strict 'refs';
2532 print join(
2533 ', ',
2534 map {
2535 "$_"
2536 . (
2537 defined( ${"$_\::VERSION"} )
2538 ? ' ' . ${"$_\::VERSION"}
2539 : undef )
2540 } @{mro::get_linear_isa(ref($isa) || $isa)}
2541 );
2542 print "\n";
2543 }
2544 next CMD;
2545}
2546
b7a96fc9 2547=head3 C<cmd_l> - list lines (command)
23053931 2548
b7a96fc9
TC
2549Most of the command is taken up with transforming all the different line
2550specification syntaxes into 'start-stop'. After that is done, the command
2551runs a loop over C<@dbline> for the specified range of lines. It handles
2552the printing of each line and any markers (C<==E<gt>> for current line,
2553C<b> for break on this line, C<a> for action on this line, C<:> for this
2554line breakable).
47e3b8cc 2555
b7a96fc9
TC
2556We save the last line listed in the C<$start> global for further listing
2557later.
2b0b9dd1 2558
b7a96fc9 2559=cut
2b0b9dd1 2560
b7a96fc9
TC
2561sub _min {
2562 my $min = shift;
2563 foreach my $v (@_) {
2564 if ($min > $v) {
2565 $min = $v;
2566 }
2b0b9dd1 2567 }
b7a96fc9
TC
2568 return $min;
2569}
2b0b9dd1 2570
b7a96fc9
TC
2571sub _max {
2572 my $max = shift;
2573 foreach my $v (@_) {
2574 if ($max < $v) {
2575 $max = $v;
2576 }
2577 }
2578 return $max;
2579}
35cd713a 2580
b7a96fc9
TC
2581sub _minify_to_max {
2582 my $ref = shift;
22fc883d 2583
b7a96fc9 2584 $$ref = _min($$ref, $max);
2b0b9dd1 2585
b7a96fc9
TC
2586 return;
2587}
69893cff 2588
b7a96fc9
TC
2589sub _cmd_l_handle_var_name {
2590 my $var_name = shift;
69893cff 2591
b7a96fc9 2592 $evalarg = $var_name;
69893cff 2593
b7a96fc9 2594 my ($s) = DB::eval();
aa057b67 2595
b7a96fc9
TC
2596 # Ooops. Bad scalar.
2597 if ($@) {
2598 print {$OUT} "Error: $@\n";
2599 next CMD;
2600 }
69893cff 2601
b7a96fc9
TC
2602 # Good scalar. If it's a reference, find what it points to.
2603 $s = CvGV_name($s);
2604 print {$OUT} "Interpreted as: $1 $s\n";
2605 $line = "$1 $s";
69893cff 2606
b7a96fc9
TC
2607 # Call self recursively to really do the command.
2608 return _cmd_l_main( $s );
2609}
69893cff 2610
b7a96fc9 2611sub _cmd_l_handle_subname {
69893cff 2612
b7a96fc9 2613 my $s = $subname;
69893cff 2614
b7a96fc9
TC
2615 # De-Perl4.
2616 $subname =~ s/\'/::/;
69893cff 2617
b7a96fc9
TC
2618 # Put it in this package unless it starts with ::.
2619 $subname = $package . "::" . $subname unless $subname =~ /::/;
69893cff 2620
b7a96fc9
TC
2621 # Put it in CORE::GLOBAL if t doesn't start with :: and
2622 # it doesn't live in this package and it lives in CORE::GLOBAL.
2623 $subname = "CORE::GLOBAL::$s"
2624 if not defined &$subname
2625 and $s !~ /::/
2626 and defined &{"CORE::GLOBAL::$s"};
69893cff 2627
b7a96fc9
TC
2628 # Put leading '::' names into 'main::'.
2629 $subname = "main" . $subname if substr( $subname, 0, 2 ) eq "::";
69893cff 2630
b7a96fc9
TC
2631 # Get name:start-stop from find_sub, and break this up at
2632 # colons.
2633 my @pieces = split( /:/, find_sub($subname) || $sub{$subname} );
be9a9b1d 2634
b7a96fc9
TC
2635 # Pull off start-stop.
2636 my $subrange = pop @pieces;
be9a9b1d 2637
b7a96fc9
TC
2638 # If the name contained colons, the split broke it up.
2639 # Put it back together.
2640 $file = join( ':', @pieces );
be9a9b1d 2641
b7a96fc9
TC
2642 # If we're not in that file, switch over to it.
2643 if ( $file ne $filename ) {
2644 if (! $slave_editor) {
2645 print {$OUT} "Switching to file '$file'.\n";
2646 }
be9a9b1d 2647
b7a96fc9
TC
2648 # Switch debugger's magic structures.
2649 *dbline = $main::{ '_<' . $file };
2650 $max = $#dbline;
2651 $filename = $file;
2652 } ## end if ($file ne $filename)
69893cff 2653
b7a96fc9
TC
2654 # Subrange is 'start-stop'. If this is less than a window full,
2655 # swap it to 'start+', which will list a window from the start point.
2656 if ($subrange) {
2657 if ( eval($subrange) < -$window ) {
2658 $subrange =~ s/-.*/+/;
2659 }
69893cff 2660
b7a96fc9
TC
2661 # Call self recursively to list the range.
2662 return _cmd_l_main( $subrange );
2663 } ## end if ($subrange)
69893cff 2664
b7a96fc9
TC
2665 # Couldn't find it.
2666 else {
2667 print {$OUT} "Subroutine $subname not found.\n";
2668 return;
2669 }
2670}
69893cff 2671
b7a96fc9
TC
2672sub _cmd_l_empty {
2673 # Compute new range to list.
2674 $incr = $window - 1;
69893cff 2675
b7a96fc9
TC
2676 # Recurse to do it.
2677 return _cmd_l_main( $start . '-' . ( $start + $incr ) );
2678}
69893cff 2679
b7a96fc9
TC
2680sub _cmd_l_plus {
2681 my ($new_start, $new_incr) = @_;
69893cff 2682
b7a96fc9
TC
2683 # Don't reset start for 'l +nnn'.
2684 $start = $new_start if $new_start;
69893cff 2685
b7a96fc9
TC
2686 # Increment for list. Use window size if not specified.
2687 # (Allows 'l +' to work.)
2688 $incr = $new_incr || ($window - 1);
69893cff 2689
b7a96fc9
TC
2690 # Create a line range we'll understand, and recurse to do it.
2691 return _cmd_l_main( $start . '-' . ( $start + $incr ) );
2692}
69893cff 2693
b7a96fc9
TC
2694sub _cmd_l_calc_initial_end_and_i {
2695 my ($spec, $start_match, $end_match) = @_;
69893cff 2696
b7a96fc9
TC
2697 # Determine end point; use end of file if not specified.
2698 my $end = ( !defined $start_match ) ? $max :
2699 ( $end_match ? $end_match : $start_match );
69893cff 2700
b7a96fc9
TC
2701 # Go on to the end, and then stop.
2702 _minify_to_max(\$end);
e219e2fb 2703
b7a96fc9
TC
2704 # Determine start line.
2705 my $i = $start_match;
e219e2fb 2706
b7a96fc9
TC
2707 if ($i eq '.') {
2708 $i = $spec;
05da04df 2709 }
69893cff 2710
b7a96fc9 2711 $i = _max($i, 1);
69893cff 2712
b7a96fc9 2713 $incr = $end - $i;
6b24a4b7 2714
b7a96fc9
TC
2715 return ($end, $i);
2716}
e22ea7cc 2717
b7a96fc9
TC
2718sub _cmd_l_range {
2719 my ($spec, $current_line, $start_match, $end_match) = @_;
69893cff 2720
b7a96fc9
TC
2721 my ($end, $i) =
2722 _cmd_l_calc_initial_end_and_i($spec, $start_match, $end_match);
69893cff 2723
b7a96fc9
TC
2724 # If we're running under a slave editor, force it to show the lines.
2725 if ($slave_editor) {
2726 print {$OUT} "\032\032$filename:$i:0\n";
2727 $i = $end;
2728 }
2729 # We're doing it ourselves. We want to show the line and special
2730 # markers for:
2731 # - the current line in execution
2732 # - whether a line is breakable or not
2733 # - whether a line has a break or not
2734 # - whether a line has an action or not
2735 else {
2736 I_TO_END:
2737 for ( ; $i <= $end ; $i++ ) {
69893cff 2738
b7a96fc9
TC
2739 # Check for breakpoints and actions.
2740 my ( $stop, $action );
2741 if ($dbline{$i}) {
2742 ( $stop, $action ) = split( /\0/, $dbline{$i} );
3d7a2a93 2743 }
69893cff 2744
b7a96fc9
TC
2745 # ==> if this is the current line in execution,
2746 # : if it's breakable.
2747 my $arrow =
2748 ( $i == $current_line and $filename eq $filename_ini )
2749 ? '==>'
2750 : ( $dbline[$i] + 0 ? ':' : ' ' );
69893cff 2751
b7a96fc9
TC
2752 # Add break and action indicators.
2753 $arrow .= 'b' if $stop;
2754 $arrow .= 'a' if $action;
69893cff 2755
b7a96fc9
TC
2756 # Print the line.
2757 print {$OUT} "$i$arrow\t", $dbline[$i];
69893cff 2758
b7a96fc9
TC
2759 # Move on to the next line. Drop out on an interrupt.
2760 if ($signal) {
2761 $i++;
2762 last I_TO_END;
eeb7da96 2763 }
b7a96fc9 2764 } ## end for (; $i <= $end ; $i++)
69893cff 2765
b7a96fc9
TC
2766 # Line the prompt up; print a newline if the last line listed
2767 # didn't have a newline.
2768 if ($dbline[ $i - 1 ] !~ /\n\z/) {
2769 print {$OUT} "\n";
2770 }
2771 } ## end else [ if ($slave_editor)
69893cff 2772
b7a96fc9
TC
2773 # Save the point we last listed to in case another relative 'l'
2774 # command is desired. Don't let it run off the end.
2775 $start = $i;
2776 _minify_to_max(\$start);
69893cff 2777
b7a96fc9
TC
2778 return;
2779}
69893cff 2780
b7a96fc9
TC
2781sub _cmd_l_main {
2782 my $spec = shift;
69893cff 2783
b7a96fc9
TC
2784 # If this is '-something', delete any spaces after the dash.
2785 $spec =~ s/\A-\s*\z/-/;
69893cff 2786
b7a96fc9
TC
2787 # If the line is '$something', assume this is a scalar containing a
2788 # line number.
2789 # Set up for DB::eval() - evaluate in *user* context.
2790 if ( my ($var_name) = $spec =~ /\A(\$.*)/s ) {
2791 return _cmd_l_handle_var_name($var_name);
2792 }
2793 # l name. Try to find a sub by that name.
2794 elsif ( ($subname) = $spec =~ /\A([\':A-Za-z_][\':\w]*(?:\[.*\])?)/s ) {
2795 return _cmd_l_handle_subname();
2796 }
2797 # Bare 'l' command.
2798 elsif ( $spec !~ /\S/ ) {
2799 return _cmd_l_empty();
2800 }
2801 # l [start]+number_of_lines
2802 elsif ( my ($new_start, $new_incr) = $spec =~ /\A(\d*)\+(\d*)\z/ ) {
2803 return _cmd_l_plus($new_start, $new_incr);
2804 }
2805 # l start-stop or l start,stop
2806 elsif (my ($s, $e) = $spec =~ /^(?:(-?[\d\$\.]+)(?:[-,]([\d\$\.]+))?)?/ ) {
2807 return _cmd_l_range($spec, $line, $s, $e);
2808 }
69893cff 2809
b7a96fc9
TC
2810 return;
2811} ## end sub cmd_l
69893cff 2812
b7a96fc9
TC
2813sub _DB__handle_l_command {
2814 my $self = shift;
69893cff 2815
b7a96fc9
TC
2816 _cmd_l_main($self->cmd_args);
2817 next CMD;
2818}
69893cff 2819
69893cff 2820
b7a96fc9
TC
2821# 't' is type.
2822# 'm' is method.
2823# 'v' is the value (i.e: method name or subroutine ref).
2824# 's' is subroutine.
2825my %cmd_lookup;
69893cff 2826
b7a96fc9
TC
2827BEGIN
2828{
2829 %cmd_lookup =
2830(
2831 '-' => { t => 'm', v => '_handle_dash_command', },
2832 '.' => { t => 's', v => \&_DB__handle_dot_command, },
2833 '=' => { t => 'm', v => '_handle_equal_sign_command', },
2834 'H' => { t => 'm', v => '_handle_H_command', },
2835 'S' => { t => 'm', v => '_handle_S_command', },
2836 'T' => { t => 'm', v => '_handle_T_command', },
2837 'W' => { t => 'm', v => '_handle_W_command', },
2838 'c' => { t => 's', v => \&_DB__handle_c_command, },
2839 'f' => { t => 's', v => \&_DB__handle_f_command, },
2840 'i' => { t => 's', v => \&_DB__handle_i_command, },
2841 'l' => { t => 's', v => \&_DB__handle_l_command, },
2842 'm' => { t => 's', v => \&_DB__handle_m_command, },
2843 'n' => { t => 'm', v => '_handle_n_command', },
2844 'p' => { t => 'm', v => '_handle_p_command', },
2845 'q' => { t => 'm', v => '_handle_q_command', },
2846 'r' => { t => 'm', v => '_handle_r_command', },
2847 's' => { t => 'm', v => '_handle_s_command', },
2848 'save' => { t => 'm', v => '_handle_save_command', },
2849 'source' => { t => 'm', v => '_handle_source_command', },
2850 't' => { t => 'm', v => '_handle_t_command', },
2851 'w' => { t => 'm', v => '_handle_w_command', },
2852 'x' => { t => 'm', v => '_handle_x_command', },
2853 'y' => { t => 's', v => \&_DB__handle_y_command, },
2854 (map { $_ => { t => 'm', v => '_handle_V_command_and_X_command', }, }
2855 ('X', 'V')),
2856 (map { $_ => { t => 'm', v => '_handle_enable_disable_commands', }, }
2857 qw(enable disable)),
2858 (map { $_ =>
2859 { t => 's', v => \&_DB__handle_restart_and_rerun_commands, },
2860 } qw(R rerun)),
2861 (map { $_ => {t => 'm', v => '_handle_cmd_wrapper_commands' }, }
2862 qw(a A b B e E h L M o O v w W)),
2863);
2864};
69893cff 2865
b7a96fc9 2866sub DB {
69893cff 2867
b7a96fc9
TC
2868 # lock the debugger and get the thread id for the prompt
2869 lock($DBGR);
2870 my $tid;
2871 my $position;
2872 my ($prefix, $after, $infix);
2873 my $pat;
2874 my $explicit_stop;
2875 my $piped;
2876 my $selected;
69893cff 2877
b7a96fc9
TC
2878 if ($ENV{PERL5DB_THREADED}) {
2879 $tid = eval { "[".threads->tid."]" };
2880 }
69893cff 2881
b7a96fc9
TC
2882 my $cmd_verb;
2883 my $cmd_args;
69893cff 2884
b7a96fc9
TC
2885 my $obj = DB::Obj->new(
2886 {
2887 position => \$position,
2888 prefix => \$prefix,
2889 after => \$after,
2890 explicit_stop => \$explicit_stop,
2891 infix => \$infix,
2892 cmd_args => \$cmd_args,
2893 cmd_verb => \$cmd_verb,
2894 pat => \$pat,
2895 piped => \$piped,
2896 selected => \$selected,
2897 },
2898 );
69893cff 2899
b7a96fc9 2900 $obj->_DB_on_init__initialize_globals(@_);
69893cff 2901
b7a96fc9
TC
2902 # Preserve current values of $@, $!, $^E, $,, $/, $\, $^W.
2903 # The code being debugged may have altered them.
2904 DB::save();
69893cff 2905
b7a96fc9
TC
2906 # Since DB::DB gets called after every line, we can use caller() to
2907 # figure out where we last were executing. Sneaky, eh? This works because
2908 # caller is returning all the extra information when called from the
2909 # debugger.
2910 local ( $package, $filename, $line ) = caller;
2911 $filename_ini = $filename;
69893cff 2912
b7a96fc9
TC
2913 # set up the context for DB::eval, so it can properly execute
2914 # code on behalf of the user. We add the package in so that the
2915 # code is eval'ed in the proper package (not in the debugger!).
2916 local $usercontext = _calc_usercontext($package);
69893cff 2917
b7a96fc9
TC
2918 # Create an alias to the active file magical array to simplify
2919 # the code here.
2920 local (*dbline) = $main::{ '_<' . $filename };
69893cff 2921
b7a96fc9
TC
2922 # Last line in the program.
2923 $max = $#dbline;
69893cff 2924
b7a96fc9
TC
2925 # The &-call is here to ascertain the mutability of @_.
2926 &_DB__determine_if_we_should_break;
69893cff 2927
b7a96fc9
TC
2928 # Preserve the current stop-or-not, and see if any of the W
2929 # (watch expressions) has changed.
2930 my $was_signal = $signal;
69893cff 2931
b7a96fc9
TC
2932 # If we have any watch expressions ...
2933 _DB__handle_watch_expressions($obj);
69893cff 2934
b7a96fc9 2935=head2 C<watchfunction()>
69893cff 2936
b7a96fc9
TC
2937C<watchfunction()> is a function that can be defined by the user; it is a
2938function which will be run on each entry to C<DB::DB>; it gets the
2939current package, filename, and line as its parameters.
69893cff 2940
b7a96fc9
TC
2941The watchfunction can do anything it likes; it is executing in the
2942debugger's context, so it has access to all of the debugger's internal
2943data structures and functions.
69893cff 2944
b7a96fc9
TC
2945C<watchfunction()> can control the debugger's actions. Any of the following
2946will cause the debugger to return control to the user's program after
2947C<watchfunction()> executes:
69893cff 2948
b7a96fc9 2949=over 4
69893cff 2950
b7a96fc9 2951=item *
69893cff 2952
b7a96fc9 2953Returning a false value from the C<watchfunction()> itself.
69893cff 2954
b7a96fc9 2955=item *
69893cff 2956
b7a96fc9 2957Altering C<$single> to a false value.
69893cff 2958
b7a96fc9 2959=item *
69893cff 2960
b7a96fc9 2961Altering C<$signal> to a false value.
69893cff 2962
b7a96fc9 2963=item *
69893cff 2964
b7a96fc9
TC
2965Turning off the C<4> bit in C<$trace> (this also disables the
2966check for C<watchfunction()>. This can be done with
69893cff 2967
b7a96fc9 2968 $trace &= ~4;
69893cff 2969
b7a96fc9 2970=back
69893cff
RGS
2971
2972=cut
2973
b7a96fc9
TC
2974 # If there's a user-defined DB::watchfunction, call it with the
2975 # current package, filename, and line. The function executes in
2976 # the DB:: package.
2977 if ( $trace & 4 ) { # User-installed watch
2978 return
2979 if watchfunction( $package, $filename, $line )
2980 and not $single
2981 and not $was_signal
2982 and not( $trace & ~4 );
2983 } ## end if ($trace & 4)
69893cff 2984
b7a96fc9
TC
2985 # Pick up any alteration to $signal in the watchfunction, and
2986 # turn off the signal now.
2987 $was_signal = $signal;
2988 $signal = 0;
69893cff 2989
b7a96fc9 2990=head2 GETTING READY TO EXECUTE COMMANDS
69893cff 2991
b7a96fc9
TC
2992The debugger decides to take control if single-step mode is on, the
2993C<t> command was entered, or the user generated a signal. If the program
2994has fallen off the end, we set things up so that entering further commands
2995won't cause trouble, and we say that the program is over.
69893cff
RGS
2996
2997=cut
2998
b7a96fc9
TC
2999 # Make sure that we always print if asked for explicitly regardless
3000 # of $trace_to_depth .
3001 $explicit_stop = ($single || $was_signal);
69893cff 3002
b7a96fc9
TC
3003 # Check to see if we should grab control ($single true,
3004 # trace set appropriately, or we got a signal).
3005 if ( $explicit_stop || ( $trace & 1 ) ) {
3006 $obj->_DB__grab_control(@_);
3007 } ## end if ($single || ($trace...
69893cff 3008
b7a96fc9 3009=pod
69893cff 3010
b7a96fc9
TC
3011If there's an action to be executed for the line we stopped at, execute it.
3012If there are any preprompt actions, execute those as well.
69893cff 3013
b7a96fc9 3014=cut
69893cff 3015
b7a96fc9
TC
3016 # If there's an action, do it now.
3017 if ($action) {
3018 $evalarg = $action;
3019 # The &-call is here to ascertain the mutability of @_.
3020 &DB::eval;
3021 }
3022 undef $action;
69893cff 3023
b7a96fc9
TC
3024 # Are we nested another level (e.g., did we evaluate a function
3025 # that had a breakpoint in it at the debugger prompt)?
3026 if ( $single || $was_signal ) {
69893cff 3027
b7a96fc9
TC
3028 # Yes, go down a level.
3029 local $level = $level + 1;
69893cff 3030
b7a96fc9
TC
3031 # Do any pre-prompt actions.
3032 foreach $evalarg (@$pre) {
3033 # The &-call is here to ascertain the mutability of @_.
3034 &DB::eval;
3035 }
69893cff 3036
b7a96fc9
TC
3037 # Complain about too much recursion if we passed the limit.
3038 if ($single & 4) {
3039 print $OUT $stack_depth . " levels deep in subroutine calls!\n";
3040 }
69893cff 3041
b7a96fc9
TC
3042 # The line we're currently on. Set $incr to -1 to stay here
3043 # until we get a command that tells us to advance.
3044 $start = $line;
3045 $incr = -1; # for backward motion.
69893cff 3046
b7a96fc9
TC
3047 # Tack preprompt debugger actions ahead of any actual input.
3048 @typeahead = ( @$pretype, @typeahead );
69893cff 3049
b7a96fc9 3050=head2 WHERE ARE WE?
69893cff 3051
b7a96fc9 3052XXX Relocate this section?
69893cff 3053
b7a96fc9
TC
3054The debugger normally shows the line corresponding to the current line of
3055execution. Sometimes, though, we want to see the next line, or to move elsewhere
3056in the file. This is done via the C<$incr>, C<$start>, and C<$max> variables.
e09195af 3057
b7a96fc9
TC
3058C<$incr> controls by how many lines the I<current> line should move forward
3059after a command is executed. If set to -1, this indicates that the I<current>
3060line shouldn't change.
e09195af 3061
b7a96fc9
TC
3062C<$start> is the I<current> line. It is used for things like knowing where to
3063move forwards or backwards from when doing an C<L> or C<-> command.
69893cff 3064
b7a96fc9
TC
3065C<$max> tells the debugger where the last line of the current file is. It's
3066used to terminate loops most often.
69893cff 3067
b7a96fc9 3068=head2 THE COMMAND LOOP
69893cff 3069
b7a96fc9
TC
3070Most of C<DB::DB> is actually a command parsing and dispatch loop. It comes
3071in two parts:
7fddc82f 3072
b7a96fc9 3073=over 4
7fddc82f 3074
b7a96fc9 3075=item *
7fddc82f 3076
b7a96fc9
TC
3077The outer part of the loop, starting at the C<CMD> label. This loop
3078reads a command and then executes it.
7fddc82f 3079
b7a96fc9 3080=item *
69893cff 3081
b7a96fc9
TC
3082The inner part of the loop, starting at the C<PIPE> label. This part
3083is wholly contained inside the C<CMD> block and only executes a command.
3084Used to handle commands running inside a pager.
69893cff 3085
b7a96fc9
TC
3086=back
3087
3088So why have two labels to restart the loop? Because sometimes, it's easier to
3089have a command I<generate> another command and then re-execute the loop to do
3090the new command. This is faster, but perhaps a bit more convoluted.
69893cff
RGS
3091
3092=cut
3093
b7a96fc9
TC
3094 # The big command dispatch loop. It keeps running until the
3095 # user yields up control again.
3096 #
3097 # If we have a terminal for input, and we get something back
3098 # from readline(), keep on processing.
69893cff 3099
b7a96fc9
TC
3100 CMD:
3101 while (_DB__read_next_cmd($tid))
3102 {
69893cff 3103
b7a96fc9
TC
3104 share($cmd);
3105 # ... try to execute the input as debugger commands.
69893cff 3106
b7a96fc9
TC
3107 # Don't stop running.
3108 $single = 0;
69893cff 3109
b7a96fc9
TC
3110 # No signal is active.
3111 $signal = 0;
69893cff 3112
b7a96fc9
TC
3113 # Handle continued commands (ending with \):
3114 if ($cmd =~ s/\\\z/\n/) {
3115 $cmd .= DB::readline(" cont: ");
3116 redo CMD;
3117 }
e2b8b3e7 3118
b7a96fc9 3119=head4 The null command
69893cff 3120
b7a96fc9
TC
3121A newline entered by itself means I<re-execute the last command>. We grab the
3122command out of C<$laststep> (where it was recorded previously), and copy it
3123back into C<$cmd> to be executed below. If there wasn't any previous command,
3124we'll do nothing below (no command will match). If there was, we also save it
3125in the command history and fall through to allow the command parsing to pick
3126it up.
69893cff 3127
b7a96fc9 3128=cut
e22ea7cc 3129
b7a96fc9
TC
3130 # Empty input means repeat the last command.
3131 if ($cmd eq '') {
3132 $cmd = $laststep;
e22ea7cc 3133 }
b7a96fc9
TC
3134 chomp($cmd); # get rid of the annoying extra newline
3135 if (length($cmd) >= option_val('HistItemMinLength', 2)) {
3136 push( @hist, $cmd );
3137 }
3138 push( @truehist, $cmd );
3139 share(@hist);
3140 share(@truehist);
69893cff 3141
b7a96fc9
TC
3142 # This is a restart point for commands that didn't arrive
3143 # via direct user input. It allows us to 'redo PIPE' to
3144 # re-execute command processing without reading a new command.
3145 PIPE: {
3146 _DB__trim_command_and_return_first_component($obj);
69893cff 3147
b7a96fc9
TC
3148=head3 COMMAND ALIASES
3149
3150The debugger can create aliases for commands (these are stored in the
3151C<%alias> hash). Before a command is executed, the command loop looks it up
3152in the alias hash and substitutes the contents of the alias for the command,
3153completely replacing it.
69893cff
RGS
3154
3155=cut
3156
b7a96fc9
TC
3157 # See if there's an alias for the command, and set it up if so.
3158 if ( $alias{$cmd_verb} ) {
69893cff 3159
b7a96fc9
TC
3160 # Squelch signal handling; we want to keep control here
3161 # if something goes loco during the alias eval.
3162 local $SIG{__DIE__};
3163 local $SIG{__WARN__};
69893cff 3164
b7a96fc9
TC
3165 # This is a command, so we eval it in the DEBUGGER's
3166 # scope! Otherwise, we can't see the special debugger
3167 # variables, or get to the debugger's subs. (Well, we
3168 # _could_, but why make it even more complicated?)
3169 eval "\$cmd =~ $alias{$cmd_verb}";
3170 if ($@) {
3171 local $\ = '';
3172 print $OUT "Couldn't evaluate '$cmd_verb' alias: $@";
3173 next CMD;
3174 }
3175 _DB__trim_command_and_return_first_component($obj);
3176 } ## end if ($alias{$cmd_verb})
69893cff 3177
b7a96fc9 3178=head3 MAIN-LINE COMMANDS
69893cff 3179
b7a96fc9
TC
3180All of these commands work up to and after the program being debugged has
3181terminated.
69893cff 3182
b7a96fc9 3183=head4 C<q> - quit
69893cff 3184
b7a96fc9
TC
3185Quit the debugger. This entails setting the C<$fall_off_end> flag, so we don't
3186try to execute further, cleaning any restart-related stuff out of the
3187environment, and executing with the last value of C<$?>.
69893cff 3188
b7a96fc9 3189=cut
90fd4c80 3190
b7a96fc9
TC
3191 # All of these commands were remapped in perl 5.8.0;
3192 # we send them off to the secondary dispatcher (see below).
3193 $obj->_handle_special_char_cmd_wrapper_commands;
3194 _DB__trim_command_and_return_first_component($obj);
22fc883d 3195
b7a96fc9
TC
3196 if (my $cmd_rec = $cmd_lookup{$cmd_verb}) {
3197 my $type = $cmd_rec->{t};
3198 my $val = $cmd_rec->{v};
3199 if ($type eq 'm') {
3200 $obj->$val();
3201 }
3202 elsif ($type eq 's') {
3203 $val->($obj);
3204 }
3205 }
22fc883d 3206
b7a96fc9 3207=head4 C<t> - trace [n]
22fc883d 3208
b7a96fc9
TC
3209Turn tracing on or off. Inverts the appropriate bit in C<$trace> (q.v.).
3210If level is specified, set C<$trace_to_depth>.
22fc883d 3211
b7a96fc9 3212=head4 C<S> - list subroutines matching/not matching a pattern
22fc883d 3213
b7a96fc9 3214Walks through C<%sub>, checking to see whether or not to print the name.
22fc883d 3215
b7a96fc9 3216=head4 C<X> - list variables in current package
22fc883d 3217
b7a96fc9
TC
3218Since the C<V> command actually processes this, just change this to the
3219appropriate C<V> command and fall through.
22fc883d 3220
b7a96fc9 3221=head4 C<V> - list variables
22fc883d 3222
b7a96fc9 3223Uses C<dumpvar.pl> to dump out the current values for selected variables.
22fc883d 3224
b7a96fc9 3225=head4 C<x> - evaluate and print an expression
8def6eff 3226
b7a96fc9
TC
3227Hands the expression off to C<DB::eval>, setting it up to print the value
3228via C<dumpvar.pl> instead of just printing it directly.
8def6eff 3229
b7a96fc9 3230=head4 C<m> - print methods
22fc883d 3231
b7a96fc9 3232Just uses C<DB::methods> to determine what methods are available.
22fc883d 3233
b7a96fc9 3234=head4 C<f> - switch files
22fc883d 3235
b7a96fc9 3236Switch to a different filename.
22fc883d 3237
b7a96fc9 3238=head4 C<.> - return to last-executed line.
22fc883d 3239
b7a96fc9
TC
3240We set C<$incr> to -1 to indicate that the debugger shouldn't move ahead,
3241and then we look up the line in the magical C<%dbline> hash.
22fc883d 3242
b7a96fc9 3243=head4 C<-> - back one window
22fc883d 3244
b7a96fc9
TC
3245We change C<$start> to be one window back; if we go back past the first line,
3246we set it to be the first line. We set C<$incr> to put us back at the
3247currently-executing line, and then put a C<l $start +> (list one window from
3248C<$start>) in C<$cmd> to be executed later.
3249
3250=head3 PRE-580 COMMANDS VS. NEW COMMANDS: C<a, A, b, B, h, l, L, M, o, O, P, v, w, W, E<lt>, E<lt>E<lt>, E<0x7B>, E<0x7B>E<0x7B>>
3251
3252In Perl 5.8.0, a realignment of the commands was done to fix up a number of
3253problems, most notably that the default case of several commands destroying
3254the user's work in setting watchpoints, actions, etc. We wanted, however, to
3255retain the old commands for those who were used to using them or who preferred
3256them. At this point, we check for the new commands and call C<cmd_wrapper> to
3257deal with them instead of processing them in-line.
22fc883d 3258
b7a96fc9 3259=head4 C<y> - List lexicals in higher scope
22fc883d 3260
b7a96fc9
TC
3261Uses C<PadWalker> to find the lexicals supplied as arguments in a scope
3262above the current one and then displays then using C<dumpvar.pl>.
22fc883d 3263
b7a96fc9 3264=head3 COMMANDS NOT WORKING AFTER PROGRAM ENDS
ad46ac70 3265
b7a96fc9
TC
3266All of the commands below this point don't work after the program being
3267debugged has ended. All of them check to see if the program has ended; this
3268allows the commands to be relocated without worrying about a 'line of
3269demarcation' above which commands can be entered anytime, and below which
3270they can't.
ad46ac70 3271
b7a96fc9 3272=head4 C<n> - single step, but don't trace down into subs
44a07e3e 3273
b7a96fc9
TC
3274Done by setting C<$single> to 2, which forces subs to execute straight through
3275when entered (see C<DB::sub>). We also save the C<n> command in C<$laststep>,
3276so a null command knows what to re-execute.
601c6a23 3277
b7a96fc9 3278=head4 C<s> - single-step, entering subs
601c6a23 3279
b7a96fc9
TC
3280Sets C<$single> to 1, which causes C<DB::sub> to continue tracing inside
3281subs. Also saves C<s> as C<$lastcmd>.
22fc883d 3282
b7a96fc9 3283=head4 C<c> - run continuously, setting an optional breakpoint
22fc883d 3284
b7a96fc9
TC
3285Most of the code for this command is taken up with locating the optional
3286breakpoint, which is either a subroutine name or a line number. We set
3287the appropriate one-time-break in C<@dbline> and then turn off single-stepping
3288in this and all call levels above this one.
22fc883d 3289
b7a96fc9 3290=head4 C<r> - return from a subroutine
22fc883d 3291
b7a96fc9
TC
3292For C<r> to work properly, the debugger has to stop execution again
3293immediately after the return is executed. This is done by forcing
3294single-stepping to be on in the call level above the current one. If
3295we are printing return values when a C<r> is executed, set C<$doret>
3296appropriately, and force us out of the command loop.
22fc883d 3297
b7a96fc9 3298=head4 C<T> - stack trace
22fc883d 3299
b7a96fc9 3300Just calls C<DB::print_trace>.
22fc883d 3301
b7a96fc9 3302=head4 C<w> - List window around current line.
22fc883d 3303
b7a96fc9 3304Just calls C<DB::cmd_w>.
22fc883d 3305
b7a96fc9 3306=head4 C<W> - watch-expression processing.
22fc883d 3307
b7a96fc9 3308Just calls C<DB::cmd_W>.
22fc883d 3309
b7a96fc9
TC
3310=head4 C</> - search forward for a string in the source
3311
3312We take the argument and treat it as a pattern. If it turns out to be a
3313bad one, we return the error we got from trying to C<eval> it and exit.
3314If not, we create some code to do the search and C<eval> it so it can't
3315mess us up.
22fc883d
SF
3316
3317=cut
3318
b7a96fc9 3319 _DB__handle_forward_slash_command($obj);
22fc883d 3320
b7a96fc9 3321=head4 C<?> - search backward for a string in the source
22fc883d 3322
b7a96fc9 3323Same as for C</>, except the loop runs backwards.
22fc883d 3324
b7a96fc9 3325=cut
22fc883d 3326
b7a96fc9 3327 _DB__handle_question_mark_command($obj);
22fc883d 3328
b7a96fc9 3329=head4 C<$rc> - Recall command
22fc883d 3330
b7a96fc9
TC
3331Manages the commands in C<@hist> (which is created if C<Term::ReadLine> reports
3332that the terminal supports history). It finds the command required, puts it
3333into C<$cmd>, and redoes the loop to execute it.
44a07e3e 3334
b7a96fc9 3335=cut
22fc883d 3336
b7a96fc9
TC
3337 # $rc - recall command.
3338 $obj->_handle_rc_recall_command;
22fc883d 3339
b7a96fc9 3340=head4 C<$sh$sh> - C<system()> command
22fc883d 3341
b7a96fc9
TC
3342Calls the C<_db_system()> to handle the command. This keeps the C<STDIN> and
3343C<STDOUT> from getting messed up.
22fc883d 3344
b7a96fc9 3345=cut
22fc883d 3346
b7a96fc9 3347 $obj->_handle_sh_command;
22fc883d 3348
b7a96fc9 3349=head4 C<$rc I<pattern> $rc> - Search command history
9875a6d2 3350
b7a96fc9
TC
3351Another command to manipulate C<@hist>: this one searches it with a pattern.
3352If a command is found, it is placed in C<$cmd> and executed via C<redo>.
9875a6d2 3353
b7a96fc9 3354=cut
174f9c5e 3355
b7a96fc9 3356 $obj->_handle_rc_search_history_command;
174f9c5e 3357
b7a96fc9 3358=head4 C<$sh> - Invoke a shell
9d0b71b3 3359
b7a96fc9 3360Uses C<_db_system()> to invoke a shell.
3249b113 3361
b7a96fc9 3362=cut
9d0b71b3 3363
b7a96fc9 3364=head4 C<$sh I<command>> - Force execution of a command in a shell
9d0b71b3 3365
b7a96fc9
TC
3366Like the above, but the command is passed to the shell. Again, we use
3367C<_db_system()> to avoid problems with C<STDIN> and C<STDOUT>.
9d0b71b3 3368
b7a96fc9 3369=head4 C<H> - display commands in history
9d0b71b3 3370
b7a96fc9 3371Prints the contents of C<@hist> (if any).
1ce985d2 3372
b7a96fc9 3373=head4 C<man, doc, perldoc> - look up documentation
1ce985d2 3374
b7a96fc9 3375Just calls C<runman()> to print the appropriate document.
1ce985d2 3376
b7a96fc9 3377=cut
1ce985d2 3378
b7a96fc9 3379 $obj->_handle_doc_command;
1ce985d2 3380
b7a96fc9 3381=head4 C<p> - print
1ce985d2 3382
b7a96fc9
TC
3383Builds a C<print EXPR> expression in the C<$cmd>; this will get executed at
3384the bottom of the loop.
1ce985d2 3385
b7a96fc9 3386=head4 C<=> - define command alias
1ce985d2 3387
b7a96fc9 3388Manipulates C<%alias> to add or list command aliases.
1ce985d2 3389
b7a96fc9 3390=head4 C<source> - read commands from a file.
1ce985d2 3391
b7a96fc9
TC
3392Opens a lexical filehandle and stacks it on C<@cmdfhs>; C<DB::readline> will
3393pick it up.
1ce985d2 3394
b7a96fc9 3395=head4 C<enable> C<disable> - enable or disable breakpoints
1ce985d2 3396
b7a96fc9 3397This enables or disables breakpoints.
1ce985d2 3398
b7a96fc9 3399=head4 C<save> - send current history to a file
d1450c23 3400
b7a96fc9
TC
3401Takes the complete history, (not the shrunken version you see with C<H>),
3402and saves it to the given filename, so it can be replayed using C<source>.
d1450c23 3403
b7a96fc9 3404Note that all C<^(save|source)>'s are commented out with a view to minimise recursion.
d1450c23 3405
b7a96fc9 3406=head4 C<R> - restart
d1450c23 3407
b7a96fc9 3408Restart the debugger session.
73c5e526 3409
b7a96fc9 3410=head4 C<rerun> - rerun the current session
cb9d1513 3411
b7a96fc9 3412Return to any given position in the B<true>-history list
73c5e526 3413
b7a96fc9 3414=head4 C<|, ||> - pipe output through the pager.
cb9d1513 3415
b7a96fc9
TC
3416For C<|>, we save C<OUT> (the debugger's output filehandle) and C<STDOUT>
3417(the program's standard output). For C<||>, we only save C<OUT>. We open a
3418pipe to the pager (restoring the output filehandles if this fails). If this
3419is the C<|> command, we also set up a C<SIGPIPE> handler which will simply
3420set C<$signal>, sending us back into the debugger.
73c5e526 3421
b7a96fc9
TC
3422We then trim off the pipe symbols and C<redo> the command loop at the
3423C<PIPE> label, causing us to evaluate the command in C<$cmd> without
3424reading another.
73c5e526 3425
b7a96fc9 3426=cut
cb9d1513 3427
b7a96fc9
TC
3428 # || - run command in the pager, with output to DB::OUT.
3429 _DB__handle_run_command_in_pager_command($obj);
cb9d1513 3430
b7a96fc9 3431=head3 END OF COMMAND PARSING
cb9d1513 3432
b7a96fc9
TC
3433Anything left in C<$cmd> at this point is a Perl expression that we want to
3434evaluate. We'll always evaluate in the user's context, and fully qualify
3435any variables we might want to address in the C<DB> package.
cb9d1513 3436
b7a96fc9 3437=cut
f89bf53e 3438
b7a96fc9 3439 } # PIPE:
573b5003 3440
b7a96fc9
TC
3441 # trace an expression
3442 $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
573b5003 3443
b7a96fc9
TC
3444 # Make sure the flag that says "the debugger's running" is
3445 # still on, to make sure we get control again.
3446 $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd";
573b5003 3447
b7a96fc9
TC
3448 # Run *our* eval that executes in the caller's context.
3449 # The &-call is here to ascertain the mutability of @_.
3450 &DB::eval;
573b5003 3451
b7a96fc9
TC
3452 # Turn off the one-time-dump stuff now.
3453 if ($onetimeDump) {
3454 $onetimeDump = undef;
3455 $onetimedumpDepth = undef;
3456 }
3457 elsif ( $term_pid == $$ ) {
3458 eval { # May run under miniperl, when not available...
3459 STDOUT->flush();
3460 STDERR->flush();
3461 };
573b5003 3462
b7a96fc9
TC
3463 # XXX If this is the master pid, print a newline.
3464 print {$OUT} "\n";
3465 }
3466 } ## end while (($term || &setterm...
601c6a23 3467
b7a96fc9 3468=head3 POST-COMMAND PROCESSING
d4038e14 3469
b7a96fc9
TC
3470After each command, we check to see if the command output was piped anywhere.
3471If so, we go through the necessary code to unhook the pipe and go back to
3472our standard filehandles for input and output.
d4038e14 3473
b7a96fc9 3474=cut
9875a6d2 3475
b7a96fc9
TC
3476 continue { # CMD:
3477 _DB__at_end_of_every_command($obj);
3478 } # CMD:
b6e88520 3479
b7a96fc9 3480=head3 COMMAND LOOP TERMINATION
b6e88520 3481
b7a96fc9
TC
3482When commands have finished executing, we come here. If the user closed the
3483input filehandle, we turn on C<$fall_off_end> to emulate a C<q> command. We
3484evaluate any post-prompt items. We restore C<$@>, C<$!>, C<$^E>, C<$,>, C<$/>,
3485C<$\>, and C<$^W>, and return a null list as expected by the Perl interpreter.
3486The interpreter will then execute the next line and then return control to us
3487again.
a523ec7c 3488
b7a96fc9 3489=cut
25953301 3490
b7a96fc9
TC
3491 # No more commands? Quit.
3492 $fall_off_end = 1 unless defined $cmd; # Emulate 'q' on EOF
25953301 3493
b7a96fc9
TC
3494 # Evaluate post-prompt commands.
3495 foreach $evalarg (@$post) {
3496 # The &-call is here to ascertain the mutability of @_.
3497 &DB::eval;
3498 }
3499 } # if ($single || $signal)
14f38b27 3500
b7a96fc9
TC
3501 # Put the user's globals back where you found them.
3502 ( $@, $!, $^E, $,, $/, $\, $^W ) = @saved;
3503 ();
3504} ## end sub DB
14f38b27 3505
b7a96fc9
TC
3506# Because DB::Obj is used above,
3507#
3508# my $obj = DB::Obj->new(
3509#
3510# The following package declaration must come before that,
3511# or else runtime errors will occur with
3512#
3513# PERLDB_OPTS="autotrace nonstop"
3514#
3515# ( rt#116771 )
3516BEGIN {
14f38b27 3517
b7a96fc9 3518package DB::Obj;
14f38b27 3519
b7a96fc9
TC
3520sub new {
3521 my $class = shift;
14f38b27 3522
b7a96fc9 3523 my $self = bless {}, $class;
14f38b27 3524
b7a96fc9 3525 $self->_init(@_);
14f38b27 3526
b7a96fc9 3527 return $self;
14f38b27
SF
3528}
3529
b7a96fc9
TC
3530sub _init {
3531 my ($self, $args) = @_;
0d2c714c 3532
b7a96fc9 3533 %{$self} = (%$self, %$args);
0d2c714c 3534
b7a96fc9
TC
3535 return;
3536}
0d2c714c 3537
b7a96fc9
TC
3538{
3539 no strict 'refs';
3540 foreach my $slot_name (qw(
3541 after explicit_stop infix pat piped position prefix selected cmd_verb
3542 cmd_args
3543 )) {
3544 my $slot = $slot_name;
3545 *{$slot} = sub {
3546 my $self = shift;
0d2c714c 3547
b7a96fc9
TC
3548 if (@_) {
3549 ${ $self->{$slot} } = shift;
3550 }
0d2c714c 3551
b7a96fc9
TC
3552 return ${ $self->{$slot} };
3553 };
0d2c714c 3554
b7a96fc9
TC
3555 *{"append_to_$slot"} = sub {
3556 my $self = shift;
3557 my $s = shift;
0d2c714c 3558
b7a96fc9
TC
3559 return $self->$slot($self->$slot . $s);
3560 };
0d2c714c
SF
3561 }
3562}
3563
b7a96fc9
TC
3564sub _DB_on_init__initialize_globals
3565{
0664c09a
SF
3566 my $self = shift;
3567
b7a96fc9
TC
3568 # Check for whether we should be running continuously or not.
3569 # _After_ the perl program is compiled, $single is set to 1:
3570 if ( $single and not $second_time++ ) {
0664c09a 3571
b7a96fc9
TC
3572 # Options say run non-stop. Run until we get an interrupt.
3573 if ($runnonstop) { # Disable until signal
3574 # If there's any call stack in place, turn off single
3575 # stepping into subs throughout the stack.
3576 for my $i (0 .. $stack_depth) {
3577 $stack[ $i ] &= ~1;
3578 }
0664c09a 3579
b7a96fc9
TC
3580 # And we are now no longer in single-step mode.
3581 $single = 0;
0664c09a 3582
b7a96fc9
TC
3583 # If we simply returned at this point, we wouldn't get
3584 # the trace info. Fall on through.
3585 # return;
3586 } ## end if ($runnonstop)
0664c09a 3587
b7a96fc9 3588 elsif ($ImmediateStop) {
0664c09a 3589
b7a96fc9
TC
3590 # We are supposed to stop here; XXX probably a break.
3591 $ImmediateStop = 0; # We've processed it; turn it off
3592 $signal = 1; # Simulate an interrupt to force
3593 # us into the command loop
0664c09a 3594 }
b7a96fc9 3595 } ## end if ($single and not $second_time...
0664c09a 3596
b7a96fc9
TC
3597 # If we're in single-step mode, or an interrupt (real or fake)
3598 # has occurred, turn off non-stop mode.
3599 $runnonstop = 0 if $single or $signal;
c7b0c61d
SF
3600
3601 return;
3602}
3603
b7a96fc9
TC
3604sub _my_print_lineinfo
3605{
3606 my ($self, $i, $incr_pos) = @_;
b6aeebb8 3607
b7a96fc9
TC
3608 if ($frame) {
3609 # Print it indented if tracing is on.
3610 DB::print_lineinfo( ' ' x $stack_depth,
3611 "$i:\t$DB::dbline[$i]" . $self->after );
b6aeebb8 3612 }
a30f63cd 3613 else {
b7a96fc9 3614 DB::depth_print_lineinfo($self->explicit_stop, $incr_pos);
a30f63cd 3615 }
b6aeebb8
SF
3616}
3617
b7a96fc9
TC
3618sub _curr_line {
3619 return $DB::dbline[$line];
3620}
bdb3f37d 3621
b7a96fc9
TC
3622sub _is_full {
3623 my ($self, $letter) = @_;
bdb3f37d 3624
b7a96fc9
TC
3625 return ($DB::cmd eq $letter);
3626}
bdb3f37d 3627