Commit | Line | Data |
---|---|---|
e22ea7cc | 1 | |
b570d64b | 2 | =head1 NAME |
69893cff | 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 | |
b570d64b | 25 | features was done using global variables, globs and the C<local()> operator |
69893cff RGS |
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 | |
b570d64b | 37 | debugger itself. |
69893cff RGS |
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 | ||
b570d64b | 49 | As you may recall from reading C<perlfunc>, the C<local()> operator makes a |
69893cff | 50 | temporary copy of a variable in the current scope. When the scope ends, the |
b570d64b | 51 | old copy is restored. This is often used in the debugger to handle the |
69893cff RGS |
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, | |
b570d64b | 62 | then altered. When the subroutine returns, Perl automatically undoes the |
69893cff RGS |
63 | localization, restoring the previous value. Voila, automatic stack management. |
64 | ||
b570d64b | 65 | The debugger uses this trick a I<lot>. Of particular note is C<DB::eval>, |
69893cff RGS |
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 | |
b570d64b | 69 | value of C<$@> is restored. This makes it simple (well, I<simpler>) to keep |
69893cff RGS |
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 | ||
b570d64b | 76 | This is used to cleverly reverse the sense of a logical test depending on |
69893cff | 77 | the value of an auxiliary variable. For instance, the debugger's C<S> |
b570d64b | 78 | (search for subroutines by pattern) allows you to negate the pattern |
69893cff RGS |
79 | like this: |
80 | ||
81 | # Find all non-'foo' subs: | |
b570d64b | 82 | S !/foo/ |
69893cff RGS |
83 | |
84 | Boolean algebra states that the truth table for XOR looks like this: | |
85 | ||
86 | =over 4 | |
87 | ||
b570d64b | 88 | =item * 0 ^ 0 = 0 |
69893cff RGS |
89 | |
90 | (! not present and no match) --> false, don't print | |
91 | ||
b570d64b | 92 | =item * 0 ^ 1 = 1 |
69893cff RGS |
93 | |
94 | (! not present and matches) --> true, print | |
95 | ||
b570d64b | 96 | =item * 1 ^ 0 = 1 |
69893cff RGS |
97 | |
98 | (! present and no match) --> true, print | |
99 | ||
b570d64b | 100 | =item * 1 ^ 1 = 0 |
69893cff RGS |
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 |
b570d64b | 108 | compact a more complicated if-then-elseif-else into a more elegant |
69893cff RGS |
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 | 116 | of 1, 2, 4, etc. (powers of 2) OR'ed together. This allows several pieces |
b570d64b | 117 | of state to be stored independently in a single scalar. |
69893cff RGS |
118 | |
119 | A test like | |
120 | ||
121 | if ($scalar & 4) ... | |
122 | ||
b570d64b | 123 | is checking to see if the appropriate bit is on. Since each bit can be |
69893cff | 124 | "addressed" independently in this way, C<$scalar> is acting sort of like |
b570d64b | 125 | an array of bits. Obviously, since the contents of C<$scalar> are just a |
69893cff RGS |
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 | |
b570d64b | 130 | all over your program whenever a bit is set, cleared, or checked. So why do |
69893cff RGS |
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 |
b570d64b | 140 | this over-optimization at the expense of readability? Possibly, but the |
69893cff RGS |
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 | |
b570d64b | 143 | best balance of readability and speed, and then document how it actually |
69893cff RGS |
144 | works. |
145 | ||
be9a9b1d AT |
146 | =item * |
147 | ||
b570d64b | 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 | |
b570d64b | 151 | this trivial. |
69893cff | 152 | |
be9a9b1d AT |
153 | =item * |
154 | ||
b570d64b SF |
155 | Third, some of these variables are being shared with the Perl core |
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 | |
69893cff RGS |
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 | |
b570d64b | 165 | speculative - it's not exactly clear what a given variable or chunk of |
69893cff RGS |
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 | ||
b570d64b | 171 | =head1 DATA STRUCTURES MAINTAINED BY CORE |
69893cff RGS |
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 | 181 | |
b570d64b SF |
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 | |
69893cff | 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 | ||
da052516 | 189 | The scalar C<${"_<$filename"}> simply contains the string C<$filename>. |
be9a9b1d AT |
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 | |
ee59ac17 | 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> | |
b570d64b | 199 | that will be executed (in the debugger's context) after the debugger has |
69893cff RGS |
200 | initialized itself. |
201 | ||
b570d64b | 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 | ||
b570d64b | 213 | =item * TTY |
69893cff RGS |
214 | |
215 | the TTY to use for debugging i/o. | |
216 | ||
b570d64b | 217 | =item * noTTY |
69893cff RGS |
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 | ||
b570d64b | 224 | =item * ReadLine |
69893cff | 225 | |
5561b870 | 226 | if false, a dummy ReadLine is used, so you can debug |
69893cff RGS |
227 | ReadLine applications. |
228 | ||
b570d64b | 229 | =item * NonStop |
69893cff RGS |
230 | |
231 | if true, no i/o is performed until interrupt. | |
232 | ||
b570d64b | 233 | =item * LineInfo |
69893cff RGS |
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 | ||
b570d64b | 238 | =item * RemotePort |
69893cff RGS |
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 | |
b570d64b | 282 | used for input. |
69893cff | 283 | |
b570d64b | 284 | =over |
69893cff RGS |
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) | |
b570d64b | 307 | is entered or exited. |
69893cff RGS |
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 | ||
7e3426ea | 321 | =item * 16 - Adds C<I<context> return from I<subname>: I<value>> messages on subroutine/eval exit. Ignored if C<4> is not on. |
69893cff RGS |
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 | ||
b570d64b SF |
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 | |
69893cff RGS |
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 | ||
b570d64b | 367 | =over 4 |
69893cff RGS |
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 | ||
b570d64b | 382 | Controls the output of trace information. |
69893cff RGS |
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 | ||
b570d64b | 405 | Local alias to the magical line array, C<@{$main::{'_<'.$filename}}> , |
69893cff RGS |
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 | ||
b570d64b | 453 | =over 4 |
69893cff RGS |
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 | |
b570d64b SF |
490 | package. This is because there are several BEGIN blocks (which of course |
491 | execute immediately) spread through the code. Why is that? | |
69893cff | 492 | |
b570d64b | 493 | The debugger needs to be able to change some things and set some things up |
69893cff RGS |
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. | |
b570d64b | 503 | The third one puts C<$^X> back to its former value. |
69893cff RGS |
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 | ||
c59f1e04 SF |
515 | use Cwd (); |
516 | ||
517 | my $_initial_cwd; | |
518 | ||
2dbd01ad | 519 | BEGIN {eval 'use IO::Handle'}; # Needed for flush only? breaks under miniperl |
9eba6a4e | 520 | |
e56c1e8d SF |
521 | BEGIN { |
522 | require feature; | |
523 | $^V =~ /^v(\d+\.\d+)/; | |
524 | feature->import(":$1"); | |
c59f1e04 | 525 | $_initial_cwd = Cwd::getcwd(); |
e56c1e8d SF |
526 | } |
527 | ||
54d04a52 | 528 | # Debugger for Perl 5.00x; perl5db.pl patch level: |
6b24a4b7 SF |
529 | use vars qw($VERSION $header); |
530 | ||
dcfbcce2 | 531 | # bump to X.XX in blead, only use X.XX_XX in maint |
7fdd4f08 | 532 | $VERSION = '1.52'; |
69893cff | 533 | |
e22ea7cc | 534 | $header = "perl5db.pl version $VERSION"; |
d338d6fe | 535 | |
69893cff RGS |
536 | =head1 DEBUGGER ROUTINES |
537 | ||
538 | =head2 C<DB::eval()> | |
539 | ||
540 | This function replaces straight C<eval()> inside the debugger; it simplifies | |
541 | the process of evaluating code in the user's context. | |
542 | ||
b570d64b | 543 | The code to be evaluated is passed via the package global variable |
69893cff RGS |
544 | C<$DB::evalarg>; this is done to avoid fiddling with the contents of C<@_>. |
545 | ||
be9a9b1d AT |
546 | Before we do the C<eval()>, we preserve the current settings of C<$trace>, |
547 | C<$single>, C<$^D> and C<$usercontext>. The latter contains the | |
548 | preserved values of C<$@>, C<$!>, C<$^E>, C<$,>, C<$/>, C<$\>, C<$^W> and the | |
549 | user's current package, grabbed when C<DB::DB> got control. This causes the | |
550 | proper context to be used when the eval is actually done. Afterward, we | |
551 | restore C<$trace>, C<$single>, and C<$^D>. | |
69893cff RGS |
552 | |
553 | Next we need to handle C<$@> without getting confused. We save C<$@> in a | |
b570d64b SF |
554 | local lexical, localize C<$saved[0]> (which is where C<save()> will put |
555 | C<$@>), and then call C<save()> to capture C<$@>, C<$!>, C<$^E>, C<$,>, | |
69893cff | 556 | C<$/>, C<$\>, and C<$^W>) and set C<$,>, C<$/>, C<$\>, and C<$^W> to values |
b570d64b SF |
557 | considered sane by the debugger. If there was an C<eval()> error, we print |
558 | it on the debugger's output. If C<$onetimedump> is defined, we call | |
559 | C<dumpit> if it's set to 'dump', or C<methods> if it's set to | |
560 | 'methods'. Setting it to something else causes the debugger to do the eval | |
561 | but not print the result - handy if you want to do something else with it | |
69893cff RGS |
562 | (the "watch expressions" code does this to get the value of the watch |
563 | expression but not show it unless it matters). | |
564 | ||
b570d64b SF |
565 | In any case, we then return the list of output from C<eval> to the caller, |
566 | and unwinding restores the former version of C<$@> in C<@saved> as well | |
69893cff RGS |
567 | (the localization of C<$saved[0]> goes away at the end of this scope). |
568 | ||
569 | =head3 Parameters and variables influencing execution of DB::eval() | |
570 | ||
571 | C<DB::eval> isn't parameterized in the standard way; this is to keep the | |
572 | debugger's calls to C<DB::eval()> from mucking with C<@_>, among other things. | |
b570d64b | 573 | The variables listed below influence C<DB::eval()>'s execution directly. |
69893cff RGS |
574 | |
575 | =over 4 | |
576 | ||
577 | =item C<$evalarg> - the thing to actually be eval'ed | |
578 | ||
be9a9b1d | 579 | =item C<$trace> - Current state of execution tracing |
69893cff | 580 | |
be9a9b1d | 581 | =item C<$single> - Current state of single-stepping |
69893cff | 582 | |
b570d64b | 583 | =item C<$onetimeDump> - what is to be displayed after the evaluation |
69893cff RGS |
584 | |
585 | =item C<$onetimeDumpDepth> - how deep C<dumpit()> should go when dumping results | |
586 | ||
587 | =back | |
588 | ||
589 | The following variables are altered by C<DB::eval()> during its execution. They | |
b570d64b | 590 | are "stacked" via C<local()>, enabling recursive calls to C<DB::eval()>. |
69893cff RGS |
591 | |
592 | =over 4 | |
593 | ||
594 | =item C<@res> - used to capture output from actual C<eval>. | |
595 | ||
596 | =item C<$otrace> - saved value of C<$trace>. | |
597 | ||
b570d64b | 598 | =item C<$osingle> - saved value of C<$single>. |
69893cff RGS |
599 | |
600 | =item C<$od> - saved value of C<$^D>. | |
601 | ||
602 | =item C<$saved[0]> - saved value of C<$@>. | |
603 | ||
b570d64b | 604 | =item $\ - for output of C<$@> if there is an evaluation error. |
69893cff RGS |
605 | |
606 | =back | |
607 | ||
608 | =head3 The problem of lexicals | |
609 | ||
610 | The context of C<DB::eval()> presents us with some problems. Obviously, | |
611 | we want to be 'sandboxed' away from the debugger's internals when we do | |
612 | the eval, but we need some way to control how punctuation variables and | |
b570d64b | 613 | debugger globals are used. |
69893cff RGS |
614 | |
615 | We can't use local, because the code inside C<DB::eval> can see localized | |
616 | variables; and we can't use C<my> either for the same reason. The code | |
617 | in this routine compromises and uses C<my>. | |
618 | ||
619 | After this routine is over, we don't have user code executing in the debugger's | |
620 | context, so we can use C<my> freely. | |
621 | ||
622 | =cut | |
623 | ||
624 | ############################################## Begin lexical danger zone | |
625 | ||
626 | # 'my' variables used here could leak into (that is, be visible in) | |
627 | # the context that the code being evaluated is executing in. This means that | |
628 | # the code could modify the debugger's variables. | |
629 | # | |
630 | # Fiddling with the debugger's context could be Bad. We insulate things as | |
631 | # much as we can. | |
632 | ||
6b24a4b7 SF |
633 | use vars qw( |
634 | @args | |
635 | %break_on_load | |
6b24a4b7 SF |
636 | $CommandSet |
637 | $CreateTTY | |
638 | $DBGR | |
639 | @dbline | |
640 | $dbline | |
641 | %dbline | |
642 | $dieLevel | |
6b24a4b7 | 643 | $filename |
6b24a4b7 SF |
644 | $histfile |
645 | $histsize | |
6b24a4b7 SF |
646 | $IN |
647 | $inhibit_exit | |
648 | @ini_INC | |
649 | $ini_warn | |
6b24a4b7 SF |
650 | $maxtrace |
651 | $od | |
6b24a4b7 SF |
652 | @options |
653 | $osingle | |
654 | $otrace | |
6b24a4b7 SF |
655 | $pager |
656 | $post | |
657 | %postponed | |
658 | $prc | |
659 | $pre | |
660 | $pretype | |
661 | $psh | |
662 | @RememberOnROptions | |
663 | $remoteport | |
664 | @res | |
665 | $rl | |
666 | @saved | |
6b24a4b7 | 667 | $signalLevel |
6b24a4b7 | 668 | $sub |
6b24a4b7 | 669 | $term |
6b24a4b7 SF |
670 | $usercontext |
671 | $warnLevel | |
6b24a4b7 SF |
672 | ); |
673 | ||
0b83f3d9 | 674 | our ( |
2ef1dcdb | 675 | @cmdfhs, |
0b83f3d9 SF |
676 | $evalarg, |
677 | $frame, | |
0664c09a | 678 | $hist, |
0b83f3d9 SF |
679 | $ImmediateStop, |
680 | $line, | |
681 | $onetimeDump, | |
b8d11fe0 | 682 | $onetimedumpDepth, |
1ce985d2 | 683 | %option, |
0b83f3d9 | 684 | $OUT, |
1ce985d2 | 685 | $packname, |
0b83f3d9 SF |
686 | $signal, |
687 | $single, | |
d1450c23 | 688 | $start, |
9d0b71b3 SF |
689 | %sub, |
690 | $subname, | |
0b83f3d9 | 691 | $trace, |
d1450c23 | 692 | $window, |
18b5b545 | 693 | ); |
931ac036 | 694 | |
6b24a4b7 SF |
695 | # Used to save @ARGV and extract any debugger-related flags. |
696 | use vars qw(@ARGS); | |
697 | ||
698 | # Used to prevent multiple entries to diesignal() | |
699 | # (if for instance diesignal() itself dies) | |
700 | use vars qw($panic); | |
701 | ||
702 | # Used to prevent the debugger from running nonstop | |
703 | # after a restart | |
ebd0282e | 704 | our ($second_time); |
6b24a4b7 SF |
705 | |
706 | sub _calc_usercontext { | |
707 | my ($package) = @_; | |
708 | ||
709 | # Cancel strict completely for the evaluated code, so the code | |
710 | # the user evaluates won't be affected by it. (Shlomi Fish) | |
22fc883d | 711 | return 'no strict; ($@, $!, $^E, $,, $/, $\, $^W) = @DB::saved;' |
6b24a4b7 SF |
712 | . "package $package;"; # this won't let them modify, alas |
713 | } | |
714 | ||
c1051fcf | 715 | sub eval { |
69893cff | 716 | |
c1051fcf | 717 | # 'my' would make it visible from user code |
e22ea7cc | 718 | # but so does local! --tchrist |
69893cff | 719 | # Remember: this localizes @DB::res, not @main::res. |
c1051fcf IZ |
720 | local @res; |
721 | { | |
e22ea7cc RF |
722 | |
723 | # Try to keep the user code from messing with us. Save these so that | |
724 | # even if the eval'ed code changes them, we can put them back again. | |
725 | # Needed because the user could refer directly to the debugger's | |
69893cff RGS |
726 | # package globals (and any 'my' variables in this containing scope) |
727 | # inside the eval(), and we want to try to stay safe. | |
e22ea7cc | 728 | local $otrace = $trace; |
69893cff RGS |
729 | local $osingle = $single; |
730 | local $od = $^D; | |
731 | ||
732 | # Untaint the incoming eval() argument. | |
733 | { ($evalarg) = $evalarg =~ /(.*)/s; } | |
734 | ||
e22ea7cc | 735 | # $usercontext built in DB::DB near the comment |
69893cff RGS |
736 | # "set up the context for DB::eval ..." |
737 | # Evaluate and save any results. | |
e22ea7cc | 738 | @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug |
69893cff RGS |
739 | |
740 | # Restore those old values. | |
741 | $trace = $otrace; | |
742 | $single = $osingle; | |
743 | $^D = $od; | |
c1051fcf | 744 | } |
69893cff RGS |
745 | |
746 | # Save the current value of $@, and preserve it in the debugger's copy | |
747 | # of the saved precious globals. | |
c1051fcf | 748 | my $at = $@; |
69893cff RGS |
749 | |
750 | # Since we're only saving $@, we only have to localize the array element | |
751 | # that it will be stored in. | |
e22ea7cc | 752 | local $saved[0]; # Preserve the old value of $@ |
e3d167f6 | 753 | eval { &DB::save }; |
69893cff RGS |
754 | |
755 | # Now see whether we need to report an error back to the user. | |
c1051fcf | 756 | if ($at) { |
69893cff RGS |
757 | local $\ = ''; |
758 | print $OUT $at; | |
759 | } | |
760 | ||
761 | # Display as required by the caller. $onetimeDump and $onetimedumpDepth | |
762 | # are package globals. | |
763 | elsif ($onetimeDump) { | |
e22ea7cc RF |
764 | if ( $onetimeDump eq 'dump' ) { |
765 | local $option{dumpDepth} = $onetimedumpDepth | |
766 | if defined $onetimedumpDepth; | |
767 | dumpit( $OUT, \@res ); | |
768 | } | |
769 | elsif ( $onetimeDump eq 'methods' ) { | |
770 | methods( $res[0] ); | |
771 | } | |
69893cff | 772 | } ## end elsif ($onetimeDump) |
c1051fcf | 773 | @res; |
69893cff RGS |
774 | } ## end sub eval |
775 | ||
776 | ############################################## End lexical danger zone | |
c1051fcf | 777 | |
e22ea7cc RF |
778 | # After this point it is safe to introduce lexicals. |
779 | # The code being debugged will be executing in its own context, and | |
69893cff | 780 | # can't see the inside of the debugger. |
d338d6fe | 781 | # |
e22ea7cc | 782 | # However, one should not overdo it: leave as much control from outside as |
69893cff RGS |
783 | # possible. If you make something a lexical, it's not going to be addressable |
784 | # from outside the debugger even if you know its name. | |
785 | ||
d338d6fe | 786 | # This file is automatically included if you do perl -d. |
787 | # It's probably not useful to include this yourself. | |
788 | # | |
e22ea7cc | 789 | # Before venturing further into these twisty passages, it is |
2f7e9187 MS |
790 | # wise to read the perldebguts man page or risk the ire of dragons. |
791 | # | |
69893cff RGS |
792 | # (It should be noted that perldebguts will tell you a lot about |
793 | # the underlying mechanics of how the debugger interfaces into the | |
794 | # Perl interpreter, but not a lot about the debugger itself. The new | |
795 | # comments in this code try to address this problem.) | |
796 | ||
d338d6fe | 797 | # Note that no subroutine call is possible until &DB::sub is defined |
36477c24 | 798 | # (for subroutines defined outside of the package DB). In fact the same is |
d338d6fe | 799 | # true if $deep is not defined. |
055fd3a9 GS |
800 | |
801 | # Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich) | |
055fd3a9 GS |
802 | |
803 | # modified Perl debugger, to be run from Emacs in perldb-mode | |
804 | # Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990 | |
805 | # Johan Vromans -- upgrade to 4.0 pl 10 | |
806 | # Ilya Zakharevich -- patches after 5.001 (and some before ;-) | |
6fae1ad7 | 807 | ######################################################################## |
d338d6fe | 808 | |
69893cff RGS |
809 | =head1 DEBUGGER INITIALIZATION |
810 | ||
811 | The debugger starts up in phases. | |
812 | ||
813 | =head2 BASIC SETUP | |
814 | ||
815 | First, it initializes the environment it wants to run in: turning off | |
816 | warnings during its own compilation, defining variables which it will need | |
817 | to avoid warnings later, setting itself up to not exit when the program | |
818 | terminates, and defaulting to printing return values for the C<r> command. | |
819 | ||
820 | =cut | |
821 | ||
eda6e075 | 822 | # Needed for the statement after exec(): |
69893cff RGS |
823 | # |
824 | # This BEGIN block is simply used to switch off warnings during debugger | |
98dc9551 | 825 | # compilation. Probably it would be better practice to fix the warnings, |
69893cff | 826 | # but this is how it's done at the moment. |
eda6e075 | 827 | |
e22ea7cc RF |
828 | BEGIN { |
829 | $ini_warn = $^W; | |
830 | $^W = 0; | |
831 | } # Switch compilation warnings off until another BEGIN. | |
d12a4851 | 832 | |
69893cff RGS |
833 | local ($^W) = 0; # Switch run-time warnings off during init. |
834 | ||
2cbb2ee1 RGS |
835 | =head2 THREADS SUPPORT |
836 | ||
837 | If we are running under a threaded Perl, we require threads and threads::shared | |
838 | if the environment variable C<PERL5DB_THREADED> is set, to enable proper | |
839 | threaded debugger control. C<-dt> can also be used to set this. | |
840 | ||
841 | Each new thread will be announced and the debugger prompt will always inform | |
842 | you of each new thread created. It will also indicate the thread id in which | |
843 | we are currently running within the prompt like this: | |
844 | ||
2dbd01ad | 845 | [tid] DB<$i> |
2cbb2ee1 RGS |
846 | |
847 | Where C<[tid]> is an integer thread id and C<$i> is the familiar debugger | |
848 | command prompt. The prompt will show: C<[0]> when running under threads, but | |
849 | not actually in a thread. C<[tid]> is consistent with C<gdb> usage. | |
850 | ||
851 | While running under threads, when you set or delete a breakpoint (etc.), this | |
b570d64b | 852 | will apply to all threads, not just the currently running one. When you are |
2cbb2ee1 RGS |
853 | in a currently executing thread, you will stay there until it completes. With |
854 | the current implementation it is not currently possible to hop from one thread | |
855 | to another. | |
856 | ||
857 | The C<e> and C<E> commands are currently fairly minimal - see C<h e> and C<h E>. | |
858 | ||
859 | Note that threading support was built into the debugger as of Perl version | |
860 | C<5.8.6> and debugger version C<1.2.8>. | |
861 | ||
862 | =cut | |
863 | ||
864 | BEGIN { | |
2dbd01ad SF |
865 | # ensure we can share our non-threaded variables or no-op |
866 | if ($ENV{PERL5DB_THREADED}) { | |
867 | require threads; | |
868 | require threads::shared; | |
869 | import threads::shared qw(share); | |
870 | $DBGR; | |
871 | share(\$DBGR); | |
872 | lock($DBGR); | |
873 | print "Threads support enabled\n"; | |
874 | } else { | |
41ef2c66 | 875 | *lock = sub(*) {}; |
cde405a6 | 876 | *share = sub(\[$@%]) {}; |
2dbd01ad | 877 | } |
2cbb2ee1 RGS |
878 | } |
879 | ||
2218c045 SF |
880 | # These variables control the execution of 'dumpvar.pl'. |
881 | { | |
882 | package dumpvar; | |
883 | use vars qw( | |
884 | $hashDepth | |
885 | $arrayDepth | |
886 | $dumpDBFiles | |
887 | $dumpPackages | |
888 | $quoteHighBit | |
889 | $printUndef | |
890 | $globPrint | |
891 | $usageOnly | |
892 | ); | |
893 | } | |
69893cff | 894 | |
2218c045 SF |
895 | # used to control die() reporting in diesignal() |
896 | { | |
897 | package Carp; | |
898 | use vars qw($CarpLevel); | |
899 | } | |
d338d6fe | 900 | |
422c59bf | 901 | # without threads, $filename is not defined until DB::DB is called |
cde405a6 | 902 | share($main::{'_<'.$filename}) if defined $filename; |
2cbb2ee1 | 903 | |
54d04a52 | 904 | # Command-line + PERLLIB: |
69893cff | 905 | # Save the contents of @INC before they are modified elsewhere. |
54d04a52 IZ |
906 | @ini_INC = @INC; |
907 | ||
69893cff RGS |
908 | # This was an attempt to clear out the previous values of various |
909 | # trapped errors. Apparently it didn't help. XXX More info needed! | |
d338d6fe | 910 | # $prevwarn = $prevdie = $prevbus = $prevsegv = ''; # Does not help?! |
911 | ||
69893cff RGS |
912 | # We set these variables to safe values. We don't want to blindly turn |
913 | # off warnings, because other packages may still want them. | |
e22ea7cc RF |
914 | $trace = $signal = $single = 0; # Uninitialized warning suppression |
915 | # (local $^W cannot help - other packages!). | |
69893cff RGS |
916 | |
917 | # Default to not exiting when program finishes; print the return | |
918 | # value when the 'r' command is used to return from a subroutine. | |
55497cff | 919 | $inhibit_exit = $option{PrintRet} = 1; |
d338d6fe | 920 | |
6b24a4b7 SF |
921 | use vars qw($trace_to_depth); |
922 | ||
5e2b42dd SF |
923 | # Default to 1E9 so it won't be limited to a certain recursion depth. |
924 | $trace_to_depth = 1E9; | |
bdba49ad | 925 | |
69893cff RGS |
926 | =head1 OPTION PROCESSING |
927 | ||
b570d64b SF |
928 | The debugger's options are actually spread out over the debugger itself and |
929 | C<dumpvar.pl>; some of these are variables to be set, while others are | |
69893cff RGS |
930 | subs to be called with a value. To try to make this a little easier to |
931 | manage, the debugger uses a few data structures to define what options | |
932 | are legal and how they are to be processed. | |
933 | ||
934 | First, the C<@options> array defines the I<names> of all the options that | |
935 | are to be accepted. | |
936 | ||
937 | =cut | |
938 | ||
939 | @options = qw( | |
5561b870 | 940 | CommandSet HistFile HistSize |
e22ea7cc RF |
941 | hashDepth arrayDepth dumpDepth |
942 | DumpDBFiles DumpPackages DumpReused | |
943 | compactDump veryCompact quote | |
944 | HighBit undefPrint globPrint | |
945 | PrintRet UsageOnly frame | |
946 | AutoTrace TTY noTTY | |
947 | ReadLine NonStop LineInfo | |
948 | maxTraceLen recallCommand ShellBang | |
949 | pager tkRunning ornaments | |
950 | signalLevel warnLevel dieLevel | |
951 | inhibit_exit ImmediateStop bareStringify | |
952 | CreateTTY RemotePort windowSize | |
584420f0 | 953 | DollarCaretP |
e22ea7cc | 954 | ); |
d12a4851 | 955 | |
584420f0 | 956 | @RememberOnROptions = qw(DollarCaretP); |
d12a4851 | 957 | |
69893cff RGS |
958 | =pod |
959 | ||
960 | Second, C<optionVars> lists the variables that each option uses to save its | |
961 | state. | |
962 | ||
963 | =cut | |
964 | ||
6b24a4b7 SF |
965 | use vars qw(%optionVars); |
966 | ||
69893cff | 967 | %optionVars = ( |
e22ea7cc RF |
968 | hashDepth => \$dumpvar::hashDepth, |
969 | arrayDepth => \$dumpvar::arrayDepth, | |
970 | CommandSet => \$CommandSet, | |
971 | DumpDBFiles => \$dumpvar::dumpDBFiles, | |
972 | DumpPackages => \$dumpvar::dumpPackages, | |
973 | DumpReused => \$dumpvar::dumpReused, | |
974 | HighBit => \$dumpvar::quoteHighBit, | |
975 | undefPrint => \$dumpvar::printUndef, | |
976 | globPrint => \$dumpvar::globPrint, | |
977 | UsageOnly => \$dumpvar::usageOnly, | |
978 | CreateTTY => \$CreateTTY, | |
979 | bareStringify => \$dumpvar::bareStringify, | |
980 | frame => \$frame, | |
981 | AutoTrace => \$trace, | |
982 | inhibit_exit => \$inhibit_exit, | |
983 | maxTraceLen => \$maxtrace, | |
984 | ImmediateStop => \$ImmediateStop, | |
985 | RemotePort => \$remoteport, | |
986 | windowSize => \$window, | |
5561b870 A |
987 | HistFile => \$histfile, |
988 | HistSize => \$histsize, | |
69893cff RGS |
989 | ); |
990 | ||
991 | =pod | |
992 | ||
993 | Third, C<%optionAction> defines the subroutine to be called to process each | |
994 | option. | |
995 | ||
b570d64b | 996 | =cut |
69893cff | 997 | |
6b24a4b7 SF |
998 | use vars qw(%optionAction); |
999 | ||
69893cff RGS |
1000 | %optionAction = ( |
1001 | compactDump => \&dumpvar::compactDump, | |
1002 | veryCompact => \&dumpvar::veryCompact, | |
1003 | quote => \&dumpvar::quote, | |
1004 | TTY => \&TTY, | |
1005 | noTTY => \&noTTY, | |
1006 | ReadLine => \&ReadLine, | |
1007 | NonStop => \&NonStop, | |
1008 | LineInfo => \&LineInfo, | |
1009 | recallCommand => \&recallCommand, | |
1010 | ShellBang => \&shellBang, | |
1011 | pager => \&pager, | |
1012 | signalLevel => \&signalLevel, | |
1013 | warnLevel => \&warnLevel, | |
1014 | dieLevel => \&dieLevel, | |
1015 | tkRunning => \&tkRunning, | |
1016 | ornaments => \&ornaments, | |
1017 | RemotePort => \&RemotePort, | |
1018 | DollarCaretP => \&DollarCaretP, | |
d12a4851 JH |
1019 | ); |
1020 | ||
69893cff RGS |
1021 | =pod |
1022 | ||
1023 | Last, the C<%optionRequire> notes modules that must be C<require>d if an | |
1024 | option is used. | |
1025 | ||
1026 | =cut | |
d338d6fe | 1027 | |
69893cff RGS |
1028 | # Note that this list is not complete: several options not listed here |
1029 | # actually require that dumpvar.pl be loaded for them to work, but are | |
1030 | # not in the table. A subsequent patch will correct this problem; for | |
1031 | # the moment, we're just recommenting, and we are NOT going to change | |
1032 | # function. | |
6b24a4b7 SF |
1033 | use vars qw(%optionRequire); |
1034 | ||
eda6e075 | 1035 | %optionRequire = ( |
69893cff RGS |
1036 | compactDump => 'dumpvar.pl', |
1037 | veryCompact => 'dumpvar.pl', | |
1038 | quote => 'dumpvar.pl', | |
e22ea7cc | 1039 | ); |
69893cff RGS |
1040 | |
1041 | =pod | |
1042 | ||
1043 | There are a number of initialization-related variables which can be set | |
1044 | by putting code to set them in a BEGIN block in the C<PERL5DB> environment | |
1045 | variable. These are: | |
1046 | ||
1047 | =over 4 | |
1048 | ||
1049 | =item C<$rl> - readline control XXX needs more explanation | |
1050 | ||
1051 | =item C<$warnLevel> - whether or not debugger takes over warning handling | |
1052 | ||
1053 | =item C<$dieLevel> - whether or not debugger takes over die handling | |
1054 | ||
1055 | =item C<$signalLevel> - whether or not debugger takes over signal handling | |
1056 | ||
1057 | =item C<$pre> - preprompt actions (array reference) | |
1058 | ||
1059 | =item C<$post> - postprompt actions (array reference) | |
1060 | ||
1061 | =item C<$pretype> | |
1062 | ||
1063 | =item C<$CreateTTY> - whether or not to create a new TTY for this debugger | |
1064 | ||
1065 | =item C<$CommandSet> - which command set to use (defaults to new, documented set) | |
1066 | ||
1067 | =back | |
1068 | ||
1069 | =cut | |
d338d6fe | 1070 | |
1071 | # These guys may be defined in $ENV{PERL5DB} : | |
69893cff RGS |
1072 | $rl = 1 unless defined $rl; |
1073 | $warnLevel = 1 unless defined $warnLevel; | |
1074 | $dieLevel = 1 unless defined $dieLevel; | |
1075 | $signalLevel = 1 unless defined $signalLevel; | |
1076 | $pre = [] unless defined $pre; | |
1077 | $post = [] unless defined $post; | |
1078 | $pretype = [] unless defined $pretype; | |
1079 | $CreateTTY = 3 unless defined $CreateTTY; | |
1080 | $CommandSet = '580' unless defined $CommandSet; | |
1081 | ||
2cbb2ee1 RGS |
1082 | share($rl); |
1083 | share($warnLevel); | |
1084 | share($dieLevel); | |
1085 | share($signalLevel); | |
1086 | share($pre); | |
1087 | share($post); | |
1088 | share($pretype); | |
1089 | share($rl); | |
1090 | share($CreateTTY); | |
1091 | share($CommandSet); | |
1092 | ||
69893cff RGS |
1093 | =pod |
1094 | ||
1095 | The default C<die>, C<warn>, and C<signal> handlers are set up. | |
1096 | ||
1097 | =cut | |
055fd3a9 | 1098 | |
d338d6fe | 1099 | warnLevel($warnLevel); |
1100 | dieLevel($dieLevel); | |
1101 | signalLevel($signalLevel); | |
055fd3a9 | 1102 | |
69893cff RGS |
1103 | =pod |
1104 | ||
1105 | The pager to be used is needed next. We try to get it from the | |
5561b870 | 1106 | environment first. If it's not defined there, we try to find it in |
69893cff RGS |
1107 | the Perl C<Config.pm>. If it's not there, we default to C<more>. We |
1108 | then call the C<pager()> function to save the pager name. | |
1109 | ||
1110 | =cut | |
1111 | ||
1112 | # This routine makes sure $pager is set up so that '|' can use it. | |
4865a36d | 1113 | pager( |
e22ea7cc | 1114 | |
69893cff | 1115 | # If PAGER is defined in the environment, use it. |
e22ea7cc RF |
1116 | defined $ENV{PAGER} |
1117 | ? $ENV{PAGER} | |
69893cff RGS |
1118 | |
1119 | # If not, see if Config.pm defines it. | |
e22ea7cc RF |
1120 | : eval { require Config } |
1121 | && defined $Config::Config{pager} | |
1122 | ? $Config::Config{pager} | |
69893cff RGS |
1123 | |
1124 | # If not, fall back to 'more'. | |
e22ea7cc RF |
1125 | : 'more' |
1126 | ) | |
1127 | unless defined $pager; | |
69893cff RGS |
1128 | |
1129 | =pod | |
1130 | ||
1131 | We set up the command to be used to access the man pages, the command | |
be9a9b1d AT |
1132 | recall character (C<!> unless otherwise defined) and the shell escape |
1133 | character (C<!> unless otherwise defined). Yes, these do conflict, and | |
69893cff RGS |
1134 | neither works in the debugger at the moment. |
1135 | ||
1136 | =cut | |
1137 | ||
055fd3a9 | 1138 | setman(); |
69893cff RGS |
1139 | |
1140 | # Set up defaults for command recall and shell escape (note: | |
1141 | # these currently don't work in linemode debugging). | |
2218c045 SF |
1142 | recallCommand("!") unless defined $prc; |
1143 | shellBang("!") unless defined $psh; | |
69893cff RGS |
1144 | |
1145 | =pod | |
1146 | ||
1147 | We then set up the gigantic string containing the debugger help. | |
1148 | We also set the limit on the number of arguments we'll display during a | |
1149 | trace. | |
1150 | ||
1151 | =cut | |
1152 | ||
04e43a21 | 1153 | sethelp(); |
69893cff RGS |
1154 | |
1155 | # If we didn't get a default for the length of eval/stack trace args, | |
1156 | # set it here. | |
1d06cb2d | 1157 | $maxtrace = 400 unless defined $maxtrace; |
69893cff RGS |
1158 | |
1159 | =head2 SETTING UP THE DEBUGGER GREETING | |
1160 | ||
be9a9b1d | 1161 | The debugger I<greeting> helps to inform the user how many debuggers are |
69893cff RGS |
1162 | running, and whether the current debugger is the primary or a child. |
1163 | ||
1164 | If we are the primary, we just hang onto our pid so we'll have it when | |
1165 | or if we start a child debugger. If we are a child, we'll set things up | |
1166 | so we'll have a unique greeting and so the parent will give us our own | |
1167 | TTY later. | |
1168 | ||
1169 | We save the current contents of the C<PERLDB_PIDS> environment variable | |
1170 | because we mess around with it. We'll also need to hang onto it because | |
1171 | we'll need it if we restart. | |
1172 | ||
1173 | Child debuggers make a label out of the current PID structure recorded in | |
1174 | PERLDB_PIDS plus the new PID. They also mark themselves as not having a TTY | |
1175 | yet so the parent will give them one later via C<resetterm()>. | |
1176 | ||
1177 | =cut | |
1178 | ||
e22ea7cc | 1179 | # Save the current contents of the environment; we're about to |
69893cff | 1180 | # much with it. We'll need this if we have to restart. |
6b24a4b7 | 1181 | use vars qw($ini_pids); |
f1583d8f | 1182 | $ini_pids = $ENV{PERLDB_PIDS}; |
69893cff | 1183 | |
6b24a4b7 SF |
1184 | use vars qw ($pids $term_pid); |
1185 | ||
e22ea7cc RF |
1186 | if ( defined $ENV{PERLDB_PIDS} ) { |
1187 | ||
69893cff | 1188 | # We're a child. Make us a label out of the current PID structure |
e22ea7cc | 1189 | # recorded in PERLDB_PIDS plus our (new) PID. Mark us as not having |
69893cff | 1190 | # a term yet so the parent will give us one later via resetterm(). |
55f4245e JM |
1191 | |
1192 | my $env_pids = $ENV{PERLDB_PIDS}; | |
1193 | $pids = "[$env_pids]"; | |
1194 | ||
1195 | # Unless we are on OpenVMS, all programs under the DCL shell run under | |
1196 | # the same PID. | |
1197 | ||
1198 | if (($^O eq 'VMS') && ($env_pids =~ /\b$$\b/)) { | |
1199 | $term_pid = $$; | |
1200 | } | |
1201 | else { | |
1202 | $ENV{PERLDB_PIDS} .= "->$$"; | |
1203 | $term_pid = -1; | |
1204 | } | |
1205 | ||
69893cff RGS |
1206 | } ## end if (defined $ENV{PERLDB_PIDS... |
1207 | else { | |
e22ea7cc RF |
1208 | |
1209 | # We're the parent PID. Initialize PERLDB_PID in case we end up with a | |
69893cff RGS |
1210 | # child debugger, and mark us as the parent, so we'll know to set up |
1211 | # more TTY's is we have to. | |
1212 | $ENV{PERLDB_PIDS} = "$$"; | |
619a0444 | 1213 | $pids = "[pid=$$]"; |
e22ea7cc | 1214 | $term_pid = $$; |
f1583d8f | 1215 | } |
69893cff | 1216 | |
6b24a4b7 | 1217 | use vars qw($pidprompt); |
f1583d8f | 1218 | $pidprompt = ''; |
69893cff RGS |
1219 | |
1220 | # Sets up $emacs as a synonym for $slave_editor. | |
7793e5c2 | 1221 | our ($slave_editor); |
69893cff RGS |
1222 | *emacs = $slave_editor if $slave_editor; # May be used in afterinit()... |
1223 | ||
1224 | =head2 READING THE RC FILE | |
1225 | ||
b570d64b | 1226 | The debugger will read a file of initialization options if supplied. If |
69893cff RGS |
1227 | running interactively, this is C<.perldb>; if not, it's C<perldb.ini>. |
1228 | ||
b570d64b | 1229 | =cut |
69893cff RGS |
1230 | |
1231 | # As noted, this test really doesn't check accurately that the debugger | |
1232 | # is running at a terminal or not. | |
d338d6fe | 1233 | |
6b24a4b7 | 1234 | use vars qw($rcfile); |
fb4d8a6c SF |
1235 | { |
1236 | my $dev_tty = (($^O eq 'VMS') ? 'TT:' : '/dev/tty'); | |
1237 | # this is the wrong metric! | |
1238 | $rcfile = ((-e $dev_tty) ? ".perldb" : "perldb.ini"); | |
d338d6fe | 1239 | } |
1240 | ||
69893cff RGS |
1241 | =pod |
1242 | ||
1243 | The debugger does a safety test of the file to be read. It must be owned | |
1244 | either by the current user or root, and must only be writable by the owner. | |
1245 | ||
1246 | =cut | |
1247 | ||
1248 | # This wraps a safety test around "do" to read and evaluate the init file. | |
1249 | # | |
055fd3a9 GS |
1250 | # This isn't really safe, because there's a race |
1251 | # between checking and opening. The solution is to | |
1252 | # open and fstat the handle, but then you have to read and | |
1253 | # eval the contents. But then the silly thing gets | |
69893cff RGS |
1254 | # your lexical scope, which is unfortunate at best. |
1255 | sub safe_do { | |
055fd3a9 GS |
1256 | my $file = shift; |
1257 | ||
1258 | # Just exactly what part of the word "CORE::" don't you understand? | |
69893cff RGS |
1259 | local $SIG{__WARN__}; |
1260 | local $SIG{__DIE__}; | |
055fd3a9 | 1261 | |
e22ea7cc | 1262 | unless ( is_safe_file($file) ) { |
69893cff | 1263 | CORE::warn <<EO_GRIPE; |
055fd3a9 | 1264 | perldb: Must not source insecure rcfile $file. |
b570d64b | 1265 | You or the superuser must be the owner, and it must not |
69893cff | 1266 | be writable by anyone but its owner. |
055fd3a9 | 1267 | EO_GRIPE |
69893cff RGS |
1268 | return; |
1269 | } ## end unless (is_safe_file($file... | |
055fd3a9 GS |
1270 | |
1271 | do $file; | |
1272 | CORE::warn("perldb: couldn't parse $file: $@") if $@; | |
69893cff | 1273 | } ## end sub safe_do |
055fd3a9 | 1274 | |
69893cff RGS |
1275 | # This is the safety test itself. |
1276 | # | |
055fd3a9 GS |
1277 | # Verifies that owner is either real user or superuser and that no |
1278 | # one but owner may write to it. This function is of limited use | |
1279 | # when called on a path instead of upon a handle, because there are | |
1280 | # no guarantees that filename (by dirent) whose file (by ino) is | |
e22ea7cc | 1281 | # eventually accessed is the same as the one tested. |
055fd3a9 GS |
1282 | # Assumes that the file's existence is not in doubt. |
1283 | sub is_safe_file { | |
1284 | my $path = shift; | |
69893cff | 1285 | stat($path) || return; # mysteriously vaporized |
e22ea7cc | 1286 | my ( $dev, $ino, $mode, $nlink, $uid, $gid ) = stat(_); |
055fd3a9 GS |
1287 | |
1288 | return 0 if $uid != 0 && $uid != $<; | |
1289 | return 0 if $mode & 022; | |
1290 | return 1; | |
69893cff | 1291 | } ## end sub is_safe_file |
055fd3a9 | 1292 | |
69893cff | 1293 | # If the rcfile (whichever one we decided was the right one to read) |
e22ea7cc RF |
1294 | # exists, we safely do it. |
1295 | if ( -f $rcfile ) { | |
055fd3a9 | 1296 | safe_do("./$rcfile"); |
69893cff | 1297 | } |
e22ea7cc | 1298 | |
69893cff | 1299 | # If there isn't one here, try the user's home directory. |
e22ea7cc | 1300 | elsif ( defined $ENV{HOME} && -f "$ENV{HOME}/$rcfile" ) { |
055fd3a9 GS |
1301 | safe_do("$ENV{HOME}/$rcfile"); |
1302 | } | |
e22ea7cc | 1303 | |
69893cff | 1304 | # Else try the login directory. |
e22ea7cc | 1305 | elsif ( defined $ENV{LOGDIR} && -f "$ENV{LOGDIR}/$rcfile" ) { |
055fd3a9 | 1306 | safe_do("$ENV{LOGDIR}/$rcfile"); |
d338d6fe | 1307 | } |
1308 | ||
69893cff | 1309 | # If the PERLDB_OPTS variable has options in it, parse those out next. |
e22ea7cc RF |
1310 | if ( defined $ENV{PERLDB_OPTS} ) { |
1311 | parse_options( $ENV{PERLDB_OPTS} ); | |
d338d6fe | 1312 | } |
1313 | ||
69893cff RGS |
1314 | =pod |
1315 | ||
1316 | The last thing we do during initialization is determine which subroutine is | |
1317 | to be used to obtain a new terminal when a new debugger is started. Right now, | |
b0b54b5e | 1318 | the debugger only handles TCP sockets, X11, OS/2, amd Mac OS X |
11653f7f | 1319 | (darwin). |
69893cff RGS |
1320 | |
1321 | =cut | |
1322 | ||
1323 | # Set up the get_fork_TTY subroutine to be aliased to the proper routine. | |
1324 | # Works if you're running an xterm or xterm-like window, or you're on | |
6fae1ad7 RF |
1325 | # OS/2, or on Mac OS X. This may need some expansion. |
1326 | ||
1327 | if (not defined &get_fork_TTY) # only if no routine exists | |
69893cff | 1328 | { |
b570d64b | 1329 | if ( defined $remoteport ) { |
11653f7f JJ |
1330 | # Expect an inetd-like server |
1331 | *get_fork_TTY = \&socket_get_fork_TTY; # to listen to us | |
1332 | } | |
1333 | elsif (defined $ENV{TERM} # If we know what kind | |
6fae1ad7 RF |
1334 | # of terminal this is, |
1335 | and $ENV{TERM} eq 'xterm' # and it's an xterm, | |
1336 | and defined $ENV{DISPLAY} # and what display it's on, | |
1337 | ) | |
1338 | { | |
1339 | *get_fork_TTY = \&xterm_get_fork_TTY; # use the xterm version | |
1340 | } | |
babb663a RH |
1341 | elsif ( $ENV{TMUX} ) { |
1342 | *get_fork_TTY = \&tmux_get_fork_TTY; | |
1343 | } | |
6fae1ad7 RF |
1344 | elsif ( $^O eq 'os2' ) { # If this is OS/2, |
1345 | *get_fork_TTY = \&os2_get_fork_TTY; # use the OS/2 version | |
1346 | } | |
1347 | elsif ( $^O eq 'darwin' # If this is Mac OS X | |
1348 | and defined $ENV{TERM_PROGRAM} # and we're running inside | |
1349 | and $ENV{TERM_PROGRAM} | |
1350 | eq 'Apple_Terminal' # Terminal.app | |
1351 | ) | |
1352 | { | |
1353 | *get_fork_TTY = \&macosx_get_fork_TTY; # use the Mac OS X version | |
1354 | } | |
69893cff | 1355 | } ## end if (not defined &get_fork_TTY... |
e22ea7cc | 1356 | |
dbb46cec DQ |
1357 | # untaint $^O, which may have been tainted by the last statement. |
1358 | # see bug [perl #24674] | |
e22ea7cc RF |
1359 | $^O =~ m/^(.*)\z/; |
1360 | $^O = $1; | |
f1583d8f | 1361 | |
d12a4851 | 1362 | # Here begin the unreadable code. It needs fixing. |
055fd3a9 | 1363 | |
69893cff RGS |
1364 | =head2 RESTART PROCESSING |
1365 | ||
1366 | This section handles the restart command. When the C<R> command is invoked, it | |
1367 | tries to capture all of the state it can into environment variables, and | |
1368 | then sets C<PERLDB_RESTART>. When we start executing again, we check to see | |
1369 | if C<PERLDB_RESTART> is there; if so, we reload all the information that | |
1370 | the R command stuffed into the environment variables. | |
1371 | ||
b570d64b | 1372 | PERLDB_RESTART - flag only, contains no restart data itself. |
69893cff RGS |
1373 | PERLDB_HIST - command history, if it's available |
1374 | PERLDB_ON_LOAD - breakpoints set by the rc file | |
555bd962 BG |
1375 | PERLDB_POSTPONE - subs that have been loaded/not executed, |
1376 | and have actions | |
69893cff RGS |
1377 | PERLDB_VISITED - files that had breakpoints |
1378 | PERLDB_FILE_... - breakpoints for a file | |
1379 | PERLDB_OPT - active options | |
1380 | PERLDB_INC - the original @INC | |
1381 | PERLDB_PRETYPE - preprompt debugger actions | |
1382 | PERLDB_PRE - preprompt Perl code | |
1383 | PERLDB_POST - post-prompt Perl code | |
1384 | PERLDB_TYPEAHEAD - typeahead captured by readline() | |
1385 | ||
1386 | We chug through all these variables and plug the values saved in them | |
1387 | back into the appropriate spots in the debugger. | |
1388 | ||
1389 | =cut | |
1390 | ||
0664c09a | 1391 | use vars qw(%postponed_file @typeahead); |
14f38b27 | 1392 | |
0664c09a | 1393 | our (@hist, @truehist); |
6b24a4b7 | 1394 | |
fb0fb5f4 SF |
1395 | sub _restore_shared_globals_after_restart |
1396 | { | |
1397 | @hist = get_list('PERLDB_HIST'); | |
1398 | %break_on_load = get_list("PERLDB_ON_LOAD"); | |
1399 | %postponed = get_list("PERLDB_POSTPONE"); | |
1400 | ||
1401 | share(@hist); | |
1402 | share(@truehist); | |
1403 | share(%break_on_load); | |
1404 | share(%postponed); | |
1405 | } | |
1406 | ||
e18a02a6 | 1407 | sub _restore_breakpoints_and_actions { |
e22ea7cc | 1408 | |
e22ea7cc | 1409 | my @had_breakpoints = get_list("PERLDB_VISITED"); |
e18a02a6 | 1410 | |
bdba49ad SF |
1411 | for my $file_idx ( 0 .. $#had_breakpoints ) { |
1412 | my $filename = $had_breakpoints[$file_idx]; | |
1413 | my %pf = get_list("PERLDB_FILE_$file_idx"); | |
1414 | $postponed_file{ $filename } = \%pf if %pf; | |
1415 | my @lines = sort {$a <=> $b} keys(%pf); | |
1416 | my @enabled_statuses = get_list("PERLDB_FILE_ENABLED_$file_idx"); | |
1417 | for my $line_idx (0 .. $#lines) { | |
1418 | _set_breakpoint_enabled_status( | |
1419 | $filename, | |
1420 | $lines[$line_idx], | |
1421 | ($enabled_statuses[$line_idx] ? 1 : ''), | |
1422 | ); | |
1423 | } | |
e22ea7cc | 1424 | } |
69893cff | 1425 | |
e18a02a6 SF |
1426 | return; |
1427 | } | |
1428 | ||
ca50076b SF |
1429 | sub _restore_options_after_restart |
1430 | { | |
1431 | my %options_map = get_list("PERLDB_OPT"); | |
1432 | ||
1433 | while ( my ( $opt, $val ) = each %options_map ) { | |
1434 | $val =~ s/[\\\']/\\$1/g; | |
1435 | parse_options("$opt'$val'"); | |
1436 | } | |
1437 | ||
1438 | return; | |
1439 | } | |
1440 | ||
18580168 SF |
1441 | sub _restore_globals_after_restart |
1442 | { | |
1443 | # restore original @INC | |
1444 | @INC = get_list("PERLDB_INC"); | |
1445 | @ini_INC = @INC; | |
1446 | ||
1447 | # return pre/postprompt actions and typeahead buffer | |
1448 | $pretype = [ get_list("PERLDB_PRETYPE") ]; | |
1449 | $pre = [ get_list("PERLDB_PRE") ]; | |
1450 | $post = [ get_list("PERLDB_POST") ]; | |
1451 | @typeahead = get_list( "PERLDB_TYPEAHEAD", @typeahead ); | |
1452 | ||
1453 | return; | |
1454 | } | |
1455 | ||
fb0fb5f4 | 1456 | |
e18a02a6 SF |
1457 | if ( exists $ENV{PERLDB_RESTART} ) { |
1458 | ||
1459 | # We're restarting, so we don't need the flag that says to restart anymore. | |
1460 | delete $ENV{PERLDB_RESTART}; | |
1461 | ||
1462 | # $restart = 1; | |
fb0fb5f4 | 1463 | _restore_shared_globals_after_restart(); |
e18a02a6 SF |
1464 | |
1465 | _restore_breakpoints_and_actions(); | |
1466 | ||
69893cff | 1467 | # restore options |
ca50076b | 1468 | _restore_options_after_restart(); |
69893cff | 1469 | |
18580168 | 1470 | _restore_globals_after_restart(); |
69893cff RGS |
1471 | } ## end if (exists $ENV{PERLDB_RESTART... |
1472 | ||
1473 | =head2 SETTING UP THE TERMINAL | |
1474 | ||
1475 | Now, we'll decide how the debugger is going to interact with the user. | |
1476 | If there's no TTY, we set the debugger to run non-stop; there's not going | |
1477 | to be anyone there to enter commands. | |
1478 | ||
1479 | =cut | |
54d04a52 | 1480 | |
ebd0282e | 1481 | use vars qw($notty $console $tty $LINEINFO); |
6b24a4b7 SF |
1482 | use vars qw($lineinfo $doccmd); |
1483 | ||
ebd0282e SF |
1484 | our ($runnonstop); |
1485 | ||
e0047406 KF |
1486 | # Local autoflush to avoid rt#116769, |
1487 | # as calling IO::File methods causes an unresolvable loop | |
1488 | # that results in debugger failure. | |
1489 | sub _autoflush { | |
1490 | my $o = select($_[0]); | |
1491 | $|++; | |
1492 | select($o); | |
1493 | } | |
1494 | ||
d338d6fe | 1495 | if ($notty) { |
69893cff | 1496 | $runnonstop = 1; |
2dbd01ad | 1497 | share($runnonstop); |
69893cff | 1498 | } |
d12a4851 | 1499 | |
69893cff RGS |
1500 | =pod |
1501 | ||
1502 | If there is a TTY, we have to determine who it belongs to before we can | |
1503 | proceed. If this is a slave editor or graphical debugger (denoted by | |
1504 | the first command-line switch being '-emacs'), we shift this off and | |
1505 | set C<$rl> to 0 (XXX ostensibly to do straight reads). | |
1506 | ||
1507 | =cut | |
1508 | ||
1509 | else { | |
e22ea7cc | 1510 | |
69893cff RGS |
1511 | # Is Perl being run from a slave editor or graphical debugger? |
1512 | # If so, don't use readline, and set $slave_editor = 1. | |
2b0b9dd1 SF |
1513 | if ($slave_editor = ( @main::ARGV && ( $main::ARGV[0] eq '-emacs' ) )) { |
1514 | $rl = 0; | |
1515 | shift(@main::ARGV); | |
1516 | } | |
e22ea7cc RF |
1517 | |
1518 | #require Term::ReadLine; | |
d12a4851 | 1519 | |
69893cff RGS |
1520 | =pod |
1521 | ||
1522 | We then determine what the console should be on various systems: | |
1523 | ||
1524 | =over 4 | |
1525 | ||
1526 | =item * Cygwin - We use C<stdin> instead of a separate device. | |
1527 | ||
1528 | =cut | |
1529 | ||
e22ea7cc RF |
1530 | if ( $^O eq 'cygwin' ) { |
1531 | ||
69893cff RGS |
1532 | # /dev/tty is binary. use stdin for textmode |
1533 | undef $console; | |
1534 | } | |
1535 | ||
69893cff RGS |
1536 | =item * Windows or MSDOS - use C<con>. |
1537 | ||
1538 | =cut | |
1539 | ||
e22ea7cc | 1540 | elsif ( $^O eq 'dos' or -e "con" or $^O eq 'MSWin32' ) { |
69893cff RGS |
1541 | $console = "con"; |
1542 | } | |
1543 | ||
cf412c92 AB |
1544 | =item * AmigaOS - use C<CONSOLE:>. |
1545 | ||
1546 | =cut | |
1547 | ||
1548 | elsif ( $^O eq 'amigaos' ) { | |
1549 | $console = "CONSOLE:"; | |
1550 | } | |
1551 | ||
69893cff RGS |
1552 | =item * VMS - use C<sys$command>. |
1553 | ||
1554 | =cut | |
1555 | ||
c9cc5940 JH |
1556 | elsif ($^O eq 'VMS') { |
1557 | $console = 'sys$command'; | |
1558 | } | |
1559 | ||
f1cba945 JK |
1560 | # Keep this penultimate, on the grounds that it satisfies a wide variety of |
1561 | # Unix-like systems that would otherwise need to be identified individually. | |
1562 | ||
1563 | =item * Unix - use F</dev/tty>. | |
1564 | ||
1565 | =cut | |
1566 | ||
1567 | elsif ( -e "/dev/tty" ) { | |
1568 | $console = "/dev/tty"; | |
1569 | } | |
1570 | ||
c9cc5940 | 1571 | # Keep this last. |
e22ea7cc | 1572 | |
c9cc5940 JH |
1573 | else { |
1574 | _db_warn("Can't figure out your console, using stdin"); | |
1575 | undef $console; | |
d12a4851 | 1576 | } |
69893cff RGS |
1577 | |
1578 | =pod | |
1579 | ||
1580 | =back | |
1581 | ||
1582 | Several other systems don't use a specific console. We C<undef $console> | |
1583 | for those (Windows using a slave editor/graphical debugger, NetWare, OS/2 | |
739a0b84 | 1584 | with a slave editor). |
69893cff RGS |
1585 | |
1586 | =cut | |
d12a4851 | 1587 | |
e22ea7cc RF |
1588 | if ( ( $^O eq 'MSWin32' ) and ( $slave_editor or defined $ENV{EMACS} ) ) { |
1589 | ||
69893cff | 1590 | # /dev/tty is binary. use stdin for textmode |
e22ea7cc RF |
1591 | $console = undef; |
1592 | } | |
1593 | ||
1594 | if ( $^O eq 'NetWare' ) { | |
d12a4851 | 1595 | |
69893cff RGS |
1596 | # /dev/tty is binary. use stdin for textmode |
1597 | $console = undef; | |
1598 | } | |
d12a4851 | 1599 | |
69893cff RGS |
1600 | # In OS/2, we need to use STDIN to get textmode too, even though |
1601 | # it pretty much looks like Unix otherwise. | |
e22ea7cc RF |
1602 | if ( defined $ENV{OS2_SHELL} and ( $slave_editor or $ENV{WINDOWID} ) ) |
1603 | { # In OS/2 | |
1604 | $console = undef; | |
1605 | } | |
1606 | ||
69893cff RGS |
1607 | =pod |
1608 | ||
1609 | If there is a TTY hanging around from a parent, we use that as the console. | |
1610 | ||
1611 | =cut | |
1612 | ||
e22ea7cc | 1613 | $console = $tty if defined $tty; |
d12a4851 | 1614 | |
b570d64b | 1615 | =head2 SOCKET HANDLING |
69893cff RGS |
1616 | |
1617 | The debugger is capable of opening a socket and carrying out a debugging | |
1618 | session over the socket. | |
1619 | ||
1620 | If C<RemotePort> was defined in the options, the debugger assumes that it | |
1621 | should try to start a debugging session on that port. It builds the socket | |
1622 | and then tries to connect the input and output filehandles to it. | |
1623 | ||
1624 | =cut | |
1625 | ||
1626 | # Handle socket stuff. | |
e22ea7cc RF |
1627 | |
1628 | if ( defined $remoteport ) { | |
1629 | ||
69893cff RGS |
1630 | # If RemotePort was defined in the options, connect input and output |
1631 | # to the socket. | |
11653f7f | 1632 | $IN = $OUT = connect_remoteport(); |
69893cff RGS |
1633 | } ## end if (defined $remoteport) |
1634 | ||
1635 | =pod | |
1636 | ||
1637 | If no C<RemotePort> was defined, and we want to create a TTY on startup, | |
1638 | this is probably a situation where multiple debuggers are running (for example, | |
1639 | a backticked command that starts up another debugger). We create a new IN and | |
1640 | OUT filehandle, and do the necessary mojo to create a new TTY if we know how | |
1641 | and if we can. | |
1642 | ||
1643 | =cut | |
1644 | ||
1645 | # Non-socket. | |
1646 | else { | |
e22ea7cc | 1647 | |
69893cff RGS |
1648 | # Two debuggers running (probably a system or a backtick that invokes |
1649 | # the debugger itself under the running one). create a new IN and OUT | |
e22ea7cc | 1650 | # filehandle, and do the necessary mojo to create a new tty if we |
69893cff | 1651 | # know how, and we can. |
e22ea7cc RF |
1652 | create_IN_OUT(4) if $CreateTTY & 4; |
1653 | if ($console) { | |
1654 | ||
69893cff | 1655 | # If we have a console, check to see if there are separate ins and |
cd1191f1 | 1656 | # outs to open. (They are assumed identical if not.) |
69893cff | 1657 | |
e22ea7cc RF |
1658 | my ( $i, $o ) = split /,/, $console; |
1659 | $o = $i unless defined $o; | |
69893cff | 1660 | |
69893cff | 1661 | # read/write on in, or just read, or read on STDIN. |
1ae6ead9 JL |
1662 | open( IN, '+<', $i ) |
1663 | || open( IN, '<', $i ) | |
e22ea7cc RF |
1664 | || open( IN, "<&STDIN" ); |
1665 | ||
69893cff RGS |
1666 | # read/write/create/clobber out, or write/create/clobber out, |
1667 | # or merge with STDERR, or merge with STDOUT. | |
1ae6ead9 JL |
1668 | open( OUT, '+>', $o ) |
1669 | || open( OUT, '>', $o ) | |
e22ea7cc RF |
1670 | || open( OUT, ">&STDERR" ) |
1671 | || open( OUT, ">&STDOUT" ); # so we don't dongle stdout | |
1672 | ||
1673 | } ## end if ($console) | |
1674 | elsif ( not defined $console ) { | |
1675 | ||
1676 | # No console. Open STDIN. | |
1677 | open( IN, "<&STDIN" ); | |
1678 | ||
1679 | # merge with STDERR, or with STDOUT. | |
1680 | open( OUT, ">&STDERR" ) | |
1681 | || open( OUT, ">&STDOUT" ); # so we don't dongle stdout | |
1682 | $console = 'STDIN/OUT'; | |
69893cff RGS |
1683 | } ## end elsif (not defined $console) |
1684 | ||
1685 | # Keep copies of the filehandles so that when the pager runs, it | |
1686 | # can close standard input without clobbering ours. | |
2b0b9dd1 SF |
1687 | if ($console or (not defined($console))) { |
1688 | $IN = \*IN; | |
1689 | $OUT = \*OUT; | |
1690 | } | |
e22ea7cc RF |
1691 | } ## end elsif (from if(defined $remoteport)) |
1692 | ||
1693 | # Unbuffer DB::OUT. We need to see responses right away. | |
e0047406 | 1694 | _autoflush($OUT); |
e22ea7cc RF |
1695 | |
1696 | # Line info goes to debugger output unless pointed elsewhere. | |
1697 | # Pointing elsewhere makes it possible for slave editors to | |
1698 | # keep track of file and position. We have both a filehandle | |
1699 | # and a I/O description to keep track of. | |
1700 | $LINEINFO = $OUT unless defined $LINEINFO; | |
1701 | $lineinfo = $console unless defined $lineinfo; | |
2dbd01ad SF |
1702 | # share($LINEINFO); # <- unable to share globs |
1703 | share($lineinfo); # | |
e22ea7cc | 1704 | |
69893cff RGS |
1705 | =pod |
1706 | ||
1707 | To finish initialization, we show the debugger greeting, | |
1708 | and then call the C<afterinit()> subroutine if there is one. | |
1709 | ||
1710 | =cut | |
d12a4851 | 1711 | |
e22ea7cc RF |
1712 | # Show the debugger greeting. |
1713 | $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/; | |
1714 | unless ($runnonstop) { | |
1715 | local $\ = ''; | |
1716 | local $, = ''; | |
1717 | if ( $term_pid eq '-1' ) { | |
1718 | print $OUT "\nDaughter DB session started...\n"; | |
1719 | } | |
1720 | else { | |
1721 | print $OUT "\nLoading DB routines from $header\n"; | |
1722 | print $OUT ( | |
1723 | "Editor support ", | |
1724 | $slave_editor ? "enabled" : "available", ".\n" | |
1725 | ); | |
1726 | print $OUT | |
1f874cb6 | 1727 | "\nEnter h or 'h h' for help, or '$doccmd perldebug' for more help.\n\n"; |
69893cff RGS |
1728 | } ## end else [ if ($term_pid eq '-1') |
1729 | } ## end unless ($runnonstop) | |
1730 | } ## end else [ if ($notty) | |
1731 | ||
1732 | # XXX This looks like a bug to me. | |
1733 | # Why copy to @ARGS and then futz with @args? | |
d338d6fe | 1734 | @ARGS = @ARGV; |
6b24a4b7 | 1735 | # for (@args) { |
69893cff RGS |
1736 | # Make sure backslashes before single quotes are stripped out, and |
1737 | # keep args unless they are numeric (XXX why?) | |
e22ea7cc RF |
1738 | # s/\'/\\\'/g; # removed while not justified understandably |
1739 | # s/(.*)/'$1'/ unless /^-?[\d.]+$/; # ditto | |
6b24a4b7 | 1740 | # } |
d338d6fe | 1741 | |
e22ea7cc | 1742 | # If there was an afterinit() sub defined, call it. It will get |
69893cff | 1743 | # executed in our scope, so it can fiddle with debugger globals. |
e22ea7cc | 1744 | if ( defined &afterinit ) { # May be defined in $rcfile |
2b0b9dd1 | 1745 | afterinit(); |
d338d6fe | 1746 | } |
e22ea7cc | 1747 | |
69893cff | 1748 | # Inform us about "Stack dump during die enabled ..." in dieLevel(). |
6b24a4b7 SF |
1749 | use vars qw($I_m_init); |
1750 | ||
43aed9ee IZ |
1751 | $I_m_init = 1; |
1752 | ||
d338d6fe | 1753 | ############################################################ Subroutines |
1754 | ||
69893cff RGS |
1755 | =head1 SUBROUTINES |
1756 | ||
1757 | =head2 DB | |
1758 | ||
1759 | This gigantic subroutine is the heart of the debugger. Called before every | |
1760 | statement, its job is to determine if a breakpoint has been reached, and | |
1761 | stop if so; read commands from the user, parse them, and execute | |
b468dcb6 | 1762 | them, and then send execution off to the next statement. |
69893cff RGS |
1763 | |
1764 | Note that the order in which the commands are processed is very important; | |
1765 | some commands earlier in the loop will actually alter the C<$cmd> variable | |
be9a9b1d | 1766 | to create other commands to be executed later. This is all highly I<optimized> |
69893cff RGS |
1767 | but can be confusing. Check the comments for each C<$cmd ... && do {}> to |
1768 | see what's happening in any given command. | |
1769 | ||
1770 | =cut | |
1771 | ||
136ae23d SF |
1772 | # $cmd cannot be an our() variable unfortunately (possible perl bug?). |
1773 | ||
6b24a4b7 SF |
1774 | use vars qw( |
1775 | $action | |
6b24a4b7 | 1776 | $cmd |
6b24a4b7 SF |
1777 | $file |
1778 | $filename_ini | |
1779 | $finished | |
1780 | %had_breakpoints | |
6b24a4b7 SF |
1781 | $level |
1782 | $max | |
6b24a4b7 | 1783 | $package |
6b24a4b7 SF |
1784 | $try |
1785 | ); | |
1786 | ||
1ce985d2 | 1787 | our ( |
bdb3f37d | 1788 | %alias, |
1ce985d2 | 1789 | $doret, |
0664c09a | 1790 | $end, |
4d0e1f38 | 1791 | $fall_off_end, |
d1450c23 | 1792 | $incr, |
73c5e526 | 1793 | $laststep, |
14f38b27 | 1794 | $rc, |
ddf4cf26 | 1795 | $sh, |
1ce985d2 SF |
1796 | $stack_depth, |
1797 | @stack, | |
1798 | @to_watch, | |
1799 | @old_watch, | |
1800 | ); | |
8ad70697 | 1801 | |
6791e41b SF |
1802 | sub _DB__determine_if_we_should_break |
1803 | { | |
1804 | # if we have something here, see if we should break. | |
1805 | # $stop is lexical and local to this block - $action on the other hand | |
1806 | # is global. | |
1807 | my $stop; | |
1808 | ||
1809 | if ( $dbline{$line} | |
1810 | && _is_breakpoint_enabled($filename, $line) | |
1811 | && (( $stop, $action ) = split( /\0/, $dbline{$line} ) ) ) | |
1812 | { | |
1813 | ||
1814 | # Stop if the stop criterion says to just stop. | |
1815 | if ( $stop eq '1' ) { | |
1816 | $signal |= 1; | |
1817 | } | |
1818 | ||
1819 | # It's a conditional stop; eval it in the user's context and | |
1820 | # see if we should stop. If so, remove the one-time sigil. | |
1821 | elsif ($stop) { | |
1822 | $evalarg = "\$DB::signal |= 1 if do {$stop}"; | |
e0cd3692 SF |
1823 | # The &-call is here to ascertain the mutability of @_. |
1824 | &DB::eval; | |
6791e41b SF |
1825 | # If the breakpoint is temporary, then delete its enabled status. |
1826 | if ($dbline{$line} =~ s/;9($|\0)/$1/) { | |
1827 | _cancel_breakpoint_temp_enabled_status($filename, $line); | |
1828 | } | |
1829 | } | |
1830 | } ## end if ($dbline{$line} && ... | |
1831 | } | |
1832 | ||
8481f647 SF |
1833 | sub _DB__is_finished { |
1834 | if ($finished and $level <= 1) { | |
1835 | end_report(); | |
1836 | return 1; | |
1837 | } | |
1838 | else { | |
1839 | return; | |
1840 | } | |
1841 | } | |
1842 | ||
32bbadc6 SF |
1843 | sub _DB__read_next_cmd |
1844 | { | |
1845 | my ($tid) = @_; | |
1846 | ||
1847 | # We have a terminal, or can get one ... | |
1848 | if (!$term) { | |
1849 | setterm(); | |
1850 | } | |
1851 | ||
7e3426ea | 1852 | # ... and it belongs to this PID or we get one for this PID ... |
32bbadc6 SF |
1853 | if ($term_pid != $$) { |
1854 | resetterm(1); | |
1855 | } | |
1856 | ||
1857 | # ... and we got a line of command input ... | |
1858 | $cmd = DB::readline( | |
1859 | "$pidprompt $tid DB" | |
1860 | . ( '<' x $level ) | |
1861 | . ( $#hist + 1 ) | |
1862 | . ( '>' x $level ) . " " | |
1863 | ); | |
1864 | ||
1865 | return defined($cmd); | |
1866 | } | |
1867 | ||
7013f40c | 1868 | sub _DB__trim_command_and_return_first_component { |
af84fb69 SF |
1869 | my ($obj) = @_; |
1870 | ||
7013f40c SF |
1871 | $cmd =~ s/\A\s+//s; # trim annoying leading whitespace |
1872 | $cmd =~ s/\s+\z//s; # trim annoying trailing whitespace | |
1873 | ||
7fdd4f08 S |
1874 | # A single-character debugger command can be immediately followed by its |
1875 | # argument if they aren't both alphanumeric; otherwise require space | |
1876 | # between commands and arguments: | |
1877 | my ($verb, $args) = $cmd =~ m{\A(.\b|\S*)\s*(.*)}s; | |
af84fb69 | 1878 | |
3249b113 SF |
1879 | $obj->cmd_verb($verb); |
1880 | $obj->cmd_args($args); | |
af84fb69 SF |
1881 | |
1882 | return; | |
7013f40c SF |
1883 | } |
1884 | ||
2a802473 | 1885 | sub _DB__handle_f_command { |
a30f63cd | 1886 | my ($obj) = @_; |
2a802473 | 1887 | |
a30f63cd | 1888 | if ($file = $obj->cmd_args) { |
2a802473 SF |
1889 | # help for no arguments (old-style was return from sub). |
1890 | if ( !$file ) { | |
1891 | print $OUT | |
1892 | "The old f command is now the r command.\n"; # hint | |
1893 | print $OUT "The new f command switches filenames.\n"; | |
1894 | next CMD; | |
1895 | } ## end if (!$file) | |
1896 | ||
1897 | # if not in magic file list, try a close match. | |
1898 | if ( !defined $main::{ '_<' . $file } ) { | |
1899 | if ( ($try) = grep( m#^_<.*$file#, keys %main:: ) ) { | |
1900 | { | |
1901 | $try = substr( $try, 2 ); | |
1902 | print $OUT "Choosing $try matching '$file':\n"; | |
1903 | $file = $try; | |
1904 | } | |
1905 | } ## end if (($try) = grep(m#^_<.*$file#... | |
1906 | } ## end if (!defined $main::{ ... | |
1907 | ||
1908 | # If not successfully switched now, we failed. | |
1909 | if ( !defined $main::{ '_<' . $file } ) { | |
1910 | print $OUT "No file matching '$file' is loaded.\n"; | |
1911 | next CMD; | |
1912 | } | |
1913 | ||
1914 | # We switched, so switch the debugger internals around. | |
1915 | elsif ( $file ne $filename ) { | |
1916 | *dbline = $main::{ '_<' . $file }; | |
1917 | $max = $#dbline; | |
1918 | $filename = $file; | |
1919 | $start = 1; | |
1920 | $cmd = "l"; | |
1921 | } ## end elsif ($file ne $filename) | |
1922 | ||
1923 | # We didn't switch; say we didn't. | |
1924 | else { | |
1925 | print $OUT "Already in $file.\n"; | |
1926 | next CMD; | |
1927 | } | |
1928 | } | |
1929 | ||
1930 | return; | |
1931 | } | |
1932 | ||
6115a173 SF |
1933 | sub _DB__handle_dot_command { |
1934 | my ($obj) = @_; | |
1935 | ||
1936 | # . command. | |
601c6a23 | 1937 | if ($obj->_is_full('.')) { |
6115a173 SF |
1938 | $incr = -1; # stay at current line |
1939 | ||
1940 | # Reset everything to the old location. | |
1941 | $start = $line; | |
1942 | $filename = $filename_ini; | |
1943 | *dbline = $main::{ '_<' . $filename }; | |
1944 | $max = $#dbline; | |
1945 | ||
1946 | # Now where are we? | |
1947 | print_lineinfo($obj->position()); | |
1948 | next CMD; | |
1949 | } | |
1950 | ||
1951 | return; | |
1952 | } | |
1953 | ||
5c2b78e7 SF |
1954 | sub _DB__handle_y_command { |
1955 | my ($obj) = @_; | |
1956 | ||
1957 | if (my ($match_level, $match_vars) | |
9875a6d2 | 1958 | = $obj->cmd_args =~ /\A(?:(\d*)\s*(.*))?\z/) { |
5c2b78e7 SF |
1959 | |
1960 | # See if we've got the necessary support. | |
db79bf92 TC |
1961 | if (!eval { |
1962 | local @INC = @INC; | |
1963 | pop @INC if $INC[-1] eq '.'; | |
1964 | require PadWalker; PadWalker->VERSION(0.08) }) { | |
84e7f475 | 1965 | my $Err = $@; |
b5679dc0 | 1966 | _db_warn( |
84e7f475 SF |
1967 | $Err =~ /locate/ |
1968 | ? "PadWalker module not found - please install\n" | |
1969 | : $Err | |
1970 | ); | |
1971 | next CMD; | |
1972 | } | |
5c2b78e7 SF |
1973 | |
1974 | # Load up dumpvar if we don't have it. If we can, that is. | |
1975 | do 'dumpvar.pl' || die $@ unless defined &main::dumpvar; | |
1976 | defined &main::dumpvar | |
1977 | or print $OUT "dumpvar.pl not available.\n" | |
1978 | and next CMD; | |
1979 | ||
1980 | # Got all the modules we need. Find them and print them. | |
1981 | my @vars = split( ' ', $match_vars || '' ); | |
1982 | ||
1983 | # Find the pad. | |
496f5ba5 | 1984 | my $h = eval { PadWalker::peek_my( ( $match_level || 0 ) + 2 ) }; |
5c2b78e7 SF |
1985 | |
1986 | # Oops. Can't find it. | |
84e7f475 SF |
1987 | if (my $Err = $@) { |
1988 | $Err =~ s/ at .*//; | |
b5679dc0 | 1989 | _db_warn($Err); |
84e7f475 SF |
1990 | next CMD; |
1991 | } | |
5c2b78e7 SF |
1992 | |
1993 | # Show the desired vars with dumplex(). | |
1994 | my $savout = select($OUT); | |
1995 | ||
1996 | # Have dumplex dump the lexicals. | |
84e7f475 SF |
1997 | foreach my $key (sort keys %$h) { |
1998 | dumpvar::dumplex( $key, $h->{$key}, | |
1999 | defined $option{dumpDepth} ? $option{dumpDepth} : -1, | |
2000 | @vars ); | |
2001 | } | |
5c2b78e7 SF |
2002 | select($savout); |
2003 | next CMD; | |
2004 | } | |
2005 | } | |
2006 | ||
35cd713a SF |
2007 | sub _DB__handle_c_command { |
2008 | my ($obj) = @_; | |
2009 | ||
a523ec7c | 2010 | my $i = $obj->cmd_args; |
35cd713a | 2011 | |
a523ec7c | 2012 | if ($i =~ m#\A[\w:]*\z#) { |
35cd713a SF |
2013 | |
2014 | # Hey, show's over. The debugged program finished | |
2015 | # executing already. | |
2016 | next CMD if _DB__is_finished(); | |
2017 | ||
2018 | # Capture the place to put a one-time break. | |
a523ec7c | 2019 | $subname = $i; |
35cd713a SF |
2020 | |
2021 | # Probably not needed, since we finish an interactive | |
2022 | # sub-session anyway... | |
2023 | # local $filename = $filename; | |
2024 | # local *dbline = *dbline; # XXX Would this work?! | |
2025 | # | |
2026 | # The above question wonders if localizing the alias | |
2027 | # to the magic array works or not. Since it's commented | |
2028 | # out, we'll just leave that to speculation for now. | |
2029 | ||
2030 | # If the "subname" isn't all digits, we'll assume it | |
2031 | # is a subroutine name, and try to find it. | |
2032 | if ( $subname =~ /\D/ ) { # subroutine name | |
2033 | # Qualify it to the current package unless it's | |
2034 | # already qualified. | |
2035 | $subname = $package . "::" . $subname | |
2036 | unless $subname =~ /::/; | |
2037 | ||
2038 | # find_sub will return "file:line_number" corresponding | |
2039 | # to where the subroutine is defined; we call find_sub, | |
2040 | # break up the return value, and assign it in one | |
2041 | # operation. | |
a523ec7c | 2042 | ( $file, $i ) = ( find_sub($subname) =~ /^(.*):(.*)$/ ); |
35cd713a SF |
2043 | |
2044 | # Force the line number to be numeric. | |
a523ec7c | 2045 | $i = $i + 0; |
35cd713a SF |
2046 | |
2047 | # If we got a line number, we found the sub. | |
a523ec7c | 2048 | if ($i) { |
35cd713a SF |
2049 | |
2050 | # Switch all the debugger's internals around so | |
2051 | # we're actually working with that file. | |
2052 | $filename = $file; | |
2053 | *dbline = $main::{ '_<' . $filename }; | |
2054 | ||
2055 | # Mark that there's a breakpoint in this file. | |
2056 | $had_breakpoints{$filename} |= 1; | |
2057 | ||
2058 | # Scan forward to the first executable line | |
2059 | # after the 'sub whatever' line. | |
2060 | $max = $#dbline; | |
a523ec7c | 2061 | my $_line_num = $i; |
9c6fceaf SF |
2062 | while ($dbline[$_line_num] == 0 && $_line_num< $max) |
2063 | { | |
2064 | $_line_num++; | |
2065 | } | |
a523ec7c | 2066 | $i = $_line_num; |
35cd713a SF |
2067 | } ## end if ($i) |
2068 | ||
2069 | # We didn't find a sub by that name. | |
2070 | else { | |
2071 | print $OUT "Subroutine $subname not found.\n"; | |
2072 | next CMD; | |
2073 | } | |
2074 | } ## end if ($subname =~ /\D/) | |
2075 | ||
2076 | # At this point, either the subname was all digits (an | |
2077 | # absolute line-break request) or we've scanned through | |
2078 | # the code following the definition of the sub, looking | |
2079 | # for an executable, which we may or may not have found. | |
2080 | # | |
2081 | # If $i (which we set $subname from) is non-zero, we | |
2082 | # got a request to break at some line somewhere. On | |
2083 | # one hand, if there wasn't any real subroutine name | |
2084 | # involved, this will be a request to break in the current | |
2085 | # file at the specified line, so we have to check to make | |
2086 | # sure that the line specified really is breakable. | |
2087 | # | |
2088 | # On the other hand, if there was a subname supplied, the | |
2089 | # preceding block has moved us to the proper file and | |
2090 | # location within that file, and then scanned forward | |
2091 | # looking for the next executable line. We have to make | |
2092 | # sure that one was found. | |
2093 | # | |
2094 | # On the gripping hand, we can't do anything unless the | |
2095 | # current value of $i points to a valid breakable line. | |
2096 | # Check that. | |
a523ec7c | 2097 | if ($i) { |
35cd713a SF |
2098 | |
2099 | # Breakable? | |
a523ec7c SF |
2100 | if ( $dbline[$i] == 0 ) { |
2101 | print $OUT "Line $i not breakable.\n"; | |
35cd713a SF |
2102 | next CMD; |
2103 | } | |
2104 | ||
2105 | # Yes. Set up the one-time-break sigil. | |
a523ec7c SF |
2106 | $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p. |
2107 | _enable_breakpoint_temp_enabled_status($filename, $i); | |
35cd713a SF |
2108 | } ## end if ($i) |
2109 | ||
2110 | # Turn off stack tracing from here up. | |
a523ec7c SF |
2111 | for my $j (0 .. $stack_depth) { |
2112 | $stack[ $j ] &= ~1; | |
35cd713a SF |
2113 | } |
2114 | last CMD; | |
2115 | } | |
2116 | ||
2117 | return; | |
2118 | } | |
2119 | ||
a4d311a3 SF |
2120 | sub _DB__handle_forward_slash_command { |
2121 | my ($obj) = @_; | |
2122 | ||
2123 | # The pattern as a string. | |
2124 | use vars qw($inpat); | |
2125 | ||
2126 | if (($inpat) = $cmd =~ m#\A/(.*)\z#) { | |
2127 | ||
2128 | # Remove the final slash. | |
2129 | $inpat =~ s:([^\\])/$:$1:; | |
2130 | ||
2131 | # If the pattern isn't null ... | |
2132 | if ( $inpat ne "" ) { | |
2133 | ||
7e3426ea | 2134 | # Turn off warn and die processing for a bit. |
a4d311a3 SF |
2135 | local $SIG{__DIE__}; |
2136 | local $SIG{__WARN__}; | |
2137 | ||
2138 | # Create the pattern. | |
2139 | eval 'no strict q/vars/; $inpat =~ m' . "\a$inpat\a"; | |
2140 | if ( $@ ne "" ) { | |
2141 | ||
2142 | # Oops. Bad pattern. No biscuit. | |
2143 | # Print the eval error and go back for more | |
2144 | # commands. | |
72c017e3 | 2145 | print {$OUT} "$@"; |
a4d311a3 SF |
2146 | next CMD; |
2147 | } | |
2148 | $obj->pat($inpat); | |
2149 | } ## end if ($inpat ne "") | |
2150 | ||
2151 | # Set up to stop on wrap-around. | |
2152 | $end = $start; | |
2153 | ||
2154 | # Don't move off the current line. | |
2155 | $incr = -1; | |
2156 | ||
2157 | my $pat = $obj->pat; | |
2158 | ||
2159 | # Done in eval so nothing breaks if the pattern | |
2160 | # does something weird. | |
2161 | eval | |
2162 | { | |
2163 | no strict q/vars/; | |
2164 | for (;;) { | |
2165 | # Move ahead one line. | |
2166 | ++$start; | |
2167 | ||
2168 | # Wrap if we pass the last line. | |
72c017e3 SF |
2169 | if ($start > $max) { |
2170 | $start = 1; | |
2171 | } | |
a4d311a3 SF |
2172 | |
2173 | # Stop if we have gotten back to this line again, | |
2174 | last if ($start == $end); | |
2175 | ||
2176 | # A hit! (Note, though, that we are doing | |
2177 | # case-insensitive matching. Maybe a qr// | |
2178 | # expression would be better, so the user could | |
2179 | # do case-sensitive matching if desired. | |
2180 | if ($dbline[$start] =~ m/$pat/i) { | |
2181 | if ($slave_editor) { | |
2182 | # Handle proper escaping in the slave. | |
72c017e3 | 2183 | print {$OUT} "\032\032$filename:$start:0\n"; |
a4d311a3 SF |
2184 | } |
2185 | else { | |
2186 | # Just print the line normally. | |
72c017e3 | 2187 | print {$OUT} "$start:\t",$dbline[$start],"\n"; |
a4d311a3 SF |
2188 | } |
2189 | # And quit since we found something. | |
2190 | last; | |
2191 | } | |
2192 | } | |
2193 | }; | |
2194 | ||
2195 | if ($@) { | |
2196 | warn $@; | |
2197 | } | |
2198 | ||
2199 | # If we wrapped, there never was a match. | |
2200 | if ( $start == $end ) { | |
2201 | print {$OUT} "/$pat/: not found\n"; | |
2202 | } | |
2203 | next CMD; | |
2204 | } | |
2205 | ||
2206 | return; | |
2207 | } | |
2208 | ||
11f0f050 SF |
2209 | sub _DB__handle_question_mark_command { |
2210 | my ($obj) = @_; | |
2211 | ||
2212 | # ? - backward pattern search. | |
2213 | if (my ($inpat) = $cmd =~ m#\A\?(.*)\z#) { | |
2214 | ||
2215 | # Get the pattern, remove trailing question mark. | |
2216 | $inpat =~ s:([^\\])\?$:$1:; | |
2217 | ||
2218 | # If we've got one ... | |
2219 | if ( $inpat ne "" ) { | |
2220 | ||
2221 | # Turn off die & warn handlers. | |
2222 | local $SIG{__DIE__}; | |
2223 | local $SIG{__WARN__}; | |
2224 | eval '$inpat =~ m' . "\a$inpat\a"; | |
2225 | ||
2226 | if ( $@ ne "" ) { | |
2227 | ||
2228 | # Ouch. Not good. Print the error. | |
2229 | print $OUT $@; | |
2230 | next CMD; | |
2231 | } | |
2232 | $obj->pat($inpat); | |
2233 | } ## end if ($inpat ne "") | |
2234 | ||
2235 | # Where we are now is where to stop after wraparound. | |
2236 | $end = $start; | |
2237 | ||
2238 | # Don't move away from this line. | |
2239 | $incr = -1; | |
2240 | ||
2241 | my $pat = $obj->pat; | |
2242 | # Search inside the eval to prevent pattern badness | |
2243 | # from killing us. | |
2244 | eval { | |
2245 | no strict q/vars/; | |
2246 | for (;;) { | |
2247 | # Back up a line. | |
2248 | --$start; | |
2249 | ||
2250 | # Wrap if we pass the first line. | |
2251 | ||
2252 | $start = $max if ($start <= 0); | |
2253 | ||
2254 | # Quit if we get back where we started, | |
2255 | last if ($start == $end); | |
2256 | ||
2257 | # Match? | |
2258 | if ($dbline[$start] =~ m/$pat/i) { | |
2259 | if ($slave_editor) { | |
2260 | # Yep, follow slave editor requirements. | |
2261 | print $OUT "\032\032$filename:$start:0\n"; | |
2262 | } | |
2263 | else { | |
2264 | # Yep, just print normally. | |
2265 | print $OUT "$start:\t",$dbline[$start],"\n"; | |
2266 | } | |
2267 | ||
2268 | # Found, so done. | |
2269 | last; | |
2270 | } | |
2271 | } | |
2272 | }; | |
2273 | ||
2274 | # Say we failed if the loop never found anything, | |
2275 | if ( $start == $end ) { | |
2276 | print {$OUT} "?$pat?: not found\n"; | |
2277 | } | |
2278 | next CMD; | |
2279 | } | |
2280 | ||
2281 | return; | |
2282 | } | |
2283 | ||
5f166812 SF |
2284 | sub _DB__handle_restart_and_rerun_commands { |
2285 | my ($obj) = @_; | |
2286 | ||
b9920278 SF |
2287 | my $cmd_cmd = $obj->cmd_verb; |
2288 | my $cmd_params = $obj->cmd_args; | |
5f166812 SF |
2289 | # R - restart execution. |
2290 | # rerun - controlled restart execution. | |
b9920278 | 2291 | if ($cmd_cmd eq 'rerun' or $cmd_params eq '') { |
c59f1e04 SF |
2292 | |
2293 | # Change directory to the initial current working directory on | |
2294 | # the script startup, so if the debugged program changed the | |
2295 | # directory, then we will still be able to find the path to the | |
2296 | # the program. (perl 5 RT #121509 ). | |
2297 | chdir ($_initial_cwd); | |
2298 | ||
5f166812 SF |
2299 | my @args = ($cmd_cmd eq 'R' ? restart() : rerun($cmd_params)); |
2300 | ||
2301 | # Close all non-system fds for a clean restart. A more | |
2302 | # correct method would be to close all fds that were not | |
2303 | # open when the process started, but this seems to be | |
2304 | # hard. See "debugger 'R'estart and open database | |
2305 | # connections" on p5p. | |
2306 | ||
2307 | my $max_fd = 1024; # default if POSIX can't be loaded | |
2308 | if (eval { require POSIX }) { | |
2309 | eval { $max_fd = POSIX::sysconf(POSIX::_SC_OPEN_MAX()) }; | |
2310 | } | |
2311 | ||
2312 | if (defined $max_fd) { | |
2313 | foreach ($^F+1 .. $max_fd-1) { | |
2314 | next unless open FD_TO_CLOSE, "<&=$_"; | |
2315 | close(FD_TO_CLOSE); | |
2316 | } | |
2317 | } | |
2318 | ||
2319 | # And run Perl again. We use exec() to keep the | |
2320 | # PID stable (and that way $ini_pids is still valid). | |
2321 | exec(@args) or print {$OUT} "exec failed: $!\n"; | |
2322 | ||
2323 | last CMD; | |
2324 | } | |
2325 | ||
2326 | return; | |
2327 | } | |
2328 | ||
33f361f5 SF |
2329 | sub _DB__handle_run_command_in_pager_command { |
2330 | my ($obj) = @_; | |
2331 | ||
2332 | if ($cmd =~ m#\A\|\|?\s*[^|]#) { | |
2333 | if ( $pager =~ /^\|/ ) { | |
2334 | ||
2335 | # Default pager is into a pipe. Redirect I/O. | |
2336 | open( SAVEOUT, ">&STDOUT" ) | |
b5679dc0 | 2337 | || _db_warn("Can't save STDOUT"); |
33f361f5 | 2338 | open( STDOUT, ">&OUT" ) |
b5679dc0 | 2339 | || _db_warn("Can't redirect STDOUT"); |
33f361f5 SF |
2340 | } ## end if ($pager =~ /^\|/) |
2341 | else { | |
2342 | ||
2343 | # Not into a pipe. STDOUT is safe. | |
b5679dc0 | 2344 | open( SAVEOUT, ">&OUT" ) || _db_warn("Can't save DB::OUT"); |
33f361f5 SF |
2345 | } |
2346 | ||
2347 | # Fix up environment to record we have less if so. | |
2348 | fix_less(); | |
2349 | ||
2350 | unless ( $obj->piped(scalar ( open( OUT, $pager ) ) ) ) { | |
2351 | ||
2352 | # Couldn't open pipe to pager. | |
b5679dc0 | 2353 | _db_warn("Can't pipe output to '$pager'"); |
33f361f5 SF |
2354 | if ( $pager =~ /^\|/ ) { |
2355 | ||
2356 | # Redirect I/O back again. | |
2357 | open( OUT, ">&STDOUT" ) # XXX: lost message | |
b5679dc0 | 2358 | || _db_warn("Can't restore DB::OUT"); |
33f361f5 | 2359 | open( STDOUT, ">&SAVEOUT" ) |
b5679dc0 | 2360 | || _db_warn("Can't restore STDOUT"); |
33f361f5 SF |
2361 | close(SAVEOUT); |
2362 | } ## end if ($pager =~ /^\|/) | |
2363 | else { | |
2364 | ||
2365 | # Redirect I/O. STDOUT already safe. | |
2366 | open( OUT, ">&STDOUT" ) # XXX: lost message | |
b5679dc0 | 2367 | || _db_warn("Can't restore DB::OUT"); |
33f361f5 SF |
2368 | } |
2369 | next CMD; | |
2370 | } ## end unless ($piped = open(OUT,... | |
2371 | ||
2372 | # Set up broken-pipe handler if necessary. | |
2373 | $SIG{PIPE} = \&DB::catch | |
2374 | if $pager =~ /^\|/ | |
2375 | && ( "" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE} ); | |
2376 | ||
e0047406 | 2377 | _autoflush(\*OUT); |
33f361f5 SF |
2378 | # Save current filehandle, and put it back. |
2379 | $obj->selected(scalar( select(OUT) )); | |
2380 | # Don't put it back if pager was a pipe. | |
2381 | if ($cmd !~ /\A\|\|/) | |
2382 | { | |
2383 | select($obj->selected()); | |
2384 | $obj->selected(""); | |
2385 | } | |
2386 | ||
2387 | # Trim off the pipe symbols and run the command now. | |
2388 | $cmd =~ s#\A\|+\s*##; | |
2389 | redo PIPE; | |
2390 | } | |
2391 | ||
2392 | return; | |
2393 | } | |
2394 | ||
321095c5 SF |
2395 | sub _DB__handle_m_command { |
2396 | my ($obj) = @_; | |
2397 | ||
2398 | if ($cmd =~ s#\Am\s+([\w:]+)\s*\z# #) { | |
2399 | methods($1); | |
2400 | next CMD; | |
2401 | } | |
2402 | ||
2403 | # m expr - set up DB::eval to do the work | |
2404 | if ($cmd =~ s#\Am\b# #) { # Rest gets done by DB::eval() | |
2405 | $onetimeDump = 'methods'; # method output gets used there | |
2406 | } | |
2407 | ||
2408 | return; | |
2409 | } | |
33f361f5 | 2410 | |
8e4cceb9 SF |
2411 | sub _DB__at_end_of_every_command { |
2412 | my ($obj) = @_; | |
2413 | ||
2414 | # At the end of every command: | |
2415 | if ($obj->piped) { | |
2416 | ||
2417 | # Unhook the pipe mechanism now. | |
2418 | if ( $pager =~ /^\|/ ) { | |
2419 | ||
2420 | # No error from the child. | |
2421 | $? = 0; | |
2422 | ||
2423 | # we cannot warn here: the handle is missing --tchrist | |
2424 | close(OUT) || print SAVEOUT "\nCan't close DB::OUT\n"; | |
2425 | ||
2426 | # most of the $? crud was coping with broken cshisms | |
2427 | # $? is explicitly set to 0, so this never runs. | |
2428 | if ($?) { | |
2429 | print SAVEOUT "Pager '$pager' failed: "; | |
2430 | if ( $? == -1 ) { | |
2431 | print SAVEOUT "shell returned -1\n"; | |
2432 | } | |
2433 | elsif ( $? >> 8 ) { | |
2434 | print SAVEOUT ( $? & 127 ) | |
2435 | ? " (SIG#" . ( $? & 127 ) . ")" | |
2436 | : "", ( $? & 128 ) ? " -- core dumped" : "", "\n"; | |
2437 | } | |
2438 | else { | |
2439 | print SAVEOUT "status ", ( $? >> 8 ), "\n"; | |
2440 | } | |
2441 | } ## end if ($?) | |
2442 | ||
2443 | # Reopen filehandle for our output (if we can) and | |
2444 | # restore STDOUT (if we can). | |
b5679dc0 | 2445 | open( OUT, ">&STDOUT" ) || _db_warn("Can't restore DB::OUT"); |
8e4cceb9 | 2446 | open( STDOUT, ">&SAVEOUT" ) |
b5679dc0 | 2447 | || _db_warn("Can't restore STDOUT"); |
8e4cceb9 SF |
2448 | |
2449 | # Turn off pipe exception handler if necessary. | |
2450 | $SIG{PIPE} = "DEFAULT" if $SIG{PIPE} eq \&DB::catch; | |
2451 | ||
2452 | # Will stop ignoring SIGPIPE if done like nohup(1) | |
2453 | # does SIGINT but Perl doesn't give us a choice. | |
2454 | } ## end if ($pager =~ /^\|/) | |
2455 | else { | |
2456 | ||
2457 | # Non-piped "pager". Just restore STDOUT. | |
b5679dc0 | 2458 | open( OUT, ">&SAVEOUT" ) || _db_warn("Can't restore DB::OUT"); |
8e4cceb9 SF |
2459 | } |
2460 | ||
9b534162 HH |
2461 | # Let Readline know about the new filehandles. |
2462 | reset_IN_OUT( \*IN, \*OUT ); | |
2463 | ||
8e4cceb9 SF |
2464 | # Close filehandle pager was using, restore the normal one |
2465 | # if necessary, | |
2466 | close(SAVEOUT); | |
2467 | ||
2468 | if ($obj->selected() ne "") { | |
2469 | select($obj->selected); | |
2470 | $obj->selected(""); | |
2471 | } | |
2472 | ||
2473 | # No pipes now. | |
2474 | $obj->piped(""); | |
2475 | } ## end if ($piped) | |
2476 | ||
2477 | return; | |
2478 | } | |
2479 | ||
5f5eab52 SF |
2480 | sub _DB__handle_watch_expressions |
2481 | { | |
2482 | my $self = shift; | |
2483 | ||
2484 | if ( $DB::trace & 2 ) { | |
2485 | for my $n (0 .. $#DB::to_watch) { | |
2486 | $DB::evalarg = $DB::to_watch[$n]; | |
2487 | local $DB::onetimeDump; # Tell DB::eval() to not output results | |
2488 | ||
2489 | # Fix context DB::eval() wants to return an array, but | |
2490 | # we need a scalar here. | |
2491 | my ($val) = join( "', '", DB::eval(@_) ); | |
2492 | $val = ( ( defined $val ) ? "'$val'" : 'undef' ); | |
2493 | ||
2494 | # Did it change? | |
2495 | if ( $val ne $DB::old_watch[$n] ) { | |
2496 | ||
2497 | # Yep! Show the difference, and fake an interrupt. | |
2498 | $DB::signal = 1; | |
2499 | print {$DB::OUT} <<EOP; | |
2500 | Watchpoint $n:\t$DB::to_watch[$n] changed: | |
2501 | old value:\t$DB::old_watch[$n] | |
2502 | new value:\t$val | |
2503 | EOP | |
2504 | $DB::old_watch[$n] = $val; | |
2505 | } ## end if ($val ne $old_watch... | |
2506 | } ## end for my $n (0 .. | |
2507 | } ## end if ($trace & 2) | |
2508 | ||
2509 | return; | |
2510 | } | |
2511 | ||
47e3b8cc SF |
2512 | # 't' is type. |
2513 | # 'm' is method. | |
2514 | # 'v' is the value (i.e: method name or subroutine ref). | |
2515 | # 's' is subroutine. | |
23053931 SF |
2516 | my %cmd_lookup; |
2517 | ||
2518 | BEGIN | |
2519 | { | |
2520 | %cmd_lookup = | |
47e3b8cc | 2521 | ( |
c9a9a6c0 | 2522 | '-' => { t => 'm', v => '_handle_dash_command', }, |
d478d7a0 | 2523 | '.' => { t => 's', v => \&_DB__handle_dot_command, }, |
8f144dfc SF |
2524 | '=' => { t => 'm', v => '_handle_equal_sign_command', }, |
2525 | 'H' => { t => 'm', v => '_handle_H_command', }, | |
c9a9a6c0 SF |
2526 | 'S' => { t => 'm', v => '_handle_S_command', }, |
2527 | 'T' => { t => 'm', v => '_handle_T_command', }, | |
8f144dfc | 2528 | 'W' => { t => 'm', v => '_handle_W_command', }, |
c9a9a6c0 | 2529 | 'c' => { t => 's', v => \&_DB__handle_c_command, }, |
d478d7a0 SF |
2530 | 'f' => { t => 's', v => \&_DB__handle_f_command, }, |
2531 | 'm' => { t => 's', v => \&_DB__handle_m_command, }, | |
c9a9a6c0 | 2532 | 'n' => { t => 'm', v => '_handle_n_command', }, |
8f144dfc | 2533 | 'p' => { t => 'm', v => '_handle_p_command', }, |
d478d7a0 | 2534 | 'q' => { t => 'm', v => '_handle_q_command', }, |
c9a9a6c0 SF |
2535 | 'r' => { t => 'm', v => '_handle_r_command', }, |
2536 | 's' => { t => 'm', v => '_handle_s_command', }, | |
8f144dfc SF |
2537 | 'save' => { t => 'm', v => '_handle_save_command', }, |
2538 | 'source' => { t => 'm', v => '_handle_source_command', }, | |
d478d7a0 | 2539 | 't' => { t => 'm', v => '_handle_t_command', }, |
8f144dfc | 2540 | 'w' => { t => 'm', v => '_handle_w_command', }, |
d478d7a0 | 2541 | 'x' => { t => 'm', v => '_handle_x_command', }, |
c9a9a6c0 | 2542 | 'y' => { t => 's', v => \&_DB__handle_y_command, }, |
d478d7a0 SF |
2543 | (map { $_ => { t => 'm', v => '_handle_V_command_and_X_command', }, } |
2544 | ('X', 'V')), | |
8f144dfc SF |
2545 | (map { $_ => { t => 'm', v => '_handle_enable_disable_commands', }, } |
2546 | qw(enable disable)), | |
2547 | (map { $_ => | |
2548 | { t => 's', v => \&_DB__handle_restart_and_rerun_commands, }, | |
2549 | } qw(R rerun)), | |
fbe9ebae | 2550 | (map { $_ => {t => 'm', v => '_handle_cmd_wrapper_commands' }, } |
ce1a6808 | 2551 | qw(a A b B e E h i l L M o O v w W)), |
47e3b8cc | 2552 | ); |
23053931 | 2553 | }; |
47e3b8cc | 2554 | |
2b0b9dd1 SF |
2555 | sub DB { |
2556 | ||
2557 | # lock the debugger and get the thread id for the prompt | |
2558 | lock($DBGR); | |
2559 | my $tid; | |
2560 | my $position; | |
2561 | my ($prefix, $after, $infix); | |
2562 | my $pat; | |
22fc883d | 2563 | my $explicit_stop; |
33f361f5 SF |
2564 | my $piped; |
2565 | my $selected; | |
2b0b9dd1 SF |
2566 | |
2567 | if ($ENV{PERL5DB_THREADED}) { | |
2568 | $tid = eval { "[".threads->tid."]" }; | |
2569 | } | |
2570 | ||
610f01b9 | 2571 | my $cmd_verb; |
3249b113 | 2572 | my $cmd_args; |
35cd713a | 2573 | |
22fc883d SF |
2574 | my $obj = DB::Obj->new( |
2575 | { | |
2576 | position => \$position, | |
2577 | prefix => \$prefix, | |
2578 | after => \$after, | |
2579 | explicit_stop => \$explicit_stop, | |
2580 | infix => \$infix, | |
3249b113 | 2581 | cmd_args => \$cmd_args, |
610f01b9 | 2582 | cmd_verb => \$cmd_verb, |
a4d311a3 | 2583 | pat => \$pat, |
33f361f5 SF |
2584 | piped => \$piped, |
2585 | selected => \$selected, | |
22fc883d SF |
2586 | }, |
2587 | ); | |
2588 | ||
2589 | $obj->_DB_on_init__initialize_globals(@_); | |
2b0b9dd1 | 2590 | |
69893cff RGS |
2591 | # Preserve current values of $@, $!, $^E, $,, $/, $\, $^W. |
2592 | # The code being debugged may have altered them. | |
b0b8faca | 2593 | DB::save(); |
69893cff RGS |
2594 | |
2595 | # Since DB::DB gets called after every line, we can use caller() to | |
2596 | # figure out where we last were executing. Sneaky, eh? This works because | |
e22ea7cc | 2597 | # caller is returning all the extra information when called from the |
69893cff | 2598 | # debugger. |
e22ea7cc | 2599 | local ( $package, $filename, $line ) = caller; |
6b24a4b7 | 2600 | $filename_ini = $filename; |
69893cff RGS |
2601 | |
2602 | # set up the context for DB::eval, so it can properly execute | |
2603 | # code on behalf of the user. We add the package in so that the | |
2604 | # code is eval'ed in the proper package (not in the debugger!). | |
6b24a4b7 | 2605 | local $usercontext = _calc_usercontext($package); |
69893cff RGS |
2606 | |
2607 | # Create an alias to the active file magical array to simplify | |
2608 | # the code here. | |
e22ea7cc | 2609 | local (*dbline) = $main::{ '_<' . $filename }; |
aa057b67 | 2610 | |
69893cff | 2611 | # Last line in the program. |
55783941 | 2612 | $max = $#dbline; |
69893cff | 2613 | |
e0cd3692 SF |
2614 | # The &-call is here to ascertain the mutability of @_. |
2615 | &_DB__determine_if_we_should_break; | |
69893cff RGS |
2616 | |
2617 | # Preserve the current stop-or-not, and see if any of the W | |
2618 | # (watch expressions) has changed. | |
36477c24 | 2619 | my $was_signal = $signal; |
69893cff RGS |
2620 | |
2621 | # If we have any watch expressions ... | |
5f5eab52 | 2622 | _DB__handle_watch_expressions($obj); |
69893cff RGS |
2623 | |
2624 | =head2 C<watchfunction()> | |
2625 | ||
2626 | C<watchfunction()> is a function that can be defined by the user; it is a | |
b570d64b | 2627 | function which will be run on each entry to C<DB::DB>; it gets the |
69893cff RGS |
2628 | current package, filename, and line as its parameters. |
2629 | ||
b570d64b | 2630 | The watchfunction can do anything it likes; it is executing in the |
69893cff RGS |
2631 | debugger's context, so it has access to all of the debugger's internal |
2632 | data structures and functions. | |
2633 | ||
2634 | C<watchfunction()> can control the debugger's actions. Any of the following | |
2635 | will cause the debugger to return control to the user's program after | |
2636 | C<watchfunction()> executes: | |
2637 | ||
b570d64b | 2638 | =over 4 |
69893cff | 2639 | |
be9a9b1d AT |
2640 | =item * |
2641 | ||
2642 | Returning a false value from the C<watchfunction()> itself. | |
2643 | ||
2644 | =item * | |
2645 | ||
2646 | Altering C<$single> to a false value. | |
2647 | ||
2648 | =item * | |
69893cff | 2649 | |
be9a9b1d | 2650 | Altering C<$signal> to a false value. |
69893cff | 2651 | |
be9a9b1d | 2652 | =item * |
69893cff | 2653 | |
be9a9b1d | 2654 | Turning off the C<4> bit in C<$trace> (this also disables the |
69893cff RGS |
2655 | check for C<watchfunction()>. This can be done with |
2656 | ||
2657 | $trace &= ~4; | |
2658 | ||
2659 | =back | |
2660 | ||
2661 | =cut | |
2662 | ||
e22ea7cc | 2663 | # If there's a user-defined DB::watchfunction, call it with the |
69893cff RGS |
2664 | # current package, filename, and line. The function executes in |
2665 | # the DB:: package. | |
e22ea7cc RF |
2666 | if ( $trace & 4 ) { # User-installed watch |
2667 | return | |
2668 | if watchfunction( $package, $filename, $line ) | |
2669 | and not $single | |
2670 | and not $was_signal | |
2671 | and not( $trace & ~4 ); | |
69893cff RGS |
2672 | } ## end if ($trace & 4) |
2673 | ||
e22ea7cc | 2674 | # Pick up any alteration to $signal in the watchfunction, and |
69893cff | 2675 | # turn off the signal now. |
6027b9a3 | 2676 | $was_signal = $signal; |
69893cff RGS |
2677 | $signal = 0; |
2678 | ||
2679 | =head2 GETTING READY TO EXECUTE COMMANDS | |
2680 | ||
2681 | The debugger decides to take control if single-step mode is on, the | |
2682 | C<t> command was entered, or the user generated a signal. If the program | |
2683 | has fallen off the end, we set things up so that entering further commands | |
2684 | won't cause trouble, and we say that the program is over. | |
2685 | ||
2686 | =cut | |
2687 | ||
8dc67a69 SF |
2688 | # Make sure that we always print if asked for explicitly regardless |
2689 | # of $trace_to_depth . | |
22fc883d | 2690 | $explicit_stop = ($single || $was_signal); |
8dc67a69 | 2691 | |
69893cff RGS |
2692 | # Check to see if we should grab control ($single true, |
2693 | # trace set appropriately, or we got a signal). | |
8dc67a69 | 2694 | if ( $explicit_stop || ( $trace & 1 ) ) { |
22fc883d | 2695 | $obj->_DB__grab_control(@_); |
69893cff RGS |
2696 | } ## end if ($single || ($trace... |
2697 | ||
2698 | =pod | |
2699 | ||
2700 | If there's an action to be executed for the line we stopped at, execute it. | |
b570d64b | 2701 | If there are any preprompt actions, execute those as well. |
e219e2fb RF |
2702 | |
2703 | =cut | |
2704 | ||
69893cff | 2705 | # If there's an action, do it now. |
05da04df SF |
2706 | if ($action) { |
2707 | $evalarg = $action; | |
e0cd3692 SF |
2708 | # The &-call is here to ascertain the mutability of @_. |
2709 | &DB::eval; | |
05da04df | 2710 | } |
e219e2fb | 2711 | |
69893cff RGS |
2712 | # Are we nested another level (e.g., did we evaluate a function |
2713 | # that had a breakpoint in it at the debugger prompt)? | |
e22ea7cc RF |
2714 | if ( $single || $was_signal ) { |
2715 | ||
69893cff | 2716 | # Yes, go down a level. |
e22ea7cc | 2717 | local $level = $level + 1; |
69893cff RGS |
2718 | |
2719 | # Do any pre-prompt actions. | |
e22ea7cc | 2720 | foreach $evalarg (@$pre) { |
e0cd3692 SF |
2721 | # The &-call is here to ascertain the mutability of @_. |
2722 | &DB::eval; | |
e22ea7cc | 2723 | } |
69893cff RGS |
2724 | |
2725 | # Complain about too much recursion if we passed the limit. | |
05da04df SF |
2726 | if ($single & 4) { |
2727 | print $OUT $stack_depth . " levels deep in subroutine calls!\n"; | |
2728 | } | |
69893cff RGS |
2729 | |
2730 | # The line we're currently on. Set $incr to -1 to stay here | |
2731 | # until we get a command that tells us to advance. | |
e22ea7cc RF |
2732 | $start = $line; |
2733 | $incr = -1; # for backward motion. | |
69893cff RGS |
2734 | |
2735 | # Tack preprompt debugger actions ahead of any actual input. | |
e22ea7cc | 2736 | @typeahead = ( @$pretype, @typeahead ); |
69893cff RGS |
2737 | |
2738 | =head2 WHERE ARE WE? | |
2739 | ||
2740 | XXX Relocate this section? | |
2741 | ||
2742 | The debugger normally shows the line corresponding to the current line of | |
2743 | execution. Sometimes, though, we want to see the next line, or to move elsewhere | |
2744 | in the file. This is done via the C<$incr>, C<$start>, and C<$max> variables. | |
2745 | ||
be9a9b1d AT |
2746 | C<$incr> controls by how many lines the I<current> line should move forward |
2747 | after a command is executed. If set to -1, this indicates that the I<current> | |
69893cff RGS |
2748 | line shouldn't change. |
2749 | ||
be9a9b1d | 2750 | C<$start> is the I<current> line. It is used for things like knowing where to |
69893cff RGS |
2751 | move forwards or backwards from when doing an C<L> or C<-> command. |
2752 | ||
2753 | C<$max> tells the debugger where the last line of the current file is. It's | |
2754 | used to terminate loops most often. | |
2755 | ||
2756 | =head2 THE COMMAND LOOP | |
2757 | ||
2758 | Most of C<DB::DB> is actually a command parsing and dispatch loop. It comes | |
2759 | in two parts: | |
2760 | ||
2761 | =over 4 | |
2762 | ||
be9a9b1d AT |
2763 | =item * |
2764 | ||
2765 | The outer part of the loop, starting at the C<CMD> label. This loop | |
69893cff RGS |
2766 | reads a command and then executes it. |
2767 | ||
be9a9b1d AT |
2768 | =item * |
2769 | ||
2770 | The inner part of the loop, starting at the C<PIPE> label. This part | |
69893cff RGS |
2771 | is wholly contained inside the C<CMD> block and only executes a command. |
2772 | Used to handle commands running inside a pager. | |
2773 | ||
2774 | =back | |
2775 | ||
2776 | So why have two labels to restart the loop? Because sometimes, it's easier to | |
2777 | have a command I<generate> another command and then re-execute the loop to do | |
2778 | the new command. This is faster, but perhaps a bit more convoluted. | |
2779 | ||
2780 | =cut | |
2781 | ||
2782 | # The big command dispatch loop. It keeps running until the | |
2783 | # user yields up control again. | |
2784 | # | |
2785 | # If we have a terminal for input, and we get something back | |
2786 | # from readline(), keep on processing. | |
6b24a4b7 | 2787 | |
e22ea7cc | 2788 | CMD: |
32bbadc6 | 2789 | while (_DB__read_next_cmd($tid)) |
69893cff | 2790 | { |
e22ea7cc | 2791 | |
8380a245 | 2792 | share($cmd); |
69893cff RGS |
2793 | # ... try to execute the input as debugger commands. |
2794 | ||
2795 | # Don't stop running. | |
2796 | $single = 0; | |
2797 | ||
2798 | # No signal is active. | |
2799 | $signal = 0; | |
2800 | ||
2801 | # Handle continued commands (ending with \): | |
3d7a2a93 | 2802 | if ($cmd =~ s/\\\z/\n/) { |
eeb7da96 | 2803 | $cmd .= DB::readline(" cont: "); |
e22ea7cc | 2804 | redo CMD; |
3d7a2a93 | 2805 | } |
69893cff RGS |
2806 | |
2807 | =head4 The null command | |
2808 | ||
be9a9b1d | 2809 | A newline entered by itself means I<re-execute the last command>. We grab the |
69893cff RGS |
2810 | command out of C<$laststep> (where it was recorded previously), and copy it |
2811 | back into C<$cmd> to be executed below. If there wasn't any previous command, | |
2812 | we'll do nothing below (no command will match). If there was, we also save it | |
2813 | in the command history and fall through to allow the command parsing to pick | |
2814 | it up. | |
2815 | ||
2816 | =cut | |
2817 | ||
2818 | # Empty input means repeat the last command. | |
eeb7da96 SF |
2819 | if ($cmd eq '') { |
2820 | $cmd = $laststep; | |
2821 | } | |
e22ea7cc | 2822 | chomp($cmd); # get rid of the annoying extra newline |
eeb7da96 SF |
2823 | if (length($cmd) >= 2) { |
2824 | push( @hist, $cmd ); | |
2825 | } | |
e22ea7cc | 2826 | push( @truehist, $cmd ); |
2dbd01ad SF |
2827 | share(@hist); |
2828 | share(@truehist); | |
e22ea7cc RF |
2829 | |
2830 | # This is a restart point for commands that didn't arrive | |
2831 | # via direct user input. It allows us to 'redo PIPE' to | |
2832 | # re-execute command processing without reading a new command. | |
69893cff | 2833 | PIPE: { |
af84fb69 | 2834 | _DB__trim_command_and_return_first_component($obj); |
69893cff RGS |
2835 | |
2836 | =head3 COMMAND ALIASES | |
2837 | ||
2838 | The debugger can create aliases for commands (these are stored in the | |
2839 | C<%alias> hash). Before a command is executed, the command loop looks it up | |
2840 | in the alias hash and substitutes the contents of the alias for the command, | |
2841 | completely replacing it. | |
2842 | ||
2843 | =cut | |
2844 | ||
2845 | # See if there's an alias for the command, and set it up if so. | |
610f01b9 | 2846 | if ( $alias{$cmd_verb} ) { |
e22ea7cc | 2847 | |
69893cff RGS |
2848 | # Squelch signal handling; we want to keep control here |
2849 | # if something goes loco during the alias eval. | |
2850 | local $SIG{__DIE__}; | |
2851 | local $SIG{__WARN__}; | |
2852 | ||
2853 | # This is a command, so we eval it in the DEBUGGER's | |
2854 | # scope! Otherwise, we can't see the special debugger | |
2855 | # variables, or get to the debugger's subs. (Well, we | |
2856 | # _could_, but why make it even more complicated?) | |
610f01b9 | 2857 | eval "\$cmd =~ $alias{$cmd_verb}"; |
69893cff RGS |
2858 | if ($@) { |
2859 | local $\ = ''; | |
610f01b9 | 2860 | print $OUT "Couldn't evaluate '$cmd_verb' alias: $@"; |
69893cff RGS |
2861 | next CMD; |
2862 | } | |
af84fb69 | 2863 | _DB__trim_command_and_return_first_component($obj); |
610f01b9 | 2864 | } ## end if ($alias{$cmd_verb}) |
69893cff RGS |
2865 | |
2866 | =head3 MAIN-LINE COMMANDS | |
2867 | ||
2868 | All of these commands work up to and after the program being debugged has | |
b570d64b | 2869 | terminated. |
69893cff RGS |
2870 | |
2871 | =head4 C<q> - quit | |
2872 | ||
b570d64b | 2873 | Quit the debugger. This entails setting the C<$fall_off_end> flag, so we don't |
69893cff RGS |
2874 | try to execute further, cleaning any restart-related stuff out of the |
2875 | environment, and executing with the last value of C<$?>. | |
2876 | ||
2877 | =cut | |
2878 | ||
fbe9ebae SF |
2879 | # All of these commands were remapped in perl 5.8.0; |
2880 | # we send them off to the secondary dispatcher (see below). | |
2881 | $obj->_handle_special_char_cmd_wrapper_commands; | |
af84fb69 | 2882 | _DB__trim_command_and_return_first_component($obj); |
fbe9ebae | 2883 | |
610f01b9 | 2884 | if (my $cmd_rec = $cmd_lookup{$cmd_verb}) { |
47e3b8cc SF |
2885 | my $type = $cmd_rec->{t}; |
2886 | my $val = $cmd_rec->{v}; | |
2887 | if ($type eq 'm') { | |
2888 | $obj->$val(); | |
2889 | } | |
2890 | elsif ($type eq 's') { | |
2891 | $val->($obj); | |
2892 | } | |
2893 | } | |
69893cff | 2894 | |
611272bb | 2895 | =head4 C<t> - trace [n] |
69893cff RGS |
2896 | |
2897 | Turn tracing on or off. Inverts the appropriate bit in C<$trace> (q.v.). | |
611272bb | 2898 | If level is specified, set C<$trace_to_depth>. |
69893cff | 2899 | |
69893cff RGS |
2900 | =head4 C<S> - list subroutines matching/not matching a pattern |
2901 | ||
2902 | Walks through C<%sub>, checking to see whether or not to print the name. | |
2903 | ||
69893cff RGS |
2904 | =head4 C<X> - list variables in current package |
2905 | ||
b570d64b | 2906 | Since the C<V> command actually processes this, just change this to the |
69893cff RGS |
2907 | appropriate C<V> command and fall through. |
2908 | ||
69893cff RGS |
2909 | =head4 C<V> - list variables |
2910 | ||
b570d64b | 2911 | Uses C<dumpvar.pl> to dump out the current values for selected variables. |
69893cff | 2912 | |
69893cff RGS |
2913 | =head4 C<x> - evaluate and print an expression |
2914 | ||
2915 | Hands the expression off to C<DB::eval>, setting it up to print the value | |
2916 | via C<dumpvar.pl> instead of just printing it directly. | |
2917 | ||
69893cff RGS |
2918 | =head4 C<m> - print methods |
2919 | ||
2920 | Just uses C<DB::methods> to determine what methods are available. | |
2921 | ||
69893cff RGS |
2922 | =head4 C<f> - switch files |
2923 | ||
73decac7 | 2924 | Switch to a different filename. |
69893cff | 2925 | |
69893cff RGS |
2926 | =head4 C<.> - return to last-executed line. |
2927 | ||
2928 | We set C<$incr> to -1 to indicate that the debugger shouldn't move ahead, | |
2929 | and then we look up the line in the magical C<%dbline> hash. | |
2930 | ||
69893cff RGS |
2931 | =head4 C<-> - back one window |
2932 | ||
2933 | We change C<$start> to be one window back; if we go back past the first line, | |
2934 | we set it to be the first line. We ser C<$incr> to put us back at the | |
2935 | currently-executing line, and then put a C<l $start +> (list one window from | |
2936 | C<$start>) in C<$cmd> to be executed later. | |
2937 | ||
8481f647 | 2938 | =head3 PRE-580 COMMANDS VS. NEW COMMANDS: C<a, A, b, B, h, l, L, M, o, O, P, v, w, W, E<lt>, E<lt>E<lt>, E<0x7B>, E<0x7B>E<0x7B>> |
69893cff RGS |
2939 | |
2940 | In Perl 5.8.0, a realignment of the commands was done to fix up a number of | |
2941 | problems, most notably that the default case of several commands destroying | |
2942 | the user's work in setting watchpoints, actions, etc. We wanted, however, to | |
2943 | retain the old commands for those who were used to using them or who preferred | |
2944 | them. At this point, we check for the new commands and call C<cmd_wrapper> to | |
2945 | deal with them instead of processing them in-line. | |
2946 | ||
69893cff RGS |
2947 | =head4 C<y> - List lexicals in higher scope |
2948 | ||
826b9a2e | 2949 | Uses C<PadWalker> to find the lexicals supplied as arguments in a scope |
69893cff RGS |
2950 | above the current one and then displays then using C<dumpvar.pl>. |
2951 | ||
69893cff RGS |
2952 | =head3 COMMANDS NOT WORKING AFTER PROGRAM ENDS |
2953 | ||
2954 | All of the commands below this point don't work after the program being | |
2955 | debugged has ended. All of them check to see if the program has ended; this | |
2956 | allows the commands to be relocated without worrying about a 'line of | |
2957 | demarcation' above which commands can be entered anytime, and below which | |
2958 | they can't. | |
2959 | ||
2960 | =head4 C<n> - single step, but don't trace down into subs | |
2961 | ||
2962 | Done by setting C<$single> to 2, which forces subs to execute straight through | |
be9a9b1d | 2963 | when entered (see C<DB::sub>). We also save the C<n> command in C<$laststep>, |
826b9a2e | 2964 | so a null command knows what to re-execute. |
69893cff | 2965 | |
69893cff RGS |
2966 | =head4 C<s> - single-step, entering subs |
2967 | ||
826b9a2e | 2968 | Sets C<$single> to 1, which causes C<DB::sub> to continue tracing inside |
69893cff RGS |
2969 | subs. Also saves C<s> as C<$lastcmd>. |
2970 | ||
69893cff RGS |
2971 | =head4 C<c> - run continuously, setting an optional breakpoint |
2972 | ||
2973 | Most of the code for this command is taken up with locating the optional | |
2974 | breakpoint, which is either a subroutine name or a line number. We set | |
2975 | the appropriate one-time-break in C<@dbline> and then turn off single-stepping | |
2976 | in this and all call levels above this one. | |
2977 | ||
69893cff RGS |
2978 | =head4 C<r> - return from a subroutine |
2979 | ||
2980 | For C<r> to work properly, the debugger has to stop execution again | |
2981 | immediately after the return is executed. This is done by forcing | |
2982 | single-stepping to be on in the call level above the current one. If | |
2983 | we are printing return values when a C<r> is executed, set C<$doret> | |
2984 | appropriately, and force us out of the command loop. | |
2985 | ||
69893cff RGS |
2986 | =head4 C<T> - stack trace |
2987 | ||
2988 | Just calls C<DB::print_trace>. | |
2989 | ||
69893cff RGS |
2990 | =head4 C<w> - List window around current line. |
2991 | ||
2992 | Just calls C<DB::cmd_w>. | |
2993 | ||
69893cff RGS |
2994 | =head4 C<W> - watch-expression processing. |
2995 | ||
b570d64b | 2996 | Just calls C<DB::cmd_W>. |
69893cff | 2997 | |
69893cff RGS |
2998 | =head4 C</> - search forward for a string in the source |
2999 | ||
ef18ae63 | 3000 | We take the argument and treat it as a pattern. If it turns out to be a |
69893cff | 3001 | bad one, we return the error we got from trying to C<eval> it and exit. |
ef18ae63 | 3002 | If not, we create some code to do the search and C<eval> it so it can't |
69893cff RGS |
3003 | mess us up. |
3004 | ||
3005 | =cut | |
3006 | ||
a4d311a3 | 3007 | _DB__handle_forward_slash_command($obj); |
69893cff RGS |
3008 | |
3009 | =head4 C<?> - search backward for a string in the source | |
3010 | ||
3011 | Same as for C</>, except the loop runs backwards. | |
3012 | ||
3013 | =cut | |
3014 | ||
11f0f050 | 3015 | _DB__handle_question_mark_command($obj); |
69893cff RGS |
3016 | |
3017 | =head4 C<$rc> - Recall command | |
3018 | ||
3019 | Manages the commands in C<@hist> (which is created if C<Term::ReadLine> reports | |
7e3426ea | 3020 | that the terminal supports history). It finds the command required, puts it |
69893cff RGS |
3021 | into C<$cmd>, and redoes the loop to execute it. |
3022 | ||
3023 | =cut | |
3024 | ||
e22ea7cc | 3025 | # $rc - recall command. |
14f38b27 | 3026 | $obj->_handle_rc_recall_command; |
69893cff RGS |
3027 | |
3028 | =head4 C<$sh$sh> - C<system()> command | |
3029 | ||
f0bb1409 | 3030 | Calls the C<_db_system()> to handle the command. This keeps the C<STDIN> and |
69893cff RGS |
3031 | C<STDOUT> from getting messed up. |
3032 | ||
3033 | =cut | |
3034 | ||
466f24c7 | 3035 | $obj->_handle_sh_command; |
69893cff RGS |
3036 | |
3037 | =head4 C<$rc I<pattern> $rc> - Search command history | |
3038 | ||
3039 | Another command to manipulate C<@hist>: this one searches it with a pattern. | |
be9a9b1d | 3040 | If a command is found, it is placed in C<$cmd> and executed via C<redo>. |
69893cff RGS |
3041 | |
3042 | =cut | |
3043 | ||
0d2c714c | 3044 | $obj->_handle_rc_search_history_command; |
69893cff | 3045 | |
ef18ae63 | 3046 | =head4 C<$sh> - Invoke a shell |
69893cff | 3047 | |
f0bb1409 | 3048 | Uses C<_db_system()> to invoke a shell. |
69893cff RGS |
3049 | |
3050 | =cut | |
3051 | ||
69893cff RGS |
3052 | =head4 C<$sh I<command>> - Force execution of a command in a shell |
3053 | ||
3054 | Like the above, but the command is passed to the shell. Again, we use | |
f0bb1409 | 3055 | C<_db_system()> to avoid problems with C<STDIN> and C<STDOUT>. |
69893cff | 3056 | |
69893cff RGS |
3057 | =head4 C<H> - display commands in history |
3058 | ||
3059 | Prints the contents of C<@hist> (if any). | |
3060 | ||
69893cff RGS |
3061 | =head4 C<man, doc, perldoc> - look up documentation |
3062 | ||
3063 | Just calls C<runman()> to print the appropriate document. | |
3064 | ||
3065 | =cut | |
3066 | ||
c7b0c61d | 3067 | $obj->_handle_doc_command; |
69893cff RGS |
3068 | |
3069 | =head4 C<p> - print | |
3070 | ||
3071 | Builds a C<print EXPR> expression in the C<$cmd>; this will get executed at | |
3072 | the bottom of the loop. | |
3073 | ||
69893cff RGS |
3074 | =head4 C<=> - define command alias |
3075 | ||
3076 | Manipulates C<%alias> to add or list command aliases. | |
3077 | ||
69893cff RGS |
3078 | =head4 C<source> - read commands from a file. |
3079 | ||
3080 | Opens a lexical filehandle and stacks it on C<@cmdfhs>; C<DB::readline> will | |
3081 | pick it up. | |
3082 | ||
d0ecd4f3 | 3083 | =head4 C<enable> C<disable> - enable or disable breakpoints |
e09195af | 3084 | |
d0ecd4f3 | 3085 | This enables or disables breakpoints. |
e09195af | 3086 | |
69893cff RGS |
3087 | =head4 C<save> - send current history to a file |
3088 | ||
3089 | Takes the complete history, (not the shrunken version you see with C<H>), | |
3090 | and saves it to the given filename, so it can be replayed using C<source>. | |
3091 | ||
3092 | Note that all C<^(save|source)>'s are commented out with a view to minimise recursion. | |
3093 | ||
7fddc82f RF |
3094 | =head4 C<R> - restart |
3095 | ||
ef18ae63 | 3096 | Restart the debugger session. |
7fddc82f RF |
3097 | |
3098 | =head4 C<rerun> - rerun the current session | |
3099 | ||
3100 | Return to any given position in the B<true>-history list | |
3101 | ||
69893cff RGS |
3102 | =head4 C<|, ||> - pipe output through the pager. |
3103 | ||
be9a9b1d | 3104 | For C<|>, we save C<OUT> (the debugger's output filehandle) and C<STDOUT> |
69893cff RGS |
3105 | (the program's standard output). For C<||>, we only save C<OUT>. We open a |
3106 | pipe to the pager (restoring the output filehandles if this fails). If this | |
b570d64b | 3107 | is the C<|> command, we also set up a C<SIGPIPE> handler which will simply |
69893cff RGS |
3108 | set C<$signal>, sending us back into the debugger. |
3109 | ||
3110 | We then trim off the pipe symbols and C<redo> the command loop at the | |
3111 | C<PIPE> label, causing us to evaluate the command in C<$cmd> without | |
3112 | reading another. | |
3113 | ||
3114 | =cut | |
3115 | ||
3116 | # || - run command in the pager, with output to DB::OUT. | |
33f361f5 | 3117 | _DB__handle_run_command_in_pager_command($obj); |
69893cff RGS |
3118 | |
3119 | =head3 END OF COMMAND PARSING | |
3120 | ||
ff41e38d SF |
3121 | Anything left in C<$cmd> at this point is a Perl expression that we want to |
3122 | evaluate. We'll always evaluate in the user's context, and fully qualify | |
69893cff RGS |
3123 | any variables we might want to address in the C<DB> package. |
3124 | ||
3125 | =cut | |
3126 | ||
e22ea7cc | 3127 | } # PIPE: |
69893cff | 3128 | |
e2b8b3e7 TC |
3129 | # trace an expression |
3130 | $cmd =~ s/^t\s/\$DB::trace |= 1;\n/; | |
3131 | ||
e22ea7cc | 3132 | # Make sure the flag that says "the debugger's running" is |
69893cff | 3133 | # still on, to make sure we get control again. |
e22ea7cc | 3134 | $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; |
69893cff RGS |
3135 | |
3136 | # Run *our* eval that executes in the caller's context. | |
e0cd3692 SF |
3137 | # The &-call is here to ascertain the mutability of @_. |
3138 | &DB::eval; | |
69893cff RGS |
3139 | |
3140 | # Turn off the one-time-dump stuff now. | |
e22ea7cc RF |
3141 | if ($onetimeDump) { |
3142 | $onetimeDump = undef; | |
69893cff | 3143 | $onetimedumpDepth = undef; |
e22ea7cc RF |
3144 | } |
3145 | elsif ( $term_pid == $$ ) { | |
8380a245 | 3146 | eval { # May run under miniperl, when not available... |
c7e68384 IZ |
3147 | STDOUT->flush(); |
3148 | STDERR->flush(); | |
8380a245 | 3149 | }; |
e22ea7cc | 3150 | |
69893cff | 3151 | # XXX If this is the master pid, print a newline. |
8380a245 | 3152 | print {$OUT} "\n"; |
e22ea7cc RF |
3153 | } |
3154 | } ## end while (($term || &setterm... | |
69893cff RGS |
3155 | |
3156 | =head3 POST-COMMAND PROCESSING | |
3157 | ||
3158 | After each command, we check to see if the command output was piped anywhere. | |
3159 | If so, we go through the necessary code to unhook the pipe and go back to | |
3160 | our standard filehandles for input and output. | |
3161 | ||
3162 | =cut | |
3163 | ||
e22ea7cc | 3164 | continue { # CMD: |
8e4cceb9 | 3165 | _DB__at_end_of_every_command($obj); |
e22ea7cc | 3166 | } # CMD: |
69893cff RGS |
3167 | |
3168 | =head3 COMMAND LOOP TERMINATION | |
3169 | ||
3170 | When commands have finished executing, we come here. If the user closed the | |
3171 | input filehandle, we turn on C<$fall_off_end> to emulate a C<q> command. We | |
3172 | evaluate any post-prompt items. We restore C<$@>, C<$!>, C<$^E>, C<$,>, C<$/>, | |
3173 | C<$\>, and C<$^W>, and return a null list as expected by the Perl interpreter. | |
3174 | The interpreter will then execute the next line and then return control to us | |
3175 | again. | |
3176 | ||
3177 | =cut | |
3178 | ||
3179 | # No more commands? Quit. | |
1f874cb6 | 3180 | $fall_off_end = 1 unless defined $cmd; # Emulate 'q' on EOF |
69893cff RGS |
3181 | |
3182 | # Evaluate post-prompt commands. | |
e22ea7cc | 3183 | foreach $evalarg (@$post) { |
e0cd3692 SF |
3184 | # The &-call is here to ascertain the mutability of @_. |
3185 | &DB::eval; | |
e22ea7cc RF |
3186 | } |
3187 | } # if ($single || $signal) | |
69893cff RGS |
3188 | |
3189 | # Put the user's globals back where you found them. | |
e22ea7cc | 3190 | ( $@, $!, $^E, $,, $/, $\, $^W ) = @saved; |
69893cff RGS |
3191 | (); |
3192 | } ## end sub DB | |
3193 | ||
90fd4c80 KF |
3194 | # Because DB::Obj is used above, |
3195 | # | |
3196 | # my $obj = DB::Obj->new( | |
3197 | # | |
7e3426ea | 3198 | # The following package declaration must come before that, |
90fd4c80 KF |
3199 | # or else runtime errors will occur with |
3200 | # | |
3201 | # PERLDB_OPTS="autotrace nonstop" | |
3202 | # | |
3203 | # ( rt#116771 ) | |
3204 | BEGIN { | |
3205 | ||
22fc883d SF |
3206 | package DB::Obj; |
3207 | ||
3208 | sub new { | |
3209 | my $class = shift; | |
3210 | ||
3211 | my $self = bless {}, $class; | |
3212 | ||
3213 | $self->_init(@_); | |
3214 | ||
3215 | return $self; | |
3216 | } | |
3217 | ||
3218 | sub _init { | |
3219 | my ($self, $args) = @_; | |
3220 | ||
3221 | %{$self} = (%$self, %$args); | |
3222 | ||
3223 | return; | |
3224 | } | |
3225 | ||
3226 | { | |
3227 | no strict 'refs'; | |
a4d311a3 | 3228 | foreach my $slot_name (qw( |
610f01b9 | 3229 | after explicit_stop infix pat piped position prefix selected cmd_verb |
3249b113 | 3230 | cmd_args |
a4d311a3 | 3231 | )) { |
22fc883d SF |
3232 | my $slot = $slot_name; |
3233 | *{$slot} = sub { | |
3234 | my $self = shift; | |
3235 | ||
3236 | if (@_) { | |
3237 | ${ $self->{$slot} } = shift; | |
3238 | } | |
3239 | ||
3240 | return ${ $self->{$slot} }; | |
3241 | }; | |
8def6eff SF |
3242 | |
3243 | *{"append_to_$slot"} = sub { | |
3244 | my $self = shift; | |
3245 | my $s = shift; | |
3246 | ||
3247 | return $self->$slot($self->$slot . $s); | |
3248 | }; | |
22fc883d SF |
3249 | } |
3250 | } | |
3251 | ||
3252 | sub _DB_on_init__initialize_globals | |
3253 | { | |
3254 | my $self = shift; | |
3255 | ||
3256 | # Check for whether we should be running continuously or not. | |
3257 | # _After_ the perl program is compiled, $single is set to 1: | |
ebd0282e | 3258 | if ( $single and not $second_time++ ) { |
22fc883d SF |
3259 | |
3260 | # Options say run non-stop. Run until we get an interrupt. | |
ebd0282e | 3261 | if ($runnonstop) { # Disable until signal |
22fc883d SF |
3262 | # If there's any call stack in place, turn off single |
3263 | # stepping into subs throughout the stack. | |
8ad70697 SF |
3264 | for my $i (0 .. $stack_depth) { |
3265 | $stack[ $i ] &= ~1; | |
22fc883d SF |
3266 | } |
3267 | ||
3268 | # And we are now no longer in single-step mode. | |
ebd0282e | 3269 | $single = 0; |
22fc883d SF |
3270 | |
3271 | # If we simply returned at this point, we wouldn't get | |
3272 | # the trace info. Fall on through. | |
3273 | # return; | |
3274 | } ## end if ($runnonstop) | |
3275 | ||
8ad70697 | 3276 | elsif ($ImmediateStop) { |
22fc883d SF |
3277 | |
3278 | # We are supposed to stop here; XXX probably a break. | |
8ad70697 | 3279 | $ImmediateStop = 0; # We've processed it; turn it off |
ebd0282e | 3280 | $signal = 1; # Simulate an interrupt to force |
22fc883d SF |
3281 | # us into the command loop |
3282 | } | |
3283 | } ## end if ($single and not $second_time... | |
3284 | ||
3285 | # If we're in single-step mode, or an interrupt (real or fake) | |
3286 | # has occurred, turn off non-stop mode. | |
ebd0282e | 3287 | $runnonstop = 0 if $single or $signal; |
22fc883d SF |
3288 | |
3289 | return; | |
3290 | } | |
3291 | ||
ad46ac70 SF |
3292 | sub _my_print_lineinfo |
3293 | { | |
3294 | my ($self, $i, $incr_pos) = @_; | |
3295 | ||
18b5b545 | 3296 | if ($frame) { |
ad46ac70 | 3297 | # Print it indented if tracing is on. |
8ad70697 | 3298 | DB::print_lineinfo( ' ' x $stack_depth, |
ad46ac70 SF |
3299 | "$i:\t$DB::dbline[$i]" . $self->after ); |
3300 | } | |
3301 | else { | |
3302 | DB::depth_print_lineinfo($self->explicit_stop, $incr_pos); | |
3303 | } | |
3304 | } | |
3305 | ||
44a07e3e | 3306 | sub _curr_line { |
18b5b545 | 3307 | return $DB::dbline[$line]; |
44a07e3e SF |
3308 | } |
3309 | ||
601c6a23 SF |
3310 | sub _is_full { |
3311 | my ($self, $letter) = @_; | |
3312 | ||
3313 | return ($DB::cmd eq $letter); | |
3314 | } | |
3315 | ||
22fc883d SF |
3316 | sub _DB__grab_control |
3317 | { | |
3318 | my $self = shift; | |
3319 | ||
3320 | # Yes, grab control. | |
7793e5c2 | 3321 | if ($slave_editor) { |
22fc883d SF |
3322 | |
3323 | # Tell the editor to update its position. | |
18b5b545 | 3324 | $self->position("\032\032${DB::filename}:$line:0\n"); |
22fc883d SF |
3325 | DB::print_lineinfo($self->position()); |
3326 | } | |
3327 | ||
3328 | =pod | |
3329 | ||
3330 | Special check: if we're in package C<DB::fake>, we've gone through the | |
3331 | C<END> block at least once. We set up everything so that we can continue | |
3332 | to enter commands and have a valid context to be in. | |
3333 | ||
3334 | =cut | |
3335 | ||
3336 | elsif ( $DB::package eq 'DB::fake' ) { | |
3337 | ||
3338 | # Fallen off the end already. | |
3339 | if (!$DB::term) { | |
3340 | DB::setterm(); | |
3341 | } | |
3342 | ||
3343 | DB::print_help(<<EOP); | |
3344 | Debugged program terminated. Use B<q> to quit or B<R> to restart, | |
3345 | use B<o> I<inhibit_exit> to avoid stopping after program termination, | |
3346 | B<h q>, B<h R> or B<h o> to get additional info. | |
3347 | EOP | |
3348 | ||
3349 | # Set the DB::eval context appropriately. | |
0b1fcdcc SF |
3350 | # At program termination disable any user actions. |
3351 | $DB::action = undef; | |
3352 | ||
22fc883d SF |
3353 | $DB::package = 'main'; |
3354 | $DB::usercontext = DB::_calc_usercontext($DB::package); | |
3355 | } ## end elsif ($package eq 'DB::fake') | |
3356 | ||
3357 | =pod | |
3358 | ||
3359 | If the program hasn't finished executing, we scan forward to the | |
3360 | next executable line, print that out, build the prompt from the file and line | |
3361 | number information, and print that. | |
3362 | ||
3363 | =cut | |
3364 | ||
3365 | else { | |
3366 | ||
3367 | ||
3368 | # Still somewhere in the midst of execution. Set up the | |
3369 | # debugger prompt. | |
3370 | $DB::sub =~ s/\'/::/; # Swap Perl 4 package separators (') to | |
3371 | # Perl 5 ones (sorry, we don't print Klingon | |
3372 | #module names) | |
3373 | ||
3374 | $self->prefix($DB::sub =~ /::/ ? "" : ($DB::package . '::')); | |
8def6eff | 3375 | $self->append_to_prefix( "$DB::sub(${DB::filename}:" ); |
44a07e3e | 3376 | $self->after( $self->_curr_line =~ /\n$/ ? '' : "\n" ); |
22fc883d SF |
3377 | |
3378 | # Break up the prompt if it's really long. | |
3379 | if ( length($self->prefix()) > 30 ) { | |
18b5b545 | 3380 | $self->position($self->prefix . "$line):\n$line:\t" . $self->_curr_line . $self->after); |
22fc883d SF |
3381 | $self->prefix(""); |
3382 | $self->infix(":\t"); | |
3383 | } | |
3384 | else { | |
3385 | $self->infix("):\t"); | |
3386 | $self->position( | |
18b5b545 | 3387 | $self->prefix . $line. $self->infix |
44a07e3e | 3388 | . $self->_curr_line . $self->after |
22fc883d SF |
3389 | ); |
3390 | } | |
3391 | ||
3392 | # Print current line info, indenting if necessary. | |
18b5b545 | 3393 | $self->_my_print_lineinfo($line, $self->position); |
22fc883d | 3394 | |
44a07e3e SF |
3395 | my $i; |
3396 | my $line_i = sub { return $DB::dbline[$i]; }; | |
3397 | ||
22fc883d SF |
3398 | # Scan forward, stopping at either the end or the next |
3399 | # unbreakable line. | |
18b5b545 | 3400 | for ( $i = $line + 1 ; $i <= $DB::max && $line_i->() == 0 ; ++$i ) |
22fc883d SF |
3401 | { #{ vi |
3402 | ||
3403 | # Drop out on null statements, block closers, and comments. | |
44a07e3e | 3404 | last if $line_i->() =~ /^\s*[\;\}\#\n]/; |
22fc883d SF |
3405 | |
3406 | # Drop out if the user interrupted us. | |
ebd0282e | 3407 | last if $signal; |
22fc883d SF |
3408 | |
3409 | # Append a newline if the line doesn't have one. Can happen | |
3410 | # in eval'ed text, for instance. | |
44a07e3e | 3411 | $self->after( $line_i->() =~ /\n$/ ? '' : "\n" ); |
22fc883d SF |
3412 | |
3413 | # Next executable line. | |
44a07e3e | 3414 | my $incr_pos = $self->prefix . $i . $self->infix . $line_i->() |
22fc883d | 3415 | . $self->after; |
8def6eff | 3416 | $self->append_to_position($incr_pos); |
ad46ac70 | 3417 | $self->_my_print_lineinfo($i, $incr_pos); |
22fc883d SF |
3418 | } ## end for ($i = $line + 1 ; $i... |
3419 | } ## end else [ if ($slave_editor) | |
3420 | ||
3421 | return; | |
3422 | } | |
3423 | ||
174f9c5e | 3424 | sub _handle_t_command { |
9875a6d2 SF |
3425 | my $self = shift; |
3426 | ||
3427 | my $levels = $self->cmd_args(); | |
3428 | ||
3429 | if ((!length($levels)) or ($levels !~ /\D/)) { | |
931ac036 | 3430 | $trace ^= 1; |
174f9c5e | 3431 | local $\ = ''; |
8ad70697 SF |
3432 | $DB::trace_to_depth = $levels ? $stack_depth + $levels : 1E9; |
3433 | print {$OUT} "Trace = " | |
931ac036 | 3434 | . ( ( $trace & 1 ) |
174f9c5e SF |
3435 | ? ( $levels ? "on (to level $DB::trace_to_depth)" : "on" ) |
3436 | : "off" ) . "\n"; | |
3437 | next CMD; | |
3438 | } | |
3439 | ||
3440 | return; | |
3441 | } | |
3442 | ||
9d0b71b3 SF |
3443 | |
3444 | sub _handle_S_command { | |
3249b113 SF |
3445 | my $self = shift; |
3446 | ||
9d0b71b3 | 3447 | if (my ($print_all_subs, $should_reverse, $Spatt) |
3249b113 | 3448 | = $self->cmd_args =~ /\A((!)?(.+))?\z/) { |
9d0b71b3 SF |
3449 | # $Spatt is the pattern (if any) to use. |
3450 | # Reverse scan? | |
3451 | my $Srev = defined $should_reverse; | |
3452 | # No args - print all subs. | |
3453 | my $Snocheck = !defined $print_all_subs; | |
3454 | ||
3455 | # Need to make these sane here. | |
3456 | local $\ = ''; | |
3457 | local $, = ''; | |
3458 | ||
3459 | # Search through the debugger's magical hash of subs. | |
3460 | # If $nocheck is true, just print the sub name. | |
3461 | # Otherwise, check it against the pattern. We then use | |
3462 | # the XOR trick to reverse the condition as required. | |
3463 | foreach $subname ( sort( keys %sub ) ) { | |
3464 | if ( $Snocheck or $Srev ^ ( $subname =~ /$Spatt/ ) ) { | |
3465 | print $OUT $subname, "\n"; | |
3466 | } | |
3467 | } | |
3468 | next CMD; | |
3469 | } | |
3470 | ||
3471 | return; | |
3472 | } | |
3473 | ||
1ce985d2 | 3474 | sub _handle_V_command_and_X_command { |
601c6a23 | 3475 | my $self = shift; |
1ce985d2 SF |
3476 | |
3477 | $DB::cmd =~ s/^X\b/V $DB::package/; | |
3478 | ||
3479 | # Bare V commands get the currently-being-debugged package | |
3480 | # added. | |
601c6a23 | 3481 | if ($self->_is_full('V')) { |
1ce985d2 SF |
3482 | $DB::cmd = "V $DB::package"; |
3483 | } | |
3484 | ||
3485 | # V - show variables in package. | |
3486 | if (my ($new_packname, $new_vars_str) = | |
3487 | $DB::cmd =~ /\AV\b\s*(\S+)\s*(.*)/) { | |
3488 | ||
3489 | # Save the currently selected filehandle and | |
3490 | # force output to debugger's filehandle (dumpvar | |
3491 | # just does "print" for output). | |
3492 | my $savout = select($OUT); | |
3493 | ||
3494 | # Grab package name and variables to dump. | |
3495 | $packname = $new_packname; | |
3496 | my @vars = split( ' ', $new_vars_str ); | |
3497 | ||
3498 | # If main::dumpvar isn't here, get it. | |
3499 | do 'dumpvar.pl' || die $@ unless defined &main::dumpvar; | |
3500 | if ( defined &main::dumpvar ) { | |
3501 | ||
3502 | # We got it. Turn off subroutine entry/exit messages | |
3503 | # for the moment, along with return values. | |
3504 | local $frame = 0; | |
3505 | local $doret = -2; | |
3506 | ||
3507 | # must detect sigpipe failures - not catching | |
3508 | # then will cause the debugger to die. | |
3509 | eval { | |
b0b8faca | 3510 | main::dumpvar( |
1ce985d2 SF |
3511 | $packname, |
3512 | defined $option{dumpDepth} | |
3513 | ? $option{dumpDepth} | |
3514 | : -1, # assume -1 unless specified | |
3515 | @vars | |
3516 | ); | |
3517 | }; | |
3518 | ||
3519 | # The die doesn't need to include the $@, because | |
3520 | # it will automatically get propagated for us. | |
3521 | if ($@) { | |
3522 | die unless $@ =~ /dumpvar print failed/; | |
3523 | } | |
3524 | } ## end if (defined &main::dumpvar) | |
3525 | else { | |
3526 | ||
3527 | # Couldn't load dumpvar. | |
3528 | print $OUT "dumpvar.pl not available.\n"; | |
3529 | } | |
3530 | ||
3531 | # Restore the output filehandle, and go round again. | |
3532 | select($savout); | |
3533 | next CMD; | |
3534 | } | |
3535 | ||
3536 | return; | |
3537 | } | |
3538 | ||
d1450c23 | 3539 | sub _handle_dash_command { |
601c6a23 | 3540 | my $self = shift; |
d1450c23 | 3541 | |
601c6a23 | 3542 | if ($self->_is_full('-')) { |
d1450c23 SF |
3543 | |
3544 | # back up by a window; go to 1 if back too far. | |
3545 | $start -= $incr + $window + 1; | |
3546 | $start = 1 if $start <= 0; | |
3547 | $incr = $window - 1; | |
3548 | ||
3549 | # Generate and execute a "l +" command (handled below). | |
3550 | $DB::cmd = 'l ' . ($start) . '+'; | |
fbe9ebae | 3551 | redo CMD; |
d1450c23 SF |
3552 | } |
3553 | return; | |
3554 | } | |
3555 | ||
cb9d1513 SF |
3556 | sub _n_or_s_commands_generic { |
3557 | my ($self, $new_val) = @_; | |
73c5e526 | 3558 | # n - next |
cb9d1513 | 3559 | next CMD if DB::_DB__is_finished(); |
73c5e526 | 3560 | |
cb9d1513 SF |
3561 | # Single step, but don't enter subs. |
3562 | $single = $new_val; | |
3563 | ||
3564 | # Save for empty command (repeat last). | |
3565 | $laststep = $DB::cmd; | |
3566 | last CMD; | |
3567 | } | |
73c5e526 | 3568 | |
cb9d1513 SF |
3569 | sub _n_or_s { |
3570 | my ($self, $letter, $new_val) = @_; | |
3571 | ||
601c6a23 | 3572 | if ($self->_is_full($letter)) { |
cb9d1513 | 3573 | $self->_n_or_s_commands_generic($new_val); |
73c5e526 | 3574 | } |
a30f63cd | 3575 | else { |
50a8a759 SF |
3576 | $self->_n_or_s_and_arg_commands_generic($letter, $new_val); |
3577 | } | |
73c5e526 SF |
3578 | |
3579 | return; | |
3580 | } | |
3581 | ||
cb9d1513 SF |
3582 | sub _handle_n_command { |
3583 | my $self = shift; | |
3584 | ||
3585 | return $self->_n_or_s('n', 2); | |
3586 | } | |
3587 | ||
3588 | sub _handle_s_command { | |
3589 | my $self = shift; | |
3590 | ||
3591 | return $self->_n_or_s('s', 1); | |
3592 | } | |
3593 | ||
573b5003 SF |
3594 | sub _handle_r_command { |
3595 | my $self = shift; | |
f89bf53e | 3596 | |
573b5003 | 3597 | # r - return from the current subroutine. |
601c6a23 | 3598 | if ($self->_is_full('r')) { |
573b5003 SF |
3599 | |
3600 | # Can't do anything if the program's over. | |
3601 | next CMD if DB::_DB__is_finished(); | |
3602 | ||
3603 | # Turn on stack trace. | |
3604 | $stack[$stack_depth] |= 1; | |
3605 | ||
3606 | # Print return value unless the stack is empty. | |
3607 | $doret = $option{PrintRet} ? $stack_depth - 1 : -2; | |
3608 | last CMD; | |
3609 | } | |
3610 | ||
3611 | return; | |
3612 | } | |
3613 | ||
d4038e14 | 3614 | sub _handle_T_command { |
601c6a23 SF |
3615 | my $self = shift; |
3616 | ||
3617 | if ($self->_is_full('T')) { | |
d4038e14 SF |
3618 | DB::print_trace( $OUT, 1 ); # skip DB |
3619 | next CMD; | |
3620 | } | |
3621 | ||
3622 | return; | |
3623 | } | |
3624 | ||
b6e88520 | 3625 | sub _handle_w_command { |
9875a6d2 SF |
3626 | my $self = shift; |
3627 | ||
3628 | DB::cmd_w( 'w', $self->cmd_args() ); | |
3629 | next CMD; | |
b6e88520 SF |
3630 | |
3631 | return; | |
3632 | } | |
3633 | ||
25953301 | 3634 | sub _handle_W_command { |
a523ec7c SF |
3635 | my $self = shift; |
3636 | ||
3637 | if (my $arg = $self->cmd_args) { | |
25953301 SF |
3638 | DB::cmd_W( 'W', $arg ); |
3639 | next CMD; | |
3640 | } | |
3641 | ||
3642 | return; | |
3643 | } | |
3644 | ||
14f38b27 SF |
3645 | sub _handle_rc_recall_command { |
3646 | my $self = shift; | |
3647 | ||
3648 | # $rc - recall command. | |
3649 | if (my ($minus, $arg) = $DB::cmd =~ m#\A$rc+\s*(-)?(\d+)?\z#) { | |
3650 | ||
3651 | # No arguments, take one thing off history. | |
3652 | pop(@hist) if length($DB::cmd) > 1; | |
3653 | ||
3654 | # Relative (- found)? | |
3655 | # Y - index back from most recent (by 1 if bare minus) | |
3656 | # N - go to that particular command slot or the last | |
3657 | # thing if nothing following. | |
14f38b27 | 3658 | |
9c6fceaf SF |
3659 | $self->cmd_verb( |
3660 | scalar($minus ? ( $#hist - ( $arg || 1 ) ) : ( $arg || $#hist )) | |
3661 | ); | |
14f38b27 SF |
3662 | |
3663 | # Pick out the command desired. | |
610f01b9 | 3664 | $DB::cmd = $hist[$self->cmd_verb]; |
14f38b27 SF |
3665 | |
3666 | # Print the command to be executed and restart the loop | |
3667 | # with that command in the buffer. | |
3668 | print {$OUT} $DB::cmd, "\n"; | |
3669 | redo CMD; | |
3670 | } | |
3671 | ||
3672 | return; | |
3673 | } | |
3674 | ||
0d2c714c SF |
3675 | sub _handle_rc_search_history_command { |
3676 | my $self = shift; | |
3677 | ||
3678 | # $rc pattern $rc - find a command in the history. | |
3679 | if (my ($arg) = $DB::cmd =~ /\A$rc([^$rc].*)\z/) { | |
3680 | ||
3681 | # Create the pattern to use. | |
3682 | my $pat = "^$arg"; | |
3683 | $self->pat($pat); | |
3684 | ||
3685 | # Toss off last entry if length is >1 (and it always is). | |
3686 | pop(@hist) if length($DB::cmd) > 1; | |
3687 | ||
9c6fceaf | 3688 | my $i; |
0d2c714c SF |
3689 | |
3690 | # Look backward through the history. | |
3691 | SEARCH_HIST: | |
3692 | for ( $i = $#hist ; $i ; --$i ) { | |
3693 | # Stop if we find it. | |
3694 | last SEARCH_HIST if $hist[$i] =~ /$pat/; | |
3695 | } | |
3696 | ||
9c6fceaf | 3697 | if ( !$i ) { |
0d2c714c SF |
3698 | |
3699 | # Never found it. | |
3700 | print $OUT "No such command!\n\n"; | |
3701 | next CMD; | |
3702 | } | |
3703 | ||
3704 | # Found it. Put it in the buffer, print it, and process it. | |
9c6fceaf | 3705 | $DB::cmd = $hist[$i]; |
0d2c714c SF |
3706 | print $OUT $DB::cmd, "\n"; |
3707 | redo CMD; | |
3708 | } | |
b6aeebb8 SF |
3709 | |
3710 | return; | |
0d2c714c SF |
3711 | } |
3712 | ||
0664c09a SF |
3713 | sub _handle_H_command { |
3714 | my $self = shift; | |
3715 | ||
3249b113 | 3716 | if ($self->cmd_args =~ m#\A\*#) { |
0664c09a SF |
3717 | @hist = @truehist = (); |
3718 | print $OUT "History cleansed\n"; | |
3719 | next CMD; | |
3720 | } | |
3721 | ||
3249b113 | 3722 | if (my ($num) = $self->cmd_args =~ /\A(?:-(\d+))?/) { |
0664c09a SF |
3723 | |
3724 | # Anything other than negative numbers is ignored by | |
3725 | # the (incorrect) pattern, so this test does nothing. | |
3726 | $end = $num ? ( $#hist - $num ) : 0; | |
3727 | ||
3728 | # Set to the minimum if less than zero. | |
3729 | $hist = 0 if $hist < 0; | |
3730 | ||
3731 | # Start at the end of the array. | |
3732 | # Stay in while we're still above the ending value. | |
3733 | # Tick back by one each time around the loop. | |
3734 | my $i; | |
3735 | ||
3736 | for ( $i = $#hist ; $i > $end ; $i-- ) { | |
3737 | ||
3738 | # Print the command unless it has no arguments. | |
3739 | print $OUT "$i: ", $hist[$i], "\n" | |
3740 | unless $hist[$i] =~ /^.?$/; | |
3741 | } | |
3742 | ||
0664c09a SF |
3743 | next CMD; |
3744 | } | |
3745 | ||
3746 | return; | |
3747 | } | |
3748 | ||
c7b0c61d SF |
3749 | sub _handle_doc_command { |
3750 | my $self = shift; | |
3751 | ||
3752 | # man, perldoc, doc - show manual pages. | |
3753 | if (my ($man_page) | |
3754 | = $DB::cmd =~ /\A(?:man|(?:perl)?doc)\b(?:\s+([^(]*))?\z/) { | |
b019bbd2 | 3755 | DB::runman($man_page); |
c7b0c61d SF |
3756 | next CMD; |
3757 | } | |
3758 | ||
3759 | return; | |
3760 | } | |
3761 | ||
b6aeebb8 SF |
3762 | sub _handle_p_command { |
3763 | my $self = shift; | |
3764 | ||
3765 | my $print_cmd = 'print {$DB::OUT} '; | |
3766 | # p - print (no args): print $_. | |
601c6a23 | 3767 | if ($self->_is_full('p')) { |
b6aeebb8 SF |
3768 | $DB::cmd = $print_cmd . '$_'; |
3769 | } | |
a30f63cd SF |
3770 | else { |
3771 | # p - print the given expression. | |
3772 | $DB::cmd =~ s/\Ap\b/$print_cmd /; | |
3773 | } | |
b6aeebb8 SF |
3774 | |
3775 | return; | |
3776 | } | |
3777 | ||
bdb3f37d SF |
3778 | sub _handle_equal_sign_command { |
3779 | my $self = shift; | |
3780 | ||
3781 | if ($DB::cmd =~ s/\A=\s*//) { | |
3782 | my @keys; | |
3783 | if ( length $DB::cmd == 0 ) { | |
3784 | ||
3785 | # No args, get current aliases. | |
3786 | @keys = sort keys %alias; | |
3787 | } | |
3788 | elsif ( my ( $k, $v ) = ( $DB::cmd =~ /^(\S+)\s+(\S.*)/ ) ) { | |
3789 | ||
3790 | # Creating a new alias. $k is alias name, $v is | |
3791 | # alias value. | |
3792 | ||
3793 | # can't use $_ or kill //g state | |
3794 | for my $x ( $k, $v ) { | |
3795 | ||
3796 | # Escape "alarm" characters. | |
3797 | $x =~ s/\a/\\a/g; | |
3798 | } | |
3799 | ||
3800 | # Substitute key for value, using alarm chars | |
3801 | # as separators (which is why we escaped them in | |
3802 | # the command). | |
3803 | $alias{$k} = "s\a$k\a$v\a"; | |
3804 | ||
3805 | # Turn off standard warn and die behavior. | |
3806 | local $SIG{__DIE__}; | |
3807 | local $SIG{__WARN__}; | |
3808 | ||
3809 | # Is it valid Perl? | |
3810 | unless ( eval "sub { s\a$k\a$v\a }; 1" ) { | |
3811 | ||
3812 | # Nope. Bad alias. Say so and get out. | |
3813 | print $OUT "Can't alias $k to $v: $@\n"; | |
3814 | delete $alias{$k}; | |
3815 | next CMD; | |
3816 | } | |
3817 | ||
3818 | # We'll only list the new one. | |
3819 | @keys = ($k); | |
3820 | } ## end elsif (my ($k, $v) = ($DB::cmd... | |
3821 | ||
3822 | # The argument is the alias to list. | |
3823 | else { | |
3824 | @keys = ($DB::cmd); | |
3825 | } | |
3826 | ||
3827 | # List aliases. | |
3828 | for my $k (@keys) { | |
3829 | ||
3830 | # Messy metaquoting: Trim the substitution code off. | |
3831 | # We use control-G as the delimiter because it's not | |
3832 | # likely to appear in the alias. | |
3833 | if ( ( my $v = $alias{$k} ) =~ s\as\a$k\a(.*)\a$\a1\a ) { | |
3834 | ||
3835 | # Print the alias. | |
3836 | print $OUT "$k\t= $1\n"; | |
3837 | } | |
3838 | elsif ( defined $alias{$k} ) { | |
3839 | ||
3840 | # Couldn't trim it off; just print the alias code. | |
3841 | print $OUT "$k\t$alias{$k}\n"; | |
3842 | } | |
3843 | else { | |
3844 | ||
3845 | # No such, dude. | |
3846 | print "No alias for $k\n"; | |
3847 | } | |
3848 | } ## end for my $k (@keys) | |
3849 | next CMD; | |
3850 | } | |
3851 | ||
3852 | return; | |
3853 | } | |
3854 | ||
2ef1dcdb SF |
3855 | sub _handle_source_command { |
3856 | my $self = shift; | |
3857 | ||
3858 | # source - read commands from a file (or pipe!) and execute. | |
f89bf53e | 3859 | if (my $sourced_fn = $self->cmd_args) { |
2ef1dcdb SF |
3860 | if ( open my $fh, $sourced_fn ) { |
3861 | ||
3862 | # Opened OK; stick it in the list of file handles. | |
3863 | push @cmdfhs, $fh; | |
3864 | } | |
3865 | else { | |
3866 | ||
3867 | # Couldn't open it. | |
b5679dc0 | 3868 | DB::_db_warn("Can't execute '$sourced_fn': $!\n"); |
2ef1dcdb SF |
3869 | } |
3870 | next CMD; | |
3871 | } | |
3872 | ||
3873 | return; | |
3874 | } | |
3875 | ||
d0ecd4f3 SF |
3876 | sub _handle_enable_disable_commands { |
3877 | my $self = shift; | |
3878 | ||
b9920278 SF |
3879 | my $which_cmd = $self->cmd_verb; |
3880 | my $position = $self->cmd_args; | |
d0ecd4f3 | 3881 | |
b9920278 | 3882 | if ($position !~ /\s/) { |
d0ecd4f3 SF |
3883 | my ($fn, $line_num); |
3884 | if ($position =~ m{\A\d+\z}) | |
3885 | { | |
3886 | $fn = $DB::filename; | |
3887 | $line_num = $position; | |
3888 | } | |
3889 | elsif (my ($new_fn, $new_line_num) | |
3890 | = $position =~ m{\A(.*):(\d+)\z}) { | |
3891 | ($fn, $line_num) = ($new_fn, $new_line_num); | |
3892 | } | |
3893 | else | |
3894 | { | |
b5679dc0 | 3895 | DB::_db_warn("Wrong spec for enable/disable argument.\n"); |
d0ecd4f3 SF |
3896 | } |
3897 | ||
3898 | if (defined($fn)) { | |
3899 | if (DB::_has_breakpoint_data_ref($fn, $line_num)) { | |
3900 | DB::_set_breakpoint_enabled_status($fn, $line_num, | |
3901 | ($which_cmd eq 'enable' ? 1 : '') | |
3902 | ); | |
3903 | } | |
3904 | else { | |
b5679dc0 | 3905 | DB::_db_warn("No breakpoint set at ${fn}:${line_num}\n"); |
d0ecd4f3 SF |
3906 | } |
3907 | } | |
3908 | ||
3909 | next CMD; | |
3910 | } | |
3911 | ||
3912 | return; | |
3913 | } | |
3914 | ||
8baafc8b SF |
3915 | sub _handle_save_command { |
3916 | my $self = shift; | |
3917 | ||
f89bf53e | 3918 | if (my $new_fn = $self->cmd_args) { |
8baafc8b SF |
3919 | my $filename = $new_fn || '.perl5dbrc'; # default? |
3920 | if ( open my $fh, '>', $filename ) { | |
3921 | ||
3922 | # chomp to remove extraneous newlines from source'd files | |
3923 | chomp( my @truelist = | |
3924 | map { m/\A\s*(save|source)/ ? "#$_" : $_ } | |
3925 | @truehist ); | |
3926 | print {$fh} join( "\n", @truelist ); | |
3927 | print "commands saved in $filename\n"; | |
3928 | } | |
3929 | else { | |
b5679dc0 | 3930 | DB::_db_warn("Can't save debugger commands in '$new_fn': $!\n"); |
8baafc8b SF |
3931 | } |
3932 | next CMD; | |
3933 | } | |
3934 | ||
3935 | return; | |
3936 | } | |
3937 | ||
50a8a759 | 3938 | sub _n_or_s_and_arg_commands_generic { |
553947ba | 3939 | my ($self, $letter, $new_val) = @_; |
4f29ef90 SF |
3940 | |
3941 | # s - single-step. Remember the last command was 's'. | |
553947ba SF |
3942 | if ($DB::cmd =~ s#\A\Q$letter\E\s#\$DB::single = $new_val;\n#) { |
3943 | $laststep = $letter; | |
4f29ef90 SF |
3944 | } |
3945 | ||
3946 | return; | |
3947 | } | |
3948 | ||
466f24c7 | 3949 | sub _handle_sh_command { |
ddf4cf26 SF |
3950 | my $self = shift; |
3951 | ||
3952 | # $sh$sh - run a shell command (if it's all ASCII). | |
3953 | # Can't run shell commands with Unicode in the debugger, hmm. | |
466f24c7 SF |
3954 | my $my_cmd = $DB::cmd; |
3955 | if ($my_cmd =~ m#\A$sh#gms) { | |
ddf4cf26 | 3956 | |
466f24c7 SF |
3957 | if ($my_cmd =~ m#\G\z#cgms) { |
3958 | # Run the user's shell. If none defined, run Bourne. | |
3959 | # We resume execution when the shell terminates. | |
f0bb1409 | 3960 | DB::_db_system( $ENV{SHELL} || "/bin/sh" ); |
466f24c7 SF |
3961 | next CMD; |
3962 | } | |
c4ce0d59 | 3963 | elsif ($my_cmd =~ m#\G$sh\s*(.*)#cgms) { |
466f24c7 | 3964 | # System it. |
f0bb1409 | 3965 | DB::_db_system($1); |
466f24c7 SF |
3966 | next CMD; |
3967 | } | |
c4ce0d59 | 3968 | elsif ($my_cmd =~ m#\G\s*(.*)#cgms) { |
f0bb1409 | 3969 | DB::_db_system( $ENV{SHELL} || "/bin/sh", "-c", $1 ); |
466f24c7 SF |
3970 | next CMD; |
3971 | } | |
ddf4cf26 SF |
3972 | } |
3973 | } | |
3974 | ||
b8d11fe0 SF |
3975 | sub _handle_x_command { |
3976 | my $self = shift; | |
321095c5 | 3977 | |
b8d11fe0 SF |
3978 | if ($DB::cmd =~ s#\Ax\b# #) { # Remainder gets done by DB::eval() |
3979 | $onetimeDump = 'dump'; # main::dumpvar shows the output | |
3980 | ||
3981 | # handle special "x 3 blah" syntax XXX propagate | |
3982 | # doc back to special variables. | |
3983 | if ( $DB::cmd =~ s#\A\s*(\d+)(?=\s)# #) { | |
3984 | $onetimedumpDepth = $1; | |
3985 | } | |
3986 | } | |
3987 | ||
3988 | return; | |
3989 | } | |
3990 | ||
4d0e1f38 SF |
3991 | sub _handle_q_command { |
3992 | my $self = shift; | |
3993 | ||
601c6a23 | 3994 | if ($self->_is_full('q')) { |
4d0e1f38 SF |
3995 | $fall_off_end = 1; |
3996 | DB::clean_ENV(); | |
3997 | exit $?; | |
3998 | } | |
3999 | ||
4000 | return; | |
4001 | } | |
4002 | ||
70196538 SF |
4003 | sub _handle_cmd_wrapper_commands { |
4004 | my $self = shift; | |
4005 | ||
b9920278 SF |
4006 | DB::cmd_wrapper( $self->cmd_verb, $self->cmd_args, $line ); |
4007 | next CMD; | |
fbe9ebae SF |
4008 | } |
4009 | ||
4010 | sub _handle_special_char_cmd_wrapper_commands { | |
4011 | my $self = shift; | |
4012 | ||
4013 | # All of these commands were remapped in perl 5.8.0; | |
4014 | # we send them off to the secondary dispatcher (see below). | |
4015 | if (my ($cmd_letter, $my_arg) = $DB::cmd =~ /\A([<>\{]{1,2})\s*(.*)/so) { | |
70196538 SF |
4016 | DB::cmd_wrapper( $cmd_letter, $my_arg, $line ); |
4017 | next CMD; | |
4018 | } | |
4019 | ||
4020 | return; | |
4021 | } | |
fbe9ebae | 4022 | |
90fd4c80 KF |
4023 | } ## end DB::Obj |
4024 | ||
22fc883d SF |
4025 | package DB; |
4026 | ||
69893cff RGS |
4027 | # The following code may be executed now: |
4028 | # BEGIN {warn 4} | |
4029 | ||
4030 | =head2 sub | |
4031 | ||
b570d64b | 4032 | C<sub> is called whenever a subroutine call happens in the program being |
69893cff RGS |
4033 | debugged. The variable C<$DB::sub> contains the name of the subroutine |
4034 | being called. | |
4035 | ||
4036 | The core function of this subroutine is to actually call the sub in the proper | |
4037 | context, capturing its output. This of course causes C<DB::DB> to get called | |
4038 | again, repeating until the subroutine ends and returns control to C<DB::sub> | |
4039 | again. Once control returns, C<DB::sub> figures out whether or not to dump the | |
4040 | return value, and returns its captured copy of the return value as its own | |
4041 | return value. The value then feeds back into the program being debugged as if | |
4042 | C<DB::sub> hadn't been there at all. | |
4043 | ||
4044 | C<sub> does all the work of printing the subroutine entry and exit messages | |
4045 | enabled by setting C<$frame>. It notes what sub the autoloader got called for, | |
b570d64b | 4046 | and also prints the return value if needed (for the C<r> command and if |
69893cff RGS |
4047 | the 16 bit is set in C<$frame>). |
4048 | ||
4049 | It also tracks the subroutine call depth by saving the current setting of | |
4050 | C<$single> in the C<@stack> package global; if this exceeds the value in | |
4051 | C<$deep>, C<sub> automatically turns on printing of the current depth by | |
be9a9b1d | 4052 | setting the C<4> bit in C<$single>. In any case, it keeps the current setting |
69893cff RGS |
4053 | of stop/don't stop on entry to subs set as it currently is set. |
4054 | ||
4055 | =head3 C<caller()> support | |
4056 | ||
4057 | If C<caller()> is called from the package C<DB>, it provides some | |
4058 | additional data, in the following order: | |
4059 | ||
4060 | =over 4 | |
4061 | ||
4062 | =item * C<$package> | |
4063 | ||
4064 | The package name the sub was in | |
4065 | ||
4066 | =item * C<$filename> | |
4067 | ||
4068 | The filename it was defined in | |
4069 | ||
4070 | =item * C<$line> | |
4071 | ||
4072 | The line number it was defined on | |
4073 | ||
4074 | =item * C<$subroutine> | |
4075 | ||
be9a9b1d | 4076 | The subroutine name; C<(eval)> if an C<eval>(). |
69893cff RGS |
4077 | |
4078 | =item * C<$hasargs> | |
4079 | ||
4080 | 1 if it has arguments, 0 if not | |
4081 | ||
4082 | =item * C<$wantarray> | |
4083 | ||
4084 | 1 if array context, 0 if scalar context | |
4085 | ||
4086 | =item * C<$evaltext> | |
4087 | ||
4088 | The C<eval>() text, if any (undefined for C<eval BLOCK>) | |
4089 | ||
4090 | =item * C<$is_require> | |
4091 | ||
4092 | frame was created by a C<use> or C<require> statement | |
4093 | ||
4094 | =item * C<$hints> | |
4095 | ||
4096 | pragma information; subject to change between versions | |
4097 | ||
4098 | =item * C<$bitmask> | |
4099 | ||
be9a9b1d | 4100 | pragma information; subject to change between versions |
69893cff RGS |
4101 | |
4102 | =item * C<@DB::args> | |
4103 | ||
4104 | arguments with which the subroutine was invoked | |
4105 | ||
4106 | =back | |
4107 | ||
4108 | =cut | |
d338d6fe | 4109 | |
6b24a4b7 SF |
4110 | use vars qw($deep); |
4111 | ||
4112 | # We need to fully qualify the name ("DB::sub") to make "use strict;" | |
4113 | # happy. -- Shlomi Fish | |
262f8b44 | 4114 | |
6baf5dd0 SF |
4115 | sub _indent_print_line_info { |
4116 | my ($offset, $str) = @_; | |
4117 | ||
4118 | print_lineinfo( ' ' x ($stack_depth - $offset), $str); | |
4119 | ||
4120 | return; | |
4121 | } | |
4122 | ||
4123 | sub _print_frame_message { | |
4124 | my ($al) = @_; | |
4125 | ||
4126 | if ($frame) { | |
4127 | if ($frame & 4) { # Extended frame entry message | |
4128 | _indent_print_line_info(-1, "in "); | |
4129 | ||
4130 | # Why -1? But it works! :-( | |
4131 | # Because print_trace will call add 1 to it and then call | |
4132 | # dump_trace; this results in our skipping -1+1 = 0 stack frames | |
4133 | # in dump_trace. | |
4134 | # | |
4135 | # Now it's 0 because we extracted a function. | |
4136 | print_trace( $LINEINFO, 0, 1, 1, "$sub$al" ); | |
4137 | } | |
4138 | else { | |
4139 | _indent_print_line_info(-1, "entering $sub$al\n" ); | |
4140 | } | |
4141 | } | |
4142 | ||
4143 | return; | |
4144 | } | |
4145 | ||
6b24a4b7 | 4146 | sub DB::sub { |
2dbd01ad SF |
4147 | # lock ourselves under threads |
4148 | lock($DBGR); | |
2cbb2ee1 | 4149 | |
69893cff RGS |
4150 | # Whether or not the autoloader was running, a scalar to put the |
4151 | # sub's return value in (if needed), and an array to put the sub's | |
4152 | # return value in (if needed). | |
e22ea7cc | 4153 | my ( $al, $ret, @ret ) = ""; |
2dbd01ad SF |
4154 | if ($sub eq 'threads::new' && $ENV{PERL5DB_THREADED}) { |
4155 | print "creating new thread\n"; | |
4156 | } | |
69893cff | 4157 | |
c81c05fc | 4158 | # If the last ten characters are '::AUTOLOAD', note we've traced |
69893cff | 4159 | # into AUTOLOAD for $sub. |
e22ea7cc | 4160 | if ( length($sub) > 10 && substr( $sub, -10, 10 ) eq '::AUTOLOAD' ) { |
6b24a4b7 | 4161 | no strict 'refs'; |
c81c05fc | 4162 | $al = " for $$sub" if defined $$sub; |
d12a4851 | 4163 | } |
69893cff RGS |
4164 | |
4165 | # We stack the stack pointer and then increment it to protect us | |
4166 | # from a situation that might unwind a whole bunch of call frames | |
4167 | # at once. Localizing the stack pointer means that it will automatically | |
4168 | # unwind the same amount when multiple stack frames are unwound. | |
e22ea7cc | 4169 | local $stack_depth = $stack_depth + 1; # Protect from non-local exits |
69893cff RGS |
4170 | |
4171 | # Expand @stack. | |
d12a4851 | 4172 | $#stack = $stack_depth; |
69893cff RGS |
4173 | |
4174 | # Save current single-step setting. | |
d12a4851 | 4175 | $stack[-1] = $single; |
69893cff | 4176 | |
e22ea7cc | 4177 | # Turn off all flags except single-stepping. |
d12a4851 | 4178 | $single &= 1; |
69893cff RGS |
4179 | |
4180 | # If we've gotten really deeply recursed, turn on the flag that will | |
4181 | # make us stop with the 'deep recursion' message. | |
d12a4851 | 4182 | $single |= 4 if $stack_depth == $deep; |
69893cff RGS |
4183 | |
4184 | # If frame messages are on ... | |
e22ea7cc | 4185 | |
6baf5dd0 SF |
4186 | _print_frame_message($al); |
4187 | # standard frame entry message | |
69893cff | 4188 | |
262f8b44 SF |
4189 | my $print_exit_msg = sub { |
4190 | # Check for exit trace messages... | |
4191 | if ($frame & 2) | |
4192 | { | |
4193 | if ($frame & 4) # Extended exit message | |
4194 | { | |
6baf5dd0 | 4195 | _indent_print_line_info(0, "out "); |
262f8b44 SF |
4196 | print_trace( $LINEINFO, 0, 1, 1, "$sub$al" ); |
4197 | } | |
4198 | else | |
4199 | { | |
6baf5dd0 | 4200 | _indent_print_line_info(0, "exited $sub$al\n" ); |
262f8b44 SF |
4201 | } |
4202 | } | |
4203 | return; | |
4204 | }; | |
4205 | ||
98dc9551 | 4206 | # Determine the sub's return type, and capture appropriately. |
d12a4851 | 4207 | if (wantarray) { |
e22ea7cc | 4208 | |
69893cff RGS |
4209 | # Called in array context. call sub and capture output. |
4210 | # DB::DB will recursively get control again if appropriate; we'll come | |
4211 | # back here when the sub is finished. | |
6b24a4b7 SF |
4212 | { |
4213 | no strict 'refs'; | |
4214 | @ret = &$sub; | |
4215 | } | |
69893cff RGS |
4216 | |
4217 | # Pop the single-step value back off the stack. | |
e22ea7cc | 4218 | $single |= $stack[ $stack_depth-- ]; |
69893cff | 4219 | |
262f8b44 | 4220 | $print_exit_msg->(); |
69893cff RGS |
4221 | |
4222 | # Print the return info if we need to. | |
e22ea7cc RF |
4223 | if ( $doret eq $stack_depth or $frame & 16 ) { |
4224 | ||
69893cff | 4225 | # Turn off output record separator. |
e22ea7cc RF |
4226 | local $\ = ''; |
4227 | my $fh = ( $doret eq $stack_depth ? $OUT : $LINEINFO ); | |
69893cff RGS |
4228 | |
4229 | # Indent if we're printing because of $frame tracing. | |
262f8b44 SF |
4230 | if ($frame & 16) |
4231 | { | |
4232 | print {$fh} ' ' x $stack_depth; | |
4233 | } | |
69893cff RGS |
4234 | |
4235 | # Print the return value. | |
262f8b44 | 4236 | print {$fh} "list context return from $sub:\n"; |
e22ea7cc | 4237 | dumpit( $fh, \@ret ); |
69893cff RGS |
4238 | |
4239 | # And don't print it again. | |
e22ea7cc | 4240 | $doret = -2; |
69893cff | 4241 | } ## end if ($doret eq $stack_depth... |
e22ea7cc RF |
4242 | # And we have to return the return value now. |
4243 | @ret; | |
69893cff RGS |
4244 | } ## end if (wantarray) |
4245 | ||
4246 | # Scalar context. | |
4247 | else { | |
2dbd01ad SF |
4248 | if ( defined wantarray ) { |
4249 | no strict 'refs'; | |
4250 | # Save the value if it's wanted at all. | |
4251 | $ret = &$sub; | |
4252 | } | |
4253 | else { | |
4254 | no strict 'refs'; | |
4255 | # Void return, explicitly. | |
4256 | &$sub; | |
4257 | undef $ret; | |
4258 | } | |
69893cff RGS |
4259 | |
4260 | # Pop the single-step value off the stack. | |
e22ea7cc | 4261 | $single |= $stack[ $stack_depth-- ]; |
69893cff RGS |
4262 | |
4263 | # If we're doing exit messages... | |
262f8b44 | 4264 | $print_exit_msg->(); |
69893cff RGS |
4265 | |
4266 | # If we are supposed to show the return value... same as before. | |
e22ea7cc RF |
4267 | if ( $doret eq $stack_depth or $frame & 16 and defined wantarray ) { |
4268 | local $\ = ''; | |
4269 | my $fh = ( $doret eq $stack_depth ? $OUT : $LINEINFO ); | |
4270 | print $fh ( ' ' x $stack_depth ) if $frame & 16; | |
4271 | print $fh ( | |
4272 | defined wantarray | |
4273 | ? "scalar context return from $sub: " | |
4274 | : "void context return from $sub\n" | |
4275 | ); | |
4276 | dumpit( $fh, $ret ) if defined wantarray; | |
4277 | $doret = -2; | |
69893cff RGS |
4278 | } ## end if ($doret eq $stack_depth... |
4279 | ||
4280 | # Return the appropriate scalar value. | |
e22ea7cc | 4281 | $ret; |
69893cff | 4282 | } ## end else [ if (wantarray) |
6b24a4b7 | 4283 | } ## end sub _sub |
69893cff | 4284 | |
89d1f0ef SP |
4285 | sub lsub : lvalue { |
4286 | ||
6b24a4b7 SF |
4287 | no strict 'refs'; |
4288 | ||
2dbd01ad SF |
4289 | # lock ourselves under threads |
4290 | lock($DBGR); | |
89d1f0ef SP |
4291 | |
4292 | # Whether or not the autoloader was running, a scalar to put the | |
4293 | # sub's return value in (if needed), and an array to put the sub's | |
4294 | # return value in (if needed). | |
4295 | my ( $al, $ret, @ret ) = ""; | |
2dbd01ad SF |
4296 | if ($sub =~ /^threads::new$/ && $ENV{PERL5DB_THREADED}) { |
4297 | print "creating new thread\n"; | |
4298 | } | |
89d1f0ef SP |
4299 | |
4300 | # If the last ten characters are C'::AUTOLOAD', note we've traced | |
4301 | # into AUTOLOAD for $sub. | |
4302 | if ( length($sub) > 10 && substr( $sub, -10, 10 ) eq '::AUTOLOAD' ) { | |
4303 | $al = " for $$sub"; | |
4304 | } | |
4305 | ||
4306 | # We stack the stack pointer and then increment it to protect us | |
4307 | # from a situation that might unwind a whole bunch of call frames | |
4308 | # at once. Localizing the stack pointer means that it will automatically | |
4309 | # unwind the same amount when multiple stack frames are unwound. | |
4310 | local $stack_depth = $stack_depth + 1; # Protect from non-local exits | |
4311 | ||
4312 | # Expand @stack. | |
4313 | $#stack = $stack_depth; | |
4314 | ||
4315 | # Save current single-step setting. | |
4316 | $stack[-1] = $single; | |
4317 | ||
4318 | # Turn off all flags except single-stepping. | |
bf261418 FC |
4319 | # Use local so the single-step value is popped back off the |
4320 | # stack for us. | |
4321 | local $single = $single & 1; | |
89d1f0ef SP |
4322 | |
4323 | # If we've gotten really deeply recursed, turn on the flag that will | |
4324 | # make us stop with the 'deep recursion' message. | |
4325 | $single |= 4 if $stack_depth == $deep; | |
4326 | ||
4327 | # If frame messages are on ... | |
6baf5dd0 | 4328 | _print_frame_message($al); |
89d1f0ef | 4329 | |
89d1f0ef SP |
4330 | # call the original lvalue sub. |
4331 | &$sub; | |
4332 | } | |
4333 | ||
611272bb PS |
4334 | # Abstracting common code from multiple places elsewhere: |
4335 | sub depth_print_lineinfo { | |
8dc67a69 SF |
4336 | my $always_print = shift; |
4337 | ||
4338 | print_lineinfo( @_ ) if ($always_print or $stack_depth < $trace_to_depth); | |
611272bb PS |
4339 | } |
4340 | ||
69893cff RGS |
4341 | =head1 EXTENDED COMMAND HANDLING AND THE COMMAND API |
4342 | ||
4343 | In Perl 5.8.0, there was a major realignment of the commands and what they did, | |
4344 | Most of the changes were to systematize the command structure and to eliminate | |
4345 | commands that threw away user input without checking. | |
4346 | ||
b570d64b SF |
4347 | The following sections describe the code added to make it easy to support |
4348 | multiple command sets with conflicting command names. This section is a start | |
69893cff RGS |
4349 | at unifying all command processing to make it simpler to develop commands. |
4350 | ||
b570d64b | 4351 | Note that all the cmd_[a-zA-Z] subroutines require the command name, a line |
69893cff RGS |
4352 | number, and C<$dbline> (the current line) as arguments. |
4353 | ||
b570d64b | 4354 | Support functions in this section which have multiple modes of failure C<die> |
69893cff RGS |
4355 | on error; the rest simply return a false value. |
4356 | ||
4357 | The user-interface functions (all of the C<cmd_*> functions) just output | |
4358 | error messages. | |
4359 | ||
4360 | =head2 C<%set> | |
4361 | ||
4362 | The C<%set> hash defines the mapping from command letter to subroutine | |
b570d64b | 4363 | name suffix. |
69893cff RGS |
4364 | |
4365 | C<%set> is a two-level hash, indexed by set name and then by command name. | |
be9a9b1d AT |
4366 | Note that trying to set the CommandSet to C<foobar> simply results in the |
4367 | 5.8.0 command set being used, since there's no top-level entry for C<foobar>. | |
69893cff | 4368 | |
b570d64b | 4369 | =cut |
d338d6fe | 4370 | |
d12a4851 | 4371 | ### The API section |
f1583d8f | 4372 | |
e22ea7cc RF |
4373 | my %set = ( # |
4374 | 'pre580' => { | |
4375 | 'a' => 'pre580_a', | |
4376 | 'A' => 'pre580_null', | |
4377 | 'b' => 'pre580_b', | |
4378 | 'B' => 'pre580_null', | |
4379 | 'd' => 'pre580_null', | |
4380 | 'D' => 'pre580_D', | |
4381 | 'h' => 'pre580_h', | |
4382 | 'M' => 'pre580_null', | |
4383 | 'O' => 'o', | |
4384 | 'o' => 'pre580_null', | |
4385 | 'v' => 'M', | |
4386 | 'w' => 'v', | |
4387 | 'W' => 'pre580_W', | |
69893cff | 4388 | }, |
e22ea7cc RF |
4389 | 'pre590' => { |
4390 | '<' => 'pre590_prepost', | |
4391 | '<<' => 'pre590_prepost', | |
4392 | '>' => 'pre590_prepost', | |
4393 | '>>' => 'pre590_prepost', | |
4394 | '{' => 'pre590_prepost', | |
4395 | '{{' => 'pre590_prepost', | |
69893cff | 4396 | }, |
d12a4851 | 4397 | ); |
492652be | 4398 | |
e09195af SF |
4399 | my %breakpoints_data; |
4400 | ||
4401 | sub _has_breakpoint_data_ref { | |
4402 | my ($filename, $line) = @_; | |
4403 | ||
4404 | return ( | |
4405 | exists( $breakpoints_data{$filename} ) | |
4406 | and | |
4407 | exists( $breakpoints_data{$filename}{$line} ) | |
4408 | ); | |
4409 | } | |
4410 | ||
4411 | sub _get_breakpoint_data_ref { | |
4412 | my ($filename, $line) = @_; | |
4413 | ||
4414 | return ($breakpoints_data{$filename}{$line} ||= +{}); | |
4415 | } | |
4416 | ||
4417 | sub _delete_breakpoint_data_ref { | |
4418 | my ($filename, $line) = @_; | |
4419 | ||
4420 | delete($breakpoints_data{$filename}{$line}); | |
4421 | if (! scalar(keys( %{$breakpoints_data{$filename}} )) ) { | |
4422 | delete($breakpoints_data{$filename}); | |
4423 | } | |
4424 | ||
4425 | return; | |
4426 | } | |
4427 | ||
4428 | sub _set_breakpoint_enabled_status { | |
4429 | my ($filename, $line, $status) = @_; | |
4430 | ||
4431 | _get_breakpoint_data_ref($filename, $line)->{'enabled'} = | |
4432 | ($status ? 1 : '') | |
4433 | ; | |
4434 | ||
4435 | return; | |
4436 | } | |
4437 | ||
5d5d9ea3 SF |
4438 | sub _enable_breakpoint_temp_enabled_status { |
4439 | my ($filename, $line) = @_; | |
4440 | ||
4441 | _get_breakpoint_data_ref($filename, $line)->{'temp_enabled'} = 1; | |
4442 | ||
4443 | return; | |
4444 | } | |
4445 | ||
4446 | sub _cancel_breakpoint_temp_enabled_status { | |
4447 | my ($filename, $line) = @_; | |
4448 | ||
4449 | my $ref = _get_breakpoint_data_ref($filename, $line); | |
b570d64b | 4450 | |
5d5d9ea3 SF |
4451 | delete ($ref->{'temp_enabled'}); |
4452 | ||
4453 | if (! %$ref) { | |
4454 | _delete_breakpoint_data_ref($filename, $line); | |
4455 | } | |
4456 | ||
4457 | return; | |
4458 | } | |
4459 | ||
e09195af SF |
4460 | sub _is_breakpoint_enabled { |
4461 | my ($filename, $line) = @_; | |
4462 | ||
5d5d9ea3 SF |
4463 | my $data_ref = _get_breakpoint_data_ref($filename, $line); |
4464 | return ($data_ref->{'enabled'} || $data_ref->{'temp_enabled'}); | |
e09195af SF |
4465 | } |
4466 | ||
69893cff RGS |
4467 | =head2 C<cmd_wrapper()> (API) |
4468 | ||
b570d64b SF |
4469 | C<cmd_wrapper()> allows the debugger to switch command sets |
4470 | depending on the value of the C<CommandSet> option. | |
69893cff | 4471 | |
be9a9b1d | 4472 | It tries to look up the command in the C<%set> package-level I<lexical> |
b570d64b SF |
4473 | (which means external entities can't fiddle with it) and create the name of |
4474 | the sub to call based on the value found in the hash (if it's there). I<All> | |
4475 | of the commands to be handled in a set have to be added to C<%set>; if they | |
69893cff RGS |
4476 | aren't found, the 5.8.0 equivalent is called (if there is one). |
4477 | ||
b570d64b | 4478 | This code uses symbolic references. |
69893cff RGS |
4479 | |
4480 | =cut | |
4481 | ||
d12a4851 | 4482 | sub cmd_wrapper { |
69893cff RGS |
4483 | my $cmd = shift; |
4484 | my $line = shift; | |
4485 | my $dblineno = shift; | |
4486 | ||
e22ea7cc | 4487 | # Assemble the command subroutine's name by looking up the |
69893cff RGS |
4488 | # command set and command name in %set. If we can't find it, |
4489 | # default to the older version of the command. | |
4490 | my $call = 'cmd_' | |
e22ea7cc | 4491 | . ( $set{$CommandSet}{$cmd} |
d7f78c33 | 4492 | || ( $cmd =~ /\A[<>{]+/o ? 'prepost' : $cmd ) ); |
69893cff RGS |
4493 | |
4494 | # Call the command subroutine, call it by name. | |
6b24a4b7 | 4495 | return __PACKAGE__->can($call)->( $cmd, $line, $dblineno ); |
e22ea7cc | 4496 | } ## end sub cmd_wrapper |
492652be | 4497 | |
69893cff RGS |
4498 | =head3 C<cmd_a> (command) |
4499 | ||
4500 | The C<a> command handles pre-execution actions. These are associated with a | |
b570d64b SF |
4501 | particular line, so they're stored in C<%dbline>. We default to the current |
4502 | line if none is specified. | |
69893cff RGS |
4503 | |
4504 | =cut | |
4505 | ||
d12a4851 | 4506 | sub cmd_a { |
e22ea7cc RF |
4507 | my $cmd = shift; |
4508 | my $line = shift || ''; # [.|line] expr | |
4509 | my $dbline = shift; | |
69893cff RGS |
4510 | |
4511 | # If it's dot (here), or not all digits, use the current line. | |
f4beae36 | 4512 | $line =~ s/\A\./$dbline/; |
69893cff | 4513 | |
e22ea7cc | 4514 | # Should be a line number followed by an expression. |
f4beae36 SF |
4515 | if ( my ($lineno, $expr) = $line =~ /^\s*(\d*)\s*(\S.+)/ ) { |
4516 | ||
4517 | if (! length($lineno)) { | |
4518 | $lineno = $dbline; | |
4519 | } | |
69893cff RGS |
4520 | |
4521 | # If we have an expression ... | |
e22ea7cc RF |
4522 | if ( length $expr ) { |
4523 | ||
69893cff | 4524 | # ... but the line isn't breakable, complain. |
e22ea7cc RF |
4525 | if ( $dbline[$lineno] == 0 ) { |
4526 | print $OUT | |
4527 | "Line $lineno($dbline[$lineno]) does not have an action?\n"; | |
4528 | } | |
69893cff | 4529 | else { |
e22ea7cc | 4530 | |
69893cff RGS |
4531 | # It's executable. Record that the line has an action. |
4532 | $had_breakpoints{$filename} |= 2; | |
4533 | ||
4534 | # Remove any action, temp breakpoint, etc. | |
4535 | $dbline{$lineno} =~ s/\0[^\0]*//; | |
4536 | ||
4537 | # Add the action to the line. | |
4538 | $dbline{$lineno} .= "\0" . action($expr); | |
72d7d80d SF |
4539 | |
4540 | _set_breakpoint_enabled_status($filename, $lineno, 1); | |
69893cff RGS |
4541 | } |
4542 | } ## end if (length $expr) | |
4543 | } ## end if ($line =~ /^\s*(\d*)\s*(\S.+)/) | |
4544 | else { | |
e22ea7cc | 4545 | |
69893cff | 4546 | # Syntax wrong. |
e22ea7cc RF |
4547 | print $OUT |
4548 | "Adding an action requires an optional lineno and an expression\n" | |
4549 | ; # hint | |
69893cff RGS |
4550 | } |
4551 | } ## end sub cmd_a | |
4552 | ||
4553 | =head3 C<cmd_A> (command) | |
4554 | ||
4555 | Delete actions. Similar to above, except the delete code is in a separate | |
4556 | subroutine, C<delete_action>. | |
4557 | ||
4558 | =cut | |
492652be | 4559 | |
d12a4851 | 4560 | sub cmd_A { |
e22ea7cc | 4561 | my $cmd = shift; |
69893cff | 4562 | my $line = shift || ''; |
e22ea7cc | 4563 | my $dbline = shift; |
69893cff RGS |
4564 | |
4565 | # Dot is this line. | |
4566 | $line =~ s/^\./$dbline/; | |
4567 | ||
4568 | # Call delete_action with a null param to delete them all. | |
4569 | # The '1' forces the eval to be true. It'll be false only | |
4570 | # if delete_action blows up for some reason, in which case | |
4571 | # we print $@ and get out. | |
e22ea7cc | 4572 | if ( $line eq '*' ) { |
baf70c80 SF |
4573 | if (! eval { _delete_all_actions(); 1 }) { |
4574 | print {$OUT} $@; | |
4575 | return; | |
4576 | } | |
e22ea7cc RF |
4577 | } |
4578 | ||
69893cff RGS |
4579 | # There's a real line number. Pass it to delete_action. |
4580 | # Error trapping is as above. | |
e22ea7cc | 4581 | elsif ( $line =~ /^(\S.*)/ ) { |
baf70c80 SF |
4582 | if (! eval { delete_action($1); 1 }) { |
4583 | print {$OUT} $@; | |
4584 | return; | |
4585 | } | |
e22ea7cc | 4586 | } |
69893cff RGS |
4587 | |
4588 | # Swing and a miss. Bad syntax. | |
4589 | else { | |
e22ea7cc RF |
4590 | print $OUT |
4591 | "Deleting an action requires a line number, or '*' for all\n" ; # hint | |
69893cff RGS |
4592 | } |
4593 | } ## end sub cmd_A | |
4594 | ||
4595 | =head3 C<delete_action> (API) | |
4596 | ||
4597 | C<delete_action> accepts either a line number or C<undef>. If a line number | |
b570d64b | 4598 | is specified, we check for the line being executable (if it's not, it |
69893cff RGS |
4599 | couldn't have had an action). If it is, we just take the action off (this |
4600 | will get any kind of an action, including breakpoints). | |
4601 | ||
4602 | =cut | |
492652be | 4603 | |
d8ff050e SF |
4604 | sub _remove_action_from_dbline { |
4605 | my $i = shift; | |
4606 | ||
4607 | $dbline{$i} =~ s/\0[^\0]*//; # \^a | |
4608 | delete $dbline{$i} if $dbline{$i} eq ''; | |
4609 | ||
4610 | return; | |
4611 | } | |
4612 | ||
4613 | sub _delete_all_actions { | |
4614 | print {$OUT} "Deleting all actions...\n"; | |
4615 | ||
4616 | for my $file ( keys %had_breakpoints ) { | |
4617 | local *dbline = $main::{ '_<' . $file }; | |
4618 | $max = $#dbline; | |
4619 | my $was; | |
4620 | for my $i (1 .. $max) { | |
4621 | if ( defined $dbline{$i} ) { | |
4622 | _remove_action_from_dbline($i); | |
4623 | } | |
4624 | } | |
4625 | ||
4626 | unless ( $had_breakpoints{$file} &= ~2 ) { | |
4627 | delete $had_breakpoints{$file}; | |
4628 | } | |
4629 | } | |
4630 | ||
4631 | return; | |
4632 | } | |
4633 | ||
d12a4851 | 4634 | sub delete_action { |
e22ea7cc | 4635 | my $i = shift; |
e22ea7cc | 4636 | |
d8ff050e | 4637 | if ( defined($i) ) { |
69893cff RGS |
4638 | # Can there be one? |
4639 | die "Line $i has no action .\n" if $dbline[$i] == 0; | |
4640 | ||
4641 | # Nuke whatever's there. | |
d8ff050e | 4642 | _remove_action_from_dbline($i); |
e22ea7cc RF |
4643 | } |
4644 | else { | |
d8ff050e SF |
4645 | _delete_all_actions(); |
4646 | } | |
4647 | } | |
69893cff RGS |
4648 | |
4649 | =head3 C<cmd_b> (command) | |
4650 | ||
4651 | Set breakpoints. Since breakpoints can be set in so many places, in so many | |
4652 | ways, conditionally or not, the breakpoint code is kind of complex. Mostly, | |
4653 | we try to parse the command type, and then shuttle it off to an appropriate | |
4654 | subroutine to actually do the work of setting the breakpoint in the right | |
4655 | place. | |
4656 | ||
4657 | =cut | |
492652be | 4658 | |
d12a4851 | 4659 | sub cmd_b { |
e22ea7cc RF |
4660 | my $cmd = shift; |
4661 | my $line = shift; # [.|line] [cond] | |
4662 | my $dbline = shift; | |
69893cff | 4663 | |
6f547d17 SF |
4664 | my $default_cond = sub { |
4665 | my $cond = shift; | |
4666 | return length($cond) ? $cond : '1'; | |
4667 | }; | |
4668 | ||
69893cff | 4669 | # Make . the current line number if it's there.. |
5343a617 | 4670 | $line =~ s/^\.(\s|\z)/$dbline$1/; |
69893cff | 4671 | |
e22ea7cc RF |
4672 | # No line number, no condition. Simple break on current line. |
4673 | if ( $line =~ /^\s*$/ ) { | |
9590c675 | 4674 | cmd_b_line( $dbline, 1 ); |
e22ea7cc | 4675 | } |
69893cff RGS |
4676 | |
4677 | # Break on load for a file. | |
9590c675 SF |
4678 | elsif ( my ($file) = $line =~ /^load\b\s*(.*)/ ) { |
4679 | $file =~ s/\s+\z//; | |
4680 | cmd_b_load($file); | |
e22ea7cc | 4681 | } |
69893cff RGS |
4682 | |
4683 | # b compile|postpone <some sub> [<condition>] | |
e22ea7cc | 4684 | # The interpreter actually traps this one for us; we just put the |
69893cff | 4685 | # necessary condition in the %postponed hash. |
3c26e84b SF |
4686 | elsif ( my ($action, $subname, $cond) |
4687 | = $line =~ /^(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ ) { | |
69893cff RGS |
4688 | |
4689 | # De-Perl4-ify the name - ' separators to ::. | |
3c26e84b | 4690 | $subname =~ s/'/::/g; |
69893cff RGS |
4691 | |
4692 | # Qualify it into the current package unless it's already qualified. | |
ea7bdd87 | 4693 | $subname = "${package}::" . $subname unless $subname =~ /::/; |
69893cff RGS |
4694 | |
4695 | # Add main if it starts with ::. | |
e22ea7cc | 4696 | $subname = "main" . $subname if substr( $subname, 0, 2 ) eq "::"; |
69893cff RGS |
4697 | |
4698 | # Save the break type for this sub. | |
3c26e84b SF |
4699 | $postponed{$subname} = (($action eq 'postpone') |
4700 | ? ( "break +0 if " . $default_cond->($cond) ) | |
4701 | : "compile"); | |
69893cff | 4702 | } ## end elsif ($line =~ ... |
076b743f | 4703 | # b <filename>:<line> [<condition>] |
9590c675 SF |
4704 | elsif (my ($filename, $line_num, $cond) |
4705 | = $line =~ /\A(\S+[^:]):(\d+)\s*(.*)/ms) { | |
076b743f SF |
4706 | cmd_b_filename_line( |
4707 | $filename, | |
b570d64b | 4708 | $line_num, |
076b743f SF |
4709 | (length($cond) ? $cond : '1'), |
4710 | ); | |
4711 | } | |
69893cff | 4712 | # b <sub name> [<condition>] |
6f547d17 | 4713 | elsif ( my ($new_subname, $new_cond) = |
9590c675 | 4714 | $line =~ /^([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/ ) { |
e22ea7cc | 4715 | |
69893cff | 4716 | # |
9590c675 | 4717 | $subname = $new_subname; |
6f547d17 | 4718 | cmd_b_sub( $subname, $default_cond->($new_cond) ); |
e22ea7cc | 4719 | } |
69893cff RGS |
4720 | |
4721 | # b <line> [<condition>]. | |
9590c675 | 4722 | elsif ( my ($line_n, $cond) = $line =~ /^(\d*)\s*(.*)/ ) { |
e22ea7cc | 4723 | |
69893cff | 4724 | # Capture the line. If none, it's the current line. |
9590c675 | 4725 | $line = $line_n || $dbline; |
69893cff | 4726 | |
69893cff | 4727 | # Break on line. |
6f547d17 | 4728 | cmd_b_line( $line, $default_cond->($cond) ); |
e22ea7cc | 4729 | } |
69893cff RGS |
4730 | |
4731 | # Line didn't make sense. | |
4732 | else { | |
4733 | print "confused by line($line)?\n"; | |
4734 | } | |
9590c675 SF |
4735 | |
4736 | return; | |
69893cff RGS |
4737 | } ## end sub cmd_b |
4738 | ||
4739 | =head3 C<break_on_load> (API) | |
4740 | ||
4741 | We want to break when this file is loaded. Mark this file in the | |
b570d64b | 4742 | C<%break_on_load> hash, and note that it has a breakpoint in |
69893cff RGS |
4743 | C<%had_breakpoints>. |
4744 | ||
4745 | =cut | |
4746 | ||
d12a4851 | 4747 | sub break_on_load { |
e22ea7cc RF |
4748 | my $file = shift; |
4749 | $break_on_load{$file} = 1; | |
4750 | $had_breakpoints{$file} |= 1; | |
d12a4851 | 4751 | } |
f1583d8f | 4752 | |
69893cff RGS |
4753 | =head3 C<report_break_on_load> (API) |
4754 | ||
b570d64b | 4755 | Gives us an array of filenames that are set to break on load. Note that |
69893cff RGS |
4756 | only files with break-on-load are in here, so simply showing the keys |
4757 | suffices. | |
4758 | ||
4759 | =cut | |
4760 | ||
d12a4851 | 4761 | sub report_break_on_load { |
e22ea7cc | 4762 | sort keys %break_on_load; |
d12a4851 | 4763 | } |
f1583d8f | 4764 | |
69893cff RGS |
4765 | =head3 C<cmd_b_load> (command) |
4766 | ||
4767 | We take the file passed in and try to find it in C<%INC> (which maps modules | |
b570d64b | 4768 | to files they came from). We mark those files for break-on-load via |
69893cff RGS |
4769 | C<break_on_load> and then report that it was done. |
4770 | ||
4771 | =cut | |
4772 | ||
d12a4851 | 4773 | sub cmd_b_load { |
e22ea7cc RF |
4774 | my $file = shift; |
4775 | my @files; | |
69893cff RGS |
4776 | |
4777 | # This is a block because that way we can use a redo inside it | |
4778 | # even without there being any looping structure at all outside it. | |
e22ea7cc RF |
4779 | { |
4780 | ||
69893cff | 4781 | # Save short name and full path if found. |
e22ea7cc RF |
4782 | push @files, $file; |
4783 | push @files, $::INC{$file} if $::INC{$file}; | |
69893cff | 4784 | |
e22ea7cc | 4785 | # Tack on .pm and do it again unless there was a '.' in the name |
69893cff | 4786 | # already. |
e22ea7cc RF |
4787 | $file .= '.pm', redo unless $file =~ /\./; |
4788 | } | |
69893cff RGS |
4789 | |
4790 | # Do the real work here. | |
e22ea7cc | 4791 | break_on_load($_) for @files; |
69893cff RGS |
4792 | |
4793 | # All the files that have break-on-load breakpoints. | |
e22ea7cc | 4794 | @files = report_break_on_load; |
69893cff RGS |
4795 | |
4796 | # Normalize for the purposes of our printing this. | |
e22ea7cc RF |
4797 | local $\ = ''; |
4798 | local $" = ' '; | |
1f874cb6 | 4799 | print $OUT "Will stop on load of '@files'.\n"; |
e22ea7cc | 4800 | } ## end sub cmd_b_load |
f1583d8f | 4801 | |
69893cff RGS |
4802 | =head3 C<$filename_error> (API package global) |
4803 | ||
4804 | Several of the functions we need to implement in the API need to work both | |
4805 | on the current file and on other files. We don't want to duplicate code, so | |
b570d64b | 4806 | C<$filename_error> is used to contain the name of the file that's being |
69893cff RGS |
4807 | worked on (if it's not the current one). |
4808 | ||
4809 | We can now build functions in pairs: the basic function works on the current | |
4810 | file, and uses C<$filename_error> as part of its error message. Since this is | |
be9a9b1d | 4811 | initialized to C<"">, no filename will appear when we are working on the |
69893cff RGS |
4812 | current file. |
4813 | ||
4814 | The second function is a wrapper which does the following: | |
4815 | ||
b570d64b | 4816 | =over 4 |
69893cff | 4817 | |
be9a9b1d AT |
4818 | =item * |
4819 | ||
4820 | Localizes C<$filename_error> and sets it to the name of the file to be processed. | |
4821 | ||
4822 | =item * | |
4823 | ||
b570d64b | 4824 | Localizes the C<*dbline> glob and reassigns it to point to the file we want to process. |
69893cff | 4825 | |
be9a9b1d | 4826 | =item * |
69893cff | 4827 | |
b570d64b | 4828 | Calls the first function. |
69893cff | 4829 | |
be9a9b1d | 4830 | The first function works on the I<current> file (i.e., the one we changed to), |
69893cff | 4831 | and prints C<$filename_error> in the error message (the name of the other file) |
be9a9b1d AT |
4832 | if it needs to. When the functions return, C<*dbline> is restored to point |
4833 | to the actual current file (the one we're executing in) and | |
4834 | C<$filename_error> is restored to C<"">. This restores everything to | |
4835 | the way it was before the second function was called at all. | |
69893cff RGS |
4836 | |
4837 | See the comments in C<breakable_line> and C<breakable_line_in_file> for more | |
4838 | details. | |
4839 | ||
4840 | =back | |
4841 | ||
4842 | =cut | |
4843 | ||
6b24a4b7 | 4844 | use vars qw($filename_error); |
d12a4851 | 4845 | $filename_error = ''; |
f1583d8f | 4846 | |
be9a9b1d | 4847 | =head3 breakable_line(from, to) (API) |
69893cff RGS |
4848 | |
4849 | The subroutine decides whether or not a line in the current file is breakable. | |
4850 | It walks through C<@dbline> within the range of lines specified, looking for | |
4851 | the first line that is breakable. | |
4852 | ||
b570d64b | 4853 | If C<$to> is greater than C<$from>, the search moves forwards, finding the |
69893cff RGS |
4854 | first line I<after> C<$to> that's breakable, if there is one. |
4855 | ||
4856 | If C<$from> is greater than C<$to>, the search goes I<backwards>, finding the | |
4857 | first line I<before> C<$to> that's breakable, if there is one. | |
4858 | ||
4859 | =cut | |
4860 | ||
d12a4851 | 4861 | sub breakable_line { |
69893cff | 4862 | |
e22ea7cc | 4863 | my ( $from, $to ) = @_; |
69893cff RGS |
4864 | |
4865 | # $i is the start point. (Where are the FORTRAN programs of yesteryear?) | |
e22ea7cc | 4866 | my $i = $from; |
69893cff RGS |
4867 | |
4868 | # If there are at least 2 arguments, we're trying to search a range. | |
e22ea7cc | 4869 | if ( @_ >= 2 ) { |
69893cff RGS |
4870 | |
4871 | # $delta is positive for a forward search, negative for a backward one. | |
e22ea7cc | 4872 | my $delta = $from < $to ? +1 : -1; |
69893cff RGS |
4873 | |
4874 | # Keep us from running off the ends of the file. | |
e22ea7cc | 4875 | my $limit = $delta > 0 ? $#dbline : 1; |
69893cff RGS |
4876 | |
4877 | # Clever test. If you're a mathematician, it's obvious why this | |
4878 | # test works. If not: | |
4879 | # If $delta is positive (going forward), $limit will be $#dbline. | |
4880 | # If $to is less than $limit, ($limit - $to) will be positive, times | |
4881 | # $delta of 1 (positive), so the result is > 0 and we should use $to | |
e22ea7cc | 4882 | # as the stopping point. |
69893cff RGS |
4883 | # |
4884 | # If $to is greater than $limit, ($limit - $to) is negative, | |
e22ea7cc | 4885 | # times $delta of 1 (positive), so the result is < 0 and we should |
69893cff RGS |
4886 | # use $limit ($#dbline) as the stopping point. |
4887 | # | |
e22ea7cc | 4888 | # If $delta is negative (going backward), $limit will be 1. |
69893cff RGS |
4889 | # If $to is zero, ($limit - $to) will be 1, times $delta of -1 |
4890 | # (negative) so the result is > 0, and we use $to as the stopping | |
4891 | # point. | |
4892 | # | |
4893 | # If $to is less than zero, ($limit - $to) will be positive, | |
e22ea7cc RF |
4894 | # times $delta of -1 (negative), so the result is not > 0, and |
4895 | # we use $limit (1) as the stopping point. | |
69893cff RGS |
4896 | # |
4897 | # If $to is 1, ($limit - $to) will zero, times $delta of -1 | |
e22ea7cc | 4898 | # (negative), still giving zero; the result is not > 0, and |
69893cff RGS |
4899 | # we use $limit (1) as the stopping point. |
4900 | # | |
4901 | # if $to is >1, ($limit - $to) will be negative, times $delta of -1 | |
4902 | # (negative), giving a positive (>0) value, so we'll set $limit to | |
4903 | # $to. | |
e22ea7cc RF |
4904 | |
4905 | $limit = $to if ( $limit - $to ) * $delta > 0; | |
69893cff RGS |
4906 | |
4907 | # The real search loop. | |
4908 | # $i starts at $from (the point we want to start searching from). | |
4909 | # We move through @dbline in the appropriate direction (determined | |
e22ea7cc RF |
4910 | # by $delta: either -1 (back) or +1 (ahead). |
4911 | # We stay in as long as we haven't hit an executable line | |
69893cff RGS |
4912 | # ($dbline[$i] == 0 means not executable) and we haven't reached |
4913 | # the limit yet (test similar to the above). | |
e22ea7cc RF |
4914 | $i += $delta while $dbline[$i] == 0 and ( $limit - $i ) * $delta > 0; |
4915 | ||
69893cff RGS |
4916 | } ## end if (@_ >= 2) |
4917 | ||
4918 | # If $i points to a line that is executable, return that. | |
e22ea7cc | 4919 | return $i unless $dbline[$i] == 0; |
69893cff RGS |
4920 | |
4921 | # Format the message and print it: no breakable lines in range. | |
e22ea7cc RF |
4922 | my ( $pl, $upto ) = ( '', '' ); |
4923 | ( $pl, $upto ) = ( 's', "..$to" ) if @_ >= 2 and $from != $to; | |
69893cff RGS |
4924 | |
4925 | # If there's a filename in filename_error, we'll see it. | |
4926 | # If not, not. | |
e22ea7cc | 4927 | die "Line$pl $from$upto$filename_error not breakable\n"; |
69893cff RGS |
4928 | } ## end sub breakable_line |
4929 | ||
be9a9b1d | 4930 | =head3 breakable_line_in_filename(file, from, to) (API) |
69893cff RGS |
4931 | |
4932 | Like C<breakable_line>, but look in another file. | |
4933 | ||
4934 | =cut | |
f1583d8f | 4935 | |
d12a4851 | 4936 | sub breakable_line_in_filename { |
e22ea7cc | 4937 | |
69893cff | 4938 | # Capture the file name. |
e22ea7cc | 4939 | my ($f) = shift; |
69893cff RGS |
4940 | |
4941 | # Swap the magic line array over there temporarily. | |
e22ea7cc | 4942 | local *dbline = $main::{ '_<' . $f }; |
69893cff RGS |
4943 | |
4944 | # If there's an error, it's in this other file. | |
1f874cb6 | 4945 | local $filename_error = " of '$f'"; |
69893cff RGS |
4946 | |
4947 | # Find the breakable line. | |
e22ea7cc | 4948 | breakable_line(@_); |
69893cff RGS |
4949 | |
4950 | # *dbline and $filename_error get restored when this block ends. | |
4951 | ||
4952 | } ## end sub breakable_line_in_filename | |
4953 | ||
4954 | =head3 break_on_line(lineno, [condition]) (API) | |
4955 | ||
b570d64b | 4956 | Adds a breakpoint with the specified condition (or 1 if no condition was |
69893cff RGS |
4957 | specified) to the specified line. Dies if it can't. |
4958 | ||
4959 | =cut | |
f1583d8f | 4960 | |
d12a4851 | 4961 | sub break_on_line { |
bc996ef8 SF |
4962 | my $i = shift; |
4963 | my $cond = @_ ? shift(@_) : 1; | |
69893cff | 4964 | |
e22ea7cc RF |
4965 | my $inii = $i; |
4966 | my $after = ''; | |
4967 | my $pl = ''; | |
69893cff RGS |
4968 | |
4969 | # Woops, not a breakable line. $filename_error allows us to say | |
4970 | # if it was in a different file. | |
e22ea7cc | 4971 | die "Line $i$filename_error not breakable.\n" if $dbline[$i] == 0; |
69893cff RGS |
4972 | |
4973 | # Mark this file as having breakpoints in it. | |
e22ea7cc RF |
4974 | $had_breakpoints{$filename} |= 1; |
4975 | ||
4976 | # If there is an action or condition here already ... | |
4977 | if ( $dbline{$i} ) { | |
69893cff | 4978 | |
69893cff | 4979 | # ... swap this condition for the existing one. |
e22ea7cc | 4980 | $dbline{$i} =~ s/^[^\0]*/$cond/; |
69893cff | 4981 | } |
e22ea7cc RF |
4982 | else { |
4983 | ||
69893cff | 4984 | # Nothing here - just add the condition. |
e22ea7cc | 4985 | $dbline{$i} = $cond; |
e09195af SF |
4986 | |
4987 | _set_breakpoint_enabled_status($filename, $i, 1); | |
69893cff | 4988 | } |
c895663c SF |
4989 | |
4990 | return; | |
69893cff RGS |
4991 | } ## end sub break_on_line |
4992 | ||
4993 | =head3 cmd_b_line(line, [condition]) (command) | |
4994 | ||
b570d64b | 4995 | Wrapper for C<break_on_line>. Prints the failure message if it |
69893cff RGS |
4996 | doesn't work. |
4997 | ||
b570d64b | 4998 | =cut |
f1583d8f | 4999 | |
d12a4851 | 5000 | sub cmd_b_line { |
4915c7ee | 5001 | if (not eval { break_on_line(@_); 1 }) { |
e22ea7cc RF |
5002 | local $\ = ''; |
5003 | print $OUT $@ and return; | |
4915c7ee SF |
5004 | } |
5005 | ||
5006 | return; | |
69893cff RGS |
5007 | } ## end sub cmd_b_line |
5008 | ||
076b743f SF |
5009 | =head3 cmd_b_filename_line(line, [condition]) (command) |
5010 | ||
b570d64b | 5011 | Wrapper for C<break_on_filename_line>. Prints the failure message if it |
076b743f SF |
5012 | doesn't work. |
5013 | ||
b570d64b | 5014 | =cut |
076b743f SF |
5015 | |
5016 | sub cmd_b_filename_line { | |
4915c7ee | 5017 | if (not eval { break_on_filename_line(@_); 1 }) { |
076b743f SF |
5018 | local $\ = ''; |
5019 | print $OUT $@ and return; | |
4915c7ee SF |
5020 | } |
5021 | ||
5022 | return; | |
076b743f SF |
5023 | } |
5024 | ||
69893cff RGS |
5025 | =head3 break_on_filename_line(file, line, [condition]) (API) |
5026 | ||
b570d64b | 5027 | Switches to the file specified and then calls C<break_on_line> to set |
69893cff RGS |
5028 | the breakpoint. |
5029 | ||
5030 | =cut | |
f1583d8f | 5031 | |
d12a4851 | 5032 | sub break_on_filename_line { |
df062bd8 SF |
5033 | my $f = shift; |
5034 | my $i = shift; | |
5035 | my $cond = @_ ? shift(@_) : 1; | |
69893cff RGS |
5036 | |
5037 | # Switch the magical hash temporarily. | |
e22ea7cc | 5038 | local *dbline = $main::{ '_<' . $f }; |
69893cff RGS |
5039 | |
5040 | # Localize the variables that break_on_line uses to make its message. | |
1f874cb6 | 5041 | local $filename_error = " of '$f'"; |
e22ea7cc | 5042 | local $filename = $f; |
69893cff RGS |
5043 | |
5044 | # Add the breakpoint. | |
e22ea7cc | 5045 | break_on_line( $i, $cond ); |
c895663c SF |
5046 | |
5047 | return; | |
69893cff RGS |
5048 | } ## end sub break_on_filename_line |
5049 | ||
5050 | =head3 break_on_filename_line_range(file, from, to, [condition]) (API) | |
5051 | ||
b570d64b | 5052 | Switch to another file, search the range of lines specified for an |
69893cff RGS |
5053 | executable one, and put a breakpoint on the first one you find. |
5054 | ||
5055 | =cut | |
f1583d8f | 5056 | |
d12a4851 | 5057 | sub break_on_filename_line_range { |
df062bd8 SF |
5058 | my $f = shift; |
5059 | my $from = shift; | |
5060 | my $to = shift; | |
5061 | my $cond = @_ ? shift(@_) : 1; | |
69893cff RGS |
5062 | |
5063 | # Find a breakable line if there is one. | |
e22ea7cc | 5064 | my $i = breakable_line_in_filename( $f, $from, $to ); |
69893cff | 5065 | |
69893cff | 5066 | # Add the breakpoint. |
e22ea7cc | 5067 | break_on_filename_line( $f, $i, $cond ); |
c895663c SF |
5068 | |
5069 | return; | |
69893cff RGS |
5070 | } ## end sub break_on_filename_line_range |
5071 | ||
5072 | =head3 subroutine_filename_lines(subname, [condition]) (API) | |
5073 | ||
5074 | Search for a subroutine within a given file. The condition is ignored. | |
5075 | Uses C<find_sub> to locate the desired subroutine. | |
5076 | ||
5077 | =cut | |
f1583d8f | 5078 | |
d12a4851 | 5079 | sub subroutine_filename_lines { |
df062bd8 | 5080 | my ( $subname ) = @_; |
69893cff RGS |
5081 | |
5082 | # Returned value from find_sub() is fullpathname:startline-endline. | |
df062bd8 SF |
5083 | # The match creates the list (fullpathname, start, end). |
5084 | return (find_sub($subname) =~ /^(.*):(\d+)-(\d+)$/); | |
69893cff RGS |
5085 | } ## end sub subroutine_filename_lines |
5086 | ||
5087 | =head3 break_subroutine(subname) (API) | |
5088 | ||
5089 | Places a break on the first line possible in the specified subroutine. Uses | |
b570d64b | 5090 | C<subroutine_filename_lines> to find the subroutine, and |
69893cff RGS |
5091 | C<break_on_filename_line_range> to place the break. |
5092 | ||
5093 | =cut | |
f1583d8f | 5094 | |
d12a4851 | 5095 | sub break_subroutine { |
e22ea7cc | 5096 | my $subname = shift; |
69893cff RGS |
5097 | |
5098 | # Get filename, start, and end. | |
e22ea7cc RF |
5099 | my ( $file, $s, $e ) = subroutine_filename_lines($subname) |
5100 | or die "Subroutine $subname not found.\n"; | |
69893cff | 5101 | |
6b24a4b7 | 5102 | |
69893cff | 5103 | # Null condition changes to '1' (always true). |
6b24a4b7 | 5104 | my $cond = @_ ? shift(@_) : 1; |
69893cff RGS |
5105 | |
5106 | # Put a break the first place possible in the range of lines | |
5107 | # that make up this subroutine. | |
6b24a4b7 | 5108 | break_on_filename_line_range( $file, $s, $e, $cond ); |
c895663c SF |
5109 | |
5110 | return; | |
69893cff RGS |
5111 | } ## end sub break_subroutine |
5112 | ||
5113 | =head3 cmd_b_sub(subname, [condition]) (command) | |
5114 | ||
5115 | We take the incoming subroutine name and fully-qualify it as best we can. | |
5116 | ||
5117 | =over 4 | |
5118 | ||
b570d64b | 5119 | =item 1. If it's already fully-qualified, leave it alone. |
69893cff RGS |
5120 | |
5121 | =item 2. Try putting it in the current package. | |
5122 | ||
5123 | =item 3. If it's not there, try putting it in CORE::GLOBAL if it exists there. | |
5124 | ||
5125 | =item 4. If it starts with '::', put it in 'main::'. | |
5126 | ||
5127 | =back | |
5128 | ||
b570d64b | 5129 | After all this cleanup, we call C<break_subroutine> to try to set the |
69893cff RGS |
5130 | breakpoint. |
5131 | ||
5132 | =cut | |
f1583d8f | 5133 | |
d12a4851 | 5134 | sub cmd_b_sub { |
83a917af SF |
5135 | my $subname = shift; |
5136 | my $cond = @_ ? shift : 1; | |
69893cff | 5137 | |
e22ea7cc | 5138 | # If the subname isn't a code reference, qualify it so that |
69893cff | 5139 | # break_subroutine() will work right. |
ae2f328f | 5140 | if ( ref($subname) ne 'CODE' ) { |
e22ea7cc | 5141 | |
83a917af SF |
5142 | # Not Perl 4. |
5143 | $subname =~ s/'/::/g; | |
e22ea7cc | 5144 | my $s = $subname; |
69893cff RGS |
5145 | |
5146 | # Put it in this package unless it's already qualified. | |
83a917af SF |
5147 | if ($subname !~ /::/) |
5148 | { | |
5149 | $subname = $package . '::' . $subname; | |
5150 | }; | |
69893cff RGS |
5151 | |
5152 | # Requalify it into CORE::GLOBAL if qualifying it into this | |
5153 | # package resulted in its not being defined, but only do so | |
5154 | # if it really is in CORE::GLOBAL. | |
83a917af SF |
5155 | my $core_name = "CORE::GLOBAL::$s"; |
5156 | if ((!defined(&$subname)) | |
5157 | and ($s !~ /::/) | |
5158 | and (defined &{$core_name})) | |
5159 | { | |
5160 | $subname = $core_name; | |
5161 | } | |
69893cff RGS |
5162 | |
5163 | # Put it in package 'main' if it has a leading ::. | |
83a917af SF |
5164 | if ($subname =~ /\A::/) |
5165 | { | |
5166 | $subname = "main" . $subname; | |
5167 | } | |
ae2f328f | 5168 | } ## end if ( ref($subname) ne 'CODE' ) { |
69893cff RGS |
5169 | |
5170 | # Try to set the breakpoint. | |
4915c7ee | 5171 | if (not eval { break_subroutine( $subname, $cond ); 1 }) { |
e22ea7cc | 5172 | local $\ = ''; |
83a917af SF |
5173 | print {$OUT} $@; |
5174 | return; | |
4915c7ee SF |
5175 | } |
5176 | ||
5177 | return; | |
69893cff RGS |
5178 | } ## end sub cmd_b_sub |
5179 | ||
5180 | =head3 C<cmd_B> - delete breakpoint(s) (command) | |
5181 | ||
5182 | The command mostly parses the command line and tries to turn the argument | |
5183 | into a line spec. If it can't, it uses the current line. It then calls | |
5184 | C<delete_breakpoint> to actually do the work. | |
5185 | ||
5186 | If C<*> is specified, C<cmd_B> calls C<delete_breakpoint> with no arguments, | |
5187 | thereby deleting all the breakpoints. | |
5188 | ||
5189 | =cut | |
5190 | ||
5191 | sub cmd_B { | |
e22ea7cc | 5192 | my $cmd = shift; |
69893cff | 5193 | |
e22ea7cc | 5194 | # No line spec? Use dbline. |
69893cff | 5195 | # If there is one, use it if it's non-zero, or wipe it out if it is. |
5830ee13 | 5196 | my $line = ( $_[0] =~ /\A\./ ) ? $dbline : (shift || ''); |
e22ea7cc | 5197 | my $dbline = shift; |
69893cff RGS |
5198 | |
5199 | # If the line was dot, make the line the current one. | |
5200 | $line =~ s/^\./$dbline/; | |
5201 | ||
5202 | # If it's * we're deleting all the breakpoints. | |
e22ea7cc | 5203 | if ( $line eq '*' ) { |
7238dade | 5204 | if (not eval { delete_breakpoint(); 1 }) { |
5830ee13 SF |
5205 | print {$OUT} $@; |
5206 | } | |
e22ea7cc | 5207 | } |
69893cff RGS |
5208 | |
5209 | # If there is a line spec, delete the breakpoint on that line. | |
5830ee13 | 5210 | elsif ( $line =~ /\A(\S.*)/ ) { |
7238dade | 5211 | if (not eval { delete_breakpoint( $line || $dbline ); 1 }) { |
e22ea7cc | 5212 | local $\ = ''; |
5830ee13 | 5213 | print {$OUT} $@; |
4915c7ee | 5214 | } |
69893cff RGS |
5215 | } ## end elsif ($line =~ /^(\S.*)/) |
5216 | ||
e22ea7cc | 5217 | # No line spec. |
69893cff | 5218 | else { |
5830ee13 | 5219 | print {$OUT} |
e22ea7cc RF |
5220 | "Deleting a breakpoint requires a line number, or '*' for all\n" |
5221 | ; # hint | |
69893cff | 5222 | } |
5830ee13 SF |
5223 | |
5224 | return; | |
69893cff RGS |
5225 | } ## end sub cmd_B |
5226 | ||
5227 | =head3 delete_breakpoint([line]) (API) | |
f1583d8f | 5228 | |
69893cff RGS |
5229 | This actually does the work of deleting either a single breakpoint, or all |
5230 | of them. | |
5231 | ||
5232 | For a single line, we look for it in C<@dbline>. If it's nonbreakable, we | |
5233 | just drop out with a message saying so. If it is, we remove the condition | |
5234 | part of the 'condition\0action' that says there's a breakpoint here. If, | |
5235 | after we've done that, there's nothing left, we delete the corresponding | |
5236 | line in C<%dbline> to signal that no action needs to be taken for this line. | |
5237 | ||
b570d64b | 5238 | For all breakpoints, we iterate through the keys of C<%had_breakpoints>, |
69893cff RGS |
5239 | which lists all currently-loaded files which have breakpoints. We then look |
5240 | at each line in each of these files, temporarily switching the C<%dbline> | |
5241 | and C<@dbline> structures to point to the files in question, and do what | |
5242 | we did in the single line case: delete the condition in C<@dbline>, and | |
5243 | delete the key in C<%dbline> if nothing's left. | |
5244 | ||
b570d64b | 5245 | We then wholesale delete C<%postponed>, C<%postponed_file>, and |
69893cff RGS |
5246 | C<%break_on_load>, because these structures contain breakpoints for files |
5247 | and code that haven't been loaded yet. We can just kill these off because there | |
5248 | are no magical debugger structures associated with them. | |
5249 | ||
5250 | =cut | |
f1583d8f | 5251 | |
a4fc4d61 SF |
5252 | sub _remove_breakpoint_entry { |
5253 | my ($fn, $i) = @_; | |
5254 | ||
5255 | delete $dbline{$i}; | |
5256 | _delete_breakpoint_data_ref($fn, $i); | |
5257 | ||
5258 | return; | |
5259 | } | |
5260 | ||
b8a8ca63 SF |
5261 | sub _delete_all_breakpoints { |
5262 | print {$OUT} "Deleting all breakpoints...\n"; | |
5263 | ||
5264 | # %had_breakpoints lists every file that had at least one | |
5265 | # breakpoint in it. | |
5266 | for my $fn ( keys %had_breakpoints ) { | |
5267 | ||
5268 | # Switch to the desired file temporarily. | |
5269 | local *dbline = $main::{ '_<' . $fn }; | |
5270 | ||
5271 | $max = $#dbline; | |
b8a8ca63 SF |
5272 | |
5273 | # For all lines in this file ... | |
5274 | for my $i (1 .. $max) { | |
5275 | ||
5276 | # If there's a breakpoint or action on this line ... | |
5277 | if ( defined $dbline{$i} ) { | |
5278 | ||
5279 | # ... remove the breakpoint. | |
5280 | $dbline{$i} =~ s/\A[^\0]+//; | |
5281 | if ( $dbline{$i} =~ s/\A\0?\z// ) { | |
b8a8ca63 | 5282 | # Remove the entry altogether if no action is there. |
a4fc4d61 | 5283 | _remove_breakpoint_entry($fn, $i); |
b8a8ca63 SF |
5284 | } |
5285 | } ## end if (defined $dbline{$i... | |
5286 | } ## end for $i (1 .. $max) | |
5287 | ||
5288 | # If, after we turn off the "there were breakpoints in this file" | |
5289 | # bit, the entry in %had_breakpoints for this file is zero, | |
5290 | # we should remove this file from the hash. | |
5291 | if ( not $had_breakpoints{$fn} &= (~1) ) { | |
5292 | delete $had_breakpoints{$fn}; | |
5293 | } | |
5294 | } ## end for my $fn (keys %had_breakpoints) | |
5295 | ||
5296 | # Kill off all the other breakpoints that are waiting for files that | |
5297 | # haven't been loaded yet. | |
5298 | undef %postponed; | |
5299 | undef %postponed_file; | |
5300 | undef %break_on_load; | |
5301 | ||
5302 | return; | |
5303 | } | |
5304 | ||
0400fe7e SF |
5305 | sub _delete_breakpoint_from_line { |
5306 | my ($i) = @_; | |
69893cff | 5307 | |
0400fe7e SF |
5308 | # Woops. This line wasn't breakable at all. |
5309 | die "Line $i not breakable.\n" if $dbline[$i] == 0; | |
e09195af | 5310 | |
0400fe7e SF |
5311 | # Kill the condition, but leave any action. |
5312 | $dbline{$i} =~ s/\A[^\0]*//; | |
69893cff | 5313 | |
0400fe7e SF |
5314 | # Remove the entry entirely if there's no action left. |
5315 | if ($dbline{$i} eq '') { | |
5316 | _remove_breakpoint_entry($filename, $i); | |
5317 | } | |
69893cff | 5318 | |
0400fe7e SF |
5319 | return; |
5320 | } | |
69893cff | 5321 | |
0400fe7e SF |
5322 | sub delete_breakpoint { |
5323 | my $i = shift; | |
69893cff | 5324 | |
0400fe7e SF |
5325 | # If we got a line, delete just that one. |
5326 | if ( defined($i) ) { | |
5327 | _delete_breakpoint_from_line($i); | |
5328 | } | |
69893cff | 5329 | # No line; delete them all. |
e22ea7cc | 5330 | else { |
b8a8ca63 | 5331 | _delete_all_breakpoints(); |
0400fe7e | 5332 | } |
b8a8ca63 SF |
5333 | |
5334 | return; | |
0400fe7e | 5335 | } |
69893cff RGS |
5336 | |
5337 | =head3 cmd_stop (command) | |
5338 | ||
5339 | This is meant to be part of the new command API, but it isn't called or used | |
5340 | anywhere else in the debugger. XXX It is probably meant for use in development | |
5341 | of new commands. | |
5342 | ||
5343 | =cut | |
5344 | ||
5345 | sub cmd_stop { # As on ^C, but not signal-safy. | |
5346 | $signal = 1; | |
d12a4851 | 5347 | } |
f1583d8f | 5348 | |
2cbb2ee1 RGS |
5349 | =head3 C<cmd_e> - threads |
5350 | ||
5351 | Display the current thread id: | |
5352 | ||
2dbd01ad | 5353 | e |
2cbb2ee1 RGS |
5354 | |
5355 | This could be how (when implemented) to send commands to this thread id (e cmd) | |
5356 | or that thread id (e tid cmd). | |
5357 | ||
5358 | =cut | |
5359 | ||
5360 | sub cmd_e { | |
5361 | my $cmd = shift; | |
5362 | my $line = shift; | |
2dbd01ad SF |
5363 | unless (exists($INC{'threads.pm'})) { |
5364 | print "threads not loaded($ENV{PERL5DB_THREADED}) | |
5365 | please run the debugger with PERL5DB_THREADED=1 set in the environment\n"; | |
5366 | } else { | |
5367 | my $tid = threads->tid; | |
5368 | print "thread id: $tid\n"; | |
5369 | } | |
2cbb2ee1 RGS |
5370 | } ## end sub cmd_e |
5371 | ||
5372 | =head3 C<cmd_E> - list of thread ids | |
5373 | ||
5374 | Display the list of available thread ids: | |
5375 | ||
2dbd01ad | 5376 | E |
2cbb2ee1 RGS |
5377 | |
5378 | This could be used (when implemented) to send commands to all threads (E cmd). | |
5379 | ||
5380 | =cut | |
5381 | ||
5382 | sub cmd_E { | |
5383 | my $cmd = shift; | |
5384 | my $line = shift; | |
2dbd01ad SF |
5385 | unless (exists($INC{'threads.pm'})) { |
5386 | print "threads not loaded($ENV{PERL5DB_THREADED}) | |
5387 | please run the debugger with PERL5DB_THREADED=1 set in the environment\n"; | |
5388 | } else { | |
5389 | my $tid = threads->tid; | |
5390 | print "thread ids: ".join(', ', | |
5391 | map { ($tid == $_->tid ? '<'.$_->tid.'>' : $_->tid) } threads->list | |
5392 | )."\n"; | |
5393 | } | |
2cbb2ee1 RGS |
5394 | } ## end sub cmd_E |
5395 | ||
69893cff RGS |
5396 | =head3 C<cmd_h> - help command (command) |
5397 | ||
5398 | Does the work of either | |
5399 | ||
5400 | =over 4 | |
5401 | ||
be9a9b1d | 5402 | =item * |
69893cff | 5403 | |
be9a9b1d AT |
5404 | Showing all the debugger help |
5405 | ||
5406 | =item * | |
5407 | ||
5408 | Showing help for a specific command | |
69893cff RGS |
5409 | |
5410 | =back | |
5411 | ||
5412 | =cut | |
5413 | ||
6b24a4b7 SF |
5414 | use vars qw($help); |
5415 | use vars qw($summary); | |
5416 | ||
d12a4851 | 5417 | sub cmd_h { |
e22ea7cc | 5418 | my $cmd = shift; |
69893cff RGS |
5419 | |
5420 | # If we have no operand, assume null. | |
e22ea7cc | 5421 | my $line = shift || ''; |
69893cff RGS |
5422 | |
5423 | # 'h h'. Print the long-format help. | |
f86a3406 | 5424 | if ( $line =~ /\Ah\s*\z/ ) { |
69893cff | 5425 | print_help($help); |
e22ea7cc | 5426 | } |
69893cff RGS |
5427 | |
5428 | # 'h <something>'. Search for the command and print only its help. | |
f86a3406 | 5429 | elsif ( my ($asked) = $line =~ /\A(\S.*)\z/ ) { |
69893cff RGS |
5430 | |
5431 | # support long commands; otherwise bogus errors | |
5432 | # happen when you ask for h on <CR> for example | |
e22ea7cc RF |
5433 | my $qasked = quotemeta($asked); # for searching; we don't |
5434 | # want to use it as a pattern. | |
5435 | # XXX: finds CR but not <CR> | |
69893cff RGS |
5436 | |
5437 | # Search the help string for the command. | |
e22ea7cc RF |
5438 | if ( |
5439 | $help =~ /^ # Start of a line | |
69893cff RGS |
5440 | <? # Optional '<' |
5441 | (?:[IB]<) # Optional markup | |
5442 | $qasked # The requested command | |
e22ea7cc RF |
5443 | /mx |
5444 | ) | |
5445 | { | |
5446 | ||
69893cff | 5447 | # It's there; pull it out and print it. |
e22ea7cc RF |
5448 | while ( |
5449 | $help =~ /^ | |
69893cff RGS |
5450 | (<? # Optional '<' |
5451 | (?:[IB]<) # Optional markup | |
5452 | $qasked # The command | |
5453 | ([\s\S]*?) # Description line(s) | |
5454 | \n) # End of last description line | |
b570d64b | 5455 | (?!\s) # Next line not starting with |
69893cff | 5456 | # whitespace |
e22ea7cc RF |
5457 | /mgx |
5458 | ) | |
5459 | { | |
69893cff | 5460 | print_help($1); |
69893cff | 5461 | } |
e22ea7cc | 5462 | } |
69893cff RGS |
5463 | |
5464 | # Not found; not a debugger command. | |
e22ea7cc RF |
5465 | else { |
5466 | print_help("B<$asked> is not a debugger command.\n"); | |
5467 | } | |
69893cff RGS |
5468 | } ## end elsif ($line =~ /^(\S.*)$/) |
5469 | ||
5470 | # 'h' - print the summary help. | |
5471 | else { | |
e22ea7cc | 5472 | print_help($summary); |
69893cff RGS |
5473 | } |
5474 | } ## end sub cmd_h | |
492652be | 5475 | |
e219e2fb RF |
5476 | =head3 C<cmd_i> - inheritance display |
5477 | ||
5478 | Display the (nested) parentage of the module or object given. | |
5479 | ||
5480 | =cut | |
5481 | ||
5482 | sub cmd_i { | |
5483 | my $cmd = shift; | |
5484 | my $line = shift; | |
8b2b9f85 S |
5485 | foreach my $isa ( split( /\s+/, $line ) ) { |
5486 | $evalarg = $isa; | |
e0cd3692 SF |
5487 | # The &-call is here to ascertain the mutability of @_. |
5488 | ($isa) = &DB::eval; | |
8b2b9f85 S |
5489 | no strict 'refs'; |
5490 | print join( | |
5491 | ', ', | |
5492 | map { | |
5493 | "$_" | |
5494 | . ( | |
5495 | defined( ${"$_\::VERSION"} ) | |
5496 | ? ' ' . ${"$_\::VERSION"} | |
5497 | : undef ) | |
5498 | } @{mro::get_linear_isa(ref($isa) || $isa)} | |
5499 | ); | |
5500 | print "\n"; | |
69893cff | 5501 | } |
e219e2fb RF |
5502 | } ## end sub cmd_i |
5503 | ||
69893cff RGS |
5504 | =head3 C<cmd_l> - list lines (command) |
5505 | ||
5506 | Most of the command is taken up with transforming all the different line | |
5507 | specification syntaxes into 'start-stop'. After that is done, the command | |
b570d64b | 5508 | runs a loop over C<@dbline> for the specified range of lines. It handles |
69893cff RGS |
5509 | the printing of each line and any markers (C<==E<gt>> for current line, |
5510 | C<b> for break on this line, C<a> for action on this line, C<:> for this | |
b570d64b | 5511 | line breakable). |
69893cff RGS |
5512 | |
5513 | We save the last line listed in the C<$start> global for further listing | |
5514 | later. | |
5515 | ||
5516 | =cut | |
5517 | ||
72c017e3 SF |
5518 | sub _min { |
5519 | my $min = shift; | |
5520 | foreach my $v (@_) { | |
c06fa2d9 SF |
5521 | if ($min > $v) { |
5522 | $min = $v; | |
72c017e3 SF |
5523 | } |
5524 | } | |
5525 | return $min; | |
5526 | } | |
5527 | ||
c06fa2d9 SF |
5528 | sub _max { |
5529 | my $max = shift; | |
5530 | foreach my $v (@_) { | |
5531 | if ($max < $v) { | |
5532 | $max = $v; | |
5533 | } | |
5534 | } | |
5535 | return $max; | |
5536 | } | |
5537 | ||
72c017e3 SF |
5538 | sub _minify_to_max { |
5539 | my $ref = shift; | |
5540 | ||
5541 | $$ref = _min($$ref, $max); | |
5542 | ||
5543 | return; | |
5544 | } | |
5545 | ||
4886a469 SF |
5546 | sub _cmd_l_handle_var_name { |
5547 | my $var_name = shift; | |
5548 | ||
5549 | $evalarg = $var_name; | |
5550 | ||
5551 | my ($s) = DB::eval(); | |
5552 | ||
5553 | # Ooops. Bad scalar. | |
5554 | if ($@) { | |
5555 | print {$OUT} "Error: $@\n"; | |
5556 | next CMD; | |
5557 | } | |
5558 | ||
5559 | # Good scalar. If it's a reference, find what it points to. | |
5560 | $s = CvGV_name($s); | |
5561 | print {$OUT} "Interpreted as: $1 $s\n"; | |
5562 | $line = "$1 $s"; | |
5563 | ||
5564 | # Call self recursively to really do the command. | |
6694d350 | 5565 | return _cmd_l_main( $s ); |
4886a469 SF |
5566 | } |
5567 | ||
a1a6cc5d | 5568 | sub _cmd_l_handle_subname { |
69893cff | 5569 | |
a1a6cc5d | 5570 | my $s = $subname; |
69893cff | 5571 | |
a1a6cc5d SF |
5572 | # De-Perl4. |
5573 | $subname =~ s/\'/::/; | |
69893cff | 5574 | |
a1a6cc5d SF |
5575 | # Put it in this package unless it starts with ::. |
5576 | $subname = $package . "::" . $subname unless $subname =~ /::/; | |
69893cff | 5577 | |
a1a6cc5d SF |
5578 | # Put it in CORE::GLOBAL if t doesn't start with :: and |
5579 | # it doesn't live in this package and it lives in CORE::GLOBAL. | |
5580 | $subname = "CORE::GLOBAL::$s" | |
5581 | if not defined &$subname | |
5582 | and $s !~ /::/ | |
5583 | and defined &{"CORE::GLOBAL::$s"}; | |
69893cff | 5584 | |
a1a6cc5d SF |
5585 | # Put leading '::' names into 'main::'. |
5586 | $subname = "main" . $subname if substr( $subname, 0, 2 ) eq "::"; | |
69893cff | 5587 | |
a1a6cc5d SF |
5588 | # Get name:start-stop from find_sub, and break this up at |
5589 | # colons. | |
5590 | my @pieces = split( /:/, find_sub($subname) || $sub{$subname} ); | |
69893cff | 5591 | |
a1a6cc5d SF |
5592 | # Pull off start-stop. |
5593 | my $subrange = pop @pieces; | |
69893cff | 5594 | |
a1a6cc5d SF |
5595 | # If the name contained colons, the split broke it up. |
5596 | # Put it back together. | |
5597 | $file = join( ':', @pieces ); | |
69893cff | 5598 | |
a1a6cc5d SF |
5599 | # If we're not in that file, switch over to it. |
5600 | if ( $file ne $filename ) { | |
5601 | if (! $slave_editor) { | |
5602 | print {$OUT} "Switching to file '$file'.\n"; | |
5603 | } | |
69893cff | 5604 | |
a1a6cc5d SF |
5605 | # Switch debugger's magic structures. |
5606 | *dbline = $main::{ '_<' . $file }; | |
5607 | $max = $#dbline; | |
5608 | $filename = $file; | |
5609 | } ## end if ($file ne $filename) | |
5610 | ||
5611 | # Subrange is 'start-stop'. If this is less than a window full, | |
5612 | # swap it to 'start+', which will list a window from the start point. | |
5613 | if ($subrange) { | |
5614 | if ( eval($subrange) < -$window ) { | |
5615 | $subrange =~ s/-.*/+/; | |
5616 | } | |
69893cff | 5617 | |
a1a6cc5d | 5618 | # Call self recursively to list the range. |
6694d350 | 5619 | return _cmd_l_main( $subrange ); |
a1a6cc5d | 5620 | } ## end if ($subrange) |
69893cff | 5621 | |
a1a6cc5d SF |
5622 | # Couldn't find it. |
5623 | else { | |
5624 | print {$OUT} "Subroutine $subname not found.\n"; | |
5625 | return; | |
5626 | } | |
5627 | } | |
69893cff | 5628 | |
a1a6cc5d SF |
5629 | sub _cmd_l_empty { |
5630 | # Compute new range to list. | |
5631 | $incr = $window - 1; | |
e22ea7cc | 5632 | |
a1a6cc5d | 5633 | # Recurse to do it. |
6694d350 | 5634 | return _cmd_l_main( $start . '-' . ( $start + $incr ) ); |
a1a6cc5d | 5635 | } |
69893cff | 5636 | |
a1a6cc5d SF |
5637 | sub _cmd_l_plus { |
5638 | my ($new_start, $new_incr) = @_; | |
5639 | ||
5640 | # Don't reset start for 'l +nnn'. | |
5641 | $start = $new_start if $new_start; | |
5642 | ||
5643 | # Increment for list. Use window size if not specified. | |
5644 | # (Allows 'l +' to work.) | |
5645 | $incr = $new_incr || ($window - 1); | |
5646 | ||
5647 | # Create a line range we'll understand, and recurse to do it. | |
a9324e31 | 5648 | return _cmd_l_main( $start . '-' . ( $start + $incr ) ); |
a1a6cc5d SF |
5649 | } |
5650 | ||
65c1346e | 5651 | sub _cmd_l_calc_initial_end_and_i { |
a9324e31 | 5652 | my ($spec, $start_match, $end_match) = @_; |
65c1346e SF |
5653 | |
5654 | # Determine end point; use end of file if not specified. | |
5655 | my $end = ( !defined $start_match ) ? $max : | |
5656 | ( $end_match ? $end_match : $start_match ); | |
5657 | ||
5658 | # Go on to the end, and then stop. | |
5659 | _minify_to_max(\$end); | |
c06fa2d9 SF |
5660 | |
5661 | # Determine start line. | |
5662 | my $i = $start_match; | |
5663 | ||
5664 | if ($i eq '.') { | |
a9324e31 | 5665 | $i = $spec; |
c06fa2d9 SF |
5666 | } |
5667 | ||
5668 | $i = _max($i, 1); | |
5669 | ||
5670 | $incr = $end - $i; | |
5671 | ||
65c1346e | 5672 | return ($end, $i); |
c06fa2d9 SF |
5673 | } |
5674 | ||
613bf352 | 5675 | sub _cmd_l_range { |
a9324e31 | 5676 | my ($spec, $current_line, $start_match, $end_match) = @_; |
613bf352 | 5677 | |
65c1346e | 5678 | my ($end, $i) = |
a9324e31 | 5679 | _cmd_l_calc_initial_end_and_i($spec, $start_match, $end_match); |
613bf352 SF |
5680 | |
5681 | # If we're running under a slave editor, force it to show the lines. | |
5682 | if ($slave_editor) { | |
c06fa2d9 | 5683 | print {$OUT} "\032\032$filename:$i:0\n"; |
613bf352 SF |
5684 | $i = $end; |
5685 | } | |
613bf352 SF |
5686 | # We're doing it ourselves. We want to show the line and special |
5687 | # markers for: | |
5688 | # - the current line in execution | |
5689 | # - whether a line is breakable or not | |
5690 | # - whether a line has a break or not | |
5691 | # - whether a line has an action or not | |
5692 | else { | |
5693 | I_TO_END: | |
5694 | for ( ; $i <= $end ; $i++ ) { | |
5695 | ||
5696 | # Check for breakpoints and actions. | |
5697 | my ( $stop, $action ); | |
5698 | if ($dbline{$i}) { | |
5699 | ( $stop, $action ) = split( /\0/, $dbline{$i} ); | |
5700 | } | |
5701 | ||
5702 | # ==> if this is the current line in execution, | |
5703 | # : if it's breakable. | |
5704 | my $arrow = | |
5705 | ( $i == $current_line and $filename eq $filename_ini ) | |
5706 | ? '==>' | |
5707 | : ( $dbline[$i] + 0 ? ':' : ' ' ); | |
5708 | ||
5709 | # Add break and action indicators. | |
5710 | $arrow .= 'b' if $stop; | |
5711 | $arrow .= 'a' if $action; | |
5712 | ||
5713 | # Print the line. | |
5714 | print {$OUT} "$i$arrow\t", $dbline[$i]; | |
5715 | ||
5716 | # Move on to the next line. Drop out on an interrupt. | |
5717 | if ($signal) { | |
5718 | $i++; | |
5719 | last I_TO_END; | |
5720 | } | |
5721 | } ## end for (; $i <= $end ; $i++) | |
5722 | ||
5723 | # Line the prompt up; print a newline if the last line listed | |
5724 | # didn't have a newline. | |
5725 | if ($dbline[ $i - 1 ] !~ /\n\z/) { | |
5726 | print {$OUT} "\n"; | |
5727 | } | |
5728 | } ## end else [ if ($slave_editor) | |
5729 | ||
5730 | # Save the point we last listed to in case another relative 'l' | |
5731 | # command is desired. Don't let it run off the end. | |
5732 | $start = $i; | |
5733 | _minify_to_max(\$start); | |
5734 | ||
5735 | return; | |
5736 | } | |
5737 | ||
6694d350 | 5738 | sub _cmd_l_main { |
401da522 | 5739 | my $spec = shift; |
a1a6cc5d SF |
5740 | |
5741 | # If this is '-something', delete any spaces after the dash. | |
401da522 | 5742 | $spec =~ s/\A-\s*\z/-/; |
a1a6cc5d SF |
5743 | |
5744 | # If the line is '$something', assume this is a scalar containing a | |
5745 | # line number. | |
5746 | # Set up for DB::eval() - evaluate in *user* context. | |
401da522 | 5747 | if ( my ($var_name) = $spec =~ /\A(\$.*)/s ) { |
a1a6cc5d | 5748 | return _cmd_l_handle_var_name($var_name); |
be43a6d3 | 5749 | } |
a1a6cc5d | 5750 | # l name. Try to find a sub by that name. |
401da522 | 5751 | elsif ( ($subname) = $spec =~ /\A([\':A-Za-z_][\':\w]*(?:\[.*\])?)/s ) { |
67eca6b1 | 5752 | return _cmd_l_handle_subname(); |
be43a6d3 | 5753 | } |
69893cff | 5754 | # Bare 'l' command. |
401da522 | 5755 | elsif ( $spec !~ /\S/ ) { |
a1a6cc5d | 5756 | return _cmd_l_empty(); |
e22ea7cc | 5757 | } |
69893cff | 5758 | # l [start]+number_of_lines |
401da522 | 5759 | elsif ( my ($new_start, $new_incr) = $spec =~ /\A(\d*)\+(\d*)\z/ ) { |
a1a6cc5d | 5760 | return _cmd_l_plus($new_start, $new_incr); |
be43a6d3 | 5761 | } |
69893cff | 5762 | # l start-stop or l start,stop |
401da522 SF |
5763 | elsif (my ($s, $e) = $spec =~ /^(?:(-?[\d\$\.]+)(?:[-,]([\d\$\.]+))?)?/ ) { |
5764 | return _cmd_l_range($spec, $line, $s, $e); | |
be43a6d3 | 5765 | } |
69893cff | 5766 | |
be43a6d3 | 5767 | return; |
69893cff RGS |
5768 | } ## end sub cmd_l |
5769 | ||
6694d350 SF |
5770 | sub cmd_l { |
5771 | my (undef, $line) = @_; | |
5772 | ||
5773 | return _cmd_l_main($line); | |
5774 | } | |
5775 | ||
69893cff RGS |
5776 | =head3 C<cmd_L> - list breakpoints, actions, and watch expressions (command) |
5777 | ||
5778 | To list breakpoints, the command has to look determine where all of them are | |
5779 | first. It starts a C<%had_breakpoints>, which tells us what all files have | |
b570d64b SF |
5780 | breakpoints and/or actions. For each file, we switch the C<*dbline> glob (the |
5781 | magic source and breakpoint data structures) to the file, and then look | |
5782 | through C<%dbline> for lines with breakpoints and/or actions, listing them | |
5783 | out. We look through C<%postponed> not-yet-compiled subroutines that have | |
5784 | breakpoints, and through C<%postponed_file> for not-yet-C<require>'d files | |
69893cff RGS |
5785 | that have breakpoints. |
5786 | ||
5787 | Watchpoints are simpler: we just list the entries in C<@to_watch>. | |
5788 | ||
5789 | =cut | |
492652be | 5790 | |
a9324e31 | 5791 | sub _cmd_L_calc_arg { |
e22ea7cc | 5792 | # If no argument, list everything. Pre-5.8.0 version always lists |
69893cff | 5793 | # everything |
e22ea7cc | 5794 | my $arg = shift || 'abw'; |
ae2f328f SF |
5795 | if ($CommandSet ne '580') |
5796 | { | |
5797 | $arg = 'abw'; | |
5798 | } | |
69893cff | 5799 | |
a9324e31 SF |
5800 | return $arg; |
5801 | } | |
5802 | ||
5803 | sub _cmd_L_calc_wanted_flags { | |
5804 | my $arg = _cmd_L_calc_arg(shift); | |
5805 | ||
5806 | return (map { index($arg, $_) >= 0 ? 1 : 0 } qw(a b w)); | |
5807 | } | |
5808 | ||
db66d27d SF |
5809 | |
5810 | sub _cmd_L_handle_breakpoints { | |
5811 | my ($handle_db_line) = @_; | |
5812 | ||
5813 | BREAKPOINTS_SCAN: | |
5814 | # Look in all the files with breakpoints... | |
5815 | for my $file ( keys %had_breakpoints ) { | |
5816 | ||
5817 | # Temporary switch to this file. | |
5818 | local *dbline = $main::{ '_<' . $file }; | |
5819 | ||
5820 | # Set up to look through the whole file. | |
5821 | $max = $#dbline; | |
5822 | my $was; # Flag: did we print something | |
5823 | # in this file? | |
5824 | ||
5825 | # For each line in the file ... | |
5826 | for my $i (1 .. $max) { | |
5827 | ||
5828 | # We've got something on this line. | |
5829 | if ( defined $dbline{$i} ) { | |
5830 | ||
5831 | # Print the header if we haven't. | |
5832 | if (not $was++) { | |
5833 | print {$OUT} "$file:\n"; | |
5834 | } | |
5835 | ||
5836 | # Print the line. | |
5837 | print {$OUT} " $i:\t", $dbline[$i]; | |
5838 | ||
5839 | $handle_db_line->($dbline{$i}); | |
5840 | ||
5841 | # Quit if the user hit interrupt. | |
5842 | if ($signal) { | |
5843 | last BREAKPOINTS_SCAN; | |
5844 | } | |
5845 | } ## end if (defined $dbline{$i... | |
5846 | } ## end for my $i (1 .. $max) | |
5847 | } ## end for my $file (keys %had_breakpoints) | |
5848 | ||
5849 | return; | |
5850 | } | |
5851 | ||
55ade8ea SF |
5852 | sub _cmd_L_handle_postponed_breakpoints { |
5853 | my ($handle_db_line) = @_; | |
5854 | ||
5855 | print {$OUT} "Postponed breakpoints in files:\n"; | |
5856 | ||
5857 | POSTPONED_SCANS: | |
5858 | for my $file ( keys %postponed_file ) { | |
5859 | my $db = $postponed_file{$file}; | |
5860 | print {$OUT} " $file:\n"; | |
5861 | for my $line ( sort { $a <=> $b } keys %$db ) { | |
5862 | print {$OUT} " $line:\n"; | |
5863 | ||
5864 | $handle_db_line->($db->{$line}); | |
5865 | ||
5866 | if ($signal) { | |
5867 | last POSTPONED_SCANS; | |
5868 | } | |
5869 | } | |
5870 | if ($signal) { | |
5871 | last POSTPONED_SCANS; | |
5872 | } | |
5873 | } | |
5874 | ||
5875 | return; | |
5876 | } | |
5877 | ||
5878 | ||
a9324e31 SF |
5879 | sub cmd_L { |
5880 | my $cmd = shift; | |
5881 | ||
5882 | my ($action_wanted, $break_wanted, $watch_wanted) = | |
5883 | _cmd_L_calc_wanted_flags(shift); | |
69893cff | 5884 | |
d0bfb56c SF |
5885 | my $handle_db_line = sub { |
5886 | my ($l) = @_; | |
5887 | ||
5888 | my ( $stop, $action ) = split( /\0/, $l ); | |
5889 | ||
5890 | if ($stop and $break_wanted) { | |
5891 | print {$OUT} " break if (", $stop, ")\n" | |
5892 | } | |
5893 | ||
5894 | if ($action && $action_wanted) { | |
5895 | print {$OUT} " action: ", $action, "\n" | |
5896 | } | |
5897 | ||
5898 | return; | |
5899 | }; | |
5900 | ||
69893cff RGS |
5901 | # Breaks and actions are found together, so we look in the same place |
5902 | # for both. | |
e22ea7cc | 5903 | if ( $break_wanted or $action_wanted ) { |
db66d27d | 5904 | _cmd_L_handle_breakpoints($handle_db_line); |
3fe486dc | 5905 | } |
69893cff RGS |
5906 | |
5907 | # Look for breaks in not-yet-compiled subs: | |
e22ea7cc | 5908 | if ( %postponed and $break_wanted ) { |
fb73dc2f | 5909 | print {$OUT} "Postponed breakpoints in subroutines:\n"; |
69893cff | 5910 | my $subname; |
fb73dc2f | 5911 | SUBS_SCAN: |
e22ea7cc | 5912 | for $subname ( keys %postponed ) { |
fb73dc2f SF |
5913 | print {$OUT} " $subname\t$postponed{$subname}\n"; |
5914 | if ($signal) { | |
5915 | last SUBS_SCAN; | |
5916 | } | |
69893cff RGS |
5917 | } |
5918 | } ## end if (%postponed and $break_wanted) | |
5919 | ||
5920 | # Find files that have not-yet-loaded breaks: | |
e22ea7cc RF |
5921 | my @have = map { # Combined keys |
5922 | keys %{ $postponed_file{$_} } | |
69893cff RGS |
5923 | } keys %postponed_file; |
5924 | ||
5925 | # If there are any, list them. | |
e22ea7cc | 5926 | if ( @have and ( $break_wanted or $action_wanted ) ) { |
55ade8ea | 5927 | _cmd_L_handle_postponed_breakpoints($handle_db_line); |
69893cff | 5928 | } ## end if (@have and ($break_wanted... |
cb45a45e | 5929 | |
e22ea7cc | 5930 | if ( %break_on_load and $break_wanted ) { |
7157728b SF |
5931 | print {$OUT} "Breakpoints on load:\n"; |
5932 | BREAK_ON_LOAD: for my $filename ( keys %break_on_load ) { | |
5933 | print {$OUT} " $filename\n"; | |
5934 | last BREAK_ON_LOAD if $signal; | |
69893cff | 5935 | } |
e22ea7cc | 5936 | } ## end if (%break_on_load and... |
cb45a45e | 5937 | |
9b5de49c SF |
5938 | if ($watch_wanted and ( $trace & 2 )) { |
5939 | print {$OUT} "Watch-expressions:\n" if @to_watch; | |
5940 | TO_WATCH: for my $expr (@to_watch) { | |
5941 | print {$OUT} " $expr\n"; | |
5942 | last TO_WATCH if $signal; | |
5943 | } | |
5944 | } | |
cb45a45e SF |
5945 | |
5946 | return; | |
69893cff RGS |
5947 | } ## end sub cmd_L |
5948 | ||
5949 | =head3 C<cmd_M> - list modules (command) | |
5950 | ||
5951 | Just call C<list_modules>. | |
5952 | ||
5953 | =cut | |
492652be | 5954 | |
d12a4851 | 5955 | sub cmd_M { |
a8146293 SF |
5956 | list_modules(); |
5957 | ||
5958 | return; | |
d12a4851 | 5959 | } |
eda6e075 | 5960 | |
69893cff RGS |
5961 | =head3 C<cmd_o> - options (command) |
5962 | ||
b570d64b | 5963 | If this is just C<o> by itself, we list the current settings via |
69893cff RGS |
5964 | C<dump_option>. If there's a nonblank value following it, we pass that on to |
5965 | C<parse_options> for processing. | |
5966 | ||
5967 | =cut | |
5968 | ||
d12a4851 | 5969 | sub cmd_o { |
e22ea7cc RF |
5970 | my $cmd = shift; |
5971 | my $opt = shift || ''; # opt[=val] | |
69893cff RGS |
5972 | |
5973 | # Nonblank. Try to parse and process. | |
e22ea7cc | 5974 | if ( $opt =~ /^(\S.*)/ ) { |
b0b8faca | 5975 | parse_options($1); |
e22ea7cc | 5976 | } |
69893cff RGS |
5977 | |
5978 | # Blank. List the current option settings. | |
5979 | else { | |
5980 | for (@options) { | |
b0b8faca | 5981 | dump_option($_); |
69893cff RGS |
5982 | } |
5983 | } | |
5984 | } ## end sub cmd_o | |
5985 | ||
5986 | =head3 C<cmd_O> - nonexistent in 5.8.x (command) | |
5987 | ||
5988 | Advises the user that the O command has been renamed. | |
5989 | ||
5990 | =cut | |
eda6e075 | 5991 | |
d12a4851 | 5992 | sub cmd_O { |
e22ea7cc RF |
5993 | print $OUT "The old O command is now the o command.\n"; # hint |
5994 | print $OUT "Use 'h' to get current command help synopsis or\n"; # | |
5995 | print $OUT "use 'o CommandSet=pre580' to revert to old usage\n"; # | |
d12a4851 | 5996 | } |
eda6e075 | 5997 | |
69893cff RGS |
5998 | =head3 C<cmd_v> - view window (command) |
5999 | ||
6000 | Uses the C<$preview> variable set in the second C<BEGIN> block (q.v.) to | |
6001 | move back a few lines to list the selected line in context. Uses C<cmd_l> | |
6002 | to do the actual listing after figuring out the range of line to request. | |
6003 | ||
b570d64b | 6004 | =cut |
69893cff | 6005 | |
6b24a4b7 SF |
6006 | use vars qw($preview); |
6007 | ||
d12a4851 | 6008 | sub cmd_v { |
e22ea7cc | 6009 | my $cmd = shift; |
69893cff RGS |
6010 | my $line = shift; |
6011 | ||
6012 | # Extract the line to list around. (Astute readers will have noted that | |
6013 | # this pattern will match whether or not a numeric line is specified, | |
6014 | # which means that we'll always enter this loop (though a non-numeric | |
6015 | # argument results in no action at all)). | |
e22ea7cc RF |
6016 | if ( $line =~ /^(\d*)$/ ) { |
6017 | ||
69893cff RGS |
6018 | # Total number of lines to list (a windowful). |
6019 | $incr = $window - 1; | |
6020 | ||
6021 | # Set the start to the argument given (if there was one). | |
6022 | $start = $1 if $1; | |
6023 | ||
6024 | # Back up by the context amount. | |
6025 | $start -= $preview; | |
6026 | ||
6027 | # Put together a linespec that cmd_l will like. | |
e22ea7cc | 6028 | $line = $start . '-' . ( $start + $incr ); |
69893cff RGS |
6029 | |
6030 | # List the lines. | |
626311fa | 6031 | cmd_l( 'l', $line ); |
69893cff RGS |
6032 | } ## end if ($line =~ /^(\d*)$/) |
6033 | } ## end sub cmd_v | |
6034 | ||
6035 | =head3 C<cmd_w> - add a watch expression (command) | |
6036 | ||
6037 | The 5.8 version of this command adds a watch expression if one is specified; | |
6038 | it does nothing if entered with no operands. | |
6039 | ||
6040 | We extract the expression, save it, evaluate it in the user's context, and | |
6041 | save the value. We'll re-evaluate it each time the debugger passes a line, | |
6042 | and will stop (see the code at the top of the command loop) if the value | |
6043 | of any of the expressions changes. | |
6044 | ||
6045 | =cut | |
eda6e075 | 6046 | |
c2dfabc3 SF |
6047 | sub _add_watch_expr { |
6048 | my $expr = shift; | |
6049 | ||
6050 | # ... save it. | |
6051 | push @to_watch, $expr; | |
6052 | ||
6053 | # Parameterize DB::eval and call it to get the expression's value | |
6054 | # in the user's context. This version can handle expressions which | |
6055 | # return a list value. | |
6056 | $evalarg = $expr; | |
e0cd3692 SF |
6057 | # The &-call is here to ascertain the mutability of @_. |
6058 | my ($val) = join( ' ', &DB::eval); | |
c2dfabc3 SF |
6059 | $val = ( defined $val ) ? "'$val'" : 'undef'; |
6060 | ||
6061 | # Save the current value of the expression. | |
6062 | push @old_watch, $val; | |
6063 | ||
6064 | # We are now watching expressions. | |
6065 | $trace |= 2; | |
6066 | ||
6067 | return; | |
6068 | } | |
6069 | ||
d12a4851 | 6070 | sub cmd_w { |
e22ea7cc | 6071 | my $cmd = shift; |
69893cff RGS |
6072 | |
6073 | # Null expression if no arguments. | |
6074 | my $expr = shift || ''; | |
6075 | ||
6076 | # If expression is not null ... | |
8a799e0b | 6077 | if ( $expr =~ /\A\S/ ) { |
c2dfabc3 | 6078 | _add_watch_expr($expr); |
69893cff RGS |
6079 | } ## end if ($expr =~ /^(\S.*)/) |
6080 | ||
6081 | # You have to give one to get one. | |
6082 | else { | |
e22ea7cc | 6083 | print $OUT "Adding a watch-expression requires an expression\n"; # hint |
69893cff | 6084 | } |
c2dfabc3 SF |
6085 | |
6086 | return; | |
6087 | } | |
69893cff RGS |
6088 | |
6089 | =head3 C<cmd_W> - delete watch expressions (command) | |
6090 | ||
6091 | This command accepts either a watch expression to be removed from the list | |
6092 | of watch expressions, or C<*> to delete them all. | |
6093 | ||
b570d64b SF |
6094 | If C<*> is specified, we simply empty the watch expression list and the |
6095 | watch expression value list. We also turn off the bit that says we've got | |
69893cff RGS |
6096 | watch expressions. |
6097 | ||
6098 | If an expression (or partial expression) is specified, we pattern-match | |
6099 | through the expressions and remove the ones that match. We also discard | |
b570d64b | 6100 | the corresponding values. If no watch expressions are left, we turn off |
be9a9b1d | 6101 | the I<watching expressions> bit. |
69893cff RGS |
6102 | |
6103 | =cut | |
eda6e075 | 6104 | |
d12a4851 | 6105 | sub cmd_W { |
69893cff RGS |
6106 | my $cmd = shift; |
6107 | my $expr = shift || ''; | |
6108 | ||
6109 | # Delete them all. | |
e22ea7cc RF |
6110 | if ( $expr eq '*' ) { |
6111 | ||
69893cff RGS |
6112 | # Not watching now. |
6113 | $trace &= ~2; | |
6114 | ||
6115 | print $OUT "Deleting all watch expressions ...\n"; | |
eda6e075 | 6116 | |
69893cff RGS |
6117 | # And all gone. |
6118 | @to_watch = @old_watch = (); | |
e22ea7cc | 6119 | } |
69893cff RGS |
6120 | |
6121 | # Delete one of them. | |
e22ea7cc RF |
6122 | elsif ( $expr =~ /^(\S.*)/ ) { |
6123 | ||
69893cff RGS |
6124 | # Where we are in the list. |
6125 | my $i_cnt = 0; | |
6126 | ||
6127 | # For each expression ... | |
6128 | foreach (@to_watch) { | |
6129 | my $val = $to_watch[$i_cnt]; | |
6130 | ||
6131 | # Does this one match the command argument? | |
e22ea7cc RF |
6132 | if ( $val eq $expr ) { # =~ m/^\Q$i$/) { |
6133 | # Yes. Turn it off, and its value too. | |
6134 | splice( @to_watch, $i_cnt, 1 ); | |
6135 | splice( @old_watch, $i_cnt, 1 ); | |
69893cff RGS |
6136 | } |
6137 | $i_cnt++; | |
6138 | } ## end foreach (@to_watch) | |
6139 | ||
6140 | # We don't bother to turn watching off because | |
7e3426ea | 6141 | # a) we don't want to stop calling watchfunction() if it exists |
69893cff RGS |
6142 | # b) foreach over a null list doesn't do anything anyway |
6143 | ||
6144 | } ## end elsif ($expr =~ /^(\S.*)/) | |
6145 | ||
e22ea7cc | 6146 | # No command arguments entered. |
69893cff | 6147 | else { |
e22ea7cc RF |
6148 | print $OUT |
6149 | "Deleting a watch-expression requires an expression, or '*' for all\n" | |
6150 | ; # hint | |
69893cff RGS |
6151 | } |
6152 | } ## end sub cmd_W | |
6153 | ||
6154 | ### END of the API section | |
6155 | ||
6156 | =head1 SUPPORT ROUTINES | |
eda6e075 | 6157 | |
69893cff RGS |
6158 | These are general support routines that are used in a number of places |
6159 | throughout the debugger. | |
6160 | ||
69893cff RGS |
6161 | =head2 save |
6162 | ||
6163 | save() saves the user's versions of globals that would mess us up in C<@saved>, | |
b570d64b | 6164 | and installs the versions we like better. |
69893cff RGS |
6165 | |
6166 | =cut | |
3a6edaec | 6167 | |
d12a4851 | 6168 | sub save { |
e22ea7cc RF |
6169 | |
6170 | # Save eval failure, command failure, extended OS error, output field | |
6171 | # separator, input record separator, output record separator and | |
69893cff | 6172 | # the warning setting. |
e22ea7cc | 6173 | @saved = ( $@, $!, $^E, $,, $/, $\, $^W ); |
69893cff | 6174 | |
e22ea7cc RF |
6175 | $, = ""; # output field separator is null string |
6176 | $/ = "\n"; # input record separator is newline | |
6177 | $\ = ""; # output record separator is null string | |
6178 | $^W = 0; # warnings are off | |
69893cff RGS |
6179 | } ## end sub save |
6180 | ||
6181 | =head2 C<print_lineinfo> - show where we are now | |
6182 | ||
6183 | print_lineinfo prints whatever it is that it is handed; it prints it to the | |
6184 | C<$LINEINFO> filehandle instead of just printing it to STDOUT. This allows | |
b570d64b | 6185 | us to feed line information to a slave editor without messing up the |
69893cff RGS |
6186 | debugger output. |
6187 | ||
6188 | =cut | |
eda6e075 | 6189 | |
d12a4851 | 6190 | sub print_lineinfo { |
e22ea7cc | 6191 | |
69893cff | 6192 | # Make the terminal sensible if we're not the primary debugger. |
e22ea7cc RF |
6193 | resetterm(1) if $LINEINFO eq $OUT and $term_pid != $$; |
6194 | local $\ = ''; | |
6195 | local $, = ''; | |
aa8c2dcb SF |
6196 | # $LINEINFO may be undef if $noTTY is set or some other issue. |
6197 | if ($LINEINFO) | |
6198 | { | |
6199 | print {$LINEINFO} @_; | |
6200 | } | |
69893cff RGS |
6201 | } ## end sub print_lineinfo |
6202 | ||
6203 | =head2 C<postponed_sub> | |
6204 | ||
6205 | Handles setting postponed breakpoints in subroutines once they're compiled. | |
6206 | For breakpoints, we use C<DB::find_sub> to locate the source file and line | |
6207 | range for the subroutine, then mark the file as having a breakpoint, | |
b570d64b | 6208 | temporarily switch the C<*dbline> glob over to the source file, and then |
69893cff RGS |
6209 | search the given range of lines to find a breakable line. If we find one, |
6210 | we set the breakpoint on it, deleting the breakpoint from C<%postponed>. | |
6211 | ||
b570d64b | 6212 | =cut |
eda6e075 | 6213 | |
d12a4851 | 6214 | # The following takes its argument via $evalarg to preserve current @_ |
eda6e075 | 6215 | |
d12a4851 | 6216 | sub postponed_sub { |
e22ea7cc | 6217 | |
69893cff | 6218 | # Get the subroutine name. |
e22ea7cc | 6219 | my $subname = shift; |
69893cff RGS |
6220 | |
6221 | # If this is a 'break +<n> if <condition>' ... | |
e22ea7cc RF |
6222 | if ( $postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s// ) { |
6223 | ||
69893cff | 6224 | # If there's no offset, use '+0'. |
e22ea7cc | 6225 | my $offset = $1 || 0; |
69893cff RGS |
6226 | |
6227 | # find_sub's value is 'fullpath-filename:start-stop'. It's | |
6228 | # possible that the filename might have colons in it too. | |
e22ea7cc RF |
6229 | my ( $file, $i ) = ( find_sub($subname) =~ /^(.*):(\d+)-.*$/ ); |
6230 | if ($i) { | |
6231 | ||
6232 | # We got the start line. Add the offset '+<n>' from | |
69893cff | 6233 | # $postponed{subname}. |
e22ea7cc | 6234 | $i += $offset; |
69893cff RGS |
6235 | |
6236 | # Switch to the file this sub is in, temporarily. | |
e22ea7cc | 6237 | local *dbline = $main::{ '_<' . $file }; |
69893cff RGS |
6238 | |
6239 | # No warnings, please. | |
e22ea7cc | 6240 | local $^W = 0; # != 0 is magical below |
69893cff RGS |
6241 | |
6242 | # This file's got a breakpoint in it. | |
e22ea7cc | 6243 | $had_breakpoints{$file} |= 1; |
69893cff RGS |
6244 | |
6245 | # Last line in file. | |
55783941 | 6246 | $max = $#dbline; |
69893cff RGS |
6247 | |
6248 | # Search forward until we hit a breakable line or get to | |
6249 | # the end of the file. | |
e22ea7cc | 6250 | ++$i until $dbline[$i] != 0 or $i >= $max; |
69893cff RGS |
6251 | |
6252 | # Copy the breakpoint in and delete it from %postponed. | |
e22ea7cc | 6253 | $dbline{$i} = delete $postponed{$subname}; |
69893cff RGS |
6254 | } ## end if ($i) |
6255 | ||
6256 | # find_sub didn't find the sub. | |
e22ea7cc RF |
6257 | else { |
6258 | local $\ = ''; | |
6259 | print $OUT "Subroutine $subname not found.\n"; | |
6260 | } | |
6261 | return; | |
6262 | } ## end if ($postponed{$subname... | |
6263 | elsif ( $postponed{$subname} eq 'compile' ) { $signal = 1 } | |
6264 | ||
1f874cb6 | 6265 | #print $OUT "In postponed_sub for '$subname'.\n"; |
e22ea7cc | 6266 | } ## end sub postponed_sub |
eda6e075 | 6267 | |
69893cff RGS |
6268 | =head2 C<postponed> |
6269 | ||
6270 | Called after each required file is compiled, but before it is executed; | |
b570d64b | 6271 | also called if the name of a just-compiled subroutine is a key of |
69893cff RGS |
6272 | C<%postponed>. Propagates saved breakpoints (from C<b compile>, C<b load>, |
6273 | etc.) into the just-compiled code. | |
6274 | ||
b570d64b | 6275 | If this is a C<require>'d file, the incoming parameter is the glob |
69893cff RGS |
6276 | C<*{"_<$filename"}>, with C<$filename> the name of the C<require>'d file. |
6277 | ||
6278 | If it's a subroutine, the incoming parameter is the subroutine name. | |
6279 | ||
6280 | =cut | |
6281 | ||
d12a4851 | 6282 | sub postponed { |
e22ea7cc | 6283 | |
69893cff RGS |
6284 | # If there's a break, process it. |
6285 | if ($ImmediateStop) { | |
69893cff | 6286 | |
e22ea7cc RF |
6287 | # Right, we've stopped. Turn it off. |
6288 | $ImmediateStop = 0; | |
6289 | ||
6290 | # Enter the command loop when DB::DB gets called. | |
6291 | $signal = 1; | |
69893cff RGS |
6292 | } |
6293 | ||
6294 | # If this is a subroutine, let postponed_sub() deal with it. | |
ae2f328f SF |
6295 | if (ref(\$_[0]) ne 'GLOB') { |
6296 | return postponed_sub(@_); | |
6297 | } | |
69893cff RGS |
6298 | |
6299 | # Not a subroutine. Deal with the file. | |
6300 | local *dbline = shift; | |
6301 | my $filename = $dbline; | |
6302 | $filename =~ s/^_<//; | |
6303 | local $\ = ''; | |
6304 | $signal = 1, print $OUT "'$filename' loaded...\n" | |
e22ea7cc RF |
6305 | if $break_on_load{$filename}; |
6306 | print_lineinfo( ' ' x $stack_depth, "Package $filename.\n" ) if $frame; | |
69893cff RGS |
6307 | |
6308 | # Do we have any breakpoints to put in this file? | |
6309 | return unless $postponed_file{$filename}; | |
6310 | ||
6311 | # Yes. Mark this file as having breakpoints. | |
6312 | $had_breakpoints{$filename} |= 1; | |
6313 | ||
98dc9551 | 6314 | # "Cannot be done: insufficient magic" - we can't just put the |
69893cff RGS |
6315 | # breakpoints saved in %postponed_file into %dbline by assigning |
6316 | # the whole hash; we have to do it one item at a time for the | |
6317 | # breakpoints to be set properly. | |
6318 | #%dbline = %{$postponed_file{$filename}}; | |
6319 | ||
6320 | # Set the breakpoints, one at a time. | |
6321 | my $key; | |
6322 | ||
e22ea7cc RF |
6323 | for $key ( keys %{ $postponed_file{$filename} } ) { |
6324 | ||
6325 | # Stash the saved breakpoint into the current file's magic line array. | |
6326 | $dbline{$key} = ${ $postponed_file{$filename} }{$key}; | |
69893cff RGS |
6327 | } |
6328 | ||
6329 | # This file's been compiled; discard the stored breakpoints. | |
6330 | delete $postponed_file{$filename}; | |
6331 | ||
6332 | } ## end sub postponed | |
6333 | ||
6334 | =head2 C<dumpit> | |
6335 | ||
b570d64b | 6336 | C<dumpit> is the debugger's wrapper around dumpvar.pl. |
69893cff RGS |
6337 | |
6338 | It gets a filehandle (to which C<dumpvar.pl>'s output will be directed) and | |
b570d64b | 6339 | a reference to a variable (the thing to be dumped) as its input. |
69893cff RGS |
6340 | |
6341 | The incoming filehandle is selected for output (C<dumpvar.pl> is printing to | |
6342 | the currently-selected filehandle, thank you very much). The current | |
b570d64b | 6343 | values of the package globals C<$single> and C<$trace> are backed up in |
69893cff RGS |
6344 | lexicals, and they are turned off (this keeps the debugger from trying |
6345 | to single-step through C<dumpvar.pl> (I think.)). C<$frame> is localized to | |
6346 | preserve its current value and it is set to zero to prevent entry/exit | |
b570d64b | 6347 | messages from printing, and C<$doret> is localized as well and set to -2 to |
69893cff RGS |
6348 | prevent return values from being shown. |
6349 | ||
b570d64b SF |
6350 | C<dumpit()> then checks to see if it needs to load C<dumpvar.pl> and |
6351 | tries to load it (note: if you have a C<dumpvar.pl> ahead of the | |
6352 | installed version in C<@INC>, yours will be used instead. Possible security | |
69893cff RGS |
6353 | problem?). |
6354 | ||
6355 | It then checks to see if the subroutine C<main::dumpValue> is now defined | |
b570d64b | 6356 | it should have been defined by C<dumpvar.pl>). If it has, C<dumpit()> |
69893cff | 6357 | localizes the globals necessary for things to be sane when C<main::dumpValue()> |
b570d64b | 6358 | is called, and picks up the variable to be dumped from the parameter list. |
69893cff | 6359 | |
b570d64b SF |
6360 | It checks the package global C<%options> to see if there's a C<dumpDepth> |
6361 | specified. If not, -1 is assumed; if so, the supplied value gets passed on to | |
6362 | C<dumpvar.pl>. This tells C<dumpvar.pl> where to leave off when dumping a | |
69893cff RGS |
6363 | structure: -1 means dump everything. |
6364 | ||
b570d64b | 6365 | C<dumpValue()> is then called if possible; if not, C<dumpit()>just prints a |
69893cff RGS |
6366 | warning. |
6367 | ||
6368 | In either case, C<$single>, C<$trace>, C<$frame>, and C<$doret> are restored | |
6369 | and we then return to the caller. | |
6370 | ||
6371 | =cut | |
eda6e075 | 6372 | |
d12a4851 | 6373 | sub dumpit { |
e22ea7cc | 6374 | |
69893cff RGS |
6375 | # Save the current output filehandle and switch to the one |
6376 | # passed in as the first parameter. | |
6b24a4b7 | 6377 | my $savout = select(shift); |
69893cff RGS |
6378 | |
6379 | # Save current settings of $single and $trace, and then turn them off. | |
d12a4851 | 6380 | my $osingle = $single; |
69893cff | 6381 | my $otrace = $trace; |
d12a4851 | 6382 | $single = $trace = 0; |
69893cff RGS |
6383 | |
6384 | # XXX Okay, what do $frame and $doret do, again? | |
d12a4851 JH |
6385 | local $frame = 0; |
6386 | local $doret = -2; | |
69893cff RGS |
6387 | |
6388 | # Load dumpvar.pl unless we've already got the sub we need from it. | |
e22ea7cc | 6389 | unless ( defined &main::dumpValue ) { |
e81465be | 6390 | do 'dumpvar.pl' or die $@; |
d12a4851 | 6391 | } |
69893cff RGS |
6392 | |
6393 | # If the load succeeded (or we already had dumpvalue()), go ahead | |
6394 | # and dump things. | |
e22ea7cc | 6395 | if ( defined &main::dumpValue ) { |
d12a4851 JH |
6396 | local $\ = ''; |
6397 | local $, = ''; | |
6398 | local $" = ' '; | |
6399 | my $v = shift; | |
6400 | my $maxdepth = shift || $option{dumpDepth}; | |
e22ea7cc | 6401 | $maxdepth = -1 unless defined $maxdepth; # -1 means infinite depth |
b0b8faca | 6402 | main::dumpValue( $v, $maxdepth ); |
69893cff RGS |
6403 | } ## end if (defined &main::dumpValue) |
6404 | ||
6405 | # Oops, couldn't load dumpvar.pl. | |
6406 | else { | |
d12a4851 | 6407 | local $\ = ''; |
e22ea7cc | 6408 | print $OUT "dumpvar.pl not available.\n"; |
d12a4851 | 6409 | } |
69893cff RGS |
6410 | |
6411 | # Reset $single and $trace to their old values. | |
d12a4851 | 6412 | $single = $osingle; |
e22ea7cc | 6413 | $trace = $otrace; |
69893cff RGS |
6414 | |
6415 | # Restore the old filehandle. | |
e22ea7cc | 6416 | select($savout); |
69893cff RGS |
6417 | } ## end sub dumpit |
6418 | ||
6419 | =head2 C<print_trace> | |
6420 | ||
b570d64b | 6421 | C<print_trace>'s job is to print a stack trace. It does this via the |
69893cff RGS |
6422 | C<dump_trace> routine, which actually does all the ferreting-out of the |
6423 | stack trace data. C<print_trace> takes care of formatting it nicely and | |
6424 | printing it to the proper filehandle. | |
6425 | ||
6426 | Parameters: | |
6427 | ||
6428 | =over 4 | |
6429 | ||
be9a9b1d AT |
6430 | =item * |
6431 | ||
6432 | The filehandle to print to. | |
69893cff | 6433 | |
be9a9b1d | 6434 | =item * |
69893cff | 6435 | |
be9a9b1d | 6436 | How many frames to skip before starting trace. |
69893cff | 6437 | |
be9a9b1d AT |
6438 | =item * |
6439 | ||
6440 | How many frames to print. | |
6441 | ||
6442 | =item * | |
6443 | ||
6444 | A flag: if true, print a I<short> trace without filenames, line numbers, or arguments | |
69893cff RGS |
6445 | |
6446 | =back | |
6447 | ||
6448 | The original comment below seems to be noting that the traceback may not be | |
6449 | correct if this routine is called in a tied method. | |
6450 | ||
6451 | =cut | |
eda6e075 | 6452 | |
d12a4851 | 6453 | # Tied method do not create a context, so may get wrong message: |
eda6e075 | 6454 | |
d12a4851 | 6455 | sub print_trace { |
e22ea7cc RF |
6456 | local $\ = ''; |
6457 | my $fh = shift; | |
6458 | ||
69893cff RGS |
6459 | # If this is going to a slave editor, but we're not the primary |
6460 | # debugger, reset it first. | |
e22ea7cc RF |
6461 | resetterm(1) |
6462 | if $fh eq $LINEINFO # slave editor | |
6463 | and $LINEINFO eq $OUT # normal output | |
6464 | and $term_pid != $$; # not the primary | |
69893cff RGS |
6465 | |
6466 | # Collect the actual trace information to be formatted. | |
6467 | # This is an array of hashes of subroutine call info. | |
e22ea7cc | 6468 | my @sub = dump_trace( $_[0] + 1, $_[1] ); |
69893cff RGS |
6469 | |
6470 | # Grab the "short report" flag from @_. | |
e22ea7cc | 6471 | my $short = $_[2]; # Print short report, next one for sub name |
69893cff RGS |
6472 | |
6473 | # Run through the traceback info, format it, and print it. | |
e22ea7cc | 6474 | my $s; |
2c247e84 | 6475 | for my $i (0 .. $#sub) { |
e22ea7cc | 6476 | |
69893cff | 6477 | # Drop out if the user has lost interest and hit control-C. |
e22ea7cc | 6478 | last if $signal; |
69893cff | 6479 | |
7e3426ea | 6480 | # Set the separator so arrays print nice. |
e22ea7cc | 6481 | local $" = ', '; |
69893cff RGS |
6482 | |
6483 | # Grab and stringify the arguments if they are there. | |
e22ea7cc RF |
6484 | my $args = |
6485 | defined $sub[$i]{args} | |
6486 | ? "(@{ $sub[$i]{args} })" | |
6487 | : ''; | |
6488 | ||
69893cff | 6489 | # Shorten them up if $maxtrace says they're too long. |
e22ea7cc RF |
6490 | $args = ( substr $args, 0, $maxtrace - 3 ) . '...' |
6491 | if length $args > $maxtrace; | |
69893cff RGS |
6492 | |
6493 | # Get the file name. | |
e22ea7cc | 6494 | my $file = $sub[$i]{file}; |
69893cff RGS |
6495 | |
6496 | # Put in a filename header if short is off. | |
1f874cb6 | 6497 | $file = $file eq '-e' ? $file : "file '$file'" unless $short; |
69893cff RGS |
6498 | |
6499 | # Get the actual sub's name, and shorten to $maxtrace's requirement. | |
7a024c05 | 6500 | $s = $sub[$i]{'sub'}; |
e22ea7cc | 6501 | $s = ( substr $s, 0, $maxtrace - 3 ) . '...' if length $s > $maxtrace; |
69893cff RGS |
6502 | |
6503 | # Short report uses trimmed file and sub names. | |
e22ea7cc RF |
6504 | if ($short) { |
6505 | my $sub = @_ >= 4 ? $_[3] : $s; | |
6506 | print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n"; | |
6507 | } ## end if ($short) | |
69893cff RGS |
6508 | |
6509 | # Non-short report includes full names. | |
e22ea7cc RF |
6510 | else { |
6511 | print $fh "$sub[$i]{context} = $s$args" | |
6512 | . " called from $file" | |
6513 | . " line $sub[$i]{line}\n"; | |
6514 | } | |
2c247e84 | 6515 | } ## end for my $i (0 .. $#sub) |
69893cff RGS |
6516 | } ## end sub print_trace |
6517 | ||
6518 | =head2 dump_trace(skip[,count]) | |
6519 | ||
6520 | Actually collect the traceback information available via C<caller()>. It does | |
6521 | some filtering and cleanup of the data, but mostly it just collects it to | |
6522 | make C<print_trace()>'s job easier. | |
6523 | ||
6524 | C<skip> defines the number of stack frames to be skipped, working backwards | |
b570d64b | 6525 | from the most current. C<count> determines the total number of frames to |
69893cff RGS |
6526 | be returned; all of them (well, the first 10^9) are returned if C<count> |
6527 | is omitted. | |
6528 | ||
6529 | This routine returns a list of hashes, from most-recent to least-recent | |
6530 | stack frame. Each has the following keys and values: | |
6531 | ||
6532 | =over 4 | |
6533 | ||
6534 | =item * C<context> - C<.> (null), C<$> (scalar), or C<@> (array) | |
6535 | ||
6536 | =item * C<sub> - subroutine name, or C<eval> information | |
6537 | ||
6538 | =item * C<args> - undef, or a reference to an array of arguments | |
6539 | ||
6540 | =item * C<file> - the file in which this item was defined (if any) | |
6541 | ||
6542 | =item * C<line> - the line on which it was defined | |
6543 | ||
6544 | =back | |
6545 | ||
6546 | =cut | |
eda6e075 | 6547 | |
b747a9b0 SF |
6548 | sub _dump_trace_calc_saved_single_arg |
6549 | { | |
6550 | my ($nothard, $arg) = @_; | |
fdada06c | 6551 | |
b747a9b0 SF |
6552 | my $type; |
6553 | if ( not defined $arg ) { # undefined parameter | |
6554 | return "undef"; | |
6555 | } | |
fdada06c | 6556 | |
b747a9b0 SF |
6557 | elsif ( $nothard and tied $arg ) { # tied parameter |
6558 | return "tied"; | |
6559 | } | |
6560 | elsif ( $nothard and $type = ref $arg ) { # reference | |
6561 | return "ref($type)"; | |
6562 | } | |
6563 | else { # can be stringified | |
6564 | local $_ = | |
6565 | "$arg"; # Safe to stringify now - should not call f(). | |
fdada06c | 6566 | |
b747a9b0 SF |
6567 | # Backslash any single-quotes or backslashes. |
6568 | s/([\'\\])/\\$1/g; | |
fdada06c | 6569 | |
b747a9b0 SF |
6570 | # Single-quote it unless it's a number or a colon-separated |
6571 | # name. | |
6572 | s/(.*)/'$1'/s | |
6573 | unless /^(?: -?[\d.]+ | \*[\w:]* )$/x; | |
fdada06c | 6574 | |
4b6af431 KW |
6575 | # Turn high-bit characters into meta-whatever, and controls into like |
6576 | # '^D'. | |
6577 | require 'meta_notation.pm'; | |
6578 | $_ = _meta_notation($_) if /[[:^print:]]/a; | |
fdada06c | 6579 | |
b747a9b0 SF |
6580 | return $_; |
6581 | } | |
6582 | } | |
6583 | ||
6584 | sub _dump_trace_calc_save_args { | |
6585 | my ($nothard) = @_; | |
fdada06c | 6586 | |
b747a9b0 SF |
6587 | return [ |
6588 | map { _dump_trace_calc_saved_single_arg($nothard, $_) } @args | |
6589 | ]; | |
fdada06c SF |
6590 | } |
6591 | ||
d12a4851 | 6592 | sub dump_trace { |
69893cff RGS |
6593 | |
6594 | # How many levels to skip. | |
e22ea7cc | 6595 | my $skip = shift; |
69893cff RGS |
6596 | |
6597 | # How many levels to show. (1e9 is a cheap way of saying "all of them"; | |
6598 | # it's unlikely that we'll have more than a billion stack frames. If you | |
6599 | # do, you've got an awfully big machine...) | |
e22ea7cc | 6600 | my $count = shift || 1e9; |
69893cff RGS |
6601 | |
6602 | # We increment skip because caller(1) is the first level *back* from | |
e22ea7cc | 6603 | # the current one. Add $skip to the count of frames so we have a |
69893cff | 6604 | # simple stop criterion, counting from $skip to $count+$skip. |
e22ea7cc RF |
6605 | $skip++; |
6606 | $count += $skip; | |
69893cff RGS |
6607 | |
6608 | # These variables are used to capture output from caller(); | |
e22ea7cc | 6609 | my ( $p, $file, $line, $sub, $h, $context ); |
69893cff | 6610 | |
78512fb5 | 6611 | my ( $e, $r, @sub, $args ); |
69893cff RGS |
6612 | |
6613 | # XXX Okay... why'd we do that? | |
e22ea7cc RF |
6614 | my $nothard = not $frame & 8; |
6615 | local $frame = 0; | |
69893cff RGS |
6616 | |
6617 | # Do not want to trace this. | |
e22ea7cc RF |
6618 | my $otrace = $trace; |
6619 | $trace = 0; | |
69893cff RGS |
6620 | |
6621 | # Start out at the skip count. | |
6622 | # If we haven't reached the number of frames requested, and caller() is | |
6623 | # still returning something, stay in the loop. (If we pass the requested | |
6624 | # number of stack frames, or we run out - caller() returns nothing - we | |
6625 | # quit. | |
6626 | # Up the stack frame index to go back one more level each time. | |
72d7d80d SF |
6627 | for ( |
6628 | my $i = $skip ; | |
e22ea7cc | 6629 | $i < $count |
72d7d80d SF |
6630 | and ( $p, $file, $line, $sub, $h, $context, $e, $r ) = caller($i) ; |
6631 | $i++ | |
2c247e84 | 6632 | ) |
69893cff RGS |
6633 | { |
6634 | ||
6635 | # Go through the arguments and save them for later. | |
fdada06c | 6636 | my $save_args = _dump_trace_calc_save_args($nothard); |
69893cff RGS |
6637 | |
6638 | # If context is true, this is array (@)context. | |
6639 | # If context is false, this is scalar ($) context. | |
e22ea7cc | 6640 | # If neither, context isn't defined. (This is apparently a 'can't |
69893cff | 6641 | # happen' trap.) |
e22ea7cc | 6642 | $context = $context ? '@' : ( defined $context ? "\$" : '.' ); |
69893cff RGS |
6643 | |
6644 | # if the sub has args ($h true), make an anonymous array of the | |
6645 | # dumped args. | |
fdada06c | 6646 | $args = $h ? $save_args : undef; |
69893cff RGS |
6647 | |
6648 | # remove trailing newline-whitespace-semicolon-end of line sequence | |
6649 | # from the eval text, if any. | |
e22ea7cc | 6650 | $e =~ s/\n\s*\;\s*\Z// if $e; |
69893cff RGS |
6651 | |
6652 | # Escape backslashed single-quotes again if necessary. | |
e22ea7cc | 6653 | $e =~ s/([\\\'])/\\$1/g if $e; |
69893cff RGS |
6654 | |
6655 | # if the require flag is true, the eval text is from a require. | |
e22ea7cc RF |
6656 | if ($r) { |
6657 | $sub = "require '$e'"; | |
6658 | } | |
6659 | ||
69893cff | 6660 | # if it's false, the eval text is really from an eval. |
e22ea7cc RF |
6661 | elsif ( defined $r ) { |
6662 | $sub = "eval '$e'"; | |
6663 | } | |
69893cff RGS |
6664 | |
6665 | # If the sub is '(eval)', this is a block eval, meaning we don't | |
6666 | # know what the eval'ed text actually was. | |
e22ea7cc RF |
6667 | elsif ( $sub eq '(eval)' ) { |
6668 | $sub = "eval {...}"; | |
6669 | } | |
69893cff RGS |
6670 | |
6671 | # Stick the collected information into @sub as an anonymous hash. | |
e22ea7cc RF |
6672 | push( |
6673 | @sub, | |
6674 | { | |
6675 | context => $context, | |
6676 | sub => $sub, | |
6677 | args => $args, | |
6678 | file => $file, | |
6679 | line => $line | |
6680 | } | |
69893cff RGS |
6681 | ); |
6682 | ||
6683 | # Stop processing frames if the user hit control-C. | |
e22ea7cc | 6684 | last if $signal; |
72d7d80d | 6685 | } ## end for ($i = $skip ; $i < ... |
69893cff RGS |
6686 | |
6687 | # Restore the trace value again. | |
e22ea7cc RF |
6688 | $trace = $otrace; |
6689 | @sub; | |
69893cff RGS |
6690 | } ## end sub dump_trace |
6691 | ||
6692 | =head2 C<action()> | |
6693 | ||
6694 | C<action()> takes input provided as the argument to an add-action command, | |
6695 | either pre- or post-, and makes sure it's a complete command. It doesn't do | |
6696 | any fancy parsing; it just keeps reading input until it gets a string | |
6697 | without a trailing backslash. | |
6698 | ||
6699 | =cut | |
eda6e075 | 6700 | |
d12a4851 JH |
6701 | sub action { |
6702 | my $action = shift; | |
69893cff | 6703 | |
e22ea7cc RF |
6704 | while ( $action =~ s/\\$// ) { |
6705 | ||
69893cff | 6706 | # We have a backslash on the end. Read more. |
b0b8faca | 6707 | $action .= gets(); |
69893cff RGS |
6708 | } ## end while ($action =~ s/\\$//) |
6709 | ||
6710 | # Return the assembled action. | |
d12a4851 | 6711 | $action; |
69893cff RGS |
6712 | } ## end sub action |
6713 | ||
6714 | =head2 unbalanced | |
6715 | ||
6716 | This routine mostly just packages up a regular expression to be used | |
6717 | to check that the thing it's being matched against has properly-matched | |
6718 | curly braces. | |
6719 | ||
be9a9b1d | 6720 | Of note is the definition of the C<$balanced_brace_re> global via C<||=>, which |
b570d64b | 6721 | speeds things up by only creating the qr//'ed expression once; if it's |
69893cff RGS |
6722 | already defined, we don't try to define it again. A speed hack. |
6723 | ||
6724 | =cut | |
eda6e075 | 6725 | |
6b24a4b7 SF |
6726 | use vars qw($balanced_brace_re); |
6727 | ||
e22ea7cc | 6728 | sub unbalanced { |
69893cff RGS |
6729 | |
6730 | # I hate using globals! | |
b570d64b | 6731 | $balanced_brace_re ||= qr{ |
e22ea7cc RF |
6732 | ^ \{ |
6733 | (?: | |
6734 | (?> [^{}] + ) # Non-parens without backtracking | |
6735 | | | |
6736 | (??{ $balanced_brace_re }) # Group with matching parens | |
6737 | ) * | |
6738 | \} $ | |
d12a4851 | 6739 | }x; |
e22ea7cc | 6740 | return $_[0] !~ m/$balanced_brace_re/; |
69893cff RGS |
6741 | } ## end sub unbalanced |
6742 | ||
6743 | =head2 C<gets()> | |
6744 | ||
6745 | C<gets()> is a primitive (very primitive) routine to read continuations. | |
6746 | It was devised for reading continuations for actions. | |
be9a9b1d | 6747 | it just reads more input with C<readline()> and returns it. |
69893cff RGS |
6748 | |
6749 | =cut | |
eda6e075 | 6750 | |
d12a4851 | 6751 | sub gets { |
b0b8faca | 6752 | return DB::readline("cont: "); |
d12a4851 | 6753 | } |
eda6e075 | 6754 | |
f0bb1409 | 6755 | =head2 C<_db_system()> - handle calls to<system()> without messing up the debugger |
69893cff RGS |
6756 | |
6757 | The C<system()> function assumes that it can just go ahead and use STDIN and | |
b570d64b SF |
6758 | STDOUT, but under the debugger, we want it to use the debugger's input and |
6759 | outout filehandles. | |
69893cff | 6760 | |
f0bb1409 | 6761 | C<_db_system()> socks away the program's STDIN and STDOUT, and then substitutes |
69893cff RGS |
6762 | the debugger's IN and OUT filehandles for them. It does the C<system()> call, |
6763 | and then puts everything back again. | |
6764 | ||
6765 | =cut | |
6766 | ||
f0bb1409 | 6767 | sub _db_system { |
e22ea7cc | 6768 | |
d12a4851 JH |
6769 | # We save, change, then restore STDIN and STDOUT to avoid fork() since |
6770 | # some non-Unix systems can do system() but have problems with fork(). | |
2384afee C |
6771 | open( SAVEIN, "<&STDIN" ) || _db_warn("Can't save STDIN"); |
6772 | open( SAVEOUT, ">&STDOUT" ) || _db_warn("Can't save STDOUT"); | |
6773 | open( STDIN, "<&IN" ) || _db_warn("Can't redirect STDIN"); | |
6774 | open( STDOUT, ">&OUT" ) || _db_warn("Can't redirect STDOUT"); | |
eda6e075 | 6775 | |
d12a4851 JH |
6776 | # XXX: using csh or tcsh destroys sigint retvals! |
6777 | system(@_); | |
2384afee C |
6778 | open( STDIN, "<&SAVEIN" ) || _db_warn("Can't restore STDIN"); |
6779 | open( STDOUT, ">&SAVEOUT" ) || _db_warn("Can't restore STDOUT"); | |
e22ea7cc | 6780 | close(SAVEIN); |
d12a4851 | 6781 | close(SAVEOUT); |
eda6e075 | 6782 | |
d12a4851 | 6783 | # most of the $? crud was coping with broken cshisms |
e22ea7cc | 6784 | if ( $? >> 8 ) { |
2384afee | 6785 | _db_warn( "(Command exited ", ( $? >> 8 ), ")\n" ); |
e22ea7cc RF |
6786 | } |
6787 | elsif ($?) { | |
2384afee | 6788 | _db_warn( |
e22ea7cc RF |
6789 | "(Command died of SIG#", |
6790 | ( $? & 127 ), | |
6791 | ( ( $? & 128 ) ? " -- core dumped" : "" ), | |
6792 | ")", "\n" | |
69893cff RGS |
6793 | ); |
6794 | } ## end elsif ($?) | |
eda6e075 | 6795 | |
d12a4851 | 6796 | return $?; |
eda6e075 | 6797 | |
69893cff RGS |
6798 | } ## end sub system |
6799 | ||
f0bb1409 SF |
6800 | *system = \&_db_system; |
6801 | ||
69893cff RGS |
6802 | =head1 TTY MANAGEMENT |
6803 | ||
6804 | The subs here do some of the terminal management for multiple debuggers. | |
6805 | ||
6806 | =head2 setterm | |
6807 | ||
6808 | Top-level function called when we want to set up a new terminal for use | |
6809 | by the debugger. | |
6810 | ||
6811 | If the C<noTTY> debugger option was set, we'll either use the terminal | |
6812 | supplied (the value of the C<noTTY> option), or we'll use C<Term::Rendezvous> | |
b570d64b SF |
6813 | to find one. If we're a forked debugger, we call C<resetterm> to try to |
6814 | get a whole new terminal if we can. | |
69893cff RGS |
6815 | |
6816 | In either case, we set up the terminal next. If the C<ReadLine> option was | |
6817 | true, we'll get a C<Term::ReadLine> object for the current terminal and save | |
b570d64b | 6818 | the appropriate attributes. We then |
69893cff RGS |
6819 | |
6820 | =cut | |
eda6e075 | 6821 | |
6b24a4b7 SF |
6822 | use vars qw($ornaments); |
6823 | use vars qw($rl_attribs); | |
6824 | ||
d12a4851 | 6825 | sub setterm { |
e22ea7cc | 6826 | |
69893cff | 6827 | # Load Term::Readline, but quietly; don't debug it and don't trace it. |
d12a4851 JH |
6828 | local $frame = 0; |
6829 | local $doret = -2; | |
999f23be | 6830 | require Term::ReadLine; |
69893cff RGS |
6831 | |
6832 | # If noTTY is set, but we have a TTY name, go ahead and hook up to it. | |
d12a4851 | 6833 | if ($notty) { |
e22ea7cc RF |
6834 | if ($tty) { |
6835 | my ( $i, $o ) = split $tty, /,/; | |
6836 | $o = $i unless defined $o; | |
1ae6ead9 JL |
6837 | open( IN, '<', $i ) or die "Cannot open TTY '$i' for read: $!"; |
6838 | open( OUT, '>', $o ) or die "Cannot open TTY '$o' for write: $!"; | |
e22ea7cc RF |
6839 | $IN = \*IN; |
6840 | $OUT = \*OUT; | |
e0047406 | 6841 | _autoflush($OUT); |
69893cff RGS |
6842 | } ## end if ($tty) |
6843 | ||
6844 | # We don't have a TTY - try to find one via Term::Rendezvous. | |
e22ea7cc | 6845 | else { |
4a49187b | 6846 | require Term::Rendezvous; |
e22ea7cc | 6847 | |
69893cff | 6848 | # See if we have anything to pass to Term::Rendezvous. |
b0e77abc BD |
6849 | # Use $HOME/.perldbtty$$ if not. |
6850 | my $rv = $ENV{PERLDB_NOTTY} || "$ENV{HOME}/.perldbtty$$"; | |
69893cff RGS |
6851 | |
6852 | # Rendezvous and get the filehandles. | |
bee4b460 | 6853 | my $term_rv = Term::Rendezvous->new( $rv ); |
e22ea7cc RF |
6854 | $IN = $term_rv->IN; |
6855 | $OUT = $term_rv->OUT; | |
69893cff RGS |
6856 | } ## end else [ if ($tty) |
6857 | } ## end if ($notty) | |
6858 | ||
69893cff | 6859 | # We're a daughter debugger. Try to fork off another TTY. |
e22ea7cc RF |
6860 | if ( $term_pid eq '-1' ) { # In a TTY with another debugger |
6861 | resetterm(2); | |
d12a4851 | 6862 | } |
69893cff RGS |
6863 | |
6864 | # If we shouldn't use Term::ReadLine, don't. | |
e22ea7cc | 6865 | if ( !$rl ) { |
bee4b460 | 6866 | $term = Term::ReadLine::Stub->new( 'perldb', $IN, $OUT ); |
e22ea7cc | 6867 | } |
d12a4851 | 6868 | |
69893cff RGS |
6869 | # We're using Term::ReadLine. Get all the attributes for this terminal. |
6870 | else { | |
bee4b460 | 6871 | $term = Term::ReadLine->new( 'perldb', $IN, $OUT ); |
e22ea7cc RF |
6872 | |
6873 | $rl_attribs = $term->Attribs; | |
6874 | $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}' | |
6875 | if defined $rl_attribs->{basic_word_break_characters} | |
6876 | and index( $rl_attribs->{basic_word_break_characters}, ":" ) == -1; | |
6877 | $rl_attribs->{special_prefixes} = '$@&%'; | |
6878 | $rl_attribs->{completer_word_break_characters} .= '$@&%'; | |
6879 | $rl_attribs->{completion_function} = \&db_complete; | |
69893cff RGS |
6880 | } ## end else [ if (!$rl) |
6881 | ||
6882 | # Set up the LINEINFO filehandle. | |
e22ea7cc | 6883 | $LINEINFO = $OUT unless defined $LINEINFO; |
d12a4851 | 6884 | $lineinfo = $console unless defined $lineinfo; |
69893cff | 6885 | |
d12a4851 | 6886 | $term->MinLine(2); |
69893cff | 6887 | |
b0b8faca | 6888 | load_hist(); |
5561b870 | 6889 | |
e22ea7cc RF |
6890 | if ( $term->Features->{setHistory} and "@hist" ne "?" ) { |
6891 | $term->SetHistory(@hist); | |
d12a4851 | 6892 | } |
69893cff RGS |
6893 | |
6894 | # XXX Ornaments are turned on unconditionally, which is not | |
6895 | # always a good thing. | |
d12a4851 JH |
6896 | ornaments($ornaments) if defined $ornaments; |
6897 | $term_pid = $$; | |
69893cff RGS |
6898 | } ## end sub setterm |
6899 | ||
5561b870 A |
6900 | sub load_hist { |
6901 | $histfile //= option_val("HistFile", undef); | |
6902 | return unless defined $histfile; | |
6903 | open my $fh, "<", $histfile or return; | |
6904 | local $/ = "\n"; | |
6905 | @hist = (); | |
6906 | while (<$fh>) { | |
6907 | chomp; | |
6908 | push @hist, $_; | |
6909 | } | |
6910 | close $fh; | |
6911 | } | |
6912 | ||
6913 | sub save_hist { | |
6914 | return unless defined $histfile; | |
6915 | eval { require File::Path } or return; | |
6916 | eval { require File::Basename } or return; | |
6917 | File::Path::mkpath(File::Basename::dirname($histfile)); | |
6918 | open my $fh, ">", $histfile or die "Could not open '$histfile': $!"; | |
6919 | $histsize //= option_val("HistSize",100); | |
6920 | my @copy = grep { $_ ne '?' } @hist; | |
6921 | my $start = scalar(@copy) > $histsize ? scalar(@copy)-$histsize : 0; | |
6922 | for ($start .. $#copy) { | |
6923 | print $fh "$copy[$_]\n"; | |
6924 | } | |
6925 | close $fh or die "Could not write '$histfile': $!"; | |
6926 | } | |
6927 | ||
69893cff RGS |
6928 | =head1 GET_FORK_TTY EXAMPLE FUNCTIONS |
6929 | ||
6930 | When the process being debugged forks, or the process invokes a command | |
6931 | via C<system()> which starts a new debugger, we need to be able to get a new | |
6932 | C<IN> and C<OUT> filehandle for the new debugger. Otherwise, the two processes | |
6933 | fight over the terminal, and you can never quite be sure who's going to get the | |
6934 | input you're typing. | |
6935 | ||
b570d64b SF |
6936 | C<get_fork_TTY> is a glob-aliased function which calls the real function that |
6937 | is tasked with doing all the necessary operating system mojo to get a new | |
69893cff RGS |
6938 | TTY (and probably another window) and to direct the new debugger to read and |
6939 | write there. | |
6940 | ||
11653f7f | 6941 | The debugger provides C<get_fork_TTY> functions which work for TCP |
b0b54b5e | 6942 | socket servers, X11, OS/2, and Mac OS X. Other systems are not |
11653f7f JJ |
6943 | supported. You are encouraged to write C<get_fork_TTY> functions which |
6944 | work for I<your> platform and contribute them. | |
6945 | ||
6946 | =head3 C<socket_get_fork_TTY> | |
6947 | ||
b570d64b | 6948 | =cut |
11653f7f JJ |
6949 | |
6950 | sub connect_remoteport { | |
6951 | require IO::Socket; | |
6952 | ||
6953 | my $socket = IO::Socket::INET->new( | |
6954 | Timeout => '10', | |
6955 | PeerAddr => $remoteport, | |
6956 | Proto => 'tcp', | |
6957 | ); | |
6958 | if ( ! $socket ) { | |
6959 | die "Unable to connect to remote host: $remoteport\n"; | |
6960 | } | |
6961 | return $socket; | |
6962 | } | |
6963 | ||
6964 | sub socket_get_fork_TTY { | |
f633fd28 | 6965 | $tty = $LINEINFO = $IN = $OUT = connect_remoteport(); |
11653f7f JJ |
6966 | |
6967 | # Do I need to worry about setting $term? | |
6968 | ||
6969 | reset_IN_OUT( $IN, $OUT ); | |
6970 | return ''; | |
6971 | } | |
69893cff RGS |
6972 | |
6973 | =head3 C<xterm_get_fork_TTY> | |
6974 | ||
b570d64b | 6975 | This function provides the C<get_fork_TTY> function for X11. If a |
69893cff RGS |
6976 | program running under the debugger forks, a new <xterm> window is opened and |
6977 | the subsidiary debugger is directed there. | |
6978 | ||
6979 | The C<open()> call is of particular note here. We have the new C<xterm> | |
b570d64b SF |
6980 | we're spawning route file number 3 to STDOUT, and then execute the C<tty> |
6981 | command (which prints the device name of the TTY we'll want to use for input | |
69893cff RGS |
6982 | and output to STDOUT, then C<sleep> for a very long time, routing this output |
6983 | to file number 3. This way we can simply read from the <XT> filehandle (which | |
b570d64b | 6984 | is STDOUT from the I<commands> we ran) to get the TTY we want to use. |
69893cff | 6985 | |
b570d64b | 6986 | Only works if C<xterm> is in your path and C<$ENV{DISPLAY}>, etc. are |
69893cff RGS |
6987 | properly set up. |
6988 | ||
6989 | =cut | |
eda6e075 | 6990 | |
d12a4851 | 6991 | sub xterm_get_fork_TTY { |
e22ea7cc RF |
6992 | ( my $name = $0 ) =~ s,^.*[/\\],,s; |
6993 | open XT, | |
69893cff | 6994 | qq[3>&1 xterm -title "Daughter Perl debugger $pids $name" -e sh -c 'tty 1>&3;\ |
d12a4851 | 6995 | sleep 10000000' |]; |
69893cff RGS |
6996 | |
6997 | # Get the output from 'tty' and clean it up a little. | |
e22ea7cc RF |
6998 | my $tty = <XT>; |
6999 | chomp $tty; | |
69893cff | 7000 | |
e22ea7cc | 7001 | $pidprompt = ''; # Shown anyway in titlebar |
69893cff | 7002 | |
98274836 JM |
7003 | # We need $term defined or we can not switch to the newly created xterm |
7004 | if ($tty ne '' && !defined $term) { | |
999f23be | 7005 | require Term::ReadLine; |
98274836 | 7006 | if ( !$rl ) { |
bee4b460 | 7007 | $term = Term::ReadLine::Stub->new( 'perldb', $IN, $OUT ); |
98274836 JM |
7008 | } |
7009 | else { | |
bee4b460 | 7010 | $term = Term::ReadLine->new( 'perldb', $IN, $OUT ); |
98274836 JM |
7011 | } |
7012 | } | |
69893cff | 7013 | # There's our new TTY. |
e22ea7cc | 7014 | return $tty; |
69893cff RGS |
7015 | } ## end sub xterm_get_fork_TTY |
7016 | ||
7017 | =head3 C<os2_get_fork_TTY> | |
7018 | ||
7019 | XXX It behooves an OS/2 expert to write the necessary documentation for this! | |
7020 | ||
7021 | =cut | |
eda6e075 | 7022 | |
d12a4851 | 7023 | # This example function resets $IN, $OUT itself |
619a0444 IZ |
7024 | my $c_pipe = 0; |
7025 | sub os2_get_fork_TTY { # A simplification of the following (and works without): | |
e22ea7cc | 7026 | local $\ = ''; |
e22ea7cc | 7027 | ( my $name = $0 ) =~ s,^.*[/\\],,s; |
2dbd01ad SF |
7028 | my %opt = ( title => "Daughter Perl debugger $pids $name", |
7029 | ($rl ? (read_by_key => 1) : ()) ); | |
619a0444 IZ |
7030 | require OS2::Process; |
7031 | my ($in, $out, $pid) = eval { OS2::Process::io_term(related => 0, %opt) } | |
7032 | or return; | |
7033 | $pidprompt = ''; # Shown anyway in titlebar | |
7034 | reset_IN_OUT($in, $out); | |
7035 | $tty = '*reset*'; | |
7036 | return ''; # Indicate that reset_IN_OUT is called | |
69893cff RGS |
7037 | } ## end sub os2_get_fork_TTY |
7038 | ||
6fae1ad7 RF |
7039 | =head3 C<macosx_get_fork_TTY> |
7040 | ||
7041 | The Mac OS X version uses AppleScript to tell Terminal.app to create | |
7042 | a new window. | |
7043 | ||
7044 | =cut | |
7045 | ||
7046 | # Notes about Terminal.app's AppleScript support, | |
7047 | # (aka things that might break in future OS versions). | |
7048 | # | |
7049 | # The "do script" command doesn't return a reference to the new window | |
7050 | # it creates, but since it appears frontmost and windows are enumerated | |
7051 | # front to back, we can use "first window" === "window 1". | |
7052 | # | |
52cd570b BL |
7053 | # Since "do script" is implemented by supplying the argument (plus a |
7054 | # return character) as terminal input, there's a potential race condition | |
7055 | # where the debugger could beat the shell to reading the command. | |
7056 | # To prevent this, we wait for the screen to clear before proceeding. | |
7057 | # | |
d457cffc BL |
7058 | # 10.3 and 10.4: |
7059 | # There's no direct accessor for the tty device name, so we fiddle | |
7060 | # with the window title options until it says what we want. | |
7061 | # | |
7062 | # 10.5: | |
7063 | # There _is_ a direct accessor for the tty device name, _and_ there's | |
7064 | # a new possible component of the window title (the name of the settings | |
7065 | # set). A separate version is needed. | |
6fae1ad7 | 7066 | |
d457cffc | 7067 | my @script_versions= |
6fae1ad7 | 7068 | |
d457cffc BL |
7069 | ([237, <<'__LEOPARD__'], |
7070 | tell application "Terminal" | |
7071 | do script "clear;exec sleep 100000" | |
7072 | tell first tab of first window | |
7073 | copy tty to thetty | |
7074 | set custom title to "forked perl debugger" | |
7075 | set title displays custom title to true | |
7076 | repeat while (length of first paragraph of (get contents)) > 0 | |
7077 | delay 0.1 | |
7078 | end repeat | |
7079 | end tell | |
7080 | end tell | |
7081 | thetty | |
7082 | __LEOPARD__ | |
7083 | ||
7084 | [100, <<'__JAGUAR_TIGER__'], | |
6fae1ad7 RF |
7085 | tell application "Terminal" |
7086 | do script "clear;exec sleep 100000" | |
7087 | tell first window | |
7088 | set title displays shell path to false | |
7089 | set title displays window size to false | |
7090 | set title displays file name to false | |
7091 | set title displays device name to true | |
7092 | set title displays custom title to true | |
7093 | set custom title to "" | |
d457cffc | 7094 | copy "/dev/" & name to thetty |
6fae1ad7 | 7095 | set custom title to "forked perl debugger" |
52cd570b BL |
7096 | repeat while (length of first paragraph of (get contents)) > 0 |
7097 | delay 0.1 | |
7098 | end repeat | |
6fae1ad7 RF |
7099 | end tell |
7100 | end tell | |
d457cffc BL |
7101 | thetty |
7102 | __JAGUAR_TIGER__ | |
7103 | ||
7104 | ); | |
7105 | ||
7106 | sub macosx_get_fork_TTY | |
7107 | { | |
7108 | my($version,$script,$pipe,$tty); | |
6fae1ad7 | 7109 | |
d457cffc BL |
7110 | return unless $version=$ENV{TERM_PROGRAM_VERSION}; |
7111 | foreach my $entry (@script_versions) { | |
2dbd01ad SF |
7112 | if ($version>=$entry->[0]) { |
7113 | $script=$entry->[1]; | |
7114 | last; | |
7115 | } | |
d457cffc BL |
7116 | } |
7117 | return unless defined($script); | |
7118 | return unless open($pipe,'-|','/usr/bin/osascript','-e',$script); | |
6fae1ad7 RF |
7119 | $tty=readline($pipe); |
7120 | close($pipe); | |
7121 | return unless defined($tty) && $tty =~ m(^/dev/); | |
7122 | chomp $tty; | |
7123 | return $tty; | |
7124 | } | |
7125 | ||
babb663a RH |
7126 | =head3 C<tmux_get_fork_TTY> |
7127 | ||
7128 | Creates a split window for subprocesses when a process running under the | |
7129 | perl debugger in Tmux forks. | |
7130 | ||
7131 | =cut | |
7132 | ||
7133 | sub tmux_get_fork_TTY { | |
7134 | return unless $ENV{TMUX}; | |
7135 | ||
7136 | my $pipe; | |
7137 | ||
7138 | my $status = open $pipe, '-|', 'tmux', 'split-window', | |
7139 | '-P', '-F', '#{pane_tty}', 'sleep 100000'; | |
7140 | ||
7141 | if ( !$status ) { | |
7142 | return; | |
7143 | } | |
7144 | ||
7145 | my $tty = <$pipe>; | |
7146 | close $pipe; | |
7147 | ||
7148 | if ( $tty ) { | |
7149 | chomp $tty; | |
7150 | ||
7151 | if ( !defined $term ) { | |
7152 | require Term::ReadLine; | |
7153 | if ( !$rl ) { | |
7154 | $term = Term::ReadLine::Stub->new( 'perldb', $IN, $OUT ); | |
7155 | } | |
7156 | else { | |
7157 | $term = Term::ReadLine->new( 'perldb', $IN, $OUT ); | |
7158 | } | |
7159 | } | |
7160 | } | |
7161 | ||
7162 | return $tty; | |
7163 | } | |
7164 | ||
69893cff | 7165 | =head2 C<create_IN_OUT($flags)> |
eda6e075 | 7166 | |
69893cff RGS |
7167 | Create a new pair of filehandles, pointing to a new TTY. If impossible, |
7168 | try to diagnose why. | |
7169 | ||
7170 | Flags are: | |
7171 | ||
7172 | =over 4 | |
7173 | ||
7174 | =item * 1 - Don't know how to create a new TTY. | |
7175 | ||
7176 | =item * 2 - Debugger has forked, but we can't get a new TTY. | |
7177 | ||
7178 | =item * 4 - standard debugger startup is happening. | |
7179 | ||
7180 | =back | |
7181 | ||
7182 | =cut | |
7183 | ||
6b24a4b7 SF |
7184 | use vars qw($fork_TTY); |
7185 | ||
69893cff RGS |
7186 | sub create_IN_OUT { # Create a window with IN/OUT handles redirected there |
7187 | ||
7188 | # If we know how to get a new TTY, do it! $in will have | |
7189 | # the TTY name if get_fork_TTY works. | |
b0b8faca | 7190 | my $in = get_fork_TTY(@_) if defined &get_fork_TTY; |
69893cff | 7191 | |
e22ea7cc RF |
7192 | # It used to be that |
7193 | $in = $fork_TTY if defined $fork_TTY; # Backward compatibility | |
7194 | ||
7195 | if ( not defined $in ) { | |
7196 | my $why = shift; | |
69893cff RGS |
7197 | |
7198 | # We don't know how. | |
e22ea7cc | 7199 | print_help(<<EOP) if $why == 1; |
d12a4851 JH |
7200 | I<#########> Forked, but do not know how to create a new B<TTY>. I<#########> |
7201 | EOP | |
69893cff RGS |
7202 | |
7203 | # Forked debugger. | |
e22ea7cc | 7204 | print_help(<<EOP) if $why == 2; |
d12a4851 JH |
7205 | I<#########> Daughter session, do not know how to change a B<TTY>. I<#########> |
7206 | This may be an asynchronous session, so the parent debugger may be active. | |
7207 | EOP | |
69893cff RGS |
7208 | |
7209 | # Note that both debuggers are fighting over the same input. | |
e22ea7cc | 7210 | print_help(<<EOP) if $why != 4; |
d12a4851 | 7211 | Since two debuggers fight for the same TTY, input is severely entangled. |
eda6e075 | 7212 | |
d12a4851 | 7213 | EOP |
e22ea7cc | 7214 | print_help(<<EOP); |
6fae1ad7 RF |
7215 | I know how to switch the output to a different window in xterms, OS/2 |
7216 | consoles, and Mac OS X Terminal.app only. For a manual switch, put the name | |
7217 | of the created I<TTY> in B<\$DB::fork_TTY>, or define a function | |
7218 | B<DB::get_fork_TTY()> returning this. | |
eda6e075 | 7219 | |
d12a4851 JH |
7220 | On I<UNIX>-like systems one can get the name of a I<TTY> for the given window |
7221 | by typing B<tty>, and disconnect the I<shell> from I<TTY> by B<sleep 1000000>. | |
eda6e075 | 7222 | |
d12a4851 | 7223 | EOP |
69893cff | 7224 | } ## end if (not defined $in) |
e22ea7cc RF |
7225 | elsif ( $in ne '' ) { |
7226 | TTY($in); | |
7227 | } | |
69893cff | 7228 | else { |
e22ea7cc | 7229 | $console = ''; # Indicate no need to open-from-the-console |
d12a4851 JH |
7230 | } |
7231 | undef $fork_TTY; | |
69893cff RGS |
7232 | } ## end sub create_IN_OUT |
7233 | ||
7234 | =head2 C<resetterm> | |
7235 | ||
7236 | Handles rejiggering the prompt when we've forked off a new debugger. | |
7237 | ||
b570d64b | 7238 | If the new debugger happened because of a C<system()> that invoked a |
69893cff RGS |
7239 | program under the debugger, the arrow between the old pid and the new |
7240 | in the prompt has I<two> dashes instead of one. | |
7241 | ||
7242 | We take the current list of pids and add this one to the end. If there | |
b570d64b SF |
7243 | isn't any list yet, we make one up out of the initial pid associated with |
7244 | the terminal and our new pid, sticking an arrow (either one-dashed or | |
69893cff RGS |
7245 | two dashed) in between them. |
7246 | ||
7247 | If C<CreateTTY> is off, or C<resetterm> was called with no arguments, | |
7248 | we don't try to create a new IN and OUT filehandle. Otherwise, we go ahead | |
7249 | and try to do that. | |
eda6e075 | 7250 | |
69893cff RGS |
7251 | =cut |
7252 | ||
e22ea7cc | 7253 | sub resetterm { # We forked, so we need a different TTY |
69893cff RGS |
7254 | |
7255 | # Needs to be passed to create_IN_OUT() as well. | |
d12a4851 | 7256 | my $in = shift; |
69893cff RGS |
7257 | |
7258 | # resetterm(2): got in here because of a system() starting a debugger. | |
7259 | # resetterm(1): just forked. | |
d12a4851 | 7260 | my $systemed = $in > 1 ? '-' : ''; |
69893cff RGS |
7261 | |
7262 | # If there's already a list of pids, add this to the end. | |
d12a4851 | 7263 | if ($pids) { |
e22ea7cc RF |
7264 | $pids =~ s/\]/$systemed->$$]/; |
7265 | } | |
69893cff RGS |
7266 | |
7267 | # No pid list. Time to make one. | |
7268 | else { | |
e22ea7cc | 7269 | $pids = "[$term_pid->$$]"; |
d12a4851 | 7270 | } |
69893cff RGS |
7271 | |
7272 | # The prompt we're going to be using for this debugger. | |
d12a4851 | 7273 | $pidprompt = $pids; |
69893cff RGS |
7274 | |
7275 | # We now 0wnz this terminal. | |
d12a4851 | 7276 | $term_pid = $$; |
69893cff RGS |
7277 | |
7278 | # Just return if we're not supposed to try to create a new TTY. | |
d12a4851 | 7279 | return unless $CreateTTY & $in; |
69893cff RGS |
7280 | |
7281 | # Try to create a new IN/OUT pair. | |
d12a4851 | 7282 | create_IN_OUT($in); |
69893cff RGS |
7283 | } ## end sub resetterm |
7284 | ||
7285 | =head2 C<readline> | |
7286 | ||
7287 | First, we handle stuff in the typeahead buffer. If there is any, we shift off | |
7288 | the next line, print a message saying we got it, add it to the terminal | |
7289 | history (if possible), and return it. | |
7290 | ||
7291 | If there's nothing in the typeahead buffer, check the command filehandle stack. | |
7292 | If there are any filehandles there, read from the last one, and return the line | |
7293 | if we got one. If not, we pop the filehandle off and close it, and try the | |
7294 | next one up the stack. | |
7295 | ||
b570d64b SF |
7296 | If we've emptied the filehandle stack, we check to see if we've got a socket |
7297 | open, and we read that and return it if we do. If we don't, we just call the | |
69893cff RGS |
7298 | core C<readline()> and return its value. |
7299 | ||
7300 | =cut | |
eda6e075 | 7301 | |
d12a4851 | 7302 | sub readline { |
69893cff RGS |
7303 | |
7304 | # Localize to prevent it from being smashed in the program being debugged. | |
e22ea7cc | 7305 | local $.; |
69893cff | 7306 | |
35879b90 SF |
7307 | # If there are stacked filehandles to read from ... |
7308 | # (Handle it before the typeahead, because we may call source/etc. from | |
7309 | # the typeahead.) | |
7310 | while (@cmdfhs) { | |
7311 | ||
7312 | # Read from the last one in the stack. | |
7313 | my $line = CORE::readline( $cmdfhs[-1] ); | |
7314 | ||
7315 | # If we got a line ... | |
7316 | defined $line | |
7317 | ? ( print $OUT ">> $line" and return $line ) # Echo and return | |
7318 | : close pop @cmdfhs; # Pop and close | |
7319 | } ## end while (@cmdfhs) | |
7320 | ||
69893cff | 7321 | # Pull a line out of the typeahead if there's stuff there. |
e22ea7cc RF |
7322 | if (@typeahead) { |
7323 | ||
69893cff | 7324 | # How many lines left. |
e22ea7cc | 7325 | my $left = @typeahead; |
69893cff RGS |
7326 | |
7327 | # Get the next line. | |
e22ea7cc | 7328 | my $got = shift @typeahead; |
69893cff RGS |
7329 | |
7330 | # Print a message saying we got input from the typeahead. | |
e22ea7cc RF |
7331 | local $\ = ''; |
7332 | print $OUT "auto(-$left)", shift, $got, "\n"; | |
69893cff RGS |
7333 | |
7334 | # Add it to the terminal history (if possible). | |
e22ea7cc RF |
7335 | $term->AddHistory($got) |
7336 | if length($got) > 1 | |
7337 | and defined $term->Features->{addHistory}; | |
7338 | return $got; | |
69893cff RGS |
7339 | } ## end if (@typeahead) |
7340 | ||
e22ea7cc | 7341 | # We really need to read some input. Turn off entry/exit trace and |
69893cff | 7342 | # return value printing. |
e22ea7cc RF |
7343 | local $frame = 0; |
7344 | local $doret = -2; | |
69893cff | 7345 | |
69893cff | 7346 | # Nothing on the filehandle stack. Socket? |
e22ea7cc RF |
7347 | if ( ref $OUT and UNIVERSAL::isa( $OUT, 'IO::Socket::INET' ) ) { |
7348 | ||
98dc9551 | 7349 | # Send anything we have to send. |
e22ea7cc | 7350 | $OUT->write( join( '', @_ ) ); |
69893cff RGS |
7351 | |
7352 | # Receive anything there is to receive. | |
a85de320 BD |
7353 | my $stuff = ''; |
7354 | my $buf; | |
4915c7ee SF |
7355 | my $first_time = 1; |
7356 | ||
7357 | while ($first_time or (length($buf) && ($stuff .= $buf) !~ /\n/)) | |
7358 | { | |
7359 | $first_time = 0; | |
a85de320 BD |
7360 | $IN->recv( $buf = '', 2048 ); # XXX "what's wrong with sysread?" |
7361 | # XXX Don't know. You tell me. | |
4915c7ee | 7362 | } |
69893cff RGS |
7363 | |
7364 | # What we got. | |
4915c7ee | 7365 | return $stuff; |
69893cff RGS |
7366 | } ## end if (ref $OUT and UNIVERSAL::isa... |
7367 | ||
7368 | # No socket. Just read from the terminal. | |
e22ea7cc | 7369 | else { |
4915c7ee | 7370 | return $term->readline(@_); |
e22ea7cc | 7371 | } |
69893cff RGS |
7372 | } ## end sub readline |
7373 | ||
7374 | =head1 OPTIONS SUPPORT ROUTINES | |
7375 | ||
7376 | These routines handle listing and setting option values. | |
7377 | ||
7378 | =head2 C<dump_option> - list the current value of an option setting | |
7379 | ||
7380 | This routine uses C<option_val> to look up the value for an option. | |
7381 | It cleans up escaped single-quotes and then displays the option and | |
7382 | its value. | |
7383 | ||
7384 | =cut | |
eda6e075 | 7385 | |
d12a4851 | 7386 | sub dump_option { |
e22ea7cc RF |
7387 | my ( $opt, $val ) = @_; |
7388 | $val = option_val( $opt, 'N/A' ); | |
d12a4851 JH |
7389 | $val =~ s/([\\\'])/\\$1/g; |
7390 | printf $OUT "%20s = '%s'\n", $opt, $val; | |
69893cff RGS |
7391 | } ## end sub dump_option |
7392 | ||
d12a4851 | 7393 | sub options2remember { |
e22ea7cc RF |
7394 | foreach my $k (@RememberOnROptions) { |
7395 | $option{$k} = option_val( $k, 'N/A' ); | |
7396 | } | |
7397 | return %option; | |
d12a4851 | 7398 | } |
eda6e075 | 7399 | |
69893cff RGS |
7400 | =head2 C<option_val> - find the current value of an option |
7401 | ||
7402 | This can't just be a simple hash lookup because of the indirect way that | |
7403 | the option values are stored. Some are retrieved by calling a subroutine, | |
7404 | some are just variables. | |
7405 | ||
7406 | You must supply a default value to be used in case the option isn't set. | |
7407 | ||
7408 | =cut | |
7409 | ||
d12a4851 | 7410 | sub option_val { |
e22ea7cc | 7411 | my ( $opt, $default ) = @_; |
d12a4851 | 7412 | my $val; |
69893cff RGS |
7413 | |
7414 | # Does this option exist, and is it a variable? | |
7415 | # If so, retrieve the value via the value in %optionVars. | |
e22ea7cc RF |
7416 | if ( defined $optionVars{$opt} |
7417 | and defined ${ $optionVars{$opt} } ) | |
7418 | { | |
69893cff RGS |
7419 | $val = ${ $optionVars{$opt} }; |
7420 | } | |
7421 | ||
7422 | # Does this option exist, and it's a subroutine? | |
7423 | # If so, call the subroutine via the ref in %optionAction | |
7424 | # and capture the value. | |
e22ea7cc RF |
7425 | elsif ( defined $optionAction{$opt} |
7426 | and defined &{ $optionAction{$opt} } ) | |
7427 | { | |
7428 | $val = &{ $optionAction{$opt} }(); | |
7429 | } | |
69893cff RGS |
7430 | |
7431 | # If there's an action or variable for the supplied option, | |
7432 | # but no value was set, use the default. | |
7433 | elsif (defined $optionAction{$opt} and not defined $option{$opt} | |
e22ea7cc | 7434 | or defined $optionVars{$opt} and not defined ${ $optionVars{$opt} } ) |
69893cff RGS |
7435 | { |
7436 | $val = $default; | |
e22ea7cc | 7437 | } |
69893cff RGS |
7438 | |
7439 | # Otherwise, do the simple hash lookup. | |
7440 | else { | |
e22ea7cc | 7441 | $val = $option{$opt}; |
d12a4851 | 7442 | } |
69893cff RGS |
7443 | |
7444 | # If the value isn't defined, use the default. | |
7445 | # Then return whatever the value is. | |
d12a4851 | 7446 | $val = $default unless defined $val; |
e22ea7cc | 7447 | $val; |
69893cff RGS |
7448 | } ## end sub option_val |
7449 | ||
7450 | =head2 C<parse_options> | |
7451 | ||
7452 | Handles the parsing and execution of option setting/displaying commands. | |
7453 | ||
be9a9b1d | 7454 | An option entered by itself is assumed to be I<set me to 1> (the default value) |
69893cff | 7455 | if the option is a boolean one. If not, the user is prompted to enter a valid |
be9a9b1d | 7456 | value or to query the current value (via C<option? >). |
69893cff | 7457 | |
be9a9b1d | 7458 | If C<option=value> is entered, we try to extract a quoted string from the |
69893cff RGS |
7459 | value (if it is quoted). If it's not, we just use the whole value as-is. |
7460 | ||
7461 | We load any modules required to service this option, and then we set it: if | |
b570d64b | 7462 | it just gets stuck in a variable, we do that; if there's a subroutine to |
69893cff RGS |
7463 | handle setting the option, we call that. |
7464 | ||
7465 | Finally, if we're running in interactive mode, we display the effect of the | |
7466 | user's command back to the terminal, skipping this if we're setting things | |
7467 | during initialization. | |
7468 | ||
7469 | =cut | |
eda6e075 | 7470 | |
d12a4851 | 7471 | sub parse_options { |
c5c03c9a | 7472 | my ($s) = @_; |
d12a4851 | 7473 | local $\ = ''; |
69893cff | 7474 | |
6b24a4b7 SF |
7475 | my $option; |
7476 | ||
69893cff | 7477 | # These options need a value. Don't allow them to be clobbered by accident. |
e22ea7cc RF |
7478 | my %opt_needs_val = map { ( $_ => 1 ) } qw{ |
7479 | dumpDepth arrayDepth hashDepth LineInfo maxTraceLen ornaments windowSize | |
7480 | pager quote ReadLine recallCommand RemotePort ShellBang TTY CommandSet | |
d12a4851 | 7481 | }; |
69893cff | 7482 | |
c5c03c9a | 7483 | while (length($s)) { |
e22ea7cc | 7484 | my $val_defaulted; |
69893cff RGS |
7485 | |
7486 | # Clean off excess leading whitespace. | |
c5c03c9a | 7487 | $s =~ s/^\s+// && next; |
69893cff RGS |
7488 | |
7489 | # Options are always all word characters, followed by a non-word | |
7490 | # separator. | |
c5c03c9a SF |
7491 | if ($s !~ s/^(\w+)(\W?)//) { |
7492 | print {$OUT} "Invalid option '$s'\n"; | |
7493 | last; | |
7494 | } | |
e22ea7cc | 7495 | my ( $opt, $sep ) = ( $1, $2 ); |
69893cff | 7496 | |
e22ea7cc | 7497 | # Make sure that such an option exists. |
c5c03c9a SF |
7498 | my $matches = ( grep { /^\Q$opt/ && ( $option = $_ ) } @options ) |
7499 | || ( grep { /^\Q$opt/i && ( $option = $_ ) } @options ); | |
e22ea7cc | 7500 | |
c5c03c9a SF |
7501 | unless ($matches) { |
7502 | print {$OUT} "Unknown option '$opt'\n"; | |
7503 | next; | |
7504 | } | |
7505 | if ($matches > 1) { | |
7506 | print {$OUT} "Ambiguous option '$opt'\n"; | |
7507 | next; | |
7508 | } | |
e22ea7cc | 7509 | my $val; |
69893cff RGS |
7510 | |
7511 | # '?' as separator means query, but must have whitespace after it. | |
e22ea7cc | 7512 | if ( "?" eq $sep ) { |
c5c03c9a SF |
7513 | if ($s =~ /\A\S/) { |
7514 | print {$OUT} "Option query '$opt?' followed by non-space '$s'\n" ; | |
7515 | ||
7516 | last; | |
7517 | } | |
69893cff | 7518 | |
e22ea7cc RF |
7519 | #&dump_option($opt); |
7520 | } ## end if ("?" eq $sep) | |
69893cff RGS |
7521 | |
7522 | # Separator is whitespace (or just a carriage return). | |
7523 | # They're going for a default, which we assume is 1. | |
e22ea7cc RF |
7524 | elsif ( $sep !~ /\S/ ) { |
7525 | $val_defaulted = 1; | |
7526 | $val = "1"; # this is an evil default; make 'em set it! | |
7527 | } | |
69893cff RGS |
7528 | |
7529 | # Separator is =. Trying to set a value. | |
e22ea7cc RF |
7530 | elsif ( $sep eq "=" ) { |
7531 | ||
69893cff | 7532 | # If quoted, extract a quoted string. |
c5c03c9a | 7533 | if ($s =~ s/ (["']) ( (?: \\. | (?! \1 ) [^\\] )* ) \1 //x) { |
d12a4851 | 7534 | my $quote = $1; |
e22ea7cc RF |
7535 | ( $val = $2 ) =~ s/\\([$quote\\])/$1/g; |
7536 | } | |
69893cff RGS |
7537 | |
7538 | # Not quoted. Use the whole thing. Warn about 'option='. | |
e22ea7cc | 7539 | else { |
c5c03c9a | 7540 | $s =~ s/^(\S*)//; |
e22ea7cc RF |
7541 | $val = $1; |
7542 | print OUT qq(Option better cleared using $opt=""\n) | |
7543 | unless length $val; | |
7544 | } ## end else [ if (s/ (["']) ( (?: \\. | (?! \1 ) [^\\] )* ) \1 //x) | |
7545 | ||
7546 | } ## end elsif ($sep eq "=") | |
7547 | ||
7548 | # "Quoted" with [], <>, or {}. | |
7549 | else { #{ to "let some poor schmuck bounce on the % key in B<vi>." | |
7550 | my ($end) = | |
7551 | "\\" . substr( ")]>}$sep", index( "([<{", $sep ), 1 ); #} | |
c5c03c9a | 7552 | $s =~ s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// |
1f874cb6 | 7553 | or print( $OUT "Unclosed option value '$opt$sep$_'\n" ), last; |
e22ea7cc RF |
7554 | ( $val = $1 ) =~ s/\\([\\$end])/$1/g; |
7555 | } ## end else [ if ("?" eq $sep) | |
69893cff RGS |
7556 | |
7557 | # Exclude non-booleans from getting set to 1 by default. | |
e22ea7cc RF |
7558 | if ( $opt_needs_val{$option} && $val_defaulted ) { |
7559 | my $cmd = ( $CommandSet eq '580' ) ? 'o' : 'O'; | |
c5c03c9a | 7560 | print {$OUT} |
1f874cb6 | 7561 | "Option '$opt' is non-boolean. Use '$cmd $option=VAL' to set, '$cmd $option?' to query\n"; |
e22ea7cc RF |
7562 | next; |
7563 | } ## end if ($opt_needs_val{$option... | |
69893cff RGS |
7564 | |
7565 | # Save the option value. | |
e22ea7cc | 7566 | $option{$option} = $val if defined $val; |
69893cff RGS |
7567 | |
7568 | # Load any module that this option requires. | |
c5c03c9a SF |
7569 | if ( defined($optionRequire{$option}) && defined($val) ) { |
7570 | eval qq{ | |
7571 | local \$frame = 0; | |
7572 | local \$doret = -2; | |
7573 | require '$optionRequire{$option}'; | |
7574 | 1; | |
7575 | } || die $@ # XXX: shouldn't happen | |
7576 | } | |
e22ea7cc RF |
7577 | |
7578 | # Set it. | |
69893cff | 7579 | # Stick it in the proper variable if it goes in a variable. |
c5c03c9a SF |
7580 | if (defined($optionVars{$option}) && defined($val)) { |
7581 | ${ $optionVars{$option} } = $val; | |
7582 | } | |
69893cff RGS |
7583 | |
7584 | # Call the appropriate sub if it gets set via sub. | |
c5c03c9a SF |
7585 | if (defined($optionAction{$option}) |
7586 | && defined (&{ $optionAction{$option} }) | |
7587 | && defined ($val)) | |
7588 | { | |
7589 | &{ $optionAction{$option} }($val); | |
7590 | } | |
d12a4851 | 7591 | |
69893cff | 7592 | # Not initialization - echo the value we set it to. |
c5c03c9a | 7593 | dump_option($option) if ($OUT ne \*STDERR); |
69893cff RGS |
7594 | } ## end while (length) |
7595 | } ## end sub parse_options | |
7596 | ||
7597 | =head1 RESTART SUPPORT | |
7598 | ||
b570d64b | 7599 | These routines are used to store (and restore) lists of items in environment |
69893cff RGS |
7600 | variables during a restart. |
7601 | ||
7602 | =head2 set_list | |
7603 | ||
7604 | Set_list packages up items to be stored in a set of environment variables | |
7605 | (VAR_n, containing the number of items, and VAR_0, VAR_1, etc., containing | |
7606 | the values). Values outside the standard ASCII charset are stored by encoding | |
18391b26 | 7607 | them as hexadecimal values. |
69893cff RGS |
7608 | |
7609 | =cut | |
eda6e075 | 7610 | |
d12a4851 | 7611 | sub set_list { |
e22ea7cc RF |
7612 | my ( $stem, @list ) = @_; |
7613 | my $val; | |
69893cff RGS |
7614 | |
7615 | # VAR_n: how many we have. Scalar assignment gets the number of items. | |
e22ea7cc | 7616 | $ENV{"${stem}_n"} = @list; |
69893cff RGS |
7617 | |
7618 | # Grab each item in the list, escape the backslashes, encode the non-ASCII | |
7619 | # as hex, and then save in the appropriate VAR_0, VAR_1, etc. | |
6b24a4b7 | 7620 | for my $i ( 0 .. $#list ) { |
e22ea7cc RF |
7621 | $val = $list[$i]; |
7622 | $val =~ s/\\/\\\\/g; | |
7d4d3e29 KW |
7623 | no warnings 'experimental::regex_sets'; |
7624 | $val =~ s/ ( (?[ [\000-\xFF] & [:^print:] ]) ) / | |
7625 | "\\0x" . unpack('H2',$1)/xaeg; | |
e22ea7cc | 7626 | $ENV{"${stem}_$i"} = $val; |
69893cff RGS |
7627 | } ## end for $i (0 .. $#list) |
7628 | } ## end sub set_list | |
7629 | ||
7630 | =head2 get_list | |
7631 | ||
7632 | Reverse the set_list operation: grab VAR_n to see how many we should be getting | |
7633 | back, and then pull VAR_0, VAR_1. etc. back out. | |
7634 | ||
b570d64b | 7635 | =cut |
eda6e075 | 7636 | |
d12a4851 | 7637 | sub get_list { |
e22ea7cc RF |
7638 | my $stem = shift; |
7639 | my @list; | |
7640 | my $n = delete $ENV{"${stem}_n"}; | |
7641 | my $val; | |
6b24a4b7 | 7642 | for my $i ( 0 .. $n - 1 ) { |
e22ea7cc RF |
7643 | $val = delete $ENV{"${stem}_$i"}; |
7644 | $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge; | |
7645 | push @list, $val; | |
7646 | } | |
7647 | @list; | |
69893cff RGS |
7648 | } ## end sub get_list |
7649 | ||
7650 | =head1 MISCELLANEOUS SIGNAL AND I/O MANAGEMENT | |
7651 | ||
7652 | =head2 catch() | |
7653 | ||
7654 | The C<catch()> subroutine is the essence of fast and low-impact. We simply | |
b570d64b | 7655 | set an already-existing global scalar variable to a constant value. This |
69893cff | 7656 | avoids allocating any memory possibly in the middle of something that will |
3c4b39be | 7657 | get all confused if we do, particularly under I<unsafe signals>. |
69893cff RGS |
7658 | |
7659 | =cut | |
eda6e075 | 7660 | |
d12a4851 JH |
7661 | sub catch { |
7662 | $signal = 1; | |
69893cff | 7663 | return; # Put nothing on the stack - malloc/free land! |
d12a4851 | 7664 | } |
eda6e075 | 7665 | |
69893cff RGS |
7666 | =head2 C<warn()> |
7667 | ||
7668 | C<warn> emits a warning, by joining together its arguments and printing | |
7669 | them, with couple of fillips. | |
7670 | ||
b570d64b SF |
7671 | If the composited message I<doesn't> end with a newline, we automatically |
7672 | add C<$!> and a newline to the end of the message. The subroutine expects $OUT | |
7673 | to be set to the filehandle to be used to output warnings; it makes no | |
69893cff RGS |
7674 | assumptions about what filehandles are available. |
7675 | ||
7676 | =cut | |
7677 | ||
b5679dc0 | 7678 | sub _db_warn { |
e22ea7cc | 7679 | my ($msg) = join( "", @_ ); |
d12a4851 JH |
7680 | $msg .= ": $!\n" unless $msg =~ /\n$/; |
7681 | local $\ = ''; | |
7682 | print $OUT $msg; | |
69893cff RGS |
7683 | } ## end sub warn |
7684 | ||
b5679dc0 SF |
7685 | *warn = \&_db_warn; |
7686 | ||
69893cff RGS |
7687 | =head1 INITIALIZATION TTY SUPPORT |
7688 | ||
7689 | =head2 C<reset_IN_OUT> | |
7690 | ||
7691 | This routine handles restoring the debugger's input and output filehandles | |
b570d64b | 7692 | after we've tried and failed to move them elsewhere. In addition, it assigns |
69893cff RGS |
7693 | the debugger's output filehandle to $LINEINFO if it was already open there. |
7694 | ||
7695 | =cut | |
eda6e075 | 7696 | |
d12a4851 JH |
7697 | sub reset_IN_OUT { |
7698 | my $switch_li = $LINEINFO eq $OUT; | |
69893cff RGS |
7699 | |
7700 | # If there's a term and it's able to get a new tty, try to get one. | |
e22ea7cc RF |
7701 | if ( $term and $term->Features->{newTTY} ) { |
7702 | ( $IN, $OUT ) = ( shift, shift ); | |
7703 | $term->newTTY( $IN, $OUT ); | |
69893cff RGS |
7704 | } |
7705 | ||
7706 | # This term can't get a new tty now. Better luck later. | |
7707 | elsif ($term) { | |
b5679dc0 | 7708 | _db_warn("Too late to set IN/OUT filehandles, enabled on next 'R'!\n"); |
e22ea7cc | 7709 | } |
69893cff RGS |
7710 | |
7711 | # Set the filehndles up as they were. | |
7712 | else { | |
e22ea7cc | 7713 | ( $IN, $OUT ) = ( shift, shift ); |
d12a4851 | 7714 | } |
69893cff RGS |
7715 | |
7716 | # Unbuffer the output filehandle. | |
e0047406 | 7717 | _autoflush($OUT); |
69893cff RGS |
7718 | |
7719 | # Point LINEINFO to the same output filehandle if it was there before. | |
d12a4851 | 7720 | $LINEINFO = $OUT if $switch_li; |
69893cff RGS |
7721 | } ## end sub reset_IN_OUT |
7722 | ||
7723 | =head1 OPTION SUPPORT ROUTINES | |
7724 | ||
b570d64b | 7725 | The following routines are used to process some of the more complicated |
69893cff RGS |
7726 | debugger options. |
7727 | ||
7728 | =head2 C<TTY> | |
7729 | ||
7730 | Sets the input and output filehandles to the specified files or pipes. | |
7731 | If the terminal supports switching, we go ahead and do it. If not, and | |
7732 | there's already a terminal in place, we save the information to take effect | |
7733 | on restart. | |
7734 | ||
7735 | If there's no terminal yet (for instance, during debugger initialization), | |
7736 | we go ahead and set C<$console> and C<$tty> to the file indicated. | |
7737 | ||
7738 | =cut | |
eda6e075 | 7739 | |
d12a4851 | 7740 | sub TTY { |
cd1191f1 | 7741 | |
e22ea7cc RF |
7742 | if ( @_ and $term and $term->Features->{newTTY} ) { |
7743 | ||
69893cff RGS |
7744 | # This terminal supports switching to a new TTY. |
7745 | # Can be a list of two files, or on string containing both names, | |
7746 | # comma-separated. | |
7747 | # XXX Should this perhaps be an assignment from @_? | |
e22ea7cc RF |
7748 | my ( $in, $out ) = shift; |
7749 | if ( $in =~ /,/ ) { | |
7750 | ||
69893cff | 7751 | # Split list apart if supplied. |
e22ea7cc RF |
7752 | ( $in, $out ) = split /,/, $in, 2; |
7753 | } | |
7754 | else { | |
7755 | ||
69893cff | 7756 | # Use the same file for both input and output. |
e22ea7cc RF |
7757 | $out = $in; |
7758 | } | |
69893cff RGS |
7759 | |
7760 | # Open file onto the debugger's filehandles, if you can. | |
1ae6ead9 JL |
7761 | open IN, '<', $in or die "cannot open '$in' for read: $!"; |
7762 | open OUT, '>', $out or die "cannot open '$out' for write: $!"; | |
69893cff RGS |
7763 | |
7764 | # Swap to the new filehandles. | |
e22ea7cc | 7765 | reset_IN_OUT( \*IN, \*OUT ); |
69893cff RGS |
7766 | |
7767 | # Save the setting for later. | |
e22ea7cc | 7768 | return $tty = $in; |
69893cff RGS |
7769 | } ## end if (@_ and $term and $term... |
7770 | ||
7771 | # Terminal doesn't support new TTY, or doesn't support readline. | |
7772 | # Can't do it now, try restarting. | |
b5679dc0 SF |
7773 | if ($term and @_) { |
7774 | _db_warn("Too late to set TTY, enabled on next 'R'!\n"); | |
7775 | } | |
e22ea7cc | 7776 | |
d12a4851 JH |
7777 | # Useful if done through PERLDB_OPTS: |
7778 | $console = $tty = shift if @_; | |
69893cff RGS |
7779 | |
7780 | # Return whatever the TTY is. | |
d12a4851 | 7781 | $tty or $console; |
69893cff RGS |
7782 | } ## end sub TTY |
7783 | ||
7784 | =head2 C<noTTY> | |
7785 | ||
7786 | Sets the C<$notty> global, controlling whether or not the debugger tries to | |
7787 | get a terminal to read from. If called after a terminal is already in place, | |
7788 | we save the value to use it if we're restarted. | |
7789 | ||
7790 | =cut | |
eda6e075 | 7791 | |
d12a4851 JH |
7792 | sub noTTY { |
7793 | if ($term) { | |
b5679dc0 | 7794 | _db_warn("Too late to set noTTY, enabled on next 'R'!\n") if @_; |
d12a4851 JH |
7795 | } |
7796 | $notty = shift if @_; | |
7797 | $notty; | |
69893cff RGS |
7798 | } ## end sub noTTY |
7799 | ||
7800 | =head2 C<ReadLine> | |
7801 | ||
b570d64b | 7802 | Sets the C<$rl> option variable. If 0, we use C<Term::ReadLine::Stub> |
be9a9b1d | 7803 | (essentially, no C<readline> processing on this I<terminal>). Otherwise, we |
69893cff RGS |
7804 | use C<Term::ReadLine>. Can't be changed after a terminal's in place; we save |
7805 | the value in case a restart is done so we can change it then. | |
7806 | ||
7807 | =cut | |
eda6e075 | 7808 | |
d12a4851 JH |
7809 | sub ReadLine { |
7810 | if ($term) { | |
b5679dc0 | 7811 | _db_warn("Too late to set ReadLine, enabled on next 'R'!\n") if @_; |
d12a4851 JH |
7812 | } |
7813 | $rl = shift if @_; | |
7814 | $rl; | |
69893cff RGS |
7815 | } ## end sub ReadLine |
7816 | ||
7817 | =head2 C<RemotePort> | |
7818 | ||
7819 | Sets the port that the debugger will try to connect to when starting up. | |
7820 | If the terminal's already been set up, we can't do it, but we remember the | |
7821 | setting in case the user does a restart. | |
7822 | ||
7823 | =cut | |
eda6e075 | 7824 | |
d12a4851 JH |
7825 | sub RemotePort { |
7826 | if ($term) { | |
b5679dc0 | 7827 | _db_warn("Too late to set RemotePort, enabled on next 'R'!\n") if @_; |
d12a4851 JH |
7828 | } |
7829 | $remoteport = shift if @_; | |
7830 | $remoteport; | |
69893cff RGS |
7831 | } ## end sub RemotePort |
7832 | ||
7833 | =head2 C<tkRunning> | |
7834 | ||
7835 | Checks with the terminal to see if C<Tk> is running, and returns true or | |
7836 | false. Returns false if the current terminal doesn't support C<readline>. | |
7837 | ||
7838 | =cut | |
eda6e075 | 7839 | |
d12a4851 | 7840 | sub tkRunning { |
e22ea7cc | 7841 | if ( ${ $term->Features }{tkRunning} ) { |
d12a4851 | 7842 | return $term->tkRunning(@_); |
e22ea7cc | 7843 | } |
69893cff | 7844 | else { |
e22ea7cc RF |
7845 | local $\ = ''; |
7846 | print $OUT "tkRunning not supported by current ReadLine package.\n"; | |
7847 | 0; | |
d12a4851 | 7848 | } |
69893cff RGS |
7849 | } ## end sub tkRunning |
7850 | ||
7851 | =head2 C<NonStop> | |
7852 | ||
7853 | Sets nonstop mode. If a terminal's already been set up, it's too late; the | |
7854 | debugger remembers the setting in case you restart, though. | |
7855 | ||
7856 | =cut | |
eda6e075 | 7857 | |
d12a4851 JH |
7858 | sub NonStop { |
7859 | if ($term) { | |
b5679dc0 | 7860 | _db_warn("Too late to set up NonStop mode, enabled on next 'R'!\n") |
69893cff | 7861 | if @_; |
d12a4851 JH |
7862 | } |
7863 | $runnonstop = shift if @_; | |
7864 | $runnonstop; | |
69893cff RGS |
7865 | } ## end sub NonStop |
7866 | ||
d12a4851 JH |
7867 | sub DollarCaretP { |
7868 | if ($term) { | |
b5679dc0 | 7869 | _db_warn("Some flag changes could not take effect until next 'R'!\n") |
e22ea7cc | 7870 | if @_; |
d12a4851 JH |
7871 | } |
7872 | $^P = parse_DollarCaretP_flags(shift) if @_; | |
e22ea7cc | 7873 | expand_DollarCaretP_flags($^P); |
d12a4851 | 7874 | } |
eda6e075 | 7875 | |
69893cff RGS |
7876 | =head2 C<pager> |
7877 | ||
7878 | Set up the C<$pager> variable. Adds a pipe to the front unless there's one | |
7879 | there already. | |
7880 | ||
7881 | =cut | |
7882 | ||
d12a4851 JH |
7883 | sub pager { |
7884 | if (@_) { | |
69893cff | 7885 | $pager = shift; |
e22ea7cc | 7886 | $pager = "|" . $pager unless $pager =~ /^(\+?\>|\|)/; |
d12a4851 JH |
7887 | } |
7888 | $pager; | |
69893cff RGS |
7889 | } ## end sub pager |
7890 | ||
7891 | =head2 C<shellBang> | |
7892 | ||
b570d64b | 7893 | Sets the shell escape command, and generates a printable copy to be used |
69893cff RGS |
7894 | in the help. |
7895 | ||
7896 | =cut | |
eda6e075 | 7897 | |
d12a4851 | 7898 | sub shellBang { |
69893cff RGS |
7899 | |
7900 | # If we got an argument, meta-quote it, and add '\b' if it | |
7901 | # ends in a word character. | |
d12a4851 | 7902 | if (@_) { |
69893cff RGS |
7903 | $sh = quotemeta shift; |
7904 | $sh .= "\\b" if $sh =~ /\w$/; | |
d12a4851 | 7905 | } |
69893cff RGS |
7906 | |
7907 | # Generate the printable version for the help: | |
e22ea7cc RF |
7908 | $psh = $sh; # copy it |
7909 | $psh =~ s/\\b$//; # Take off trailing \b if any | |
7910 | $psh =~ s/\\(.)/$1/g; # De-escape | |
7911 | $psh; # return the printable version | |
69893cff RGS |
7912 | } ## end sub shellBang |
7913 | ||
7914 | =head2 C<ornaments> | |
7915 | ||
7916 | If the terminal has its own ornaments, fetch them. Otherwise accept whatever | |
7917 | was passed as the argument. (This means you can't override the terminal's | |
7918 | ornaments.) | |
7919 | ||
b570d64b | 7920 | =cut |
eda6e075 | 7921 | |
d12a4851 | 7922 | sub ornaments { |
e22ea7cc RF |
7923 | if ( defined $term ) { |
7924 | ||
69893cff | 7925 | # We don't want to show warning backtraces, but we do want die() ones. |
cb031de9 SF |
7926 | local $warnLevel = 0; |
7927 | local $dieLevel = 1; | |
69893cff RGS |
7928 | |
7929 | # No ornaments if the terminal doesn't support them. | |
cb031de9 SF |
7930 | if (not $term->Features->{ornaments}) { |
7931 | return ''; | |
7932 | } | |
7933 | ||
7934 | return (eval { $term->ornaments(@_) } || ''); | |
e22ea7cc | 7935 | } |
69893cff RGS |
7936 | |
7937 | # Use what was passed in if we can't determine it ourselves. | |
7938 | else { | |
e22ea7cc | 7939 | $ornaments = shift; |
cb031de9 SF |
7940 | |
7941 | return $ornaments; | |
e22ea7cc | 7942 | } |
cb031de9 | 7943 | |
69893cff RGS |
7944 | } ## end sub ornaments |
7945 | ||
7946 | =head2 C<recallCommand> | |
7947 | ||
7948 | Sets the recall command, and builds a printable version which will appear in | |
7949 | the help text. | |
7950 | ||
7951 | =cut | |
eda6e075 | 7952 | |
d12a4851 | 7953 | sub recallCommand { |
69893cff RGS |
7954 | |
7955 | # If there is input, metaquote it. Add '\b' if it ends with a word | |
7956 | # character. | |
d12a4851 | 7957 | if (@_) { |
69893cff RGS |
7958 | $rc = quotemeta shift; |
7959 | $rc .= "\\b" if $rc =~ /\w$/; | |
d12a4851 | 7960 | } |
69893cff RGS |
7961 | |
7962 | # Build it into a printable version. | |
cb031de9 | 7963 | $prc = $rc; # Copy it |
e22ea7cc RF |
7964 | $prc =~ s/\\b$//; # Remove trailing \b |
7965 | $prc =~ s/\\(.)/$1/g; # Remove escapes | |
cb031de9 | 7966 | return $prc; # Return the printable version |
69893cff RGS |
7967 | } ## end sub recallCommand |
7968 | ||
7969 | =head2 C<LineInfo> - where the line number information goes | |
7970 | ||
7971 | Called with no arguments, returns the file or pipe that line info should go to. | |
7972 | ||
b570d64b SF |
7973 | Called with an argument (a file or a pipe), it opens that onto the |
7974 | C<LINEINFO> filehandle, unbuffers the filehandle, and then returns the | |
69893cff RGS |
7975 | file or pipe again to the caller. |
7976 | ||
7977 | =cut | |
eda6e075 | 7978 | |
d12a4851 | 7979 | sub LineInfo { |
62ba816c SF |
7980 | if (@_) { |
7981 | $lineinfo = shift; | |
69893cff | 7982 | |
62ba816c SF |
7983 | # If this is a valid "thing to be opened for output", tack a |
7984 | # '>' onto the front. | |
7985 | my $stream = ( $lineinfo =~ /^(\+?\>|\|)/ ) ? $lineinfo : ">$lineinfo"; | |
69893cff | 7986 | |
62ba816c SF |
7987 | # If this is a pipe, the stream points to a slave editor. |
7988 | $slave_editor = ( $stream =~ /^\|/ ); | |
69893cff | 7989 | |
d7441b49 | 7990 | my $new_lineinfo_fh; |
62ba816c | 7991 | # Open it up and unbuffer it. |
d7441b49 SF |
7992 | open ($new_lineinfo_fh , $stream ) |
7993 | or _db_warn("Cannot open '$stream' for write"); | |
7994 | $LINEINFO = $new_lineinfo_fh; | |
e0047406 | 7995 | _autoflush($LINEINFO); |
62ba816c | 7996 | } |
69893cff | 7997 | |
62ba816c | 7998 | return $lineinfo; |
69893cff RGS |
7999 | } ## end sub LineInfo |
8000 | ||
8001 | =head1 COMMAND SUPPORT ROUTINES | |
8002 | ||
8003 | These subroutines provide functionality for various commands. | |
8004 | ||
8005 | =head2 C<list_modules> | |
8006 | ||
8007 | For the C<M> command: list modules loaded and their versions. | |
be9a9b1d AT |
8008 | Essentially just runs through the keys in %INC, picks each package's |
8009 | C<$VERSION> variable, gets the file name, and formats the information | |
8010 | for output. | |
69893cff RGS |
8011 | |
8012 | =cut | |
8013 | ||
e22ea7cc RF |
8014 | sub list_modules { # versions |
8015 | my %version; | |
8016 | my $file; | |
eda6e075 | 8017 | |
69893cff RGS |
8018 | # keys are the "as-loaded" name, values are the fully-qualified path |
8019 | # to the file itself. | |
e22ea7cc RF |
8020 | for ( keys %INC ) { |
8021 | $file = $_; # get the module name | |
8022 | s,\.p[lm]$,,i; # remove '.pl' or '.pm' | |
8023 | s,/,::,g; # change '/' to '::' | |
8024 | s/^perl5db$/DB/; # Special case: debugger | |
8025 | # moves to package DB | |
8026 | s/^Term::ReadLine::readline$/readline/; # simplify readline | |
8027 | ||
69893cff RGS |
8028 | # If the package has a $VERSION package global (as all good packages |
8029 | # should!) decode it and save as partial message. | |
f311474d VP |
8030 | my $pkg_version = do { no strict 'refs'; ${ $_ . '::VERSION' } }; |
8031 | if ( defined $pkg_version ) { | |
8032 | $version{$file} = "$pkg_version from "; | |
e22ea7cc | 8033 | } |
69893cff RGS |
8034 | |
8035 | # Finish up the message with the file the package came from. | |
e22ea7cc | 8036 | $version{$file} .= $INC{$file}; |
69893cff RGS |
8037 | } ## end for (keys %INC) |
8038 | ||
8039 | # Hey, dumpit() formats a hash nicely, so why not use it? | |
e22ea7cc | 8040 | dumpit( $OUT, \%version ); |
69893cff RGS |
8041 | } ## end sub list_modules |
8042 | ||
8043 | =head2 C<sethelp()> | |
8044 | ||
8045 | Sets up the monster string used to format and print the help. | |
8046 | ||
8047 | =head3 HELP MESSAGE FORMAT | |
8048 | ||
be9a9b1d AT |
8049 | The help message is a peculiar format unto itself; it mixes C<pod> I<ornaments> |
8050 | (C<< B<> >> C<< I<> >>) with tabs to come up with a format that's fairly | |
69893cff RGS |
8051 | easy to parse and portable, but which still allows the help to be a little |
8052 | nicer than just plain text. | |
8053 | ||
be9a9b1d AT |
8054 | Essentially, you define the command name (usually marked up with C<< B<> >> |
8055 | and C<< I<> >>), followed by a tab, and then the descriptive text, ending in a | |
8056 | newline. The descriptive text can also be marked up in the same way. If you | |
8057 | need to continue the descriptive text to another line, start that line with | |
69893cff RGS |
8058 | just tabs and then enter the marked-up text. |
8059 | ||
0083b479 SF |
8060 | If you are modifying the help text, I<be careful>. The help-string parser is |
8061 | not very sophisticated, and if you don't follow these rules it will mangle the | |
69893cff RGS |
8062 | help beyond hope until you fix the string. |
8063 | ||
8064 | =cut | |
eda6e075 | 8065 | |
6b24a4b7 SF |
8066 | use vars qw($pre580_help); |
8067 | use vars qw($pre580_summary); | |
8068 | ||
d12a4851 | 8069 | sub sethelp { |
69893cff | 8070 | |
d12a4851 JH |
8071 | # XXX: make sure there are tabs between the command and explanation, |
8072 | # or print_help will screw up your formatting if you have | |
8073 | # eeevil ornaments enabled. This is an insane mess. | |
eda6e075 | 8074 | |
d12a4851 | 8075 | $help = " |
0083b479 SF |
8076 | Help is currently only available for the new 5.8 command set. |
8077 | No help is available for the old command set. | |
e22ea7cc | 8078 | We assume you know what you're doing if you switch to it. |
eda6e075 | 8079 | |
69893cff RGS |
8080 | B<T> Stack trace. |
8081 | B<s> [I<expr>] Single step [in I<expr>]. | |
8082 | B<n> [I<expr>] Next, steps over subroutine calls [in I<expr>]. | |
8083 | <B<CR>> Repeat last B<n> or B<s> command. | |
8084 | B<r> Return from current subroutine. | |
8085 | B<c> [I<line>|I<sub>] Continue; optionally inserts a one-time-only breakpoint | |
8086 | at the specified position. | |
8087 | B<l> I<min>B<+>I<incr> List I<incr>+1 lines starting at I<min>. | |
8088 | B<l> I<min>B<->I<max> List lines I<min> through I<max>. | |
8089 | B<l> I<line> List single I<line>. | |
8090 | B<l> I<subname> List first window of lines from subroutine. | |
8091 | B<l> I<\$var> List first window of lines from subroutine referenced by I<\$var>. | |
8092 | B<l> List next window of lines. | |
8093 | B<-> List previous window of lines. | |
8094 | B<v> [I<line>] View window around I<line>. | |
8095 | B<.> Return to the executed line. | |
8096 | B<f> I<filename> Switch to viewing I<filename>. File must be already loaded. | |
8097 | I<filename> may be either the full name of the file, or a regular | |
8098 | expression matching the full file name: | |
8099 | B<f> I</home/me/foo.pl> and B<f> I<oo\\.> may access the same file. | |
8100 | Evals (with saved bodies) are considered to be filenames: | |
8101 | B<f> I<(eval 7)> and B<f> I<eval 7\\b> access the body of the 7th eval | |
8102 | (in the order of execution). | |
8103 | B</>I<pattern>B</> Search forwards for I<pattern>; final B</> is optional. | |
8104 | B<?>I<pattern>B<?> Search backwards for I<pattern>; final B<?> is optional. | |
8105 | B<L> [I<a|b|w>] List actions and or breakpoints and or watch-expressions. | |
8106 | B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>. | |
611272bb PS |
8107 | B<t> [I<n>] Toggle trace mode (to max I<n> levels below current stack depth). |
8108 | B<t> [I<n>] I<expr> Trace through execution of I<expr>. | |
69893cff | 8109 | B<b> Sets breakpoint on current line) |
d12a4851 | 8110 | B<b> [I<line>] [I<condition>] |
69893cff RGS |
8111 | Set breakpoint; I<line> defaults to the current execution line; |
8112 | I<condition> breaks if it evaluates to true, defaults to '1'. | |
d12a4851 | 8113 | B<b> I<subname> [I<condition>] |
69893cff RGS |
8114 | Set breakpoint at first line of subroutine. |
8115 | B<b> I<\$var> Set breakpoint at first line of subroutine referenced by I<\$var>. | |
d12a4851 JH |
8116 | B<b> B<load> I<filename> Set breakpoint on 'require'ing the given file. |
8117 | B<b> B<postpone> I<subname> [I<condition>] | |
0083b479 | 8118 | Set breakpoint at first line of subroutine after |
69893cff | 8119 | it is compiled. |
d12a4851 | 8120 | B<b> B<compile> I<subname> |
69893cff RGS |
8121 | Stop after the subroutine is compiled. |
8122 | B<B> [I<line>] Delete the breakpoint for I<line>. | |
d12a4851 JH |
8123 | B<B> I<*> Delete all breakpoints. |
8124 | B<a> [I<line>] I<command> | |
69893cff RGS |
8125 | Set an action to be done before the I<line> is executed; |
8126 | I<line> defaults to the current execution line. | |
8127 | Sequence is: check for breakpoint/watchpoint, print line | |
8128 | if necessary, do action, prompt user if necessary, | |
8129 | execute line. | |
8130 | B<a> Does nothing | |
8131 | B<A> [I<line>] Delete the action for I<line>. | |
d12a4851 | 8132 | B<A> I<*> Delete all actions. |
69893cff RGS |
8133 | B<w> I<expr> Add a global watch-expression. |
8134 | B<w> Does nothing | |
8135 | B<W> I<expr> Delete a global watch-expression. | |
d12a4851 | 8136 | B<W> I<*> Delete all watch-expressions. |
69893cff RGS |
8137 | B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current). |
8138 | Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps. | |
8139 | B<X> [I<vars>] Same as \"B<V> I<currentpackage> [I<vars>]\". | |
69893cff RGS |
8140 | B<x> I<expr> Evals expression in list context, dumps the result. |
8141 | B<m> I<expr> Evals expression in list context, prints methods callable | |
8142 | on the first element of the result. | |
8143 | B<m> I<class> Prints methods callable via the given class. | |
8144 | B<M> Show versions of loaded modules. | |
e219e2fb | 8145 | B<i> I<class> Prints nested parents of given class. |
2cbb2ee1 RGS |
8146 | B<e> Display current thread id. |
8147 | B<E> Display all thread ids the current one will be identified: <n>. | |
e22ea7cc | 8148 | B<y> [I<n> [I<Vars>]] List lexicals in higher scope <n>. Vars same as B<V>. |
69893cff RGS |
8149 | |
8150 | B<<> ? List Perl commands to run before each prompt. | |
8151 | B<<> I<expr> Define Perl command to run before each prompt. | |
8152 | B<<<> I<expr> Add to the list of Perl commands to run before each prompt. | |
e22ea7cc | 8153 | B<< *> Delete the list of perl commands to run before each prompt. |
69893cff RGS |
8154 | B<>> ? List Perl commands to run after each prompt. |
8155 | B<>> I<expr> Define Perl command to run after each prompt. | |
8156 | B<>>B<>> I<expr> Add to the list of Perl commands to run after each prompt. | |
e22ea7cc | 8157 | B<>>B< *> Delete the list of Perl commands to run after each prompt. |
69893cff RGS |
8158 | B<{> I<db_command> Define debugger command to run before each prompt. |
8159 | B<{> ? List debugger commands to run before each prompt. | |
8160 | B<{{> I<db_command> Add to the list of debugger commands to run before each prompt. | |
8161 | B<{ *> Delete the list of debugger commands to run before each prompt. | |
8162 | B<$prc> I<number> Redo a previous command (default previous command). | |
8163 | B<$prc> I<-number> Redo number'th-to-last command. | |
8164 | B<$prc> I<pattern> Redo last command that started with I<pattern>. | |
8165 | See 'B<O> I<recallCommand>' too. | |
8166 | B<$psh$psh> I<cmd> Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)" | |
e22ea7cc RF |
8167 | . ( |
8168 | $rc eq $sh | |
8169 | ? "" | |
8170 | : " | |
8171 | B<$psh> [I<cmd>] Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." | |
8172 | ) . " | |
69893cff | 8173 | See 'B<O> I<shellBang>' too. |
7fddc82f | 8174 | B<source> I<file> Execute I<file> containing debugger commands (may nest). |
e219e2fb | 8175 | B<save> I<file> Save current debugger session (actual history) to I<file>. |
7fddc82f RF |
8176 | B<rerun> Rerun session to current position. |
8177 | B<rerun> I<n> Rerun session to numbered command. | |
8178 | B<rerun> I<-n> Rerun session to number'th-to-last command. | |
69893cff | 8179 | B<H> I<-number> Display last number commands (default all). |
e22ea7cc | 8180 | B<H> I<*> Delete complete history. |
69893cff RGS |
8181 | B<p> I<expr> Same as \"I<print {DB::OUT} expr>\" in current package. |
8182 | B<|>I<dbcmd> Run debugger command, piping DB::OUT to current pager. | |
98dc9551 | 8183 | B<||>I<dbcmd> Same as B<|>I<dbcmd> but DB::OUT is temporarily select()ed as well. |
69893cff RGS |
8184 | B<\=> [I<alias> I<value>] Define a command alias, or list current aliases. |
8185 | I<command> Execute as a perl statement in current package. | |
8186 | B<R> Pure-man-restart of debugger, some of debugger state | |
8187 | and command-line options may be lost. | |
8188 | Currently the following settings are preserved: | |
0083b479 | 8189 | history, breakpoints and actions, debugger B<O>ptions |
69893cff RGS |
8190 | and the following command-line options: I<-w>, I<-I>, I<-e>. |
8191 | ||
8192 | B<o> [I<opt>] ... Set boolean option to true | |
8193 | B<o> [I<opt>B<?>] Query options | |
0083b479 | 8194 | B<o> [I<opt>B<=>I<val>] [I<opt>=B<\">I<val>B<\">] ... |
5561b870 | 8195 | Set options. Use quotes if spaces in value. |
69893cff RGS |
8196 | I<recallCommand>, I<ShellBang> chars used to recall command or spawn shell; |
8197 | I<pager> program for output of \"|cmd\"; | |
8198 | I<tkRunning> run Tk while prompting (with ReadLine); | |
8199 | I<signalLevel> I<warnLevel> I<dieLevel> level of verbosity; | |
8200 | I<inhibit_exit> Allows stepping off the end of the script. | |
8201 | I<ImmediateStop> Debugger should stop as early as possible. | |
8202 | I<RemotePort> Remote hostname:port for remote debugging | |
d12a4851 | 8203 | The following options affect what happens with B<V>, B<X>, and B<x> commands: |
69893cff RGS |
8204 | I<arrayDepth>, I<hashDepth> print only first N elements ('' for all); |
8205 | I<compactDump>, I<veryCompact> change style of array and hash dump; | |
8206 | I<globPrint> whether to print contents of globs; | |
8207 | I<DumpDBFiles> dump arrays holding debugged files; | |
8208 | I<DumpPackages> dump symbol tables of packages; | |
8209 | I<DumpReused> dump contents of \"reused\" addresses; | |
8210 | I<quote>, I<HighBit>, I<undefPrint> change style of string dump; | |
8211 | I<bareStringify> Do not print the overload-stringified value; | |
d12a4851 | 8212 | Other options include: |
69893cff RGS |
8213 | I<PrintRet> affects printing of return value after B<r> command, |
8214 | I<frame> affects printing messages on subroutine entry/exit. | |
8215 | I<AutoTrace> affects printing messages on possible breaking points. | |
8216 | I<maxTraceLen> gives max length of evals/args listed in stack trace. | |
8217 | I<ornaments> affects screen appearance of the command line. | |
8218 | I<CreateTTY> bits control attempts to create a new TTY on events: | |
8219 | 1: on fork() 2: debugger is started inside debugger | |
8220 | 4: on startup | |
8221 | During startup options are initialized from \$ENV{PERLDB_OPTS}. | |
8222 | You can put additional initialization options I<TTY>, I<noTTY>, | |
8223 | I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use | |
1f874cb6 | 8224 | B<R> after you set them). |
69893cff RGS |
8225 | |
8226 | B<q> or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction. | |
8227 | B<h> Summary of debugger commands. | |
8228 | B<h> [I<db_command>] Get help [on a specific debugger command], enter B<|h> to page. | |
8229 | B<h h> Long help for debugger commands | |
0083b479 | 8230 | B<$doccmd> I<manpage> Runs the external doc viewer B<$doccmd> command on the |
69893cff RGS |
8231 | named Perl I<manpage>, or on B<$doccmd> itself if omitted. |
8232 | Set B<\$DB::doccmd> to change viewer. | |
eda6e075 | 8233 | |
1f874cb6 | 8234 | Type '|h h' for a paged display if this was too hard to read. |
eda6e075 | 8235 | |
e22ea7cc | 8236 | "; # Fix balance of vi % matching: }}}} |
eda6e075 | 8237 | |
d12a4851 JH |
8238 | # note: tabs in the following section are not-so-helpful |
8239 | $summary = <<"END_SUM"; | |
8240 | I<List/search source lines:> I<Control script execution:> | |
8241 | B<l> [I<ln>|I<sub>] List source code B<T> Stack trace | |
8242 | B<-> or B<.> List previous/current line B<s> [I<expr>] Single step [in expr] | |
8243 | B<v> [I<line>] View around line B<n> [I<expr>] Next, steps over subs | |
8244 | B<f> I<filename> View source in file <B<CR>/B<Enter>> Repeat last B<n> or B<s> | |
8245 | B</>I<pattern>B</> B<?>I<patt>B<?> Search forw/backw B<r> Return from subroutine | |
8246 | B<M> Show module versions B<c> [I<ln>|I<sub>] Continue until position | |
8247 | I<Debugger controls:> B<L> List break/watch/actions | |
611272bb | 8248 | B<o> [...] Set debugger options B<t> [I<n>] [I<expr>] Toggle trace [max depth] ][trace expr] |
d12a4851 JH |
8249 | B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I<cmd>] Do pre/post-prompt B<b> [I<ln>|I<event>|I<sub>] [I<cnd>] Set breakpoint |
8250 | B<$prc> [I<N>|I<pat>] Redo a previous command B<B> I<ln|*> Delete a/all breakpoints | |
8251 | B<H> [I<-num>] Display last num commands B<a> [I<ln>] I<cmd> Do cmd before line | |
8252 | B<=> [I<a> I<val>] Define/list an alias B<A> I<ln|*> Delete a/all actions | |
8253 | B<h> [I<db_cmd>] Get help on command B<w> I<expr> Add a watch expression | |
8254 | B<h h> Complete help page B<W> I<expr|*> Delete a/all watch exprs | |
8255 | B<|>[B<|>]I<db_cmd> Send output to pager B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess | |
8256 | B<q> or B<^D> Quit B<R> Attempt a restart | |
8257 | I<Data Examination:> B<expr> Execute perl code, also see: B<s>,B<n>,B<t> I<expr> | |
8258 | B<x>|B<m> I<expr> Evals expr in list context, dumps the result or lists methods. | |
8259 | B<p> I<expr> Print expression (uses script's current package). | |
8260 | B<S> [[B<!>]I<pat>] List subroutine names [not] matching pattern | |
8261 | B<V> [I<Pk> [I<Vars>]] List Variables in Package. Vars can be ~pattern or !pattern. | |
e219e2fb | 8262 | B<X> [I<Vars>] Same as \"B<V> I<current_package> [I<Vars>]\". B<i> I<class> inheritance tree. |
d12a4851 | 8263 | B<y> [I<n> [I<Vars>]] List lexicals in higher scope <n>. Vars same as B<V>. |
2cbb2ee1 | 8264 | B<e> Display thread id B<E> Display all thread ids. |
d12a4851 JH |
8265 | For more help, type B<h> I<cmd_letter>, or run B<$doccmd perldebug> for all docs. |
8266 | END_SUM | |
e22ea7cc | 8267 | |
69893cff RGS |
8268 | # ')}}; # Fix balance of vi % matching |
8269 | ||
8270 | # and this is really numb... | |
8271 | $pre580_help = " | |
8272 | B<T> Stack trace. | |
8273 | B<s> [I<expr>] Single step [in I<expr>]. | |
8274 | B<n> [I<expr>] Next, steps over subroutine calls [in I<expr>]. | |
e22ea7cc | 8275 | B<CR>> Repeat last B<n> or B<s> command. |
69893cff RGS |
8276 | B<r> Return from current subroutine. |
8277 | B<c> [I<line>|I<sub>] Continue; optionally inserts a one-time-only breakpoint | |
8278 | at the specified position. | |
8279 | B<l> I<min>B<+>I<incr> List I<incr>+1 lines starting at I<min>. | |
8280 | B<l> I<min>B<->I<max> List lines I<min> through I<max>. | |
8281 | B<l> I<line> List single I<line>. | |
8282 | B<l> I<subname> List first window of lines from subroutine. | |
8283 | B<l> I<\$var> List first window of lines from subroutine referenced by I<\$var>. | |
8284 | B<l> List next window of lines. | |
8285 | B<-> List previous window of lines. | |
8286 | B<w> [I<line>] List window around I<line>. | |
8287 | B<.> Return to the executed line. | |
8288 | B<f> I<filename> Switch to viewing I<filename>. File must be already loaded. | |
8289 | I<filename> may be either the full name of the file, or a regular | |
8290 | expression matching the full file name: | |
8291 | B<f> I</home/me/foo.pl> and B<f> I<oo\\.> may access the same file. | |
8292 | Evals (with saved bodies) are considered to be filenames: | |
8293 | B<f> I<(eval 7)> and B<f> I<eval 7\\b> access the body of the 7th eval | |
8294 | (in the order of execution). | |
8295 | B</>I<pattern>B</> Search forwards for I<pattern>; final B</> is optional. | |
8296 | B<?>I<pattern>B<?> Search backwards for I<pattern>; final B<?> is optional. | |
8297 | B<L> List all breakpoints and actions. | |
8298 | B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>. | |
611272bb PS |
8299 | B<t> [I<n>] Toggle trace mode (to max I<n> levels below current stack depth) . |
8300 | B<t> [I<n>] I<expr> Trace through execution of I<expr>. | |
d12a4851 | 8301 | B<b> [I<line>] [I<condition>] |
69893cff RGS |
8302 | Set breakpoint; I<line> defaults to the current execution line; |
8303 | I<condition> breaks if it evaluates to true, defaults to '1'. | |
d12a4851 | 8304 | B<b> I<subname> [I<condition>] |
69893cff RGS |
8305 | Set breakpoint at first line of subroutine. |
8306 | B<b> I<\$var> Set breakpoint at first line of subroutine referenced by I<\$var>. | |
1f874cb6 | 8307 | B<b> B<load> I<filename> Set breakpoint on 'require'ing the given file. |
d12a4851 | 8308 | B<b> B<postpone> I<subname> [I<condition>] |
0083b479 | 8309 | Set breakpoint at first line of subroutine after |
69893cff | 8310 | it is compiled. |
d12a4851 | 8311 | B<b> B<compile> I<subname> |
69893cff RGS |
8312 | Stop after the subroutine is compiled. |
8313 | B<d> [I<line>] Delete the breakpoint for I<line>. | |
8314 | B<D> Delete all breakpoints. | |
d12a4851 | 8315 | B<a> [I<line>] I<command> |
69893cff RGS |
8316 | Set an action to be done before the I<line> is executed; |
8317 | I<line> defaults to the current execution line. | |
8318 | Sequence is: check for breakpoint/watchpoint, print line | |
8319 | if necessary, do action, prompt user if necessary, | |
8320 | execute line. | |
8321 | B<a> [I<line>] Delete the action for I<line>. | |
8322 | B<A> Delete all actions. | |
8323 | B<W> I<expr> Add a global watch-expression. | |
8324 | B<W> Delete all watch-expressions. | |
8325 | B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current). | |
8326 | Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps. | |
8327 | B<X> [I<vars>] Same as \"B<V> I<currentpackage> [I<vars>]\". | |
8328 | B<x> I<expr> Evals expression in list context, dumps the result. | |
8329 | B<m> I<expr> Evals expression in list context, prints methods callable | |
8330 | on the first element of the result. | |
8331 | B<m> I<class> Prints methods callable via the given class. | |
8332 | ||
8333 | B<<> ? List Perl commands to run before each prompt. | |
8334 | B<<> I<expr> Define Perl command to run before each prompt. | |
8335 | B<<<> I<expr> Add to the list of Perl commands to run before each prompt. | |
8336 | B<>> ? List Perl commands to run after each prompt. | |
8337 | B<>> I<expr> Define Perl command to run after each prompt. | |
8338 | B<>>B<>> I<expr> Add to the list of Perl commands to run after each prompt. | |
8339 | B<{> I<db_command> Define debugger command to run before each prompt. | |
8340 | B<{> ? List debugger commands to run before each prompt. | |
8341 | B<{{> I<db_command> Add to the list of debugger commands to run before each prompt. | |
8342 | B<$prc> I<number> Redo a previous command (default previous command). | |
8343 | B<$prc> I<-number> Redo number'th-to-last command. | |
8344 | B<$prc> I<pattern> Redo last command that started with I<pattern>. | |
8345 | See 'B<O> I<recallCommand>' too. | |
8346 | B<$psh$psh> I<cmd> Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)" | |
e22ea7cc RF |
8347 | . ( |
8348 | $rc eq $sh | |
8349 | ? "" | |
8350 | : " | |
69893cff | 8351 | B<$psh> [I<cmd>] Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." |
e22ea7cc | 8352 | ) . " |
69893cff RGS |
8353 | See 'B<O> I<shellBang>' too. |
8354 | B<source> I<file> Execute I<file> containing debugger commands (may nest). | |
8355 | B<H> I<-number> Display last number commands (default all). | |
8356 | B<p> I<expr> Same as \"I<print {DB::OUT} expr>\" in current package. | |
8357 | B<|>I<dbcmd> Run debugger command, piping DB::OUT to current pager. | |
8358 | B<||>I<dbcmd> Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well. | |
8359 | B<\=> [I<alias> I<value>] Define a command alias, or list current aliases. | |
8360 | I<command> Execute as a perl statement in current package. | |
8361 | B<v> Show versions of loaded modules. | |
8362 | B<R> Pure-man-restart of debugger, some of debugger state | |
8363 | and command-line options may be lost. | |
8364 | Currently the following settings are preserved: | |
0083b479 | 8365 | history, breakpoints and actions, debugger B<O>ptions |
69893cff RGS |
8366 | and the following command-line options: I<-w>, I<-I>, I<-e>. |
8367 | ||
8368 | B<O> [I<opt>] ... Set boolean option to true | |
8369 | B<O> [I<opt>B<?>] Query options | |
0083b479 | 8370 | B<O> [I<opt>B<=>I<val>] [I<opt>=B<\">I<val>B<\">] ... |
5561b870 | 8371 | Set options. Use quotes if spaces in value. |
69893cff RGS |
8372 | I<recallCommand>, I<ShellBang> chars used to recall command or spawn shell; |
8373 | I<pager> program for output of \"|cmd\"; | |
8374 | I<tkRunning> run Tk while prompting (with ReadLine); | |
8375 | I<signalLevel> I<warnLevel> I<dieLevel> level of verbosity; | |
8376 | I<inhibit_exit> Allows stepping off the end of the script. | |
8377 | I<ImmediateStop> Debugger should stop as early as possible. | |
8378 | I<RemotePort> Remote hostname:port for remote debugging | |
d12a4851 | 8379 | The following options affect what happens with B<V>, B<X>, and B<x> commands: |
69893cff RGS |
8380 | I<arrayDepth>, I<hashDepth> print only first N elements ('' for all); |
8381 | I<compactDump>, I<veryCompact> change style of array and hash dump; | |
8382 | I<globPrint> whether to print contents of globs; | |
8383 | I<DumpDBFiles> dump arrays holding debugged files; | |
8384 | I<DumpPackages> dump symbol tables of packages; | |
8385 | I<DumpReused> dump contents of \"reused\" addresses; | |
8386 | I<quote>, I<HighBit>, I<undefPrint> change style of string dump; | |
8387 | I<bareStringify> Do not print the overload-stringified value; | |
d12a4851 | 8388 | Other options include: |
69893cff RGS |
8389 | I<PrintRet> affects printing of return value after B<r> command, |
8390 | I<frame> affects printing messages on subroutine entry/exit. | |
8391 | I<AutoTrace> affects printing messages on possible breaking points. | |
8392 | I<maxTraceLen> gives max length of evals/args listed in stack trace. | |
8393 | I<ornaments> affects screen appearance of the command line. | |
8394 | I<CreateTTY> bits control attempts to create a new TTY on events: | |
8395 | 1: on fork() 2: debugger is started inside debugger | |
8396 | 4: on startup | |
8397 | During startup options are initialized from \$ENV{PERLDB_OPTS}. | |
8398 | You can put additional initialization options I<TTY>, I<noTTY>, | |
8399 | I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use | |
1f874cb6 | 8400 | B<R> after you set them). |
69893cff RGS |
8401 | |
8402 | B<q> or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction. | |
8403 | B<h> [I<db_command>] Get help [on a specific debugger command], enter B<|h> to page. | |
8404 | B<h h> Summary of debugger commands. | |
b570d64b | 8405 | B<$doccmd> I<manpage> Runs the external doc viewer B<$doccmd> command on the |
69893cff RGS |
8406 | named Perl I<manpage>, or on B<$doccmd> itself if omitted. |
8407 | Set B<\$DB::doccmd> to change viewer. | |
eda6e075 | 8408 | |
1f874cb6 | 8409 | Type '|h' for a paged display if this was too hard to read. |
3a6edaec | 8410 | |
e22ea7cc | 8411 | "; # Fix balance of vi % matching: }}}} |
eda6e075 | 8412 | |
d12a4851 JH |
8413 | # note: tabs in the following section are not-so-helpful |
8414 | $pre580_summary = <<"END_SUM"; | |
8415 | I<List/search source lines:> I<Control script execution:> | |
8416 | B<l> [I<ln>|I<sub>] List source code B<T> Stack trace | |
8417 | B<-> or B<.> List previous/current line B<s> [I<expr>] Single step [in expr] | |
8418 | B<w> [I<line>] List around line B<n> [I<expr>] Next, steps over subs | |
8419 | B<f> I<filename> View source in file <B<CR>/B<Enter>> Repeat last B<n> or B<s> | |
8420 | B</>I<pattern>B</> B<?>I<patt>B<?> Search forw/backw B<r> Return from subroutine | |
8421 | B<v> Show versions of modules B<c> [I<ln>|I<sub>] Continue until position | |
8422 | I<Debugger controls:> B<L> List break/watch/actions | |
8423 | B<O> [...] Set debugger options B<t> [I<expr>] Toggle trace [trace expr] | |
8424 | B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I<cmd>] Do pre/post-prompt B<b> [I<ln>|I<event>|I<sub>] [I<cnd>] Set breakpoint | |
8425 | B<$prc> [I<N>|I<pat>] Redo a previous command B<d> [I<ln>] or B<D> Delete a/all breakpoints | |
8426 | B<H> [I<-num>] Display last num commands B<a> [I<ln>] I<cmd> Do cmd before line | |
8427 | B<=> [I<a> I<val>] Define/list an alias B<W> I<expr> Add a watch expression | |
8428 | B<h> [I<db_cmd>] Get help on command B<A> or B<W> Delete all actions/watch | |
8429 | B<|>[B<|>]I<db_cmd> Send output to pager B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess | |
8430 | B<q> or B<^D> Quit B<R> Attempt a restart | |
8431 | I<Data Examination:> B<expr> Execute perl code, also see: B<s>,B<n>,B<t> I<expr> | |
8432 | B<x>|B<m> I<expr> Evals expr in list context, dumps the result or lists methods. | |
8433 | B<p> I<expr> Print expression (uses script's current package). | |
8434 | B<S> [[B<!>]I<pat>] List subroutine names [not] matching pattern | |
8435 | B<V> [I<Pk> [I<Vars>]] List Variables in Package. Vars can be ~pattern or !pattern. | |
8436 | B<X> [I<Vars>] Same as \"B<V> I<current_package> [I<Vars>]\". | |
8437 | B<y> [I<n> [I<Vars>]] List lexicals in higher scope <n>. Vars same as B<V>. | |
8438 | For more help, type B<h> I<cmd_letter>, or run B<$doccmd perldebug> for all docs. | |
8439 | END_SUM | |
eda6e075 | 8440 | |
e22ea7cc | 8441 | # ')}}; # Fix balance of vi % matching |
69893cff RGS |
8442 | |
8443 | } ## end sub sethelp | |
8444 | ||
8445 | =head2 C<print_help()> | |
8446 | ||
8447 | Most of what C<print_help> does is just text formatting. It finds the | |
8448 | C<B> and C<I> ornaments, cleans them off, and substitutes the proper | |
0083b479 | 8449 | terminal control characters to simulate them (courtesy of |
be9a9b1d | 8450 | C<Term::ReadLine::TermCap>). |
69893cff RGS |
8451 | |
8452 | =cut | |
eda6e075 | 8453 | |
d12a4851 | 8454 | sub print_help { |
ef6abee5 | 8455 | my $help_str = shift; |
eda6e075 | 8456 | |
d12a4851 JH |
8457 | # Restore proper alignment destroyed by eeevil I<> and B<> |
8458 | # ornaments: A pox on both their houses! | |
8459 | # | |
8460 | # A help command will have everything up to and including | |
8461 | # the first tab sequence padded into a field 16 (or if indented 20) | |
8462 | # wide. If it's wider than that, an extra space will be added. | |
e07ae11c | 8463 | $help_str =~ s{ |
e22ea7cc | 8464 | ^ # only matters at start of line |
7d4d3e29 | 8465 | ( \ {4} | \t )* # some subcommands are indented |
e22ea7cc RF |
8466 | ( < ? # so <CR> works |
8467 | [BI] < [^\t\n] + ) # find an eeevil ornament | |
8468 | ( \t+ ) # original separation, discarded | |
0083b479 | 8469 | ( .* ) # this will now start (no earlier) than |
e22ea7cc | 8470 | # column 16 |
d12a4851 | 8471 | } { |
e22ea7cc RF |
8472 | my($leadwhite, $command, $midwhite, $text) = ($1, $2, $3, $4); |
8473 | my $clean = $command; | |
0083b479 | 8474 | $clean =~ s/[BI]<([^>]*)>/$1/g; |
69893cff | 8475 | |
e22ea7cc RF |
8476 | # replace with this whole string: |
8477 | ($leadwhite ? " " x 4 : "") | |
d12a4851 JH |
8478 | . $command |
8479 | . ((" " x (16 + ($leadwhite ? 4 : 0) - length($clean))) || " ") | |
8480 | . $text; | |
eda6e075 | 8481 | |
d12a4851 | 8482 | }mgex; |
eda6e075 | 8483 | |
e07ae11c | 8484 | $help_str =~ s{ # handle bold ornaments |
e22ea7cc | 8485 | B < ( [^>] + | > ) > |
d12a4851 | 8486 | } { |
0083b479 | 8487 | $Term::ReadLine::TermCap::rl_term_set[2] |
e22ea7cc RF |
8488 | . $1 |
8489 | . $Term::ReadLine::TermCap::rl_term_set[3] | |
d12a4851 | 8490 | }gex; |
eda6e075 | 8491 | |
e07ae11c | 8492 | $help_str =~ s{ # handle italic ornaments |
e22ea7cc | 8493 | I < ( [^>] + | > ) > |
d12a4851 | 8494 | } { |
0083b479 | 8495 | $Term::ReadLine::TermCap::rl_term_set[0] |
e22ea7cc RF |
8496 | . $1 |
8497 | . $Term::ReadLine::TermCap::rl_term_set[1] | |
d12a4851 | 8498 | }gex; |
eda6e075 | 8499 | |
d12a4851 | 8500 | local $\ = ''; |
e07ae11c SF |
8501 | print {$OUT} $help_str; |
8502 | ||
8503 | return; | |
69893cff RGS |
8504 | } ## end sub print_help |
8505 | ||
0083b479 | 8506 | =head2 C<fix_less> |
69893cff RGS |
8507 | |
8508 | This routine does a lot of gyrations to be sure that the pager is C<less>. | |
8509 | It checks for C<less> masquerading as C<more> and records the result in | |
d463cf23 | 8510 | C<$fixed_less> so we don't have to go through doing the stats again. |
69893cff RGS |
8511 | |
8512 | =cut | |
eda6e075 | 8513 | |
6b24a4b7 SF |
8514 | use vars qw($fixed_less); |
8515 | ||
b67545dd SF |
8516 | sub _calc_is_less { |
8517 | if ($pager =~ /\bless\b/) | |
8518 | { | |
8519 | return 1; | |
8520 | } | |
8521 | elsif ($pager =~ /\bmore\b/) | |
8522 | { | |
69893cff | 8523 | # Nope, set to more. See what's out there. |
e22ea7cc RF |
8524 | my @st_more = stat('/usr/bin/more'); |
8525 | my @st_less = stat('/usr/bin/less'); | |
69893cff RGS |
8526 | |
8527 | # is it really less, pretending to be more? | |
b67545dd SF |
8528 | return ( |
8529 | @st_more | |
8530 | && @st_less | |
8531 | && $st_more[0] == $st_less[0] | |
8532 | && $st_more[1] == $st_less[1] | |
8533 | ); | |
8534 | } | |
8535 | else { | |
8536 | return; | |
8537 | } | |
8538 | } | |
8539 | ||
8540 | sub fix_less { | |
8541 | ||
8542 | # We already know if this is set. | |
8543 | return if $fixed_less; | |
e22ea7cc | 8544 | |
d12a4851 | 8545 | # changes environment! |
69893cff | 8546 | # 'r' added so we don't do (slow) stats again. |
b67545dd SF |
8547 | $fixed_less = 1 if _calc_is_less(); |
8548 | ||
8549 | return; | |
69893cff RGS |
8550 | } ## end sub fix_less |
8551 | ||
8552 | =head1 DIE AND WARN MANAGEMENT | |
8553 | ||
8554 | =head2 C<diesignal> | |
8555 | ||
8556 | C<diesignal> is a just-drop-dead C<die> handler. It's most useful when trying | |
8557 | to debug a debugger problem. | |
8558 | ||
8559 | It does its best to report the error that occurred, and then forces the | |
8560 | program, debugger, and everything to die. | |
8561 | ||
8562 | =cut | |
eda6e075 | 8563 | |
d12a4851 | 8564 | sub diesignal { |
e22ea7cc | 8565 | |
69893cff | 8566 | # No entry/exit messages. |
d12a4851 | 8567 | local $frame = 0; |
69893cff RGS |
8568 | |
8569 | # No return value prints. | |
d12a4851 | 8570 | local $doret = -2; |
69893cff RGS |
8571 | |
8572 | # set the abort signal handling to the default (just terminate). | |
d12a4851 | 8573 | $SIG{'ABRT'} = 'DEFAULT'; |
69893cff RGS |
8574 | |
8575 | # If we enter the signal handler recursively, kill myself with an | |
8576 | # abort signal (so we just terminate). | |
d12a4851 | 8577 | kill 'ABRT', $$ if $panic++; |
69893cff RGS |
8578 | |
8579 | # If we can show detailed info, do so. | |
e22ea7cc RF |
8580 | if ( defined &Carp::longmess ) { |
8581 | ||
69893cff | 8582 | # Don't recursively enter the warn handler, since we're carping. |
e22ea7cc | 8583 | local $SIG{__WARN__} = ''; |
69893cff | 8584 | |
e22ea7cc RF |
8585 | # Skip two levels before reporting traceback: we're skipping |
8586 | # mydie and confess. | |
8587 | local $Carp::CarpLevel = 2; # mydie + confess | |
69893cff RGS |
8588 | |
8589 | # Tell us all about it. | |
b5679dc0 | 8590 | _db_warn( Carp::longmess("Signal @_") ); |
d12a4851 | 8591 | } |
69893cff RGS |
8592 | |
8593 | # No Carp. Tell us about the signal as best we can. | |
d12a4851 | 8594 | else { |
69893cff RGS |
8595 | local $\ = ''; |
8596 | print $DB::OUT "Got signal @_\n"; | |
d12a4851 | 8597 | } |
69893cff RGS |
8598 | |
8599 | # Drop dead. | |
d12a4851 | 8600 | kill 'ABRT', $$; |
69893cff RGS |
8601 | } ## end sub diesignal |
8602 | ||
8603 | =head2 C<dbwarn> | |
8604 | ||
8605 | The debugger's own default C<$SIG{__WARN__}> handler. We load C<Carp> to | |
8606 | be able to get a stack trace, and output the warning message vi C<DB::dbwarn()>. | |
8607 | ||
8608 | =cut | |
8609 | ||
e22ea7cc | 8610 | sub dbwarn { |
eda6e075 | 8611 | |
e22ea7cc RF |
8612 | # No entry/exit trace. |
8613 | local $frame = 0; | |
69893cff RGS |
8614 | |
8615 | # No return value printing. | |
e22ea7cc | 8616 | local $doret = -2; |
69893cff RGS |
8617 | |
8618 | # Turn off warn and die handling to prevent recursive entries to this | |
8619 | # routine. | |
e22ea7cc RF |
8620 | local $SIG{__WARN__} = ''; |
8621 | local $SIG{__DIE__} = ''; | |
69893cff RGS |
8622 | |
8623 | # Load Carp if we can. If $^S is false (current thing being compiled isn't | |
8624 | # done yet), we may not be able to do a require. | |
e22ea7cc RF |
8625 | eval { require Carp } |
8626 | if defined $^S; # If error/warning during compilation, | |
8627 | # require may be broken. | |
69893cff RGS |
8628 | |
8629 | # Use the core warn() unless Carp loaded OK. | |
e22ea7cc RF |
8630 | CORE::warn( @_, |
8631 | "\nCannot print stack trace, load with -MCarp option to see stack" ), | |
8632 | return | |
8633 | unless defined &Carp::longmess; | |
69893cff RGS |
8634 | |
8635 | # Save the current values of $single and $trace, and then turn them off. | |
e22ea7cc RF |
8636 | my ( $mysingle, $mytrace ) = ( $single, $trace ); |
8637 | $single = 0; | |
8638 | $trace = 0; | |
69893cff | 8639 | |
e22ea7cc | 8640 | # We can call Carp::longmess without its being "debugged" (which we |
69893cff | 8641 | # don't want - we just want to use it!). Capture this for later. |
e22ea7cc | 8642 | my $mess = Carp::longmess(@_); |
69893cff RGS |
8643 | |
8644 | # Restore $single and $trace to their original values. | |
e22ea7cc | 8645 | ( $single, $trace ) = ( $mysingle, $mytrace ); |
69893cff RGS |
8646 | |
8647 | # Use the debugger's own special way of printing warnings to print | |
8648 | # the stack trace message. | |
b5679dc0 | 8649 | _db_warn($mess); |
69893cff RGS |
8650 | } ## end sub dbwarn |
8651 | ||
8652 | =head2 C<dbdie> | |
8653 | ||
8654 | The debugger's own C<$SIG{__DIE__}> handler. Handles providing a stack trace | |
b570d64b SF |
8655 | by loading C<Carp> and calling C<Carp::longmess()> to get it. We turn off |
8656 | single stepping and tracing during the call to C<Carp::longmess> to avoid | |
69893cff RGS |
8657 | debugging it - we just want to use it. |
8658 | ||
8659 | If C<dieLevel> is zero, we let the program being debugged handle the | |
8660 | exceptions. If it's 1, you get backtraces for any exception. If it's 2, | |
8661 | the debugger takes over all exception handling, printing a backtrace and | |
b570d64b | 8662 | displaying the exception via its C<dbwarn()> routine. |
69893cff RGS |
8663 | |
8664 | =cut | |
8665 | ||
d12a4851 | 8666 | sub dbdie { |
e22ea7cc RF |
8667 | local $frame = 0; |
8668 | local $doret = -2; | |
8669 | local $SIG{__DIE__} = ''; | |
8670 | local $SIG{__WARN__} = ''; | |
e22ea7cc RF |
8671 | if ( $dieLevel > 2 ) { |
8672 | local $SIG{__WARN__} = \&dbwarn; | |
b5679dc0 | 8673 | _db_warn(@_); # Yell no matter what |
e22ea7cc RF |
8674 | return; |
8675 | } | |
8676 | if ( $dieLevel < 2 ) { | |
8677 | die @_ if $^S; # in eval propagate | |
8678 | } | |
69893cff | 8679 | |
98dc9551 | 8680 | # The code used to check $^S to see if compilation of the current thing |
69893cff | 8681 | # hadn't finished. We don't do it anymore, figuring eval is pretty stable. |
e22ea7cc | 8682 | eval { require Carp }; |
d12a4851 | 8683 | |
e22ea7cc RF |
8684 | die( @_, |
8685 | "\nCannot print stack trace, load with -MCarp option to see stack" ) | |
8686 | unless defined &Carp::longmess; | |
d12a4851 | 8687 | |
69893cff RGS |
8688 | # We do not want to debug this chunk (automatic disabling works |
8689 | # inside DB::DB, but not in Carp). Save $single and $trace, turn them off, | |
8690 | # get the stack trace from Carp::longmess (if possible), restore $signal | |
8691 | # and $trace, and then die with the stack trace. | |
e22ea7cc RF |
8692 | my ( $mysingle, $mytrace ) = ( $single, $trace ); |
8693 | $single = 0; | |
8694 | $trace = 0; | |
8695 | my $mess = "@_"; | |
8696 | { | |
8697 | ||
8698 | package Carp; # Do not include us in the list | |
8699 | eval { $mess = Carp::longmess(@_); }; | |
8700 | } | |
8701 | ( $single, $trace ) = ( $mysingle, $mytrace ); | |
8702 | die $mess; | |
69893cff RGS |
8703 | } ## end sub dbdie |
8704 | ||
8705 | =head2 C<warnlevel()> | |
8706 | ||
8707 | Set the C<$DB::warnLevel> variable that stores the value of the | |
8708 | C<warnLevel> option. Calling C<warnLevel()> with a positive value | |
8709 | results in the debugger taking over all warning handlers. Setting | |
8710 | C<warnLevel> to zero leaves any warning handlers set up by the program | |
8711 | being debugged in place. | |
8712 | ||
8713 | =cut | |
eda6e075 | 8714 | |
d12a4851 | 8715 | sub warnLevel { |
e22ea7cc | 8716 | if (@_) { |
6b24a4b7 | 8717 | my $prevwarn = $SIG{__WARN__} unless $warnLevel; |
e22ea7cc RF |
8718 | $warnLevel = shift; |
8719 | if ($warnLevel) { | |
8720 | $SIG{__WARN__} = \&DB::dbwarn; | |
8721 | } | |
8722 | elsif ($prevwarn) { | |
8723 | $SIG{__WARN__} = $prevwarn; | |
ea581a51 TM |
8724 | } else { |
8725 | undef $SIG{__WARN__}; | |
e22ea7cc | 8726 | } |
69893cff | 8727 | } ## end if (@_) |
e22ea7cc | 8728 | $warnLevel; |
69893cff RGS |
8729 | } ## end sub warnLevel |
8730 | ||
8731 | =head2 C<dielevel> | |
8732 | ||
b570d64b | 8733 | Similar to C<warnLevel>. Non-zero values for C<dieLevel> result in the |
69893cff RGS |
8734 | C<DB::dbdie()> function overriding any other C<die()> handler. Setting it to |
8735 | zero lets you use your own C<die()> handler. | |
8736 | ||
8737 | =cut | |
eda6e075 | 8738 | |
d12a4851 | 8739 | sub dieLevel { |
e22ea7cc RF |
8740 | local $\ = ''; |
8741 | if (@_) { | |
6b24a4b7 | 8742 | my $prevdie = $SIG{__DIE__} unless $dieLevel; |
e22ea7cc RF |
8743 | $dieLevel = shift; |
8744 | if ($dieLevel) { | |
8745 | ||
69893cff | 8746 | # Always set it to dbdie() for non-zero values. |
e22ea7cc | 8747 | $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2; |
69893cff | 8748 | |
e22ea7cc RF |
8749 | # No longer exists, so don't try to use it. |
8750 | #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2; | |
69893cff RGS |
8751 | |
8752 | # If we've finished initialization, mention that stack dumps | |
8753 | # are enabled, If dieLevel is 1, we won't stack dump if we die | |
8754 | # in an eval(). | |
e22ea7cc RF |
8755 | print $OUT "Stack dump during die enabled", |
8756 | ( $dieLevel == 1 ? " outside of evals" : "" ), ".\n" | |
8757 | if $I_m_init; | |
69893cff RGS |
8758 | |
8759 | # XXX This is probably obsolete, given that diehard() is gone. | |
e22ea7cc | 8760 | print $OUT "Dump printed too.\n" if $dieLevel > 2; |
69893cff RGS |
8761 | } ## end if ($dieLevel) |
8762 | ||
8763 | # Put the old one back if there was one. | |
e22ea7cc RF |
8764 | elsif ($prevdie) { |
8765 | $SIG{__DIE__} = $prevdie; | |
8766 | print $OUT "Default die handler restored.\n"; | |
ea581a51 TM |
8767 | } else { |
8768 | undef $SIG{__DIE__}; | |
8769 | print $OUT "Die handler removed.\n"; | |
e22ea7cc | 8770 | } |
69893cff | 8771 | } ## end if (@_) |
e22ea7cc | 8772 | $dieLevel; |
69893cff RGS |
8773 | } ## end sub dieLevel |
8774 | ||
8775 | =head2 C<signalLevel> | |
8776 | ||
8777 | Number three in a series: set C<signalLevel> to zero to keep your own | |
b570d64b | 8778 | signal handler for C<SIGSEGV> and/or C<SIGBUS>. Otherwise, the debugger |
69893cff RGS |
8779 | takes over and handles them with C<DB::diesignal()>. |
8780 | ||
8781 | =cut | |
eda6e075 | 8782 | |
d12a4851 | 8783 | sub signalLevel { |
e22ea7cc | 8784 | if (@_) { |
6b24a4b7 SF |
8785 | my $prevsegv = $SIG{SEGV} unless $signalLevel; |
8786 | my $prevbus = $SIG{BUS} unless $signalLevel; | |
e22ea7cc RF |
8787 | $signalLevel = shift; |
8788 | if ($signalLevel) { | |
8789 | $SIG{SEGV} = \&DB::diesignal; | |
8790 | $SIG{BUS} = \&DB::diesignal; | |
8791 | } | |
8792 | else { | |
8793 | $SIG{SEGV} = $prevsegv; | |
8794 | $SIG{BUS} = $prevbus; | |
8795 | } | |
69893cff | 8796 | } ## end if (@_) |
e22ea7cc | 8797 | $signalLevel; |
69893cff RGS |
8798 | } ## end sub signalLevel |
8799 | ||
8800 | =head1 SUBROUTINE DECODING SUPPORT | |
8801 | ||
8802 | These subroutines are used during the C<x> and C<X> commands to try to | |
8803 | produce as much information as possible about a code reference. They use | |
8804 | L<Devel::Peek> to try to find the glob in which this code reference lives | |
8805 | (if it does) - this allows us to actually code references which correspond | |
8806 | to named subroutines (including those aliased via glob assignment). | |
8807 | ||
8808 | =head2 C<CvGV_name()> | |
8809 | ||
be9a9b1d | 8810 | Wrapper for C<CvGV_name_or_bust>; tries to get the name of a reference |
69893cff | 8811 | via that routine. If this fails, return the reference again (when the |
be9a9b1d | 8812 | reference is stringified, it'll come out as C<SOMETHING(0x...)>). |
69893cff RGS |
8813 | |
8814 | =cut | |
eda6e075 | 8815 | |
d12a4851 | 8816 | sub CvGV_name { |
e22ea7cc RF |
8817 | my $in = shift; |
8818 | my $name = CvGV_name_or_bust($in); | |
8819 | defined $name ? $name : $in; | |
d12a4851 | 8820 | } |
eda6e075 | 8821 | |
69893cff RGS |
8822 | =head2 C<CvGV_name_or_bust> I<coderef> |
8823 | ||
8824 | Calls L<Devel::Peek> to try to find the glob the ref lives in; returns | |
8825 | C<undef> if L<Devel::Peek> can't be loaded, or if C<Devel::Peek::CvGV> can't | |
8826 | find a glob for this ref. | |
8827 | ||
be9a9b1d | 8828 | Returns C<< I<package>::I<glob name> >> if the code ref is found in a glob. |
69893cff RGS |
8829 | |
8830 | =cut | |
8831 | ||
6b24a4b7 SF |
8832 | use vars qw($skipCvGV); |
8833 | ||
d12a4851 | 8834 | sub CvGV_name_or_bust { |
e22ea7cc RF |
8835 | my $in = shift; |
8836 | return if $skipCvGV; # Backdoor to avoid problems if XS broken... | |
8837 | return unless ref $in; | |
8838 | $in = \&$in; # Hard reference... | |
8839 | eval { require Devel::Peek; 1 } or return; | |
8840 | my $gv = Devel::Peek::CvGV($in) or return; | |
8841 | *$gv{PACKAGE} . '::' . *$gv{NAME}; | |
69893cff RGS |
8842 | } ## end sub CvGV_name_or_bust |
8843 | ||
8844 | =head2 C<find_sub> | |
8845 | ||
b570d64b | 8846 | A utility routine used in various places; finds the file where a subroutine |
69893cff RGS |
8847 | was defined, and returns that filename and a line-number range. |
8848 | ||
be9a9b1d AT |
8849 | Tries to use C<@sub> first; if it can't find it there, it tries building a |
8850 | reference to the subroutine and uses C<CvGV_name_or_bust> to locate it, | |
8851 | loading it into C<@sub> as a side effect (XXX I think). If it can't find it | |
8852 | this way, it brute-force searches C<%sub>, checking for identical references. | |
69893cff RGS |
8853 | |
8854 | =cut | |
eda6e075 | 8855 | |
4915c7ee SF |
8856 | sub _find_sub_helper { |
8857 | my $subr = shift; | |
8858 | ||
8859 | return unless defined &$subr; | |
8860 | my $name = CvGV_name_or_bust($subr); | |
8861 | my $data; | |
8862 | $data = $sub{$name} if defined $name; | |
8863 | return $data if defined $data; | |
8864 | ||
8865 | # Old stupid way... | |
8866 | $subr = \&$subr; # Hard reference | |
8867 | my $s; | |
8868 | for ( keys %sub ) { | |
8869 | $s = $_, last if $subr eq \&$_; | |
8870 | } | |
8871 | if ($s) | |
8872 | { | |
8873 | return $sub{$s}; | |
8874 | } | |
8875 | else | |
8876 | { | |
8877 | return; | |
8878 | } | |
8879 | ||
8880 | } | |
8881 | ||
d12a4851 | 8882 | sub find_sub { |
e22ea7cc | 8883 | my $subr = shift; |
4915c7ee | 8884 | return ( $sub{$subr} || _find_sub_helper($subr) ); |
69893cff RGS |
8885 | } ## end sub find_sub |
8886 | ||
8887 | =head2 C<methods> | |
8888 | ||
be9a9b1d | 8889 | A subroutine that uses the utility function C<methods_via> to find all the |
b570d64b | 8890 | methods in the class corresponding to the current reference and in |
69893cff RGS |
8891 | C<UNIVERSAL>. |
8892 | ||
8893 | =cut | |
eda6e075 | 8894 | |
6b24a4b7 SF |
8895 | use vars qw(%seen); |
8896 | ||
d12a4851 | 8897 | sub methods { |
69893cff RGS |
8898 | |
8899 | # Figure out the class - either this is the class or it's a reference | |
8900 | # to something blessed into that class. | |
e22ea7cc RF |
8901 | my $class = shift; |
8902 | $class = ref $class if ref $class; | |
69893cff | 8903 | |
e22ea7cc | 8904 | local %seen; |
69893cff RGS |
8905 | |
8906 | # Show the methods that this class has. | |
e22ea7cc RF |
8907 | methods_via( $class, '', 1 ); |
8908 | ||
8909 | # Show the methods that UNIVERSAL has. | |
8910 | methods_via( 'UNIVERSAL', 'UNIVERSAL', 0 ); | |
69893cff RGS |
8911 | } ## end sub methods |
8912 | ||
8913 | =head2 C<methods_via($class, $prefix, $crawl_upward)> | |
8914 | ||
8915 | C<methods_via> does the work of crawling up the C<@ISA> tree and reporting | |
8916 | all the parent class methods. C<$class> is the name of the next class to | |
8917 | try; C<$prefix> is the message prefix, which gets built up as we go up the | |
8918 | C<@ISA> tree to show parentage; C<$crawl_upward> is 1 if we should try to go | |
8919 | higher in the C<@ISA> tree, 0 if we should stop. | |
8920 | ||
8921 | =cut | |
eda6e075 | 8922 | |
d12a4851 | 8923 | sub methods_via { |
e22ea7cc | 8924 | |
69893cff | 8925 | # If we've processed this class already, just quit. |
e22ea7cc RF |
8926 | my $class = shift; |
8927 | return if $seen{$class}++; | |
8928 | ||
8929 | # This is a package that is contributing the methods we're about to print. | |
8930 | my $prefix = shift; | |
8931 | my $prepend = $prefix ? "via $prefix: " : ''; | |
859c7a68 NC |
8932 | my @to_print; |
8933 | ||
8934 | # Extract from all the symbols in this class. | |
6b24a4b7 SF |
8935 | my $class_ref = do { no strict "refs"; \%{$class . '::'} }; |
8936 | while (my ($name, $glob) = each %$class_ref) { | |
2dbd01ad SF |
8937 | # references directly in the symbol table are Proxy Constant |
8938 | # Subroutines, and are by their very nature defined | |
8939 | # Otherwise, check if the thing is a typeglob, and if it is, it decays | |
8940 | # to a subroutine reference, which can be tested by defined. | |
8941 | # $glob might also be the value -1 (from sub foo;) | |
8942 | # or (say) '$$' (from sub foo ($$);) | |
8943 | # \$glob will be SCALAR in both cases. | |
8944 | if ((ref $glob || ($glob && ref \$glob eq 'GLOB' && defined &$glob)) | |
8945 | && !$seen{$name}++) { | |
8946 | push @to_print, "$prepend$name\n"; | |
8947 | } | |
859c7a68 | 8948 | } |
69893cff | 8949 | |
e22ea7cc | 8950 | { |
2dbd01ad SF |
8951 | local $\ = ''; |
8952 | local $, = ''; | |
8953 | print $DB::OUT $_ foreach sort @to_print; | |
859c7a68 | 8954 | } |
69893cff RGS |
8955 | |
8956 | # If the $crawl_upward argument is false, just quit here. | |
e22ea7cc | 8957 | return unless shift; |
69893cff RGS |
8958 | |
8959 | # $crawl_upward true: keep going up the tree. | |
8960 | # Find all the classes this one is a subclass of. | |
6b24a4b7 SF |
8961 | my $class_ISA_ref = do { no strict "refs"; \@{"${class}::ISA"} }; |
8962 | for my $name ( @$class_ISA_ref ) { | |
e22ea7cc | 8963 | |
69893cff | 8964 | # Set up the new prefix. |
e22ea7cc RF |
8965 | $prepend = $prefix ? $prefix . " -> $name" : $name; |
8966 | ||
8967 | # Crawl up the tree and keep trying to crawl up. | |
8968 | methods_via( $name, $prepend, 1 ); | |
8969 | } | |
69893cff RGS |
8970 | } ## end sub methods_via |
8971 | ||
8972 | =head2 C<setman> - figure out which command to use to show documentation | |
eda6e075 | 8973 | |
69893cff RGS |
8974 | Just checks the contents of C<$^O> and sets the C<$doccmd> global accordingly. |
8975 | ||
8976 | =cut | |
8977 | ||
8978 | sub setman { | |
2b894b7a | 8979 | $doccmd = $^O !~ /^(?:MSWin32|VMS|os2|dos|amigaos|riscos|NetWare)\z/s |
e22ea7cc RF |
8980 | ? "man" # O Happy Day! |
8981 | : "perldoc"; # Alas, poor unfortunates | |
69893cff RGS |
8982 | } ## end sub setman |
8983 | ||
8984 | =head2 C<runman> - run the appropriate command to show documentation | |
8985 | ||
8986 | Accepts a man page name; runs the appropriate command to display it (set up | |
f0bb1409 | 8987 | during debugger initialization). Uses C<_db_system()> to avoid mucking up the |
69893cff RGS |
8988 | program's STDIN and STDOUT. |
8989 | ||
8990 | =cut | |
8991 | ||
2a0cf698 SF |
8992 | sub runman { |
8993 | my $page = shift; | |
8994 | unless ($page) { | |
f0bb1409 | 8995 | _db_system("$doccmd $doccmd"); |
2a0cf698 SF |
8996 | return; |
8997 | } | |
8998 | ||
8999 | # this way user can override, like with $doccmd="man -Mwhatever" | |
9000 | # or even just "man " to disable the path check. | |
ae2f328f | 9001 | if ( $doccmd ne 'man' ) { |
f0bb1409 | 9002 | _db_system("$doccmd $page"); |
2a0cf698 SF |
9003 | return; |
9004 | } | |
9005 | ||
9006 | $page = 'perl' if lc($page) eq 'help'; | |
9007 | ||
9008 | require Config; | |
29fd4a04 NC |
9009 | my $man1dir = $Config::Config{man1direxp}; |
9010 | my $man3dir = $Config::Config{man3direxp}; | |
2a0cf698 SF |
9011 | for ( $man1dir, $man3dir ) { s#/[^/]*\z## if /\S/ } |
9012 | my $manpath = ''; | |
9013 | $manpath .= "$man1dir:" if $man1dir =~ /\S/; | |
9014 | $manpath .= "$man3dir:" if $man3dir =~ /\S/ && $man1dir ne $man3dir; | |
9015 | chop $manpath if $manpath; | |
9016 | ||
9017 | # harmless if missing, I figure | |
58219fbd | 9018 | local $ENV{MANPATH} = $manpath if $manpath; |
2a0cf698 SF |
9019 | my $nopathopt = $^O =~ /dunno what goes here/; |
9020 | if ( | |
9021 | CORE::system( | |
9022 | $doccmd, | |
9023 | ||
9024 | # I just *know* there are men without -M | |
9025 | ( ( $manpath && !$nopathopt ) ? ( "-M", $manpath ) : () ), | |
9026 | split ' ', $page | |
9027 | ) | |
9028 | ) | |
9029 | { | |
9030 | unless ( $page =~ /^perl\w/ ) { | |
45827d0e NC |
9031 | # Previously the debugger contained a list which it slurped in, |
9032 | # listing the known "perl" manpages. However, it was out of date, | |
9033 | # with errors both of omission and inclusion. This approach is | |
9034 | # considerably less complex. The failure mode on a butchered | |
9035 | # install is simply that the user has to run man or perldoc | |
9036 | # "manually" with the full manpage name. | |
9037 | ||
9038 | # There is a list of $^O values in installperl to determine whether | |
9039 | # the directory is 'pods' or 'pod'. However, we can avoid tight | |
9040 | # coupling to that by simply checking the "non-standard" 'pods' | |
9041 | # first. | |
9042 | my $pods = "$Config::Config{privlibexp}/pods"; | |
9043 | $pods = "$Config::Config{privlibexp}/pod" | |
9044 | unless -d $pods; | |
9045 | if (-f "$pods/perl$page.pod") { | |
e22ea7cc RF |
9046 | CORE::system( $doccmd, |
9047 | ( ( $manpath && !$nopathopt ) ? ( "-M", $manpath ) : () ), | |
2b3e68fd | 9048 | "perl$page" ); |
2a0cf698 | 9049 | } |
2b3e68fd | 9050 | } |
69893cff | 9051 | } ## end if (CORE::system($doccmd... |
69893cff RGS |
9052 | } ## end sub runman |
9053 | ||
9054 | #use Carp; # This did break, left for debugging | |
9055 | ||
9056 | =head1 DEBUGGER INITIALIZATION - THE SECOND BEGIN BLOCK | |
9057 | ||
9058 | Because of the way the debugger interface to the Perl core is designed, any | |
9059 | debugger package globals that C<DB::sub()> requires have to be defined before | |
9060 | any subroutines can be called. These are defined in the second C<BEGIN> block. | |
9061 | ||
9062 | This block sets things up so that (basically) the world is sane | |
9063 | before the debugger starts executing. We set up various variables that the | |
9064 | debugger has to have set up before the Perl core starts running: | |
9065 | ||
b570d64b | 9066 | =over 4 |
69893cff | 9067 | |
be9a9b1d AT |
9068 | =item * |
9069 | ||
9070 | The debugger's own filehandles (copies of STD and STDOUT for now). | |
9071 | ||
9072 | =item * | |
9073 | ||
9074 | Characters for shell escapes, the recall command, and the history command. | |
69893cff | 9075 | |
be9a9b1d | 9076 | =item * |
69893cff | 9077 | |
be9a9b1d | 9078 | The maximum recursion depth. |
69893cff | 9079 | |
be9a9b1d | 9080 | =item * |
69893cff | 9081 | |
be9a9b1d | 9082 | The size of a C<w> command's window. |
69893cff | 9083 | |
be9a9b1d | 9084 | =item * |
69893cff | 9085 | |
be9a9b1d | 9086 | The before-this-line context to be printed in a C<v> (view a window around this line) command. |
69893cff | 9087 | |
be9a9b1d | 9088 | =item * |
69893cff | 9089 | |
be9a9b1d | 9090 | The fact that we're not in a sub at all right now. |
69893cff | 9091 | |
be9a9b1d | 9092 | =item * |
69893cff | 9093 | |
be9a9b1d AT |
9094 | The default SIGINT handler for the debugger. |
9095 | ||
9096 | =item * | |
9097 | ||
9098 | The appropriate value of the flag in C<$^D> that says the debugger is running | |
9099 | ||
9100 | =item * | |
9101 | ||
9102 | The current debugger recursion level | |
9103 | ||
9104 | =item * | |
9105 | ||
9106 | The list of postponed items and the C<$single> stack (XXX define this) | |
9107 | ||
9108 | =item * | |
9109 | ||
9110 | That we want no return values and no subroutine entry/exit trace. | |
69893cff RGS |
9111 | |
9112 | =back | |
9113 | ||
9114 | =cut | |
eda6e075 | 9115 | |
d12a4851 | 9116 | # The following BEGIN is very handy if debugger goes havoc, debugging debugger? |
eda6e075 | 9117 | |
6b24a4b7 SF |
9118 | use vars qw($db_stop); |
9119 | ||
e22ea7cc RF |
9120 | BEGIN { # This does not compile, alas. (XXX eh?) |
9121 | $IN = \*STDIN; # For bugs before DB::OUT has been opened | |
9122 | $OUT = \*STDERR; # For errors before DB::OUT has been opened | |
69893cff | 9123 | |
e22ea7cc RF |
9124 | # Define characters used by command parsing. |
9125 | $sh = '!'; # Shell escape (does not work) | |
9126 | $rc = ','; # Recall command (does not work) | |
9127 | @hist = ('?'); # Show history (does not work) | |
9128 | @truehist = (); # Can be saved for replay (per session) | |
69893cff | 9129 | |
e22ea7cc | 9130 | # This defines the point at which you get the 'deep recursion' |
69893cff | 9131 | # warning. It MUST be defined or the debugger will not load. |
7aeefbb3 | 9132 | $deep = 1000; |
69893cff | 9133 | |
e22ea7cc | 9134 | # Number of lines around the current one that are shown in the |
69893cff | 9135 | # 'w' command. |
e22ea7cc | 9136 | $window = 10; |
69893cff RGS |
9137 | |
9138 | # How much before-the-current-line context the 'v' command should | |
9139 | # use in calculating the start of the window it will display. | |
e22ea7cc | 9140 | $preview = 3; |
69893cff RGS |
9141 | |
9142 | # We're not in any sub yet, but we need this to be a defined value. | |
e22ea7cc | 9143 | $sub = ''; |
69893cff | 9144 | |
e22ea7cc | 9145 | # Set up the debugger's interrupt handler. It simply sets a flag |
69893cff | 9146 | # ($signal) that DB::DB() will check before each command is executed. |
e22ea7cc | 9147 | $SIG{INT} = \&DB::catch; |
69893cff RGS |
9148 | |
9149 | # The following lines supposedly, if uncommented, allow the debugger to | |
e22ea7cc | 9150 | # debug itself. Perhaps we can try that someday. |
69893cff | 9151 | # This may be enabled to debug debugger: |
e22ea7cc RF |
9152 | #$warnLevel = 1 unless defined $warnLevel; |
9153 | #$dieLevel = 1 unless defined $dieLevel; | |
9154 | #$signalLevel = 1 unless defined $signalLevel; | |
d12a4851 | 9155 | |
69893cff RGS |
9156 | # This is the flag that says "a debugger is running, please call |
9157 | # DB::DB and DB::sub". We will turn it on forcibly before we try to | |
9158 | # execute anything in the user's context, because we always want to | |
9159 | # get control back. | |
e22ea7cc RF |
9160 | $db_stop = 0; # Compiler warning ... |
9161 | $db_stop = 1 << 30; # ... because this is only used in an eval() later. | |
69893cff RGS |
9162 | |
9163 | # This variable records how many levels we're nested in debugging. Used | |
e22ea7cc | 9164 | # Used in the debugger prompt, and in determining whether it's all over or |
69893cff | 9165 | # not. |
e22ea7cc | 9166 | $level = 0; # Level of recursive debugging |
69893cff RGS |
9167 | |
9168 | # "Triggers bug (?) in perl if we postpone this until runtime." | |
9169 | # XXX No details on this yet, or whether we should fix the bug instead | |
e22ea7cc | 9170 | # of work around it. Stay tuned. |
6b24a4b7 | 9171 | @stack = (0); |
69893cff RGS |
9172 | |
9173 | # Used to track the current stack depth using the auto-stacked-variable | |
9174 | # trick. | |
e22ea7cc | 9175 | $stack_depth = 0; # Localized repeatedly; simple way to track $#stack |
69893cff RGS |
9176 | |
9177 | # Don't print return values on exiting a subroutine. | |
e22ea7cc | 9178 | $doret = -2; |
69893cff RGS |
9179 | |
9180 | # No extry/exit tracing. | |
e22ea7cc | 9181 | $frame = 0; |
eda6e075 | 9182 | |
69893cff RGS |
9183 | } ## end BEGIN |
9184 | ||
9185 | BEGIN { $^W = $ini_warn; } # Switch warnings back | |
9186 | ||
9187 | =head1 READLINE SUPPORT - COMPLETION FUNCTION | |
9188 | ||
9189 | =head2 db_complete | |
eda6e075 | 9190 | |
b570d64b | 9191 | C<readline> support - adds command completion to basic C<readline>. |
69893cff RGS |
9192 | |
9193 | Returns a list of possible completions to C<readline> when invoked. C<readline> | |
b570d64b | 9194 | will print the longest common substring following the text already entered. |
69893cff RGS |
9195 | |
9196 | If there is only a single possible completion, C<readline> will use it in full. | |
9197 | ||
b570d64b | 9198 | This code uses C<map> and C<grep> heavily to create lists of possible |
69893cff RGS |
9199 | completion. Think LISP in this section. |
9200 | ||
9201 | =cut | |
eda6e075 | 9202 | |
d12a4851 | 9203 | sub db_complete { |
69893cff RGS |
9204 | |
9205 | # Specific code for b c l V m f O, &blah, $blah, @blah, %blah | |
9206 | # $text is the text to be completed. | |
9207 | # $line is the incoming line typed by the user. | |
9208 | # $start is the start of the text to be completed in the incoming line. | |
e22ea7cc | 9209 | my ( $text, $line, $start ) = @_; |
69893cff RGS |
9210 | |
9211 | # Save the initial text. | |
9212 | # The search pattern is current package, ::, extract the next qualifier | |
9213 | # Prefix and pack are set to undef. | |
e22ea7cc | 9214 | my ( $itext, $search, $prefix, $pack ) = |
ea7bdd87 | 9215 | ( $text, "^\Q${package}::\E([^:]+)\$" ); |
e22ea7cc | 9216 | |
b570d64b | 9217 | =head3 C<b postpone|compile> |
69893cff RGS |
9218 | |
9219 | =over 4 | |
9220 | ||
be9a9b1d AT |
9221 | =item * |
9222 | ||
9223 | Find all the subroutines that might match in this package | |
9224 | ||
9225 | =item * | |
9226 | ||
3c4b39be | 9227 | Add C<postpone>, C<load>, and C<compile> as possibles (we may be completing the keyword itself) |
be9a9b1d AT |
9228 | |
9229 | =item * | |
9230 | ||
9231 | Include all the rest of the subs that are known | |
69893cff | 9232 | |
be9a9b1d | 9233 | =item * |
69893cff | 9234 | |
be9a9b1d | 9235 | C<grep> out the ones that match the text we have so far |
69893cff | 9236 | |
be9a9b1d | 9237 | =item * |
69893cff | 9238 | |
be9a9b1d | 9239 | Return this as the list of possible completions |
69893cff RGS |
9240 | |
9241 | =back | |
9242 | ||
b570d64b | 9243 | =cut |
69893cff | 9244 | |
e22ea7cc RF |
9245 | return sort grep /^\Q$text/, ( keys %sub ), |
9246 | qw(postpone load compile), # subroutines | |
9247 | ( map { /$search/ ? ($1) : () } keys %sub ) | |
9248 | if ( substr $line, 0, $start ) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/; | |
69893cff RGS |
9249 | |
9250 | =head3 C<b load> | |
9251 | ||
be9a9b1d | 9252 | Get all the possible files from C<@INC> as it currently stands and |
69893cff RGS |
9253 | select the ones that match the text so far. |
9254 | ||
9255 | =cut | |
9256 | ||
e22ea7cc RF |
9257 | return sort grep /^\Q$text/, values %INC # files |
9258 | if ( substr $line, 0, $start ) =~ /^\|*b\s+load\s+$/; | |
69893cff RGS |
9259 | |
9260 | =head3 C<V> (list variable) and C<m> (list modules) | |
9261 | ||
9262 | There are two entry points for these commands: | |
9263 | ||
9264 | =head4 Unqualified package names | |
9265 | ||
9266 | Get the top-level packages and grab everything that matches the text | |
9267 | so far. For each match, recursively complete the partial packages to | |
9268 | get all possible matching packages. Return this sorted list. | |
9269 | ||
9270 | =cut | |
9271 | ||
e22ea7cc RF |
9272 | return sort map { ( $_, db_complete( $_ . "::", "V ", 2 ) ) } |
9273 | grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : () } keys %:: # top-packages | |
9274 | if ( substr $line, 0, $start ) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/; | |
69893cff RGS |
9275 | |
9276 | =head4 Qualified package names | |
9277 | ||
9278 | Take a partially-qualified package and find all subpackages for it | |
9279 | by getting all the subpackages for the package so far, matching all | |
b570d64b | 9280 | the subpackages against the text, and discarding all of them which |
69893cff RGS |
9281 | start with 'main::'. Return this list. |
9282 | ||
9283 | =cut | |
9284 | ||
e22ea7cc RF |
9285 | return sort map { ( $_, db_complete( $_ . "::", "V ", 2 ) ) } |
9286 | grep !/^main::/, grep /^\Q$text/, | |
9df8bd1d VP |
9287 | map { /^(.*)::$/ ? ( $prefix . "::$1" ) : () } |
9288 | do { no strict 'refs'; keys %{ $prefix . '::' } } | |
e22ea7cc RF |
9289 | if ( substr $line, 0, $start ) =~ /^\|*[Vm]\s+$/ |
9290 | and $text =~ /^(.*[^:])::?(\w*)$/ | |
9291 | and $prefix = $1; | |
69893cff RGS |
9292 | |
9293 | =head3 C<f> - switch files | |
9294 | ||
9295 | Here, we want to get a fully-qualified filename for the C<f> command. | |
9296 | Possibilities are: | |
9297 | ||
9298 | =over 4 | |
9299 | ||
9300 | =item 1. The original source file itself | |
9301 | ||
9302 | =item 2. A file from C<@INC> | |
9303 | ||
9304 | =item 3. An C<eval> (the debugger gets a C<(eval N)> fake file for each C<eval>). | |
9305 | ||
9306 | =back | |
9307 | ||
9308 | =cut | |
9309 | ||
e22ea7cc RF |
9310 | if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files |
9311 | # We might possibly want to switch to an eval (which has a "filename" | |
9312 | # like '(eval 9)'), so we may need to clean up the completion text | |
9313 | # before proceeding. | |
9314 | $prefix = length($1) - length($text); | |
9315 | $text = $1; | |
69893cff RGS |
9316 | |
9317 | =pod | |
9318 | ||
b570d64b SF |
9319 | Under the debugger, source files are represented as C<_E<lt>/fullpath/to/file> |
9320 | (C<eval>s are C<_E<lt>(eval NNN)>) keys in C<%main::>. We pull all of these | |
9321 | out of C<%main::>, add the initial source file, and extract the ones that | |
69893cff RGS |
9322 | match the completion text so far. |
9323 | ||
9324 | =cut | |
9325 | ||
e22ea7cc RF |
9326 | return sort |
9327 | map { substr $_, 2 + $prefix } grep /^_<\Q$text/, ( keys %main:: ), | |
9328 | $0; | |
69893cff RGS |
9329 | } ## end if ($line =~ /^\|*f\s+(.*)/) |
9330 | ||
9331 | =head3 Subroutine name completion | |
9332 | ||
9333 | We look through all of the defined subs (the keys of C<%sub>) and | |
9334 | return both all the possible matches to the subroutine name plus | |
9335 | all the matches qualified to the current package. | |
9336 | ||
9337 | =cut | |
9338 | ||
e22ea7cc RF |
9339 | if ( ( substr $text, 0, 1 ) eq '&' ) { # subroutines |
9340 | $text = substr $text, 1; | |
9341 | $prefix = "&"; | |
9342 | return sort map "$prefix$_", grep /^\Q$text/, ( keys %sub ), | |
69893cff RGS |
9343 | ( |
9344 | map { /$search/ ? ($1) : () } | |
e22ea7cc RF |
9345 | keys %sub |
9346 | ); | |
69893cff RGS |
9347 | } ## end if ((substr $text, 0, ... |
9348 | ||
9349 | =head3 Scalar, array, and hash completion: partially qualified package | |
9350 | ||
9351 | Much like the above, except we have to do a little more cleanup: | |
9352 | ||
9353 | =cut | |
9354 | ||
e22ea7cc | 9355 | if ( $text =~ /^[\$@%](.*)::(.*)/ ) { # symbols in a package |
69893cff RGS |
9356 | |
9357 | =pod | |
9358 | ||
b570d64b | 9359 | =over 4 |
69893cff | 9360 | |
be9a9b1d AT |
9361 | =item * |
9362 | ||
9363 | Determine the package that the symbol is in. Put it in C<::> (effectively C<main::>) if no package is specified. | |
69893cff RGS |
9364 | |
9365 | =cut | |
9366 | ||
e22ea7cc | 9367 | $pack = ( $1 eq 'main' ? '' : $1 ) . '::'; |
69893cff RGS |
9368 | |
9369 | =pod | |
9370 | ||
be9a9b1d AT |
9371 | =item * |
9372 | ||
9373 | Figure out the prefix vs. what needs completing. | |
69893cff RGS |
9374 | |
9375 | =cut | |
9376 | ||
e22ea7cc RF |
9377 | $prefix = ( substr $text, 0, 1 ) . $1 . '::'; |
9378 | $text = $2; | |
69893cff RGS |
9379 | |
9380 | =pod | |
9381 | ||
be9a9b1d AT |
9382 | =item * |
9383 | ||
9384 | Look through all the symbols in the package. C<grep> out all the possible hashes/arrays/scalars, and then C<grep> the possible matches out of those. C<map> the prefix onto all the possibilities. | |
69893cff RGS |
9385 | |
9386 | =cut | |
9387 | ||
32050a63 SF |
9388 | my @out = do { |
9389 | no strict 'refs'; | |
9390 | map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, | |
9391 | keys %$pack; | |
9392 | }; | |
69893cff RGS |
9393 | |
9394 | =pod | |
9395 | ||
be9a9b1d AT |
9396 | =item * |
9397 | ||
9398 | If there's only one hit, and it's a package qualifier, and it's not equal to the initial text, re-complete it using the symbol we actually found. | |
69893cff RGS |
9399 | |
9400 | =cut | |
9401 | ||
e22ea7cc RF |
9402 | if ( @out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext ) { |
9403 | return db_complete( $out[0], $line, $start ); | |
9404 | } | |
69893cff RGS |
9405 | |
9406 | # Return the list of possibles. | |
e22ea7cc | 9407 | return sort @out; |
69893cff RGS |
9408 | |
9409 | } ## end if ($text =~ /^[\$@%](.*)::(.*)/) | |
9410 | ||
9411 | =pod | |
9412 | ||
9413 | =back | |
9414 | ||
9415 | =head3 Symbol completion: current package or package C<main>. | |
9416 | ||
9417 | =cut | |
9418 | ||
e22ea7cc | 9419 | if ( $text =~ /^[\$@%]/ ) { # symbols (in $package + packages in main) |
69893cff RGS |
9420 | =pod |
9421 | ||
9422 | =over 4 | |
9423 | ||
be9a9b1d AT |
9424 | =item * |
9425 | ||
9426 | If it's C<main>, delete main to just get C<::> leading. | |
69893cff RGS |
9427 | |
9428 | =cut | |
9429 | ||
e22ea7cc | 9430 | $pack = ( $package eq 'main' ? '' : $package ) . '::'; |
69893cff RGS |
9431 | |
9432 | =pod | |
9433 | ||
be9a9b1d AT |
9434 | =item * |
9435 | ||
9436 | We set the prefix to the item's sigil, and trim off the sigil to get the text to be completed. | |
69893cff RGS |
9437 | |
9438 | =cut | |
9439 | ||
e22ea7cc RF |
9440 | $prefix = substr $text, 0, 1; |
9441 | $text = substr $text, 1; | |
69893cff | 9442 | |
d2286278 S |
9443 | my @out; |
9444 | ||
9445 | =pod | |
9446 | ||
9447 | =item * | |
9448 | ||
9449 | We look for the lexical scope above DB::DB and auto-complete lexical variables | |
9450 | if PadWalker could be loaded. | |
9451 | ||
9452 | =cut | |
9453 | ||
db79bf92 TC |
9454 | if (not $text =~ /::/ and eval { |
9455 | local @INC = @INC; | |
9456 | pop @INC if $INC[-1] eq '.'; | |
9457 | require PadWalker } ) { | |
d2286278 S |
9458 | my $level = 1; |
9459 | while (1) { | |
9460 | my @info = caller($level); | |
9461 | $level++; | |
9462 | $level = -1, last | |
9463 | if not @info; | |
9464 | last if $info[3] eq 'DB::DB'; | |
9465 | } | |
9466 | if ($level > 0) { | |
9467 | my $lexicals = PadWalker::peek_my($level); | |
9468 | push @out, grep /^\Q$prefix$text/, keys %$lexicals; | |
9469 | } | |
9470 | } | |
9471 | ||
69893cff RGS |
9472 | =pod |
9473 | ||
be9a9b1d AT |
9474 | =item * |
9475 | ||
9476 | If the package is C<::> (C<main>), create an empty list; if it's something else, create a list of all the packages known. Append whichever list to a list of all the possible symbols in the current package. C<grep> out the matches to the text entered so far, then C<map> the prefix back onto the symbols. | |
69893cff RGS |
9477 | |
9478 | =cut | |
9479 | ||
d2286278 | 9480 | push @out, map "$prefix$_", grep /^\Q$text/, |
c3970b80 | 9481 | ( grep /^_?[a-zA-Z]/, do { no strict 'refs'; keys %$pack } ), |
e22ea7cc | 9482 | ( $pack eq '::' ? () : ( grep /::$/, keys %:: ) ); |
69893cff | 9483 | |
be9a9b1d AT |
9484 | =item * |
9485 | ||
9486 | If there's only one hit, it's a package qualifier, and it's not equal to the initial text, recomplete using this symbol. | |
69893cff RGS |
9487 | |
9488 | =back | |
9489 | ||
9490 | =cut | |
9491 | ||
e22ea7cc RF |
9492 | if ( @out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext ) { |
9493 | return db_complete( $out[0], $line, $start ); | |
9494 | } | |
69893cff RGS |
9495 | |
9496 | # Return the list of possibles. | |
e22ea7cc | 9497 | return sort @out; |
69893cff RGS |
9498 | } ## end if ($text =~ /^[\$@%]/) |
9499 | ||
b570d64b | 9500 | =head3 Options |
69893cff RGS |
9501 | |
9502 | We use C<option_val()> to look up the current value of the option. If there's | |
b570d64b | 9503 | only a single value, we complete the command in such a way that it is a |
69893cff RGS |
9504 | complete command for setting the option in question. If there are multiple |
9505 | possible values, we generate a command consisting of the option plus a trailing | |
9506 | question mark, which, if executed, will list the current value of the option. | |
9507 | ||
9508 | =cut | |
9509 | ||
e22ea7cc RF |
9510 | if ( ( substr $line, 0, $start ) =~ /^\|*[oO]\b.*\s$/ ) |
9511 | { # Options after space | |
9512 | # We look for the text to be matched in the list of possible options, | |
9513 | # and fetch the current value. | |
9514 | my @out = grep /^\Q$text/, @options; | |
9515 | my $val = option_val( $out[0], undef ); | |
69893cff RGS |
9516 | |
9517 | # Set up a 'query option's value' command. | |
e22ea7cc RF |
9518 | my $out = '? '; |
9519 | if ( not defined $val or $val =~ /[\n\r]/ ) { | |
9520 | ||
9521 | # There's really nothing else we can do. | |
9522 | } | |
69893cff RGS |
9523 | |
9524 | # We have a value. Create a proper option-setting command. | |
e22ea7cc RF |
9525 | elsif ( $val =~ /\s/ ) { |
9526 | ||
69893cff | 9527 | # XXX This may be an extraneous variable. |
e22ea7cc | 9528 | my $found; |
69893cff RGS |
9529 | |
9530 | # We'll want to quote the string (because of the embedded | |
9531 | # whtespace), but we want to make sure we don't end up with | |
9532 | # mismatched quote characters. We try several possibilities. | |
6b24a4b7 | 9533 | foreach my $l ( split //, qq/\"\'\#\|/ ) { |
e22ea7cc | 9534 | |
69893cff RGS |
9535 | # If we didn't find this quote character in the value, |
9536 | # quote it using this quote character. | |
e22ea7cc RF |
9537 | $out = "$l$val$l ", last if ( index $val, $l ) == -1; |
9538 | } | |
69893cff RGS |
9539 | } ## end elsif ($val =~ /\s/) |
9540 | ||
9541 | # Don't need any quotes. | |
e22ea7cc RF |
9542 | else { |
9543 | $out = "=$val "; | |
9544 | } | |
69893cff RGS |
9545 | |
9546 | # If there were multiple possible values, return '? ', which | |
9547 | # makes the command into a query command. If there was just one, | |
9548 | # have readline append that. | |
e22ea7cc RF |
9549 | $rl_attribs->{completer_terminator_character} = |
9550 | ( @out == 1 ? $out : '? ' ); | |
69893cff RGS |
9551 | |
9552 | # Return list of possibilities. | |
e22ea7cc | 9553 | return sort @out; |
69893cff RGS |
9554 | } ## end if ((substr $line, 0, ... |
9555 | ||
9556 | =head3 Filename completion | |
9557 | ||
9558 | For entering filenames. We simply call C<readline>'s C<filename_list()> | |
9559 | method with the completion text to get the possible completions. | |
9560 | ||
9561 | =cut | |
9562 | ||
e22ea7cc | 9563 | return $term->filename_list($text); # filenames |
69893cff RGS |
9564 | |
9565 | } ## end sub db_complete | |
9566 | ||
9567 | =head1 MISCELLANEOUS SUPPORT FUNCTIONS | |
9568 | ||
9569 | Functions that possibly ought to be somewhere else. | |
9570 | ||
9571 | =head2 end_report | |
9572 | ||
9573 | Say we're done. | |
9574 | ||
9575 | =cut | |
55497cff | 9576 | |
43aed9ee | 9577 | sub end_report { |
e22ea7cc | 9578 | local $\ = ''; |
1f874cb6 | 9579 | print $OUT "Use 'q' to quit or 'R' to restart. 'h q' for details.\n"; |
43aed9ee | 9580 | } |
4639966b | 9581 | |
69893cff RGS |
9582 | =head2 clean_ENV |
9583 | ||
9584 | If we have $ini_pids, save it in the environment; else remove it from the | |
9585 | environment. Used by the C<R> (restart) command. | |
9586 | ||
9587 | =cut | |
9588 | ||
bf25f2b5 | 9589 | sub clean_ENV { |
e22ea7cc | 9590 | if ( defined($ini_pids) ) { |
bf25f2b5 | 9591 | $ENV{PERLDB_PIDS} = $ini_pids; |
e22ea7cc | 9592 | } |
69893cff | 9593 | else { |
e22ea7cc | 9594 | delete( $ENV{PERLDB_PIDS} ); |
bf25f2b5 | 9595 | } |
69893cff | 9596 | } ## end sub clean_ENV |
06492da6 | 9597 | |
d12a4851 | 9598 | # PERLDBf_... flag names from perl.h |
e22ea7cc RF |
9599 | our ( %DollarCaretP_flags, %DollarCaretP_flags_r ); |
9600 | ||
d12a4851 | 9601 | BEGIN { |
e22ea7cc RF |
9602 | %DollarCaretP_flags = ( |
9603 | PERLDBf_SUB => 0x01, # Debug sub enter/exit | |
9604 | PERLDBf_LINE => 0x02, # Keep line # | |
9605 | PERLDBf_NOOPT => 0x04, # Switch off optimizations | |
9606 | PERLDBf_INTER => 0x08, # Preserve more data | |
9607 | PERLDBf_SUBLINE => 0x10, # Keep subr source lines | |
9608 | PERLDBf_SINGLE => 0x20, # Start with single-step on | |
9609 | PERLDBf_NONAME => 0x40, # For _SUB: no name of the subr | |
9610 | PERLDBf_GOTO => 0x80, # Report goto: call DB::goto | |
9611 | PERLDBf_NAMEEVAL => 0x100, # Informative names for evals | |
9612 | PERLDBf_NAMEANON => 0x200, # Informative names for anon subs | |
b8fcbefe | 9613 | PERLDBf_SAVESRC => 0x400, # Save source lines into @{"_<$filename"} |
584420f0 | 9614 | PERLDB_ALL => 0x33f, # No _NONAME, _GOTO |
d12a4851 | 9615 | ); |
b8fcbefe NC |
9616 | # PERLDBf_LINE also enables the actions of PERLDBf_SAVESRC, so the debugger |
9617 | # doesn't need to set it. It's provided for the benefit of profilers and | |
9618 | # other code analysers. | |
06492da6 | 9619 | |
e22ea7cc | 9620 | %DollarCaretP_flags_r = reverse %DollarCaretP_flags; |
d12a4851 | 9621 | } |
eda6e075 | 9622 | |
d12a4851 | 9623 | sub parse_DollarCaretP_flags { |
e22ea7cc RF |
9624 | my $flags = shift; |
9625 | $flags =~ s/^\s+//; | |
9626 | $flags =~ s/\s+$//; | |
9627 | my $acu = 0; | |
9628 | foreach my $f ( split /\s*\|\s*/, $flags ) { | |
9629 | my $value; | |
9630 | if ( $f =~ /^0x([[:xdigit:]]+)$/ ) { | |
9631 | $value = hex $1; | |
9632 | } | |
9633 | elsif ( $f =~ /^(\d+)$/ ) { | |
9634 | $value = int $1; | |
9635 | } | |
9636 | elsif ( $f =~ /^DEFAULT$/i ) { | |
9637 | $value = $DollarCaretP_flags{PERLDB_ALL}; | |
9638 | } | |
9639 | else { | |
9640 | $f =~ /^(?:PERLDBf_)?(.*)$/i; | |
9641 | $value = $DollarCaretP_flags{ 'PERLDBf_' . uc($1) }; | |
9642 | unless ( defined $value ) { | |
9643 | print $OUT ( | |
9644 | "Unrecognized \$^P flag '$f'!\n", | |
9645 | "Acceptable flags are: " | |
9646 | . join( ', ', sort keys %DollarCaretP_flags ), | |
9647 | ", and hexadecimal and decimal numbers.\n" | |
9648 | ); | |
9649 | return undef; | |
9650 | } | |
9651 | } | |
9652 | $acu |= $value; | |
d12a4851 JH |
9653 | } |
9654 | $acu; | |
9655 | } | |
eda6e075 | 9656 | |
d12a4851 | 9657 | sub expand_DollarCaretP_flags { |
e22ea7cc RF |
9658 | my $DollarCaretP = shift; |
9659 | my @bits = ( | |
9660 | map { | |
9661 | my $n = ( 1 << $_ ); | |
9662 | ( $DollarCaretP & $n ) | |
9663 | ? ( $DollarCaretP_flags_r{$n} | |
9664 | || sprintf( '0x%x', $n ) ) | |
9665 | : () | |
9666 | } 0 .. 31 | |
9667 | ); | |
9668 | return @bits ? join( '|', @bits ) : 0; | |
d12a4851 | 9669 | } |
06492da6 | 9670 | |
be9a9b1d AT |
9671 | =over 4 |
9672 | ||
7fddc82f RF |
9673 | =item rerun |
9674 | ||
9675 | Rerun the current session to: | |
9676 | ||
9677 | rerun current position | |
9678 | ||
9679 | rerun 4 command number 4 | |
9680 | ||
9681 | rerun -4 current command minus 4 (go back 4 steps) | |
9682 | ||
9683 | Whether this always makes sense, in the current context is unknowable, and is | |
98dc9551 | 9684 | in part left as a useful exercise for the reader. This sub returns the |
7fddc82f RF |
9685 | appropriate arguments to rerun the current session. |
9686 | ||
9687 | =cut | |
9688 | ||
9689 | sub rerun { | |
b570d64b | 9690 | my $i = shift; |
7fddc82f RF |
9691 | my @args; |
9692 | pop(@truehist); # strim | |
9693 | unless (defined $truehist[$i]) { | |
9694 | print "Unable to return to non-existent command: $i\n"; | |
9695 | } else { | |
9696 | $#truehist = ($i < 0 ? $#truehist + $i : $i > 0 ? $i : $#truehist); | |
9697 | my @temp = @truehist; # store | |
9698 | push(@DB::typeahead, @truehist); # saved | |
9699 | @truehist = @hist = (); # flush | |
b0b8faca SF |
9700 | @args = restart(); # setup |
9701 | get_list("PERLDB_HIST"); # clean | |
9702 | set_list("PERLDB_HIST", @temp); # reset | |
7fddc82f RF |
9703 | } |
9704 | return @args; | |
9705 | } | |
9706 | ||
9707 | =item restart | |
9708 | ||
9709 | Restarting the debugger is a complex operation that occurs in several phases. | |
9710 | First, we try to reconstruct the command line that was used to invoke Perl | |
9711 | and the debugger. | |
9712 | ||
9713 | =cut | |
9714 | ||
9715 | sub restart { | |
9716 | # I may not be able to resurrect you, but here goes ... | |
9717 | print $OUT | |
9718 | "Warning: some settings and command-line options may be lost!\n"; | |
9719 | my ( @script, @flags, $cl ); | |
9720 | ||
9721 | # If warn was on before, turn it on again. | |
9722 | push @flags, '-w' if $ini_warn; | |
7fddc82f RF |
9723 | |
9724 | # Rebuild the -I flags that were on the initial | |
9725 | # command line. | |
9726 | for (@ini_INC) { | |
9727 | push @flags, '-I', $_; | |
9728 | } | |
9729 | ||
9730 | # Turn on taint if it was on before. | |
9731 | push @flags, '-T' if ${^TAINT}; | |
9732 | ||
9733 | # Arrange for setting the old INC: | |
9734 | # Save the current @init_INC in the environment. | |
9735 | set_list( "PERLDB_INC", @ini_INC ); | |
9736 | ||
9737 | # If this was a perl one-liner, go to the "file" | |
9738 | # corresponding to the one-liner read all the lines | |
9739 | # out of it (except for the first one, which is going | |
9740 | # to be added back on again when 'perl -d' runs: that's | |
9741 | # the 'require perl5db.pl;' line), and add them back on | |
9742 | # to the command line to be executed. | |
9743 | if ( $0 eq '-e' ) { | |
a47c73fc VP |
9744 | my $lines = *{$main::{'_<-e'}}{ARRAY}; |
9745 | for ( 1 .. $#$lines ) { # The first line is PERL5DB | |
9746 | chomp( $cl = $lines->[$_] ); | |
7fddc82f RF |
9747 | push @script, '-e', $cl; |
9748 | } | |
9749 | } ## end if ($0 eq '-e') | |
9750 | ||
9751 | # Otherwise we just reuse the original name we had | |
9752 | # before. | |
9753 | else { | |
9754 | @script = $0; | |
9755 | } | |
9756 | ||
9757 | =pod | |
9758 | ||
9759 | After the command line has been reconstructed, the next step is to save | |
9760 | the debugger's status in environment variables. The C<DB::set_list> routine | |
9761 | is used to save aggregate variables (both hashes and arrays); scalars are | |
9762 | just popped into environment variables directly. | |
9763 | ||
9764 | =cut | |
9765 | ||
9766 | # If the terminal supported history, grab it and | |
9767 | # save that in the environment. | |
9768 | set_list( "PERLDB_HIST", | |
9769 | $term->Features->{getHistory} | |
9770 | ? $term->GetHistory | |
9771 | : @hist ); | |
9772 | ||
9773 | # Find all the files that were visited during this | |
9774 | # session (i.e., the debugger had magic hashes | |
9775 | # corresponding to them) and stick them in the environment. | |
9776 | my @had_breakpoints = keys %had_breakpoints; | |
9777 | set_list( "PERLDB_VISITED", @had_breakpoints ); | |
9778 | ||
9779 | # Save the debugger options we chose. | |
9780 | set_list( "PERLDB_OPT", %option ); | |
9781 | # set_list( "PERLDB_OPT", options2remember() ); | |
9782 | ||
9783 | # Save the break-on-loads. | |
9784 | set_list( "PERLDB_ON_LOAD", %break_on_load ); | |
9785 | ||
b570d64b | 9786 | =pod |
7fddc82f RF |
9787 | |
9788 | The most complex part of this is the saving of all of the breakpoints. They | |
9789 | can live in an awful lot of places, and we have to go through all of them, | |
9790 | find the breakpoints, and then save them in the appropriate environment | |
9791 | variable via C<DB::set_list>. | |
9792 | ||
9793 | =cut | |
9794 | ||
9795 | # Go through all the breakpoints and make sure they're | |
9796 | # still valid. | |
9797 | my @hard; | |
9798 | for ( 0 .. $#had_breakpoints ) { | |
9799 | ||
9800 | # We were in this file. | |
9801 | my $file = $had_breakpoints[$_]; | |
9802 | ||
9803 | # Grab that file's magic line hash. | |
9804 | *dbline = $main::{ '_<' . $file }; | |
9805 | ||
9806 | # Skip out if it doesn't exist, or if the breakpoint | |
9807 | # is in a postponed file (we'll do postponed ones | |
9808 | # later). | |
9809 | next unless %dbline or $postponed_file{$file}; | |
9810 | ||
9811 | # In an eval. This is a little harder, so we'll | |
9812 | # do more processing on that below. | |
9813 | ( push @hard, $file ), next | |
9814 | if $file =~ /^\(\w*eval/; | |
9815 | ||
9816 | # XXX I have no idea what this is doing. Yet. | |
9817 | my @add; | |
9818 | @add = %{ $postponed_file{$file} } | |
9819 | if $postponed_file{$file}; | |
9820 | ||
9821 | # Save the list of all the breakpoints for this file. | |
9822 | set_list( "PERLDB_FILE_$_", %dbline, @add ); | |
bdba49ad SF |
9823 | |
9824 | # Serialize the extra data %breakpoints_data hash. | |
9825 | # That's a bug fix. | |
b570d64b | 9826 | set_list( "PERLDB_FILE_ENABLED_$_", |
bdba49ad SF |
9827 | map { _is_breakpoint_enabled($file, $_) ? 1 : 0 } |
9828 | sort { $a <=> $b } keys(%dbline) | |
9829 | ) | |
7fddc82f RF |
9830 | } ## end for (0 .. $#had_breakpoints) |
9831 | ||
9832 | # The breakpoint was inside an eval. This is a little | |
9833 | # more difficult. XXX and I don't understand it. | |
7ba78092 | 9834 | foreach my $hard_file (@hard) { |
7fddc82f | 9835 | # Get over to the eval in question. |
7ba78092 SF |
9836 | *dbline = $main::{ '_<' . $hard_file }; |
9837 | my $quoted = quotemeta $hard_file; | |
9838 | my %subs; | |
9839 | for my $sub ( keys %sub ) { | |
9840 | if (my ($n1, $n2) = $sub{$sub} =~ /\A$quoted:(\d+)-(\d+)\z/) { | |
9841 | $subs{$sub} = [ $n1, $n2 ]; | |
9842 | } | |
7fddc82f RF |
9843 | } |
9844 | unless (%subs) { | |
7ba78092 SF |
9845 | print {$OUT} |
9846 | "No subroutines in $hard_file, ignoring breakpoints.\n"; | |
7fddc82f RF |
9847 | next; |
9848 | } | |
7ba78092 | 9849 | LINES: foreach my $line ( keys %dbline ) { |
7fddc82f RF |
9850 | |
9851 | # One breakpoint per sub only: | |
7ba78092 SF |
9852 | my ( $offset, $found ); |
9853 | SUBS: foreach my $sub ( keys %subs ) { | |
7fddc82f | 9854 | if ( |
7ba78092 | 9855 | $subs{$sub}->[1] >= $line # Not after the subroutine |
7fddc82f RF |
9856 | and ( |
9857 | not defined $offset # Not caught | |
7ba78092 | 9858 | or $offset < 0 |
7fddc82f | 9859 | ) |
7ba78092 | 9860 | ) |
7fddc82f RF |
9861 | { # or badly caught |
9862 | $found = $sub; | |
9863 | $offset = $line - $subs{$sub}->[0]; | |
7ba78092 SF |
9864 | if ($offset >= 0) { |
9865 | $offset = "+$offset"; | |
9866 | last SUBS; | |
9867 | } | |
7fddc82f RF |
9868 | } ## end if ($subs{$sub}->[1] >=... |
9869 | } ## end for $sub (keys %subs) | |
9870 | if ( defined $offset ) { | |
9871 | $postponed{$found} = | |
7ba78092 | 9872 | "break $offset if $dbline{$line}"; |
7fddc82f RF |
9873 | } |
9874 | else { | |
7ba78092 SF |
9875 | print {$OUT} |
9876 | ("Breakpoint in ${hard_file}:$line ignored:" | |
9877 | . " after all the subroutines.\n"); | |
7fddc82f RF |
9878 | } |
9879 | } ## end for $line (keys %dbline) | |
9880 | } ## end for (@hard) | |
9881 | ||
9882 | # Save the other things that don't need to be | |
9883 | # processed. | |
9884 | set_list( "PERLDB_POSTPONE", %postponed ); | |
9885 | set_list( "PERLDB_PRETYPE", @$pretype ); | |
9886 | set_list( "PERLDB_PRE", @$pre ); | |
9887 | set_list( "PERLDB_POST", @$post ); | |
9888 | set_list( "PERLDB_TYPEAHEAD", @typeahead ); | |
9889 | ||
98dc9551 | 9890 | # We are officially restarting. |
7fddc82f RF |
9891 | $ENV{PERLDB_RESTART} = 1; |
9892 | ||
9893 | # We are junking all child debuggers. | |
9894 | delete $ENV{PERLDB_PIDS}; # Restore ini state | |
9895 | ||
9896 | # Set this back to the initial pid. | |
9897 | $ENV{PERLDB_PIDS} = $ini_pids if defined $ini_pids; | |
9898 | ||
b570d64b | 9899 | =pod |
7fddc82f RF |
9900 | |
9901 | After all the debugger status has been saved, we take the command we built up | |
9902 | and then return it, so we can C<exec()> it. The debugger will spot the | |
9903 | C<PERLDB_RESTART> environment variable and realize it needs to reload its state | |
9904 | from the environment. | |
9905 | ||
9906 | =cut | |
9907 | ||
9908 | # And run Perl again. Add the "-d" flag, all the | |
9909 | # flags we built up, the script (whether a one-liner | |
9910 | # or a file), add on the -emacs flag for a slave editor, | |
b570d64b | 9911 | # and then the old arguments. |
7fddc82f RF |
9912 | |
9913 | return ($^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS); | |
9914 | ||
9915 | }; # end restart | |
9916 | ||
be9a9b1d AT |
9917 | =back |
9918 | ||
69893cff RGS |
9919 | =head1 END PROCESSING - THE C<END> BLOCK |
9920 | ||
b570d64b SF |
9921 | Come here at the very end of processing. We want to go into a |
9922 | loop where we allow the user to enter commands and interact with the | |
9923 | debugger, but we don't want anything else to execute. | |
69893cff RGS |
9924 | |
9925 | First we set the C<$finished> variable, so that some commands that | |
9926 | shouldn't be run after the end of program quit working. | |
9927 | ||
9928 | We then figure out whether we're truly done (as in the user entered a C<q> | |
9929 | command, or we finished execution while running nonstop). If we aren't, | |
9930 | we set C<$single> to 1 (causing the debugger to get control again). | |
9931 | ||
be9a9b1d | 9932 | We then call C<DB::fake::at_exit()>, which returns the C<Use 'q' to quit ...> |
69893cff RGS |
9933 | message and returns control to the debugger. Repeat. |
9934 | ||
9935 | When the user finally enters a C<q> command, C<$fall_off_end> is set to | |
b570d64b | 9936 | 1 and the C<END> block simply exits with C<$single> set to 0 (don't |
69893cff RGS |
9937 | break, run to completion.). |
9938 | ||
9939 | =cut | |
9940 | ||
55497cff | 9941 | END { |
e22ea7cc RF |
9942 | $finished = 1 if $inhibit_exit; # So that some commands may be disabled. |
9943 | $fall_off_end = 1 unless $inhibit_exit; | |
69893cff | 9944 | |
e22ea7cc | 9945 | # Do not stop in at_exit() and destructors on exit: |
5561b870 | 9946 | if ($fall_off_end or $runnonstop) { |
b0b8faca | 9947 | save_hist(); |
5561b870 A |
9948 | } else { |
9949 | $DB::single = 1; | |
9950 | DB::fake::at_exit(); | |
9951 | } | |
69893cff | 9952 | } ## end END |
eda6e075 | 9953 | |
69893cff | 9954 | =head1 PRE-5.8 COMMANDS |
eda6e075 | 9955 | |
b570d64b | 9956 | Some of the commands changed function quite a bit in the 5.8 command |
69893cff RGS |
9957 | realignment, so much so that the old code had to be replaced completely. |
9958 | Because we wanted to retain the option of being able to go back to the | |
9959 | former command set, we moved the old code off to this section. | |
9960 | ||
b570d64b | 9961 | There's an awful lot of duplicated code here. We've duplicated the |
69893cff RGS |
9962 | comments to keep things clear. |
9963 | ||
9964 | =head2 Null command | |
9965 | ||
be9a9b1d | 9966 | Does nothing. Used to I<turn off> commands. |
69893cff RGS |
9967 | |
9968 | =cut | |
492652be RF |
9969 | |
9970 | sub cmd_pre580_null { | |
69893cff RGS |
9971 | |
9972 | # do nothing... | |
492652be RF |
9973 | } |
9974 | ||
69893cff RGS |
9975 | =head2 Old C<a> command. |
9976 | ||
9977 | This version added actions if you supplied them, and deleted them | |
9978 | if you didn't. | |
9979 | ||
9980 | =cut | |
9981 | ||
492652be | 9982 | sub cmd_pre580_a { |
69893cff RGS |
9983 | my $xcmd = shift; |
9984 | my $cmd = shift; | |
9985 | ||
9986 | # Argument supplied. Add the action. | |
e22ea7cc | 9987 | if ( $cmd =~ /^(\d*)\s*(.*)/ ) { |
69893cff RGS |
9988 | |
9989 | # If the line isn't there, use the current line. | |
6b24a4b7 SF |
9990 | my $i = $1 || $line; |
9991 | my $j = $2; | |
69893cff RGS |
9992 | |
9993 | # If there is an action ... | |
e22ea7cc | 9994 | if ( length $j ) { |
69893cff RGS |
9995 | |
9996 | # ... but the line isn't breakable, skip it. | |
e22ea7cc | 9997 | if ( $dbline[$i] == 0 ) { |
69893cff RGS |
9998 | print $OUT "Line $i may not have an action.\n"; |
9999 | } | |
10000 | else { | |
e22ea7cc | 10001 | |
69893cff RGS |
10002 | # ... and the line is breakable: |
10003 | # Mark that there's an action in this file. | |
10004 | $had_breakpoints{$filename} |= 2; | |
10005 | ||
10006 | # Delete any current action. | |
10007 | $dbline{$i} =~ s/\0[^\0]*//; | |
10008 | ||
10009 | # Add the new action, continuing the line as needed. | |
10010 | $dbline{$i} .= "\0" . action($j); | |
10011 | } | |
10012 | } ## end if (length $j) | |
10013 | ||
10014 | # No action supplied. | |
10015 | else { | |
e22ea7cc | 10016 | |
69893cff RGS |
10017 | # Delete the action. |
10018 | $dbline{$i} =~ s/\0[^\0]*//; | |
e22ea7cc RF |
10019 | |
10020 | # Mark as having no break or action if nothing's left. | |
69893cff RGS |
10021 | delete $dbline{$i} if $dbline{$i} eq ''; |
10022 | } | |
10023 | } ## end if ($cmd =~ /^(\d*)\s*(.*)/) | |
10024 | } ## end sub cmd_pre580_a | |
10025 | ||
b570d64b | 10026 | =head2 Old C<b> command |
69893cff RGS |
10027 | |
10028 | Add breakpoints. | |
10029 | ||
10030 | =cut | |
492652be RF |
10031 | |
10032 | sub cmd_pre580_b { | |
e22ea7cc | 10033 | my $xcmd = shift; |
69893cff RGS |
10034 | my $cmd = shift; |
10035 | my $dbline = shift; | |
10036 | ||
10037 | # Break on load. | |
e22ea7cc | 10038 | if ( $cmd =~ /^load\b\s*(.*)/ ) { |
69893cff RGS |
10039 | my $file = $1; |
10040 | $file =~ s/\s+$//; | |
b0b8faca | 10041 | cmd_b_load($file); |
69893cff RGS |
10042 | } |
10043 | ||
10044 | # b compile|postpone <some sub> [<condition>] | |
e22ea7cc | 10045 | # The interpreter actually traps this one for us; we just put the |
69893cff | 10046 | # necessary condition in the %postponed hash. |
e22ea7cc RF |
10047 | elsif ( $cmd =~ /^(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ ) { |
10048 | ||
69893cff RGS |
10049 | # Capture the condition if there is one. Make it true if none. |
10050 | my $cond = length $3 ? $3 : '1'; | |
10051 | ||
10052 | # Save the sub name and set $break to 1 if $1 was 'postpone', 0 | |
10053 | # if it was 'compile'. | |
e22ea7cc | 10054 | my ( $subname, $break ) = ( $2, $1 eq 'postpone' ); |
69893cff RGS |
10055 | |
10056 | # De-Perl4-ify the name - ' separators to ::. | |
10057 | $subname =~ s/\'/::/g; | |
10058 | ||
10059 | # Qualify it into the current package unless it's already qualified. | |
ea7bdd87 | 10060 | $subname = "${package}::" . $subname |
e22ea7cc | 10061 | unless $subname =~ /::/; |
69893cff RGS |
10062 | |
10063 | # Add main if it starts with ::. | |
e22ea7cc | 10064 | $subname = "main" . $subname if substr( $subname, 0, 2 ) eq "::"; |
69893cff RGS |
10065 | |
10066 | # Save the break type for this sub. | |
10067 | $postponed{$subname} = $break ? "break +0 if $cond" : "compile"; | |
10068 | } ## end elsif ($cmd =~ ... | |
e22ea7cc | 10069 | |
69893cff | 10070 | # b <sub name> [<condition>] |
e22ea7cc | 10071 | elsif ( $cmd =~ /^([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/ ) { |
69893cff RGS |
10072 | my $subname = $1; |
10073 | my $cond = length $2 ? $2 : '1'; | |
b0b8faca | 10074 | cmd_b_sub( $subname, $cond ); |
e22ea7cc | 10075 | } |
69893cff | 10076 | # b <line> [<condition>]. |
e22ea7cc | 10077 | elsif ( $cmd =~ /^(\d*)\s*(.*)/ ) { |
69893cff RGS |
10078 | my $i = $1 || $dbline; |
10079 | my $cond = length $2 ? $2 : '1'; | |
b0b8faca | 10080 | cmd_b_line( $i, $cond ); |
69893cff RGS |
10081 | } |
10082 | } ## end sub cmd_pre580_b | |
10083 | ||
10084 | =head2 Old C<D> command. | |
10085 | ||
10086 | Delete all breakpoints unconditionally. | |
10087 | ||
10088 | =cut | |
492652be RF |
10089 | |
10090 | sub cmd_pre580_D { | |
69893cff RGS |
10091 | my $xcmd = shift; |
10092 | my $cmd = shift; | |
e22ea7cc | 10093 | if ( $cmd =~ /^\s*$/ ) { |
69893cff RGS |
10094 | print $OUT "Deleting all breakpoints...\n"; |
10095 | ||
10096 | # %had_breakpoints lists every file that had at least one | |
10097 | # breakpoint in it. | |
10098 | my $file; | |
e22ea7cc RF |
10099 | for $file ( keys %had_breakpoints ) { |
10100 | ||
69893cff | 10101 | # Switch to the desired file temporarily. |
e22ea7cc | 10102 | local *dbline = $main::{ '_<' . $file }; |
69893cff | 10103 | |
55783941 | 10104 | $max = $#dbline; |
69893cff RGS |
10105 | my $was; |
10106 | ||
10107 | # For all lines in this file ... | |
2c247e84 | 10108 | for my $i (1 .. $max) { |
e22ea7cc | 10109 | |
69893cff | 10110 | # If there's a breakpoint or action on this line ... |
e22ea7cc RF |
10111 | if ( defined $dbline{$i} ) { |
10112 | ||
69893cff RGS |
10113 | # ... remove the breakpoint. |
10114 | $dbline{$i} =~ s/^[^\0]+//; | |
e22ea7cc RF |
10115 | if ( $dbline{$i} =~ s/^\0?$// ) { |
10116 | ||
69893cff RGS |
10117 | # Remove the entry altogether if no action is there. |
10118 | delete $dbline{$i}; | |
10119 | } | |
10120 | } ## end if (defined $dbline{$i... | |
2c247e84 | 10121 | } ## end for my $i (1 .. $max) |
69893cff RGS |
10122 | |
10123 | # If, after we turn off the "there were breakpoints in this file" | |
e22ea7cc | 10124 | # bit, the entry in %had_breakpoints for this file is zero, |
69893cff | 10125 | # we should remove this file from the hash. |
e22ea7cc | 10126 | if ( not $had_breakpoints{$file} &= ~1 ) { |
69893cff RGS |
10127 | delete $had_breakpoints{$file}; |
10128 | } | |
10129 | } ## end for $file (keys %had_breakpoints) | |
10130 | ||
10131 | # Kill off all the other breakpoints that are waiting for files that | |
10132 | # haven't been loaded yet. | |
10133 | undef %postponed; | |
10134 | undef %postponed_file; | |
10135 | undef %break_on_load; | |
10136 | } ## end if ($cmd =~ /^\s*$/) | |
10137 | } ## end sub cmd_pre580_D | |
10138 | ||
10139 | =head2 Old C<h> command | |
10140 | ||
b570d64b | 10141 | Print help. Defaults to printing the long-form help; the 5.8 version |
69893cff RGS |
10142 | prints the summary by default. |
10143 | ||
10144 | =cut | |
492652be RF |
10145 | |
10146 | sub cmd_pre580_h { | |
69893cff RGS |
10147 | my $xcmd = shift; |
10148 | my $cmd = shift; | |
10149 | ||
10150 | # Print the *right* help, long format. | |
e22ea7cc | 10151 | if ( $cmd =~ /^\s*$/ ) { |
69893cff RGS |
10152 | print_help($pre580_help); |
10153 | } | |
10154 | ||
e22ea7cc RF |
10155 | # 'h h' - explicitly-requested summary. |
10156 | elsif ( $cmd =~ /^h\s*/ ) { | |
69893cff RGS |
10157 | print_help($pre580_summary); |
10158 | } | |
10159 | ||
10160 | # Find and print a command's help. | |
e22ea7cc RF |
10161 | elsif ( $cmd =~ /^h\s+(\S.*)$/ ) { |
10162 | my $asked = $1; # for proper errmsg | |
10163 | my $qasked = quotemeta($asked); # for searching | |
10164 | # XXX: finds CR but not <CR> | |
10165 | if ( | |
10166 | $pre580_help =~ /^ | |
69893cff RGS |
10167 | <? # Optional '<' |
10168 | (?:[IB]<) # Optional markup | |
10169 | $qasked # The command name | |
e22ea7cc RF |
10170 | /mx |
10171 | ) | |
10172 | { | |
69893cff RGS |
10173 | |
10174 | while ( | |
10175 | $pre580_help =~ /^ | |
10176 | ( # The command help: | |
10177 | <? # Optional '<' | |
10178 | (?:[IB]<) # Optional markup | |
10179 | $qasked # The command name | |
10180 | ([\s\S]*?) # Lines starting with tabs | |
10181 | \n # Final newline | |
10182 | ) | |
e22ea7cc RF |
10183 | (?!\s)/mgx |
10184 | ) # Line not starting with space | |
10185 | # (Next command's help) | |
69893cff RGS |
10186 | { |
10187 | print_help($1); | |
10188 | } | |
10189 | } ## end if ($pre580_help =~ /^<?(?:[IB]<)$qasked/m) | |
10190 | ||
10191 | # Help not found. | |
10192 | else { | |
10193 | print_help("B<$asked> is not a debugger command.\n"); | |
10194 | } | |
10195 | } ## end elsif ($cmd =~ /^h\s+(\S.*)$/) | |
10196 | } ## end sub cmd_pre580_h | |
10197 | ||
10198 | =head2 Old C<W> command | |
10199 | ||
10200 | C<W E<lt>exprE<gt>> adds a watch expression, C<W> deletes them all. | |
10201 | ||
10202 | =cut | |
492652be RF |
10203 | |
10204 | sub cmd_pre580_W { | |
69893cff RGS |
10205 | my $xcmd = shift; |
10206 | my $cmd = shift; | |
10207 | ||
10208 | # Delete all watch expressions. | |
e22ea7cc RF |
10209 | if ( $cmd =~ /^$/ ) { |
10210 | ||
69893cff RGS |
10211 | # No watching is going on. |
10212 | $trace &= ~2; | |
e22ea7cc | 10213 | |
69893cff RGS |
10214 | # Kill all the watch expressions and values. |
10215 | @to_watch = @old_watch = (); | |
10216 | } | |
10217 | ||
10218 | # Add a watch expression. | |
e22ea7cc RF |
10219 | elsif ( $cmd =~ /^(.*)/s ) { |
10220 | ||
69893cff RGS |
10221 | # add it to the list to be watched. |
10222 | push @to_watch, $1; | |
10223 | ||
e22ea7cc | 10224 | # Get the current value of the expression. |
69893cff RGS |
10225 | # Doesn't handle expressions returning list values! |
10226 | $evalarg = $1; | |
e0cd3692 SF |
10227 | # The &-call is here to ascertain the mutability of @_. |
10228 | my ($val) = &DB::eval; | |
e22ea7cc | 10229 | $val = ( defined $val ) ? "'$val'" : 'undef'; |
69893cff RGS |
10230 | |
10231 | # Save it. | |
10232 | push @old_watch, $val; | |
10233 | ||
10234 | # We're watching stuff. | |
10235 | $trace |= 2; | |
10236 | ||
10237 | } ## end elsif ($cmd =~ /^(.*)/s) | |
10238 | } ## end sub cmd_pre580_W | |
10239 | ||
10240 | =head1 PRE-AND-POST-PROMPT COMMANDS AND ACTIONS | |
10241 | ||
b570d64b | 10242 | The debugger used to have a bunch of nearly-identical code to handle |
69893cff | 10243 | the pre-and-post-prompt action commands. C<cmd_pre590_prepost> and |
b570d64b | 10244 | C<cmd_prepost> unify all this into one set of code to handle the |
69893cff RGS |
10245 | appropriate actions. |
10246 | ||
10247 | =head2 C<cmd_pre590_prepost> | |
10248 | ||
10249 | A small wrapper around C<cmd_prepost>; it makes sure that the default doesn't | |
10250 | do something destructive. In pre 5.8 debuggers, the default action was to | |
10251 | delete all the actions. | |
10252 | ||
10253 | =cut | |
492652be | 10254 | |
35408c4e | 10255 | sub cmd_pre590_prepost { |
69893cff RGS |
10256 | my $cmd = shift; |
10257 | my $line = shift || '*'; | |
10258 | my $dbline = shift; | |
35408c4e | 10259 | |
b0b8faca | 10260 | return cmd_prepost( $cmd, $line, $dbline ); |
69893cff | 10261 | } ## end sub cmd_pre590_prepost |
eda6e075 | 10262 | |
69893cff RGS |
10263 | =head2 C<cmd_prepost> |
10264 | ||
be9a9b1d | 10265 | Actually does all the handling for C<E<lt>>, C<E<gt>>, C<{{>, C<{>, etc. |
69893cff RGS |
10266 | Since the lists of actions are all held in arrays that are pointed to by |
10267 | references anyway, all we have to do is pick the right array reference and | |
10268 | then use generic code to all, delete, or list actions. | |
10269 | ||
10270 | =cut | |
10271 | ||
e22ea7cc RF |
10272 | sub cmd_prepost { |
10273 | my $cmd = shift; | |
69893cff RGS |
10274 | |
10275 | # No action supplied defaults to 'list'. | |
e22ea7cc RF |
10276 | my $line = shift || '?'; |
10277 | ||
10278 | # Figure out what to put in the prompt. | |
69893cff RGS |
10279 | my $which = ''; |
10280 | ||
10281 | # Make sure we have some array or another to address later. | |
7e3426ea | 10282 | # This means that if for some reason the tests fail, we won't be |
69893cff | 10283 | # trying to stash actions or delete them from the wrong place. |
e22ea7cc | 10284 | my $aref = []; |
69893cff | 10285 | |
e22ea7cc | 10286 | # < - Perl code to run before prompt. |
69893cff RGS |
10287 | if ( $cmd =~ /^\</o ) { |
10288 | $which = 'pre-perl'; | |
10289 | $aref = $pre; | |
10290 | } | |
10291 | ||
10292 | # > - Perl code to run after prompt. | |
10293 | elsif ( $cmd =~ /^\>/o ) { | |
10294 | $which = 'post-perl'; | |
10295 | $aref = $post; | |
10296 | } | |
10297 | ||
10298 | # { - first check for properly-balanced braces. | |
10299 | elsif ( $cmd =~ /^\{/o ) { | |
10300 | if ( $cmd =~ /^\{.*\}$/o && unbalanced( substr( $cmd, 1 ) ) ) { | |
10301 | print $OUT | |
1f874cb6 | 10302 | "$cmd is now a debugger command\nuse ';$cmd' if you mean Perl code\n"; |
69893cff RGS |
10303 | } |
10304 | ||
10305 | # Properly balanced. Pre-prompt debugger actions. | |
10306 | else { | |
10307 | $which = 'pre-debugger'; | |
10308 | $aref = $pretype; | |
10309 | } | |
10310 | } ## end elsif ( $cmd =~ /^\{/o ) | |
10311 | ||
10312 | # Did we find something that makes sense? | |
10313 | unless ($which) { | |
10314 | print $OUT "Confused by command: $cmd\n"; | |
10315 | } | |
10316 | ||
e22ea7cc | 10317 | # Yes. |
69893cff | 10318 | else { |
e22ea7cc | 10319 | |
69893cff RGS |
10320 | # List actions. |
10321 | if ( $line =~ /^\s*\?\s*$/o ) { | |
10322 | unless (@$aref) { | |
e22ea7cc | 10323 | |
69893cff RGS |
10324 | # Nothing there. Complain. |
10325 | print $OUT "No $which actions.\n"; | |
10326 | } | |
10327 | else { | |
e22ea7cc | 10328 | |
69893cff RGS |
10329 | # List the actions in the selected list. |
10330 | print $OUT "$which commands:\n"; | |
10331 | foreach my $action (@$aref) { | |
10332 | print $OUT "\t$cmd -- $action\n"; | |
10333 | } | |
10334 | } ## end else | |
10335 | } ## end if ( $line =~ /^\s*\?\s*$/o) | |
10336 | ||
10337 | # Might be a delete. | |
10338 | else { | |
10339 | if ( length($cmd) == 1 ) { | |
10340 | if ( $line =~ /^\s*\*\s*$/o ) { | |
e22ea7cc RF |
10341 | |
10342 | # It's a delete. Get rid of the old actions in the | |
69893cff RGS |
10343 | # selected list.. |
10344 | @$aref = (); | |
10345 | print $OUT "All $cmd actions cleared.\n"; | |
10346 | } | |
10347 | else { | |
e22ea7cc | 10348 | |
69893cff RGS |
10349 | # Replace all the actions. (This is a <, >, or {). |
10350 | @$aref = action($line); | |
10351 | } | |
10352 | } ## end if ( length($cmd) == 1) | |
e22ea7cc RF |
10353 | elsif ( length($cmd) == 2 ) { |
10354 | ||
69893cff RGS |
10355 | # Add the action to the line. (This is a <<, >>, or {{). |
10356 | push @$aref, action($line); | |
10357 | } | |
10358 | else { | |
e22ea7cc | 10359 | |
69893cff RGS |
10360 | # <<<, >>>>, {{{{{{ ... something not a command. |
10361 | print $OUT | |
10362 | "Confused by strange length of $which command($cmd)...\n"; | |
10363 | } | |
10364 | } ## end else [ if ( $line =~ /^\s*\?\s*$/o) | |
10365 | } ## end else | |
10366 | } ## end sub cmd_prepost | |
10367 | ||
69893cff RGS |
10368 | =head1 C<DB::fake> |
10369 | ||
10370 | Contains the C<at_exit> routine that the debugger uses to issue the | |
10371 | C<Debugged program terminated ...> message after the program completes. See | |
10372 | the C<END> block documentation for more details. | |
10373 | ||
10374 | =cut | |
35408c4e | 10375 | |
55497cff | 10376 | package DB::fake; |
10377 | ||
10378 | sub at_exit { | |
1f874cb6 | 10379 | "Debugged program terminated. Use 'q' to quit or 'R' to restart."; |
55497cff | 10380 | } |
10381 | ||
69893cff | 10382 | package DB; # Do not trace this 1; below! |
36477c24 | 10383 | |
d338d6fe | 10384 | 1; |
69893cff | 10385 | |
7fddc82f | 10386 |