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