| 1 | |
| 2 | =head1 NAME |
| 3 | |
| 4 | perl5db.pl - the perl debugger |
| 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 S<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 | See L<perldebug> for an overview of how to use the debugger. |
| 18 | |
| 19 | =head1 GENERAL NOTES |
| 20 | |
| 21 | The debugger can look pretty forbidding to many Perl programmers. There are |
| 22 | a number of reasons for this, many stemming out of the debugger's history. |
| 23 | |
| 24 | When the debugger was first written, Perl didn't have a lot of its nicer |
| 25 | features - no references, no lexical variables, no closures, no object-oriented |
| 26 | programming. So a lot of the things one would normally have done using such |
| 27 | features was done using global variables, globs and the C<local()> operator |
| 28 | in creative ways. |
| 29 | |
| 30 | Some of these have survived into the current debugger; a few of the more |
| 31 | interesting and still-useful idioms are noted in this section, along with notes |
| 32 | on the comments themselves. |
| 33 | |
| 34 | =head2 Why not use more lexicals? |
| 35 | |
| 36 | Experienced Perl programmers will note that the debugger code tends to use |
| 37 | mostly package globals rather than lexically-scoped variables. This is done |
| 38 | to allow a significant amount of control of the debugger from outside the |
| 39 | debugger itself. |
| 40 | |
| 41 | Unfortunately, though the variables are accessible, they're not well |
| 42 | documented, so it's generally been a decision that hasn't made a lot of |
| 43 | difference to most users. Where appropriate, comments have been added to |
| 44 | make variables more accessible and usable, with the understanding that these |
| 45 | I<are> debugger internals, and are therefore subject to change. Future |
| 46 | development should probably attempt to replace the globals with a well-defined |
| 47 | API, but for now, the variables are what we've got. |
| 48 | |
| 49 | =head2 Automated variable stacking via C<local()> |
| 50 | |
| 51 | As you may recall from reading C<perlfunc>, the C<local()> operator makes a |
| 52 | temporary copy of a variable in the current scope. When the scope ends, the |
| 53 | old copy is restored. This is often used in the debugger to handle the |
| 54 | automatic stacking of variables during recursive calls: |
| 55 | |
| 56 | sub foo { |
| 57 | local $some_global++; |
| 58 | |
| 59 | # Do some stuff, then ... |
| 60 | return; |
| 61 | } |
| 62 | |
| 63 | What happens is that on entry to the subroutine, C<$some_global> is localized, |
| 64 | then altered. When the subroutine returns, Perl automatically undoes the |
| 65 | localization, restoring the previous value. Voila, automatic stack management. |
| 66 | |
| 67 | The debugger uses this trick a I<lot>. Of particular note is C<DB::eval>, |
| 68 | which lets the debugger get control inside of C<eval>'ed code. The debugger |
| 69 | localizes a saved copy of C<$@> inside the subroutine, which allows it to |
| 70 | keep C<$@> safe until it C<DB::eval> returns, at which point the previous |
| 71 | value of C<$@> is restored. This makes it simple (well, I<simpler>) to keep |
| 72 | track of C<$@> inside C<eval>s which C<eval> other C<eval's>. |
| 73 | |
| 74 | In any case, watch for this pattern. It occurs fairly often. |
| 75 | |
| 76 | =head2 The C<^> trick |
| 77 | |
| 78 | This is used to cleverly reverse the sense of a logical test depending on |
| 79 | the value of an auxiliary variable. For instance, the debugger's C<S> |
| 80 | (search for subroutines by pattern) allows you to negate the pattern |
| 81 | like this: |
| 82 | |
| 83 | # Find all non-'foo' subs: |
| 84 | S !/foo/ |
| 85 | |
| 86 | Boolean algebra states that the truth table for XOR looks like this: |
| 87 | |
| 88 | =over 4 |
| 89 | |
| 90 | =item * 0 ^ 0 = 0 |
| 91 | |
| 92 | (! not present and no match) --> false, don't print |
| 93 | |
| 94 | =item * 0 ^ 1 = 1 |
| 95 | |
| 96 | (! not present and matches) --> true, print |
| 97 | |
| 98 | =item * 1 ^ 0 = 1 |
| 99 | |
| 100 | (! present and no match) --> true, print |
| 101 | |
| 102 | =item * 1 ^ 1 = 0 |
| 103 | |
| 104 | (! present and matches) --> false, don't print |
| 105 | |
| 106 | =back |
| 107 | |
| 108 | As you can see, the first pair applies when C<!> isn't supplied, and |
| 109 | the second pair applies when it is. The XOR simply allows us to |
| 110 | compact a more complicated if-then-elseif-else into a more elegant |
| 111 | (but perhaps overly clever) single test. After all, it needed this |
| 112 | explanation... |
| 113 | |
| 114 | =head2 FLAGS, FLAGS, FLAGS |
| 115 | |
| 116 | There is a certain C programming legacy in the debugger. Some variables, |
| 117 | such as C<$single>, C<$trace>, and C<$frame>, have I<magical> values composed |
| 118 | of 1, 2, 4, etc. (powers of 2) OR'ed together. This allows several pieces |
| 119 | of state to be stored independently in a single scalar. |
| 120 | |
| 121 | A test like |
| 122 | |
| 123 | if ($scalar & 4) ... |
| 124 | |
| 125 | is checking to see if the appropriate bit is on. Since each bit can be |
| 126 | "addressed" independently in this way, C<$scalar> is acting sort of like |
| 127 | an array of bits. Obviously, since the contents of C<$scalar> are just a |
| 128 | bit-pattern, we can save and restore it easily (it will just look like |
| 129 | a number). |
| 130 | |
| 131 | The problem, is of course, that this tends to leave magic numbers scattered |
| 132 | all over your program whenever a bit is set, cleared, or checked. So why do |
| 133 | it? |
| 134 | |
| 135 | =over 4 |
| 136 | |
| 137 | =item * |
| 138 | |
| 139 | First, doing an arithmetical or bitwise operation on a scalar is |
| 140 | just about the fastest thing you can do in Perl: S<C<use constant>> actually |
| 141 | creates a subroutine call, and array and hash lookups are much slower. Is |
| 142 | this over-optimization at the expense of readability? Possibly, but the |
| 143 | debugger accesses these variables a I<lot>. Any rewrite of the code will |
| 144 | probably have to benchmark alternate implementations and see which is the |
| 145 | best balance of readability and speed, and then document how it actually |
| 146 | works. |
| 147 | |
| 148 | =item * |
| 149 | |
| 150 | Second, it's very easy to serialize a scalar number. This is done in |
| 151 | the restart code; the debugger state variables are saved in C<%ENV> and then |
| 152 | restored when the debugger is restarted. Having them be just numbers makes |
| 153 | this trivial. |
| 154 | |
| 155 | =item * |
| 156 | |
| 157 | Third, some of these variables are being shared with the Perl core |
| 158 | smack in the middle of the interpreter's execution loop. It's much faster for |
| 159 | a C program (like the interpreter) to check a bit in a scalar than to access |
| 160 | several different variables (or a Perl array). |
| 161 | |
| 162 | =back |
| 163 | |
| 164 | =head2 What are those C<XXX> comments for? |
| 165 | |
| 166 | Any comment containing C<XXX> means that the comment is either somewhat |
| 167 | speculative - it's not exactly clear what a given variable or chunk of |
| 168 | code is doing, or that it is incomplete - the basics may be clear, but the |
| 169 | subtleties are not completely documented. |
| 170 | |
| 171 | Send in a patch if you can clear up, fill out, or clarify an C<XXX>. |
| 172 | |
| 173 | =head1 DATA STRUCTURES MAINTAINED BY CORE |
| 174 | |
| 175 | There are a number of special data structures provided to the debugger by |
| 176 | the Perl interpreter. |
| 177 | |
| 178 | The array C<@{$main::{'_<'.$filename}}> (aliased locally to C<@dbline> |
| 179 | via glob assignment) contains the text from C<$filename>, with each |
| 180 | element corresponding to a single line of C<$filename>. Additionally, |
| 181 | breakable lines will be dualvars with the numeric component being the |
| 182 | memory address of a COP node. Non-breakable lines are dualvar to 0. |
| 183 | |
| 184 | The hash C<%{'_<'.$filename}> (aliased locally to C<%dbline> via glob |
| 185 | assignment) contains breakpoints and actions. The keys are line numbers; |
| 186 | you can set individual values, but not the whole hash. The Perl interpreter |
| 187 | uses this hash to determine where breakpoints have been set. Any true value is |
| 188 | considered to be a breakpoint; C<perl5db.pl> uses C<$break_condition\0$action>. |
| 189 | Values are magical in numeric context: 1 if the line is breakable, 0 if not. |
| 190 | |
| 191 | The scalar C<${"_<$filename"}> simply contains the string C<$filename>. |
| 192 | This is also the case for evaluated strings that contain subroutines, or |
| 193 | which are currently being executed. The $filename for C<eval>ed strings looks |
| 194 | like S<C<(eval 34)>>. |
| 195 | |
| 196 | =head1 DEBUGGER STARTUP |
| 197 | |
| 198 | When C<perl5db.pl> starts, it reads an rcfile (C<perl5db.ini> for |
| 199 | non-interactive sessions, C<.perldb> for interactive ones) that can set a number |
| 200 | of options. In addition, this file may define a subroutine C<&afterinit> |
| 201 | that will be executed (in the debugger's context) after the debugger has |
| 202 | initialized itself. |
| 203 | |
| 204 | Next, it checks the C<PERLDB_OPTS> environment variable and treats its |
| 205 | contents as the argument of a C<o> command in the debugger. |
| 206 | |
| 207 | =head2 STARTUP-ONLY OPTIONS |
| 208 | |
| 209 | The following options can only be specified at startup. |
| 210 | To set them in your rcfile, add a call to |
| 211 | C<&parse_options("optionName=new_value")>. |
| 212 | |
| 213 | =over 4 |
| 214 | |
| 215 | =item * TTY |
| 216 | |
| 217 | the TTY to use for debugging i/o. |
| 218 | |
| 219 | =item * noTTY |
| 220 | |
| 221 | if set, goes in NonStop mode. On interrupt, if TTY is not set, |
| 222 | uses the value of noTTY or F<$HOME/.perldbtty$$> to find TTY using |
| 223 | Term::Rendezvous. Current variant is to have the name of TTY in this |
| 224 | file. |
| 225 | |
| 226 | =item * ReadLine |
| 227 | |
| 228 | if false, a dummy ReadLine is used, so you can debug |
| 229 | ReadLine applications. |
| 230 | |
| 231 | =item * NonStop |
| 232 | |
| 233 | if true, no i/o is performed until interrupt. |
| 234 | |
| 235 | =item * LineInfo |
| 236 | |
| 237 | file or pipe to print line number info to. If it is a |
| 238 | pipe, a short "emacs like" message is used. |
| 239 | |
| 240 | =item * RemotePort |
| 241 | |
| 242 | host:port to connect to on remote host for remote debugging. |
| 243 | |
| 244 | =item * HistFile |
| 245 | |
| 246 | file to store session history to. There is no default and so no |
| 247 | history file is written unless this variable is explicitly set. |
| 248 | |
| 249 | =item * HistSize |
| 250 | |
| 251 | number of commands to store to the file specified in C<HistFile>. |
| 252 | Default is 100. |
| 253 | |
| 254 | =back |
| 255 | |
| 256 | =head3 SAMPLE RCFILE |
| 257 | |
| 258 | &parse_options("NonStop=1 LineInfo=db.out"); |
| 259 | sub afterinit { $trace = 1; } |
| 260 | |
| 261 | The script will run without human intervention, putting trace |
| 262 | information into C<db.out>. (If you interrupt it, you had better |
| 263 | reset C<LineInfo> to something I<interactive>!) |
| 264 | |
| 265 | =head1 INTERNALS DESCRIPTION |
| 266 | |
| 267 | =head2 DEBUGGER INTERFACE VARIABLES |
| 268 | |
| 269 | Perl supplies the values for C<%sub>. It effectively inserts |
| 270 | a C<&DB::DB();> in front of each place that can have a |
| 271 | breakpoint. At each subroutine call, it calls C<&DB::sub> with |
| 272 | C<$DB::sub> set to the called subroutine. It also inserts a C<BEGIN |
| 273 | {require 'perl5db.pl'}> before the first line. |
| 274 | |
| 275 | After each C<require>d file is compiled, but before it is executed, a |
| 276 | call to C<&DB::postponed($main::{'_<'.$filename})> is done. C<$filename> |
| 277 | is the expanded name of the C<require>d file (as found via C<%INC>). |
| 278 | |
| 279 | =head3 IMPORTANT INTERNAL VARIABLES |
| 280 | |
| 281 | =head4 C<$CreateTTY> |
| 282 | |
| 283 | Used to control when the debugger will attempt to acquire another TTY to be |
| 284 | used for input. |
| 285 | |
| 286 | =over |
| 287 | |
| 288 | =item * 1 - on C<fork()> |
| 289 | |
| 290 | =item * 2 - debugger is started inside debugger |
| 291 | |
| 292 | =item * 4 - on startup |
| 293 | |
| 294 | =back |
| 295 | |
| 296 | =head4 C<$doret> |
| 297 | |
| 298 | The value -2 indicates that no return value should be printed. |
| 299 | Any other positive value causes C<DB::sub> to print return values. |
| 300 | |
| 301 | =head4 C<$evalarg> |
| 302 | |
| 303 | The item to be eval'ed by C<DB::eval>. Used to prevent messing with the current |
| 304 | contents of C<@_> when C<DB::eval> is called. |
| 305 | |
| 306 | =head4 C<$frame> |
| 307 | |
| 308 | Determines what messages (if any) will get printed when a subroutine (or eval) |
| 309 | is entered or exited. |
| 310 | |
| 311 | =over 4 |
| 312 | |
| 313 | =item * 0 - No enter/exit messages |
| 314 | |
| 315 | =item * 1 - Print I<entering> messages on subroutine entry |
| 316 | |
| 317 | =item * 2 - Adds exit messages on subroutine exit. If no other flag is on, acts like 1+2. |
| 318 | |
| 319 | =item * 4 - Extended messages: C<< <in|out> I<context>=I<fully-qualified sub name> from I<file>:I<line> >>. If no other flag is on, acts like 1+4. |
| 320 | |
| 321 | =item * 8 - Adds parameter information to messages, and overloaded stringify and tied FETCH is enabled on the printed arguments. Ignored if C<4> is not on. |
| 322 | |
| 323 | =item * 16 - Adds C<I<context> return from I<subname>: I<value>> messages on subroutine/eval exit. Ignored if C<4> is not on. |
| 324 | |
| 325 | =back |
| 326 | |
| 327 | To get everything, use C<$frame=30> (or S<C<o f=30>> as a debugger command). |
| 328 | The debugger internally juggles the value of C<$frame> during execution to |
| 329 | protect external modules that the debugger uses from getting traced. |
| 330 | |
| 331 | =head4 C<$level> |
| 332 | |
| 333 | Tracks current debugger nesting level. Used to figure out how many |
| 334 | C<E<lt>E<gt>> pairs to surround the line number with when the debugger |
| 335 | outputs a prompt. Also used to help determine if the program has finished |
| 336 | during command parsing. |
| 337 | |
| 338 | =head4 C<$onetimeDump> |
| 339 | |
| 340 | Controls what (if anything) C<DB::eval()> will print after evaluating an |
| 341 | expression. |
| 342 | |
| 343 | =over 4 |
| 344 | |
| 345 | =item * C<undef> - don't print anything |
| 346 | |
| 347 | =item * C<dump> - use C<dumpvar.pl> to display the value returned |
| 348 | |
| 349 | =item * C<methods> - print the methods callable on the first item returned |
| 350 | |
| 351 | =back |
| 352 | |
| 353 | =head4 C<$onetimeDumpDepth> |
| 354 | |
| 355 | Controls how far down C<dumpvar.pl> will go before printing C<...> while |
| 356 | dumping a structure. Numeric. If C<undef>, print all levels. |
| 357 | |
| 358 | =head4 C<$signal> |
| 359 | |
| 360 | Used to track whether or not an C<INT> signal has been detected. C<DB::DB()>, |
| 361 | which is called before every statement, checks this and puts the user into |
| 362 | command mode if it finds C<$signal> set to a true value. |
| 363 | |
| 364 | =head4 C<$single> |
| 365 | |
| 366 | Controls behavior during single-stepping. Stacked in C<@stack> on entry to |
| 367 | each subroutine; popped again at the end of each subroutine. |
| 368 | |
| 369 | =over 4 |
| 370 | |
| 371 | =item * 0 - run continuously. |
| 372 | |
| 373 | =item * 1 - single-step, go into subs. The C<s> command. |
| 374 | |
| 375 | =item * 2 - single-step, don't go into subs. The C<n> command. |
| 376 | |
| 377 | =item * 4 - print current sub depth (turned on to force this when C<too much |
| 378 | recursion> occurs. |
| 379 | |
| 380 | =back |
| 381 | |
| 382 | =head4 C<$trace> |
| 383 | |
| 384 | Controls the output of trace information. |
| 385 | |
| 386 | =over 4 |
| 387 | |
| 388 | =item * 1 - The C<t> command was entered to turn on tracing (every line executed is printed) |
| 389 | |
| 390 | =item * 2 - watch expressions are active |
| 391 | |
| 392 | =item * 4 - user defined a C<watchfunction()> in C<afterinit()> |
| 393 | |
| 394 | =back |
| 395 | |
| 396 | =head4 C<$client_editor> |
| 397 | |
| 398 | 1 if C<LINEINFO> was directed to a pipe; 0 otherwise. (The term |
| 399 | C<$slave_editor> was formerly used here.) |
| 400 | |
| 401 | =head4 C<@cmdfhs> |
| 402 | |
| 403 | Stack of filehandles that C<DB::readline()> will read commands from. |
| 404 | Manipulated by the debugger's C<source> command and C<DB::readline()> itself. |
| 405 | |
| 406 | =head4 C<@dbline> |
| 407 | |
| 408 | Local alias to the magical line array, C<@{$main::{'_<'.$filename}}> , |
| 409 | supplied by the Perl interpreter to the debugger. Contains the source. |
| 410 | |
| 411 | =head4 C<@old_watch> |
| 412 | |
| 413 | Previous values of watch expressions. First set when the expression is |
| 414 | entered; reset whenever the watch expression changes. |
| 415 | |
| 416 | =head4 C<@saved> |
| 417 | |
| 418 | Saves important globals (C<$@>, C<$!>, C<$^E>, C<$,>, C<$/>, C<$\>, C<$^W>) |
| 419 | so that the debugger can substitute safe values while it's running, and |
| 420 | restore them when it returns control. |
| 421 | |
| 422 | =head4 C<@stack> |
| 423 | |
| 424 | Saves the current value of C<$single> on entry to a subroutine. |
| 425 | Manipulated by the C<c> command to turn off tracing in all subs above the |
| 426 | current one. |
| 427 | |
| 428 | =head4 C<@to_watch> |
| 429 | |
| 430 | The 'watch' expressions: to be evaluated before each line is executed. |
| 431 | |
| 432 | =head4 C<@typeahead> |
| 433 | |
| 434 | The typeahead buffer, used by C<DB::readline>. |
| 435 | |
| 436 | =head4 C<%alias> |
| 437 | |
| 438 | Command aliases. Stored as character strings to be substituted for a command |
| 439 | entered. |
| 440 | |
| 441 | =head4 C<%break_on_load> |
| 442 | |
| 443 | Keys are file names, values are 1 (break when this file is loaded) or undef |
| 444 | (don't break when it is loaded). |
| 445 | |
| 446 | =head4 C<%dbline> |
| 447 | |
| 448 | Keys are line numbers, values are C<condition\0action>. If used in numeric |
| 449 | context, values are 0 if not breakable, 1 if breakable, no matter what is |
| 450 | in the actual hash entry. |
| 451 | |
| 452 | =head4 C<%had_breakpoints> |
| 453 | |
| 454 | Keys are file names; values are bitfields: |
| 455 | |
| 456 | =over 4 |
| 457 | |
| 458 | =item * 1 - file has a breakpoint in it. |
| 459 | |
| 460 | =item * 2 - file has an action in it. |
| 461 | |
| 462 | =back |
| 463 | |
| 464 | A zero or undefined value means this file has neither. |
| 465 | |
| 466 | =head4 C<%option> |
| 467 | |
| 468 | Stores the debugger options. These are character string values. |
| 469 | |
| 470 | =head4 C<%postponed> |
| 471 | |
| 472 | Saves breakpoints for code that hasn't been compiled yet. |
| 473 | Keys are subroutine names, values are: |
| 474 | |
| 475 | =over 4 |
| 476 | |
| 477 | =item * C<compile> - break when this sub is compiled |
| 478 | |
| 479 | =item * C<< break +0 if <condition> >> - break (conditionally) at the start of this routine. The condition will be '1' if no condition was specified. |
| 480 | |
| 481 | =back |
| 482 | |
| 483 | =head4 C<%postponed_file> |
| 484 | |
| 485 | This hash keeps track of breakpoints that need to be set for files that have |
| 486 | not yet been compiled. Keys are filenames; values are references to hashes. |
| 487 | Each of these hashes is keyed by line number, and its values are breakpoint |
| 488 | definitions (C<condition\0action>). |
| 489 | |
| 490 | =head1 DEBUGGER INITIALIZATION |
| 491 | |
| 492 | The debugger's initialization actually jumps all over the place inside this |
| 493 | package. This is because there are several BEGIN blocks (which of course |
| 494 | execute immediately) spread through the code. Why is that? |
| 495 | |
| 496 | The debugger needs to be able to change some things and set some things up |
| 497 | before the debugger code is compiled; most notably, the C<$deep> variable that |
| 498 | C<DB::sub> uses to tell when a program has recursed deeply. In addition, the |
| 499 | debugger has to turn off warnings while the debugger code is compiled, but then |
| 500 | restore them to their original setting before the program being debugged begins |
| 501 | executing. |
| 502 | |
| 503 | The first C<BEGIN> block simply turns off warnings by saving the current |
| 504 | setting of C<$^W> and then setting it to zero. The second one initializes |
| 505 | the debugger variables that are needed before the debugger begins executing. |
| 506 | The third one puts C<$^X> back to its former value. |
| 507 | |
| 508 | We'll detail the second C<BEGIN> block later; just remember that if you need |
| 509 | to initialize something before the debugger starts really executing, that's |
| 510 | where it has to go. |
| 511 | |
| 512 | =cut |
| 513 | |
| 514 | package DB; |
| 515 | |
| 516 | use strict; |
| 517 | |
| 518 | use Cwd (); |
| 519 | |
| 520 | my $_initial_cwd; |
| 521 | |
| 522 | BEGIN {eval 'use IO::Handle'}; # Needed for flush only? breaks under miniperl |
| 523 | |
| 524 | BEGIN { |
| 525 | require feature; |
| 526 | $^V =~ /^v(\d+\.\d+)/; |
| 527 | feature->import(":$1"); |
| 528 | $_initial_cwd = Cwd::getcwd(); |
| 529 | } |
| 530 | |
| 531 | # Debugger for Perl 5.00x; perl5db.pl patch level: |
| 532 | use vars qw($VERSION $header); |
| 533 | |
| 534 | # bump to X.XX in blead, only use X.XX_XX in maint |
| 535 | $VERSION = '1.80'; |
| 536 | |
| 537 | $header = "perl5db.pl version $VERSION"; |
| 538 | |
| 539 | =head1 DEBUGGER ROUTINES |
| 540 | |
| 541 | =head2 C<DB::eval()> |
| 542 | |
| 543 | This function replaces straight C<eval()> inside the debugger; it simplifies |
| 544 | the process of evaluating code in the user's context. |
| 545 | |
| 546 | The code to be evaluated is passed via the package global variable |
| 547 | C<$DB::evalarg>; this is done to avoid fiddling with the contents of C<@_>. |
| 548 | |
| 549 | Before we do the C<eval()>, we preserve the current settings of C<$trace>, |
| 550 | C<$single>, C<$^D> and C<$usercontext>. The latter contains the |
| 551 | preserved values of C<$@>, C<$!>, C<$^E>, C<$,>, C<$/>, C<$\>, C<$^W> and the |
| 552 | user's current package, grabbed when C<DB::DB> got control. This causes the |
| 553 | proper context to be used when the eval is actually done. Afterward, we |
| 554 | restore C<$trace>, C<$single>, and C<$^D>. |
| 555 | |
| 556 | Next we need to handle C<$@> without getting confused. We save C<$@> in a |
| 557 | local lexical, localize C<$saved[0]> (which is where C<save()> will put |
| 558 | C<$@>), and then call C<save()> to capture C<$@>, C<$!>, C<$^E>, C<$,>, |
| 559 | C<$/>, C<$\>, and C<$^W>) and set C<$,>, C<$/>, C<$\>, and C<$^W> to values |
| 560 | considered sane by the debugger. If there was an C<eval()> error, we print |
| 561 | it on the debugger's output. If C<$onetimedump> is defined, we call |
| 562 | C<dumpit> if it's set to 'dump', or C<methods> if it's set to |
| 563 | 'methods'. Setting it to something else causes the debugger to do the eval |
| 564 | but not print the result - handy if you want to do something else with it |
| 565 | (the "watch expressions" code does this to get the value of the watch |
| 566 | expression but not show it unless it matters). |
| 567 | |
| 568 | In any case, we then return the list of output from C<eval> to the caller, |
| 569 | and unwinding restores the former version of C<$@> in C<@saved> as well |
| 570 | (the localization of C<$saved[0]> goes away at the end of this scope). |
| 571 | |
| 572 | =head3 Parameters and variables influencing execution of DB::eval() |
| 573 | |
| 574 | C<DB::eval> isn't parameterized in the standard way; this is to keep the |
| 575 | debugger's calls to C<DB::eval()> from mucking with C<@_>, among other things. |
| 576 | The variables listed below influence C<DB::eval()>'s execution directly. |
| 577 | |
| 578 | =over 4 |
| 579 | |
| 580 | =item C<$evalarg> - the thing to actually be eval'ed |
| 581 | |
| 582 | =item C<$trace> - Current state of execution tracing |
| 583 | |
| 584 | =item C<$single> - Current state of single-stepping |
| 585 | |
| 586 | =item C<$onetimeDump> - what is to be displayed after the evaluation |
| 587 | |
| 588 | =item C<$onetimeDumpDepth> - how deep C<dumpit()> should go when dumping results |
| 589 | |
| 590 | =back |
| 591 | |
| 592 | The following variables are altered by C<DB::eval()> during its execution. They |
| 593 | are "stacked" via C<local()>, enabling recursive calls to C<DB::eval()>. |
| 594 | |
| 595 | =over 4 |
| 596 | |
| 597 | =item C<@res> - used to capture output from actual C<eval>. |
| 598 | |
| 599 | =item C<$otrace> - saved value of C<$trace>. |
| 600 | |
| 601 | =item C<$osingle> - saved value of C<$single>. |
| 602 | |
| 603 | =item C<$od> - saved value of C<$^D>. |
| 604 | |
| 605 | =item C<$saved[0]> - saved value of C<$@>. |
| 606 | |
| 607 | =item $\ - for output of C<$@> if there is an evaluation error. |
| 608 | |
| 609 | =back |
| 610 | |
| 611 | =head3 The problem of lexicals |
| 612 | |
| 613 | The context of C<DB::eval()> presents us with some problems. Obviously, |
| 614 | we want to be 'sandboxed' away from the debugger's internals when we do |
| 615 | the eval, but we need some way to control how punctuation variables and |
| 616 | debugger globals are used. |
| 617 | |
| 618 | We can't use local, because the code inside C<DB::eval> can see localized |
| 619 | variables; and we can't use C<my> either for the same reason. The code |
| 620 | in this routine compromises and uses C<my>. |
| 621 | |
| 622 | After this routine is over, we don't have user code executing in the debugger's |
| 623 | context, so we can use C<my> freely. |
| 624 | |
| 625 | =cut |
| 626 | |
| 627 | ############################################## Begin lexical danger zone |
| 628 | |
| 629 | # 'my' variables used here could leak into (that is, be visible in) |
| 630 | # the context that the code being evaluated is executing in. This means that |
| 631 | # the code could modify the debugger's variables. |
| 632 | # |
| 633 | # Fiddling with the debugger's context could be Bad. We insulate things as |
| 634 | # much as we can. |
| 635 | |
| 636 | use vars qw( |
| 637 | @args |
| 638 | %break_on_load |
| 639 | $CommandSet |
| 640 | $CreateTTY |
| 641 | $DBGR |
| 642 | @dbline |
| 643 | $dbline |
| 644 | %dbline |
| 645 | $dieLevel |
| 646 | $filename |
| 647 | $histfile |
| 648 | $histsize |
| 649 | $histitemminlength |
| 650 | $IN |
| 651 | $inhibit_exit |
| 652 | @ini_INC |
| 653 | $ini_warn |
| 654 | $maxtrace |
| 655 | $od |
| 656 | @options |
| 657 | $osingle |
| 658 | $otrace |
| 659 | $pager |
| 660 | $post |
| 661 | %postponed |
| 662 | $prc |
| 663 | $pre |
| 664 | $pretype |
| 665 | $psh |
| 666 | @RememberOnROptions |
| 667 | $remoteport |
| 668 | @res |
| 669 | $rl |
| 670 | @saved |
| 671 | $signalLevel |
| 672 | $sub |
| 673 | $term |
| 674 | $usercontext |
| 675 | $warnLevel |
| 676 | ); |
| 677 | |
| 678 | our ( |
| 679 | @cmdfhs, |
| 680 | $evalarg, |
| 681 | $frame, |
| 682 | $hist, |
| 683 | $ImmediateStop, |
| 684 | $line, |
| 685 | $onetimeDump, |
| 686 | $onetimedumpDepth, |
| 687 | %option, |
| 688 | $OUT, |
| 689 | $packname, |
| 690 | $signal, |
| 691 | $single, |
| 692 | $start, |
| 693 | %sub, |
| 694 | $subname, |
| 695 | $trace, |
| 696 | $window, |
| 697 | ); |
| 698 | |
| 699 | # Used to save @ARGV and extract any debugger-related flags. |
| 700 | use vars qw(@ARGS); |
| 701 | |
| 702 | # Used to prevent multiple entries to diesignal() |
| 703 | # (if for instance diesignal() itself dies) |
| 704 | use vars qw($panic); |
| 705 | |
| 706 | # Used to prevent the debugger from running nonstop |
| 707 | # after a restart |
| 708 | our ($second_time); |
| 709 | |
| 710 | sub _calc_usercontext { |
| 711 | my ($package) = @_; |
| 712 | |
| 713 | # Cancel strict completely for the evaluated code, so the code |
| 714 | # the user evaluates won't be affected by it. (Shlomi Fish) |
| 715 | return 'no strict; ($@, $!, $^E, $,, $/, $\, $^W) = @DB::saved;' |
| 716 | . "package $package;"; # this won't let them modify, alas |
| 717 | } |
| 718 | |
| 719 | sub eval { |
| 720 | |
| 721 | # 'my' would make it visible from user code |
| 722 | # but so does local! --tchrist |
| 723 | # Remember: this localizes @DB::res, not @main::res. |
| 724 | local @res; |
| 725 | { |
| 726 | |
| 727 | # Try to keep the user code from messing with us. Save these so that |
| 728 | # even if the eval'ed code changes them, we can put them back again. |
| 729 | # Needed because the user could refer directly to the debugger's |
| 730 | # package globals (and any 'my' variables in this containing scope) |
| 731 | # inside the eval(), and we want to try to stay safe. |
| 732 | local $otrace = $trace; |
| 733 | local $osingle = $single; |
| 734 | local $od = $^D; |
| 735 | |
| 736 | # Untaint the incoming eval() argument. |
| 737 | { ($evalarg) = $evalarg =~ /(.*)/s; } |
| 738 | |
| 739 | # $usercontext built in DB::DB near the comment |
| 740 | # "set up the context for DB::eval ..." |
| 741 | # Evaluate and save any results. |
| 742 | @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug |
| 743 | |
| 744 | # Restore those old values. |
| 745 | $trace = $otrace; |
| 746 | $single = $osingle; |
| 747 | $^D = $od; |
| 748 | } |
| 749 | |
| 750 | # Save the current value of $@, and preserve it in the debugger's copy |
| 751 | # of the saved precious globals. |
| 752 | my $at = $@; |
| 753 | |
| 754 | # Since we're only saving $@, we only have to localize the array element |
| 755 | # that it will be stored in. |
| 756 | local $saved[0]; # Preserve the old value of $@ |
| 757 | eval { &DB::save }; |
| 758 | |
| 759 | # Now see whether we need to report an error back to the user. |
| 760 | if ($at) { |
| 761 | local $\ = ''; |
| 762 | print $OUT $at; |
| 763 | } |
| 764 | |
| 765 | # Display as required by the caller. $onetimeDump and $onetimedumpDepth |
| 766 | # are package globals. |
| 767 | elsif ($onetimeDump) { |
| 768 | if ( $onetimeDump eq 'dump' ) { |
| 769 | local $option{dumpDepth} = $onetimedumpDepth |
| 770 | if defined $onetimedumpDepth; |
| 771 | dumpit( $OUT, \@res ); |
| 772 | } |
| 773 | elsif ( $onetimeDump eq 'methods' ) { |
| 774 | methods( $res[0] ); |
| 775 | } |
| 776 | } ## end elsif ($onetimeDump) |
| 777 | @res; |
| 778 | } ## end sub eval |
| 779 | |
| 780 | ############################################## End lexical danger zone |
| 781 | |
| 782 | # After this point it is safe to introduce lexicals. |
| 783 | # The code being debugged will be executing in its own context, and |
| 784 | # can't see the inside of the debugger. |
| 785 | # |
| 786 | # However, one should not overdo it: leave as much control from outside as |
| 787 | # possible. If you make something a lexical, it's not going to be addressable |
| 788 | # from outside the debugger even if you know its name. |
| 789 | |
| 790 | # This file is automatically included if you do perl -d. |
| 791 | # It's probably not useful to include this yourself. |
| 792 | # |
| 793 | # Before venturing further into these twisty passages, it is |
| 794 | # wise to read the perldebguts man page or risk the ire of dragons. |
| 795 | # |
| 796 | # (It should be noted that perldebguts will tell you a lot about |
| 797 | # the underlying mechanics of how the debugger interfaces into the |
| 798 | # Perl interpreter, but not a lot about the debugger itself. The new |
| 799 | # comments in this code try to address this problem.) |
| 800 | |
| 801 | # Note that no subroutine call is possible until &DB::sub is defined |
| 802 | # (for subroutines defined outside of the package DB). In fact the same is |
| 803 | # true if $deep is not defined. |
| 804 | |
| 805 | # Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich) |
| 806 | |
| 807 | # modified Perl debugger, to be run from Emacs in perldb-mode |
| 808 | # Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990 |
| 809 | # Johan Vromans -- upgrade to 4.0 pl 10 |
| 810 | # Ilya Zakharevich -- patches after 5.001 (and some before ;-) |
| 811 | ######################################################################## |
| 812 | |
| 813 | =head1 DEBUGGER INITIALIZATION |
| 814 | |
| 815 | The debugger starts up in phases. |
| 816 | |
| 817 | =head2 BASIC SETUP |
| 818 | |
| 819 | First, it initializes the environment it wants to run in: turning off |
| 820 | warnings during its own compilation, defining variables which it will need |
| 821 | to avoid warnings later, setting itself up to not exit when the program |
| 822 | terminates, and defaulting to printing return values for the C<r> command. |
| 823 | |
| 824 | =cut |
| 825 | |
| 826 | # Needed for the statement after exec(): |
| 827 | # |
| 828 | # This BEGIN block is simply used to switch off warnings during debugger |
| 829 | # compilation. Probably it would be better practice to fix the warnings, |
| 830 | # but this is how it's done at the moment. |
| 831 | |
| 832 | BEGIN { |
| 833 | $ini_warn = $^W; |
| 834 | $^W = 0; |
| 835 | } # Switch compilation warnings off until another BEGIN. |
| 836 | |
| 837 | local ($^W) = 0; # Switch run-time warnings off during init. |
| 838 | |
| 839 | =head2 THREADS SUPPORT |
| 840 | |
| 841 | If we are running under a threaded Perl, we require threads and threads::shared |
| 842 | if the environment variable C<PERL5DB_THREADED> is set, to enable proper |
| 843 | threaded debugger control. C<-dt> can also be used to set this. |
| 844 | |
| 845 | Each new thread will be announced and the debugger prompt will always inform |
| 846 | you of each new thread created. It will also indicate the thread id in which |
| 847 | we are currently running within the prompt like this: |
| 848 | |
| 849 | [tid] DB<$i> |
| 850 | |
| 851 | Where C<[tid]> is an integer thread id and C<$i> is the familiar debugger |
| 852 | command prompt. The prompt will show: C<[0]> when running under threads, but |
| 853 | not actually in a thread. C<[tid]> is consistent with C<gdb> usage. |
| 854 | |
| 855 | While running under threads, when you set or delete a breakpoint (etc.), this |
| 856 | will apply to all threads, not just the currently running one. When you are |
| 857 | in a currently executing thread, you will stay there until it completes. With |
| 858 | the current implementation it is not currently possible to hop from one thread |
| 859 | to another. |
| 860 | |
| 861 | The C<e> and C<E> commands are currently fairly minimal - see |
| 862 | S<C<h e>> and S<C<h E>>. |
| 863 | |
| 864 | Note that threading support was built into the debugger as of Perl version |
| 865 | C<5.8.6> and debugger version C<1.2.8>. |
| 866 | |
| 867 | =cut |
| 868 | |
| 869 | BEGIN { |
| 870 | # ensure we can share our non-threaded variables or no-op |
| 871 | if ($ENV{PERL5DB_THREADED}) { |
| 872 | require threads; |
| 873 | require threads::shared; |
| 874 | threads::shared->import('share'); |
| 875 | $DBGR; |
| 876 | share(\$DBGR); |
| 877 | lock($DBGR); |
| 878 | print "Threads support enabled\n"; |
| 879 | } else { |
| 880 | *lock = sub :prototype(*) {}; |
| 881 | *share = sub :prototype(\[$@%]) {}; |
| 882 | } |
| 883 | } |
| 884 | |
| 885 | # These variables control the execution of 'dumpvar.pl'. |
| 886 | { |
| 887 | package dumpvar; |
| 888 | use vars qw( |
| 889 | $hashDepth |
| 890 | $arrayDepth |
| 891 | $dumpDBFiles |
| 892 | $dumpPackages |
| 893 | $quoteHighBit |
| 894 | $printUndef |
| 895 | $globPrint |
| 896 | $usageOnly |
| 897 | ); |
| 898 | } |
| 899 | |
| 900 | # used to control die() reporting in diesignal() |
| 901 | { |
| 902 | package Carp; |
| 903 | use vars qw($CarpLevel); |
| 904 | } |
| 905 | |
| 906 | # without threads, $filename is not defined until DB::DB is called |
| 907 | share($main::{'_<'.$filename}) if defined $filename; |
| 908 | |
| 909 | # Command-line + PERLLIB: |
| 910 | # Save the contents of @INC before they are modified elsewhere. |
| 911 | @ini_INC = @INC; |
| 912 | |
| 913 | # This was an attempt to clear out the previous values of various |
| 914 | # trapped errors. Apparently it didn't help. XXX More info needed! |
| 915 | # $prevwarn = $prevdie = $prevbus = $prevsegv = ''; # Does not help?! |
| 916 | |
| 917 | # We set these variables to safe values. We don't want to blindly turn |
| 918 | # off warnings, because other packages may still want them. |
| 919 | $trace = $signal = $single = 0; # Uninitialized warning suppression |
| 920 | # (local $^W cannot help - other packages!). |
| 921 | |
| 922 | # Default to not exiting when program finishes; print the return |
| 923 | # value when the 'r' command is used to return from a subroutine. |
| 924 | $inhibit_exit = $option{PrintRet} = 1; |
| 925 | |
| 926 | use vars qw($trace_to_depth); |
| 927 | |
| 928 | # Default to 1E9 so it won't be limited to a certain recursion depth. |
| 929 | $trace_to_depth = 1E9; |
| 930 | |
| 931 | =head1 OPTION PROCESSING |
| 932 | |
| 933 | The debugger's options are actually spread out over the debugger itself and |
| 934 | C<dumpvar.pl>; some of these are variables to be set, while others are |
| 935 | subs to be called with a value. To try to make this a little easier to |
| 936 | manage, the debugger uses a few data structures to define what options |
| 937 | are legal and how they are to be processed. |
| 938 | |
| 939 | First, the C<@options> array defines the I<names> of all the options that |
| 940 | are to be accepted. |
| 941 | |
| 942 | =cut |
| 943 | |
| 944 | @options = qw( |
| 945 | CommandSet HistFile HistSize |
| 946 | HistItemMinLength |
| 947 | hashDepth arrayDepth dumpDepth |
| 948 | DumpDBFiles DumpPackages DumpReused |
| 949 | compactDump veryCompact quote |
| 950 | HighBit undefPrint globPrint |
| 951 | PrintRet UsageOnly frame |
| 952 | AutoTrace TTY noTTY |
| 953 | ReadLine NonStop LineInfo |
| 954 | maxTraceLen recallCommand ShellBang |
| 955 | pager tkRunning ornaments |
| 956 | signalLevel warnLevel dieLevel |
| 957 | inhibit_exit ImmediateStop bareStringify |
| 958 | CreateTTY RemotePort windowSize |
| 959 | DollarCaretP |
| 960 | ); |
| 961 | |
| 962 | @RememberOnROptions = qw(DollarCaretP); |
| 963 | |
| 964 | =pod |
| 965 | |
| 966 | Second, C<optionVars> lists the variables that each option uses to save its |
| 967 | state. |
| 968 | |
| 969 | =cut |
| 970 | |
| 971 | use vars qw(%optionVars); |
| 972 | |
| 973 | %optionVars = ( |
| 974 | hashDepth => \$dumpvar::hashDepth, |
| 975 | arrayDepth => \$dumpvar::arrayDepth, |
| 976 | CommandSet => \$CommandSet, |
| 977 | DumpDBFiles => \$dumpvar::dumpDBFiles, |
| 978 | DumpPackages => \$dumpvar::dumpPackages, |
| 979 | DumpReused => \$dumpvar::dumpReused, |
| 980 | HighBit => \$dumpvar::quoteHighBit, |
| 981 | undefPrint => \$dumpvar::printUndef, |
| 982 | globPrint => \$dumpvar::globPrint, |
| 983 | UsageOnly => \$dumpvar::usageOnly, |
| 984 | CreateTTY => \$CreateTTY, |
| 985 | bareStringify => \$dumpvar::bareStringify, |
| 986 | frame => \$frame, |
| 987 | AutoTrace => \$trace, |
| 988 | inhibit_exit => \$inhibit_exit, |
| 989 | maxTraceLen => \$maxtrace, |
| 990 | ImmediateStop => \$ImmediateStop, |
| 991 | RemotePort => \$remoteport, |
| 992 | windowSize => \$window, |
| 993 | HistFile => \$histfile, |
| 994 | HistSize => \$histsize, |
| 995 | HistItemMinLength => \$histitemminlength |
| 996 | ); |
| 997 | |
| 998 | =pod |
| 999 | |
| 1000 | Third, C<%optionAction> defines the subroutine to be called to process each |
| 1001 | option. |
| 1002 | |
| 1003 | =cut |
| 1004 | |
| 1005 | use vars qw(%optionAction); |
| 1006 | |
| 1007 | %optionAction = ( |
| 1008 | compactDump => \&dumpvar::compactDump, |
| 1009 | veryCompact => \&dumpvar::veryCompact, |
| 1010 | quote => \&dumpvar::quote, |
| 1011 | TTY => \&TTY, |
| 1012 | noTTY => \&noTTY, |
| 1013 | ReadLine => \&ReadLine, |
| 1014 | NonStop => \&NonStop, |
| 1015 | LineInfo => \&LineInfo, |
| 1016 | recallCommand => \&recallCommand, |
| 1017 | ShellBang => \&shellBang, |
| 1018 | pager => \&pager, |
| 1019 | signalLevel => \&signalLevel, |
| 1020 | warnLevel => \&warnLevel, |
| 1021 | dieLevel => \&dieLevel, |
| 1022 | tkRunning => \&tkRunning, |
| 1023 | ornaments => \&ornaments, |
| 1024 | RemotePort => \&RemotePort, |
| 1025 | DollarCaretP => \&DollarCaretP, |
| 1026 | ); |
| 1027 | |
| 1028 | =pod |
| 1029 | |
| 1030 | Last, the C<%optionRequire> notes modules that must be C<require>d if an |
| 1031 | option is used. |
| 1032 | |
| 1033 | =cut |
| 1034 | |
| 1035 | # Note that this list is not complete: several options not listed here |
| 1036 | # actually require that dumpvar.pl be loaded for them to work, but are |
| 1037 | # not in the table. A subsequent patch will correct this problem; for |
| 1038 | # the moment, we're just recommenting, and we are NOT going to change |
| 1039 | # function. |
| 1040 | use vars qw(%optionRequire); |
| 1041 | |
| 1042 | %optionRequire = ( |
| 1043 | compactDump => 'dumpvar.pl', |
| 1044 | veryCompact => 'dumpvar.pl', |
| 1045 | quote => 'dumpvar.pl', |
| 1046 | ); |
| 1047 | |
| 1048 | =pod |
| 1049 | |
| 1050 | There are a number of initialization-related variables which can be set |
| 1051 | by putting code to set them in a BEGIN block in the C<PERL5DB> environment |
| 1052 | variable. These are: |
| 1053 | |
| 1054 | =over 4 |
| 1055 | |
| 1056 | =item C<$rl> - readline control XXX needs more explanation |
| 1057 | |
| 1058 | =item C<$warnLevel> - whether or not debugger takes over warning handling |
| 1059 | |
| 1060 | =item C<$dieLevel> - whether or not debugger takes over die handling |
| 1061 | |
| 1062 | =item C<$signalLevel> - whether or not debugger takes over signal handling |
| 1063 | |
| 1064 | =item C<$pre> - preprompt actions (array reference) |
| 1065 | |
| 1066 | =item C<$post> - postprompt actions (array reference) |
| 1067 | |
| 1068 | =item C<$pretype> |
| 1069 | |
| 1070 | =item C<$CreateTTY> - whether or not to create a new TTY for this debugger |
| 1071 | |
| 1072 | =item C<$CommandSet> - which command set to use (defaults to new, documented set) |
| 1073 | |
| 1074 | =back |
| 1075 | |
| 1076 | =cut |
| 1077 | |
| 1078 | # These guys may be defined in $ENV{PERL5DB} : |
| 1079 | $rl = 1 unless defined $rl; |
| 1080 | $warnLevel = 1 unless defined $warnLevel; |
| 1081 | $dieLevel = 1 unless defined $dieLevel; |
| 1082 | $signalLevel = 1 unless defined $signalLevel; |
| 1083 | $pre = [] unless defined $pre; |
| 1084 | $post = [] unless defined $post; |
| 1085 | $pretype = [] unless defined $pretype; |
| 1086 | $CreateTTY = 3 unless defined $CreateTTY; |
| 1087 | $CommandSet = '580' unless defined $CommandSet; |
| 1088 | |
| 1089 | share($rl); |
| 1090 | share($warnLevel); |
| 1091 | share($dieLevel); |
| 1092 | share($signalLevel); |
| 1093 | share($pre); |
| 1094 | share($post); |
| 1095 | share($pretype); |
| 1096 | share($CreateTTY); |
| 1097 | share($CommandSet); |
| 1098 | |
| 1099 | =pod |
| 1100 | |
| 1101 | The default C<die>, C<warn>, and C<signal> handlers are set up. |
| 1102 | |
| 1103 | =cut |
| 1104 | |
| 1105 | warnLevel($warnLevel); |
| 1106 | dieLevel($dieLevel); |
| 1107 | signalLevel($signalLevel); |
| 1108 | |
| 1109 | =pod |
| 1110 | |
| 1111 | The pager to be used is needed next. We try to get it from the |
| 1112 | environment first. If it's not defined there, we try to find it in |
| 1113 | the Perl C<Config.pm>. If it's not there, we default to C<more>. We |
| 1114 | then call the C<pager()> function to save the pager name. |
| 1115 | |
| 1116 | =cut |
| 1117 | |
| 1118 | # This routine makes sure $pager is set up so that '|' can use it. |
| 1119 | pager( |
| 1120 | |
| 1121 | # If PAGER is defined in the environment, use it. |
| 1122 | defined $ENV{PAGER} |
| 1123 | ? $ENV{PAGER} |
| 1124 | |
| 1125 | # If not, see if Config.pm defines it. |
| 1126 | : eval { require Config } |
| 1127 | && defined $Config::Config{pager} |
| 1128 | ? $Config::Config{pager} |
| 1129 | |
| 1130 | # If not, fall back to 'more'. |
| 1131 | : 'more' |
| 1132 | ) |
| 1133 | unless defined $pager; |
| 1134 | |
| 1135 | =pod |
| 1136 | |
| 1137 | We set up the command to be used to access the man pages, the command |
| 1138 | recall character (C<!> unless otherwise defined) and the shell escape |
| 1139 | character (C<!> unless otherwise defined). Yes, these do conflict, and |
| 1140 | neither works in the debugger at the moment. |
| 1141 | |
| 1142 | =cut |
| 1143 | |
| 1144 | setman(); |
| 1145 | |
| 1146 | # Set up defaults for command recall and shell escape (note: |
| 1147 | # these currently don't work in linemode debugging). |
| 1148 | recallCommand("!") unless defined $prc; |
| 1149 | shellBang("!") unless defined $psh; |
| 1150 | |
| 1151 | =pod |
| 1152 | |
| 1153 | We then set up the gigantic string containing the debugger help. |
| 1154 | We also set the limit on the number of arguments we'll display during a |
| 1155 | trace. |
| 1156 | |
| 1157 | =cut |
| 1158 | |
| 1159 | sethelp(); |
| 1160 | |
| 1161 | # If we didn't get a default for the length of eval/stack trace args, |
| 1162 | # set it here. |
| 1163 | $maxtrace = 400 unless defined $maxtrace; |
| 1164 | |
| 1165 | =head2 SETTING UP THE DEBUGGER GREETING |
| 1166 | |
| 1167 | The debugger I<greeting> helps to inform the user how many debuggers are |
| 1168 | running, and whether the current debugger is the primary or a child. |
| 1169 | |
| 1170 | If we are the primary, we just hang onto our pid so we'll have it when |
| 1171 | or if we start a child debugger. If we are a child, we'll set things up |
| 1172 | so we'll have a unique greeting and so the parent will give us our own |
| 1173 | TTY later. |
| 1174 | |
| 1175 | We save the current contents of the C<PERLDB_PIDS> environment variable |
| 1176 | because we mess around with it. We'll also need to hang onto it because |
| 1177 | we'll need it if we restart. |
| 1178 | |
| 1179 | Child debuggers make a label out of the current PID structure recorded in |
| 1180 | PERLDB_PIDS plus the new PID. They also mark themselves as not having a TTY |
| 1181 | yet so the parent will give them one later via C<resetterm()>. |
| 1182 | |
| 1183 | =cut |
| 1184 | |
| 1185 | # Save the current contents of the environment; we're about to |
| 1186 | # much with it. We'll need this if we have to restart. |
| 1187 | use vars qw($ini_pids); |
| 1188 | $ini_pids = $ENV{PERLDB_PIDS}; |
| 1189 | |
| 1190 | use vars qw ($pids $term_pid); |
| 1191 | |
| 1192 | if ( defined $ENV{PERLDB_PIDS} ) { |
| 1193 | |
| 1194 | # We're a child. Make us a label out of the current PID structure |
| 1195 | # recorded in PERLDB_PIDS plus our (new) PID. Mark us as not having |
| 1196 | # a term yet so the parent will give us one later via resetterm(). |
| 1197 | |
| 1198 | my $env_pids = $ENV{PERLDB_PIDS}; |
| 1199 | $pids = "[$env_pids]"; |
| 1200 | |
| 1201 | # Unless we are on OpenVMS, all programs under the DCL shell run under |
| 1202 | # the same PID. |
| 1203 | |
| 1204 | if (($^O eq 'VMS') && ($env_pids =~ /\b$$\b/)) { |
| 1205 | $term_pid = $$; |
| 1206 | } |
| 1207 | else { |
| 1208 | $ENV{PERLDB_PIDS} .= "->$$"; |
| 1209 | $term_pid = -1; |
| 1210 | } |
| 1211 | |
| 1212 | } ## end if (defined $ENV{PERLDB_PIDS... |
| 1213 | else { |
| 1214 | |
| 1215 | # We're the parent PID. Initialize PERLDB_PID in case we end up with a |
| 1216 | # child debugger, and mark us as the parent, so we'll know to set up |
| 1217 | # more TTY's is we have to. |
| 1218 | $ENV{PERLDB_PIDS} = "$$"; |
| 1219 | $pids = "[pid=$$]"; |
| 1220 | $term_pid = $$; |
| 1221 | } |
| 1222 | |
| 1223 | use vars qw($pidprompt); |
| 1224 | $pidprompt = ''; |
| 1225 | |
| 1226 | # Sets up $emacs as a synonym for $client_editor. |
| 1227 | our ($client_editor); |
| 1228 | *emacs = $client_editor if $client_editor; # May be used in afterinit()... |
| 1229 | |
| 1230 | =head2 READING THE RC FILE |
| 1231 | |
| 1232 | The debugger will read a file of initialization options if supplied. If |
| 1233 | running interactively, this is C<.perldb>; if not, it's C<perldb.ini>. |
| 1234 | |
| 1235 | =cut |
| 1236 | |
| 1237 | # As noted, this test really doesn't check accurately that the debugger |
| 1238 | # is running at a terminal or not. |
| 1239 | |
| 1240 | use vars qw($rcfile); |
| 1241 | { |
| 1242 | my $dev_tty = (($^O eq 'VMS') ? 'TT:' : '/dev/tty'); |
| 1243 | # this is the wrong metric! |
| 1244 | $rcfile = ((-e $dev_tty) ? ".perldb" : "perldb.ini"); |
| 1245 | } |
| 1246 | |
| 1247 | =pod |
| 1248 | |
| 1249 | The debugger does a safety test of the file to be read. It must be owned |
| 1250 | either by the current user or root, and must only be writable by the owner. |
| 1251 | |
| 1252 | =cut |
| 1253 | |
| 1254 | # This wraps a safety test around "do" to read and evaluate the init file. |
| 1255 | # |
| 1256 | # This isn't really safe, because there's a race |
| 1257 | # between checking and opening. The solution is to |
| 1258 | # open and fstat the handle, but then you have to read and |
| 1259 | # eval the contents. But then the silly thing gets |
| 1260 | # your lexical scope, which is unfortunate at best. |
| 1261 | sub safe_do { |
| 1262 | my $file = shift; |
| 1263 | |
| 1264 | # Just exactly what part of the word "CORE::" don't you understand? |
| 1265 | local $SIG{__WARN__}; |
| 1266 | local $SIG{__DIE__}; |
| 1267 | |
| 1268 | unless ( is_safe_file($file) ) { |
| 1269 | CORE::warn <<EO_GRIPE; |
| 1270 | perldb: Must not source insecure rcfile $file. |
| 1271 | You or the superuser must be the owner, and it must not |
| 1272 | be writable by anyone but its owner. |
| 1273 | EO_GRIPE |
| 1274 | return; |
| 1275 | } ## end unless (is_safe_file($file... |
| 1276 | |
| 1277 | do $file; |
| 1278 | CORE::warn("perldb: couldn't parse $file: $@") if $@; |
| 1279 | } ## end sub safe_do |
| 1280 | |
| 1281 | # This is the safety test itself. |
| 1282 | # |
| 1283 | # Verifies that owner is either real user or superuser and that no |
| 1284 | # one but owner may write to it. This function is of limited use |
| 1285 | # when called on a path instead of upon a handle, because there are |
| 1286 | # no guarantees that filename (by dirent) whose file (by ino) is |
| 1287 | # eventually accessed is the same as the one tested. |
| 1288 | # Assumes that the file's existence is not in doubt. |
| 1289 | sub is_safe_file { |
| 1290 | my $path = shift; |
| 1291 | stat($path) || return; # mysteriously vaporized |
| 1292 | my ( $dev, $ino, $mode, $nlink, $uid, $gid ) = stat(_); |
| 1293 | |
| 1294 | return 0 if $uid != 0 && $uid != $<; |
| 1295 | return 0 if $mode & 022; |
| 1296 | return 1; |
| 1297 | } ## end sub is_safe_file |
| 1298 | |
| 1299 | # If the rcfile (whichever one we decided was the right one to read) |
| 1300 | # exists, we safely do it. |
| 1301 | if ( -f $rcfile ) { |
| 1302 | safe_do("./$rcfile"); |
| 1303 | } |
| 1304 | |
| 1305 | # If there isn't one here, try the user's home directory. |
| 1306 | elsif ( defined $ENV{HOME} && -f "$ENV{HOME}/$rcfile" ) { |
| 1307 | safe_do("$ENV{HOME}/$rcfile"); |
| 1308 | } |
| 1309 | |
| 1310 | # Else try the login directory. |
| 1311 | elsif ( defined $ENV{LOGDIR} && -f "$ENV{LOGDIR}/$rcfile" ) { |
| 1312 | safe_do("$ENV{LOGDIR}/$rcfile"); |
| 1313 | } |
| 1314 | |
| 1315 | # If the PERLDB_OPTS variable has options in it, parse those out next. |
| 1316 | if ( defined $ENV{PERLDB_OPTS} ) { |
| 1317 | parse_options( $ENV{PERLDB_OPTS} ); |
| 1318 | } |
| 1319 | |
| 1320 | =pod |
| 1321 | |
| 1322 | The last thing we do during initialization is determine which subroutine is |
| 1323 | to be used to obtain a new terminal when a new debugger is started. Right now, |
| 1324 | the debugger only handles TCP sockets, X11, OS/2, amd Mac OS X |
| 1325 | (darwin). |
| 1326 | |
| 1327 | =cut |
| 1328 | |
| 1329 | # Set up the get_fork_TTY subroutine to be aliased to the proper routine. |
| 1330 | # Works if you're running an xterm or xterm-like window, or you're on |
| 1331 | # OS/2, or on Mac OS X. This may need some expansion. |
| 1332 | |
| 1333 | if (not defined &get_fork_TTY) # only if no routine exists |
| 1334 | { |
| 1335 | if ( defined $remoteport ) { |
| 1336 | # Expect an inetd-like server |
| 1337 | *get_fork_TTY = \&socket_get_fork_TTY; # to listen to us |
| 1338 | } |
| 1339 | elsif (defined $ENV{TERM} # If we know what kind |
| 1340 | # of terminal this is, |
| 1341 | and $ENV{TERM} eq 'xterm' # and it's an xterm, |
| 1342 | and defined $ENV{DISPLAY} # and what display it's on, |
| 1343 | ) |
| 1344 | { |
| 1345 | *get_fork_TTY = \&xterm_get_fork_TTY; # use the xterm version |
| 1346 | } |
| 1347 | elsif ( $ENV{TMUX} ) { |
| 1348 | *get_fork_TTY = \&tmux_get_fork_TTY; |
| 1349 | } |
| 1350 | elsif ( $^O eq 'os2' ) { # If this is OS/2, |
| 1351 | *get_fork_TTY = \&os2_get_fork_TTY; # use the OS/2 version |
| 1352 | } |
| 1353 | elsif ( $^O eq 'darwin' # If this is Mac OS X |
| 1354 | and defined $ENV{TERM_PROGRAM} # and we're running inside |
| 1355 | and $ENV{TERM_PROGRAM} |
| 1356 | eq 'Apple_Terminal' # Terminal.app |
| 1357 | ) |
| 1358 | { |
| 1359 | *get_fork_TTY = \&macosx_get_fork_TTY; # use the Mac OS X version |
| 1360 | } |
| 1361 | } ## end if (not defined &get_fork_TTY... |
| 1362 | |
| 1363 | # untaint $^O, which may have been tainted by the last statement. |
| 1364 | # see bug [perl #24674] |
| 1365 | $^O =~ m/^(.*)\z/; |
| 1366 | $^O = $1; |
| 1367 | |
| 1368 | # Here begin the unreadable code. It needs fixing. |
| 1369 | |
| 1370 | =head2 RESTART PROCESSING |
| 1371 | |
| 1372 | This section handles the restart command. When the C<R> command is invoked, it |
| 1373 | tries to capture all of the state it can into environment variables, and |
| 1374 | then sets C<PERLDB_RESTART>. When we start executing again, we check to see |
| 1375 | if C<PERLDB_RESTART> is there; if so, we reload all the information that |
| 1376 | the R command stuffed into the environment variables. |
| 1377 | |
| 1378 | PERLDB_RESTART - flag only, contains no restart data itself. |
| 1379 | PERLDB_HIST - command history, if it's available |
| 1380 | PERLDB_ON_LOAD - breakpoints set by the rc file |
| 1381 | PERLDB_POSTPONE - subs that have been loaded/not executed, |
| 1382 | and have actions |
| 1383 | PERLDB_VISITED - files that had breakpoints |
| 1384 | PERLDB_FILE_... - breakpoints for a file |
| 1385 | PERLDB_OPT - active options |
| 1386 | PERLDB_INC - the original @INC |
| 1387 | PERLDB_PRETYPE - preprompt debugger actions |
| 1388 | PERLDB_PRE - preprompt Perl code |
| 1389 | PERLDB_POST - post-prompt Perl code |
| 1390 | PERLDB_TYPEAHEAD - typeahead captured by readline() |
| 1391 | |
| 1392 | We chug through all these variables and plug the values saved in them |
| 1393 | back into the appropriate spots in the debugger. |
| 1394 | |
| 1395 | =cut |
| 1396 | |
| 1397 | use vars qw(%postponed_file @typeahead); |
| 1398 | |
| 1399 | our (@hist, @truehist); |
| 1400 | |
| 1401 | sub _restore_shared_globals_after_restart |
| 1402 | { |
| 1403 | @hist = get_list('PERLDB_HIST'); |
| 1404 | %break_on_load = get_list("PERLDB_ON_LOAD"); |
| 1405 | %postponed = get_list("PERLDB_POSTPONE"); |
| 1406 | |
| 1407 | share(@hist); |
| 1408 | share(@truehist); |
| 1409 | share(%break_on_load); |
| 1410 | share(%postponed); |
| 1411 | } |
| 1412 | |
| 1413 | sub _restore_breakpoints_and_actions { |
| 1414 | |
| 1415 | my @had_breakpoints = get_list("PERLDB_VISITED"); |
| 1416 | |
| 1417 | for my $file_idx ( 0 .. $#had_breakpoints ) { |
| 1418 | my $filename = $had_breakpoints[$file_idx]; |
| 1419 | my %pf = get_list("PERLDB_FILE_$file_idx"); |
| 1420 | $postponed_file{ $filename } = \%pf if %pf; |
| 1421 | my @lines = sort {$a <=> $b} keys(%pf); |
| 1422 | my @enabled_statuses = get_list("PERLDB_FILE_ENABLED_$file_idx"); |
| 1423 | for my $line_idx (0 .. $#lines) { |
| 1424 | _set_breakpoint_enabled_status( |
| 1425 | $filename, |
| 1426 | $lines[$line_idx], |
| 1427 | ($enabled_statuses[$line_idx] ? 1 : ''), |
| 1428 | ); |
| 1429 | } |
| 1430 | } |
| 1431 | |
| 1432 | return; |
| 1433 | } |
| 1434 | |
| 1435 | sub _restore_options_after_restart |
| 1436 | { |
| 1437 | my %options_map = get_list("PERLDB_OPT"); |
| 1438 | |
| 1439 | while ( my ( $opt, $val ) = each %options_map ) { |
| 1440 | $val =~ s/[\\\']/\\$1/g; |
| 1441 | parse_options("$opt'$val'"); |
| 1442 | } |
| 1443 | |
| 1444 | return; |
| 1445 | } |
| 1446 | |
| 1447 | sub _restore_globals_after_restart |
| 1448 | { |
| 1449 | # restore original @INC |
| 1450 | @INC = get_list("PERLDB_INC"); |
| 1451 | @ini_INC = @INC; |
| 1452 | |
| 1453 | # return pre/postprompt actions and typeahead buffer |
| 1454 | $pretype = [ get_list("PERLDB_PRETYPE") ]; |
| 1455 | $pre = [ get_list("PERLDB_PRE") ]; |
| 1456 | $post = [ get_list("PERLDB_POST") ]; |
| 1457 | @typeahead = get_list( "PERLDB_TYPEAHEAD", @typeahead ); |
| 1458 | |
| 1459 | return; |
| 1460 | } |
| 1461 | |
| 1462 | |
| 1463 | if ( exists $ENV{PERLDB_RESTART} ) { |
| 1464 | |
| 1465 | # We're restarting, so we don't need the flag that says to restart anymore. |
| 1466 | delete $ENV{PERLDB_RESTART}; |
| 1467 | |
| 1468 | # $restart = 1; |
| 1469 | _restore_shared_globals_after_restart(); |
| 1470 | |
| 1471 | _restore_breakpoints_and_actions(); |
| 1472 | |
| 1473 | # restore options |
| 1474 | _restore_options_after_restart(); |
| 1475 | |
| 1476 | _restore_globals_after_restart(); |
| 1477 | } ## end if (exists $ENV{PERLDB_RESTART... |
| 1478 | |
| 1479 | =head2 SETTING UP THE TERMINAL |
| 1480 | |
| 1481 | Now, we'll decide how the debugger is going to interact with the user. |
| 1482 | If there's no TTY, we set the debugger to run non-stop; there's not going |
| 1483 | to be anyone there to enter commands. |
| 1484 | |
| 1485 | =cut |
| 1486 | |
| 1487 | use vars qw($notty $console $tty $LINEINFO); |
| 1488 | use vars qw($lineinfo $doccmd); |
| 1489 | |
| 1490 | our ($runnonstop); |
| 1491 | |
| 1492 | # Local autoflush to avoid rt#116769, |
| 1493 | # as calling IO::File methods causes an unresolvable loop |
| 1494 | # that results in debugger failure. |
| 1495 | sub _autoflush { |
| 1496 | my $o = select($_[0]); |
| 1497 | $|++; |
| 1498 | select($o); |
| 1499 | } |
| 1500 | |
| 1501 | if ($notty) { |
| 1502 | $runnonstop = 1; |
| 1503 | share($runnonstop); |
| 1504 | } |
| 1505 | |
| 1506 | =pod |
| 1507 | |
| 1508 | If there is a TTY, we have to determine who it belongs to before we can |
| 1509 | proceed. If this is a client editor or graphical debugger (denoted by |
| 1510 | the first command-line switch being '-emacs'), we shift this off and |
| 1511 | set C<$rl> to 0 (XXX ostensibly to do straight reads). |
| 1512 | |
| 1513 | =cut |
| 1514 | |
| 1515 | else { |
| 1516 | |
| 1517 | # Is Perl being run from a client editor or graphical debugger? |
| 1518 | # If so, don't use readline, and set $client_editor = 1. |
| 1519 | if ($client_editor = ( @main::ARGV && ( $main::ARGV[0] eq '-emacs' ) )) { |
| 1520 | $rl = 0; |
| 1521 | shift(@main::ARGV); |
| 1522 | } |
| 1523 | |
| 1524 | #require Term::ReadLine; |
| 1525 | |
| 1526 | =pod |
| 1527 | |
| 1528 | We then determine what the console should be on various systems: |
| 1529 | |
| 1530 | =over 4 |
| 1531 | |
| 1532 | =item * Cygwin - We use C<stdin> instead of a separate device. |
| 1533 | |
| 1534 | =cut |
| 1535 | |
| 1536 | if ( $^O eq 'cygwin' ) { |
| 1537 | |
| 1538 | # /dev/tty is binary. use stdin for textmode |
| 1539 | undef $console; |
| 1540 | } |
| 1541 | |
| 1542 | =item * Windows - use C<con>. |
| 1543 | |
| 1544 | =cut |
| 1545 | |
| 1546 | elsif ( $^O eq 'MSWin32' and -e "con" ) { |
| 1547 | $console = "con"; |
| 1548 | } |
| 1549 | |
| 1550 | =item * AmigaOS - use C<CONSOLE:>. |
| 1551 | |
| 1552 | =cut |
| 1553 | |
| 1554 | elsif ( $^O eq 'amigaos' ) { |
| 1555 | $console = "CONSOLE:"; |
| 1556 | } |
| 1557 | |
| 1558 | =item * VMS - use C<sys$command>. |
| 1559 | |
| 1560 | =cut |
| 1561 | |
| 1562 | elsif ($^O eq 'VMS') { |
| 1563 | $console = 'sys$command'; |
| 1564 | } |
| 1565 | |
| 1566 | # Keep this penultimate, on the grounds that it satisfies a wide variety of |
| 1567 | # Unix-like systems that would otherwise need to be identified individually. |
| 1568 | |
| 1569 | =item * Unix - use F</dev/tty>. |
| 1570 | |
| 1571 | =cut |
| 1572 | |
| 1573 | elsif ( -e "/dev/tty" ) { |
| 1574 | $console = "/dev/tty"; |
| 1575 | } |
| 1576 | |
| 1577 | # Keep this last. |
| 1578 | |
| 1579 | else { |
| 1580 | _db_warn("Can't figure out your console, using stdin"); |
| 1581 | undef $console; |
| 1582 | } |
| 1583 | |
| 1584 | =pod |
| 1585 | |
| 1586 | =back |
| 1587 | |
| 1588 | Several other systems don't use a specific console. We S<C<undef $console>> |
| 1589 | for those (Windows using a client editor/graphical debugger, OS/2 |
| 1590 | with a client editor). |
| 1591 | |
| 1592 | =cut |
| 1593 | |
| 1594 | if ( ( $^O eq 'MSWin32' ) and ( $client_editor or defined $ENV{EMACS} ) ) { |
| 1595 | |
| 1596 | # /dev/tty is binary. use stdin for textmode |
| 1597 | $console = undef; |
| 1598 | } |
| 1599 | |
| 1600 | # In OS/2, we need to use STDIN to get textmode too, even though |
| 1601 | # it pretty much looks like Unix otherwise. |
| 1602 | if ( defined $ENV{OS2_SHELL} and ( $client_editor or $ENV{WINDOWID} ) ) |
| 1603 | { # In OS/2 |
| 1604 | $console = undef; |
| 1605 | } |
| 1606 | |
| 1607 | =pod |
| 1608 | |
| 1609 | If there is a TTY hanging around from a parent, we use that as the console. |
| 1610 | |
| 1611 | =cut |
| 1612 | |
| 1613 | $console = $tty if defined $tty; |
| 1614 | |
| 1615 | =head2 SOCKET HANDLING |
| 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. |
| 1627 | |
| 1628 | if ( defined $remoteport ) { |
| 1629 | |
| 1630 | # If RemotePort was defined in the options, connect input and output |
| 1631 | # to the socket. |
| 1632 | $IN = $OUT = connect_remoteport(); |
| 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 { |
| 1647 | |
| 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 |
| 1650 | # filehandle, and do the necessary mojo to create a new tty if we |
| 1651 | # know how, and we can. |
| 1652 | create_IN_OUT(4) if $CreateTTY & 4; |
| 1653 | if ($console) { |
| 1654 | |
| 1655 | # If we have a console, check to see if there are separate ins and |
| 1656 | # outs to open. (They are assumed identical if not.) |
| 1657 | |
| 1658 | my ( $i, $o ) = split /,/, $console; |
| 1659 | $o = $i unless defined $o; |
| 1660 | |
| 1661 | # read/write on in, or just read, or read on STDIN. |
| 1662 | open( IN, '+<', $i ) |
| 1663 | || open( IN, '<', $i ) |
| 1664 | || open( IN, "<&STDIN" ); |
| 1665 | |
| 1666 | # read/write/create/clobber out, or write/create/clobber out, |
| 1667 | # or merge with STDERR, or merge with STDOUT. |
| 1668 | open( OUT, '+>', $o ) |
| 1669 | || open( OUT, '>', $o ) |
| 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'; |
| 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. |
| 1687 | if ($console or (not defined($console))) { |
| 1688 | $IN = \*IN; |
| 1689 | $OUT = \*OUT; |
| 1690 | } |
| 1691 | } ## end elsif (from if(defined $remoteport)) |
| 1692 | |
| 1693 | # Unbuffer DB::OUT. We need to see responses right away. |
| 1694 | _autoflush($OUT); |
| 1695 | |
| 1696 | # Line info goes to debugger output unless pointed elsewhere. |
| 1697 | # Pointing elsewhere makes it possible for client 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; |
| 1702 | # share($LINEINFO); # <- unable to share globs |
| 1703 | share($lineinfo); # |
| 1704 | |
| 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 |
| 1711 | |
| 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 | $client_editor ? "enabled" : "available", ".\n" |
| 1725 | ); |
| 1726 | print $OUT |
| 1727 | "\nEnter h or 'h h' for help, or '$doccmd perldebug' for more help.\n\n"; |
| 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? |
| 1734 | @ARGS = @ARGV; |
| 1735 | # for (@args) { |
| 1736 | # Make sure backslashes before single quotes are stripped out, and |
| 1737 | # keep args unless they are numeric (XXX why?) |
| 1738 | # s/\'/\\\'/g; # removed while not justified understandably |
| 1739 | # s/(.*)/'$1'/ unless /^-?[\d.]+$/; # ditto |
| 1740 | # } |
| 1741 | |
| 1742 | # If there was an afterinit() sub defined, call it. It will get |
| 1743 | # executed in our scope, so it can fiddle with debugger globals. |
| 1744 | if ( defined &afterinit ) { # May be defined in $rcfile |
| 1745 | afterinit(); |
| 1746 | } |
| 1747 | |
| 1748 | # Inform us about "Stack dump during die enabled ..." in dieLevel(). |
| 1749 | use vars qw($I_m_init); |
| 1750 | |
| 1751 | $I_m_init = 1; |
| 1752 | |
| 1753 | ############################################################ Subroutines |
| 1754 | |
| 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 |
| 1762 | them, and then send execution off to the next statement. |
| 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 |
| 1766 | to create other commands to be executed later. This is all highly I<optimized> |
| 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 | |
| 1772 | # $cmd cannot be an our() variable unfortunately (possible perl bug?). |
| 1773 | |
| 1774 | use vars qw( |
| 1775 | $action |
| 1776 | $cmd |
| 1777 | $file |
| 1778 | $filename_ini |
| 1779 | $finished |
| 1780 | %had_breakpoints |
| 1781 | $level |
| 1782 | $max |
| 1783 | $package |
| 1784 | $try |
| 1785 | ); |
| 1786 | |
| 1787 | our ( |
| 1788 | %alias, |
| 1789 | $doret, |
| 1790 | $end, |
| 1791 | $fall_off_end, |
| 1792 | $incr, |
| 1793 | $laststep, |
| 1794 | $rc, |
| 1795 | $sh, |
| 1796 | $stack_depth, |
| 1797 | @stack, |
| 1798 | @to_watch, |
| 1799 | @old_watch, |
| 1800 | ); |
| 1801 | |
| 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}"; |
| 1823 | # The &-call is here to ascertain the mutability of @_. |
| 1824 | &DB::eval; |
| 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 | |
| 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 | |
| 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 | |
| 1852 | # ... and it belongs to this PID or we get one for this PID ... |
| 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 | |
| 1868 | sub _DB__trim_command_and_return_first_component { |
| 1869 | my ($obj) = @_; |
| 1870 | |
| 1871 | $cmd =~ s/\A\s+//s; # trim annoying leading whitespace |
| 1872 | $cmd =~ s/\s+\z//s; # trim annoying trailing whitespace |
| 1873 | |
| 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; |
| 1878 | |
| 1879 | $obj->cmd_verb($verb); |
| 1880 | $obj->cmd_args($args); |
| 1881 | |
| 1882 | return; |
| 1883 | } |
| 1884 | |
| 1885 | sub _DB__handle_f_command { |
| 1886 | my ($obj) = @_; |
| 1887 | |
| 1888 | if ($file = $obj->cmd_args) { |
| 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 | |
| 1933 | sub _DB__handle_dot_command { |
| 1934 | my ($obj) = @_; |
| 1935 | |
| 1936 | # . command. |
| 1937 | if ($obj->_is_full('.')) { |
| 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 | |
| 1954 | sub _DB__handle_y_command { |
| 1955 | my ($obj) = @_; |
| 1956 | |
| 1957 | if (my ($match_level, $match_vars) |
| 1958 | = $obj->cmd_args =~ /\A(?:(\d*)\s*(.*))?\z/) { |
| 1959 | |
| 1960 | # See if we've got the necessary support. |
| 1961 | if (!eval { |
| 1962 | local @INC = @INC; |
| 1963 | pop @INC if $INC[-1] eq '.'; |
| 1964 | require PadWalker; PadWalker->VERSION(0.08) }) { |
| 1965 | my $Err = $@; |
| 1966 | _db_warn( |
| 1967 | $Err =~ /locate/ |
| 1968 | ? "PadWalker module not found - please install\n" |
| 1969 | : $Err |
| 1970 | ); |
| 1971 | next CMD; |
| 1972 | } |
| 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. |
| 1984 | my $h = eval { PadWalker::peek_my( ( $match_level || 0 ) + 2 ) }; |
| 1985 | |
| 1986 | # Oops. Can't find it. |
| 1987 | if (my $Err = $@) { |
| 1988 | $Err =~ s/ at .*//; |
| 1989 | _db_warn($Err); |
| 1990 | next CMD; |
| 1991 | } |
| 1992 | |
| 1993 | # Show the desired vars with dumplex(). |
| 1994 | my $savout = select($OUT); |
| 1995 | |
| 1996 | # Have dumplex dump the lexicals. |
| 1997 | foreach my $key (sort keys %$h) { |
| 1998 | dumpvar::dumplex( $key, $h->{$key}, |
| 1999 | defined $option{dumpDepth} ? $option{dumpDepth} : -1, |
| 2000 | @vars ); |
| 2001 | } |
| 2002 | select($savout); |
| 2003 | next CMD; |
| 2004 | } |
| 2005 | } |
| 2006 | |
| 2007 | sub _DB__handle_c_command { |
| 2008 | my ($obj) = @_; |
| 2009 | |
| 2010 | my $i = $obj->cmd_args; |
| 2011 | |
| 2012 | if ($i =~ m#\A[\w:]*\z#) { |
| 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. |
| 2019 | $subname = $i; |
| 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. |
| 2042 | ( $file, $i ) = ( find_sub($subname) =~ /^(.*):(.*)$/ ); |
| 2043 | |
| 2044 | # Force the line number to be numeric. |
| 2045 | $i = $i + 0; |
| 2046 | |
| 2047 | # If we got a line number, we found the sub. |
| 2048 | if ($i) { |
| 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; |
| 2061 | my $_line_num = $i; |
| 2062 | while ($dbline[$_line_num] == 0 && $_line_num< $max) |
| 2063 | { |
| 2064 | $_line_num++; |
| 2065 | } |
| 2066 | $i = $_line_num; |
| 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. |
| 2097 | if ($i) { |
| 2098 | |
| 2099 | # Breakable? |
| 2100 | if ( $dbline[$i] == 0 ) { |
| 2101 | print $OUT "Line $i not breakable.\n"; |
| 2102 | next CMD; |
| 2103 | } |
| 2104 | |
| 2105 | # Yes. Set up the one-time-break sigil. |
| 2106 | $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p. |
| 2107 | _enable_breakpoint_temp_enabled_status($filename, $i); |
| 2108 | } ## end if ($i) |
| 2109 | |
| 2110 | # Turn off stack tracing from here up. |
| 2111 | for my $j (0 .. $stack_depth) { |
| 2112 | $stack[ $j ] &= ~1; |
| 2113 | } |
| 2114 | last CMD; |
| 2115 | } |
| 2116 | |
| 2117 | return; |
| 2118 | } |
| 2119 | |
| 2120 | my $sub_twice = chr utf8::unicode_to_native(032); |
| 2121 | $sub_twice = $sub_twice x 2; |
| 2122 | |
| 2123 | sub _DB__handle_forward_slash_command { |
| 2124 | my ($obj) = @_; |
| 2125 | |
| 2126 | # The pattern as a string. |
| 2127 | use vars qw($inpat); |
| 2128 | |
| 2129 | if (($inpat) = $cmd =~ m#\A/(.*)\z#) { |
| 2130 | |
| 2131 | # Remove the final slash. |
| 2132 | $inpat =~ s:([^\\])/$:$1:; |
| 2133 | |
| 2134 | # If the pattern isn't null ... |
| 2135 | if ( $inpat ne "" ) { |
| 2136 | |
| 2137 | # Turn off warn and die processing for a bit. |
| 2138 | local $SIG{__DIE__}; |
| 2139 | local $SIG{__WARN__}; |
| 2140 | |
| 2141 | # Create the pattern. |
| 2142 | eval 'no strict q/vars/; $inpat =~ m' . "\a$inpat\a"; |
| 2143 | if ( $@ ne "" ) { |
| 2144 | |
| 2145 | # Oops. Bad pattern. No biscuit. |
| 2146 | # Print the eval error and go back for more |
| 2147 | # commands. |
| 2148 | print {$OUT} "$@"; |
| 2149 | next CMD; |
| 2150 | } |
| 2151 | $obj->pat($inpat); |
| 2152 | } ## end if ($inpat ne "") |
| 2153 | |
| 2154 | # Set up to stop on wrap-around. |
| 2155 | $end = $start; |
| 2156 | |
| 2157 | # Don't move off the current line. |
| 2158 | $incr = -1; |
| 2159 | |
| 2160 | my $pat = $obj->pat; |
| 2161 | |
| 2162 | # Done in eval so nothing breaks if the pattern |
| 2163 | # does something weird. |
| 2164 | eval |
| 2165 | { |
| 2166 | no strict q/vars/; |
| 2167 | for (;;) { |
| 2168 | # Move ahead one line. |
| 2169 | ++$start; |
| 2170 | |
| 2171 | # Wrap if we pass the last line. |
| 2172 | if ($start > $max) { |
| 2173 | $start = 1; |
| 2174 | } |
| 2175 | |
| 2176 | # Stop if we have gotten back to this line again, |
| 2177 | last if ($start == $end); |
| 2178 | |
| 2179 | # A hit! (Note, though, that we are doing |
| 2180 | # case-insensitive matching. Maybe a qr// |
| 2181 | # expression would be better, so the user could |
| 2182 | # do case-sensitive matching if desired. |
| 2183 | if ($dbline[$start] =~ m/$pat/i) { |
| 2184 | if ($client_editor) { |
| 2185 | # Handle proper escaping in the client. |
| 2186 | print {$OUT} "$sub_twice$filename:$start:0\n"; |
| 2187 | } |
| 2188 | else { |
| 2189 | # Just print the line normally. |
| 2190 | print {$OUT} "$start:\t",$dbline[$start],"\n"; |
| 2191 | } |
| 2192 | # And quit since we found something. |
| 2193 | last; |
| 2194 | } |
| 2195 | } |
| 2196 | }; |
| 2197 | |
| 2198 | if ($@) { |
| 2199 | warn $@; |
| 2200 | } |
| 2201 | |
| 2202 | # If we wrapped, there never was a match. |
| 2203 | if ( $start == $end ) { |
| 2204 | print {$OUT} "/$pat/: not found\n"; |
| 2205 | } |
| 2206 | next CMD; |
| 2207 | } |
| 2208 | |
| 2209 | return; |
| 2210 | } |
| 2211 | |
| 2212 | sub _DB__handle_question_mark_command { |
| 2213 | my ($obj) = @_; |
| 2214 | |
| 2215 | # ? - backward pattern search. |
| 2216 | if (my ($inpat) = $cmd =~ m#\A\?(.*)\z#) { |
| 2217 | |
| 2218 | # Get the pattern, remove trailing question mark. |
| 2219 | $inpat =~ s:([^\\])\?$:$1:; |
| 2220 | |
| 2221 | # If we've got one ... |
| 2222 | if ( $inpat ne "" ) { |
| 2223 | |
| 2224 | # Turn off die & warn handlers. |
| 2225 | local $SIG{__DIE__}; |
| 2226 | local $SIG{__WARN__}; |
| 2227 | eval '$inpat =~ m' . "\a$inpat\a"; |
| 2228 | |
| 2229 | if ( $@ ne "" ) { |
| 2230 | |
| 2231 | # Ouch. Not good. Print the error. |
| 2232 | print $OUT $@; |
| 2233 | next CMD; |
| 2234 | } |
| 2235 | $obj->pat($inpat); |
| 2236 | } ## end if ($inpat ne "") |
| 2237 | |
| 2238 | # Where we are now is where to stop after wraparound. |
| 2239 | $end = $start; |
| 2240 | |
| 2241 | # Don't move away from this line. |
| 2242 | $incr = -1; |
| 2243 | |
| 2244 | my $pat = $obj->pat; |
| 2245 | # Search inside the eval to prevent pattern badness |
| 2246 | # from killing us. |
| 2247 | eval { |
| 2248 | no strict q/vars/; |
| 2249 | for (;;) { |
| 2250 | # Back up a line. |
| 2251 | --$start; |
| 2252 | |
| 2253 | # Wrap if we pass the first line. |
| 2254 | |
| 2255 | $start = $max if ($start <= 0); |
| 2256 | |
| 2257 | # Quit if we get back where we started, |
| 2258 | last if ($start == $end); |
| 2259 | |
| 2260 | # Match? |
| 2261 | if ($dbline[$start] =~ m/$pat/i) { |
| 2262 | if ($client_editor) { |
| 2263 | # Yep, follow client editor requirements. |
| 2264 | print $OUT "$sub_twice$filename:$start:0\n"; |
| 2265 | } |
| 2266 | else { |
| 2267 | # Yep, just print normally. |
| 2268 | print $OUT "$start:\t",$dbline[$start],"\n"; |
| 2269 | } |
| 2270 | |
| 2271 | # Found, so done. |
| 2272 | last; |
| 2273 | } |
| 2274 | } |
| 2275 | }; |
| 2276 | |
| 2277 | # Say we failed if the loop never found anything, |
| 2278 | if ( $start == $end ) { |
| 2279 | print {$OUT} "?$pat?: not found\n"; |
| 2280 | } |
| 2281 | next CMD; |
| 2282 | } |
| 2283 | |
| 2284 | return; |
| 2285 | } |
| 2286 | |
| 2287 | sub _DB__handle_restart_and_rerun_commands { |
| 2288 | my ($obj) = @_; |
| 2289 | |
| 2290 | my $cmd_cmd = $obj->cmd_verb; |
| 2291 | my $cmd_params = $obj->cmd_args; |
| 2292 | # R - restart execution. |
| 2293 | # rerun - controlled restart execution. |
| 2294 | if ($cmd_cmd eq 'rerun' or $cmd_params eq '') { |
| 2295 | |
| 2296 | # Change directory to the initial current working directory on |
| 2297 | # the script startup, so if the debugged program changed the |
| 2298 | # directory, then we will still be able to find the path to the |
| 2299 | # program. (perl 5 RT #121509 ). |
| 2300 | chdir ($_initial_cwd); |
| 2301 | |
| 2302 | my @args = ($cmd_cmd eq 'R' ? restart() : rerun($cmd_params)); |
| 2303 | |
| 2304 | # Close all non-system fds for a clean restart. A more |
| 2305 | # correct method would be to close all fds that were not |
| 2306 | # open when the process started, but this seems to be |
| 2307 | # hard. See "debugger 'R'estart and open database |
| 2308 | # connections" on p5p. |
| 2309 | |
| 2310 | my $max_fd = 1024; # default if POSIX can't be loaded |
| 2311 | if (eval { require POSIX }) { |
| 2312 | eval { $max_fd = POSIX::sysconf(POSIX::_SC_OPEN_MAX()) }; |
| 2313 | } |
| 2314 | |
| 2315 | if (defined $max_fd) { |
| 2316 | foreach ($^F+1 .. $max_fd-1) { |
| 2317 | next unless open FD_TO_CLOSE, "<&=$_"; |
| 2318 | close(FD_TO_CLOSE); |
| 2319 | } |
| 2320 | } |
| 2321 | |
| 2322 | # And run Perl again. We use exec() to keep the |
| 2323 | # PID stable (and that way $ini_pids is still valid). |
| 2324 | exec(@args) or print {$OUT} "exec failed: $!\n"; |
| 2325 | |
| 2326 | last CMD; |
| 2327 | } |
| 2328 | |
| 2329 | return; |
| 2330 | } |
| 2331 | |
| 2332 | sub _DB__handle_run_command_in_pager_command { |
| 2333 | my ($obj) = @_; |
| 2334 | |
| 2335 | if ($cmd =~ m#\A\|\|?\s*[^|]#) { |
| 2336 | if ( $pager =~ /^\|/ ) { |
| 2337 | |
| 2338 | # Default pager is into a pipe. Redirect I/O. |
| 2339 | open( SAVEOUT, ">&STDOUT" ) |
| 2340 | || _db_warn("Can't save STDOUT"); |
| 2341 | open( STDOUT, ">&OUT" ) |
| 2342 | || _db_warn("Can't redirect STDOUT"); |
| 2343 | } ## end if ($pager =~ /^\|/) |
| 2344 | else { |
| 2345 | |
| 2346 | # Not into a pipe. STDOUT is safe. |
| 2347 | open( SAVEOUT, ">&OUT" ) || _db_warn("Can't save DB::OUT"); |
| 2348 | } |
| 2349 | |
| 2350 | # Fix up environment to record we have less if so. |
| 2351 | fix_less(); |
| 2352 | |
| 2353 | unless ( $obj->piped(scalar ( open( OUT, $pager ) ) ) ) { |
| 2354 | |
| 2355 | # Couldn't open pipe to pager. |
| 2356 | _db_warn("Can't pipe output to '$pager'"); |
| 2357 | if ( $pager =~ /^\|/ ) { |
| 2358 | |
| 2359 | # Redirect I/O back again. |
| 2360 | open( OUT, ">&STDOUT" ) # XXX: lost message |
| 2361 | || _db_warn("Can't restore DB::OUT"); |
| 2362 | open( STDOUT, ">&SAVEOUT" ) |
| 2363 | || _db_warn("Can't restore STDOUT"); |
| 2364 | close(SAVEOUT); |
| 2365 | } ## end if ($pager =~ /^\|/) |
| 2366 | else { |
| 2367 | |
| 2368 | # Redirect I/O. STDOUT already safe. |
| 2369 | open( OUT, ">&STDOUT" ) # XXX: lost message |
| 2370 | || _db_warn("Can't restore DB::OUT"); |
| 2371 | } |
| 2372 | next CMD; |
| 2373 | } ## end unless ($piped = open(OUT,... |
| 2374 | |
| 2375 | # Set up broken-pipe handler if necessary. |
| 2376 | $SIG{PIPE} = \&DB::catch |
| 2377 | if $pager =~ /^\|/ |
| 2378 | && ( "" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE} ); |
| 2379 | |
| 2380 | _autoflush(\*OUT); |
| 2381 | # Save current filehandle, and put it back. |
| 2382 | $obj->selected(scalar( select(OUT) )); |
| 2383 | # Don't put it back if pager was a pipe. |
| 2384 | if ($cmd !~ /\A\|\|/) |
| 2385 | { |
| 2386 | select($obj->selected()); |
| 2387 | $obj->selected(""); |
| 2388 | } |
| 2389 | |
| 2390 | # Trim off the pipe symbols and run the command now. |
| 2391 | $cmd =~ s#\A\|+\s*##; |
| 2392 | redo PIPE; |
| 2393 | } |
| 2394 | |
| 2395 | return; |
| 2396 | } |
| 2397 | |
| 2398 | sub _DB__handle_m_command { |
| 2399 | my ($obj) = @_; |
| 2400 | |
| 2401 | if ($cmd =~ s#\Am\s+([\w:]+)\s*\z# #) { |
| 2402 | methods($1); |
| 2403 | next CMD; |
| 2404 | } |
| 2405 | |
| 2406 | # m expr - set up DB::eval to do the work |
| 2407 | if ($cmd =~ s#\Am\b# #) { # Rest gets done by DB::eval() |
| 2408 | $onetimeDump = 'methods'; # method output gets used there |
| 2409 | } |
| 2410 | |
| 2411 | return; |
| 2412 | } |
| 2413 | |
| 2414 | sub _DB__at_end_of_every_command { |
| 2415 | my ($obj) = @_; |
| 2416 | |
| 2417 | # At the end of every command: |
| 2418 | if ($obj->piped) { |
| 2419 | |
| 2420 | # Unhook the pipe mechanism now. |
| 2421 | if ( $pager =~ /^\|/ ) { |
| 2422 | |
| 2423 | # No error from the child. |
| 2424 | $? = 0; |
| 2425 | |
| 2426 | # we cannot warn here: the handle is missing --tchrist |
| 2427 | close(OUT) || print SAVEOUT "\nCan't close DB::OUT\n"; |
| 2428 | |
| 2429 | # most of the $? crud was coping with broken cshisms |
| 2430 | # $? is explicitly set to 0, so this never runs. |
| 2431 | if ($?) { |
| 2432 | print SAVEOUT "Pager '$pager' failed: "; |
| 2433 | if ( $? == -1 ) { |
| 2434 | print SAVEOUT "shell returned -1\n"; |
| 2435 | } |
| 2436 | elsif ( $? >> 8 ) { |
| 2437 | print SAVEOUT ( $? & 127 ) |
| 2438 | ? " (SIG#" . ( $? & 127 ) . ")" |
| 2439 | : "", ( $? & 128 ) ? " -- core dumped" : "", "\n"; |
| 2440 | } |
| 2441 | else { |
| 2442 | print SAVEOUT "status ", ( $? >> 8 ), "\n"; |
| 2443 | } |
| 2444 | } ## end if ($?) |
| 2445 | |
| 2446 | # Reopen filehandle for our output (if we can) and |
| 2447 | # restore STDOUT (if we can). |
| 2448 | open( OUT, ">&STDOUT" ) || _db_warn("Can't restore DB::OUT"); |
| 2449 | open( STDOUT, ">&SAVEOUT" ) |
| 2450 | || _db_warn("Can't restore STDOUT"); |
| 2451 | |
| 2452 | # Turn off pipe exception handler if necessary. |
| 2453 | $SIG{PIPE} = "DEFAULT" if $SIG{PIPE} eq \&DB::catch; |
| 2454 | |
| 2455 | # Will stop ignoring SIGPIPE if done like nohup(1) |
| 2456 | # does SIGINT but Perl doesn't give us a choice. |
| 2457 | } ## end if ($pager =~ /^\|/) |
| 2458 | else { |
| 2459 | |
| 2460 | # Non-piped "pager". Just restore STDOUT. |
| 2461 | open( OUT, ">&SAVEOUT" ) || _db_warn("Can't restore DB::OUT"); |
| 2462 | } |
| 2463 | |
| 2464 | # Let Readline know about the new filehandles. |
| 2465 | reset_IN_OUT( \*IN, \*OUT ); |
| 2466 | |
| 2467 | # Close filehandle pager was using, restore the normal one |
| 2468 | # if necessary, |
| 2469 | close(SAVEOUT); |
| 2470 | |
| 2471 | if ($obj->selected() ne "") { |
| 2472 | select($obj->selected); |
| 2473 | $obj->selected(""); |
| 2474 | } |
| 2475 | |
| 2476 | # No pipes now. |
| 2477 | $obj->piped(""); |
| 2478 | } ## end if ($piped) |
| 2479 | |
| 2480 | return; |
| 2481 | } |
| 2482 | |
| 2483 | sub _DB__handle_watch_expressions |
| 2484 | { |
| 2485 | my $self = shift; |
| 2486 | |
| 2487 | if ( $DB::trace & 2 ) { |
| 2488 | for my $n (0 .. $#DB::to_watch) { |
| 2489 | $DB::evalarg = $DB::to_watch[$n]; |
| 2490 | local $DB::onetimeDump; # Tell DB::eval() to not output results |
| 2491 | |
| 2492 | # Fix context DB::eval() wants to return an array, but |
| 2493 | # we need a scalar here. |
| 2494 | my ($val) = join( "', '", DB::eval(@_) ); |
| 2495 | $val = ( ( defined $val ) ? "'$val'" : 'undef' ); |
| 2496 | |
| 2497 | # Did it change? |
| 2498 | if ( $val ne $DB::old_watch[$n] ) { |
| 2499 | |
| 2500 | # Yep! Show the difference, and fake an interrupt. |
| 2501 | $DB::signal = 1; |
| 2502 | print {$DB::OUT} <<EOP; |
| 2503 | Watchpoint $n:\t$DB::to_watch[$n] changed: |
| 2504 | old value:\t$DB::old_watch[$n] |
| 2505 | new value:\t$val |
| 2506 | EOP |
| 2507 | $DB::old_watch[$n] = $val; |
| 2508 | } ## end if ($val ne $old_watch... |
| 2509 | } ## end for my $n (0 .. |
| 2510 | } ## end if ($trace & 2) |
| 2511 | |
| 2512 | return; |
| 2513 | } |
| 2514 | |
| 2515 | =head3 C<_DB__handle_i_command> - inheritance display |
| 2516 | |
| 2517 | Display the (nested) parentage of the module or object given. |
| 2518 | |
| 2519 | =cut |
| 2520 | |
| 2521 | sub _DB__handle_i_command { |
| 2522 | my $self = shift; |
| 2523 | |
| 2524 | my $line = $self->cmd_args; |
| 2525 | require mro; |
| 2526 | foreach my $isa ( split( /\s+/, $line ) ) { |
| 2527 | $evalarg = "$isa"; |
| 2528 | # The &-call is here to ascertain the mutability of @_. |
| 2529 | ($isa) = &DB::eval; |
| 2530 | no strict 'refs'; |
| 2531 | print join( |
| 2532 | ', ', |
| 2533 | map { |
| 2534 | "$_" |
| 2535 | . ( |
| 2536 | defined( ${"$_\::VERSION"} ) |
| 2537 | ? ' ' . ${"$_\::VERSION"} |
| 2538 | : undef ) |
| 2539 | } @{mro::get_linear_isa(ref($isa) || $isa)} |
| 2540 | ); |
| 2541 | print "\n"; |
| 2542 | } |
| 2543 | next CMD; |
| 2544 | } |
| 2545 | |
| 2546 | =head3 C<_cmd_l_main> - list lines (command) |
| 2547 | |
| 2548 | Most of the command is taken up with transforming all the different line |
| 2549 | specification syntaxes into 'start-stop'. After that is done, the command |
| 2550 | runs a loop over C<@dbline> for the specified range of lines. It handles |
| 2551 | the printing of each line and any markers (C<==E<gt>> for current line, |
| 2552 | C<b> for break on this line, C<a> for action on this line, C<:> for this |
| 2553 | line breakable). |
| 2554 | |
| 2555 | We save the last line listed in the C<$start> global for further listing |
| 2556 | later. |
| 2557 | |
| 2558 | =cut |
| 2559 | |
| 2560 | sub _min { |
| 2561 | my $min = shift; |
| 2562 | foreach my $v (@_) { |
| 2563 | if ($min > $v) { |
| 2564 | $min = $v; |
| 2565 | } |
| 2566 | } |
| 2567 | return $min; |
| 2568 | } |
| 2569 | |
| 2570 | sub _max { |
| 2571 | my $max = shift; |
| 2572 | foreach my $v (@_) { |
| 2573 | if ($max < $v) { |
| 2574 | $max = $v; |
| 2575 | } |
| 2576 | } |
| 2577 | return $max; |
| 2578 | } |
| 2579 | |
| 2580 | sub _minify_to_max { |
| 2581 | my $ref = shift; |
| 2582 | |
| 2583 | $$ref = _min($$ref, $max); |
| 2584 | |
| 2585 | return; |
| 2586 | } |
| 2587 | |
| 2588 | sub _cmd_l_handle_var_name { |
| 2589 | my $var_name = shift; |
| 2590 | |
| 2591 | $evalarg = $var_name; |
| 2592 | |
| 2593 | my ($s) = DB::eval(); |
| 2594 | |
| 2595 | # Ooops. Bad scalar. |
| 2596 | if ($@) { |
| 2597 | print {$OUT} "Error: $@\n"; |
| 2598 | next CMD; |
| 2599 | } |
| 2600 | |
| 2601 | # Good scalar. If it's a reference, find what it points to. |
| 2602 | $s = CvGV_name($s); |
| 2603 | print {$OUT} "Interpreted as: $1 $s\n"; |
| 2604 | $line = "$1 $s"; |
| 2605 | |
| 2606 | # Call self recursively to really do the command. |
| 2607 | return _cmd_l_main( $s ); |
| 2608 | } |
| 2609 | |
| 2610 | sub _cmd_l_handle_subname { |
| 2611 | |
| 2612 | my $s = my $subname = shift; |
| 2613 | |
| 2614 | # De-Perl4. |
| 2615 | $subname =~ s/\'/::/; |
| 2616 | |
| 2617 | # Put it in this package unless it starts with ::. |
| 2618 | $subname = $package . "::" . $subname unless $subname =~ /::/; |
| 2619 | |
| 2620 | # Put it in CORE::GLOBAL if t doesn't start with :: and |
| 2621 | # it doesn't live in this package and it lives in CORE::GLOBAL. |
| 2622 | $subname = "CORE::GLOBAL::$s" |
| 2623 | if not defined &$subname |
| 2624 | and $s !~ /::/ |
| 2625 | and defined &{"CORE::GLOBAL::$s"}; |
| 2626 | |
| 2627 | # Put leading '::' names into 'main::'. |
| 2628 | $subname = "main" . $subname if substr( $subname, 0, 2 ) eq "::"; |
| 2629 | |
| 2630 | # Get name:start-stop from find_sub, and break this up at |
| 2631 | # colons. |
| 2632 | my @pieces = split( /:/, find_sub($subname) || $sub{$subname} ); |
| 2633 | |
| 2634 | # Pull off start-stop. |
| 2635 | my $subrange = pop @pieces; |
| 2636 | |
| 2637 | # If the name contained colons, the split broke it up. |
| 2638 | # Put it back together. |
| 2639 | $file = join( ':', @pieces ); |
| 2640 | |
| 2641 | # If we're not in that file, switch over to it. |
| 2642 | if ( $file ne $filename ) { |
| 2643 | if (! $client_editor) { |
| 2644 | print {$OUT} "Switching to file '$file'.\n"; |
| 2645 | } |
| 2646 | |
| 2647 | # Switch debugger's magic structures. |
| 2648 | *dbline = $main::{ '_<' . $file }; |
| 2649 | $max = $#dbline; |
| 2650 | $filename = $file; |
| 2651 | } ## end if ($file ne $filename) |
| 2652 | |
| 2653 | # Subrange is 'start-stop'. If this is less than a window full, |
| 2654 | # swap it to 'start+', which will list a window from the start point. |
| 2655 | if ($subrange) { |
| 2656 | if ( eval($subrange) < -$window ) { |
| 2657 | $subrange =~ s/-.*/+/; |
| 2658 | } |
| 2659 | |
| 2660 | # Call self recursively to list the range. |
| 2661 | return _cmd_l_main( $subrange ); |
| 2662 | } ## end if ($subrange) |
| 2663 | |
| 2664 | # Couldn't find it. |
| 2665 | else { |
| 2666 | print {$OUT} "Subroutine $subname not found.\n"; |
| 2667 | return; |
| 2668 | } |
| 2669 | } |
| 2670 | |
| 2671 | sub _cmd_l_empty { |
| 2672 | # Compute new range to list. |
| 2673 | $incr = $window - 1; |
| 2674 | |
| 2675 | # Recurse to do it. |
| 2676 | return _cmd_l_main( $start . '-' . ( $start + $incr ) ); |
| 2677 | } |
| 2678 | |
| 2679 | sub _cmd_l_plus { |
| 2680 | my ($new_start, $new_incr) = @_; |
| 2681 | |
| 2682 | # Don't reset start for 'l +nnn'. |
| 2683 | $start = $new_start if $new_start; |
| 2684 | |
| 2685 | # Increment for list. Use window size if not specified. |
| 2686 | # (Allows 'l +' to work.) |
| 2687 | $incr = $new_incr || ($window - 1); |
| 2688 | |
| 2689 | # Create a line range we'll understand, and recurse to do it. |
| 2690 | return _cmd_l_main( $start . '-' . ( $start + $incr ) ); |
| 2691 | } |
| 2692 | |
| 2693 | sub _cmd_l_calc_initial_end_and_i { |
| 2694 | my ($current_line, $start_match, $end_match) = @_; |
| 2695 | |
| 2696 | my $end = $end_match // $start_match // $max; |
| 2697 | # Clean up the end spec if needed. |
| 2698 | $end = $current_line if $end eq '.'; |
| 2699 | _minify_to_max(\$end); |
| 2700 | |
| 2701 | # Determine the loop start point. |
| 2702 | my $i = $start_match // 1; |
| 2703 | $i = $current_line if $i eq '.'; |
| 2704 | |
| 2705 | return ($end, $i); |
| 2706 | } |
| 2707 | |
| 2708 | sub _cmd_l_range { |
| 2709 | my ($current_line, $start_match, $end_match) = @_; |
| 2710 | |
| 2711 | my ($end, $i) = |
| 2712 | _cmd_l_calc_initial_end_and_i($current_line, $start_match, $end_match); |
| 2713 | |
| 2714 | # If we're running under a client editor, force it to show the lines. |
| 2715 | if ($client_editor) { |
| 2716 | print {$OUT} "$sub_twice$filename:$i:0\n"; |
| 2717 | $i = $end; |
| 2718 | } |
| 2719 | # We're doing it ourselves. We want to show the line and special |
| 2720 | # markers for: |
| 2721 | # - the current line in execution |
| 2722 | # - whether a line is breakable or not |
| 2723 | # - whether a line has a break or not |
| 2724 | # - whether a line has an action or not |
| 2725 | else { |
| 2726 | I_TO_END: |
| 2727 | for ( ; $i <= $end ; $i++ ) { |
| 2728 | |
| 2729 | # Check for breakpoints and actions. |
| 2730 | my ( $stop, $action ); |
| 2731 | if ($dbline{$i}) { |
| 2732 | ( $stop, $action ) = split( /\0/, $dbline{$i} ); |
| 2733 | } |
| 2734 | |
| 2735 | # ==> if this is the current line in execution, |
| 2736 | # : if it's breakable. |
| 2737 | my $arrow = |
| 2738 | ( $i == $current_line and $filename eq $filename_ini ) |
| 2739 | ? '==>' |
| 2740 | : ( $dbline[$i] + 0 ? ':' : ' ' ); |
| 2741 | |
| 2742 | # Add break and action indicators. |
| 2743 | $arrow .= 'b' if $stop; |
| 2744 | $arrow .= 'a' if $action; |
| 2745 | |
| 2746 | # Print the line. |
| 2747 | print {$OUT} "$i$arrow\t", $dbline[$i]; |
| 2748 | |
| 2749 | # Move on to the next line. Drop out on an interrupt. |
| 2750 | if ($signal) { |
| 2751 | $i++; |
| 2752 | last I_TO_END; |
| 2753 | } |
| 2754 | } ## end for (; $i <= $end ; $i++) |
| 2755 | |
| 2756 | # Line the prompt up; print a newline if the last line listed |
| 2757 | # didn't have a newline. |
| 2758 | if ($dbline[ $i - 1 ] !~ /\n\z/) { |
| 2759 | print {$OUT} "\n"; |
| 2760 | } |
| 2761 | } ## end else [ if ($client_editor) |
| 2762 | |
| 2763 | # Save the point we last listed to in case another relative 'l' |
| 2764 | # command is desired. Don't let it run off the end. |
| 2765 | $start = $i; |
| 2766 | _minify_to_max(\$start); |
| 2767 | |
| 2768 | return; |
| 2769 | } |
| 2770 | |
| 2771 | sub _cmd_l_main { |
| 2772 | my $spec = shift; |
| 2773 | |
| 2774 | # If the line is '$something', assume this is a scalar containing a |
| 2775 | # line number. |
| 2776 | # Set up for DB::eval() - evaluate in *user* context. |
| 2777 | if ( $spec =~ /\A(\$(?:[0-9]+|[^\W\d]\w*))\z/ ) { |
| 2778 | return _cmd_l_handle_var_name($spec); |
| 2779 | } |
| 2780 | # l name. Try to find a sub by that name. |
| 2781 | elsif ( ($subname) = $spec =~ /\A([\':A-Za-z_][\':\w]*(?:\[.*\])?)/s ) { |
| 2782 | return _cmd_l_handle_subname($subname); |
| 2783 | } |
| 2784 | # Bare 'l' command. |
| 2785 | elsif ( $spec !~ /\S/ ) { |
| 2786 | return _cmd_l_empty(); |
| 2787 | } |
| 2788 | # l [start]+number_of_lines |
| 2789 | elsif ( my ($new_start, $new_incr) = $spec =~ /\A(\d*)\+(\d*)\z/ ) { |
| 2790 | return _cmd_l_plus($new_start, $new_incr); |
| 2791 | } |
| 2792 | # l start-stop or l start,stop |
| 2793 | # Purposefully limited to ASCII; UTF-8 support would be nice sometime. |
| 2794 | elsif (my ($s, $e) = $spec =~ /\A(?:(\.|\d+)(?:[-,](\.|\d+))?)?\z/a ) { |
| 2795 | return _cmd_l_range($line, $s, $e); |
| 2796 | } |
| 2797 | # Protest at bizarre and incorrect specs. |
| 2798 | else { |
| 2799 | print {$OUT} "Invalid line specification '$spec'.\n"; |
| 2800 | } |
| 2801 | |
| 2802 | return; |
| 2803 | } ## end sub _cmd_l_main |
| 2804 | |
| 2805 | sub _DB__handle_l_command { |
| 2806 | my $self = shift; |
| 2807 | |
| 2808 | _cmd_l_main($self->cmd_args); |
| 2809 | next CMD; |
| 2810 | } |
| 2811 | |
| 2812 | |
| 2813 | # 't' is type. |
| 2814 | # 'm' is method. |
| 2815 | # 'v' is the value (i.e: method name or subroutine ref). |
| 2816 | # 's' is subroutine. |
| 2817 | my %cmd_lookup; |
| 2818 | |
| 2819 | BEGIN |
| 2820 | { |
| 2821 | %cmd_lookup = |
| 2822 | ( |
| 2823 | '-' => { t => 'm', v => '_handle_dash_command', }, |
| 2824 | '.' => { t => 's', v => \&_DB__handle_dot_command, }, |
| 2825 | '=' => { t => 'm', v => '_handle_equal_sign_command', }, |
| 2826 | 'H' => { t => 'm', v => '_handle_H_command', }, |
| 2827 | 'S' => { t => 'm', v => '_handle_S_command', }, |
| 2828 | 'T' => { t => 'm', v => '_handle_T_command', }, |
| 2829 | 'W' => { t => 'm', v => '_handle_W_command', }, |
| 2830 | 'c' => { t => 's', v => \&_DB__handle_c_command, }, |
| 2831 | 'f' => { t => 's', v => \&_DB__handle_f_command, }, |
| 2832 | 'i' => { t => 's', v => \&_DB__handle_i_command, }, |
| 2833 | 'l' => { t => 's', v => \&_DB__handle_l_command, }, |
| 2834 | 'm' => { t => 's', v => \&_DB__handle_m_command, }, |
| 2835 | 'n' => { t => 'm', v => '_handle_n_command', }, |
| 2836 | 'p' => { t => 'm', v => '_handle_p_command', }, |
| 2837 | 'q' => { t => 'm', v => '_handle_q_command', }, |
| 2838 | 'r' => { t => 'm', v => '_handle_r_command', }, |
| 2839 | 's' => { t => 'm', v => '_handle_s_command', }, |
| 2840 | 'save' => { t => 'm', v => '_handle_save_command', }, |
| 2841 | 'source' => { t => 'm', v => '_handle_source_command', }, |
| 2842 | 't' => { t => 'm', v => '_handle_t_command', }, |
| 2843 | 'w' => { t => 'm', v => '_handle_w_command', }, |
| 2844 | 'x' => { t => 'm', v => '_handle_x_command', }, |
| 2845 | 'y' => { t => 's', v => \&_DB__handle_y_command, }, |
| 2846 | (map { $_ => { t => 'm', v => '_handle_V_command_and_X_command', }, } |
| 2847 | ('X', 'V')), |
| 2848 | (map { $_ => { t => 'm', v => '_handle_enable_disable_commands', }, } |
| 2849 | qw(enable disable)), |
| 2850 | (map { $_ => |
| 2851 | { t => 's', v => \&_DB__handle_restart_and_rerun_commands, }, |
| 2852 | } qw(R rerun)), |
| 2853 | (map { $_ => {t => 'm', v => '_handle_cmd_wrapper_commands' }, } |
| 2854 | qw(a A b B e E h L M o O v w W)), |
| 2855 | ); |
| 2856 | }; |
| 2857 | |
| 2858 | sub DB { |
| 2859 | |
| 2860 | # lock the debugger and get the thread id for the prompt |
| 2861 | lock($DBGR); |
| 2862 | my $tid; |
| 2863 | my $position; |
| 2864 | my ($prefix, $after, $infix); |
| 2865 | my $pat; |
| 2866 | my $explicit_stop; |
| 2867 | my $piped; |
| 2868 | my $selected; |
| 2869 | |
| 2870 | if ($ENV{PERL5DB_THREADED}) { |
| 2871 | $tid = eval { "[".threads->tid."]" }; |
| 2872 | } |
| 2873 | |
| 2874 | my $cmd_verb; |
| 2875 | my $cmd_args; |
| 2876 | |
| 2877 | my $obj = DB::Obj->new( |
| 2878 | { |
| 2879 | position => \$position, |
| 2880 | prefix => \$prefix, |
| 2881 | after => \$after, |
| 2882 | explicit_stop => \$explicit_stop, |
| 2883 | infix => \$infix, |
| 2884 | cmd_args => \$cmd_args, |
| 2885 | cmd_verb => \$cmd_verb, |
| 2886 | pat => \$pat, |
| 2887 | piped => \$piped, |
| 2888 | selected => \$selected, |
| 2889 | }, |
| 2890 | ); |
| 2891 | |
| 2892 | $obj->_DB_on_init__initialize_globals(@_); |
| 2893 | |
| 2894 | # Preserve current values of $@, $!, $^E, $,, $/, $\, $^W. |
| 2895 | # The code being debugged may have altered them. |
| 2896 | DB::save(); |
| 2897 | |
| 2898 | # Since DB::DB gets called after every line, we can use caller() to |
| 2899 | # figure out where we last were executing. Sneaky, eh? This works because |
| 2900 | # caller is returning all the extra information when called from the |
| 2901 | # debugger. |
| 2902 | local ( $package, $filename, $line ) = caller; |
| 2903 | $filename_ini = $filename; |
| 2904 | |
| 2905 | # set up the context for DB::eval, so it can properly execute |
| 2906 | # code on behalf of the user. We add the package in so that the |
| 2907 | # code is eval'ed in the proper package (not in the debugger!). |
| 2908 | local $usercontext = _calc_usercontext($package); |
| 2909 | |
| 2910 | # Create an alias to the active file magical array to simplify |
| 2911 | # the code here. |
| 2912 | local (*dbline) = $main::{ '_<' . $filename }; |
| 2913 | |
| 2914 | # Last line in the program. |
| 2915 | $max = $#dbline; |
| 2916 | |
| 2917 | # The &-call is here to ascertain the mutability of @_. |
| 2918 | &_DB__determine_if_we_should_break; |
| 2919 | |
| 2920 | # Preserve the current stop-or-not, and see if any of the W |
| 2921 | # (watch expressions) has changed. |
| 2922 | my $was_signal = $signal; |
| 2923 | |
| 2924 | # If we have any watch expressions ... |
| 2925 | _DB__handle_watch_expressions($obj); |
| 2926 | |
| 2927 | =head2 C<watchfunction()> |
| 2928 | |
| 2929 | C<watchfunction()> is a function that can be defined by the user; it is a |
| 2930 | function which will be run on each entry to C<DB::DB>; it gets the |
| 2931 | current package, filename, and line as its parameters. |
| 2932 | |
| 2933 | The watchfunction can do anything it likes; it is executing in the |
| 2934 | debugger's context, so it has access to all of the debugger's internal |
| 2935 | data structures and functions. |
| 2936 | |
| 2937 | C<watchfunction()> can control the debugger's actions. Any of the following |
| 2938 | will cause the debugger to return control to the user's program after |
| 2939 | C<watchfunction()> executes: |
| 2940 | |
| 2941 | =over 4 |
| 2942 | |
| 2943 | =item * |
| 2944 | |
| 2945 | Returning a false value from the C<watchfunction()> itself. |
| 2946 | |
| 2947 | =item * |
| 2948 | |
| 2949 | Altering C<$single> to a false value. |
| 2950 | |
| 2951 | =item * |
| 2952 | |
| 2953 | Altering C<$signal> to a false value. |
| 2954 | |
| 2955 | =item * |
| 2956 | |
| 2957 | Turning off the C<4> bit in C<$trace> (this also disables the |
| 2958 | check for C<watchfunction()>. This can be done with |
| 2959 | |
| 2960 | $trace &= ~4; |
| 2961 | |
| 2962 | =back |
| 2963 | |
| 2964 | =cut |
| 2965 | |
| 2966 | # If there's a user-defined DB::watchfunction, call it with the |
| 2967 | # current package, filename, and line. The function executes in |
| 2968 | # the DB:: package. |
| 2969 | if ( $trace & 4 ) { # User-installed watch |
| 2970 | return |
| 2971 | if watchfunction( $package, $filename, $line ) |
| 2972 | and not $single |
| 2973 | and not $was_signal |
| 2974 | and not( $trace & ~4 ); |
| 2975 | } ## end if ($trace & 4) |
| 2976 | |
| 2977 | # Pick up any alteration to $signal in the watchfunction, and |
| 2978 | # turn off the signal now. |
| 2979 | $was_signal = $signal; |
| 2980 | $signal = 0; |
| 2981 | |
| 2982 | =head2 GETTING READY TO EXECUTE COMMANDS |
| 2983 | |
| 2984 | The debugger decides to take control if single-step mode is on, the |
| 2985 | C<t> command was entered, or the user generated a signal. If the program |
| 2986 | has fallen off the end, we set things up so that entering further commands |
| 2987 | won't cause trouble, and we say that the program is over. |
| 2988 | |
| 2989 | =cut |
| 2990 | |
| 2991 | # Make sure that we always print if asked for explicitly regardless |
| 2992 | # of $trace_to_depth . |
| 2993 | $explicit_stop = ($single || $was_signal); |
| 2994 | |
| 2995 | # Check to see if we should grab control ($single true, |
| 2996 | # trace set appropriately, or we got a signal). |
| 2997 | if ( $explicit_stop || ( $trace & 1 ) ) { |
| 2998 | $obj->_DB__grab_control(@_); |
| 2999 | } ## end if ($single || ($trace... |
| 3000 | |
| 3001 | =pod |
| 3002 | |
| 3003 | If there's an action to be executed for the line we stopped at, execute it. |
| 3004 | If there are any preprompt actions, execute those as well. |
| 3005 | |
| 3006 | =cut |
| 3007 | |
| 3008 | # If there's an action, do it now. |
| 3009 | if ($action) { |
| 3010 | $evalarg = $action; |
| 3011 | # The &-call is here to ascertain the mutability of @_. |
| 3012 | &DB::eval; |
| 3013 | } |
| 3014 | undef $action; |
| 3015 | |
| 3016 | # Are we nested another level (e.g., did we evaluate a function |
| 3017 | # that had a breakpoint in it at the debugger prompt)? |
| 3018 | if ( $single || $was_signal ) { |
| 3019 | |
| 3020 | # Yes, go down a level. |
| 3021 | local $level = $level + 1; |
| 3022 | |
| 3023 | # Do any pre-prompt actions. |
| 3024 | foreach $evalarg (@$pre) { |
| 3025 | # The &-call is here to ascertain the mutability of @_. |
| 3026 | &DB::eval; |
| 3027 | } |
| 3028 | |
| 3029 | # Complain about too much recursion if we passed the limit. |
| 3030 | if ($single & 4) { |
| 3031 | print $OUT $stack_depth . " levels deep in subroutine calls!\n"; |
| 3032 | } |
| 3033 | |
| 3034 | # The line we're currently on. Set $incr to -1 to stay here |
| 3035 | # until we get a command that tells us to advance. |
| 3036 | $start = $line; |
| 3037 | $incr = -1; # for backward motion. |
| 3038 | |
| 3039 | # Tack preprompt debugger actions ahead of any actual input. |
| 3040 | @typeahead = ( @$pretype, @typeahead ); |
| 3041 | |
| 3042 | =head2 WHERE ARE WE? |
| 3043 | |
| 3044 | XXX Relocate this section? |
| 3045 | |
| 3046 | The debugger normally shows the line corresponding to the current line of |
| 3047 | execution. Sometimes, though, we want to see the next line, or to move elsewhere |
| 3048 | in the file. This is done via the C<$incr>, C<$start>, and C<$max> variables. |
| 3049 | |
| 3050 | C<$incr> controls by how many lines the I<current> line should move forward |
| 3051 | after a command is executed. If set to -1, this indicates that the I<current> |
| 3052 | line shouldn't change. |
| 3053 | |
| 3054 | C<$start> is the I<current> line. It is used for things like knowing where to |
| 3055 | move forwards or backwards from when doing an C<L> or C<-> command. |
| 3056 | |
| 3057 | C<$max> tells the debugger where the last line of the current file is. It's |
| 3058 | used to terminate loops most often. |
| 3059 | |
| 3060 | =head2 THE COMMAND LOOP |
| 3061 | |
| 3062 | Most of C<DB::DB> is actually a command parsing and dispatch loop. It comes |
| 3063 | in two parts: |
| 3064 | |
| 3065 | =over 4 |
| 3066 | |
| 3067 | =item * |
| 3068 | |
| 3069 | The outer part of the loop, starting at the C<CMD> label. This loop |
| 3070 | reads a command and then executes it. |
| 3071 | |
| 3072 | =item * |
| 3073 | |
| 3074 | The inner part of the loop, starting at the C<PIPE> label. This part |
| 3075 | is wholly contained inside the C<CMD> block and only executes a command. |
| 3076 | Used to handle commands running inside a pager. |
| 3077 | |
| 3078 | =back |
| 3079 | |
| 3080 | So why have two labels to restart the loop? Because sometimes, it's easier to |
| 3081 | have a command I<generate> another command and then re-execute the loop to do |
| 3082 | the new command. This is faster, but perhaps a bit more convoluted. |
| 3083 | |
| 3084 | =cut |
| 3085 | |
| 3086 | # The big command dispatch loop. It keeps running until the |
| 3087 | # user yields up control again. |
| 3088 | # |
| 3089 | # If we have a terminal for input, and we get something back |
| 3090 | # from readline(), keep on processing. |
| 3091 | |
| 3092 | CMD: |
| 3093 | while (_DB__read_next_cmd($tid)) |
| 3094 | { |
| 3095 | |
| 3096 | share($cmd); |
| 3097 | # ... try to execute the input as debugger commands. |
| 3098 | |
| 3099 | # Don't stop running. |
| 3100 | $single = 0; |
| 3101 | |
| 3102 | # No signal is active. |
| 3103 | $signal = 0; |
| 3104 | |
| 3105 | # Handle continued commands (ending with \): |
| 3106 | if ($cmd =~ s/\\\z/\n/) { |
| 3107 | $cmd .= DB::readline(" cont: "); |
| 3108 | redo CMD; |
| 3109 | } |
| 3110 | |
| 3111 | =head4 The null command |
| 3112 | |
| 3113 | A newline entered by itself means I<re-execute the last command>. We grab the |
| 3114 | command out of C<$laststep> (where it was recorded previously), and copy it |
| 3115 | back into C<$cmd> to be executed below. If there wasn't any previous command, |
| 3116 | we'll do nothing below (no command will match). If there was, we also save it |
| 3117 | in the command history and fall through to allow the command parsing to pick |
| 3118 | it up. |
| 3119 | |
| 3120 | =cut |
| 3121 | |
| 3122 | # Empty input means repeat the last command. |
| 3123 | if ($cmd eq '') { |
| 3124 | $cmd = $laststep; |
| 3125 | } |
| 3126 | chomp($cmd); # get rid of the annoying extra newline |
| 3127 | if (length($cmd) >= option_val('HistItemMinLength', 2)) { |
| 3128 | push( @hist, $cmd ); |
| 3129 | } |
| 3130 | push( @truehist, $cmd ); |
| 3131 | share(@hist); |
| 3132 | share(@truehist); |
| 3133 | |
| 3134 | # This is a restart point for commands that didn't arrive |
| 3135 | # via direct user input. It allows us to 'redo PIPE' to |
| 3136 | # re-execute command processing without reading a new command. |
| 3137 | PIPE: { |
| 3138 | _DB__trim_command_and_return_first_component($obj); |
| 3139 | |
| 3140 | =head3 COMMAND ALIASES |
| 3141 | |
| 3142 | The debugger can create aliases for commands (these are stored in the |
| 3143 | C<%alias> hash). Before a command is executed, the command loop looks it up |
| 3144 | in the alias hash and substitutes the contents of the alias for the command, |
| 3145 | completely replacing it. |
| 3146 | |
| 3147 | =cut |
| 3148 | |
| 3149 | # See if there's an alias for the command, and set it up if so. |
| 3150 | if ( $alias{$cmd_verb} ) { |
| 3151 | |
| 3152 | # Squelch signal handling; we want to keep control here |
| 3153 | # if something goes loco during the alias eval. |
| 3154 | local $SIG{__DIE__}; |
| 3155 | local $SIG{__WARN__}; |
| 3156 | |
| 3157 | # This is a command, so we eval it in the DEBUGGER's |
| 3158 | # scope! Otherwise, we can't see the special debugger |
| 3159 | # variables, or get to the debugger's subs. (Well, we |
| 3160 | # _could_, but why make it even more complicated?) |
| 3161 | eval "\$cmd =~ $alias{$cmd_verb}"; |
| 3162 | if ($@) { |
| 3163 | local $\ = ''; |
| 3164 | print $OUT "Couldn't evaluate '$cmd_verb' alias: $@"; |
| 3165 | next CMD; |
| 3166 | } |
| 3167 | _DB__trim_command_and_return_first_component($obj); |
| 3168 | } ## end if ($alias{$cmd_verb}) |
| 3169 | |
| 3170 | =head3 MAIN-LINE COMMANDS |
| 3171 | |
| 3172 | All of these commands work up to and after the program being debugged has |
| 3173 | terminated. |
| 3174 | |
| 3175 | =head4 C<q> - quit |
| 3176 | |
| 3177 | Quit the debugger. This entails setting the C<$fall_off_end> flag, so we don't |
| 3178 | try to execute further, cleaning any restart-related stuff out of the |
| 3179 | environment, and executing with the last value of C<$?>. |
| 3180 | |
| 3181 | =cut |
| 3182 | |
| 3183 | # All of these commands were remapped in perl 5.8.0; |
| 3184 | # we send them off to the secondary dispatcher (see below). |
| 3185 | $obj->_handle_special_char_cmd_wrapper_commands; |
| 3186 | _DB__trim_command_and_return_first_component($obj); |
| 3187 | |
| 3188 | if (my $cmd_rec = $cmd_lookup{$cmd_verb}) { |
| 3189 | my $type = $cmd_rec->{t}; |
| 3190 | my $val = $cmd_rec->{v}; |
| 3191 | if ($type eq 'm') { |
| 3192 | $obj->$val(); |
| 3193 | } |
| 3194 | elsif ($type eq 's') { |
| 3195 | $val->($obj); |
| 3196 | } |
| 3197 | } |
| 3198 | |
| 3199 | =head4 C<t> - trace [n] |
| 3200 | |
| 3201 | Turn tracing on or off. Inverts the appropriate bit in C<$trace> (q.v.). |
| 3202 | If level is specified, set C<$trace_to_depth>. |
| 3203 | |
| 3204 | =head4 C<S> - list subroutines matching/not matching a pattern |
| 3205 | |
| 3206 | Walks through C<%sub>, checking to see whether or not to print the name. |
| 3207 | |
| 3208 | =head4 C<X> - list variables in current package |
| 3209 | |
| 3210 | Since the C<V> command actually processes this, just change this to the |
| 3211 | appropriate C<V> command and fall through. |
| 3212 | |
| 3213 | =head4 C<V> - list variables |
| 3214 | |
| 3215 | Uses C<dumpvar.pl> to dump out the current values for selected variables. |
| 3216 | |
| 3217 | =head4 C<x> - evaluate and print an expression |
| 3218 | |
| 3219 | Hands the expression off to C<DB::eval>, setting it up to print the value |
| 3220 | via C<dumpvar.pl> instead of just printing it directly. |
| 3221 | |
| 3222 | =head4 C<m> - print methods |
| 3223 | |
| 3224 | Just uses C<DB::methods> to determine what methods are available. |
| 3225 | |
| 3226 | =head4 C<f> - switch files |
| 3227 | |
| 3228 | Switch to a different filename. |
| 3229 | |
| 3230 | =head4 C<.> - return to last-executed line |
| 3231 | |
| 3232 | We set C<$incr> to -1 to indicate that the debugger shouldn't move ahead, |
| 3233 | and then we look up the line in the magical C<%dbline> hash. |
| 3234 | |
| 3235 | =head4 C<-> - back one window |
| 3236 | |
| 3237 | We change C<$start> to be one window back; if we go back past the first line, |
| 3238 | we set it to be the first line. We set C<$incr> to put us back at the |
| 3239 | currently-executing line, and then put a S<C<l $start +>> (list one window from |
| 3240 | C<$start>) in C<$cmd> to be executed later. |
| 3241 | |
| 3242 | =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>> |
| 3243 | |
| 3244 | In Perl 5.8.0, a realignment of the commands was done to fix up a number of |
| 3245 | problems, most notably that the default case of several commands destroying |
| 3246 | the user's work in setting watchpoints, actions, etc. We wanted, however, to |
| 3247 | retain the old commands for those who were used to using them or who preferred |
| 3248 | them. At this point, we check for the new commands and call C<cmd_wrapper> to |
| 3249 | deal with them instead of processing them in-line. |
| 3250 | |
| 3251 | =head4 C<y> - List lexicals in higher scope |
| 3252 | |
| 3253 | Uses C<PadWalker> to find the lexicals supplied as arguments in a scope |
| 3254 | above the current one and then displays them using F<dumpvar.pl>. |
| 3255 | |
| 3256 | =head3 COMMANDS NOT WORKING AFTER PROGRAM ENDS |
| 3257 | |
| 3258 | All of the commands below this point don't work after the program being |
| 3259 | debugged has ended. All of them check to see if the program has ended; this |
| 3260 | allows the commands to be relocated without worrying about a 'line of |
| 3261 | demarcation' above which commands can be entered anytime, and below which |
| 3262 | they can't. |
| 3263 | |
| 3264 | =head4 C<n> - single step, but don't trace down into subs |
| 3265 | |
| 3266 | Done by setting C<$single> to 2, which forces subs to execute straight through |
| 3267 | when entered (see C<DB::sub> in L</DEBUGGER INTERFACE VARIABLES>). We also |
| 3268 | save the C<n> command in C<$laststep>, |
| 3269 | |
| 3270 | so a null command knows what to re-execute. |
| 3271 | |
| 3272 | =head4 C<s> - single-step, entering subs |
| 3273 | |
| 3274 | Sets C<$single> to 1, which causes C<DB::sub> to continue tracing inside |
| 3275 | subs. Also saves C<s> as C<$lastcmd>. |
| 3276 | |
| 3277 | =head4 C<c> - run continuously, setting an optional breakpoint |
| 3278 | |
| 3279 | Most of the code for this command is taken up with locating the optional |
| 3280 | breakpoint, which is either a subroutine name or a line number. We set |
| 3281 | the appropriate one-time-break in C<@dbline> and then turn off single-stepping |
| 3282 | in this and all call levels above this one. |
| 3283 | |
| 3284 | =head4 C<r> - return from a subroutine |
| 3285 | |
| 3286 | For C<r> to work properly, the debugger has to stop execution again |
| 3287 | immediately after the return is executed. This is done by forcing |
| 3288 | single-stepping to be on in the call level above the current one. If |
| 3289 | we are printing return values when a C<r> is executed, set C<$doret> |
| 3290 | appropriately, and force us out of the command loop. |
| 3291 | |
| 3292 | =head4 C<T> - stack trace |
| 3293 | |
| 3294 | Just calls C<DB::print_trace>. |
| 3295 | |
| 3296 | =head4 C<w> - List window around current line |
| 3297 | |
| 3298 | Just calls C<DB::cmd_w>. |
| 3299 | |
| 3300 | =head4 C<W> - watch-expression processing |
| 3301 | |
| 3302 | Just calls C<DB::cmd_W>. |
| 3303 | |
| 3304 | =head4 C</> - search forward for a string in the source |
| 3305 | |
| 3306 | We take the argument and treat it as a pattern. If it turns out to be a |
| 3307 | bad one, we return the error we got from trying to C<eval> it and exit. |
| 3308 | If not, we create some code to do the search and C<eval> it so it can't |
| 3309 | mess us up. |
| 3310 | |
| 3311 | =cut |
| 3312 | |
| 3313 | _DB__handle_forward_slash_command($obj); |
| 3314 | |
| 3315 | =head4 C<?> - search backward for a string in the source |
| 3316 | |
| 3317 | Same as for C</>, except the loop runs backwards. |
| 3318 | |
| 3319 | =cut |
| 3320 | |
| 3321 | _DB__handle_question_mark_command($obj); |
| 3322 | |
| 3323 | =head4 C<$rc> - Recall command |
| 3324 | |
| 3325 | Manages the commands in C<@hist> (which is created if C<Term::ReadLine> reports |
| 3326 | that the terminal supports history). It finds the command required, puts it |
| 3327 | into C<$cmd>, and redoes the loop to execute it. |
| 3328 | |
| 3329 | =cut |
| 3330 | |
| 3331 | # $rc - recall command. |
| 3332 | $obj->_handle_rc_recall_command; |
| 3333 | |
| 3334 | =head4 C<$sh$sh> - C<system()> command |
| 3335 | |
| 3336 | Calls the C<_db_system()> to handle the command. This keeps the C<STDIN> and |
| 3337 | C<STDOUT> from getting messed up. |
| 3338 | |
| 3339 | =cut |
| 3340 | |
| 3341 | $obj->_handle_sh_command; |
| 3342 | |
| 3343 | =head4 C<$rc I<pattern> $rc> - Search command history |
| 3344 | |
| 3345 | Another command to manipulate C<@hist>: this one searches it with a pattern. |
| 3346 | If a command is found, it is placed in C<$cmd> and executed via C<redo>. |
| 3347 | |
| 3348 | =cut |
| 3349 | |
| 3350 | $obj->_handle_rc_search_history_command; |
| 3351 | |
| 3352 | =head4 C<$sh> - Invoke a shell |
| 3353 | |
| 3354 | Uses C<_db_system()> to invoke a shell. |
| 3355 | |
| 3356 | =cut |
| 3357 | |
| 3358 | =head4 C<$sh I<command>> - Force execution of a command in a shell |
| 3359 | |
| 3360 | Like the above, but the command is passed to the shell. Again, we use |
| 3361 | C<_db_system()> to avoid problems with C<STDIN> and C<STDOUT>. |
| 3362 | |
| 3363 | =head4 C<H> - display commands in history |
| 3364 | |
| 3365 | Prints the contents of C<@hist> (if any). |
| 3366 | |
| 3367 | =head4 C<man, doc, perldoc> - look up documentation |
| 3368 | |
| 3369 | Just calls C<runman()> to print the appropriate document. |
| 3370 | |
| 3371 | =cut |
| 3372 | |
| 3373 | $obj->_handle_doc_command; |
| 3374 | |
| 3375 | =head4 C<p> - print |
| 3376 | |
| 3377 | Builds a C<print EXPR> expression in the C<$cmd>; this will get executed at |
| 3378 | the bottom of the loop. |
| 3379 | |
| 3380 | =head4 C<=> - define command alias |
| 3381 | |
| 3382 | Manipulates C<%alias> to add or list command aliases. |
| 3383 | |
| 3384 | =head4 C<source> - read commands from a file |
| 3385 | |
| 3386 | Opens a lexical filehandle and stacks it on C<@cmdfhs>; C<DB::readline> will |
| 3387 | pick it up. |
| 3388 | |
| 3389 | =head4 C<enable> C<disable> - enable or disable breakpoints |
| 3390 | |
| 3391 | This enables or disables breakpoints. |
| 3392 | |
| 3393 | =head4 C<save> - send current history to a file |
| 3394 | |
| 3395 | Takes the complete history, (not the shrunken version you see with C<H>), |
| 3396 | and saves it to the given filename, so it can be replayed using C<source>. |
| 3397 | |
| 3398 | Note that all C<^(save|source)>'s are commented out with a view to minimise recursion. |
| 3399 | |
| 3400 | =head4 C<R> - restart |
| 3401 | |
| 3402 | Restart the debugger session. |
| 3403 | |
| 3404 | =head4 C<rerun> - rerun the current session |
| 3405 | |
| 3406 | Return to any given position in the B<true>-history list |
| 3407 | |
| 3408 | =head4 C<|, ||> - pipe output through the pager |
| 3409 | |
| 3410 | For C<|>, we save C<OUT> (the debugger's output filehandle) and C<STDOUT> |
| 3411 | (the program's standard output). For C<||>, we only save C<OUT>. We open a |
| 3412 | pipe to the pager (restoring the output filehandles if this fails). If this |
| 3413 | is the C<|> command, we also set up a C<SIGPIPE> handler which will simply |
| 3414 | set C<$signal>, sending us back into the debugger. |
| 3415 | |
| 3416 | We then trim off the pipe symbols and C<redo> the command loop at the |
| 3417 | C<PIPE> label, causing us to evaluate the command in C<$cmd> without |
| 3418 | reading another. |
| 3419 | |
| 3420 | =cut |
| 3421 | |
| 3422 | # || - run command in the pager, with output to DB::OUT. |
| 3423 | _DB__handle_run_command_in_pager_command($obj); |
| 3424 | |
| 3425 | =head3 END OF COMMAND PARSING |
| 3426 | |
| 3427 | Anything left in C<$cmd> at this point is a Perl expression that we want to |
| 3428 | evaluate. We'll always evaluate in the user's context, and fully qualify |
| 3429 | any variables we might want to address in the C<DB> package. |
| 3430 | |
| 3431 | =cut |
| 3432 | |
| 3433 | } # PIPE: |
| 3434 | |
| 3435 | # trace an expression |
| 3436 | $cmd =~ s/^t\s/\$DB::trace |= 1;\n/; |
| 3437 | |
| 3438 | # Make sure the flag that says "the debugger's running" is |
| 3439 | # still on, to make sure we get control again. |
| 3440 | $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; |
| 3441 | |
| 3442 | # Run *our* eval that executes in the caller's context. |
| 3443 | # The &-call is here to ascertain the mutability of @_. |
| 3444 | &DB::eval; |
| 3445 | |
| 3446 | # Turn off the one-time-dump stuff now. |
| 3447 | if ($onetimeDump) { |
| 3448 | $onetimeDump = undef; |
| 3449 | $onetimedumpDepth = undef; |
| 3450 | } |
| 3451 | elsif ( $term_pid == $$ ) { |
| 3452 | eval { # May run under miniperl, when not available... |
| 3453 | STDOUT->flush(); |
| 3454 | STDERR->flush(); |
| 3455 | }; |
| 3456 | |
| 3457 | # XXX If this is the master pid, print a newline. |
| 3458 | print {$OUT} "\n"; |
| 3459 | } |
| 3460 | } ## end while (($term || &setterm... |
| 3461 | |
| 3462 | =head3 POST-COMMAND PROCESSING |
| 3463 | |
| 3464 | After each command, we check to see if the command output was piped anywhere. |
| 3465 | If so, we go through the necessary code to unhook the pipe and go back to |
| 3466 | our standard filehandles for input and output. |
| 3467 | |
| 3468 | =cut |
| 3469 | |
| 3470 | continue { # CMD: |
| 3471 | _DB__at_end_of_every_command($obj); |
| 3472 | } # CMD: |
| 3473 | |
| 3474 | =head3 COMMAND LOOP TERMINATION |
| 3475 | |
| 3476 | When commands have finished executing, we come here. If the user closed the |
| 3477 | input filehandle, we turn on C<$fall_off_end> to emulate a C<q> command. We |
| 3478 | evaluate any post-prompt items. We restore C<$@>, C<$!>, C<$^E>, C<$,>, C<$/>, |
| 3479 | C<$\>, and C<$^W>, and return a null list as expected by the Perl interpreter. |
| 3480 | The interpreter will then execute the next line and then return control to us |
| 3481 | again. |
| 3482 | |
| 3483 | =cut |
| 3484 | |
| 3485 | # No more commands? Quit. |
| 3486 | unless (defined $cmd) { |
| 3487 | DB::Obj::_do_quit(); |
| 3488 | } |
| 3489 | |
| 3490 | # Evaluate post-prompt commands. |
| 3491 | foreach $evalarg (@$post) { |
| 3492 | # The &-call is here to ascertain the mutability of @_. |
| 3493 | &DB::eval; |
| 3494 | } |
| 3495 | } # if ($single || $signal) |
| 3496 | |
| 3497 | # Put the user's globals back where you found them. |
| 3498 | ( $@, $!, $^E, $,, $/, $\, $^W ) = @saved; |
| 3499 | (); |
| 3500 | } ## end sub DB |
| 3501 | |
| 3502 | # Because DB::Obj is used above, |
| 3503 | # |
| 3504 | # my $obj = DB::Obj->new( |
| 3505 | # |
| 3506 | # The following package declaration must come before that, |
| 3507 | # or else runtime errors will occur with |
| 3508 | # |
| 3509 | # PERLDB_OPTS="autotrace nonstop" |
| 3510 | # |
| 3511 | # ( rt#116771 ) |
| 3512 | BEGIN { |
| 3513 | |
| 3514 | package DB::Obj; |
| 3515 | |
| 3516 | sub new { |
| 3517 | my $class = shift; |
| 3518 | |
| 3519 | my $self = bless {}, $class; |
| 3520 | |
| 3521 | $self->_init(@_); |
| 3522 | |
| 3523 | return $self; |
| 3524 | } |
| 3525 | |
| 3526 | sub _init { |
| 3527 | my ($self, $args) = @_; |
| 3528 | |
| 3529 | %{$self} = (%$self, %$args); |
| 3530 | |
| 3531 | return; |
| 3532 | } |
| 3533 | |
| 3534 | { |
| 3535 | no strict 'refs'; |
| 3536 | foreach my $slot_name (qw( |
| 3537 | after explicit_stop infix pat piped position prefix selected cmd_verb |
| 3538 | cmd_args |
| 3539 | )) { |
| 3540 | my $slot = $slot_name; |
| 3541 | *{$slot} = sub { |
| 3542 | my $self = shift; |
| 3543 | |
| 3544 | if (@_) { |
| 3545 | ${ $self->{$slot} } = shift; |
| 3546 | } |
| 3547 | |
| 3548 | return ${ $self->{$slot} }; |
| 3549 | }; |
| 3550 | |
| 3551 | *{"append_to_$slot"} = sub { |
| 3552 | my $self = shift; |
| 3553 | my $s = shift; |
| 3554 | |
| 3555 | return $self->$slot($self->$slot . $s); |
| 3556 | }; |
| 3557 | } |
| 3558 | } |
| 3559 | |
| 3560 | sub _DB_on_init__initialize_globals |
| 3561 | { |
| 3562 | my $self = shift; |
| 3563 | |
| 3564 | # Check for whether we should be running continuously or not. |
| 3565 | # _After_ the perl program is compiled, $single is set to 1: |
| 3566 | if ( $single and not $second_time++ ) { |
| 3567 | |
| 3568 | # Options say run non-stop. Run until we get an interrupt. |
| 3569 | if ($runnonstop) { # Disable until signal |
| 3570 | # If there's any call stack in place, turn off single |
| 3571 | # stepping into subs throughout the stack. |
| 3572 | for my $i (0 .. $stack_depth) { |
| 3573 | $stack[ $i ] &= ~1; |
| 3574 | } |
| 3575 | |
| 3576 | # And we are now no longer in single-step mode. |
| 3577 | $single = 0; |
| 3578 | |
| 3579 | # If we simply returned at this point, we wouldn't get |
| 3580 | # the trace info. Fall on through. |
| 3581 | # return; |
| 3582 | } ## end if ($runnonstop) |
| 3583 | |
| 3584 | elsif ($ImmediateStop) { |
| 3585 | |
| 3586 | # We are supposed to stop here; XXX probably a break. |
| 3587 | $ImmediateStop = 0; # We've processed it; turn it off |
| 3588 | $signal = 1; # Simulate an interrupt to force |
| 3589 | # us into the command loop |
| 3590 | } |
| 3591 | } ## end if ($single and not $second_time... |
| 3592 | |
| 3593 | # If we're in single-step mode, or an interrupt (real or fake) |
| 3594 | # has occurred, turn off non-stop mode. |
| 3595 | $runnonstop = 0 if $single or $signal; |
| 3596 | |
| 3597 | return; |
| 3598 | } |
| 3599 | |
| 3600 | sub _my_print_lineinfo |
| 3601 | { |
| 3602 | my ($self, $i, $incr_pos) = @_; |
| 3603 | |
| 3604 | if ($frame) { |
| 3605 | # Print it indented if tracing is on. |
| 3606 | DB::print_lineinfo( ' ' x $stack_depth, |
| 3607 | "$i:\t$DB::dbline[$i]" . $self->after ); |
| 3608 | } |
| 3609 | else { |
| 3610 | DB::depth_print_lineinfo($self->explicit_stop, $incr_pos); |
| 3611 | } |
| 3612 | } |
| 3613 | |
| 3614 | sub _curr_line { |
| 3615 | return $DB::dbline[$line]; |
| 3616 | } |
| 3617 | |
| 3618 | sub _is_full { |
| 3619 | my ($self, $letter) = @_; |
| 3620 | |
| 3621 | return ($DB::cmd eq $letter); |
| 3622 | } |
| 3623 | |
| 3624 | sub _DB__grab_control |
| 3625 | { |
| 3626 | my $self = shift; |
| 3627 | |
| 3628 | # Yes, grab control. |
| 3629 | if ($client_editor) { |
| 3630 | |
| 3631 | # Tell the editor to update its position. |
| 3632 | $self->position("$sub_twice${DB::filename}:$line:0\n"); |
| 3633 | DB::print_lineinfo($self->position()); |
| 3634 | } |
| 3635 | |
| 3636 | =pod |
| 3637 | |
| 3638 | Special check: if we're in package C<DB::fake>, we've gone through the |
| 3639 | C<END> block at least once. We set up everything so that we can continue |
| 3640 | to enter commands and have a valid context to be in. |
| 3641 | |
| 3642 | =cut |
| 3643 | |
| 3644 | elsif ( $DB::package eq 'DB::fake' ) { |
| 3645 | |
| 3646 | # Fallen off the end already. |
| 3647 | if (!$DB::term) { |
| 3648 | DB::setterm(); |
| 3649 | } |
| 3650 | |
| 3651 | DB::print_help(<<EOP); |
| 3652 | Debugged program terminated. Use B<q> to quit or B<R> to restart, |
| 3653 | use B<o> I<inhibit_exit> to avoid stopping after program termination, |
| 3654 | S<B<h q>>, S<B<h R>> or S<B<h o>> to get additional info. |
| 3655 | EOP |
| 3656 | |
| 3657 | $DB::package = 'main'; |
| 3658 | $DB::usercontext = DB::_calc_usercontext($DB::package); |
| 3659 | } ## end elsif ($package eq 'DB::fake') |
| 3660 | |
| 3661 | =pod |
| 3662 | |
| 3663 | If the program hasn't finished executing, we scan forward to the |
| 3664 | next executable line, print that out, build the prompt from the file and line |
| 3665 | number information, and print that. |
| 3666 | |
| 3667 | =cut |
| 3668 | |
| 3669 | else { |
| 3670 | |
| 3671 | |
| 3672 | # Still somewhere in the midst of execution. Set up the |
| 3673 | # debugger prompt. |
| 3674 | $DB::sub =~ s/\'/::/; # Swap Perl 4 package separators (') to |
| 3675 | # Perl 5 ones (sorry, we don't print Klingon |
| 3676 | #module names) |
| 3677 | |
| 3678 | $self->prefix($DB::sub =~ /::/ ? "" : ($DB::package . '::')); |
| 3679 | $self->append_to_prefix( "$DB::sub(${DB::filename}:" ); |
| 3680 | $self->after( $self->_curr_line =~ /\n$/ ? '' : "\n" ); |
| 3681 | |
| 3682 | # Break up the prompt if it's really long. |
| 3683 | if ( length($self->prefix()) > 30 ) { |
| 3684 | $self->position($self->prefix . "$line):\n$line:\t" . $self->_curr_line . $self->after); |
| 3685 | $self->prefix(""); |
| 3686 | $self->infix(":\t"); |
| 3687 | } |
| 3688 | else { |
| 3689 | $self->infix("):\t"); |
| 3690 | $self->position( |
| 3691 | $self->prefix . $line. $self->infix |
| 3692 | . $self->_curr_line . $self->after |
| 3693 | ); |
| 3694 | } |
| 3695 | |
| 3696 | # Print current line info, indenting if necessary. |
| 3697 | $self->_my_print_lineinfo($line, $self->position); |
| 3698 | |
| 3699 | my $i; |
| 3700 | my $line_i = sub { return $DB::dbline[$i]; }; |
| 3701 | |
| 3702 | # Scan forward, stopping at either the end or the next |
| 3703 | # unbreakable line. |
| 3704 | for ( $i = $line + 1 ; $i <= $DB::max && $line_i->() == 0 ; ++$i ) |
| 3705 | { #{ vi |
| 3706 | |
| 3707 | # Drop out on null statements, block closers, and comments. |
| 3708 | last if $line_i->() =~ /^\s*[\;\}\#\n]/; |
| 3709 | |
| 3710 | # Drop out if the user interrupted us. |
| 3711 | last if $signal; |
| 3712 | |
| 3713 | # Append a newline if the line doesn't have one. Can happen |
| 3714 | # in eval'ed text, for instance. |
| 3715 | $self->after( $line_i->() =~ /\n$/ ? '' : "\n" ); |
| 3716 | |
| 3717 | # Next executable line. |
| 3718 | my $incr_pos = $self->prefix . $i . $self->infix . $line_i->() |
| 3719 | . $self->after; |
| 3720 | $self->append_to_position($incr_pos); |
| 3721 | $self->_my_print_lineinfo($i, $incr_pos); |
| 3722 | } ## end for ($i = $line + 1 ; $i... |
| 3723 | } ## end else [ if ($client_editor) |
| 3724 | |
| 3725 | return; |
| 3726 | } |
| 3727 | |
| 3728 | sub _handle_t_command { |
| 3729 | my $self = shift; |
| 3730 | |
| 3731 | my $levels = $self->cmd_args(); |
| 3732 | |
| 3733 | if ((!length($levels)) or ($levels !~ /\D/)) { |
| 3734 | $trace ^= 1; |
| 3735 | local $\ = ''; |
| 3736 | $DB::trace_to_depth = $levels ? $stack_depth + $levels : 1E9; |
| 3737 | print {$OUT} "Trace = " |
| 3738 | . ( ( $trace & 1 ) |
| 3739 | ? ( $levels ? "on (to level $DB::trace_to_depth)" : "on" ) |
| 3740 | : "off" ) . "\n"; |
| 3741 | next CMD; |
| 3742 | } |
| 3743 | |
| 3744 | return; |
| 3745 | } |
| 3746 | |
| 3747 | |
| 3748 | sub _handle_S_command { |
| 3749 | my $self = shift; |
| 3750 | |
| 3751 | if (my ($print_all_subs, $should_reverse, $Spatt) |
| 3752 | = $self->cmd_args =~ /\A((!)?(.+))?\z/) { |
| 3753 | # $Spatt is the pattern (if any) to use. |
| 3754 | # Reverse scan? |
| 3755 | my $Srev = defined $should_reverse; |
| 3756 | # No args - print all subs. |
| 3757 | my $Snocheck = !defined $print_all_subs; |
| 3758 | |
| 3759 | # Need to make these sane here. |
| 3760 | local $\ = ''; |
| 3761 | local $, = ''; |
| 3762 | |
| 3763 | # Search through the debugger's magical hash of subs. |
| 3764 | # If $nocheck is true, just print the sub name. |
| 3765 | # Otherwise, check it against the pattern. We then use |
| 3766 | # the XOR trick to reverse the condition as required. |
| 3767 | foreach $subname ( sort( keys %sub ) ) { |
| 3768 | if ( $Snocheck or $Srev ^ ( $subname =~ /$Spatt/ ) ) { |
| 3769 | print $OUT $subname, "\n"; |
| 3770 | } |
| 3771 | } |
| 3772 | next CMD; |
| 3773 | } |
| 3774 | |
| 3775 | return; |
| 3776 | } |
| 3777 | |
| 3778 | sub _handle_V_command_and_X_command { |
| 3779 | my $self = shift; |
| 3780 | |
| 3781 | $DB::cmd =~ s/^X\b/V $DB::package/; |
| 3782 | |
| 3783 | # Bare V commands get the currently-being-debugged package |
| 3784 | # added. |
| 3785 | if ($self->_is_full('V')) { |
| 3786 | $DB::cmd = "V $DB::package"; |
| 3787 | } |
| 3788 | |
| 3789 | # V - show variables in package. |
| 3790 | if (my ($new_packname, $new_vars_str) = |
| 3791 | $DB::cmd =~ /\AV\b\s*(\S+)\s*(.*)/) { |
| 3792 | |
| 3793 | # Save the currently selected filehandle and |
| 3794 | # force output to debugger's filehandle (dumpvar |
| 3795 | # just does "print" for output). |
| 3796 | my $savout = select($OUT); |
| 3797 | |
| 3798 | # Grab package name and variables to dump. |
| 3799 | $packname = $new_packname; |
| 3800 | my @vars = split( ' ', $new_vars_str ); |
| 3801 | |
| 3802 | # If main::dumpvar isn't here, get it. |
| 3803 | do 'dumpvar.pl' || die $@ unless defined &main::dumpvar; |
| 3804 | if ( defined &main::dumpvar ) { |
| 3805 | |
| 3806 | # We got it. Turn off subroutine entry/exit messages |
| 3807 | # for the moment, along with return values. |
| 3808 | local $frame = 0; |
| 3809 | local $doret = -2; |
| 3810 | |
| 3811 | # must detect sigpipe failures - not catching |
| 3812 | # then will cause the debugger to die. |
| 3813 | eval { |
| 3814 | main::dumpvar( |
| 3815 | $packname, |
| 3816 | defined $option{dumpDepth} |
| 3817 | ? $option{dumpDepth} |
| 3818 | : -1, # assume -1 unless specified |
| 3819 | @vars |
| 3820 | ); |
| 3821 | }; |
| 3822 | |
| 3823 | # The die doesn't need to include the $@, because |
| 3824 | # it will automatically get propagated for us. |
| 3825 | if ($@) { |
| 3826 | die unless $@ =~ /dumpvar print failed/; |
| 3827 | } |
| 3828 | } ## end if (defined &main::dumpvar) |
| 3829 | else { |
| 3830 | |
| 3831 | # Couldn't load dumpvar. |
| 3832 | print $OUT "dumpvar.pl not available.\n"; |
| 3833 | } |
| 3834 | |
| 3835 | # Restore the output filehandle, and go round again. |
| 3836 | select($savout); |
| 3837 | next CMD; |
| 3838 | } |
| 3839 | |
| 3840 | return; |
| 3841 | } |
| 3842 | |
| 3843 | sub _handle_dash_command { |
| 3844 | my $self = shift; |
| 3845 | |
| 3846 | if ($self->_is_full('-')) { |
| 3847 | |
| 3848 | # back up by a window; go to 1 if back too far. |
| 3849 | $start -= $incr + $window + 1; |
| 3850 | $start = 1 if $start <= 0; |
| 3851 | $incr = $window - 1; |
| 3852 | |
| 3853 | # Generate and execute a "l +" command (handled below). |
| 3854 | $DB::cmd = 'l ' . ($start) . '+'; |
| 3855 | redo CMD; |
| 3856 | } |
| 3857 | return; |
| 3858 | } |
| 3859 | |
| 3860 | sub _n_or_s_commands_generic { |
| 3861 | my ($self, $new_val) = @_; |
| 3862 | # n - next |
| 3863 | next CMD if DB::_DB__is_finished(); |
| 3864 | |
| 3865 | # Single step, but don't enter subs. |
| 3866 | $single = $new_val; |
| 3867 | |
| 3868 | # Save for empty command (repeat last). |
| 3869 | $laststep = $DB::cmd; |
| 3870 | last CMD; |
| 3871 | } |
| 3872 | |
| 3873 | sub _n_or_s { |
| 3874 | my ($self, $letter, $new_val) = @_; |
| 3875 | |
| 3876 | if ($self->_is_full($letter)) { |
| 3877 | $self->_n_or_s_commands_generic($new_val); |
| 3878 | } |
| 3879 | else { |
| 3880 | $self->_n_or_s_and_arg_commands_generic($letter, $new_val); |
| 3881 | } |
| 3882 | |
| 3883 | return; |
| 3884 | } |
| 3885 | |
| 3886 | sub _handle_n_command { |
| 3887 | my $self = shift; |
| 3888 | |
| 3889 | return $self->_n_or_s('n', 2); |
| 3890 | } |
| 3891 | |
| 3892 | sub _handle_s_command { |
| 3893 | my $self = shift; |
| 3894 | |
| 3895 | return $self->_n_or_s('s', 1); |
| 3896 | } |
| 3897 | |
| 3898 | sub _handle_r_command { |
| 3899 | my $self = shift; |
| 3900 | |
| 3901 | # r - return from the current subroutine. |
| 3902 | if ($self->_is_full('r')) { |
| 3903 | |
| 3904 | # Can't do anything if the program's over. |
| 3905 | next CMD if DB::_DB__is_finished(); |
| 3906 | |
| 3907 | # Turn on stack trace. |
| 3908 | $stack[$stack_depth] |= 1; |
| 3909 | |
| 3910 | # Print return value unless the stack is empty. |
| 3911 | $doret = $option{PrintRet} ? $stack_depth - 1 : -2; |
| 3912 | last CMD; |
| 3913 | } |
| 3914 | |
| 3915 | return; |
| 3916 | } |
| 3917 | |
| 3918 | sub _handle_T_command { |
| 3919 | my $self = shift; |
| 3920 | |
| 3921 | if ($self->_is_full('T')) { |
| 3922 | DB::print_trace( $OUT, 1 ); # skip DB |
| 3923 | next CMD; |
| 3924 | } |
| 3925 | |
| 3926 | return; |
| 3927 | } |
| 3928 | |
| 3929 | sub _handle_w_command { |
| 3930 | my $self = shift; |
| 3931 | |
| 3932 | DB::cmd_w( 'w', $self->cmd_args() ); |
| 3933 | next CMD; |
| 3934 | |
| 3935 | return; |
| 3936 | } |
| 3937 | |
| 3938 | sub _handle_W_command { |
| 3939 | my $self = shift; |
| 3940 | |
| 3941 | if (my $arg = $self->cmd_args) { |
| 3942 | DB::cmd_W( 'W', $arg ); |
| 3943 | next CMD; |
| 3944 | } |
| 3945 | |
| 3946 | return; |
| 3947 | } |
| 3948 | |
| 3949 | sub _handle_rc_recall_command { |
| 3950 | my $self = shift; |
| 3951 | |
| 3952 | # $rc - recall command. |
| 3953 | if (my ($minus, $arg) = $DB::cmd =~ m#\A$rc+\s*(-)?(\d+)?\z#) { |
| 3954 | |
| 3955 | # No arguments, take one thing off history. |
| 3956 | pop(@hist) if length($DB::cmd) > 1; |
| 3957 | |
| 3958 | # Relative (- found)? |
| 3959 | # Y - index back from most recent (by 1 if bare minus) |
| 3960 | # N - go to that particular command slot or the last |
| 3961 | # thing if nothing following. |
| 3962 | |
| 3963 | $self->cmd_verb( |
| 3964 | scalar($minus ? ( $#hist - ( $arg || 1 ) ) : ( $arg || $#hist )) |
| 3965 | ); |
| 3966 | |
| 3967 | # Pick out the command desired. |
| 3968 | $DB::cmd = $hist[$self->cmd_verb]; |
| 3969 | |
| 3970 | # Print the command to be executed and restart the loop |
| 3971 | # with that command in the buffer. |
| 3972 | print {$OUT} $DB::cmd, "\n"; |
| 3973 | redo CMD; |
| 3974 | } |
| 3975 | |
| 3976 | return; |
| 3977 | } |
| 3978 | |
| 3979 | sub _handle_rc_search_history_command { |
| 3980 | my $self = shift; |
| 3981 | |
| 3982 | # $rc pattern $rc - find a command in the history. |
| 3983 | if (my ($arg) = $DB::cmd =~ /\A$rc([^$rc].*)\z/) { |
| 3984 | |
| 3985 | # Create the pattern to use. |
| 3986 | my $pat = "^$arg"; |
| 3987 | $self->pat($pat); |
| 3988 | |
| 3989 | # Toss off last entry if length is >1 (and it always is). |
| 3990 | pop(@hist) if length($DB::cmd) > 1; |
| 3991 | |
| 3992 | my $i; |
| 3993 | |
| 3994 | # Look backward through the history. |
| 3995 | SEARCH_HIST: |
| 3996 | for ( $i = $#hist ; $i ; --$i ) { |
| 3997 | # Stop if we find it. |
| 3998 | last SEARCH_HIST if $hist[$i] =~ /$pat/; |
| 3999 | } |
| 4000 | |
| 4001 | if ( !$i ) { |
| 4002 | |
| 4003 | # Never found it. |
| 4004 | print $OUT "No such command!\n\n"; |
| 4005 | next CMD; |
| 4006 | } |
| 4007 | |
| 4008 | # Found it. Put it in the buffer, print it, and process it. |
| 4009 | $DB::cmd = $hist[$i]; |
| 4010 | print $OUT $DB::cmd, "\n"; |
| 4011 | redo CMD; |
| 4012 | } |
| 4013 | |
| 4014 | return; |
| 4015 | } |
| 4016 | |
| 4017 | sub _handle_H_command { |
| 4018 | my $self = shift; |
| 4019 | |
| 4020 | if ($self->cmd_args =~ m#\A\*#) { |
| 4021 | @hist = @truehist = (); |
| 4022 | print $OUT "History cleansed\n"; |
| 4023 | next CMD; |
| 4024 | } |
| 4025 | |
| 4026 | if (my ($num) = $self->cmd_args =~ /\A(?:-(\d+))?/) { |
| 4027 | |
| 4028 | # Anything other than negative numbers is ignored by |
| 4029 | # the (incorrect) pattern, so this test does nothing. |
| 4030 | $end = $num ? ( $#hist - $num ) : 0; |
| 4031 | |
| 4032 | # Set to the minimum if less than zero. |
| 4033 | $hist = 0 if $hist < 0; |
| 4034 | |
| 4035 | # Start at the end of the array. |
| 4036 | # Stay in while we're still above the ending value. |
| 4037 | # Tick back by one each time around the loop. |
| 4038 | my $i; |
| 4039 | |
| 4040 | for ( $i = $#hist ; $i > $end ; $i-- ) { |
| 4041 | print $OUT "$i: ", $hist[$i], "\n"; |
| 4042 | } |
| 4043 | |
| 4044 | next CMD; |
| 4045 | } |
| 4046 | |
| 4047 | return; |
| 4048 | } |
| 4049 | |
| 4050 | sub _handle_doc_command { |
| 4051 | my $self = shift; |
| 4052 | |
| 4053 | # man, perldoc, doc - show manual pages. |
| 4054 | if (my ($man_page) |
| 4055 | = $DB::cmd =~ /\A(?:man|(?:perl)?doc)\b(?:\s+([^(]*))?\z/) { |
| 4056 | DB::runman($man_page); |
| 4057 | next CMD; |
| 4058 | } |
| 4059 | |
| 4060 | return; |
| 4061 | } |
| 4062 | |
| 4063 | sub _handle_p_command { |
| 4064 | my $self = shift; |
| 4065 | |
| 4066 | my $print_cmd = 'print {$DB::OUT} '; |
| 4067 | # p - print (no args): print $_. |
| 4068 | if ($self->_is_full('p')) { |
| 4069 | $DB::cmd = $print_cmd . '$_'; |
| 4070 | } |
| 4071 | else { |
| 4072 | # p - print the given expression. |
| 4073 | $DB::cmd =~ s/\Ap\b/$print_cmd /; |
| 4074 | } |
| 4075 | |
| 4076 | return; |
| 4077 | } |
| 4078 | |
| 4079 | sub _handle_equal_sign_command { |
| 4080 | my $self = shift; |
| 4081 | |
| 4082 | if ($DB::cmd =~ s/\A=\s*//) { |
| 4083 | my @keys; |
| 4084 | if ( length $DB::cmd == 0 ) { |
| 4085 | |
| 4086 | # No args, get current aliases. |
| 4087 | @keys = sort keys %alias; |
| 4088 | } |
| 4089 | elsif ( my ( $k, $v ) = ( $DB::cmd =~ /^(\S+)\s+(\S.*)/ ) ) { |
| 4090 | |
| 4091 | # Creating a new alias. $k is alias name, $v is |
| 4092 | # alias value. |
| 4093 | |
| 4094 | # can't use $_ or kill //g state |
| 4095 | for my $x ( $k, $v ) { |
| 4096 | |
| 4097 | # Escape "alarm" characters. |
| 4098 | $x =~ s/\a/\\a/g; |
| 4099 | } |
| 4100 | |
| 4101 | # Substitute key for value, using alarm chars |
| 4102 | # as separators (which is why we escaped them in |
| 4103 | # the command). |
| 4104 | $alias{$k} = "s\a$k\a$v\a"; |
| 4105 | |
| 4106 | # Turn off standard warn and die behavior. |
| 4107 | local $SIG{__DIE__}; |
| 4108 | local $SIG{__WARN__}; |
| 4109 | |
| 4110 | # Is it valid Perl? |
| 4111 | unless ( eval "sub { s\a$k\a$v\a }; 1" ) { |
| 4112 | |
| 4113 | # Nope. Bad alias. Say so and get out. |
| 4114 | print $OUT "Can't alias $k to $v: $@\n"; |
| 4115 | delete $alias{$k}; |
| 4116 | next CMD; |
| 4117 | } |
| 4118 | |
| 4119 | # We'll only list the new one. |
| 4120 | @keys = ($k); |
| 4121 | } ## end elsif (my ($k, $v) = ($DB::cmd... |
| 4122 | |
| 4123 | # The argument is the alias to list. |
| 4124 | else { |
| 4125 | @keys = ($DB::cmd); |
| 4126 | } |
| 4127 | |
| 4128 | # List aliases. |
| 4129 | for my $k (@keys) { |
| 4130 | |
| 4131 | # Messy metaquoting: Trim the substitution code off. |
| 4132 | # We use control-G as the delimiter because it's not |
| 4133 | # likely to appear in the alias. |
| 4134 | if ( ( my $v = $alias{$k} ) =~ s\as\a$k\a(.*)\a$\a1\a ) { |
| 4135 | |
| 4136 | # Print the alias. |
| 4137 | print $OUT "$k\t= $1\n"; |
| 4138 | } |
| 4139 | elsif ( defined $alias{$k} ) { |
| 4140 | |
| 4141 | # Couldn't trim it off; just print the alias code. |
| 4142 | print $OUT "$k\t$alias{$k}\n"; |
| 4143 | } |
| 4144 | else { |
| 4145 | |
| 4146 | # No such, dude. |
| 4147 | print "No alias for $k\n"; |
| 4148 | } |
| 4149 | } ## end for my $k (@keys) |
| 4150 | next CMD; |
| 4151 | } |
| 4152 | |
| 4153 | return; |
| 4154 | } |
| 4155 | |
| 4156 | sub _handle_source_command { |
| 4157 | my $self = shift; |
| 4158 | |
| 4159 | # source - read commands from a file (or pipe!) and execute. |
| 4160 | if (my $sourced_fn = $self->cmd_args) { |
| 4161 | if ( open my $fh, $sourced_fn ) { |
| 4162 | |
| 4163 | # Opened OK; stick it in the list of file handles. |
| 4164 | push @cmdfhs, $fh; |
| 4165 | } |
| 4166 | else { |
| 4167 | |
| 4168 | # Couldn't open it. |
| 4169 | DB::_db_warn("Can't execute '$sourced_fn': $!\n"); |
| 4170 | } |
| 4171 | next CMD; |
| 4172 | } |
| 4173 | |
| 4174 | return; |
| 4175 | } |
| 4176 | |
| 4177 | sub _handle_enable_disable_commands { |
| 4178 | my $self = shift; |
| 4179 | |
| 4180 | my $which_cmd = $self->cmd_verb; |
| 4181 | my $position = $self->cmd_args; |
| 4182 | |
| 4183 | if ($position !~ /\s/) { |
| 4184 | my ($fn, $line_num); |
| 4185 | if ($position =~ m{\A\d+\z}) |
| 4186 | { |
| 4187 | $fn = $DB::filename; |
| 4188 | $line_num = $position; |
| 4189 | } |
| 4190 | elsif (my ($new_fn, $new_line_num) |
| 4191 | = $position =~ m{\A(.*):(\d+)\z}) { |
| 4192 | ($fn, $line_num) = ($new_fn, $new_line_num); |
| 4193 | } |
| 4194 | else |
| 4195 | { |
| 4196 | DB::_db_warn("Wrong spec for enable/disable argument.\n"); |
| 4197 | } |
| 4198 | |
| 4199 | if (defined($fn)) { |
| 4200 | if (DB::_has_breakpoint_data_ref($fn, $line_num)) { |
| 4201 | DB::_set_breakpoint_enabled_status($fn, $line_num, |
| 4202 | ($which_cmd eq 'enable' ? 1 : '') |
| 4203 | ); |
| 4204 | } |
| 4205 | else { |
| 4206 | DB::_db_warn("No breakpoint set at ${fn}:${line_num}\n"); |
| 4207 | } |
| 4208 | } |
| 4209 | |
| 4210 | next CMD; |
| 4211 | } |
| 4212 | |
| 4213 | return; |
| 4214 | } |
| 4215 | |
| 4216 | sub _handle_save_command { |
| 4217 | my $self = shift; |
| 4218 | |
| 4219 | if (my $new_fn = $self->cmd_args) { |
| 4220 | my $filename = $new_fn || '.perl5dbrc'; # default? |
| 4221 | if ( open my $fh, '>', $filename ) { |
| 4222 | |
| 4223 | # chomp to remove extraneous newlines from source'd files |
| 4224 | chomp( my @truelist = |
| 4225 | map { m/\A\s*(save|source)/ ? "#$_" : $_ } |
| 4226 | @truehist ); |
| 4227 | print {$fh} join( "\n", @truelist ); |
| 4228 | print "commands saved in $filename\n"; |
| 4229 | } |
| 4230 | else { |
| 4231 | DB::_db_warn("Can't save debugger commands in '$new_fn': $!\n"); |
| 4232 | } |
| 4233 | next CMD; |
| 4234 | } |
| 4235 | |
| 4236 | return; |
| 4237 | } |
| 4238 | |
| 4239 | sub _n_or_s_and_arg_commands_generic { |
| 4240 | my ($self, $letter, $new_val) = @_; |
| 4241 | |
| 4242 | # s - single-step. Remember the last command was 's'. |
| 4243 | if ($DB::cmd =~ s#\A\Q$letter\E\s#\$DB::single = $new_val;\n#) { |
| 4244 | $laststep = $letter; |
| 4245 | } |
| 4246 | |
| 4247 | return; |
| 4248 | } |
| 4249 | |
| 4250 | sub _handle_sh_command { |
| 4251 | my $self = shift; |
| 4252 | |
| 4253 | # $sh$sh - run a shell command (if it's all ASCII). |
| 4254 | # Can't run shell commands with Unicode in the debugger, hmm. |
| 4255 | my $my_cmd = $DB::cmd; |
| 4256 | if ($my_cmd =~ m#\A$sh#gms) { |
| 4257 | |
| 4258 | if ($my_cmd =~ m#\G\z#cgms) { |
| 4259 | # Run the user's shell. If none defined, run Bourne. |
| 4260 | # We resume execution when the shell terminates. |
| 4261 | DB::_db_system( $ENV{SHELL} || "/bin/sh" ); |
| 4262 | next CMD; |
| 4263 | } |
| 4264 | elsif ($my_cmd =~ m#\G$sh\s*(.*)#cgms) { |
| 4265 | # System it. |
| 4266 | DB::_db_system($1); |
| 4267 | next CMD; |
| 4268 | } |
| 4269 | elsif ($my_cmd =~ m#\G\s*(.*)#cgms) { |
| 4270 | DB::_db_system( $ENV{SHELL} || "/bin/sh", "-c", $1 ); |
| 4271 | next CMD; |
| 4272 | } |
| 4273 | } |
| 4274 | } |
| 4275 | |
| 4276 | sub _handle_x_command { |
| 4277 | my $self = shift; |
| 4278 | |
| 4279 | if ($DB::cmd =~ s#\Ax\b# #) { # Remainder gets done by DB::eval() |
| 4280 | $onetimeDump = 'dump'; # main::dumpvar shows the output |
| 4281 | |
| 4282 | # handle special "x 3 blah" syntax XXX propagate |
| 4283 | # doc back to special variables. |
| 4284 | if ( $DB::cmd =~ s#\A\s*(\d+)(?=\s)# #) { |
| 4285 | $onetimedumpDepth = $1; |
| 4286 | } |
| 4287 | } |
| 4288 | |
| 4289 | return; |
| 4290 | } |
| 4291 | |
| 4292 | sub _do_quit { |
| 4293 | $fall_off_end = 1; |
| 4294 | DB::clean_ENV(); |
| 4295 | exit $?; |
| 4296 | } |
| 4297 | |
| 4298 | sub _handle_q_command { |
| 4299 | my $self = shift; |
| 4300 | |
| 4301 | if ($self->_is_full('q')) { |
| 4302 | _do_quit(); |
| 4303 | } |
| 4304 | |
| 4305 | return; |
| 4306 | } |
| 4307 | |
| 4308 | sub _handle_cmd_wrapper_commands { |
| 4309 | my $self = shift; |
| 4310 | |
| 4311 | DB::cmd_wrapper( $self->cmd_verb, $self->cmd_args, $line ); |
| 4312 | next CMD; |
| 4313 | } |
| 4314 | |
| 4315 | sub _handle_special_char_cmd_wrapper_commands { |
| 4316 | my $self = shift; |
| 4317 | |
| 4318 | # All of these commands were remapped in perl 5.8.0; |
| 4319 | # we send them off to the secondary dispatcher (see below). |
| 4320 | if (my ($cmd_letter, $my_arg) = $DB::cmd =~ /\A([<>\{]{1,2})\s*(.*)/so) { |
| 4321 | DB::cmd_wrapper( $cmd_letter, $my_arg, $line ); |
| 4322 | next CMD; |
| 4323 | } |
| 4324 | |
| 4325 | return; |
| 4326 | } |
| 4327 | |
| 4328 | } ## end DB::Obj |
| 4329 | |
| 4330 | package DB; |
| 4331 | |
| 4332 | # The following code may be executed now: |
| 4333 | # BEGIN {warn 4} |
| 4334 | |
| 4335 | =head2 sub |
| 4336 | |
| 4337 | C<sub> is called whenever a subroutine call happens in the program being |
| 4338 | debugged. The variable C<$DB::sub> contains the name of the subroutine |
| 4339 | being called. |
| 4340 | |
| 4341 | The core function of this subroutine is to actually call the sub in the proper |
| 4342 | context, capturing its output. This of course causes C<DB::DB> to get called |
| 4343 | again, repeating until the subroutine ends and returns control to C<DB::sub> |
| 4344 | again. Once control returns, C<DB::sub> figures out whether or not to dump the |
| 4345 | return value, and returns its captured copy of the return value as its own |
| 4346 | return value. The value then feeds back into the program being debugged as if |
| 4347 | C<DB::sub> hadn't been there at all. |
| 4348 | |
| 4349 | C<sub> does all the work of printing the subroutine entry and exit messages |
| 4350 | enabled by setting C<$frame>. It notes what sub the autoloader got called for, |
| 4351 | and also prints the return value if needed (for the C<r> command and if |
| 4352 | the 16 bit is set in C<$frame>). |
| 4353 | |
| 4354 | It also tracks the subroutine call depth by saving the current setting of |
| 4355 | C<$single> in the C<@stack> package global; if this exceeds the value in |
| 4356 | C<$deep>, C<sub> automatically turns on printing of the current depth by |
| 4357 | setting the C<4> bit in C<$single>. In any case, it keeps the current setting |
| 4358 | of stop/don't stop on entry to subs set as it currently is set. |
| 4359 | |
| 4360 | =head3 C<caller()> support |
| 4361 | |
| 4362 | If C<caller()> is called from the package C<DB>, it provides some |
| 4363 | additional data, in the following order: |
| 4364 | |
| 4365 | =over 4 |
| 4366 | |
| 4367 | =item * C<$package> |
| 4368 | |
| 4369 | The package name the sub was in |
| 4370 | |
| 4371 | =item * C<$filename> |
| 4372 | |
| 4373 | The filename it was defined in |
| 4374 | |
| 4375 | =item * C<$line> |
| 4376 | |
| 4377 | The line number it was defined on |
| 4378 | |
| 4379 | =item * C<$subroutine> |
| 4380 | |
| 4381 | The subroutine name; C<(eval)> if an C<eval>(). |
| 4382 | |
| 4383 | =item * C<$hasargs> |
| 4384 | |
| 4385 | 1 if it has arguments, 0 if not |
| 4386 | |
| 4387 | =item * C<$wantarray> |
| 4388 | |
| 4389 | 1 if array context, 0 if scalar context |
| 4390 | |
| 4391 | =item * C<$evaltext> |
| 4392 | |
| 4393 | The C<eval>() text, if any (undefined for S<C<eval BLOCK>>) |
| 4394 | |
| 4395 | =item * C<$is_require> |
| 4396 | |
| 4397 | frame was created by a C<use> or C<require> statement |
| 4398 | |
| 4399 | =item * C<$hints> |
| 4400 | |
| 4401 | pragma information; subject to change between versions |
| 4402 | |
| 4403 | =item * C<$bitmask> |
| 4404 | |
| 4405 | pragma information; subject to change between versions |
| 4406 | |
| 4407 | =item * C<@DB::args> |
| 4408 | |
| 4409 | arguments with which the subroutine was invoked |
| 4410 | |
| 4411 | =back |
| 4412 | |
| 4413 | =cut |
| 4414 | |
| 4415 | use vars qw($deep); |
| 4416 | |
| 4417 | # We need to fully qualify the name ("DB::sub") to make "use strict;" |
| 4418 | # happy. -- Shlomi Fish |
| 4419 | |
| 4420 | sub _indent_print_line_info { |
| 4421 | my ($offset, $str) = @_; |
| 4422 | |
| 4423 | print_lineinfo( ' ' x ($stack_depth - $offset), $str); |
| 4424 | |
| 4425 | return; |
| 4426 | } |
| 4427 | |
| 4428 | sub _print_frame_message { |
| 4429 | my ($al) = @_; |
| 4430 | |
| 4431 | if ($frame) { |
| 4432 | if ($frame & 4) { # Extended frame entry message |
| 4433 | _indent_print_line_info(-1, "in "); |
| 4434 | |
| 4435 | # Why -1? But it works! :-( |
| 4436 | # Because print_trace will call add 1 to it and then call |
| 4437 | # dump_trace; this results in our skipping -1+1 = 0 stack frames |
| 4438 | # in dump_trace. |
| 4439 | # |
| 4440 | # Now it's 0 because we extracted a function. |
| 4441 | print_trace( $LINEINFO, 0, 1, 1, "$sub$al" ); |
| 4442 | } |
| 4443 | else { |
| 4444 | _indent_print_line_info(-1, "entering $sub$al\n" ); |
| 4445 | } |
| 4446 | } |
| 4447 | |
| 4448 | return; |
| 4449 | } |
| 4450 | |
| 4451 | sub DB::sub { |
| 4452 | my ( $al, $ret, @ret ) = ""; |
| 4453 | |
| 4454 | # We stack the stack pointer and then increment it to protect us |
| 4455 | # from a situation that might unwind a whole bunch of call frames |
| 4456 | # at once. Localizing the stack pointer means that it will automatically |
| 4457 | # unwind the same amount when multiple stack frames are unwound. |
| 4458 | local $stack_depth = $stack_depth + 1; # Protect from non-local exits |
| 4459 | |
| 4460 | { |
| 4461 | # lock ourselves under threads |
| 4462 | # While lock() permits recursive locks, there's two cases where it's bad |
| 4463 | # that we keep a hold on the lock while we call the sub: |
| 4464 | # - during cloning, Package::CLONE might be called in the context of the new |
| 4465 | # thread, which will deadlock if we hold the lock across the threads::new call |
| 4466 | # - for any function that waits any significant time |
| 4467 | # This also deadlocks if the parent thread joins(), since holding the lock |
| 4468 | # will prevent any child threads passing this point. |
| 4469 | # So release the lock for the function call. |
| 4470 | lock($DBGR); |
| 4471 | |
| 4472 | # Whether or not the autoloader was running, a scalar to put the |
| 4473 | # sub's return value in (if needed), and an array to put the sub's |
| 4474 | # return value in (if needed). |
| 4475 | if ($sub eq 'threads::new' && $ENV{PERL5DB_THREADED}) { |
| 4476 | print "creating new thread\n"; |
| 4477 | } |
| 4478 | |
| 4479 | # If the last ten characters are '::AUTOLOAD', note we've traced |
| 4480 | # into AUTOLOAD for $sub. |
| 4481 | if ( length($sub) > 10 && substr( $sub, -10, 10 ) eq '::AUTOLOAD' ) { |
| 4482 | no strict 'refs'; |
| 4483 | $al = " for $$sub" if defined $$sub; |
| 4484 | } |
| 4485 | |
| 4486 | # Expand @stack. |
| 4487 | $#stack = $stack_depth; |
| 4488 | |
| 4489 | # Save current single-step setting. |
| 4490 | $stack[-1] = $single; |
| 4491 | |
| 4492 | # Turn off all flags except single-stepping. |
| 4493 | $single &= 1; |
| 4494 | |
| 4495 | # If we've gotten really deeply recursed, turn on the flag that will |
| 4496 | # make us stop with the 'deep recursion' message. |
| 4497 | $single |= 4 if $stack_depth == $deep; |
| 4498 | |
| 4499 | # If frame messages are on ... |
| 4500 | |
| 4501 | _print_frame_message($al); |
| 4502 | } |
| 4503 | |
| 4504 | # Determine the sub's return type, and capture appropriately. |
| 4505 | if (wantarray) { |
| 4506 | |
| 4507 | # Called in array context. call sub and capture output. |
| 4508 | # DB::DB will recursively get control again if appropriate; we'll come |
| 4509 | # back here when the sub is finished. |
| 4510 | no strict 'refs'; |
| 4511 | @ret = &$sub; |
| 4512 | } |
| 4513 | elsif ( defined wantarray ) { |
| 4514 | no strict 'refs'; |
| 4515 | # Save the value if it's wanted at all. |
| 4516 | $ret = &$sub; |
| 4517 | } |
| 4518 | else { |
| 4519 | no strict 'refs'; |
| 4520 | # Void return, explicitly. |
| 4521 | &$sub; |
| 4522 | undef $ret; |
| 4523 | } |
| 4524 | |
| 4525 | { |
| 4526 | lock($DBGR); |
| 4527 | |
| 4528 | # Pop the single-step value back off the stack. |
| 4529 | $single |= $stack[ $stack_depth-- ]; |
| 4530 | |
| 4531 | if ($frame & 2) { |
| 4532 | if ($frame & 4) { # Extended exit message |
| 4533 | _indent_print_line_info(0, "out "); |
| 4534 | print_trace( $LINEINFO, -1, 1, 1, "$sub$al" ); |
| 4535 | } |
| 4536 | else { |
| 4537 | _indent_print_line_info(0, "exited $sub$al\n" ); |
| 4538 | } |
| 4539 | } |
| 4540 | |
| 4541 | if (wantarray) { |
| 4542 | # Print the return info if we need to. |
| 4543 | if ( $doret eq $stack_depth or $frame & 16 ) { |
| 4544 | |
| 4545 | # Turn off output record separator. |
| 4546 | local $\ = ''; |
| 4547 | my $fh = ( $doret eq $stack_depth ? $OUT : $LINEINFO ); |
| 4548 | |
| 4549 | # Indent if we're printing because of $frame tracing. |
| 4550 | if ($frame & 16) |
| 4551 | { |
| 4552 | print {$fh} ' ' x $stack_depth; |
| 4553 | } |
| 4554 | |
| 4555 | # Print the return value. |
| 4556 | print {$fh} "list context return from $sub:\n"; |
| 4557 | dumpit( $fh, \@ret ); |
| 4558 | |
| 4559 | # And don't print it again. |
| 4560 | $doret = -2; |
| 4561 | } ## end if ($doret eq $stack_depth... |
| 4562 | # And we have to return the return value now. |
| 4563 | @ret; |
| 4564 | } ## end if (wantarray) |
| 4565 | # Scalar context. |
| 4566 | else { |
| 4567 | # If we are supposed to show the return value... same as before. |
| 4568 | if ( $doret eq $stack_depth or $frame & 16 and defined wantarray ) { |
| 4569 | local $\ = ''; |
| 4570 | my $fh = ( $doret eq $stack_depth ? $OUT : $LINEINFO ); |
| 4571 | print $fh ( ' ' x $stack_depth ) if $frame & 16; |
| 4572 | print $fh ( |
| 4573 | defined wantarray |
| 4574 | ? "scalar context return from $sub: " |
| 4575 | : "void context return from $sub\n" |
| 4576 | ); |
| 4577 | dumpit( $fh, $ret ) if defined wantarray; |
| 4578 | $doret = -2; |
| 4579 | } ## end if ($doret eq $stack_depth... |
| 4580 | |
| 4581 | # Return the appropriate scalar value. |
| 4582 | $ret; |
| 4583 | } ## end else [ if (wantarray) |
| 4584 | } |
| 4585 | } ## end sub _sub |
| 4586 | |
| 4587 | sub lsub : lvalue { |
| 4588 | |
| 4589 | # We stack the stack pointer and then increment it to protect us |
| 4590 | # from a situation that might unwind a whole bunch of call frames |
| 4591 | # at once. Localizing the stack pointer means that it will automatically |
| 4592 | # unwind the same amount when multiple stack frames are unwound. |
| 4593 | local $stack_depth = $stack_depth + 1; # Protect from non-local exits |
| 4594 | |
| 4595 | # Expand @stack. |
| 4596 | $#stack = $stack_depth; |
| 4597 | |
| 4598 | # Save current single-step setting. |
| 4599 | $stack[-1] = $single; |
| 4600 | |
| 4601 | # Turn off all flags except single-stepping. |
| 4602 | # Use local so the single-step value is popped back off the |
| 4603 | # stack for us. |
| 4604 | local $single = $single & 1; |
| 4605 | |
| 4606 | no strict 'refs'; |
| 4607 | { |
| 4608 | # lock ourselves under threads |
| 4609 | lock($DBGR); |
| 4610 | |
| 4611 | # Whether or not the autoloader was running, a scalar to put the |
| 4612 | # sub's return value in (if needed), and an array to put the sub's |
| 4613 | # return value in (if needed). |
| 4614 | my ( $al, $ret, @ret ) = ""; |
| 4615 | if ($sub =~ /^threads::new$/ && $ENV{PERL5DB_THREADED}) { |
| 4616 | print "creating new thread\n"; |
| 4617 | } |
| 4618 | |
| 4619 | # If the last ten characters are C'::AUTOLOAD', note we've traced |
| 4620 | # into AUTOLOAD for $sub. |
| 4621 | if ( length($sub) > 10 && substr( $sub, -10, 10 ) eq '::AUTOLOAD' ) { |
| 4622 | $al = " for $$sub"; |
| 4623 | } |
| 4624 | |
| 4625 | # If we've gotten really deeply recursed, turn on the flag that will |
| 4626 | # make us stop with the 'deep recursion' message. |
| 4627 | $single |= 4 if $stack_depth == $deep; |
| 4628 | |
| 4629 | # If frame messages are on ... |
| 4630 | _print_frame_message($al); |
| 4631 | } |
| 4632 | |
| 4633 | # call the original lvalue sub. |
| 4634 | &$sub; |
| 4635 | } |
| 4636 | |
| 4637 | # Abstracting common code from multiple places elsewhere: |
| 4638 | sub depth_print_lineinfo { |
| 4639 | my $always_print = shift; |
| 4640 | |
| 4641 | print_lineinfo( @_ ) if ($always_print or $stack_depth < $trace_to_depth); |
| 4642 | } |
| 4643 | |
| 4644 | =head1 EXTENDED COMMAND HANDLING AND THE COMMAND API |
| 4645 | |
| 4646 | In Perl 5.8.0, there was a major realignment of the commands and what they did, |
| 4647 | Most of the changes were to systematize the command structure and to eliminate |
| 4648 | commands that threw away user input without checking. |
| 4649 | |
| 4650 | The following sections describe the code added to make it easy to support |
| 4651 | multiple command sets with conflicting command names. This section is a start |
| 4652 | at unifying all command processing to make it simpler to develop commands. |
| 4653 | |
| 4654 | Note that all the cmd_[a-zA-Z] subroutines require the command name, a line |
| 4655 | number, and C<$dbline> (the current line) as arguments. |
| 4656 | |
| 4657 | Support functions in this section which have multiple modes of failure C<die> |
| 4658 | on error; the rest simply return a false value. |
| 4659 | |
| 4660 | The user-interface functions (all of the C<cmd_*> functions) just output |
| 4661 | error messages. |
| 4662 | |
| 4663 | =head2 C<%set> |
| 4664 | |
| 4665 | The C<%set> hash defines the mapping from command letter to subroutine |
| 4666 | name suffix. |
| 4667 | |
| 4668 | C<%set> is a two-level hash, indexed by set name and then by command name. |
| 4669 | Note that trying to set the CommandSet to C<foobar> simply results in the |
| 4670 | 5.8.0 command set being used, since there's no top-level entry for C<foobar>. |
| 4671 | |
| 4672 | =cut |
| 4673 | |
| 4674 | ### The API section |
| 4675 | |
| 4676 | my %set = ( # |
| 4677 | 'pre580' => { |
| 4678 | 'a' => 'pre580_a', |
| 4679 | 'A' => 'pre580_null', |
| 4680 | 'b' => 'pre580_b', |
| 4681 | 'B' => 'pre580_null', |
| 4682 | 'd' => 'pre580_null', |
| 4683 | 'D' => 'pre580_D', |
| 4684 | 'h' => 'pre580_h', |
| 4685 | 'M' => 'pre580_null', |
| 4686 | 'O' => 'o', |
| 4687 | 'o' => 'pre580_null', |
| 4688 | 'v' => 'M', |
| 4689 | 'w' => 'v', |
| 4690 | 'W' => 'pre580_W', |
| 4691 | }, |
| 4692 | 'pre590' => { |
| 4693 | '<' => 'pre590_prepost', |
| 4694 | '<<' => 'pre590_prepost', |
| 4695 | '>' => 'pre590_prepost', |
| 4696 | '>>' => 'pre590_prepost', |
| 4697 | '{' => 'pre590_prepost', |
| 4698 | '{{' => 'pre590_prepost', |
| 4699 | }, |
| 4700 | ); |
| 4701 | |
| 4702 | my %breakpoints_data; |
| 4703 | |
| 4704 | sub _has_breakpoint_data_ref { |
| 4705 | my ($filename, $line) = @_; |
| 4706 | |
| 4707 | return ( |
| 4708 | exists( $breakpoints_data{$filename} ) |
| 4709 | and |
| 4710 | exists( $breakpoints_data{$filename}{$line} ) |
| 4711 | ); |
| 4712 | } |
| 4713 | |
| 4714 | sub _get_breakpoint_data_ref { |
| 4715 | my ($filename, $line) = @_; |
| 4716 | |
| 4717 | return ($breakpoints_data{$filename}{$line} ||= +{}); |
| 4718 | } |
| 4719 | |
| 4720 | sub _delete_breakpoint_data_ref { |
| 4721 | my ($filename, $line) = @_; |
| 4722 | |
| 4723 | delete($breakpoints_data{$filename}{$line}); |
| 4724 | if (! scalar(keys( %{$breakpoints_data{$filename}} )) ) { |
| 4725 | delete($breakpoints_data{$filename}); |
| 4726 | } |
| 4727 | |
| 4728 | return; |
| 4729 | } |
| 4730 | |
| 4731 | sub _set_breakpoint_enabled_status { |
| 4732 | my ($filename, $line, $status) = @_; |
| 4733 | |
| 4734 | _get_breakpoint_data_ref($filename, $line)->{'enabled'} = |
| 4735 | ($status ? 1 : '') |
| 4736 | ; |
| 4737 | |
| 4738 | return; |
| 4739 | } |
| 4740 | |
| 4741 | sub _enable_breakpoint_temp_enabled_status { |
| 4742 | my ($filename, $line) = @_; |
| 4743 | |
| 4744 | _get_breakpoint_data_ref($filename, $line)->{'temp_enabled'} = 1; |
| 4745 | |
| 4746 | return; |
| 4747 | } |
| 4748 | |
| 4749 | sub _cancel_breakpoint_temp_enabled_status { |
| 4750 | my ($filename, $line) = @_; |
| 4751 | |
| 4752 | my $ref = _get_breakpoint_data_ref($filename, $line); |
| 4753 | |
| 4754 | delete ($ref->{'temp_enabled'}); |
| 4755 | |
| 4756 | if (! %$ref) { |
| 4757 | _delete_breakpoint_data_ref($filename, $line); |
| 4758 | } |
| 4759 | |
| 4760 | return; |
| 4761 | } |
| 4762 | |
| 4763 | sub _is_breakpoint_enabled { |
| 4764 | my ($filename, $line) = @_; |
| 4765 | |
| 4766 | my $data_ref = _get_breakpoint_data_ref($filename, $line); |
| 4767 | return ($data_ref->{'enabled'} || $data_ref->{'temp_enabled'}); |
| 4768 | } |
| 4769 | |
| 4770 | =head2 C<cmd_wrapper()> (API) |
| 4771 | |
| 4772 | C<cmd_wrapper()> allows the debugger to switch command sets |
| 4773 | depending on the value of the C<CommandSet> option. |
| 4774 | |
| 4775 | It tries to look up the command in the C<%set> package-level I<lexical> |
| 4776 | (which means external entities can't fiddle with it) and create the name of |
| 4777 | the sub to call based on the value found in the hash (if it's there). I<All> |
| 4778 | of the commands to be handled in a set have to be added to C<%set>; if they |
| 4779 | aren't found, the 5.8.0 equivalent is called (if there is one). |
| 4780 | |
| 4781 | This code uses symbolic references. |
| 4782 | |
| 4783 | =cut |
| 4784 | |
| 4785 | sub cmd_wrapper { |
| 4786 | my $cmd = shift; |
| 4787 | my $line = shift; |
| 4788 | my $dblineno = shift; |
| 4789 | |
| 4790 | # Assemble the command subroutine's name by looking up the |
| 4791 | # command set and command name in %set. If we can't find it, |
| 4792 | # default to the older version of the command. |
| 4793 | my $call = 'cmd_' |
| 4794 | . ( $set{$CommandSet}{$cmd} |
| 4795 | || ( $cmd =~ /\A[<>{]+/o ? 'prepost' : $cmd ) ); |
| 4796 | |
| 4797 | # Call the command subroutine, call it by name. |
| 4798 | return __PACKAGE__->can($call)->( $cmd, $line, $dblineno ); |
| 4799 | } ## end sub cmd_wrapper |
| 4800 | |
| 4801 | =head3 C<cmd_a> (command) |
| 4802 | |
| 4803 | The C<a> command handles pre-execution actions. These are associated with a |
| 4804 | particular line, so they're stored in C<%dbline>. We default to the current |
| 4805 | line if none is specified. |
| 4806 | |
| 4807 | =cut |
| 4808 | |
| 4809 | sub cmd_a { |
| 4810 | my $cmd = shift; |
| 4811 | my $line = shift || ''; # [.|line] expr |
| 4812 | my $dbline = shift; |
| 4813 | |
| 4814 | # If it's dot (here), or not all digits, use the current line. |
| 4815 | $line =~ s/\A\./$dbline/; |
| 4816 | |
| 4817 | # Should be a line number followed by an expression. |
| 4818 | if ( my ($lineno, $expr) = $line =~ /^\s*(\d*)\s*(\S.+)/ ) { |
| 4819 | |
| 4820 | if (! length($lineno)) { |
| 4821 | $lineno = $dbline; |
| 4822 | } |
| 4823 | |
| 4824 | # If we have an expression ... |
| 4825 | if ( length $expr ) { |
| 4826 | |
| 4827 | # ... but the line isn't breakable, complain. |
| 4828 | if ( $dbline[$lineno] == 0 ) { |
| 4829 | print $OUT |
| 4830 | "Line $lineno($dbline[$lineno]) does not have an action?\n"; |
| 4831 | } |
| 4832 | else { |
| 4833 | |
| 4834 | # It's executable. Record that the line has an action. |
| 4835 | $had_breakpoints{$filename} |= 2; |
| 4836 | |
| 4837 | # Remove any action, temp breakpoint, etc. |
| 4838 | $dbline{$lineno} =~ s/\0[^\0]*//; |
| 4839 | |
| 4840 | # Add the action to the line. |
| 4841 | $dbline{$lineno} .= "\0" . action($expr); |
| 4842 | |
| 4843 | _set_breakpoint_enabled_status($filename, $lineno, 1); |
| 4844 | } |
| 4845 | } ## end if (length $expr) |
| 4846 | } ## end if ($line =~ /^\s*(\d*)\s*(\S.+)/) |
| 4847 | else { |
| 4848 | |
| 4849 | # Syntax wrong. |
| 4850 | print $OUT |
| 4851 | "Adding an action requires an optional lineno and an expression\n" |
| 4852 | ; # hint |
| 4853 | } |
| 4854 | } ## end sub cmd_a |
| 4855 | |
| 4856 | =head3 C<cmd_A> (command) |
| 4857 | |
| 4858 | Delete actions. Similar to above, except the delete code is in a separate |
| 4859 | subroutine, C<delete_action>. |
| 4860 | |
| 4861 | =cut |
| 4862 | |
| 4863 | sub cmd_A { |
| 4864 | my $cmd = shift; |
| 4865 | my $line = shift || ''; |
| 4866 | my $dbline = shift; |
| 4867 | |
| 4868 | # Dot is this line. |
| 4869 | $line =~ s/^\./$dbline/; |
| 4870 | |
| 4871 | # Call delete_action with a null param to delete them all. |
| 4872 | # The '1' forces the eval to be true. It'll be false only |
| 4873 | # if delete_action blows up for some reason, in which case |
| 4874 | # we print $@ and get out. |
| 4875 | if ( $line eq '*' ) { |
| 4876 | if (! eval { _delete_all_actions(); 1 }) { |
| 4877 | print {$OUT} $@; |
| 4878 | return; |
| 4879 | } |
| 4880 | } |
| 4881 | |
| 4882 | # There's a real line number. Pass it to delete_action. |
| 4883 | # Error trapping is as above. |
| 4884 | elsif ( $line =~ /^(\S.*)/ ) { |
| 4885 | if (! eval { delete_action($1); 1 }) { |
| 4886 | print {$OUT} $@; |
| 4887 | return; |
| 4888 | } |
| 4889 | } |
| 4890 | |
| 4891 | # Swing and a miss. Bad syntax. |
| 4892 | else { |
| 4893 | print $OUT |
| 4894 | "Deleting an action requires a line number, or '*' for all\n" ; # hint |
| 4895 | } |
| 4896 | } ## end sub cmd_A |
| 4897 | |
| 4898 | =head3 C<delete_action> (API) |
| 4899 | |
| 4900 | C<delete_action> accepts either a line number or C<undef>. If a line number |
| 4901 | is specified, we check for the line being executable (if it's not, it |
| 4902 | couldn't have had an action). If it is, we just take the action off (this |
| 4903 | will get any kind of an action, including breakpoints). |
| 4904 | |
| 4905 | =cut |
| 4906 | |
| 4907 | sub _remove_action_from_dbline { |
| 4908 | my $i = shift; |
| 4909 | |
| 4910 | $dbline{$i} =~ s/\0[^\0]*//; # \^a |
| 4911 | delete $dbline{$i} if $dbline{$i} eq ''; |
| 4912 | |
| 4913 | return; |
| 4914 | } |
| 4915 | |
| 4916 | sub _delete_all_actions { |
| 4917 | print {$OUT} "Deleting all actions...\n"; |
| 4918 | |
| 4919 | for my $file ( keys %had_breakpoints ) { |
| 4920 | local *dbline = $main::{ '_<' . $file }; |
| 4921 | $max = $#dbline; |
| 4922 | my $was; |
| 4923 | for my $i (1 .. $max) { |
| 4924 | if ( defined $dbline{$i} ) { |
| 4925 | _remove_action_from_dbline($i); |
| 4926 | } |
| 4927 | } |
| 4928 | |
| 4929 | unless ( $had_breakpoints{$file} &= ~2 ) { |
| 4930 | delete $had_breakpoints{$file}; |
| 4931 | } |
| 4932 | } |
| 4933 | |
| 4934 | return; |
| 4935 | } |
| 4936 | |
| 4937 | sub delete_action { |
| 4938 | my $i = shift; |
| 4939 | |
| 4940 | if ( defined($i) ) { |
| 4941 | # Can there be one? |
| 4942 | die "Line $i has no action .\n" if $dbline[$i] == 0; |
| 4943 | |
| 4944 | # Nuke whatever's there. |
| 4945 | _remove_action_from_dbline($i); |
| 4946 | } |
| 4947 | else { |
| 4948 | _delete_all_actions(); |
| 4949 | } |
| 4950 | } |
| 4951 | |
| 4952 | =head3 C<cmd_b> (command) |
| 4953 | |
| 4954 | Set breakpoints. Since breakpoints can be set in so many places, in so many |
| 4955 | ways, conditionally or not, the breakpoint code is kind of complex. Mostly, |
| 4956 | we try to parse the command type, and then shuttle it off to an appropriate |
| 4957 | subroutine to actually do the work of setting the breakpoint in the right |
| 4958 | place. |
| 4959 | |
| 4960 | =cut |
| 4961 | |
| 4962 | sub cmd_b { |
| 4963 | my $cmd = shift; |
| 4964 | my $line = shift; # [.|line] [cond] |
| 4965 | my $dbline = shift; |
| 4966 | |
| 4967 | my $default_cond = sub { |
| 4968 | my $cond = shift; |
| 4969 | return length($cond) ? $cond : '1'; |
| 4970 | }; |
| 4971 | |
| 4972 | # Make . the current line number if it's there.. |
| 4973 | $line =~ s/^\.(\s|\z)/$dbline$1/; |
| 4974 | |
| 4975 | # No line number, no condition. Simple break on current line. |
| 4976 | if ( $line =~ /^\s*$/ ) { |
| 4977 | cmd_b_line( $dbline, 1 ); |
| 4978 | } |
| 4979 | |
| 4980 | # Break on load for a file. |
| 4981 | elsif ( my ($file) = $line =~ /^load\b\s*(.*)/ ) { |
| 4982 | $file =~ s/\s+\z//; |
| 4983 | cmd_b_load($file); |
| 4984 | } |
| 4985 | |
| 4986 | # b compile|postpone <some sub> [<condition>] |
| 4987 | # The interpreter actually traps this one for us; we just put the |
| 4988 | # necessary condition in the %postponed hash. |
| 4989 | elsif ( my ($action, $subname, $cond) |
| 4990 | = $line =~ /^(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ ) { |
| 4991 | |
| 4992 | # De-Perl4-ify the name - ' separators to ::. |
| 4993 | $subname =~ s/'/::/g; |
| 4994 | |
| 4995 | # Qualify it into the current package unless it's already qualified. |
| 4996 | $subname = "${package}::" . $subname unless $subname =~ /::/; |
| 4997 | |
| 4998 | # Add main if it starts with ::. |
| 4999 | $subname = "main" . $subname if substr( $subname, 0, 2 ) eq "::"; |
| 5000 | |
| 5001 | # Save the break type for this sub. |
| 5002 | $postponed{$subname} = (($action eq 'postpone') |
| 5003 | ? ( "break +0 if " . $default_cond->($cond) ) |
| 5004 | : "compile"); |
| 5005 | } ## end elsif ($line =~ ... |
| 5006 | # b <filename>:<line> [<condition>] |
| 5007 | elsif (my ($filename, $line_num, $cond) |
| 5008 | = $line =~ /\A(\S+[^:]):(\d+)\s*(.*)/ms) { |
| 5009 | cmd_b_filename_line( |
| 5010 | $filename, |
| 5011 | $line_num, |
| 5012 | (length($cond) ? $cond : '1'), |
| 5013 | ); |
| 5014 | } |
| 5015 | # b <sub name> [<condition>] |
| 5016 | elsif ( my ($new_subname, $new_cond) = |
| 5017 | $line =~ /^([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/ ) { |
| 5018 | |
| 5019 | # |
| 5020 | $subname = $new_subname; |
| 5021 | cmd_b_sub( $subname, $default_cond->($new_cond) ); |
| 5022 | } |
| 5023 | |
| 5024 | # b <line> [<condition>]. |
| 5025 | elsif ( my ($line_n, $cond) = $line =~ /^(\d*)\s*(.*)/ ) { |
| 5026 | |
| 5027 | # Capture the line. If none, it's the current line. |
| 5028 | $line = $line_n || $dbline; |
| 5029 | |
| 5030 | # Break on line. |
| 5031 | cmd_b_line( $line, $default_cond->($cond) ); |
| 5032 | } |
| 5033 | |
| 5034 | # Line didn't make sense. |
| 5035 | else { |
| 5036 | print "confused by line($line)?\n"; |
| 5037 | } |
| 5038 | |
| 5039 | return; |
| 5040 | } ## end sub cmd_b |
| 5041 | |
| 5042 | =head3 C<break_on_load> (API) |
| 5043 | |
| 5044 | We want to break when this file is loaded. Mark this file in the |
| 5045 | C<%break_on_load> hash, and note that it has a breakpoint in |
| 5046 | C<%had_breakpoints>. |
| 5047 | |
| 5048 | =cut |
| 5049 | |
| 5050 | sub break_on_load { |
| 5051 | my $file = shift; |
| 5052 | $break_on_load{$file} = 1; |
| 5053 | $had_breakpoints{$file} |= 1; |
| 5054 | } |
| 5055 | |
| 5056 | =head3 C<report_break_on_load> (API) |
| 5057 | |
| 5058 | Gives us an array of filenames that are set to break on load. Note that |
| 5059 | only files with break-on-load are in here, so simply showing the keys |
| 5060 | suffices. |
| 5061 | |
| 5062 | =cut |
| 5063 | |
| 5064 | sub report_break_on_load { |
| 5065 | sort keys %break_on_load; |
| 5066 | } |
| 5067 | |
| 5068 | =head3 C<cmd_b_load> (command) |
| 5069 | |
| 5070 | We take the file passed in and try to find it in C<%INC> (which maps modules |
| 5071 | to files they came from). We mark those files for break-on-load via |
| 5072 | C<break_on_load> and then report that it was done. |
| 5073 | |
| 5074 | =cut |
| 5075 | |
| 5076 | sub cmd_b_load { |
| 5077 | my $file = shift; |
| 5078 | my @files; |
| 5079 | |
| 5080 | # This is a block because that way we can use a redo inside it |
| 5081 | # even without there being any looping structure at all outside it. |
| 5082 | { |
| 5083 | |
| 5084 | # Save short name and full path if found. |
| 5085 | push @files, $file; |
| 5086 | push @files, $::INC{$file} if $::INC{$file}; |
| 5087 | |
| 5088 | # Tack on .pm and do it again unless there was a '.' in the name |
| 5089 | # already. |
| 5090 | $file .= '.pm', redo unless $file =~ /\./; |
| 5091 | } |
| 5092 | |
| 5093 | # Do the real work here. |
| 5094 | break_on_load($_) for @files; |
| 5095 | |
| 5096 | # All the files that have break-on-load breakpoints. |
| 5097 | @files = report_break_on_load; |
| 5098 | |
| 5099 | # Normalize for the purposes of our printing this. |
| 5100 | local $\ = ''; |
| 5101 | local $" = ' '; |
| 5102 | print $OUT "Will stop on load of '@files'.\n"; |
| 5103 | } ## end sub cmd_b_load |
| 5104 | |
| 5105 | =head3 C<$filename_error> (API package global) |
| 5106 | |
| 5107 | Several of the functions we need to implement in the API need to work both |
| 5108 | on the current file and on other files. We don't want to duplicate code, so |
| 5109 | C<$filename_error> is used to contain the name of the file that's being |
| 5110 | worked on (if it's not the current one). |
| 5111 | |
| 5112 | We can now build functions in pairs: the basic function works on the current |
| 5113 | file, and uses C<$filename_error> as part of its error message. Since this is |
| 5114 | initialized to C<"">, no filename will appear when we are working on the |
| 5115 | current file. |
| 5116 | |
| 5117 | The second function is a wrapper which does the following: |
| 5118 | |
| 5119 | =over 4 |
| 5120 | |
| 5121 | =item * |
| 5122 | |
| 5123 | Localizes C<$filename_error> and sets it to the name of the file to be processed. |
| 5124 | |
| 5125 | =item * |
| 5126 | |
| 5127 | Localizes the C<*dbline> glob and reassigns it to point to the file we want to process. |
| 5128 | |
| 5129 | =item * |
| 5130 | |
| 5131 | Calls the first function. |
| 5132 | |
| 5133 | The first function works on the I<current> file (i.e., the one we changed to), |
| 5134 | and prints C<$filename_error> in the error message (the name of the other file) |
| 5135 | if it needs to. When the functions return, C<*dbline> is restored to point |
| 5136 | to the actual current file (the one we're executing in) and |
| 5137 | C<$filename_error> is restored to C<"">. This restores everything to |
| 5138 | the way it was before the second function was called at all. |
| 5139 | |
| 5140 | See the comments in L<S<C<sub breakable_line>>|/breakable_line(from, to) (API)> |
| 5141 | and |
| 5142 | L<S<C<sub breakable_line_in_filename>>|/breakable_line_in_filename(file, from, to) (API)> |
| 5143 | for more details. |
| 5144 | |
| 5145 | =back |
| 5146 | |
| 5147 | =cut |
| 5148 | |
| 5149 | use vars qw($filename_error); |
| 5150 | $filename_error = ''; |
| 5151 | |
| 5152 | =head3 breakable_line(from, to) (API) |
| 5153 | |
| 5154 | The subroutine decides whether or not a line in the current file is breakable. |
| 5155 | It walks through C<@dbline> within the range of lines specified, looking for |
| 5156 | the first line that is breakable. |
| 5157 | |
| 5158 | If C<$to> is greater than C<$from>, the search moves forwards, finding the |
| 5159 | first line I<after> C<$to> that's breakable, if there is one. |
| 5160 | |
| 5161 | If C<$from> is greater than C<$to>, the search goes I<backwards>, finding the |
| 5162 | first line I<before> C<$to> that's breakable, if there is one. |
| 5163 | |
| 5164 | =cut |
| 5165 | |
| 5166 | sub breakable_line { |
| 5167 | |
| 5168 | my ( $from, $to ) = @_; |
| 5169 | |
| 5170 | # $i is the start point. (Where are the FORTRAN programs of yesteryear?) |
| 5171 | my $i = $from; |
| 5172 | |
| 5173 | # If there are at least 2 arguments, we're trying to search a range. |
| 5174 | if ( @_ >= 2 ) { |
| 5175 | |
| 5176 | # $delta is positive for a forward search, negative for a backward one. |
| 5177 | my $delta = $from < $to ? +1 : -1; |
| 5178 | |
| 5179 | # Keep us from running off the ends of the file. |
| 5180 | my $limit = $delta > 0 ? $#dbline : 1; |
| 5181 | |
| 5182 | # Clever test. If you're a mathematician, it's obvious why this |
| 5183 | # test works. If not: |
| 5184 | # If $delta is positive (going forward), $limit will be $#dbline. |
| 5185 | # If $to is less than $limit, ($limit - $to) will be positive, times |
| 5186 | # $delta of 1 (positive), so the result is > 0 and we should use $to |
| 5187 | # as the stopping point. |
| 5188 | # |
| 5189 | # If $to is greater than $limit, ($limit - $to) is negative, |
| 5190 | # times $delta of 1 (positive), so the result is < 0 and we should |
| 5191 | # use $limit ($#dbline) as the stopping point. |
| 5192 | # |
| 5193 | # If $delta is negative (going backward), $limit will be 1. |
| 5194 | # If $to is zero, ($limit - $to) will be 1, times $delta of -1 |
| 5195 | # (negative) so the result is > 0, and we use $to as the stopping |
| 5196 | # point. |
| 5197 | # |
| 5198 | # If $to is less than zero, ($limit - $to) will be positive, |
| 5199 | # times $delta of -1 (negative), so the result is not > 0, and |
| 5200 | # we use $limit (1) as the stopping point. |
| 5201 | # |
| 5202 | # If $to is 1, ($limit - $to) will zero, times $delta of -1 |
| 5203 | # (negative), still giving zero; the result is not > 0, and |
| 5204 | # we use $limit (1) as the stopping point. |
| 5205 | # |
| 5206 | # if $to is >1, ($limit - $to) will be negative, times $delta of -1 |
| 5207 | # (negative), giving a positive (>0) value, so we'll set $limit to |
| 5208 | # $to. |
| 5209 | |
| 5210 | $limit = $to if ( $limit - $to ) * $delta > 0; |
| 5211 | |
| 5212 | # The real search loop. |
| 5213 | # $i starts at $from (the point we want to start searching from). |
| 5214 | # We move through @dbline in the appropriate direction (determined |
| 5215 | # by $delta: either -1 (back) or +1 (ahead). |
| 5216 | # We stay in as long as we haven't hit an executable line |
| 5217 | # ($dbline[$i] == 0 means not executable) and we haven't reached |
| 5218 | # the limit yet (test similar to the above). |
| 5219 | $i += $delta while $dbline[$i] == 0 and ( $limit - $i ) * $delta > 0; |
| 5220 | |
| 5221 | } ## end if (@_ >= 2) |
| 5222 | |
| 5223 | # If $i points to a line that is executable, return that. |
| 5224 | return $i unless $dbline[$i] == 0; |
| 5225 | |
| 5226 | # Format the message and print it: no breakable lines in range. |
| 5227 | my ( $pl, $upto ) = ( '', '' ); |
| 5228 | ( $pl, $upto ) = ( 's', "..$to" ) if @_ >= 2 and $from != $to; |
| 5229 | |
| 5230 | # If there's a filename in filename_error, we'll see it. |
| 5231 | # If not, not. |
| 5232 | die "Line$pl $from$upto$filename_error not breakable\n"; |
| 5233 | } ## end sub breakable_line |
| 5234 | |
| 5235 | =head3 breakable_line_in_filename(file, from, to) (API) |
| 5236 | |
| 5237 | Like C<breakable_line>, but look in another file. |
| 5238 | |
| 5239 | =cut |
| 5240 | |
| 5241 | sub breakable_line_in_filename { |
| 5242 | |
| 5243 | # Capture the file name. |
| 5244 | my ($f) = shift; |
| 5245 | |
| 5246 | # Swap the magic line array over there temporarily. |
| 5247 | local *dbline = $main::{ '_<' . $f }; |
| 5248 | |
| 5249 | # If there's an error, it's in this other file. |
| 5250 | local $filename_error = " of '$f'"; |
| 5251 | |
| 5252 | # Find the breakable line. |
| 5253 | breakable_line(@_); |
| 5254 | |
| 5255 | # *dbline and $filename_error get restored when this block ends. |
| 5256 | |
| 5257 | } ## end sub breakable_line_in_filename |
| 5258 | |
| 5259 | =head3 break_on_line(lineno, [condition]) (API) |
| 5260 | |
| 5261 | Adds a breakpoint with the specified condition (or 1 if no condition was |
| 5262 | specified) to the specified line. Dies if it can't. |
| 5263 | |
| 5264 | =cut |
| 5265 | |
| 5266 | sub break_on_line { |
| 5267 | my $i = shift; |
| 5268 | my $cond = @_ ? shift(@_) : 1; |
| 5269 | |
| 5270 | my $inii = $i; |
| 5271 | my $after = ''; |
| 5272 | my $pl = ''; |
| 5273 | |
| 5274 | # Woops, not a breakable line. $filename_error allows us to say |
| 5275 | # if it was in a different file. |
| 5276 | die "Line $i$filename_error not breakable.\n" if $dbline[$i] == 0; |
| 5277 | |
| 5278 | # Mark this file as having breakpoints in it. |
| 5279 | $had_breakpoints{$filename} |= 1; |
| 5280 | |
| 5281 | # If there is an action or condition here already ... |
| 5282 | if ( $dbline{$i} ) { |
| 5283 | |
| 5284 | # ... swap this condition for the existing one. |
| 5285 | $dbline{$i} =~ s/^[^\0]*/$cond/; |
| 5286 | } |
| 5287 | else { |
| 5288 | |
| 5289 | # Nothing here - just add the condition. |
| 5290 | $dbline{$i} = $cond; |
| 5291 | |
| 5292 | _set_breakpoint_enabled_status($filename, $i, 1); |
| 5293 | } |
| 5294 | |
| 5295 | return; |
| 5296 | } ## end sub break_on_line |
| 5297 | |
| 5298 | =head3 cmd_b_line(line, [condition]) (command) |
| 5299 | |
| 5300 | Wrapper for C<break_on_line>. Prints the failure message if it |
| 5301 | doesn't work. |
| 5302 | |
| 5303 | =cut |
| 5304 | |
| 5305 | sub cmd_b_line { |
| 5306 | if (not eval { break_on_line(@_); 1 }) { |
| 5307 | local $\ = ''; |
| 5308 | print $OUT $@ and return; |
| 5309 | } |
| 5310 | |
| 5311 | return; |
| 5312 | } ## end sub cmd_b_line |
| 5313 | |
| 5314 | =head3 cmd_b_filename_line(line, [condition]) (command) |
| 5315 | |
| 5316 | Wrapper for C<break_on_filename_line>. Prints the failure message if it |
| 5317 | doesn't work. |
| 5318 | |
| 5319 | =cut |
| 5320 | |
| 5321 | sub cmd_b_filename_line { |
| 5322 | if (not eval { break_on_filename_line(@_); 1 }) { |
| 5323 | local $\ = ''; |
| 5324 | print $OUT $@ and return; |
| 5325 | } |
| 5326 | |
| 5327 | return; |
| 5328 | } |
| 5329 | |
| 5330 | =head3 break_on_filename_line(file, line, [condition]) (API) |
| 5331 | |
| 5332 | Switches to the file specified and then calls C<break_on_line> to set |
| 5333 | the breakpoint. |
| 5334 | |
| 5335 | =cut |
| 5336 | |
| 5337 | sub break_on_filename_line { |
| 5338 | my $f = shift; |
| 5339 | my $i = shift; |
| 5340 | my $cond = @_ ? shift(@_) : 1; |
| 5341 | |
| 5342 | # Switch the magical hash temporarily. |
| 5343 | local *dbline = $main::{ '_<' . $f }; |
| 5344 | |
| 5345 | # Localize the variables that break_on_line uses to make its message. |
| 5346 | local $filename_error = " of '$f'"; |
| 5347 | local $filename = $f; |
| 5348 | |
| 5349 | # Add the breakpoint. |
| 5350 | break_on_line( $i, $cond ); |
| 5351 | |
| 5352 | return; |
| 5353 | } ## end sub break_on_filename_line |
| 5354 | |
| 5355 | =head3 break_on_filename_line_range(file, from, to, [condition]) (API) |
| 5356 | |
| 5357 | Switch to another file, search the range of lines specified for an |
| 5358 | executable one, and put a breakpoint on the first one you find. |
| 5359 | |
| 5360 | =cut |
| 5361 | |
| 5362 | sub break_on_filename_line_range { |
| 5363 | my $f = shift; |
| 5364 | my $from = shift; |
| 5365 | my $to = shift; |
| 5366 | my $cond = @_ ? shift(@_) : 1; |
| 5367 | |
| 5368 | # Find a breakable line if there is one. |
| 5369 | my $i = breakable_line_in_filename( $f, $from, $to ); |
| 5370 | |
| 5371 | # Add the breakpoint. |
| 5372 | break_on_filename_line( $f, $i, $cond ); |
| 5373 | |
| 5374 | return; |
| 5375 | } ## end sub break_on_filename_line_range |
| 5376 | |
| 5377 | =head3 subroutine_filename_lines(subname, [condition]) (API) |
| 5378 | |
| 5379 | Search for a subroutine within a given file. The condition is ignored. |
| 5380 | Uses C<find_sub> to locate the desired subroutine. |
| 5381 | |
| 5382 | =cut |
| 5383 | |
| 5384 | sub subroutine_filename_lines { |
| 5385 | my ( $subname ) = @_; |
| 5386 | |
| 5387 | # Returned value from find_sub() is fullpathname:startline-endline. |
| 5388 | # The match creates the list (fullpathname, start, end). |
| 5389 | return (find_sub($subname) =~ /^(.*):(\d+)-(\d+)$/); |
| 5390 | } ## end sub subroutine_filename_lines |
| 5391 | |
| 5392 | =head3 break_subroutine(subname) (API) |
| 5393 | |
| 5394 | Places a break on the first line possible in the specified subroutine. Uses |
| 5395 | C<subroutine_filename_lines> to find the subroutine, and |
| 5396 | C<break_on_filename_line_range> to place the break. |
| 5397 | |
| 5398 | =cut |
| 5399 | |
| 5400 | sub break_subroutine { |
| 5401 | my $subname = shift; |
| 5402 | |
| 5403 | # Get filename, start, and end. |
| 5404 | my ( $file, $s, $e ) = subroutine_filename_lines($subname) |
| 5405 | or die "Subroutine $subname not found.\n"; |
| 5406 | |
| 5407 | |
| 5408 | # Null condition changes to '1' (always true). |
| 5409 | my $cond = @_ ? shift(@_) : 1; |
| 5410 | |
| 5411 | # Put a break the first place possible in the range of lines |
| 5412 | # that make up this subroutine. |
| 5413 | break_on_filename_line_range( $file, $s, $e, $cond ); |
| 5414 | |
| 5415 | return; |
| 5416 | } ## end sub break_subroutine |
| 5417 | |
| 5418 | =head3 cmd_b_sub(subname, [condition]) (command) |
| 5419 | |
| 5420 | We take the incoming subroutine name and fully-qualify it as best we can. |
| 5421 | |
| 5422 | =over 4 |
| 5423 | |
| 5424 | =item 1. If it's already fully-qualified, leave it alone. |
| 5425 | |
| 5426 | =item 2. Try putting it in the current package. |
| 5427 | |
| 5428 | =item 3. If it's not there, try putting it in CORE::GLOBAL if it exists there. |
| 5429 | |
| 5430 | =item 4. If it starts with '::', put it in 'main::'. |
| 5431 | |
| 5432 | =back |
| 5433 | |
| 5434 | After all this cleanup, we call C<break_subroutine> to try to set the |
| 5435 | breakpoint. |
| 5436 | |
| 5437 | =cut |
| 5438 | |
| 5439 | sub cmd_b_sub { |
| 5440 | my $subname = shift; |
| 5441 | my $cond = @_ ? shift : 1; |
| 5442 | |
| 5443 | # If the subname isn't a code reference, qualify it so that |
| 5444 | # break_subroutine() will work right. |
| 5445 | if ( ref($subname) ne 'CODE' ) { |
| 5446 | |
| 5447 | # Not Perl 4. |
| 5448 | $subname =~ s/'/::/g; |
| 5449 | my $s = $subname; |
| 5450 | |
| 5451 | # Put it in this package unless it's already qualified. |
| 5452 | if ($subname !~ /::/) |
| 5453 | { |
| 5454 | $subname = $package . '::' . $subname; |
| 5455 | }; |
| 5456 | |
| 5457 | # Requalify it into CORE::GLOBAL if qualifying it into this |
| 5458 | # package resulted in its not being defined, but only do so |
| 5459 | # if it really is in CORE::GLOBAL. |
| 5460 | my $core_name = "CORE::GLOBAL::$s"; |
| 5461 | if ((!defined(&$subname)) |
| 5462 | and ($s !~ /::/) |
| 5463 | and (defined &{$core_name})) |
| 5464 | { |
| 5465 | $subname = $core_name; |
| 5466 | } |
| 5467 | |
| 5468 | # Put it in package 'main' if it has a leading ::. |
| 5469 | if ($subname =~ /\A::/) |
| 5470 | { |
| 5471 | $subname = "main" . $subname; |
| 5472 | } |
| 5473 | } ## end if ( ref($subname) ne 'CODE' ) { |
| 5474 | |
| 5475 | # Try to set the breakpoint. |
| 5476 | if (not eval { break_subroutine( $subname, $cond ); 1 }) { |
| 5477 | local $\ = ''; |
| 5478 | print {$OUT} $@; |
| 5479 | return; |
| 5480 | } |
| 5481 | |
| 5482 | return; |
| 5483 | } ## end sub cmd_b_sub |
| 5484 | |
| 5485 | =head3 C<cmd_B> - delete breakpoint(s) (command) |
| 5486 | |
| 5487 | The command mostly parses the command line and tries to turn the argument |
| 5488 | into a line spec. If it can't, it uses the current line. It then calls |
| 5489 | C<delete_breakpoint> to actually do the work. |
| 5490 | |
| 5491 | If C<*> is specified, C<cmd_B> calls C<delete_breakpoint> with no arguments, |
| 5492 | thereby deleting all the breakpoints. |
| 5493 | |
| 5494 | =cut |
| 5495 | |
| 5496 | sub cmd_B { |
| 5497 | my $cmd = shift; |
| 5498 | |
| 5499 | # No line spec? Use dbline. |
| 5500 | # If there is one, use it if it's non-zero, or wipe it out if it is. |
| 5501 | my $line = ( $_[0] =~ /\A\./ ) ? $dbline : (shift || ''); |
| 5502 | my $dbline = shift; |
| 5503 | |
| 5504 | # If the line was dot, make the line the current one. |
| 5505 | $line =~ s/^\./$dbline/; |
| 5506 | |
| 5507 | # If it's * we're deleting all the breakpoints. |
| 5508 | if ( $line eq '*' ) { |
| 5509 | if (not eval { delete_breakpoint(); 1 }) { |
| 5510 | print {$OUT} $@; |
| 5511 | } |
| 5512 | } |
| 5513 | |
| 5514 | # If there is a line spec, delete the breakpoint on that line. |
| 5515 | elsif ( $line =~ /\A(\S.*)/ ) { |
| 5516 | if (not eval { delete_breakpoint( $line || $dbline ); 1 }) { |
| 5517 | local $\ = ''; |
| 5518 | print {$OUT} $@; |
| 5519 | } |
| 5520 | } ## end elsif ($line =~ /^(\S.*)/) |
| 5521 | |
| 5522 | # No line spec. |
| 5523 | else { |
| 5524 | print {$OUT} |
| 5525 | "Deleting a breakpoint requires a line number, or '*' for all\n" |
| 5526 | ; # hint |
| 5527 | } |
| 5528 | |
| 5529 | return; |
| 5530 | } ## end sub cmd_B |
| 5531 | |
| 5532 | =head3 delete_breakpoint([line]) (API) |
| 5533 | |
| 5534 | This actually does the work of deleting either a single breakpoint, or all |
| 5535 | of them. |
| 5536 | |
| 5537 | For a single line, we look for it in C<@dbline>. If it's nonbreakable, we |
| 5538 | just drop out with a message saying so. If it is, we remove the condition |
| 5539 | part of the 'condition\0action' that says there's a breakpoint here. If, |
| 5540 | after we've done that, there's nothing left, we delete the corresponding |
| 5541 | line in C<%dbline> to signal that no action needs to be taken for this line. |
| 5542 | |
| 5543 | For all breakpoints, we iterate through the keys of C<%had_breakpoints>, |
| 5544 | which lists all currently-loaded files which have breakpoints. We then look |
| 5545 | at each line in each of these files, temporarily switching the C<%dbline> |
| 5546 | and C<@dbline> structures to point to the files in question, and do what |
| 5547 | we did in the single line case: delete the condition in C<@dbline>, and |
| 5548 | delete the key in C<%dbline> if nothing's left. |
| 5549 | |
| 5550 | We then wholesale delete C<%postponed>, C<%postponed_file>, and |
| 5551 | C<%break_on_load>, because these structures contain breakpoints for files |
| 5552 | and code that haven't been loaded yet. We can just kill these off because there |
| 5553 | are no magical debugger structures associated with them. |
| 5554 | |
| 5555 | =cut |
| 5556 | |
| 5557 | sub _remove_breakpoint_entry { |
| 5558 | my ($fn, $i) = @_; |
| 5559 | |
| 5560 | delete $dbline{$i}; |
| 5561 | _delete_breakpoint_data_ref($fn, $i); |
| 5562 | |
| 5563 | return; |
| 5564 | } |
| 5565 | |
| 5566 | sub _delete_all_breakpoints { |
| 5567 | print {$OUT} "Deleting all breakpoints...\n"; |
| 5568 | |
| 5569 | # %had_breakpoints lists every file that had at least one |
| 5570 | # breakpoint in it. |
| 5571 | for my $fn ( keys %had_breakpoints ) { |
| 5572 | |
| 5573 | # Switch to the desired file temporarily. |
| 5574 | local *dbline = $main::{ '_<' . $fn }; |
| 5575 | |
| 5576 | $max = $#dbline; |
| 5577 | |
| 5578 | # For all lines in this file ... |
| 5579 | for my $i (1 .. $max) { |
| 5580 | |
| 5581 | # If there's a breakpoint or action on this line ... |
| 5582 | if ( defined $dbline{$i} ) { |
| 5583 | |
| 5584 | # ... remove the breakpoint. |
| 5585 | $dbline{$i} =~ s/\A[^\0]+//; |
| 5586 | if ( $dbline{$i} =~ s/\A\0?\z// ) { |
| 5587 | # Remove the entry altogether if no action is there. |
| 5588 | _remove_breakpoint_entry($fn, $i); |
| 5589 | } |
| 5590 | } ## end if (defined $dbline{$i... |
| 5591 | } ## end for $i (1 .. $max) |
| 5592 | |
| 5593 | # If, after we turn off the "there were breakpoints in this file" |
| 5594 | # bit, the entry in %had_breakpoints for this file is zero, |
| 5595 | # we should remove this file from the hash. |
| 5596 | if ( not $had_breakpoints{$fn} &= (~1) ) { |
| 5597 | delete $had_breakpoints{$fn}; |
| 5598 | } |
| 5599 | } ## end for my $fn (keys %had_breakpoints) |
| 5600 | |
| 5601 | # Kill off all the other breakpoints that are waiting for files that |
| 5602 | # haven't been loaded yet. |
| 5603 | undef %postponed; |
| 5604 | undef %postponed_file; |
| 5605 | undef %break_on_load; |
| 5606 | |
| 5607 | return; |
| 5608 | } |
| 5609 | |
| 5610 | sub _delete_breakpoint_from_line { |
| 5611 | my ($i) = @_; |
| 5612 | |
| 5613 | # Woops. This line wasn't breakable at all. |
| 5614 | die "Line $i not breakable.\n" if $dbline[$i] == 0; |
| 5615 | |
| 5616 | # Kill the condition, but leave any action. |
| 5617 | $dbline{$i} =~ s/\A[^\0]*//; |
| 5618 | |
| 5619 | # Remove the entry entirely if there's no action left. |
| 5620 | if ($dbline{$i} eq '') { |
| 5621 | _remove_breakpoint_entry($filename, $i); |
| 5622 | } |
| 5623 | |
| 5624 | return; |
| 5625 | } |
| 5626 | |
| 5627 | sub delete_breakpoint { |
| 5628 | my $i = shift; |
| 5629 | |
| 5630 | # If we got a line, delete just that one. |
| 5631 | if ( defined($i) ) { |
| 5632 | _delete_breakpoint_from_line($i); |
| 5633 | } |
| 5634 | # No line; delete them all. |
| 5635 | else { |
| 5636 | _delete_all_breakpoints(); |
| 5637 | } |
| 5638 | |
| 5639 | return; |
| 5640 | } |
| 5641 | |
| 5642 | =head3 cmd_stop (command) |
| 5643 | |
| 5644 | This is meant to be part of the new command API, but it isn't called or used |
| 5645 | anywhere else in the debugger. XXX It is probably meant for use in development |
| 5646 | of new commands. |
| 5647 | |
| 5648 | =cut |
| 5649 | |
| 5650 | sub cmd_stop { # As on ^C, but not signal-safy. |
| 5651 | $signal = 1; |
| 5652 | } |
| 5653 | |
| 5654 | =head3 C<cmd_e> - threads |
| 5655 | |
| 5656 | Display the current thread id: |
| 5657 | |
| 5658 | e |
| 5659 | |
| 5660 | This could be how (when implemented) to send commands to this thread id (e cmd) |
| 5661 | or that thread id (e tid cmd). |
| 5662 | |
| 5663 | =cut |
| 5664 | |
| 5665 | sub cmd_e { |
| 5666 | my $cmd = shift; |
| 5667 | my $line = shift; |
| 5668 | unless (exists($INC{'threads.pm'})) { |
| 5669 | print "threads not loaded($ENV{PERL5DB_THREADED}) |
| 5670 | please run the debugger with PERL5DB_THREADED=1 set in the environment\n"; |
| 5671 | } else { |
| 5672 | my $tid = threads->tid; |
| 5673 | print "thread id: $tid\n"; |
| 5674 | } |
| 5675 | } ## end sub cmd_e |
| 5676 | |
| 5677 | =head3 C<cmd_E> - list of thread ids |
| 5678 | |
| 5679 | Display the list of available thread ids: |
| 5680 | |
| 5681 | E |
| 5682 | |
| 5683 | This could be used (when implemented) to send commands to all threads (E cmd). |
| 5684 | |
| 5685 | =cut |
| 5686 | |
| 5687 | sub cmd_E { |
| 5688 | my $cmd = shift; |
| 5689 | my $line = shift; |
| 5690 | unless (exists($INC{'threads.pm'})) { |
| 5691 | print "threads not loaded($ENV{PERL5DB_THREADED}) |
| 5692 | please run the debugger with PERL5DB_THREADED=1 set in the environment\n"; |
| 5693 | } else { |
| 5694 | my $tid = threads->tid; |
| 5695 | print "thread ids: ".join(', ', |
| 5696 | map { ($tid == $_->tid ? '<'.$_->tid.'>' : $_->tid) } threads->list |
| 5697 | )."\n"; |
| 5698 | } |
| 5699 | } ## end sub cmd_E |
| 5700 | |
| 5701 | =head3 C<cmd_h> - help command (command) |
| 5702 | |
| 5703 | Does the work of either |
| 5704 | |
| 5705 | =over 4 |
| 5706 | |
| 5707 | =item * |
| 5708 | |
| 5709 | Showing all the debugger help |
| 5710 | |
| 5711 | =item * |
| 5712 | |
| 5713 | Showing help for a specific command |
| 5714 | |
| 5715 | =back |
| 5716 | |
| 5717 | =cut |
| 5718 | |
| 5719 | use vars qw($help); |
| 5720 | use vars qw($summary); |
| 5721 | |
| 5722 | sub cmd_h { |
| 5723 | my $cmd = shift; |
| 5724 | |
| 5725 | # If we have no operand, assume null. |
| 5726 | my $line = shift || ''; |
| 5727 | |
| 5728 | # 'h h'. Print the long-format help. |
| 5729 | if ( $line =~ /\Ah\s*\z/ ) { |
| 5730 | print_help($help); |
| 5731 | } |
| 5732 | |
| 5733 | # 'h <something>'. Search for the command and print only its help. |
| 5734 | elsif ( my ($asked) = $line =~ /\A(\S.*)\z/ ) { |
| 5735 | |
| 5736 | # support long commands; otherwise bogus errors |
| 5737 | # happen when you ask for h on <CR> for example |
| 5738 | my $qasked = quotemeta($asked); # for searching; we don't |
| 5739 | # want to use it as a pattern. |
| 5740 | # XXX: finds CR but not <CR> |
| 5741 | |
| 5742 | # Search the help string for the command. |
| 5743 | if ( |
| 5744 | $help =~ /^ # Start of a line |
| 5745 | <? # Optional '<' |
| 5746 | (?:[IB]<) # Optional markup |
| 5747 | $qasked # The requested command |
| 5748 | /mx |
| 5749 | ) |
| 5750 | { |
| 5751 | |
| 5752 | # It's there; pull it out and print it. |
| 5753 | while ( |
| 5754 | $help =~ /^ |
| 5755 | (<? # Optional '<' |
| 5756 | (?:[IB]<) # Optional markup |
| 5757 | $qasked # The command |
| 5758 | ([\s\S]*?) # Description line(s) |
| 5759 | \n) # End of last description line |
| 5760 | (?!\s) # Next line not starting with |
| 5761 | # whitespace |
| 5762 | /mgx |
| 5763 | ) |
| 5764 | { |
| 5765 | print_help($1); |
| 5766 | } |
| 5767 | } |
| 5768 | |
| 5769 | # Not found; not a debugger command. |
| 5770 | else { |
| 5771 | print_help("B<$asked> is not a debugger command.\n"); |
| 5772 | } |
| 5773 | } ## end elsif ($line =~ /^(\S.*)$/) |
| 5774 | |
| 5775 | # 'h' - print the summary help. |
| 5776 | else { |
| 5777 | print_help($summary); |
| 5778 | } |
| 5779 | } ## end sub cmd_h |
| 5780 | |
| 5781 | =head3 C<cmd_L> - list breakpoints, actions, and watch expressions (command) |
| 5782 | |
| 5783 | To list breakpoints, the command has to look determine where all of them are |
| 5784 | first. It starts a C<%had_breakpoints>, which tells us what all files have |
| 5785 | breakpoints and/or actions. For each file, we switch the C<*dbline> glob (the |
| 5786 | magic source and breakpoint data structures) to the file, and then look |
| 5787 | through C<%dbline> for lines with breakpoints and/or actions, listing them |
| 5788 | out. We look through C<%postponed> not-yet-compiled subroutines that have |
| 5789 | breakpoints, and through C<%postponed_file> for not-yet-C<require>'d files |
| 5790 | that have breakpoints. |
| 5791 | |
| 5792 | Watchpoints are simpler: we just list the entries in C<@to_watch>. |
| 5793 | |
| 5794 | =cut |
| 5795 | |
| 5796 | sub _cmd_L_calc_arg { |
| 5797 | # If no argument, list everything. Pre-5.8.0 version always lists |
| 5798 | # everything |
| 5799 | my $arg = shift || 'abw'; |
| 5800 | if ($CommandSet ne '580') |
| 5801 | { |
| 5802 | $arg = 'abw'; |
| 5803 | } |
| 5804 | |
| 5805 | return $arg; |
| 5806 | } |
| 5807 | |
| 5808 | sub _cmd_L_calc_wanted_flags { |
| 5809 | my $arg = _cmd_L_calc_arg(shift); |
| 5810 | |
| 5811 | return (map { index($arg, $_) >= 0 ? 1 : 0 } qw(a b w)); |
| 5812 | } |
| 5813 | |
| 5814 | |
| 5815 | sub _cmd_L_handle_breakpoints { |
| 5816 | my ($handle_db_line) = @_; |
| 5817 | |
| 5818 | BREAKPOINTS_SCAN: |
| 5819 | # Look in all the files with breakpoints... |
| 5820 | for my $file ( keys %had_breakpoints ) { |
| 5821 | |
| 5822 | # Temporary switch to this file. |
| 5823 | local *dbline = $main::{ '_<' . $file }; |
| 5824 | |
| 5825 | # Set up to look through the whole file. |
| 5826 | $max = $#dbline; |
| 5827 | my $was; # Flag: did we print something |
| 5828 | # in this file? |
| 5829 | |
| 5830 | # For each line in the file ... |
| 5831 | for my $i (1 .. $max) { |
| 5832 | |
| 5833 | # We've got something on this line. |
| 5834 | if ( defined $dbline{$i} ) { |
| 5835 | |
| 5836 | # Print the header if we haven't. |
| 5837 | if (not $was++) { |
| 5838 | print {$OUT} "$file:\n"; |
| 5839 | } |
| 5840 | |
| 5841 | # Print the line. |
| 5842 | print {$OUT} " $i:\t", $dbline[$i]; |
| 5843 | |
| 5844 | $handle_db_line->($dbline{$i}); |
| 5845 | |
| 5846 | # Quit if the user hit interrupt. |
| 5847 | if ($signal) { |
| 5848 | last BREAKPOINTS_SCAN; |
| 5849 | } |
| 5850 | } ## end if (defined $dbline{$i... |
| 5851 | } ## end for my $i (1 .. $max) |
| 5852 | } ## end for my $file (keys %had_breakpoints) |
| 5853 | |
| 5854 | return; |
| 5855 | } |
| 5856 | |
| 5857 | sub _cmd_L_handle_postponed_breakpoints { |
| 5858 | my ($handle_db_line) = @_; |
| 5859 | |
| 5860 | print {$OUT} "Postponed breakpoints in files:\n"; |
| 5861 | |
| 5862 | POSTPONED_SCANS: |
| 5863 | for my $file ( keys %postponed_file ) { |
| 5864 | my $db = $postponed_file{$file}; |
| 5865 | print {$OUT} " $file:\n"; |
| 5866 | for my $line ( sort { $a <=> $b } keys %$db ) { |
| 5867 | print {$OUT} " $line:\n"; |
| 5868 | |
| 5869 | $handle_db_line->($db->{$line}); |
| 5870 | |
| 5871 | if ($signal) { |
| 5872 | last POSTPONED_SCANS; |
| 5873 | } |
| 5874 | } |
| 5875 | if ($signal) { |
| 5876 | last POSTPONED_SCANS; |
| 5877 | } |
| 5878 | } |
| 5879 | |
| 5880 | return; |
| 5881 | } |
| 5882 | |
| 5883 | |
| 5884 | sub cmd_L { |
| 5885 | my $cmd = shift; |
| 5886 | |
| 5887 | my ($action_wanted, $break_wanted, $watch_wanted) = |
| 5888 | _cmd_L_calc_wanted_flags(shift); |
| 5889 | |
| 5890 | my $handle_db_line = sub { |
| 5891 | my ($l) = @_; |
| 5892 | |
| 5893 | my ( $stop, $action ) = split( /\0/, $l ); |
| 5894 | |
| 5895 | if ($stop and $break_wanted) { |
| 5896 | print {$OUT} " break if (", $stop, ")\n" |
| 5897 | } |
| 5898 | |
| 5899 | if ($action && $action_wanted) { |
| 5900 | print {$OUT} " action: ", $action, "\n" |
| 5901 | } |
| 5902 | |
| 5903 | return; |
| 5904 | }; |
| 5905 | |
| 5906 | # Breaks and actions are found together, so we look in the same place |
| 5907 | # for both. |
| 5908 | if ( $break_wanted or $action_wanted ) { |
| 5909 | _cmd_L_handle_breakpoints($handle_db_line); |
| 5910 | } |
| 5911 | |
| 5912 | # Look for breaks in not-yet-compiled subs: |
| 5913 | if ( %postponed and $break_wanted ) { |
| 5914 | print {$OUT} "Postponed breakpoints in subroutines:\n"; |
| 5915 | my $subname; |
| 5916 | SUBS_SCAN: |
| 5917 | for $subname ( keys %postponed ) { |
| 5918 | print {$OUT} " $subname\t$postponed{$subname}\n"; |
| 5919 | if ($signal) { |
| 5920 | last SUBS_SCAN; |
| 5921 | } |
| 5922 | } |
| 5923 | } ## end if (%postponed and $break_wanted) |
| 5924 | |
| 5925 | # Find files that have not-yet-loaded breaks: |
| 5926 | my @have = map { # Combined keys |
| 5927 | keys %{ $postponed_file{$_} } |
| 5928 | } keys %postponed_file; |
| 5929 | |
| 5930 | # If there are any, list them. |
| 5931 | if ( @have and ( $break_wanted or $action_wanted ) ) { |
| 5932 | _cmd_L_handle_postponed_breakpoints($handle_db_line); |
| 5933 | } ## end if (@have and ($break_wanted... |
| 5934 | |
| 5935 | if ( %break_on_load and $break_wanted ) { |
| 5936 | print {$OUT} "Breakpoints on load:\n"; |
| 5937 | BREAK_ON_LOAD: for my $filename ( keys %break_on_load ) { |
| 5938 | print {$OUT} " $filename\n"; |
| 5939 | last BREAK_ON_LOAD if $signal; |
| 5940 | } |
| 5941 | } ## end if (%break_on_load and... |
| 5942 | |
| 5943 | if ($watch_wanted and ( $trace & 2 )) { |
| 5944 | print {$OUT} "Watch-expressions:\n" if @to_watch; |
| 5945 | TO_WATCH: for my $expr (@to_watch) { |
| 5946 | print {$OUT} " $expr\n"; |
| 5947 | last TO_WATCH if $signal; |
| 5948 | } |
| 5949 | } |
| 5950 | |
| 5951 | return; |
| 5952 | } ## end sub cmd_L |
| 5953 | |
| 5954 | =head3 C<cmd_M> - list modules (command) |
| 5955 | |
| 5956 | Just call C<list_modules>. |
| 5957 | |
| 5958 | =cut |
| 5959 | |
| 5960 | sub cmd_M { |
| 5961 | list_modules(); |
| 5962 | |
| 5963 | return; |
| 5964 | } |
| 5965 | |
| 5966 | =head3 C<cmd_o> - options (command) |
| 5967 | |
| 5968 | If this is just C<o> by itself, we list the current settings via |
| 5969 | C<dump_option>. If there's a nonblank value following it, we pass that on to |
| 5970 | C<parse_options> for processing. |
| 5971 | |
| 5972 | =cut |
| 5973 | |
| 5974 | sub cmd_o { |
| 5975 | my $cmd = shift; |
| 5976 | my $opt = shift || ''; # opt[=val] |
| 5977 | |
| 5978 | # Nonblank. Try to parse and process. |
| 5979 | if ( $opt =~ /^(\S.*)/ ) { |
| 5980 | parse_options($1); |
| 5981 | } |
| 5982 | |
| 5983 | # Blank. List the current option settings. |
| 5984 | else { |
| 5985 | for (@options) { |
| 5986 | dump_option($_); |
| 5987 | } |
| 5988 | } |
| 5989 | } ## end sub cmd_o |
| 5990 | |
| 5991 | =head3 C<cmd_O> - nonexistent in 5.8.x (command) |
| 5992 | |
| 5993 | Advises the user that the O command has been renamed. |
| 5994 | |
| 5995 | =cut |
| 5996 | |
| 5997 | sub cmd_O { |
| 5998 | print $OUT "The old O command is now the o command.\n"; # hint |
| 5999 | print $OUT "Use 'h' to get current command help synopsis or\n"; # |
| 6000 | print $OUT "use 'o CommandSet=pre580' to revert to old usage\n"; # |
| 6001 | } |
| 6002 | |
| 6003 | =head3 C<cmd_v> - view window (command) |
| 6004 | |
| 6005 | Uses the C<$preview> variable set in the second C<BEGIN> block (q.v.) to |
| 6006 | move back a few lines to list the selected line in context. Uses C<_cmd_l_main> |
| 6007 | to do the actual listing after figuring out the range of line to request. |
| 6008 | |
| 6009 | =cut |
| 6010 | |
| 6011 | use vars qw($preview); |
| 6012 | |
| 6013 | sub cmd_v { |
| 6014 | my $cmd = shift; |
| 6015 | my $line = shift; |
| 6016 | |
| 6017 | # Extract the line to list around. (Astute readers will have noted that |
| 6018 | # this pattern will match whether or not a numeric line is specified, |
| 6019 | # which means that we'll always enter this loop (though a non-numeric |
| 6020 | # argument results in no action at all)). |
| 6021 | if ( $line =~ /^(\d*)$/ ) { |
| 6022 | |
| 6023 | # Total number of lines to list (a windowful). |
| 6024 | $incr = $window - 1; |
| 6025 | |
| 6026 | # Set the start to the argument given (if there was one). |
| 6027 | $start = $1 if $1; |
| 6028 | |
| 6029 | # Back up by the context amount. Don't back up past line 1. |
| 6030 | $start -= $preview; |
| 6031 | $start = 1 unless $start > 0; |
| 6032 | |
| 6033 | # Put together a linespec that _cmd_l_main will like. |
| 6034 | $line = $start . '-' . ( $start + $incr ); |
| 6035 | |
| 6036 | # List the lines. |
| 6037 | _cmd_l_main( $line ); |
| 6038 | } ## end if ($line =~ /^(\d*)$/) |
| 6039 | } ## end sub cmd_v |
| 6040 | |
| 6041 | =head3 C<cmd_w> - add a watch expression (command) |
| 6042 | |
| 6043 | The 5.8 version of this command adds a watch expression if one is specified; |
| 6044 | it does nothing if entered with no operands. |
| 6045 | |
| 6046 | We extract the expression, save it, evaluate it in the user's context, and |
| 6047 | save the value. We'll re-evaluate it each time the debugger passes a line, |
| 6048 | and will stop (see the code at the top of the command loop) if the value |
| 6049 | of any of the expressions changes. |
| 6050 | |
| 6051 | =cut |
| 6052 | |
| 6053 | sub _add_watch_expr { |
| 6054 | my $expr = shift; |
| 6055 | |
| 6056 | # ... save it. |
| 6057 | push @to_watch, $expr; |
| 6058 | |
| 6059 | # Parameterize DB::eval and call it to get the expression's value |
| 6060 | # in the user's context. This version can handle expressions which |
| 6061 | # return a list value. |
| 6062 | $evalarg = $expr; |
| 6063 | # The &-call is here to ascertain the mutability of @_. |
| 6064 | my ($val) = join( ' ', &DB::eval); |
| 6065 | $val = ( defined $val ) ? "'$val'" : 'undef'; |
| 6066 | |
| 6067 | # Save the current value of the expression. |
| 6068 | push @old_watch, $val; |
| 6069 | |
| 6070 | # We are now watching expressions. |
| 6071 | $trace |= 2; |
| 6072 | |
| 6073 | return; |
| 6074 | } |
| 6075 | |
| 6076 | sub cmd_w { |
| 6077 | my $cmd = shift; |
| 6078 | |
| 6079 | # Null expression if no arguments. |
| 6080 | my $expr = shift || ''; |
| 6081 | |
| 6082 | # If expression is not null ... |
| 6083 | if ( $expr =~ /\A\S/ ) { |
| 6084 | _add_watch_expr($expr); |
| 6085 | } ## end if ($expr =~ /^(\S.*)/) |
| 6086 | |
| 6087 | # You have to give one to get one. |
| 6088 | else { |
| 6089 | print $OUT "Adding a watch-expression requires an expression\n"; # hint |
| 6090 | } |
| 6091 | |
| 6092 | return; |
| 6093 | } |
| 6094 | |
| 6095 | =head3 C<cmd_W> - delete watch expressions (command) |
| 6096 | |
| 6097 | This command accepts either a watch expression to be removed from the list |
| 6098 | of watch expressions, or C<*> to delete them all. |
| 6099 | |
| 6100 | If C<*> is specified, we simply empty the watch expression list and the |
| 6101 | watch expression value list. We also turn off the bit that says we've got |
| 6102 | watch expressions. |
| 6103 | |
| 6104 | If an expression (or partial expression) is specified, we pattern-match |
| 6105 | through the expressions and remove the ones that match. We also discard |
| 6106 | the corresponding values. If no watch expressions are left, we turn off |
| 6107 | the I<watching expressions> bit. |
| 6108 | |
| 6109 | =cut |
| 6110 | |
| 6111 | sub cmd_W { |
| 6112 | my $cmd = shift; |
| 6113 | my $expr = shift || ''; |
| 6114 | |
| 6115 | # Delete them all. |
| 6116 | if ( $expr eq '*' ) { |
| 6117 | |
| 6118 | # Not watching now. |
| 6119 | $trace &= ~2; |
| 6120 | |
| 6121 | print $OUT "Deleting all watch expressions ...\n"; |
| 6122 | |
| 6123 | # And all gone. |
| 6124 | @to_watch = @old_watch = (); |
| 6125 | } |
| 6126 | |
| 6127 | # Delete one of them. |
| 6128 | elsif ( $expr =~ /^(\S.*)/ ) { |
| 6129 | |
| 6130 | # Where we are in the list. |
| 6131 | my $i_cnt = 0; |
| 6132 | |
| 6133 | # For each expression ... |
| 6134 | foreach (@to_watch) { |
| 6135 | my $val = $to_watch[$i_cnt]; |
| 6136 | |
| 6137 | # Does this one match the command argument? |
| 6138 | if ( $val eq $expr ) { # =~ m/^\Q$i$/) { |
| 6139 | # Yes. Turn it off, and its value too. |
| 6140 | splice( @to_watch, $i_cnt, 1 ); |
| 6141 | splice( @old_watch, $i_cnt, 1 ); |
| 6142 | } |
| 6143 | $i_cnt++; |
| 6144 | } ## end foreach (@to_watch) |
| 6145 | |
| 6146 | # We don't bother to turn watching off because |
| 6147 | # a) we don't want to stop calling watchfunction() if it exists |
| 6148 | # b) foreach over a null list doesn't do anything anyway |
| 6149 | |
| 6150 | } ## end elsif ($expr =~ /^(\S.*)/) |
| 6151 | |
| 6152 | # No command arguments entered. |
| 6153 | else { |
| 6154 | print $OUT |
| 6155 | "Deleting a watch-expression requires an expression, or '*' for all\n" |
| 6156 | ; # hint |
| 6157 | } |
| 6158 | } ## end sub cmd_W |
| 6159 | |
| 6160 | ### END of the API section |
| 6161 | |
| 6162 | =head1 SUPPORT ROUTINES |
| 6163 | |
| 6164 | These are general support routines that are used in a number of places |
| 6165 | throughout the debugger. |
| 6166 | |
| 6167 | =head2 save |
| 6168 | |
| 6169 | save() saves the user's versions of globals that would mess us up in C<@saved>, |
| 6170 | and installs the versions we like better. |
| 6171 | |
| 6172 | =cut |
| 6173 | |
| 6174 | sub save { |
| 6175 | |
| 6176 | # Save eval failure, command failure, extended OS error, output field |
| 6177 | # separator, input record separator, output record separator and |
| 6178 | # the warning setting. |
| 6179 | @saved = ( $@, $!, $^E, $,, $/, $\, $^W ); |
| 6180 | |
| 6181 | $, = ""; # output field separator is null string |
| 6182 | $/ = "\n"; # input record separator is newline |
| 6183 | $\ = ""; # output record separator is null string |
| 6184 | $^W = 0; # warnings are off |
| 6185 | } ## end sub save |
| 6186 | |
| 6187 | =head2 C<print_lineinfo> - show where we are now |
| 6188 | |
| 6189 | print_lineinfo prints whatever it is that it is handed; it prints it to the |
| 6190 | C<$LINEINFO> filehandle instead of just printing it to STDOUT. This allows |
| 6191 | us to feed line information to a client editor without messing up the |
| 6192 | debugger output. |
| 6193 | |
| 6194 | =cut |
| 6195 | |
| 6196 | sub print_lineinfo { |
| 6197 | |
| 6198 | # Make the terminal sensible if we're not the primary debugger. |
| 6199 | resetterm(1) if $LINEINFO eq $OUT and $term_pid != $$; |
| 6200 | local $\ = ''; |
| 6201 | local $, = ''; |
| 6202 | # $LINEINFO may be undef if $noTTY is set or some other issue. |
| 6203 | if ($LINEINFO) |
| 6204 | { |
| 6205 | print {$LINEINFO} @_; |
| 6206 | } |
| 6207 | } ## end sub print_lineinfo |
| 6208 | |
| 6209 | =head2 C<postponed_sub> |
| 6210 | |
| 6211 | Handles setting postponed breakpoints in subroutines once they're compiled. |
| 6212 | For breakpoints, we use C<DB::find_sub> to locate the source file and line |
| 6213 | range for the subroutine, then mark the file as having a breakpoint, |
| 6214 | temporarily switch the C<*dbline> glob over to the source file, and then |
| 6215 | search the given range of lines to find a breakable line. If we find one, |
| 6216 | we set the breakpoint on it, deleting the breakpoint from C<%postponed>. |
| 6217 | |
| 6218 | =cut |
| 6219 | |
| 6220 | # The following takes its argument via $evalarg to preserve current @_ |
| 6221 | |
| 6222 | sub postponed_sub { |
| 6223 | |
| 6224 | # Get the subroutine name. |
| 6225 | my $subname = shift; |
| 6226 | |
| 6227 | # If this is a 'break +<n> if <condition>' ... |
| 6228 | if ( $postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s// ) { |
| 6229 | |
| 6230 | # If there's no offset, use '+0'. |
| 6231 | my $offset = $1 || 0; |
| 6232 | |
| 6233 | # find_sub's value is 'fullpath-filename:start-stop'. It's |
| 6234 | # possible that the filename might have colons in it too. |
| 6235 | my ( $file, $i ) = ( find_sub($subname) =~ /^(.*):(\d+)-.*$/ ); |
| 6236 | if ($i) { |
| 6237 | |
| 6238 | # We got the start line. Add the offset '+<n>' from |
| 6239 | # $postponed{subname}. |
| 6240 | $i += $offset; |
| 6241 | |
| 6242 | # Switch to the file this sub is in, temporarily. |
| 6243 | local *dbline = $main::{ '_<' . $file }; |
| 6244 | |
| 6245 | # No warnings, please. |
| 6246 | local $^W = 0; # != 0 is magical below |
| 6247 | |
| 6248 | # This file's got a breakpoint in it. |
| 6249 | $had_breakpoints{$file} |= 1; |
| 6250 | |
| 6251 | # Last line in file. |
| 6252 | $max = $#dbline; |
| 6253 | |
| 6254 | # Search forward until we hit a breakable line or get to |
| 6255 | # the end of the file. |
| 6256 | ++$i until $dbline[$i] != 0 or $i >= $max; |
| 6257 | |
| 6258 | # Copy the breakpoint in and delete it from %postponed. |
| 6259 | $dbline{$i} = delete $postponed{$subname}; |
| 6260 | } ## end if ($i) |
| 6261 | |
| 6262 | # find_sub didn't find the sub. |
| 6263 | else { |
| 6264 | local $\ = ''; |
| 6265 | print $OUT "Subroutine $subname not found.\n"; |
| 6266 | } |
| 6267 | return; |
| 6268 | } ## end if ($postponed{$subname... |
| 6269 | elsif ( $postponed{$subname} eq 'compile' ) { $signal = 1 } |
| 6270 | |
| 6271 | #print $OUT "In postponed_sub for '$subname'.\n"; |
| 6272 | } ## end sub postponed_sub |
| 6273 | |
| 6274 | =head2 C<postponed> |
| 6275 | |
| 6276 | Called after each required file is compiled, but before it is executed; |
| 6277 | also called if the name of a just-compiled subroutine is a key of |
| 6278 | C<%postponed>. Propagates saved breakpoints (from S<C<b compile>>, |
| 6279 | S<C<b load>>, etc.) into the just-compiled code. |
| 6280 | |
| 6281 | If this is a C<require>'d file, the incoming parameter is the glob |
| 6282 | C<*{"_<$filename"}>, with C<$filename> the name of the C<require>'d file. |
| 6283 | |
| 6284 | If it's a subroutine, the incoming parameter is the subroutine name. |
| 6285 | |
| 6286 | =cut |
| 6287 | |
| 6288 | sub postponed { |
| 6289 | |
| 6290 | # If there's a break, process it. |
| 6291 | if ($ImmediateStop) { |
| 6292 | |
| 6293 | # Right, we've stopped. Turn it off. |
| 6294 | $ImmediateStop = 0; |
| 6295 | |
| 6296 | # Enter the command loop when DB::DB gets called. |
| 6297 | $signal = 1; |
| 6298 | } |
| 6299 | |
| 6300 | # If this is a subroutine, let postponed_sub() deal with it. |
| 6301 | if (ref(\$_[0]) ne 'GLOB') { |
| 6302 | return postponed_sub(@_); |
| 6303 | } |
| 6304 | |
| 6305 | # Not a subroutine. Deal with the file. |
| 6306 | local *dbline = shift; |
| 6307 | my $filename = $dbline; |
| 6308 | $filename =~ s/^_<//; |
| 6309 | local $\ = ''; |
| 6310 | $signal = 1, print $OUT "'$filename' loaded...\n" |
| 6311 | if $break_on_load{$filename}; |
| 6312 | print_lineinfo( ' ' x $stack_depth, "Package $filename.\n" ) if $frame; |
| 6313 | |
| 6314 | # Do we have any breakpoints to put in this file? |
| 6315 | return unless $postponed_file{$filename}; |
| 6316 | |
| 6317 | # Yes. Mark this file as having breakpoints. |
| 6318 | $had_breakpoints{$filename} |= 1; |
| 6319 | |
| 6320 | # "Cannot be done: insufficient magic" - we can't just put the |
| 6321 | # breakpoints saved in %postponed_file into %dbline by assigning |
| 6322 | # the whole hash; we have to do it one item at a time for the |
| 6323 | # breakpoints to be set properly. |
| 6324 | #%dbline = %{$postponed_file{$filename}}; |
| 6325 | |
| 6326 | # Set the breakpoints, one at a time. |
| 6327 | my $key; |
| 6328 | |
| 6329 | for $key ( keys %{ $postponed_file{$filename} } ) { |
| 6330 | |
| 6331 | # Stash the saved breakpoint into the current file's magic line array. |
| 6332 | $dbline{$key} = ${ $postponed_file{$filename} }{$key}; |
| 6333 | } |
| 6334 | |
| 6335 | # This file's been compiled; discard the stored breakpoints. |
| 6336 | delete $postponed_file{$filename}; |
| 6337 | |
| 6338 | } ## end sub postponed |
| 6339 | |
| 6340 | =head2 C<dumpit> |
| 6341 | |
| 6342 | C<dumpit> is the debugger's wrapper around dumpvar.pl. |
| 6343 | |
| 6344 | It gets a filehandle (to which C<dumpvar.pl>'s output will be directed) and |
| 6345 | a reference to a variable (the thing to be dumped) as its input. |
| 6346 | |
| 6347 | The incoming filehandle is selected for output (C<dumpvar.pl> is printing to |
| 6348 | the currently-selected filehandle, thank you very much). The current |
| 6349 | values of the package globals C<$single> and C<$trace> are backed up in |
| 6350 | lexicals, and they are turned off (this keeps the debugger from trying |
| 6351 | to single-step through C<dumpvar.pl> (I think.)). C<$frame> is localized to |
| 6352 | preserve its current value and it is set to zero to prevent entry/exit |
| 6353 | messages from printing, and C<$doret> is localized as well and set to -2 to |
| 6354 | prevent return values from being shown. |
| 6355 | |
| 6356 | C<dumpit()> then checks to see if it needs to load C<dumpvar.pl> and |
| 6357 | tries to load it (note: if you have a C<dumpvar.pl> ahead of the |
| 6358 | installed version in C<@INC>, yours will be used instead. Possible security |
| 6359 | problem?). |
| 6360 | |
| 6361 | It then checks to see if the subroutine C<main::dumpValue> is now defined |
| 6362 | it should have been defined by C<dumpvar.pl>). If it has, C<dumpit()> |
| 6363 | localizes the globals necessary for things to be sane when C<main::dumpValue()> |
| 6364 | is called, and picks up the variable to be dumped from the parameter list. |
| 6365 | |
| 6366 | It checks the package global C<%options> to see if there's a C<dumpDepth> |
| 6367 | specified. If not, -1 is assumed; if so, the supplied value gets passed on to |
| 6368 | C<dumpvar.pl>. This tells C<dumpvar.pl> where to leave off when dumping a |
| 6369 | structure: -1 means dump everything. |
| 6370 | |
| 6371 | C<dumpValue()> is then called if possible; if not, C<dumpit()>just prints a |
| 6372 | warning. |
| 6373 | |
| 6374 | In either case, C<$single>, C<$trace>, C<$frame>, and C<$doret> are restored |
| 6375 | and we then return to the caller. |
| 6376 | |
| 6377 | =cut |
| 6378 | |
| 6379 | sub dumpit { |
| 6380 | |
| 6381 | # Save the current output filehandle and switch to the one |
| 6382 | # passed in as the first parameter. |
| 6383 | my $savout = select(shift); |
| 6384 | |
| 6385 | # Save current settings of $single and $trace, and then turn them off. |
| 6386 | my $osingle = $single; |
| 6387 | my $otrace = $trace; |
| 6388 | $single = $trace = 0; |
| 6389 | |
| 6390 | # XXX Okay, what do $frame and $doret do, again? |
| 6391 | local $frame = 0; |
| 6392 | local $doret = -2; |
| 6393 | |
| 6394 | # Load dumpvar.pl unless we've already got the sub we need from it. |
| 6395 | unless ( defined &main::dumpValue ) { |
| 6396 | do 'dumpvar.pl' or die $@; |
| 6397 | } |
| 6398 | |
| 6399 | # If the load succeeded (or we already had dumpvalue()), go ahead |
| 6400 | # and dump things. |
| 6401 | if ( defined &main::dumpValue ) { |
| 6402 | local $\ = ''; |
| 6403 | local $, = ''; |
| 6404 | local $" = ' '; |
| 6405 | my $v = shift; |
| 6406 | my $maxdepth = shift || $option{dumpDepth}; |
| 6407 | $maxdepth = -1 unless defined $maxdepth; # -1 means infinite depth |
| 6408 | main::dumpValue( $v, $maxdepth ); |
| 6409 | } ## end if (defined &main::dumpValue) |
| 6410 | |
| 6411 | # Oops, couldn't load dumpvar.pl. |
| 6412 | else { |
| 6413 | local $\ = ''; |
| 6414 | print $OUT "dumpvar.pl not available.\n"; |
| 6415 | } |
| 6416 | |
| 6417 | # Reset $single and $trace to their old values. |
| 6418 | $single = $osingle; |
| 6419 | $trace = $otrace; |
| 6420 | |
| 6421 | # Restore the old filehandle. |
| 6422 | select($savout); |
| 6423 | } ## end sub dumpit |
| 6424 | |
| 6425 | =head2 C<print_trace> |
| 6426 | |
| 6427 | C<print_trace>'s job is to print a stack trace. It does this via the |
| 6428 | C<dump_trace> routine, which actually does all the ferreting-out of the |
| 6429 | stack trace data. C<print_trace> takes care of formatting it nicely and |
| 6430 | printing it to the proper filehandle. |
| 6431 | |
| 6432 | Parameters: |
| 6433 | |
| 6434 | =over 4 |
| 6435 | |
| 6436 | =item * |
| 6437 | |
| 6438 | The filehandle to print to. |
| 6439 | |
| 6440 | =item * |
| 6441 | |
| 6442 | How many frames to skip before starting trace. |
| 6443 | |
| 6444 | =item * |
| 6445 | |
| 6446 | How many frames to print. |
| 6447 | |
| 6448 | =item * |
| 6449 | |
| 6450 | A flag: if true, print a I<short> trace without filenames, line numbers, or arguments |
| 6451 | |
| 6452 | =back |
| 6453 | |
| 6454 | The original comment below seems to be noting that the traceback may not be |
| 6455 | correct if this routine is called in a tied method. |
| 6456 | |
| 6457 | =cut |
| 6458 | |
| 6459 | # Tied method do not create a context, so may get wrong message: |
| 6460 | |
| 6461 | sub print_trace { |
| 6462 | local $\ = ''; |
| 6463 | my $fh = shift; |
| 6464 | |
| 6465 | # If this is going to a client editor, but we're not the primary |
| 6466 | # debugger, reset it first. |
| 6467 | resetterm(1) |
| 6468 | if $fh eq $LINEINFO # client editor |
| 6469 | and $LINEINFO eq $OUT # normal output |
| 6470 | and $term_pid != $$; # not the primary |
| 6471 | |
| 6472 | # Collect the actual trace information to be formatted. |
| 6473 | # This is an array of hashes of subroutine call info. |
| 6474 | my @sub = dump_trace( $_[0] + 1, $_[1] ); |
| 6475 | |
| 6476 | # Grab the "short report" flag from @_. |
| 6477 | my $short = $_[2]; # Print short report, next one for sub name |
| 6478 | |
| 6479 | # Run through the traceback info, format it, and print it. |
| 6480 | my $s; |
| 6481 | for my $i (0 .. $#sub) { |
| 6482 | |
| 6483 | # Drop out if the user has lost interest and hit control-C. |
| 6484 | last if $signal; |
| 6485 | |
| 6486 | # Set the separator so arrays print nice. |
| 6487 | local $" = ', '; |
| 6488 | |
| 6489 | # Grab and stringify the arguments if they are there. |
| 6490 | my $args = |
| 6491 | defined $sub[$i]{args} |
| 6492 | ? "(@{ $sub[$i]{args} })" |
| 6493 | : ''; |
| 6494 | |
| 6495 | # Shorten them up if $maxtrace says they're too long. |
| 6496 | $args = ( substr $args, 0, $maxtrace - 3 ) . '...' |
| 6497 | if length $args > $maxtrace; |
| 6498 | |
| 6499 | # Get the file name. |
| 6500 | my $file = $sub[$i]{file}; |
| 6501 | |
| 6502 | # Put in a filename header if short is off. |
| 6503 | $file = $file eq '-e' ? $file : "file '$file'" unless $short; |
| 6504 | |
| 6505 | # Get the actual sub's name, and shorten to $maxtrace's requirement. |
| 6506 | $s = $sub[$i]{'sub'}; |
| 6507 | $s = ( substr $s, 0, $maxtrace - 3 ) . '...' if length $s > $maxtrace; |
| 6508 | |
| 6509 | # Short report uses trimmed file and sub names. |
| 6510 | if ($short) { |
| 6511 | my $sub = @_ >= 4 ? $_[3] : $s; |
| 6512 | print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n"; |
| 6513 | } ## end if ($short) |
| 6514 | |
| 6515 | # Non-short report includes full names. |
| 6516 | else { |
| 6517 | print $fh "$sub[$i]{context} = $s$args" |
| 6518 | . " called from $file" |
| 6519 | . " line $sub[$i]{line}\n"; |
| 6520 | } |
| 6521 | } ## end for my $i (0 .. $#sub) |
| 6522 | } ## end sub print_trace |
| 6523 | |
| 6524 | =head2 dump_trace(skip[,count]) |
| 6525 | |
| 6526 | Actually collect the traceback information available via C<caller()>. It does |
| 6527 | some filtering and cleanup of the data, but mostly it just collects it to |
| 6528 | make C<print_trace()>'s job easier. |
| 6529 | |
| 6530 | C<skip> defines the number of stack frames to be skipped, working backwards |
| 6531 | from the most current. C<count> determines the total number of frames to |
| 6532 | be returned; all of them (well, the first 10^9) are returned if C<count> |
| 6533 | is omitted. |
| 6534 | |
| 6535 | This routine returns a list of hashes, from most-recent to least-recent |
| 6536 | stack frame. Each has the following keys and values: |
| 6537 | |
| 6538 | =over 4 |
| 6539 | |
| 6540 | =item * C<context> - C<.> (null), C<$> (scalar), or C<@> (array) |
| 6541 | |
| 6542 | =item * C<sub> - subroutine name, or C<eval> information |
| 6543 | |
| 6544 | =item * C<args> - undef, or a reference to an array of arguments |
| 6545 | |
| 6546 | =item * C<file> - the file in which this item was defined (if any) |
| 6547 | |
| 6548 | =item * C<line> - the line on which it was defined |
| 6549 | |
| 6550 | =back |
| 6551 | |
| 6552 | =cut |
| 6553 | |
| 6554 | sub _dump_trace_calc_saved_single_arg |
| 6555 | { |
| 6556 | my ($nothard, $arg) = @_; |
| 6557 | |
| 6558 | my $type; |
| 6559 | if ( not defined $arg ) { # undefined parameter |
| 6560 | return "undef"; |
| 6561 | } |
| 6562 | |
| 6563 | elsif ( $nothard and tied $arg ) { # tied parameter |
| 6564 | return "tied"; |
| 6565 | } |
| 6566 | elsif ( $nothard and $type = ref $arg ) { # reference |
| 6567 | return "ref($type)"; |
| 6568 | } |
| 6569 | else { # can be stringified |
| 6570 | local $_ = |
| 6571 | "$arg"; # Safe to stringify now - should not call f(). |
| 6572 | |
| 6573 | # Backslash any single-quotes or backslashes. |
| 6574 | s/([\'\\])/\\$1/g; |
| 6575 | |
| 6576 | # Single-quote it unless it's a number or a colon-separated |
| 6577 | # name. |
| 6578 | s/(.*)/'$1'/s |
| 6579 | unless /^(?: -?[\d.]+ | \*[\w:]* )$/x; |
| 6580 | |
| 6581 | # Turn high-bit characters into meta-whatever, and controls into like |
| 6582 | # '^D'. |
| 6583 | require 'meta_notation.pm'; |
| 6584 | $_ = _meta_notation($_) if /[[:^print:]]/a; |
| 6585 | |
| 6586 | return $_; |
| 6587 | } |
| 6588 | } |
| 6589 | |
| 6590 | sub _dump_trace_calc_save_args { |
| 6591 | my ($nothard) = @_; |
| 6592 | |
| 6593 | return [ |
| 6594 | map { _dump_trace_calc_saved_single_arg($nothard, $_) } @args |
| 6595 | ]; |
| 6596 | } |
| 6597 | |
| 6598 | sub dump_trace { |
| 6599 | |
| 6600 | # How many levels to skip. |
| 6601 | my $skip = shift; |
| 6602 | |
| 6603 | # How many levels to show. (1e9 is a cheap way of saying "all of them"; |
| 6604 | # it's unlikely that we'll have more than a billion stack frames. If you |
| 6605 | # do, you've got an awfully big machine...) |
| 6606 | my $count = shift || 1e9; |
| 6607 | |
| 6608 | # We increment skip because caller(1) is the first level *back* from |
| 6609 | # the current one. Add $skip to the count of frames so we have a |
| 6610 | # simple stop criterion, counting from $skip to $count+$skip. |
| 6611 | $skip++; |
| 6612 | $count += $skip; |
| 6613 | |
| 6614 | # These variables are used to capture output from caller(); |
| 6615 | my ( $p, $file, $line, $sub, $h, $context ); |
| 6616 | |
| 6617 | my ( $e, $r, @sub, $args ); |
| 6618 | |
| 6619 | # XXX Okay... why'd we do that? |
| 6620 | my $nothard = not $frame & 8; |
| 6621 | local $frame = 0; |
| 6622 | |
| 6623 | # Do not want to trace this. |
| 6624 | my $otrace = $trace; |
| 6625 | $trace = 0; |
| 6626 | |
| 6627 | # Start out at the skip count. |
| 6628 | # If we haven't reached the number of frames requested, and caller() is |
| 6629 | # still returning something, stay in the loop. (If we pass the requested |
| 6630 | # number of stack frames, or we run out - caller() returns nothing - we |
| 6631 | # quit. |
| 6632 | # Up the stack frame index to go back one more level each time. |
| 6633 | for ( |
| 6634 | my $i = $skip ; |
| 6635 | $i < $count |
| 6636 | and ( $p, $file, $line, $sub, $h, $context, $e, $r ) = caller($i) ; |
| 6637 | $i++ |
| 6638 | ) |
| 6639 | { |
| 6640 | # if the sub has args ($h true), make an anonymous array of the |
| 6641 | # dumped args. |
| 6642 | my $args = $h ? _dump_trace_calc_save_args($nothard) : undef; |
| 6643 | |
| 6644 | # If context is true, this is array (@)context. |
| 6645 | # If context is false, this is scalar ($) context. |
| 6646 | # If neither, context isn't defined. (This is apparently a 'can't |
| 6647 | # happen' trap.) |
| 6648 | $context = $context ? '@' : ( defined $context ? "\$" : '.' ); |
| 6649 | |
| 6650 | # remove trailing newline-whitespace-semicolon-end of line sequence |
| 6651 | # from the eval text, if any. |
| 6652 | $e =~ s/\n\s*\;\s*\Z// if $e; |
| 6653 | |
| 6654 | # Escape backslashed single-quotes again if necessary. |
| 6655 | $e =~ s/([\\\'])/\\$1/g if $e; |
| 6656 | |
| 6657 | # if the require flag is true, the eval text is from a require. |
| 6658 | if ($r) { |
| 6659 | $sub = "require '$e'"; |
| 6660 | } |
| 6661 | |
| 6662 | # if it's false, the eval text is really from an eval. |
| 6663 | elsif ( defined $r ) { |
| 6664 | $sub = "eval '$e'"; |
| 6665 | } |
| 6666 | |
| 6667 | # If the sub is '(eval)', this is a block eval, meaning we don't |
| 6668 | # know what the eval'ed text actually was. |
| 6669 | elsif ( $sub eq '(eval)' ) { |
| 6670 | $sub = "eval {...}"; |
| 6671 | } |
| 6672 | |
| 6673 | # Stick the collected information into @sub as an anonymous hash. |
| 6674 | push( |
| 6675 | @sub, |
| 6676 | { |
| 6677 | context => $context, |
| 6678 | sub => $sub, |
| 6679 | args => $args, |
| 6680 | file => $file, |
| 6681 | line => $line |
| 6682 | } |
| 6683 | ); |
| 6684 | |
| 6685 | # Stop processing frames if the user hit control-C. |
| 6686 | last if $signal; |
| 6687 | } ## end for ($i = $skip ; $i < ... |
| 6688 | |
| 6689 | # Restore the trace value again. |
| 6690 | $trace = $otrace; |
| 6691 | @sub; |
| 6692 | } ## end sub dump_trace |
| 6693 | |
| 6694 | =head2 C<action()> |
| 6695 | |
| 6696 | C<action()> takes input provided as the argument to an add-action command, |
| 6697 | either pre- or post-, and makes sure it's a complete command. It doesn't do |
| 6698 | any fancy parsing; it just keeps reading input until it gets a string |
| 6699 | without a trailing backslash. |
| 6700 | |
| 6701 | =cut |
| 6702 | |
| 6703 | sub action { |
| 6704 | my $action = shift; |
| 6705 | |
| 6706 | while ( $action =~ s/\\$// ) { |
| 6707 | |
| 6708 | # We have a backslash on the end. Read more. |
| 6709 | $action .= gets(); |
| 6710 | } ## end while ($action =~ s/\\$//) |
| 6711 | |
| 6712 | # Return the assembled action. |
| 6713 | $action; |
| 6714 | } ## end sub action |
| 6715 | |
| 6716 | =head2 unbalanced |
| 6717 | |
| 6718 | This routine mostly just packages up a regular expression to be used |
| 6719 | to check that the thing it's being matched against has properly-matched |
| 6720 | curly braces. |
| 6721 | |
| 6722 | Of note is the definition of the C<$balanced_brace_re> global via C<||=>, which |
| 6723 | speeds things up by only creating the qr//'ed expression once; if it's |
| 6724 | already defined, we don't try to define it again. A speed hack. |
| 6725 | |
| 6726 | =cut |
| 6727 | |
| 6728 | use vars qw($balanced_brace_re); |
| 6729 | |
| 6730 | sub unbalanced { |
| 6731 | |
| 6732 | # I hate using globals! |
| 6733 | $balanced_brace_re ||= qr{ |
| 6734 | ^ \{ |
| 6735 | (?: |
| 6736 | (?> [^{}] + ) # Non-parens without backtracking |
| 6737 | | |
| 6738 | (??{ $balanced_brace_re }) # Group with matching parens |
| 6739 | ) * |
| 6740 | \} $ |
| 6741 | }x; |
| 6742 | return $_[0] !~ m/$balanced_brace_re/; |
| 6743 | } ## end sub unbalanced |
| 6744 | |
| 6745 | =head2 C<gets()> |
| 6746 | |
| 6747 | C<gets()> is a primitive (very primitive) routine to read continuations. |
| 6748 | It was devised for reading continuations for actions. |
| 6749 | it just reads more input with C<readline()> and returns it. |
| 6750 | |
| 6751 | =cut |
| 6752 | |
| 6753 | sub gets { |
| 6754 | return DB::readline("cont: "); |
| 6755 | } |
| 6756 | |
| 6757 | =head2 C<_db_system()> - handle calls to<system()> without messing up the debugger |
| 6758 | |
| 6759 | The C<system()> function assumes that it can just go ahead and use STDIN and |
| 6760 | STDOUT, but under the debugger, we want it to use the debugger's input and |
| 6761 | outout filehandles. |
| 6762 | |
| 6763 | C<_db_system()> socks away the program's STDIN and STDOUT, and then substitutes |
| 6764 | the debugger's IN and OUT filehandles for them. It does the C<system()> call, |
| 6765 | and then puts everything back again. |
| 6766 | |
| 6767 | =cut |
| 6768 | |
| 6769 | sub _db_system { |
| 6770 | |
| 6771 | # We save, change, then restore STDIN and STDOUT to avoid fork() since |
| 6772 | # some non-Unix systems can do system() but have problems with fork(). |
| 6773 | open( SAVEIN, "<&STDIN" ) || _db_warn("Can't save STDIN"); |
| 6774 | open( SAVEOUT, ">&STDOUT" ) || _db_warn("Can't save STDOUT"); |
| 6775 | open( STDIN, "<&IN" ) || _db_warn("Can't redirect STDIN"); |
| 6776 | open( STDOUT, ">&OUT" ) || _db_warn("Can't redirect STDOUT"); |
| 6777 | |
| 6778 | # XXX: using csh or tcsh destroys sigint retvals! |
| 6779 | system(@_); |
| 6780 | open( STDIN, "<&SAVEIN" ) || _db_warn("Can't restore STDIN"); |
| 6781 | open( STDOUT, ">&SAVEOUT" ) || _db_warn("Can't restore STDOUT"); |
| 6782 | close(SAVEIN); |
| 6783 | close(SAVEOUT); |
| 6784 | |
| 6785 | # most of the $? crud was coping with broken cshisms |
| 6786 | if ( $? >> 8 ) { |
| 6787 | _db_warn( "(Command exited ", ( $? >> 8 ), ")\n" ); |
| 6788 | } |
| 6789 | elsif ($?) { |
| 6790 | _db_warn( |
| 6791 | "(Command died of SIG#", |
| 6792 | ( $? & 127 ), |
| 6793 | ( ( $? & 128 ) ? " -- core dumped" : "" ), |
| 6794 | ")", "\n" |
| 6795 | ); |
| 6796 | } ## end elsif ($?) |
| 6797 | |
| 6798 | return $?; |
| 6799 | |
| 6800 | } ## end sub system |
| 6801 | |
| 6802 | *system = \&_db_system; |
| 6803 | |
| 6804 | =head1 TTY MANAGEMENT |
| 6805 | |
| 6806 | The subs here do some of the terminal management for multiple debuggers. |
| 6807 | |
| 6808 | =head2 setterm |
| 6809 | |
| 6810 | Top-level function called when we want to set up a new terminal for use |
| 6811 | by the debugger. |
| 6812 | |
| 6813 | If the C<noTTY> debugger option was set, we'll either use the terminal |
| 6814 | supplied (the value of the C<noTTY> option), or we'll use C<Term::Rendezvous> |
| 6815 | to find one. If we're a forked debugger, we call C<resetterm> to try to |
| 6816 | get a whole new terminal if we can. |
| 6817 | |
| 6818 | In either case, we set up the terminal next. If the C<ReadLine> option was |
| 6819 | true, we'll get a C<Term::ReadLine> object for the current terminal and save |
| 6820 | the appropriate attributes. We then |
| 6821 | |
| 6822 | =cut |
| 6823 | |
| 6824 | use vars qw($ornaments); |
| 6825 | use vars qw($rl_attribs); |
| 6826 | |
| 6827 | sub setterm { |
| 6828 | |
| 6829 | # Load Term::Readline, but quietly; don't debug it and don't trace it. |
| 6830 | local $frame = 0; |
| 6831 | local $doret = -2; |
| 6832 | require Term::ReadLine; |
| 6833 | |
| 6834 | # If noTTY is set, but we have a TTY name, go ahead and hook up to it. |
| 6835 | if ($notty) { |
| 6836 | if ($tty) { |
| 6837 | my ( $i, $o ) = split $tty, /,/; |
| 6838 | $o = $i unless defined $o; |
| 6839 | open( IN, '<', $i ) or die "Cannot open TTY '$i' for read: $!"; |
| 6840 | open( OUT, '>', $o ) or die "Cannot open TTY '$o' for write: $!"; |
| 6841 | $IN = \*IN; |
| 6842 | $OUT = \*OUT; |
| 6843 | _autoflush($OUT); |
| 6844 | } ## end if ($tty) |
| 6845 | |
| 6846 | # We don't have a TTY - try to find one via Term::Rendezvous. |
| 6847 | else { |
| 6848 | require Term::Rendezvous; |
| 6849 | |
| 6850 | # See if we have anything to pass to Term::Rendezvous. |
| 6851 | # Use $HOME/.perldbtty$$ if not. |
| 6852 | my $rv = $ENV{PERLDB_NOTTY} || "$ENV{HOME}/.perldbtty$$"; |
| 6853 | |
| 6854 | # Rendezvous and get the filehandles. |
| 6855 | my $term_rv = Term::Rendezvous->new( $rv ); |
| 6856 | $IN = $term_rv->IN; |
| 6857 | $OUT = $term_rv->OUT; |
| 6858 | } ## end else [ if ($tty) |
| 6859 | } ## end if ($notty) |
| 6860 | |
| 6861 | # We're a daughter debugger. Try to fork off another TTY. |
| 6862 | if ( $term_pid eq '-1' ) { # In a TTY with another debugger |
| 6863 | resetterm(2); |
| 6864 | } |
| 6865 | |
| 6866 | # If we shouldn't use Term::ReadLine, don't. |
| 6867 | if ( !$rl ) { |
| 6868 | $term = Term::ReadLine::Stub->new( 'perldb', $IN, $OUT ); |
| 6869 | } |
| 6870 | |
| 6871 | # We're using Term::ReadLine. Get all the attributes for this terminal. |
| 6872 | else { |
| 6873 | $term = Term::ReadLine->new( 'perldb', $IN, $OUT ); |
| 6874 | |
| 6875 | $rl_attribs = $term->Attribs; |
| 6876 | $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}' |
| 6877 | if defined $rl_attribs->{basic_word_break_characters} |
| 6878 | and index( $rl_attribs->{basic_word_break_characters}, ":" ) == -1; |
| 6879 | $rl_attribs->{special_prefixes} = '$@&%'; |
| 6880 | $rl_attribs->{completer_word_break_characters} .= '$@&%'; |
| 6881 | $rl_attribs->{completion_function} = \&db_complete; |
| 6882 | } ## end else [ if (!$rl) |
| 6883 | |
| 6884 | # Set up the LINEINFO filehandle. |
| 6885 | $LINEINFO = $OUT unless defined $LINEINFO; |
| 6886 | $lineinfo = $console unless defined $lineinfo; |
| 6887 | |
| 6888 | $term->MinLine(2); |
| 6889 | |
| 6890 | load_hist(); |
| 6891 | |
| 6892 | if ( $term->Features->{setHistory} and "@hist" ne "?" ) { |
| 6893 | $term->SetHistory(@hist); |
| 6894 | } |
| 6895 | |
| 6896 | # XXX Ornaments are turned on unconditionally, which is not |
| 6897 | # always a good thing. |
| 6898 | ornaments($ornaments) if defined $ornaments; |
| 6899 | $term_pid = $$; |
| 6900 | } ## end sub setterm |
| 6901 | |
| 6902 | sub load_hist { |
| 6903 | $histfile //= option_val("HistFile", undef); |
| 6904 | return unless defined $histfile; |
| 6905 | open my $fh, "<", $histfile or return; |
| 6906 | local $/ = "\n"; |
| 6907 | @hist = (); |
| 6908 | while (<$fh>) { |
| 6909 | chomp; |
| 6910 | push @hist, $_; |
| 6911 | } |
| 6912 | close $fh; |
| 6913 | } |
| 6914 | |
| 6915 | sub save_hist { |
| 6916 | return unless defined $histfile; |
| 6917 | eval { require File::Path } or return; |
| 6918 | eval { require File::Basename } or return; |
| 6919 | File::Path::mkpath(File::Basename::dirname($histfile)); |
| 6920 | open my $fh, ">", $histfile or die "Could not open '$histfile': $!"; |
| 6921 | $histsize //= option_val("HistSize",100); |
| 6922 | my @copy = grep { $_ ne '?' } @hist; |
| 6923 | my $start = scalar(@copy) > $histsize ? scalar(@copy)-$histsize : 0; |
| 6924 | for ($start .. $#copy) { |
| 6925 | print $fh "$copy[$_]\n"; |
| 6926 | } |
| 6927 | close $fh or die "Could not write '$histfile': $!"; |
| 6928 | } |
| 6929 | |
| 6930 | =head1 GET_FORK_TTY EXAMPLE FUNCTIONS |
| 6931 | |
| 6932 | When the process being debugged forks, or the process invokes a command |
| 6933 | via C<system()> which starts a new debugger, we need to be able to get a new |
| 6934 | C<IN> and C<OUT> filehandle for the new debugger. Otherwise, the two processes |
| 6935 | fight over the terminal, and you can never quite be sure who's going to get the |
| 6936 | input you're typing. |
| 6937 | |
| 6938 | C<get_fork_TTY> is a glob-aliased function which calls the real function that |
| 6939 | is tasked with doing all the necessary operating system mojo to get a new |
| 6940 | TTY (and probably another window) and to direct the new debugger to read and |
| 6941 | write there. |
| 6942 | |
| 6943 | The debugger provides C<get_fork_TTY> functions which work for TCP |
| 6944 | socket servers, X11, OS/2, and Mac OS X. Other systems are not |
| 6945 | supported. You are encouraged to write C<get_fork_TTY> functions which |
| 6946 | work for I<your> platform and contribute them. |
| 6947 | |
| 6948 | =head3 C<socket_get_fork_TTY> |
| 6949 | |
| 6950 | =cut |
| 6951 | |
| 6952 | sub connect_remoteport { |
| 6953 | require IO::Socket; |
| 6954 | |
| 6955 | my $socket = IO::Socket::INET->new( |
| 6956 | Timeout => '10', |
| 6957 | PeerAddr => $remoteport, |
| 6958 | Proto => 'tcp', |
| 6959 | ); |
| 6960 | if ( ! $socket ) { |
| 6961 | die "Unable to connect to remote host: $remoteport\n"; |
| 6962 | } |
| 6963 | return $socket; |
| 6964 | } |
| 6965 | |
| 6966 | sub socket_get_fork_TTY { |
| 6967 | $tty = $LINEINFO = $IN = $OUT = connect_remoteport(); |
| 6968 | |
| 6969 | # Do I need to worry about setting $term? |
| 6970 | |
| 6971 | reset_IN_OUT( $IN, $OUT ); |
| 6972 | return ''; |
| 6973 | } |
| 6974 | |
| 6975 | =head3 C<xterm_get_fork_TTY> |
| 6976 | |
| 6977 | This function provides the C<get_fork_TTY> function for X11. If a |
| 6978 | program running under the debugger forks, a new <xterm> window is opened and |
| 6979 | the subsidiary debugger is directed there. |
| 6980 | |
| 6981 | The C<open()> call is of particular note here. We have the new C<xterm> |
| 6982 | we're spawning route file number 3 to STDOUT, and then execute the C<tty> |
| 6983 | command (which prints the device name of the TTY we'll want to use for input |
| 6984 | and output to STDOUT, then C<sleep> for a very long time, routing this output |
| 6985 | to file number 3. This way we can simply read from the <XT> filehandle (which |
| 6986 | is STDOUT from the I<commands> we ran) to get the TTY we want to use. |
| 6987 | |
| 6988 | Only works if C<xterm> is in your path and C<$ENV{DISPLAY}>, etc. are |
| 6989 | properly set up. |
| 6990 | |
| 6991 | =cut |
| 6992 | |
| 6993 | sub xterm_get_fork_TTY { |
| 6994 | ( my $name = $0 ) =~ s,^.*[/\\],,s; |
| 6995 | open XT, |
| 6996 | qq[3>&1 xterm -title "Daughter Perl debugger $pids $name" -e sh -c 'tty 1>&3;\ |
| 6997 | sleep 10000000' |]; |
| 6998 | |
| 6999 | # Get the output from 'tty' and clean it up a little. |
| 7000 | my $tty = <XT>; |
| 7001 | chomp $tty; |
| 7002 | |
| 7003 | $pidprompt = ''; # Shown anyway in titlebar |
| 7004 | |
| 7005 | # We need $term defined or we can not switch to the newly created xterm |
| 7006 | if ($tty ne '' && !defined $term) { |
| 7007 | require Term::ReadLine; |
| 7008 | if ( !$rl ) { |
| 7009 | $term = Term::ReadLine::Stub->new( 'perldb', $IN, $OUT ); |
| 7010 | } |
| 7011 | else { |
| 7012 | $term = Term::ReadLine->new( 'perldb', $IN, $OUT ); |
| 7013 | } |
| 7014 | } |
| 7015 | # There's our new TTY. |
| 7016 | return $tty; |
| 7017 | } ## end sub xterm_get_fork_TTY |
| 7018 | |
| 7019 | =head3 C<os2_get_fork_TTY> |
| 7020 | |
| 7021 | XXX It behooves an OS/2 expert to write the necessary documentation for this! |
| 7022 | |
| 7023 | =cut |
| 7024 | |
| 7025 | # This example function resets $IN, $OUT itself |
| 7026 | my $c_pipe = 0; |
| 7027 | sub os2_get_fork_TTY { # A simplification of the following (and works without): |
| 7028 | local $\ = ''; |
| 7029 | ( my $name = $0 ) =~ s,^.*[/\\],,s; |
| 7030 | my %opt = ( title => "Daughter Perl debugger $pids $name", |
| 7031 | ($rl ? (read_by_key => 1) : ()) ); |
| 7032 | require OS2::Process; |
| 7033 | my ($in, $out, $pid) = eval { OS2::Process::io_term(related => 0, %opt) } |
| 7034 | or return; |
| 7035 | $pidprompt = ''; # Shown anyway in titlebar |
| 7036 | reset_IN_OUT($in, $out); |
| 7037 | $tty = '*reset*'; |
| 7038 | return ''; # Indicate that reset_IN_OUT is called |
| 7039 | } ## end sub os2_get_fork_TTY |
| 7040 | |
| 7041 | =head3 C<macosx_get_fork_TTY> |
| 7042 | |
| 7043 | The Mac OS X version uses AppleScript to tell Terminal.app to create |
| 7044 | a new window. |
| 7045 | |
| 7046 | =cut |
| 7047 | |
| 7048 | # Notes about Terminal.app's AppleScript support, |
| 7049 | # (aka things that might break in future OS versions). |
| 7050 | # |
| 7051 | # The "do script" command doesn't return a reference to the new window |
| 7052 | # it creates, but since it appears frontmost and windows are enumerated |
| 7053 | # front to back, we can use "first window" === "window 1". |
| 7054 | # |
| 7055 | # Since "do script" is implemented by supplying the argument (plus a |
| 7056 | # return character) as terminal input, there's a potential race condition |
| 7057 | # where the debugger could beat the shell to reading the command. |
| 7058 | # To prevent this, we wait for the screen to clear before proceeding. |
| 7059 | # |
| 7060 | # 10.3 and 10.4: |
| 7061 | # There's no direct accessor for the tty device name, so we fiddle |
| 7062 | # with the window title options until it says what we want. |
| 7063 | # |
| 7064 | # 10.5: |
| 7065 | # There _is_ a direct accessor for the tty device name, _and_ there's |
| 7066 | # a new possible component of the window title (the name of the settings |
| 7067 | # set). A separate version is needed. |
| 7068 | |
| 7069 | my @script_versions= |
| 7070 | |
| 7071 | ([237, <<'__LEOPARD__'], |
| 7072 | tell application "Terminal" |
| 7073 | do script "clear;exec sleep 100000" |
| 7074 | tell first tab of first window |
| 7075 | copy tty to thetty |
| 7076 | set custom title to "forked perl debugger" |
| 7077 | set title displays custom title to true |
| 7078 | repeat while (length of first paragraph of (get contents)) > 0 |
| 7079 | delay 0.1 |
| 7080 | end repeat |
| 7081 | end tell |
| 7082 | end tell |
| 7083 | thetty |
| 7084 | __LEOPARD__ |
| 7085 | |
| 7086 | [100, <<'__JAGUAR_TIGER__'], |
| 7087 | tell application "Terminal" |
| 7088 | do script "clear;exec sleep 100000" |
| 7089 | tell first window |
| 7090 | set title displays shell path to false |
| 7091 | set title displays window size to false |
| 7092 | set title displays file name to false |
| 7093 | set title displays device name to true |
| 7094 | set title displays custom title to true |
| 7095 | set custom title to "" |
| 7096 | copy "/dev/" & name to thetty |
| 7097 | set custom title to "forked perl debugger" |
| 7098 | repeat while (length of first paragraph of (get contents)) > 0 |
| 7099 | delay 0.1 |
| 7100 | end repeat |
| 7101 | end tell |
| 7102 | end tell |
| 7103 | thetty |
| 7104 | __JAGUAR_TIGER__ |
| 7105 | |
| 7106 | ); |
| 7107 | |
| 7108 | sub macosx_get_fork_TTY |
| 7109 | { |
| 7110 | my($version,$script,$pipe,$tty); |
| 7111 | |
| 7112 | return unless $version=$ENV{TERM_PROGRAM_VERSION}; |
| 7113 | foreach my $entry (@script_versions) { |
| 7114 | if ($version>=$entry->[0]) { |
| 7115 | $script=$entry->[1]; |
| 7116 | last; |
| 7117 | } |
| 7118 | } |
| 7119 | return unless defined($script); |
| 7120 | return unless open($pipe,'-|','/usr/bin/osascript','-e',$script); |
| 7121 | $tty=readline($pipe); |
| 7122 | close($pipe); |
| 7123 | return unless defined($tty) && $tty =~ m(^/dev/); |
| 7124 | chomp $tty; |
| 7125 | return $tty; |
| 7126 | } |
| 7127 | |
| 7128 | =head3 C<tmux_get_fork_TTY> |
| 7129 | |
| 7130 | Creates a split window for subprocesses when a process running under the |
| 7131 | perl debugger in Tmux forks. |
| 7132 | |
| 7133 | =cut |
| 7134 | |
| 7135 | sub tmux_get_fork_TTY { |
| 7136 | return unless $ENV{TMUX}; |
| 7137 | |
| 7138 | my $pipe; |
| 7139 | |
| 7140 | my $status = open $pipe, '-|', 'tmux', 'split-window', |
| 7141 | '-P', '-F', '#{pane_tty}', 'sleep 100000'; |
| 7142 | |
| 7143 | if ( !$status ) { |
| 7144 | return; |
| 7145 | } |
| 7146 | |
| 7147 | my $tty = <$pipe>; |
| 7148 | close $pipe; |
| 7149 | |
| 7150 | if ( $tty ) { |
| 7151 | chomp $tty; |
| 7152 | |
| 7153 | if ( !defined $term ) { |
| 7154 | require Term::ReadLine; |
| 7155 | if ( !$rl ) { |
| 7156 | $term = Term::ReadLine::Stub->new( 'perldb', $IN, $OUT ); |
| 7157 | } |
| 7158 | else { |
| 7159 | $term = Term::ReadLine->new( 'perldb', $IN, $OUT ); |
| 7160 | } |
| 7161 | } |
| 7162 | } |
| 7163 | |
| 7164 | return $tty; |
| 7165 | } |
| 7166 | |
| 7167 | =head2 C<create_IN_OUT($flags)> |
| 7168 | |
| 7169 | Create a new pair of filehandles, pointing to a new TTY. If impossible, |
| 7170 | try to diagnose why. |
| 7171 | |
| 7172 | Flags are: |
| 7173 | |
| 7174 | =over 4 |
| 7175 | |
| 7176 | =item * 1 - Don't know how to create a new TTY. |
| 7177 | |
| 7178 | =item * 2 - Debugger has forked, but we can't get a new TTY. |
| 7179 | |
| 7180 | =item * 4 - standard debugger startup is happening. |
| 7181 | |
| 7182 | =back |
| 7183 | |
| 7184 | =cut |
| 7185 | |
| 7186 | use vars qw($fork_TTY); |
| 7187 | |
| 7188 | sub create_IN_OUT { # Create a window with IN/OUT handles redirected there |
| 7189 | |
| 7190 | # If we know how to get a new TTY, do it! $in will have |
| 7191 | # the TTY name if get_fork_TTY works. |
| 7192 | my $in = get_fork_TTY(@_) if defined &get_fork_TTY; |
| 7193 | |
| 7194 | # It used to be that |
| 7195 | $in = $fork_TTY if defined $fork_TTY; # Backward compatibility |
| 7196 | |
| 7197 | if ( not defined $in ) { |
| 7198 | my $why = shift; |
| 7199 | |
| 7200 | # We don't know how. |
| 7201 | print_help(<<EOP) if $why == 1; |
| 7202 | I<#########> Forked, but do not know how to create a new B<TTY>. I<#########> |
| 7203 | EOP |
| 7204 | |
| 7205 | # Forked debugger. |
| 7206 | print_help(<<EOP) if $why == 2; |
| 7207 | I<#########> Daughter session, do not know how to change a B<TTY>. I<#########> |
| 7208 | This may be an asynchronous session, so the parent debugger may be active. |
| 7209 | EOP |
| 7210 | |
| 7211 | # Note that both debuggers are fighting over the same input. |
| 7212 | print_help(<<EOP) if $why != 4; |
| 7213 | Since two debuggers fight for the same TTY, input is severely entangled. |
| 7214 | |
| 7215 | EOP |
| 7216 | print_help(<<EOP); |
| 7217 | I know how to switch the output to a different window in xterms, OS/2 |
| 7218 | consoles, and Mac OS X Terminal.app only. For a manual switch, put the name |
| 7219 | of the created I<TTY> in B<\$DB::fork_TTY>, or define a function |
| 7220 | B<DB::get_fork_TTY()> returning this. |
| 7221 | |
| 7222 | On I<UNIX>-like systems one can get the name of a I<TTY> for the given window |
| 7223 | by typing B<tty>, and disconnect the I<shell> from I<TTY> by S<B<sleep 1000000>>. |
| 7224 | |
| 7225 | EOP |
| 7226 | } ## end if (not defined $in) |
| 7227 | elsif ( $in ne '' ) { |
| 7228 | TTY($in); |
| 7229 | } |
| 7230 | else { |
| 7231 | $console = ''; # Indicate no need to open-from-the-console |
| 7232 | } |
| 7233 | undef $fork_TTY; |
| 7234 | } ## end sub create_IN_OUT |
| 7235 | |
| 7236 | =head2 C<resetterm> |
| 7237 | |
| 7238 | Handles rejiggering the prompt when we've forked off a new debugger. |
| 7239 | |
| 7240 | If the new debugger happened because of a C<system()> that invoked a |
| 7241 | program under the debugger, the arrow between the old pid and the new |
| 7242 | in the prompt has I<two> dashes instead of one. |
| 7243 | |
| 7244 | We take the current list of pids and add this one to the end. If there |
| 7245 | isn't any list yet, we make one up out of the initial pid associated with |
| 7246 | the terminal and our new pid, sticking an arrow (either one-dashed or |
| 7247 | two dashed) in between them. |
| 7248 | |
| 7249 | If C<CreateTTY> is off, or C<resetterm> was called with no arguments, |
| 7250 | we don't try to create a new IN and OUT filehandle. Otherwise, we go ahead |
| 7251 | and try to do that. |
| 7252 | |
| 7253 | =cut |
| 7254 | |
| 7255 | sub resetterm { # We forked, so we need a different TTY |
| 7256 | |
| 7257 | # Needs to be passed to create_IN_OUT() as well. |
| 7258 | my $in = shift; |
| 7259 | |
| 7260 | # resetterm(2): got in here because of a system() starting a debugger. |
| 7261 | # resetterm(1): just forked. |
| 7262 | my $systemed = $in > 1 ? '-' : ''; |
| 7263 | |
| 7264 | # If there's already a list of pids, add this to the end. |
| 7265 | if ($pids) { |
| 7266 | $pids =~ s/\]/$systemed->$$]/; |
| 7267 | } |
| 7268 | |
| 7269 | # No pid list. Time to make one. |
| 7270 | else { |
| 7271 | $pids = "[$term_pid->$$]"; |
| 7272 | } |
| 7273 | |
| 7274 | # The prompt we're going to be using for this debugger. |
| 7275 | $pidprompt = $pids; |
| 7276 | |
| 7277 | # We now 0wnz this terminal. |
| 7278 | $term_pid = $$; |
| 7279 | |
| 7280 | # Just return if we're not supposed to try to create a new TTY. |
| 7281 | return unless $CreateTTY & $in; |
| 7282 | |
| 7283 | # Try to create a new IN/OUT pair. |
| 7284 | create_IN_OUT($in); |
| 7285 | } ## end sub resetterm |
| 7286 | |
| 7287 | =head2 C<readline> |
| 7288 | |
| 7289 | First, we handle stuff in the typeahead buffer. If there is any, we shift off |
| 7290 | the next line, print a message saying we got it, add it to the terminal |
| 7291 | history (if possible), and return it. |
| 7292 | |
| 7293 | If there's nothing in the typeahead buffer, check the command filehandle stack. |
| 7294 | If there are any filehandles there, read from the last one, and return the line |
| 7295 | if we got one. If not, we pop the filehandle off and close it, and try the |
| 7296 | next one up the stack. |
| 7297 | |
| 7298 | If we've emptied the filehandle stack, we check to see if we've got a socket |
| 7299 | open, and we read that and return it if we do. If we don't, we just call the |
| 7300 | core C<readline()> and return its value. |
| 7301 | |
| 7302 | =cut |
| 7303 | |
| 7304 | sub readline { |
| 7305 | |
| 7306 | # Localize to prevent it from being smashed in the program being debugged. |
| 7307 | local $.; |
| 7308 | |
| 7309 | # If there are stacked filehandles to read from ... |
| 7310 | # (Handle it before the typeahead, because we may call source/etc. from |
| 7311 | # the typeahead.) |
| 7312 | while (@cmdfhs) { |
| 7313 | |
| 7314 | # Read from the last one in the stack. |
| 7315 | my $line = CORE::readline( $cmdfhs[-1] ); |
| 7316 | |
| 7317 | # If we got a line ... |
| 7318 | defined $line |
| 7319 | ? ( print $OUT ">> $line" and return $line ) # Echo and return |
| 7320 | : close pop @cmdfhs; # Pop and close |
| 7321 | } ## end while (@cmdfhs) |
| 7322 | |
| 7323 | # Pull a line out of the typeahead if there's stuff there. |
| 7324 | if (@typeahead) { |
| 7325 | |
| 7326 | # How many lines left. |
| 7327 | my $left = @typeahead; |
| 7328 | |
| 7329 | # Get the next line. |
| 7330 | my $got = shift @typeahead; |
| 7331 | |
| 7332 | # Print a message saying we got input from the typeahead. |
| 7333 | local $\ = ''; |
| 7334 | print $OUT "auto(-$left)", shift, $got, "\n"; |
| 7335 | |
| 7336 | # Add it to the terminal history (if possible). |
| 7337 | $term->AddHistory($got) |
| 7338 | if length($got) >= option_val("HistItemMinLength", 2) |
| 7339 | and defined $term->Features->{addHistory}; |
| 7340 | return $got; |
| 7341 | } ## end if (@typeahead) |
| 7342 | |
| 7343 | # We really need to read some input. Turn off entry/exit trace and |
| 7344 | # return value printing. |
| 7345 | local $frame = 0; |
| 7346 | local $doret = -2; |
| 7347 | |
| 7348 | # Nothing on the filehandle stack. Socket? |
| 7349 | if ( ref $OUT and UNIVERSAL::isa( $OUT, 'IO::Socket::INET' ) ) { |
| 7350 | |
| 7351 | # Send anything we have to send. |
| 7352 | $OUT->write( join( '', @_ ) ); |
| 7353 | |
| 7354 | # Receive anything there is to receive. |
| 7355 | my $stuff = ''; |
| 7356 | my $buf; |
| 7357 | my $first_time = 1; |
| 7358 | |
| 7359 | while ($first_time or (length($buf) && ($stuff .= $buf) !~ /\n/)) |
| 7360 | { |
| 7361 | $first_time = 0; |
| 7362 | $IN->recv( $buf = '', 2048 ); # XXX "what's wrong with sysread?" |
| 7363 | # XXX Don't know. You tell me. |
| 7364 | } |
| 7365 | |
| 7366 | # What we got. |
| 7367 | return $stuff; |
| 7368 | } ## end if (ref $OUT and UNIVERSAL::isa... |
| 7369 | |
| 7370 | # No socket. Just read from the terminal. |
| 7371 | else { |
| 7372 | return $term->readline(@_); |
| 7373 | } |
| 7374 | } ## end sub readline |
| 7375 | |
| 7376 | =head1 OPTIONS SUPPORT ROUTINES |
| 7377 | |
| 7378 | These routines handle listing and setting option values. |
| 7379 | |
| 7380 | =head2 C<dump_option> - list the current value of an option setting |
| 7381 | |
| 7382 | This routine uses C<option_val> to look up the value for an option. |
| 7383 | It cleans up escaped single-quotes and then displays the option and |
| 7384 | its value. |
| 7385 | |
| 7386 | =cut |
| 7387 | |
| 7388 | sub dump_option { |
| 7389 | my ( $opt, $val ) = @_; |
| 7390 | $val = option_val( $opt, 'N/A' ); |
| 7391 | $val =~ s/([\\\'])/\\$1/g; |
| 7392 | printf $OUT "%20s = '%s'\n", $opt, $val; |
| 7393 | } ## end sub dump_option |
| 7394 | |
| 7395 | sub options2remember { |
| 7396 | foreach my $k (@RememberOnROptions) { |
| 7397 | $option{$k} = option_val( $k, 'N/A' ); |
| 7398 | } |
| 7399 | return %option; |
| 7400 | } |
| 7401 | |
| 7402 | =head2 C<option_val> - find the current value of an option |
| 7403 | |
| 7404 | This can't just be a simple hash lookup because of the indirect way that |
| 7405 | the option values are stored. Some are retrieved by calling a subroutine, |
| 7406 | some are just variables. |
| 7407 | |
| 7408 | You must supply a default value to be used in case the option isn't set. |
| 7409 | |
| 7410 | =cut |
| 7411 | |
| 7412 | sub option_val { |
| 7413 | my ( $opt, $default ) = @_; |
| 7414 | my $val; |
| 7415 | |
| 7416 | # Does this option exist, and is it a variable? |
| 7417 | # If so, retrieve the value via the value in %optionVars. |
| 7418 | if ( defined $optionVars{$opt} |
| 7419 | and defined ${ $optionVars{$opt} } ) |
| 7420 | { |
| 7421 | $val = ${ $optionVars{$opt} }; |
| 7422 | } |
| 7423 | |
| 7424 | # Does this option exist, and it's a subroutine? |
| 7425 | # If so, call the subroutine via the ref in %optionAction |
| 7426 | # and capture the value. |
| 7427 | elsif ( defined $optionAction{$opt} |
| 7428 | and defined &{ $optionAction{$opt} } ) |
| 7429 | { |
| 7430 | $val = &{ $optionAction{$opt} }(); |
| 7431 | } |
| 7432 | |
| 7433 | # If there's an action or variable for the supplied option, |
| 7434 | # but no value was set, use the default. |
| 7435 | elsif (defined $optionAction{$opt} and not defined $option{$opt} |
| 7436 | or defined $optionVars{$opt} and not defined ${ $optionVars{$opt} } ) |
| 7437 | { |
| 7438 | $val = $default; |
| 7439 | } |
| 7440 | |
| 7441 | # Otherwise, do the simple hash lookup. |
| 7442 | else { |
| 7443 | $val = $option{$opt}; |
| 7444 | } |
| 7445 | |
| 7446 | # If the value isn't defined, use the default. |
| 7447 | # Then return whatever the value is. |
| 7448 | $val = $default unless defined $val; |
| 7449 | $val; |
| 7450 | } ## end sub option_val |
| 7451 | |
| 7452 | =head2 C<parse_options> |
| 7453 | |
| 7454 | Handles the parsing and execution of option setting/displaying commands. |
| 7455 | |
| 7456 | An option entered by itself is assumed to be I<set me to 1> (the default value) |
| 7457 | if the option is a boolean one. If not, the user is prompted to enter a valid |
| 7458 | value or to query the current value (via C<option? >). |
| 7459 | |
| 7460 | If C<option=value> is entered, we try to extract a quoted string from the |
| 7461 | value (if it is quoted). If it's not, we just use the whole value as-is. |
| 7462 | |
| 7463 | We load any modules required to service this option, and then we set it: if |
| 7464 | it just gets stuck in a variable, we do that; if there's a subroutine to |
| 7465 | handle setting the option, we call that. |
| 7466 | |
| 7467 | Finally, if we're running in interactive mode, we display the effect of the |
| 7468 | user's command back to the terminal, skipping this if we're setting things |
| 7469 | during initialization. |
| 7470 | |
| 7471 | =cut |
| 7472 | |
| 7473 | sub parse_options { |
| 7474 | my ($s) = @_; |
| 7475 | local $\ = ''; |
| 7476 | |
| 7477 | my $option; |
| 7478 | |
| 7479 | # These options need a value. Don't allow them to be clobbered by accident. |
| 7480 | my %opt_needs_val = map { ( $_ => 1 ) } qw{ |
| 7481 | dumpDepth arrayDepth hashDepth LineInfo maxTraceLen ornaments windowSize |
| 7482 | pager quote ReadLine recallCommand RemotePort ShellBang TTY CommandSet |
| 7483 | }; |
| 7484 | |
| 7485 | while (length($s)) { |
| 7486 | my $val_defaulted; |
| 7487 | |
| 7488 | # Clean off excess leading whitespace. |
| 7489 | $s =~ s/^\s+// && next; |
| 7490 | |
| 7491 | # Options are always all word characters, followed by a non-word |
| 7492 | # separator. |
| 7493 | if ($s !~ s/^(\w+)(\W?)//) { |
| 7494 | print {$OUT} "Invalid option '$s'\n"; |
| 7495 | last; |
| 7496 | } |
| 7497 | my ( $opt, $sep ) = ( $1, $2 ); |
| 7498 | |
| 7499 | # Make sure that such an option exists. |
| 7500 | my $matches = ( grep { /^\Q$opt/ && ( $option = $_ ) } @options ) |
| 7501 | || ( grep { /^\Q$opt/i && ( $option = $_ ) } @options ); |
| 7502 | |
| 7503 | unless ($matches) { |
| 7504 | print {$OUT} "Unknown option '$opt'\n"; |
| 7505 | next; |
| 7506 | } |
| 7507 | if ($matches > 1) { |
| 7508 | print {$OUT} "Ambiguous option '$opt'\n"; |
| 7509 | next; |
| 7510 | } |
| 7511 | my $val; |
| 7512 | |
| 7513 | # '?' as separator means query, but must have whitespace after it. |
| 7514 | if ( "?" eq $sep ) { |
| 7515 | if ($s =~ /\A\S/) { |
| 7516 | print {$OUT} "Option query '$opt?' followed by non-space '$s'\n" ; |
| 7517 | |
| 7518 | last; |
| 7519 | } |
| 7520 | |
| 7521 | #&dump_option($opt); |
| 7522 | } ## end if ("?" eq $sep) |
| 7523 | |
| 7524 | # Separator is whitespace (or just a carriage return). |
| 7525 | # They're going for a default, which we assume is 1. |
| 7526 | elsif ( $sep !~ /\S/ ) { |
| 7527 | $val_defaulted = 1; |
| 7528 | $val = "1"; # this is an evil default; make 'em set it! |
| 7529 | } |
| 7530 | |
| 7531 | # Separator is =. Trying to set a value. |
| 7532 | elsif ( $sep eq "=" ) { |
| 7533 | |
| 7534 | # If quoted, extract a quoted string. |
| 7535 | if ($s =~ s/ (["']) ( (?: \\. | (?! \1 ) [^\\] )* ) \1 //x) { |
| 7536 | my $quote = $1; |
| 7537 | ( $val = $2 ) =~ s/\\([$quote\\])/$1/g; |
| 7538 | } |
| 7539 | |
| 7540 | # Not quoted. Use the whole thing. Warn about 'option='. |
| 7541 | else { |
| 7542 | $s =~ s/^(\S*)//; |
| 7543 | $val = $1; |
| 7544 | print OUT qq(Option better cleared using $opt=""\n) |
| 7545 | unless length $val; |
| 7546 | } ## end else [ if (s/ (["']) ( (?: \\. | (?! \1 ) [^\\] )* ) \1 //x) |
| 7547 | |
| 7548 | } ## end elsif ($sep eq "=") |
| 7549 | |
| 7550 | # "Quoted" with [], <>, or {}. |
| 7551 | else { #{ to "let some poor schmuck bounce on the % key in B<vi>." |
| 7552 | my ($end) = |
| 7553 | "\\" . substr( ")]>}$sep", index( "([<{", $sep ), 1 ); #} |
| 7554 | $s =~ s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// |
| 7555 | or print( $OUT "Unclosed option value '$opt$sep$_'\n" ), last; |
| 7556 | ( $val = $1 ) =~ s/\\([\\$end])/$1/g; |
| 7557 | } ## end else [ if ("?" eq $sep) |
| 7558 | |
| 7559 | # Exclude non-booleans from getting set to 1 by default. |
| 7560 | if ( $opt_needs_val{$option} && $val_defaulted ) { |
| 7561 | my $cmd = ( $CommandSet eq '580' ) ? 'o' : 'O'; |
| 7562 | print {$OUT} |
| 7563 | "Option '$opt' is non-boolean. Use '$cmd $option=VAL' to set, '$cmd $option?' to query\n"; |
| 7564 | next; |
| 7565 | } ## end if ($opt_needs_val{$option... |
| 7566 | |
| 7567 | # Save the option value. |
| 7568 | $option{$option} = $val if defined $val; |
| 7569 | |
| 7570 | # Load any module that this option requires. |
| 7571 | if ( defined($optionRequire{$option}) && defined($val) ) { |
| 7572 | eval qq{ |
| 7573 | local \$frame = 0; |
| 7574 | local \$doret = -2; |
| 7575 | require '$optionRequire{$option}'; |
| 7576 | 1; |
| 7577 | } || die $@ # XXX: shouldn't happen |
| 7578 | } |
| 7579 | |
| 7580 | # Set it. |
| 7581 | # Stick it in the proper variable if it goes in a variable. |
| 7582 | if (defined($optionVars{$option}) && defined($val)) { |
| 7583 | ${ $optionVars{$option} } = $val; |
| 7584 | } |
| 7585 | |
| 7586 | # Call the appropriate sub if it gets set via sub. |
| 7587 | if (defined($optionAction{$option}) |
| 7588 | && defined (&{ $optionAction{$option} }) |
| 7589 | && defined ($val)) |
| 7590 | { |
| 7591 | &{ $optionAction{$option} }($val); |
| 7592 | } |
| 7593 | |
| 7594 | # Not initialization - echo the value we set it to. |
| 7595 | dump_option($option) if ($OUT ne \*STDERR); |
| 7596 | } ## end while (length) |
| 7597 | } ## end sub parse_options |
| 7598 | |
| 7599 | =head1 RESTART SUPPORT |
| 7600 | |
| 7601 | These routines are used to store (and restore) lists of items in environment |
| 7602 | variables during a restart. |
| 7603 | |
| 7604 | =head2 set_list |
| 7605 | |
| 7606 | Set_list packages up items to be stored in a set of environment variables |
| 7607 | (VAR_n, containing the number of items, and VAR_0, VAR_1, etc., containing |
| 7608 | the values). Values outside the standard ASCII charset are stored by encoding |
| 7609 | them as hexadecimal values. |
| 7610 | |
| 7611 | =cut |
| 7612 | |
| 7613 | sub set_list { |
| 7614 | my ( $stem, @list ) = @_; |
| 7615 | my $val; |
| 7616 | |
| 7617 | # VAR_n: how many we have. Scalar assignment gets the number of items. |
| 7618 | $ENV{"${stem}_n"} = @list; |
| 7619 | |
| 7620 | # Grab each item in the list, escape the backslashes, encode the non-ASCII |
| 7621 | # as hex, and then save in the appropriate VAR_0, VAR_1, etc. |
| 7622 | for my $i ( 0 .. $#list ) { |
| 7623 | $val = $list[$i]; |
| 7624 | $val =~ s/\\/\\\\/g; |
| 7625 | $val =~ s/ ( (?[ [\000-\xFF] & [:^print:] ]) ) / |
| 7626 | "\\0x" . unpack('H2',$1)/xaeg; |
| 7627 | $ENV{"${stem}_$i"} = $val; |
| 7628 | } ## end for $i (0 .. $#list) |
| 7629 | } ## end sub set_list |
| 7630 | |
| 7631 | =head2 get_list |
| 7632 | |
| 7633 | Reverse the set_list operation: grab VAR_n to see how many we should be getting |
| 7634 | back, and then pull VAR_0, VAR_1. etc. back out. |
| 7635 | |
| 7636 | =cut |
| 7637 | |
| 7638 | sub get_list { |
| 7639 | my $stem = shift; |
| 7640 | my @list; |
| 7641 | my $n = delete $ENV{"${stem}_n"}; |
| 7642 | my $val; |
| 7643 | for my $i ( 0 .. $n - 1 ) { |
| 7644 | $val = delete $ENV{"${stem}_$i"}; |
| 7645 | $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge; |
| 7646 | push @list, $val; |
| 7647 | } |
| 7648 | @list; |
| 7649 | } ## end sub get_list |
| 7650 | |
| 7651 | =head1 MISCELLANEOUS SIGNAL AND I/O MANAGEMENT |
| 7652 | |
| 7653 | =head2 catch() |
| 7654 | |
| 7655 | The C<catch()> subroutine is the essence of fast and low-impact. We simply |
| 7656 | set an already-existing global scalar variable to a constant value. This |
| 7657 | avoids allocating any memory possibly in the middle of something that will |
| 7658 | get all confused if we do, particularly under I<unsafe signals>. |
| 7659 | |
| 7660 | =cut |
| 7661 | |
| 7662 | sub catch { |
| 7663 | $signal = 1; |
| 7664 | return; # Put nothing on the stack - malloc/free land! |
| 7665 | } |
| 7666 | |
| 7667 | =head2 C<warn()> |
| 7668 | |
| 7669 | C<warn> emits a warning, by joining together its arguments and printing |
| 7670 | them, with couple of fillips. |
| 7671 | |
| 7672 | If the composited message I<doesn't> end with a newline, we automatically |
| 7673 | add C<$!> and a newline to the end of the message. The subroutine expects $OUT |
| 7674 | to be set to the filehandle to be used to output warnings; it makes no |
| 7675 | assumptions about what filehandles are available. |
| 7676 | |
| 7677 | =cut |
| 7678 | |
| 7679 | sub _db_warn { |
| 7680 | my ($msg) = join( "", @_ ); |
| 7681 | $msg .= ": $!\n" unless $msg =~ /\n$/; |
| 7682 | local $\ = ''; |
| 7683 | print $OUT $msg; |
| 7684 | } ## end sub warn |
| 7685 | |
| 7686 | *warn = \&_db_warn; |
| 7687 | |
| 7688 | =head1 INITIALIZATION TTY SUPPORT |
| 7689 | |
| 7690 | =head2 C<reset_IN_OUT> |
| 7691 | |
| 7692 | This routine handles restoring the debugger's input and output filehandles |
| 7693 | after we've tried and failed to move them elsewhere. In addition, it assigns |
| 7694 | the debugger's output filehandle to $LINEINFO if it was already open there. |
| 7695 | |
| 7696 | =cut |
| 7697 | |
| 7698 | sub reset_IN_OUT { |
| 7699 | my $switch_li = $LINEINFO eq $OUT; |
| 7700 | |
| 7701 | # If there's a term and it's able to get a new tty, try to get one. |
| 7702 | if ( $term and $term->Features->{newTTY} ) { |
| 7703 | ( $IN, $OUT ) = ( shift, shift ); |
| 7704 | $term->newTTY( $IN, $OUT ); |
| 7705 | } |
| 7706 | |
| 7707 | # This term can't get a new tty now. Better luck later. |
| 7708 | elsif ($term) { |
| 7709 | _db_warn("Too late to set IN/OUT filehandles, enabled on next 'R'!\n"); |
| 7710 | } |
| 7711 | |
| 7712 | # Set the filehndles up as they were. |
| 7713 | else { |
| 7714 | ( $IN, $OUT ) = ( shift, shift ); |
| 7715 | } |
| 7716 | |
| 7717 | # Unbuffer the output filehandle. |
| 7718 | _autoflush($OUT); |
| 7719 | |
| 7720 | # Point LINEINFO to the same output filehandle if it was there before. |
| 7721 | $LINEINFO = $OUT if $switch_li; |
| 7722 | } ## end sub reset_IN_OUT |
| 7723 | |
| 7724 | =head1 OPTION SUPPORT ROUTINES |
| 7725 | |
| 7726 | The following routines are used to process some of the more complicated |
| 7727 | debugger options. |
| 7728 | |
| 7729 | =head2 C<TTY> |
| 7730 | |
| 7731 | Sets the input and output filehandles to the specified files or pipes. |
| 7732 | If the terminal supports switching, we go ahead and do it. If not, and |
| 7733 | there's already a terminal in place, we save the information to take effect |
| 7734 | on restart. |
| 7735 | |
| 7736 | If there's no terminal yet (for instance, during debugger initialization), |
| 7737 | we go ahead and set C<$console> and C<$tty> to the file indicated. |
| 7738 | |
| 7739 | =cut |
| 7740 | |
| 7741 | sub TTY { |
| 7742 | |
| 7743 | if ( @_ and $term and $term->Features->{newTTY} ) { |
| 7744 | |
| 7745 | # This terminal supports switching to a new TTY. |
| 7746 | # Can be a list of two files, or on string containing both names, |
| 7747 | # comma-separated. |
| 7748 | # XXX Should this perhaps be an assignment from @_? |
| 7749 | my ( $in, $out ) = shift; |
| 7750 | if ( $in =~ /,/ ) { |
| 7751 | |
| 7752 | # Split list apart if supplied. |
| 7753 | ( $in, $out ) = split /,/, $in, 2; |
| 7754 | } |
| 7755 | else { |
| 7756 | |
| 7757 | # Use the same file for both input and output. |
| 7758 | $out = $in; |
| 7759 | } |
| 7760 | |
| 7761 | # Open file onto the debugger's filehandles, if you can. |
| 7762 | open IN, '<', $in or die "cannot open '$in' for read: $!"; |
| 7763 | open OUT, '>', $out or die "cannot open '$out' for write: $!"; |
| 7764 | |
| 7765 | # Swap to the new filehandles. |
| 7766 | reset_IN_OUT( \*IN, \*OUT ); |
| 7767 | |
| 7768 | # Save the setting for later. |
| 7769 | return $tty = $in; |
| 7770 | } ## end if (@_ and $term and $term... |
| 7771 | |
| 7772 | # Terminal doesn't support new TTY, or doesn't support readline. |
| 7773 | # Can't do it now, try restarting. |
| 7774 | if ($term and @_) { |
| 7775 | _db_warn("Too late to set TTY, enabled on next 'R'!\n"); |
| 7776 | } |
| 7777 | |
| 7778 | # Useful if done through PERLDB_OPTS: |
| 7779 | $console = $tty = shift if @_; |
| 7780 | |
| 7781 | # Return whatever the TTY is. |
| 7782 | $tty or $console; |
| 7783 | } ## end sub TTY |
| 7784 | |
| 7785 | =head2 C<noTTY> |
| 7786 | |
| 7787 | Sets the C<$notty> global, controlling whether or not the debugger tries to |
| 7788 | get a terminal to read from. If called after a terminal is already in place, |
| 7789 | we save the value to use it if we're restarted. |
| 7790 | |
| 7791 | =cut |
| 7792 | |
| 7793 | sub noTTY { |
| 7794 | if ($term) { |
| 7795 | _db_warn("Too late to set noTTY, enabled on next 'R'!\n") if @_; |
| 7796 | } |
| 7797 | $notty = shift if @_; |
| 7798 | $notty; |
| 7799 | } ## end sub noTTY |
| 7800 | |
| 7801 | =head2 C<ReadLine> |
| 7802 | |
| 7803 | Sets the C<$rl> option variable. If 0, we use C<Term::ReadLine::Stub> |
| 7804 | (essentially, no C<readline> processing on this I<terminal>). Otherwise, we |
| 7805 | use C<Term::ReadLine>. Can't be changed after a terminal's in place; we save |
| 7806 | the value in case a restart is done so we can change it then. |
| 7807 | |
| 7808 | =cut |
| 7809 | |
| 7810 | sub ReadLine { |
| 7811 | if ($term) { |
| 7812 | _db_warn("Too late to set ReadLine, enabled on next 'R'!\n") if @_; |
| 7813 | } |
| 7814 | $rl = shift if @_; |
| 7815 | $rl; |
| 7816 | } ## end sub ReadLine |
| 7817 | |
| 7818 | =head2 C<RemotePort> |
| 7819 | |
| 7820 | Sets the port that the debugger will try to connect to when starting up. |
| 7821 | If the terminal's already been set up, we can't do it, but we remember the |
| 7822 | setting in case the user does a restart. |
| 7823 | |
| 7824 | =cut |
| 7825 | |
| 7826 | sub RemotePort { |
| 7827 | if ($term) { |
| 7828 | _db_warn("Too late to set RemotePort, enabled on next 'R'!\n") if @_; |
| 7829 | } |
| 7830 | $remoteport = shift if @_; |
| 7831 | $remoteport; |
| 7832 | } ## end sub RemotePort |
| 7833 | |
| 7834 | =head2 C<tkRunning> |
| 7835 | |
| 7836 | Checks with the terminal to see if C<Tk> is running, and returns true or |
| 7837 | false. Returns false if the current terminal doesn't support C<readline>. |
| 7838 | |
| 7839 | =cut |
| 7840 | |
| 7841 | sub tkRunning { |
| 7842 | if ( ${ $term->Features }{tkRunning} ) { |
| 7843 | return $term->tkRunning(@_); |
| 7844 | } |
| 7845 | else { |
| 7846 | local $\ = ''; |
| 7847 | print $OUT "tkRunning not supported by current ReadLine package.\n"; |
| 7848 | 0; |
| 7849 | } |
| 7850 | } ## end sub tkRunning |
| 7851 | |
| 7852 | =head2 C<NonStop> |
| 7853 | |
| 7854 | Sets nonstop mode. If a terminal's already been set up, it's too late; the |
| 7855 | debugger remembers the setting in case you restart, though. |
| 7856 | |
| 7857 | =cut |
| 7858 | |
| 7859 | sub NonStop { |
| 7860 | if ($term) { |
| 7861 | _db_warn("Too late to set up NonStop mode, enabled on next 'R'!\n") |
| 7862 | if @_; |
| 7863 | } |
| 7864 | $runnonstop = shift if @_; |
| 7865 | $runnonstop; |
| 7866 | } ## end sub NonStop |
| 7867 | |
| 7868 | sub DollarCaretP { |
| 7869 | if ($term) { |
| 7870 | _db_warn("Some flag changes could not take effect until next 'R'!\n") |
| 7871 | if @_; |
| 7872 | } |
| 7873 | $^P = parse_DollarCaretP_flags(shift) if @_; |
| 7874 | expand_DollarCaretP_flags($^P); |
| 7875 | } |
| 7876 | |
| 7877 | =head2 C<pager> |
| 7878 | |
| 7879 | Set up the C<$pager> variable. Adds a pipe to the front unless there's one |
| 7880 | there already. |
| 7881 | |
| 7882 | =cut |
| 7883 | |
| 7884 | sub pager { |
| 7885 | if (@_) { |
| 7886 | $pager = shift; |
| 7887 | $pager = "|" . $pager unless $pager =~ /^(\+?\>|\|)/; |
| 7888 | } |
| 7889 | $pager; |
| 7890 | } ## end sub pager |
| 7891 | |
| 7892 | =head2 C<shellBang> |
| 7893 | |
| 7894 | Sets the shell escape command, and generates a printable copy to be used |
| 7895 | in the help. |
| 7896 | |
| 7897 | =cut |
| 7898 | |
| 7899 | sub shellBang { |
| 7900 | |
| 7901 | # If we got an argument, meta-quote it, and add '\b' if it |
| 7902 | # ends in a word character. |
| 7903 | if (@_) { |
| 7904 | $sh = quotemeta shift; |
| 7905 | $sh .= "\\b" if $sh =~ /\w$/; |
| 7906 | } |
| 7907 | |
| 7908 | # Generate the printable version for the help: |
| 7909 | $psh = $sh; # copy it |
| 7910 | $psh =~ s/\\b$//; # Take off trailing \b if any |
| 7911 | $psh =~ s/\\(.)/$1/g; # De-escape |
| 7912 | $psh; # return the printable version |
| 7913 | } ## end sub shellBang |
| 7914 | |
| 7915 | =head2 C<ornaments> |
| 7916 | |
| 7917 | If the terminal has its own ornaments, fetch them. Otherwise accept whatever |
| 7918 | was passed as the argument. (This means you can't override the terminal's |
| 7919 | ornaments.) |
| 7920 | |
| 7921 | =cut |
| 7922 | |
| 7923 | sub ornaments { |
| 7924 | if ( defined $term ) { |
| 7925 | |
| 7926 | # We don't want to show warning backtraces, but we do want die() ones. |
| 7927 | local $warnLevel = 0; |
| 7928 | local $dieLevel = 1; |
| 7929 | |
| 7930 | # No ornaments if the terminal doesn't support them. |
| 7931 | if (not $term->Features->{ornaments}) { |
| 7932 | return ''; |
| 7933 | } |
| 7934 | |
| 7935 | return (eval { $term->ornaments(@_) } || ''); |
| 7936 | } |
| 7937 | |
| 7938 | # Use what was passed in if we can't determine it ourselves. |
| 7939 | else { |
| 7940 | $ornaments = shift; |
| 7941 | |
| 7942 | return $ornaments; |
| 7943 | } |
| 7944 | |
| 7945 | } ## end sub ornaments |
| 7946 | |
| 7947 | =head2 C<recallCommand> |
| 7948 | |
| 7949 | Sets the recall command, and builds a printable version which will appear in |
| 7950 | the help text. |
| 7951 | |
| 7952 | =cut |
| 7953 | |
| 7954 | sub recallCommand { |
| 7955 | |
| 7956 | # If there is input, metaquote it. Add '\b' if it ends with a word |
| 7957 | # character. |
| 7958 | if (@_) { |
| 7959 | $rc = quotemeta shift; |
| 7960 | $rc .= "\\b" if $rc =~ /\w$/; |
| 7961 | } |
| 7962 | |
| 7963 | # Build it into a printable version. |
| 7964 | $prc = $rc; # Copy it |
| 7965 | $prc =~ s/\\b$//; # Remove trailing \b |
| 7966 | $prc =~ s/\\(.)/$1/g; # Remove escapes |
| 7967 | return $prc; # Return the printable version |
| 7968 | } ## end sub recallCommand |
| 7969 | |
| 7970 | =head2 C<LineInfo> - where the line number information goes |
| 7971 | |
| 7972 | Called with no arguments, returns the file or pipe that line info should go to. |
| 7973 | |
| 7974 | Called with an argument (a file or a pipe), it opens that onto the |
| 7975 | C<LINEINFO> filehandle, unbuffers the filehandle, and then returns the |
| 7976 | file or pipe again to the caller. |
| 7977 | |
| 7978 | =cut |
| 7979 | |
| 7980 | sub LineInfo { |
| 7981 | if (@_) { |
| 7982 | $lineinfo = shift; |
| 7983 | |
| 7984 | # If this is a valid "thing to be opened for output", tack a |
| 7985 | # '>' onto the front. |
| 7986 | my $stream = ( $lineinfo =~ /^(\+?\>|\|)/ ) ? $lineinfo : ">$lineinfo"; |
| 7987 | |
| 7988 | # If this is a pipe, the stream points to a client editor. |
| 7989 | $client_editor = ( $stream =~ /^\|/ ); |
| 7990 | |
| 7991 | my $new_lineinfo_fh; |
| 7992 | # Open it up and unbuffer it. |
| 7993 | open ($new_lineinfo_fh , $stream ) |
| 7994 | or _db_warn("Cannot open '$stream' for write"); |
| 7995 | $LINEINFO = $new_lineinfo_fh; |
| 7996 | _autoflush($LINEINFO); |
| 7997 | } |
| 7998 | |
| 7999 | return $lineinfo; |
| 8000 | } ## end sub LineInfo |
| 8001 | |
| 8002 | =head1 COMMAND SUPPORT ROUTINES |
| 8003 | |
| 8004 | These subroutines provide functionality for various commands. |
| 8005 | |
| 8006 | =head2 C<list_modules> |
| 8007 | |
| 8008 | For the C<M> command: list modules loaded and their versions. |
| 8009 | Essentially just runs through the keys in %INC, picks each package's |
| 8010 | C<$VERSION> variable, gets the file name, and formats the information |
| 8011 | for output. |
| 8012 | |
| 8013 | =cut |
| 8014 | |
| 8015 | sub list_modules { # versions |
| 8016 | my %version; |
| 8017 | my $file; |
| 8018 | |
| 8019 | # keys are the "as-loaded" name, values are the fully-qualified path |
| 8020 | # to the file itself. |
| 8021 | for ( keys %INC ) { |
| 8022 | $file = $_; # get the module name |
| 8023 | s,\.p[lm]$,,i; # remove '.pl' or '.pm' |
| 8024 | s,/,::,g; # change '/' to '::' |
| 8025 | s/^perl5db$/DB/; # Special case: debugger |
| 8026 | # moves to package DB |
| 8027 | s/^Term::ReadLine::readline$/readline/; # simplify readline |
| 8028 | |
| 8029 | # If the package has a $VERSION package global (as all good packages |
| 8030 | # should!) decode it and save as partial message. |
| 8031 | my $pkg_version = do { no strict 'refs'; ${ $_ . '::VERSION' } }; |
| 8032 | if ( defined $pkg_version ) { |
| 8033 | $version{$file} = "$pkg_version from "; |
| 8034 | } |
| 8035 | |
| 8036 | # Finish up the message with the file the package came from. |
| 8037 | $version{$file} .= $INC{$file}; |
| 8038 | } ## end for (keys %INC) |
| 8039 | |
| 8040 | # Hey, dumpit() formats a hash nicely, so why not use it? |
| 8041 | dumpit( $OUT, \%version ); |
| 8042 | } ## end sub list_modules |
| 8043 | |
| 8044 | =head2 C<sethelp()> |
| 8045 | |
| 8046 | Sets up the monster string used to format and print the help. |
| 8047 | |
| 8048 | =head3 HELP MESSAGE FORMAT |
| 8049 | |
| 8050 | The help message is a peculiar format unto itself; it mixes C<pod> I<ornaments> |
| 8051 | (C<< B<> >> C<< I<> >>) with tabs to come up with a format that's fairly |
| 8052 | easy to parse and portable, but which still allows the help to be a little |
| 8053 | nicer than just plain text. |
| 8054 | |
| 8055 | Essentially, you define the command name (usually marked up with C<< B<> >> |
| 8056 | and C<< I<> >>), followed by a tab, and then the descriptive text, ending in a |
| 8057 | newline. The descriptive text can also be marked up in the same way. If you |
| 8058 | need to continue the descriptive text to another line, start that line with |
| 8059 | just tabs and then enter the marked-up text. |
| 8060 | |
| 8061 | If you are modifying the help text, I<be careful>. The help-string parser is |
| 8062 | not very sophisticated, and if you don't follow these rules it will mangle the |
| 8063 | help beyond hope until you fix the string. |
| 8064 | |
| 8065 | =cut |
| 8066 | |
| 8067 | use vars qw($pre580_help); |
| 8068 | use vars qw($pre580_summary); |
| 8069 | |
| 8070 | sub sethelp { |
| 8071 | |
| 8072 | # XXX: make sure there are tabs between the command and explanation, |
| 8073 | # or print_help will screw up your formatting if you have |
| 8074 | # eeevil ornaments enabled. This is an insane mess. |
| 8075 | |
| 8076 | $help = " |
| 8077 | Help is currently only available for the new 5.8 command set. |
| 8078 | No help is available for the old command set. |
| 8079 | We assume you know what you're doing if you switch to it. |
| 8080 | |
| 8081 | B<T> Stack trace. |
| 8082 | B<s> [I<expr>] Single step [in I<expr>]. |
| 8083 | B<n> [I<expr>] Next, steps over subroutine calls [in I<expr>]. |
| 8084 | <B<CR>> Repeat last B<n> or B<s> command. |
| 8085 | B<r> Return from current subroutine. |
| 8086 | B<c> [I<line>|I<sub>] Continue; optionally inserts a one-time-only breakpoint |
| 8087 | at the specified position. |
| 8088 | B<l> I<min>B<+>I<incr> List I<incr>+1 lines starting at I<min>. |
| 8089 | B<l> I<min>B<->I<max> List lines I<min> through I<max>. |
| 8090 | B<l> I<line> List single I<line>. |
| 8091 | B<l> I<subname> List first window of lines from subroutine. |
| 8092 | B<l> I<\$var> List first window of lines from subroutine referenced by I<\$var>. |
| 8093 | B<l> List next window of lines. |
| 8094 | B<-> List previous window of lines. |
| 8095 | B<v> [I<line>] View window around I<line>. |
| 8096 | B<.> Return to the executed line. |
| 8097 | B<f> I<filename> Switch to viewing I<filename>. File must be already loaded. |
| 8098 | I<filename> may be either the full name of the file, or a regular |
| 8099 | expression matching the full file name: |
| 8100 | B<f> I</home/me/foo.pl> and B<f> I<oo\\.> may access the same file. |
| 8101 | Evals (with saved bodies) are considered to be filenames: |
| 8102 | B<f> I<(eval 7)> and B<f> I<eval 7\\b> access the body of the 7th eval |
| 8103 | (in the order of execution). |
| 8104 | B</>I<pattern>B</> Search forwards for I<pattern>; final B</> is optional. |
| 8105 | B<?>I<pattern>B<?> Search backwards for I<pattern>; final B<?> is optional. |
| 8106 | B<L> [I<a|b|w>] List actions and or breakpoints and or watch-expressions. |
| 8107 | B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>. |
| 8108 | B<t> [I<n>] Toggle trace mode (to max I<n> levels below current stack depth). |
| 8109 | B<t> [I<n>] I<expr> Trace through execution of I<expr>. |
| 8110 | B<b> Sets breakpoint on current line) |
| 8111 | B<b> [I<line>] [I<condition>] |
| 8112 | Set breakpoint; I<line> defaults to the current execution line; |
| 8113 | I<condition> breaks if it evaluates to true, defaults to '1'. |
| 8114 | B<b> I<subname> [I<condition>] |
| 8115 | Set breakpoint at first line of subroutine. |
| 8116 | B<b> I<\$var> Set breakpoint at first line of subroutine referenced by I<\$var>. |
| 8117 | B<b> B<load> I<filename> Set breakpoint on 'require'ing the given file. |
| 8118 | B<b> B<postpone> I<subname> [I<condition>] |
| 8119 | Set breakpoint at first line of subroutine after |
| 8120 | it is compiled. |
| 8121 | B<b> B<compile> I<subname> |
| 8122 | Stop after the subroutine is compiled. |
| 8123 | B<B> [I<line>] Delete the breakpoint for I<line>. |
| 8124 | B<B> I<*> Delete all breakpoints. |
| 8125 | B<a> [I<line>] I<command> |
| 8126 | Set an action to be done before the I<line> is executed; |
| 8127 | I<line> defaults to the current execution line. |
| 8128 | Sequence is: check for breakpoint/watchpoint, print line |
| 8129 | if necessary, do action, prompt user if necessary, |
| 8130 | execute line. |
| 8131 | B<a> Does nothing |
| 8132 | B<A> [I<line>] Delete the action for I<line>. |
| 8133 | B<A> I<*> Delete all actions. |
| 8134 | B<w> I<expr> Add a global watch-expression. |
| 8135 | B<w> Does nothing |
| 8136 | B<W> I<expr> Delete a global watch-expression. |
| 8137 | B<W> I<*> Delete all watch-expressions. |
| 8138 | B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current). |
| 8139 | Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps. |
| 8140 | B<X> [I<vars>] Same as \"B<V> I<currentpackage> [I<vars>]\". |
| 8141 | B<x> I<expr> Evals expression in list context, dumps the result. |
| 8142 | B<m> I<expr> Evals expression in list context, prints methods callable |
| 8143 | on the first element of the result. |
| 8144 | B<m> I<class> Prints methods callable via the given class. |
| 8145 | B<M> Show versions of loaded modules. |
| 8146 | B<i> I<class> Prints nested parents of given class. |
| 8147 | B<e> Display current thread id. |
| 8148 | B<E> Display all thread ids the current one will be identified: <n>. |
| 8149 | B<y> [I<n> [I<Vars>]] List lexicals in higher scope <n>. Vars same as B<V>. |
| 8150 | |
| 8151 | B<<> ? List Perl commands to run before each prompt. |
| 8152 | B<<> I<expr> Define Perl command to run before each prompt. |
| 8153 | B<<<> I<expr> Add to the list of Perl commands to run before each prompt. |
| 8154 | B<< *> Delete the list of perl commands to run before each prompt. |
| 8155 | B<>> ? List Perl commands to run after each prompt. |
| 8156 | B<>> I<expr> Define Perl command to run after each prompt. |
| 8157 | B<>>B<>> I<expr> Add to the list of Perl commands to run after each prompt. |
| 8158 | B<>>B< *> Delete the list of Perl commands to run after each prompt. |
| 8159 | B<{> I<db_command> Define debugger command to run before each prompt. |
| 8160 | B<{> ? List debugger commands to run before each prompt. |
| 8161 | B<{{> I<db_command> Add to the list of debugger commands to run before each prompt. |
| 8162 | B<{ *> Delete the list of debugger commands to run before each prompt. |
| 8163 | B<$prc> I<number> Redo a previous command (default previous command). |
| 8164 | B<$prc> I<-number> Redo number'th-to-last command. |
| 8165 | B<$prc> I<pattern> Redo last command that started with I<pattern>. |
| 8166 | See 'B<O> I<recallCommand>' too. |
| 8167 | B<$psh$psh> I<cmd> Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)" |
| 8168 | . ( |
| 8169 | $rc eq $sh |
| 8170 | ? "" |
| 8171 | : " |
| 8172 | B<$psh> [I<cmd>] Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." |
| 8173 | ) . " |
| 8174 | See 'B<O> I<shellBang>' too. |
| 8175 | B<source> I<file> Execute I<file> containing debugger commands (may nest). |
| 8176 | B<save> I<file> Save current debugger session (actual history) to I<file>. |
| 8177 | B<rerun> Rerun session to current position. |
| 8178 | B<rerun> I<n> Rerun session to numbered command. |
| 8179 | B<rerun> I<-n> Rerun session to number'th-to-last command. |
| 8180 | B<H> I<-number> Display last number commands (default all). |
| 8181 | B<H> I<*> Delete complete history. |
| 8182 | B<p> I<expr> Same as \"I<print {DB::OUT} expr>\" in current package. |
| 8183 | B<|>I<dbcmd> Run debugger command, piping DB::OUT to current pager. |
| 8184 | B<||>I<dbcmd> Same as B<|>I<dbcmd> but DB::OUT is temporarily select()ed as well. |
| 8185 | B<\=> [I<alias> I<value>] Define a command alias, or list current aliases. |
| 8186 | I<command> Execute as a perl statement in current package. |
| 8187 | B<R> Poor man's restart of the debugger, some of debugger state |
| 8188 | and command-line options may be lost. |
| 8189 | Currently the following settings are preserved: |
| 8190 | history, breakpoints and actions, debugger B<O>ptions |
| 8191 | and the following command-line options: I<-w>, I<-I>, I<-e>. |
| 8192 | |
| 8193 | B<o> [I<opt>] ... Set boolean option to true |
| 8194 | B<o> [I<opt>B<?>] Query options |
| 8195 | B<o> [I<opt>B<=>I<val>] [I<opt>=B<\">I<val>B<\">] ... |
| 8196 | Set options. Use quotes if spaces in value. |
| 8197 | I<recallCommand>, I<ShellBang> chars used to recall command or spawn shell; |
| 8198 | I<pager> program for output of \"|cmd\"; |
| 8199 | I<tkRunning> run Tk while prompting (with ReadLine); |
| 8200 | I<signalLevel> I<warnLevel> I<dieLevel> level of verbosity; |
| 8201 | I<inhibit_exit> Allows stepping off the end of the script. |
| 8202 | I<ImmediateStop> Debugger should stop as early as possible. |
| 8203 | I<RemotePort> Remote hostname:port for remote debugging |
| 8204 | The following options affect what happens with B<V>, B<X>, and B<x> commands: |
| 8205 | I<arrayDepth>, I<hashDepth> print only first N elements ('' for all); |
| 8206 | I<compactDump>, I<veryCompact> change style of array and hash dump; |
| 8207 | I<globPrint> whether to print contents of globs; |
| 8208 | I<DumpDBFiles> dump arrays holding debugged files; |
| 8209 | I<DumpPackages> dump symbol tables of packages; |
| 8210 | I<DumpReused> dump contents of \"reused\" addresses; |
| 8211 | I<quote>, I<HighBit>, I<undefPrint> change style of string dump; |
| 8212 | I<bareStringify> Do not print the overload-stringified value; |
| 8213 | Other options include: |
| 8214 | I<PrintRet> affects printing of return value after B<r> command, |
| 8215 | I<frame> affects printing messages on subroutine entry/exit. |
| 8216 | I<AutoTrace> affects printing messages on possible breaking points. |
| 8217 | I<maxTraceLen> gives max length of evals/args listed in stack trace. |
| 8218 | I<ornaments> affects screen appearance of the command line. |
| 8219 | I<CreateTTY> bits control attempts to create a new TTY on events: |
| 8220 | 1: on fork() 2: debugger is started inside debugger |
| 8221 | 4: on startup |
| 8222 | During startup options are initialized from \$ENV{PERLDB_OPTS}. |
| 8223 | You can put additional initialization options I<TTY>, I<noTTY>, |
| 8224 | I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use |
| 8225 | B<R> after you set them). |
| 8226 | |
| 8227 | B<q> or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction. |
| 8228 | B<h> Summary of debugger commands. |
| 8229 | B<h> [I<db_command>] Get help [on a specific debugger command], enter B<|h> to page. |
| 8230 | B<h h> Long help for debugger commands |
| 8231 | B<$doccmd> I<manpage> Runs the external doc viewer B<$doccmd> command on the |
| 8232 | named Perl I<manpage>, or on B<$doccmd> itself if omitted. |
| 8233 | Set B<\$DB::doccmd> to change viewer. |
| 8234 | |
| 8235 | Type '|h h' for a paged display if this was too hard to read. |
| 8236 | |
| 8237 | "; # Fix balance of vi % matching: }}}} |
| 8238 | |
| 8239 | # note: tabs in the following section are not-so-helpful |
| 8240 | $summary = <<"END_SUM"; |
| 8241 | I<List/search source lines:> I<Control script execution:> |
| 8242 | B<l> [I<ln>|I<sub>] List source code B<T> Stack trace |
| 8243 | B<-> or B<.> List previous/current line B<s> [I<expr>] Single step [in expr] |
| 8244 | B<v> [I<line>] View around line B<n> [I<expr>] Next, steps over subs |
| 8245 | B<f> I<filename> View source in file <B<CR>/B<Enter>> Repeat last B<n> or B<s> |
| 8246 | B</>I<pattern>B</> B<?>I<patt>B<?> Search forw/backw B<r> Return from subroutine |
| 8247 | B<M> Show module versions B<c> [I<ln>|I<sub>] Continue until position |
| 8248 | I<Debugger controls:> B<L> List break/watch/actions |
| 8249 | B<o> [...] Set debugger options B<t> [I<n>] [I<expr>] Toggle trace [max depth] ][trace expr] |
| 8250 | B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I<cmd>] Do pre/post-prompt B<b> [I<ln>|I<event>|I<sub>] [I<cnd>] Set breakpoint |
| 8251 | B<$prc> [I<N>|I<pat>] Redo a previous command B<B> I<ln|*> Delete a/all breakpoints |
| 8252 | B<H> [I<-num>] Display last num commands B<a> [I<ln>] I<cmd> Do cmd before line |
| 8253 | B<=> [I<a> I<val>] Define/list an alias B<A> I<ln|*> Delete a/all actions |
| 8254 | B<h> [I<db_cmd>] Get help on command B<w> I<expr> Add a watch expression |
| 8255 | B<h h> Complete help page B<W> I<expr|*> Delete a/all watch exprs |
| 8256 | B<|>[B<|>]I<db_cmd> Send output to pager B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess |
| 8257 | B<q> or B<^D> Quit B<R> Attempt a restart |
| 8258 | I<Data Examination:> B<expr> Execute perl code, also see: B<s>,B<n>,B<t> I<expr> |
| 8259 | B<x>|B<m> I<expr> Evals expr in list context, dumps the result or lists methods. |
| 8260 | B<p> I<expr> Print expression (uses script's current package). |
| 8261 | B<S> [[B<!>]I<pat>] List subroutine names [not] matching pattern |
| 8262 | B<V> [I<Pk> [I<Vars>]] List Variables in Package. Vars can be ~pattern or !pattern. |
| 8263 | B<X> [I<Vars>] Same as \"B<V> I<current_package> [I<Vars>]\". B<i> I<class> inheritance tree. |
| 8264 | B<y> [I<n> [I<Vars>]] List lexicals in higher scope <n>. Vars same as B<V>. |
| 8265 | B<e> Display thread id B<E> Display all thread ids. |
| 8266 | For more help, type B<h> I<cmd_letter>, or run B<$doccmd perldebug> for all docs. |
| 8267 | END_SUM |
| 8268 | |
| 8269 | # ')}}; # Fix balance of vi % matching |
| 8270 | |
| 8271 | # and this is really numb... |
| 8272 | $pre580_help = " |
| 8273 | B<T> Stack trace. |
| 8274 | B<s> [I<expr>] Single step [in I<expr>]. |
| 8275 | B<n> [I<expr>] Next, steps over subroutine calls [in I<expr>]. |
| 8276 | B<CR>> Repeat last B<n> or B<s> command. |
| 8277 | B<r> Return from current subroutine. |
| 8278 | B<c> [I<line>|I<sub>] Continue; optionally inserts a one-time-only breakpoint |
| 8279 | at the specified position. |
| 8280 | B<l> I<min>B<+>I<incr> List I<incr>+1 lines starting at I<min>. |
| 8281 | B<l> I<min>B<->I<max> List lines I<min> through I<max>. |
| 8282 | B<l> I<line> List single I<line>. |
| 8283 | B<l> I<subname> List first window of lines from subroutine. |
| 8284 | B<l> I<\$var> List first window of lines from subroutine referenced by I<\$var>. |
| 8285 | B<l> List next window of lines. |
| 8286 | B<-> List previous window of lines. |
| 8287 | B<w> [I<line>] List window around I<line>. |
| 8288 | B<.> Return to the executed line. |
| 8289 | B<f> I<filename> Switch to viewing I<filename>. File must be already loaded. |
| 8290 | I<filename> may be either the full name of the file, or a regular |
| 8291 | expression matching the full file name: |
| 8292 | B<f> I</home/me/foo.pl> and B<f> I<oo\\.> may access the same file. |
| 8293 | Evals (with saved bodies) are considered to be filenames: |
| 8294 | B<f> I<(eval 7)> and B<f> I<eval 7\\b> access the body of the 7th eval |
| 8295 | (in the order of execution). |
| 8296 | B</>I<pattern>B</> Search forwards for I<pattern>; final B</> is optional. |
| 8297 | B<?>I<pattern>B<?> Search backwards for I<pattern>; final B<?> is optional. |
| 8298 | B<L> List all breakpoints and actions. |
| 8299 | B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>. |
| 8300 | B<t> [I<n>] Toggle trace mode (to max I<n> levels below current stack depth) . |
| 8301 | B<t> [I<n>] I<expr> Trace through execution of I<expr>. |
| 8302 | B<b> [I<line>] [I<condition>] |
| 8303 | Set breakpoint; I<line> defaults to the current execution line; |
| 8304 | I<condition> breaks if it evaluates to true, defaults to '1'. |
| 8305 | B<b> I<subname> [I<condition>] |
| 8306 | Set breakpoint at first line of subroutine. |
| 8307 | B<b> I<\$var> Set breakpoint at first line of subroutine referenced by I<\$var>. |
| 8308 | B<b> B<load> I<filename> Set breakpoint on 'require'ing the given file. |
| 8309 | B<b> B<postpone> I<subname> [I<condition>] |
| 8310 | Set breakpoint at first line of subroutine after |
| 8311 | it is compiled. |
| 8312 | B<b> B<compile> I<subname> |
| 8313 | Stop after the subroutine is compiled. |
| 8314 | B<d> [I<line>] Delete the breakpoint for I<line>. |
| 8315 | B<D> Delete all breakpoints. |
| 8316 | B<a> [I<line>] I<command> |
| 8317 | Set an action to be done before the I<line> is executed; |
| 8318 | I<line> defaults to the current execution line. |
| 8319 | Sequence is: check for breakpoint/watchpoint, print line |
| 8320 | if necessary, do action, prompt user if necessary, |
| 8321 | execute line. |
| 8322 | B<a> [I<line>] Delete the action for I<line>. |
| 8323 | B<A> Delete all actions. |
| 8324 | B<W> I<expr> Add a global watch-expression. |
| 8325 | B<W> Delete all watch-expressions. |
| 8326 | B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current). |
| 8327 | Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps. |
| 8328 | B<X> [I<vars>] Same as \"B<V> I<currentpackage> [I<vars>]\". |
| 8329 | B<x> I<expr> Evals expression in list context, dumps the result. |
| 8330 | B<m> I<expr> Evals expression in list context, prints methods callable |
| 8331 | on the first element of the result. |
| 8332 | B<m> I<class> Prints methods callable via the given class. |
| 8333 | |
| 8334 | B<<> ? List Perl commands to run before each prompt. |
| 8335 | B<<> I<expr> Define Perl command to run before each prompt. |
| 8336 | B<<<> I<expr> Add to the list of Perl commands to run before each prompt. |
| 8337 | B<>> ? List Perl commands to run after each prompt. |
| 8338 | B<>> I<expr> Define Perl command to run after each prompt. |
| 8339 | B<>>B<>> I<expr> Add to the list of Perl commands to run after each prompt. |
| 8340 | B<{> I<db_command> Define debugger command to run before each prompt. |
| 8341 | B<{> ? List debugger commands to run before each prompt. |
| 8342 | B<{{> I<db_command> Add to the list of debugger commands to run before each prompt. |
| 8343 | B<$prc> I<number> Redo a previous command (default previous command). |
| 8344 | B<$prc> I<-number> Redo number'th-to-last command. |
| 8345 | B<$prc> I<pattern> Redo last command that started with I<pattern>. |
| 8346 | See 'B<O> I<recallCommand>' too. |
| 8347 | B<$psh$psh> I<cmd> Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)" |
| 8348 | . ( |
| 8349 | $rc eq $sh |
| 8350 | ? "" |
| 8351 | : " |
| 8352 | B<$psh> [I<cmd>] Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." |
| 8353 | ) . " |
| 8354 | See 'B<O> I<shellBang>' too. |
| 8355 | B<source> I<file> Execute I<file> containing debugger commands (may nest). |
| 8356 | B<H> I<-number> Display last number commands (default all). |
| 8357 | B<p> I<expr> Same as \"I<print {DB::OUT} expr>\" in current package. |
| 8358 | B<|>I<dbcmd> Run debugger command, piping DB::OUT to current pager. |
| 8359 | B<||>I<dbcmd> Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well. |
| 8360 | B<\=> [I<alias> I<value>] Define a command alias, or list current aliases. |
| 8361 | I<command> Execute as a perl statement in current package. |
| 8362 | B<v> Show versions of loaded modules. |
| 8363 | B<R> Poor man's restart of the debugger, some of debugger state |
| 8364 | and command-line options may be lost. |
| 8365 | Currently the following settings are preserved: |
| 8366 | history, breakpoints and actions, debugger B<O>ptions |
| 8367 | and the following command-line options: I<-w>, I<-I>, I<-e>. |
| 8368 | |
| 8369 | B<O> [I<opt>] ... Set boolean option to true |
| 8370 | B<O> [I<opt>B<?>] Query options |
| 8371 | B<O> [I<opt>B<=>I<val>] [I<opt>=B<\">I<val>B<\">] ... |
| 8372 | Set options. Use quotes if spaces in value. |
| 8373 | I<recallCommand>, I<ShellBang> chars used to recall command or spawn shell; |
| 8374 | I<pager> program for output of \"|cmd\"; |
| 8375 | I<tkRunning> run Tk while prompting (with ReadLine); |
| 8376 | I<signalLevel> I<warnLevel> I<dieLevel> level of verbosity; |
| 8377 | I<inhibit_exit> Allows stepping off the end of the script. |
| 8378 | I<ImmediateStop> Debugger should stop as early as possible. |
| 8379 | I<RemotePort> Remote hostname:port for remote debugging |
| 8380 | The following options affect what happens with B<V>, B<X>, and B<x> commands: |
| 8381 | I<arrayDepth>, I<hashDepth> print only first N elements ('' for all); |
| 8382 | I<compactDump>, I<veryCompact> change style of array and hash dump; |
| 8383 | I<globPrint> whether to print contents of globs; |
| 8384 | I<DumpDBFiles> dump arrays holding debugged files; |
| 8385 | I<DumpPackages> dump symbol tables of packages; |
| 8386 | I<DumpReused> dump contents of \"reused\" addresses; |
| 8387 | I<quote>, I<HighBit>, I<undefPrint> change style of string dump; |
| 8388 | I<bareStringify> Do not print the overload-stringified value; |
| 8389 | Other options include: |
| 8390 | I<PrintRet> affects printing of return value after B<r> command, |
| 8391 | I<frame> affects printing messages on subroutine entry/exit. |
| 8392 | I<AutoTrace> affects printing messages on possible breaking points. |
| 8393 | I<maxTraceLen> gives max length of evals/args listed in stack trace. |
| 8394 | I<ornaments> affects screen appearance of the command line. |
| 8395 | I<CreateTTY> bits control attempts to create a new TTY on events: |
| 8396 | 1: on fork() 2: debugger is started inside debugger |
| 8397 | 4: on startup |
| 8398 | During startup options are initialized from \$ENV{PERLDB_OPTS}. |
| 8399 | You can put additional initialization options I<TTY>, I<noTTY>, |
| 8400 | I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use |
| 8401 | B<R> after you set them). |
| 8402 | |
| 8403 | B<q> or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction. |
| 8404 | B<h> [I<db_command>] Get help [on a specific debugger command], enter B<|h> to page. |
| 8405 | B<h h> Summary of debugger commands. |
| 8406 | B<$doccmd> I<manpage> Runs the external doc viewer B<$doccmd> command on the |
| 8407 | named Perl I<manpage>, or on B<$doccmd> itself if omitted. |
| 8408 | Set B<\$DB::doccmd> to change viewer. |
| 8409 | |
| 8410 | Type '|h' for a paged display if this was too hard to read. |
| 8411 | |
| 8412 | "; # Fix balance of vi % matching: }}}} |
| 8413 | |
| 8414 | # note: tabs in the following section are not-so-helpful |
| 8415 | $pre580_summary = <<"END_SUM"; |
| 8416 | I<List/search source lines:> I<Control script execution:> |
| 8417 | B<l> [I<ln>|I<sub>] List source code B<T> Stack trace |
| 8418 | B<-> or B<.> List previous/current line B<s> [I<expr>] Single step [in expr] |
| 8419 | B<w> [I<line>] List around line B<n> [I<expr>] Next, steps over subs |
| 8420 | B<f> I<filename> View source in file <B<CR>/B<Enter>> Repeat last B<n> or B<s> |
| 8421 | B</>I<pattern>B</> B<?>I<patt>B<?> Search forw/backw B<r> Return from subroutine |
| 8422 | B<v> Show versions of modules B<c> [I<ln>|I<sub>] Continue until position |
| 8423 | I<Debugger controls:> B<L> List break/watch/actions |
| 8424 | B<O> [...] Set debugger options B<t> [I<expr>] Toggle trace [trace expr] |
| 8425 | B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I<cmd>] Do pre/post-prompt B<b> [I<ln>|I<event>|I<sub>] [I<cnd>] Set breakpoint |
| 8426 | B<$prc> [I<N>|I<pat>] Redo a previous command B<d> [I<ln>] or B<D> Delete a/all breakpoints |
| 8427 | B<H> [I<-num>] Display last num commands B<a> [I<ln>] I<cmd> Do cmd before line |
| 8428 | B<=> [I<a> I<val>] Define/list an alias B<W> I<expr> Add a watch expression |
| 8429 | B<h> [I<db_cmd>] Get help on command B<A> or B<W> Delete all actions/watch |
| 8430 | B<|>[B<|>]I<db_cmd> Send output to pager B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess |
| 8431 | B<q> or B<^D> Quit B<R> Attempt a restart |
| 8432 | I<Data Examination:> B<expr> Execute perl code, also see: B<s>,B<n>,B<t> I<expr> |
| 8433 | B<x>|B<m> I<expr> Evals expr in list context, dumps the result or lists methods. |
| 8434 | B<p> I<expr> Print expression (uses script's current package). |
| 8435 | B<S> [[B<!>]I<pat>] List subroutine names [not] matching pattern |
| 8436 | B<V> [I<Pk> [I<Vars>]] List Variables in Package. Vars can be ~pattern or !pattern. |
| 8437 | B<X> [I<Vars>] Same as \"B<V> I<current_package> [I<Vars>]\". |
| 8438 | B<y> [I<n> [I<Vars>]] List lexicals in higher scope <n>. Vars same as B<V>. |
| 8439 | For more help, type B<h> I<cmd_letter>, or run B<$doccmd perldebug> for all docs. |
| 8440 | END_SUM |
| 8441 | |
| 8442 | # ')}}; # Fix balance of vi % matching |
| 8443 | |
| 8444 | } ## end sub sethelp |
| 8445 | |
| 8446 | =head2 C<print_help()> |
| 8447 | |
| 8448 | Most of what C<print_help> does is just text formatting. It finds the |
| 8449 | C<B> and C<I> ornaments, cleans them off, and substitutes the proper |
| 8450 | terminal control characters to simulate them (courtesy of |
| 8451 | C<Term::ReadLine::TermCap>). |
| 8452 | |
| 8453 | =cut |
| 8454 | |
| 8455 | sub print_help { |
| 8456 | my $help_str = shift; |
| 8457 | |
| 8458 | # Restore proper alignment destroyed by eeevil I<> and B<> |
| 8459 | # ornaments: A pox on both their houses! |
| 8460 | # |
| 8461 | # A help command will have everything up to and including |
| 8462 | # the first tab sequence padded into a field 16 (or if indented 20) |
| 8463 | # wide. If it's wider than that, an extra space will be added. |
| 8464 | $help_str =~ s{ |
| 8465 | ^ # only matters at start of line |
| 8466 | ( \ {4} | \t )* # some subcommands are indented |
| 8467 | ( < ? # so <CR> works |
| 8468 | [BI] < [^\t\n] + ) # find an eeevil ornament |
| 8469 | ( \t+ ) # original separation, discarded |
| 8470 | ( .* ) # this will now start (no earlier) than |
| 8471 | # column 16 |
| 8472 | } { |
| 8473 | my($leadwhite, $command, $midwhite, $text) = ($1, $2, $3, $4); |
| 8474 | my $clean = $command; |
| 8475 | $clean =~ s/[BI]<([^>]*)>/$1/g; |
| 8476 | |
| 8477 | # replace with this whole string: |
| 8478 | ($leadwhite ? " " x 4 : "") |
| 8479 | . $command |
| 8480 | . ((" " x (16 + ($leadwhite ? 4 : 0) - length($clean))) || " ") |
| 8481 | . $text; |
| 8482 | |
| 8483 | }mgex; |
| 8484 | |
| 8485 | $help_str =~ s{ # handle bold ornaments |
| 8486 | B < ( [^>] + | > ) > |
| 8487 | } { |
| 8488 | $Term::ReadLine::TermCap::rl_term_set[2] |
| 8489 | . $1 |
| 8490 | . $Term::ReadLine::TermCap::rl_term_set[3] |
| 8491 | }gex; |
| 8492 | |
| 8493 | $help_str =~ s{ # handle italic ornaments |
| 8494 | I < ( [^>] + | > ) > |
| 8495 | } { |
| 8496 | $Term::ReadLine::TermCap::rl_term_set[0] |
| 8497 | . $1 |
| 8498 | . $Term::ReadLine::TermCap::rl_term_set[1] |
| 8499 | }gex; |
| 8500 | |
| 8501 | local $\ = ''; |
| 8502 | print {$OUT} $help_str; |
| 8503 | |
| 8504 | return; |
| 8505 | } ## end sub print_help |
| 8506 | |
| 8507 | =head2 C<fix_less> |
| 8508 | |
| 8509 | This routine does a lot of gyrations to be sure that the pager is C<less>. |
| 8510 | It checks for C<less> masquerading as C<more> and records the result in |
| 8511 | C<$fixed_less> so we don't have to go through doing the stats again. |
| 8512 | |
| 8513 | =cut |
| 8514 | |
| 8515 | use vars qw($fixed_less); |
| 8516 | |
| 8517 | sub _calc_is_less { |
| 8518 | if ($pager =~ /\bless\b/) |
| 8519 | { |
| 8520 | return 1; |
| 8521 | } |
| 8522 | elsif ($pager =~ /\bmore\b/) |
| 8523 | { |
| 8524 | # Nope, set to more. See what's out there. |
| 8525 | my @st_more = stat('/usr/bin/more'); |
| 8526 | my @st_less = stat('/usr/bin/less'); |
| 8527 | |
| 8528 | # is it really less, pretending to be more? |
| 8529 | return ( |
| 8530 | @st_more |
| 8531 | && @st_less |
| 8532 | && $st_more[0] == $st_less[0] |
| 8533 | && $st_more[1] == $st_less[1] |
| 8534 | ); |
| 8535 | } |
| 8536 | else { |
| 8537 | return; |
| 8538 | } |
| 8539 | } |
| 8540 | |
| 8541 | sub fix_less { |
| 8542 | |
| 8543 | # We already know if this is set. |
| 8544 | return if $fixed_less; |
| 8545 | |
| 8546 | # changes environment! |
| 8547 | # 'r' added so we don't do (slow) stats again. |
| 8548 | $fixed_less = 1 if _calc_is_less(); |
| 8549 | |
| 8550 | return; |
| 8551 | } ## end sub fix_less |
| 8552 | |
| 8553 | =head1 DIE AND WARN MANAGEMENT |
| 8554 | |
| 8555 | =head2 C<diesignal> |
| 8556 | |
| 8557 | C<diesignal> is a just-drop-dead C<die> handler. It's most useful when trying |
| 8558 | to debug a debugger problem. |
| 8559 | |
| 8560 | It does its best to report the error that occurred, and then forces the |
| 8561 | program, debugger, and everything to die. |
| 8562 | |
| 8563 | =cut |
| 8564 | |
| 8565 | sub diesignal { |
| 8566 | |
| 8567 | # No entry/exit messages. |
| 8568 | local $frame = 0; |
| 8569 | |
| 8570 | # No return value prints. |
| 8571 | local $doret = -2; |
| 8572 | |
| 8573 | # set the abort signal handling to the default (just terminate). |
| 8574 | $SIG{'ABRT'} = 'DEFAULT'; |
| 8575 | |
| 8576 | # If we enter the signal handler recursively, kill myself with an |
| 8577 | # abort signal (so we just terminate). |
| 8578 | kill 'ABRT', $$ if $panic++; |
| 8579 | |
| 8580 | # If we can show detailed info, do so. |
| 8581 | if ( defined &Carp::longmess ) { |
| 8582 | |
| 8583 | # Don't recursively enter the warn handler, since we're carping. |
| 8584 | local $SIG{__WARN__} = ''; |
| 8585 | |
| 8586 | # Skip two levels before reporting traceback: we're skipping |
| 8587 | # mydie and confess. |
| 8588 | local $Carp::CarpLevel = 2; # mydie + confess |
| 8589 | |
| 8590 | # Tell us all about it. |
| 8591 | _db_warn( Carp::longmess("Signal @_") ); |
| 8592 | } |
| 8593 | |
| 8594 | # No Carp. Tell us about the signal as best we can. |
| 8595 | else { |
| 8596 | local $\ = ''; |
| 8597 | print $DB::OUT "Got signal @_\n"; |
| 8598 | } |
| 8599 | |
| 8600 | # Drop dead. |
| 8601 | kill 'ABRT', $$; |
| 8602 | } ## end sub diesignal |
| 8603 | |
| 8604 | =head2 C<dbwarn> |
| 8605 | |
| 8606 | The debugger's own default C<$SIG{__WARN__}> handler. We load C<Carp> to |
| 8607 | be able to get a stack trace, and output the warning message vi C<DB::dbwarn()>. |
| 8608 | |
| 8609 | =cut |
| 8610 | |
| 8611 | sub dbwarn { |
| 8612 | |
| 8613 | # No entry/exit trace. |
| 8614 | local $frame = 0; |
| 8615 | |
| 8616 | # No return value printing. |
| 8617 | local $doret = -2; |
| 8618 | |
| 8619 | # Turn off warn and die handling to prevent recursive entries to this |
| 8620 | # routine. |
| 8621 | local $SIG{__WARN__} = ''; |
| 8622 | local $SIG{__DIE__} = ''; |
| 8623 | |
| 8624 | # Load Carp if we can. If $^S is false (current thing being compiled isn't |
| 8625 | # done yet), we may not be able to do a require. |
| 8626 | eval { require Carp } |
| 8627 | if defined $^S; # If error/warning during compilation, |
| 8628 | # require may be broken. |
| 8629 | |
| 8630 | # Use the core warn() unless Carp loaded OK. |
| 8631 | CORE::warn( @_, |
| 8632 | "\nCannot print stack trace, load with -MCarp option to see stack" ), |
| 8633 | return |
| 8634 | unless defined &Carp::longmess; |
| 8635 | |
| 8636 | # Save the current values of $single and $trace, and then turn them off. |
| 8637 | my ( $mysingle, $mytrace ) = ( $single, $trace ); |
| 8638 | $single = 0; |
| 8639 | $trace = 0; |
| 8640 | |
| 8641 | # We can call Carp::longmess without its being "debugged" (which we |
| 8642 | # don't want - we just want to use it!). Capture this for later. |
| 8643 | my $mess = Carp::longmess(@_); |
| 8644 | |
| 8645 | # Restore $single and $trace to their original values. |
| 8646 | ( $single, $trace ) = ( $mysingle, $mytrace ); |
| 8647 | |
| 8648 | # Use the debugger's own special way of printing warnings to print |
| 8649 | # the stack trace message. |
| 8650 | _db_warn($mess); |
| 8651 | } ## end sub dbwarn |
| 8652 | |
| 8653 | =head2 C<dbdie> |
| 8654 | |
| 8655 | The debugger's own C<$SIG{__DIE__}> handler. Handles providing a stack trace |
| 8656 | by loading C<Carp> and calling C<Carp::longmess()> to get it. We turn off |
| 8657 | single stepping and tracing during the call to C<Carp::longmess> to avoid |
| 8658 | debugging it - we just want to use it. |
| 8659 | |
| 8660 | If C<dieLevel> is zero, we let the program being debugged handle the |
| 8661 | exceptions. If it's 1, you get backtraces for any exception. If it's 2, |
| 8662 | the debugger takes over all exception handling, printing a backtrace and |
| 8663 | displaying the exception via its C<dbwarn()> routine. |
| 8664 | |
| 8665 | =cut |
| 8666 | |
| 8667 | sub dbdie { |
| 8668 | local $frame = 0; |
| 8669 | local $doret = -2; |
| 8670 | local $SIG{__DIE__} = ''; |
| 8671 | local $SIG{__WARN__} = ''; |
| 8672 | if ( $dieLevel > 2 ) { |
| 8673 | local $SIG{__WARN__} = \&dbwarn; |
| 8674 | _db_warn(@_); # Yell no matter what |
| 8675 | return; |
| 8676 | } |
| 8677 | if ( $dieLevel < 2 ) { |
| 8678 | die @_ if $^S; # in eval propagate |
| 8679 | } |
| 8680 | |
| 8681 | # The code used to check $^S to see if compilation of the current thing |
| 8682 | # hadn't finished. We don't do it anymore, figuring eval is pretty stable. |
| 8683 | eval { require Carp }; |
| 8684 | |
| 8685 | die( @_, |
| 8686 | "\nCannot print stack trace, load with -MCarp option to see stack" ) |
| 8687 | unless defined &Carp::longmess; |
| 8688 | |
| 8689 | # We do not want to debug this chunk (automatic disabling works |
| 8690 | # inside DB::DB, but not in Carp). Save $single and $trace, turn them off, |
| 8691 | # get the stack trace from Carp::longmess (if possible), restore $signal |
| 8692 | # and $trace, and then die with the stack trace. |
| 8693 | my ( $mysingle, $mytrace ) = ( $single, $trace ); |
| 8694 | $single = 0; |
| 8695 | $trace = 0; |
| 8696 | my $mess = "@_"; |
| 8697 | { |
| 8698 | |
| 8699 | package Carp; # Do not include us in the list |
| 8700 | eval { $mess = Carp::longmess(@_); }; |
| 8701 | } |
| 8702 | ( $single, $trace ) = ( $mysingle, $mytrace ); |
| 8703 | die $mess; |
| 8704 | } ## end sub dbdie |
| 8705 | |
| 8706 | =head2 C<warnlevel()> |
| 8707 | |
| 8708 | Set the C<$DB::warnLevel> variable that stores the value of the |
| 8709 | C<warnLevel> option. Calling C<warnLevel()> with a positive value |
| 8710 | results in the debugger taking over all warning handlers. Setting |
| 8711 | C<warnLevel> to zero leaves any warning handlers set up by the program |
| 8712 | being debugged in place. |
| 8713 | |
| 8714 | =cut |
| 8715 | |
| 8716 | sub warnLevel { |
| 8717 | if (@_) { |
| 8718 | my $prevwarn = $SIG{__WARN__} unless $warnLevel; |
| 8719 | $warnLevel = shift; |
| 8720 | if ($warnLevel) { |
| 8721 | $SIG{__WARN__} = \&DB::dbwarn; |
| 8722 | } |
| 8723 | elsif ($prevwarn) { |
| 8724 | $SIG{__WARN__} = $prevwarn; |
| 8725 | } else { |
| 8726 | undef $SIG{__WARN__}; |
| 8727 | } |
| 8728 | } ## end if (@_) |
| 8729 | $warnLevel; |
| 8730 | } ## end sub warnLevel |
| 8731 | |
| 8732 | =head2 C<dielevel> |
| 8733 | |
| 8734 | Similar to C<warnLevel>. Non-zero values for C<dieLevel> result in the |
| 8735 | C<DB::dbdie()> function overriding any other C<die()> handler. Setting it to |
| 8736 | zero lets you use your own C<die()> handler. |
| 8737 | |
| 8738 | =cut |
| 8739 | |
| 8740 | sub dieLevel { |
| 8741 | local $\ = ''; |
| 8742 | if (@_) { |
| 8743 | my $prevdie = $SIG{__DIE__} unless $dieLevel; |
| 8744 | $dieLevel = shift; |
| 8745 | if ($dieLevel) { |
| 8746 | |
| 8747 | # Always set it to dbdie() for non-zero values. |
| 8748 | $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2; |
| 8749 | |
| 8750 | # No longer exists, so don't try to use it. |
| 8751 | #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2; |
| 8752 | |
| 8753 | # If we've finished initialization, mention that stack dumps |
| 8754 | # are enabled, If dieLevel is 1, we won't stack dump if we die |
| 8755 | # in an eval(). |
| 8756 | print $OUT "Stack dump during die enabled", |
| 8757 | ( $dieLevel == 1 ? " outside of evals" : "" ), ".\n" |
| 8758 | if $I_m_init; |
| 8759 | |
| 8760 | # XXX This is probably obsolete, given that diehard() is gone. |
| 8761 | print $OUT "Dump printed too.\n" if $dieLevel > 2; |
| 8762 | } ## end if ($dieLevel) |
| 8763 | |
| 8764 | # Put the old one back if there was one. |
| 8765 | elsif ($prevdie) { |
| 8766 | $SIG{__DIE__} = $prevdie; |
| 8767 | print $OUT "Default die handler restored.\n"; |
| 8768 | } else { |
| 8769 | undef $SIG{__DIE__}; |
| 8770 | print $OUT "Die handler removed.\n"; |
| 8771 | } |
| 8772 | } ## end if (@_) |
| 8773 | $dieLevel; |
| 8774 | } ## end sub dieLevel |
| 8775 | |
| 8776 | =head2 C<signalLevel> |
| 8777 | |
| 8778 | Number three in a series: set C<signalLevel> to zero to keep your own |
| 8779 | signal handler for C<SIGSEGV> and/or C<SIGBUS>. Otherwise, the debugger |
| 8780 | takes over and handles them with C<DB::diesignal()>. |
| 8781 | |
| 8782 | =cut |
| 8783 | |
| 8784 | sub signalLevel { |
| 8785 | if (@_) { |
| 8786 | my $prevsegv = $SIG{SEGV} unless $signalLevel; |
| 8787 | my $prevbus = $SIG{BUS} unless $signalLevel; |
| 8788 | $signalLevel = shift; |
| 8789 | if ($signalLevel) { |
| 8790 | $SIG{SEGV} = \&DB::diesignal; |
| 8791 | $SIG{BUS} = \&DB::diesignal; |
| 8792 | } |
| 8793 | else { |
| 8794 | $SIG{SEGV} = $prevsegv; |
| 8795 | $SIG{BUS} = $prevbus; |
| 8796 | } |
| 8797 | } ## end if (@_) |
| 8798 | $signalLevel; |
| 8799 | } ## end sub signalLevel |
| 8800 | |
| 8801 | =head1 SUBROUTINE DECODING SUPPORT |
| 8802 | |
| 8803 | These subroutines are used during the C<x> and C<X> commands to try to |
| 8804 | produce as much information as possible about a code reference. They use |
| 8805 | L<Devel::Peek> to try to find the glob in which this code reference lives |
| 8806 | (if it does) - this allows us to actually code references which correspond |
| 8807 | to named subroutines (including those aliased via glob assignment). |
| 8808 | |
| 8809 | =head2 C<CvGV_name()> |
| 8810 | |
| 8811 | Wrapper for C<CvGV_name_or_bust>; tries to get the name of a reference |
| 8812 | via that routine. If this fails, return the reference again (when the |
| 8813 | reference is stringified, it'll come out as C<SOMETHING(0x...)>). |
| 8814 | |
| 8815 | =cut |
| 8816 | |
| 8817 | sub CvGV_name { |
| 8818 | my $in = shift; |
| 8819 | my $name = CvGV_name_or_bust($in); |
| 8820 | defined $name ? $name : $in; |
| 8821 | } |
| 8822 | |
| 8823 | =head2 C<CvGV_name_or_bust> I<coderef> |
| 8824 | |
| 8825 | Calls L<Devel::Peek> to try to find the glob the ref lives in; returns |
| 8826 | C<undef> if L<Devel::Peek> can't be loaded, or if C<Devel::Peek::CvGV> can't |
| 8827 | find a glob for this ref. |
| 8828 | |
| 8829 | Returns C<< I<package>::I<glob name> >> if the code ref is found in a glob. |
| 8830 | |
| 8831 | =cut |
| 8832 | |
| 8833 | use vars qw($skipCvGV); |
| 8834 | |
| 8835 | sub CvGV_name_or_bust { |
| 8836 | my $in = shift; |
| 8837 | return if $skipCvGV; # Backdoor to avoid problems if XS broken... |
| 8838 | return unless ref $in; |
| 8839 | $in = \&$in; # Hard reference... |
| 8840 | eval { require Devel::Peek; 1 } or return; |
| 8841 | my $gv = Devel::Peek::CvGV($in) or return; |
| 8842 | *$gv{PACKAGE} . '::' . *$gv{NAME}; |
| 8843 | } ## end sub CvGV_name_or_bust |
| 8844 | |
| 8845 | =head2 C<find_sub> |
| 8846 | |
| 8847 | A utility routine used in various places; finds the file where a subroutine |
| 8848 | was defined, and returns that filename and a line-number range. |
| 8849 | |
| 8850 | Tries to use C<@sub> first; if it can't find it there, it tries building a |
| 8851 | reference to the subroutine and uses C<CvGV_name_or_bust> to locate it, |
| 8852 | loading it into C<@sub> as a side effect (XXX I think). If it can't find it |
| 8853 | this way, it brute-force searches C<%sub>, checking for identical references. |
| 8854 | |
| 8855 | =cut |
| 8856 | |
| 8857 | sub _find_sub_helper { |
| 8858 | my $subr = shift; |
| 8859 | |
| 8860 | return unless defined &$subr; |
| 8861 | my $name = CvGV_name_or_bust($subr); |
| 8862 | my $data; |
| 8863 | $data = $sub{$name} if defined $name; |
| 8864 | return $data if defined $data; |
| 8865 | |
| 8866 | # Old stupid way... |
| 8867 | $subr = \&$subr; # Hard reference |
| 8868 | my $s; |
| 8869 | for ( keys %sub ) { |
| 8870 | $s = $_, last if $subr eq \&$_; |
| 8871 | } |
| 8872 | if ($s) |
| 8873 | { |
| 8874 | return $sub{$s}; |
| 8875 | } |
| 8876 | else |
| 8877 | { |
| 8878 | return; |
| 8879 | } |
| 8880 | |
| 8881 | } |
| 8882 | |
| 8883 | sub find_sub { |
| 8884 | my $subr = shift; |
| 8885 | return ( $sub{$subr} || _find_sub_helper($subr) ); |
| 8886 | } ## end sub find_sub |
| 8887 | |
| 8888 | =head2 C<methods> |
| 8889 | |
| 8890 | A subroutine that uses the utility function C<methods_via> to find all the |
| 8891 | methods in the class corresponding to the current reference and in |
| 8892 | C<UNIVERSAL>. |
| 8893 | |
| 8894 | =cut |
| 8895 | |
| 8896 | use vars qw(%seen); |
| 8897 | |
| 8898 | sub methods { |
| 8899 | |
| 8900 | # Figure out the class - either this is the class or it's a reference |
| 8901 | # to something blessed into that class. |
| 8902 | my $class = shift; |
| 8903 | $class = ref $class if ref $class; |
| 8904 | |
| 8905 | local %seen; |
| 8906 | |
| 8907 | # Show the methods that this class has. |
| 8908 | methods_via( $class, '', 1 ); |
| 8909 | |
| 8910 | # Show the methods that UNIVERSAL has. |
| 8911 | methods_via( 'UNIVERSAL', 'UNIVERSAL', 0 ); |
| 8912 | } ## end sub methods |
| 8913 | |
| 8914 | =head2 C<methods_via($class, $prefix, $crawl_upward)> |
| 8915 | |
| 8916 | C<methods_via> does the work of crawling up the C<@ISA> tree and reporting |
| 8917 | all the parent class methods. C<$class> is the name of the next class to |
| 8918 | try; C<$prefix> is the message prefix, which gets built up as we go up the |
| 8919 | C<@ISA> tree to show parentage; C<$crawl_upward> is 1 if we should try to go |
| 8920 | higher in the C<@ISA> tree, 0 if we should stop. |
| 8921 | |
| 8922 | =cut |
| 8923 | |
| 8924 | sub methods_via { |
| 8925 | |
| 8926 | # If we've processed this class already, just quit. |
| 8927 | my $class = shift; |
| 8928 | return if $seen{$class}++; |
| 8929 | |
| 8930 | # This is a package that is contributing the methods we're about to print. |
| 8931 | my $prefix = shift; |
| 8932 | my $prepend = $prefix ? "via $prefix: " : ''; |
| 8933 | my @to_print; |
| 8934 | |
| 8935 | # Extract from all the symbols in this class. |
| 8936 | my $class_ref = do { no strict "refs"; \%{$class . '::'} }; |
| 8937 | while (my ($name, $glob) = each %$class_ref) { |
| 8938 | # references directly in the symbol table are Proxy Constant |
| 8939 | # Subroutines, and are by their very nature defined |
| 8940 | # Otherwise, check if the thing is a typeglob, and if it is, it decays |
| 8941 | # to a subroutine reference, which can be tested by defined. |
| 8942 | # $glob might also be the value -1 (from sub foo;) |
| 8943 | # or (say) '$$' (from sub foo ($$);) |
| 8944 | # \$glob will be SCALAR in both cases. |
| 8945 | if ((ref $glob || ($glob && ref \$glob eq 'GLOB' && defined &$glob)) |
| 8946 | && !$seen{$name}++) { |
| 8947 | push @to_print, "$prepend$name\n"; |
| 8948 | } |
| 8949 | } |
| 8950 | |
| 8951 | { |
| 8952 | local $\ = ''; |
| 8953 | local $, = ''; |
| 8954 | print $DB::OUT $_ foreach sort @to_print; |
| 8955 | } |
| 8956 | |
| 8957 | # If the $crawl_upward argument is false, just quit here. |
| 8958 | return unless shift; |
| 8959 | |
| 8960 | # $crawl_upward true: keep going up the tree. |
| 8961 | # Find all the classes this one is a subclass of. |
| 8962 | my $class_ISA_ref = do { no strict "refs"; \@{"${class}::ISA"} }; |
| 8963 | for my $name ( @$class_ISA_ref ) { |
| 8964 | |
| 8965 | # Set up the new prefix. |
| 8966 | $prepend = $prefix ? $prefix . " -> $name" : $name; |
| 8967 | |
| 8968 | # Crawl up the tree and keep trying to crawl up. |
| 8969 | methods_via( $name, $prepend, 1 ); |
| 8970 | } |
| 8971 | } ## end sub methods_via |
| 8972 | |
| 8973 | =head2 C<setman> - figure out which command to use to show documentation |
| 8974 | |
| 8975 | Just checks the contents of C<$^O> and sets the C<$doccmd> global accordingly. |
| 8976 | |
| 8977 | =cut |
| 8978 | |
| 8979 | sub setman { |
| 8980 | $doccmd = $^O !~ /^(?:MSWin32|VMS|os2|amigaos|riscos)\z/s |
| 8981 | ? "man" # O Happy Day! |
| 8982 | : "perldoc"; # Alas, poor unfortunates |
| 8983 | } ## end sub setman |
| 8984 | |
| 8985 | =head2 C<runman> - run the appropriate command to show documentation |
| 8986 | |
| 8987 | Accepts a man page name; runs the appropriate command to display it (set up |
| 8988 | during debugger initialization). Uses C<_db_system()> to avoid mucking up the |
| 8989 | program's STDIN and STDOUT. |
| 8990 | |
| 8991 | =cut |
| 8992 | |
| 8993 | sub runman { |
| 8994 | my $page = shift; |
| 8995 | unless ($page) { |
| 8996 | _db_system("$doccmd $doccmd"); |
| 8997 | return; |
| 8998 | } |
| 8999 | |
| 9000 | # this way user can override, like with $doccmd="man -Mwhatever" |
| 9001 | # or even just "man " to disable the path check. |
| 9002 | if ( $doccmd ne 'man' ) { |
| 9003 | _db_system("$doccmd $page"); |
| 9004 | return; |
| 9005 | } |
| 9006 | |
| 9007 | $page = 'perl' if lc($page) eq 'help'; |
| 9008 | |
| 9009 | require Config; |
| 9010 | my $man1dir = $Config::Config{man1direxp}; |
| 9011 | my $man3dir = $Config::Config{man3direxp}; |
| 9012 | for ( $man1dir, $man3dir ) { s#/[^/]*\z## if /\S/ } |
| 9013 | my $manpath = ''; |
| 9014 | $manpath .= "$man1dir:" if $man1dir =~ /\S/; |
| 9015 | $manpath .= "$man3dir:" if $man3dir =~ /\S/ && $man1dir ne $man3dir; |
| 9016 | chop $manpath if $manpath; |
| 9017 | |
| 9018 | # harmless if missing, I figure |
| 9019 | local $ENV{MANPATH} = $manpath if $manpath; |
| 9020 | my $nopathopt = $^O =~ /dunno what goes here/; |
| 9021 | if ( |
| 9022 | CORE::system( |
| 9023 | $doccmd, |
| 9024 | |
| 9025 | # I just *know* there are men without -M |
| 9026 | ( ( $manpath && !$nopathopt ) ? ( "-M", $manpath ) : () ), |
| 9027 | split ' ', $page |
| 9028 | ) |
| 9029 | ) |
| 9030 | { |
| 9031 | unless ( $page =~ /^perl\w/ ) { |
| 9032 | # Previously the debugger contained a list which it slurped in, |
| 9033 | # listing the known "perl" manpages. However, it was out of date, |
| 9034 | # with errors both of omission and inclusion. This approach is |
| 9035 | # considerably less complex. The failure mode on a butchered |
| 9036 | # install is simply that the user has to run man or perldoc |
| 9037 | # "manually" with the full manpage name. |
| 9038 | |
| 9039 | # There is a list of $^O values in installperl to determine whether |
| 9040 | # the directory is 'pods' or 'pod'. However, we can avoid tight |
| 9041 | # coupling to that by simply checking the "non-standard" 'pods' |
| 9042 | # first. |
| 9043 | my $pods = "$Config::Config{privlibexp}/pods"; |
| 9044 | $pods = "$Config::Config{privlibexp}/pod" |
| 9045 | unless -d $pods; |
| 9046 | if (-f "$pods/perl$page.pod") { |
| 9047 | CORE::system( $doccmd, |
| 9048 | ( ( $manpath && !$nopathopt ) ? ( "-M", $manpath ) : () ), |
| 9049 | "perl$page" ); |
| 9050 | } |
| 9051 | } |
| 9052 | } ## end if (CORE::system($doccmd... |
| 9053 | } ## end sub runman |
| 9054 | |
| 9055 | #use Carp; # This did break, left for debugging |
| 9056 | |
| 9057 | =head1 DEBUGGER INITIALIZATION - THE SECOND BEGIN BLOCK |
| 9058 | |
| 9059 | Because of the way the debugger interface to the Perl core is designed, any |
| 9060 | debugger package globals that C<DB::sub()> requires have to be defined before |
| 9061 | any subroutines can be called. These are defined in the second C<BEGIN> block. |
| 9062 | |
| 9063 | This block sets things up so that (basically) the world is sane |
| 9064 | before the debugger starts executing. We set up various variables that the |
| 9065 | debugger has to have set up before the Perl core starts running: |
| 9066 | |
| 9067 | =over 4 |
| 9068 | |
| 9069 | =item * |
| 9070 | |
| 9071 | The debugger's own filehandles (copies of STD and STDOUT for now). |
| 9072 | |
| 9073 | =item * |
| 9074 | |
| 9075 | Characters for shell escapes, the recall command, and the history command. |
| 9076 | |
| 9077 | =item * |
| 9078 | |
| 9079 | The maximum recursion depth. |
| 9080 | |
| 9081 | =item * |
| 9082 | |
| 9083 | The size of a C<w> command's window. |
| 9084 | |
| 9085 | =item * |
| 9086 | |
| 9087 | The before-this-line context to be printed in a C<v> (view a window around this line) command. |
| 9088 | |
| 9089 | =item * |
| 9090 | |
| 9091 | The fact that we're not in a sub at all right now. |
| 9092 | |
| 9093 | =item * |
| 9094 | |
| 9095 | The default SIGINT handler for the debugger. |
| 9096 | |
| 9097 | =item * |
| 9098 | |
| 9099 | The appropriate value of the flag in C<$^D> that says the debugger is running |
| 9100 | |
| 9101 | =item * |
| 9102 | |
| 9103 | The current debugger recursion level |
| 9104 | |
| 9105 | =item * |
| 9106 | |
| 9107 | The list of postponed items and the C<$single> stack (XXX define this) |
| 9108 | |
| 9109 | =item * |
| 9110 | |
| 9111 | That we want no return values and no subroutine entry/exit trace. |
| 9112 | |
| 9113 | =back |
| 9114 | |
| 9115 | =cut |
| 9116 | |
| 9117 | # The following BEGIN is very handy if debugger goes havoc, debugging debugger? |
| 9118 | |
| 9119 | use vars qw($db_stop); |
| 9120 | |
| 9121 | BEGIN { # This does not compile, alas. (XXX eh?) |
| 9122 | $IN = \*STDIN; # For bugs before DB::OUT has been opened |
| 9123 | $OUT = \*STDERR; # For errors before DB::OUT has been opened |
| 9124 | |
| 9125 | # Define characters used by command parsing. |
| 9126 | $sh = '!'; # Shell escape (does not work) |
| 9127 | $rc = ','; # Recall command (does not work) |
| 9128 | @hist = ('?'); # Show history (does not work) |
| 9129 | @truehist = (); # Can be saved for replay (per session) |
| 9130 | |
| 9131 | # This defines the point at which you get the 'deep recursion' |
| 9132 | # warning. It MUST be defined or the debugger will not load. |
| 9133 | $deep = 1000; |
| 9134 | |
| 9135 | # Number of lines around the current one that are shown in the |
| 9136 | # 'w' command. |
| 9137 | $window = 10; |
| 9138 | |
| 9139 | # How much before-the-current-line context the 'v' command should |
| 9140 | # use in calculating the start of the window it will display. |
| 9141 | $preview = 3; |
| 9142 | |
| 9143 | # We're not in any sub yet, but we need this to be a defined value. |
| 9144 | $sub = ''; |
| 9145 | |
| 9146 | # Set up the debugger's interrupt handler. It simply sets a flag |
| 9147 | # ($signal) that DB::DB() will check before each command is executed. |
| 9148 | $SIG{INT} = \&DB::catch; |
| 9149 | |
| 9150 | # The following lines supposedly, if uncommented, allow the debugger to |
| 9151 | # debug itself. Perhaps we can try that someday. |
| 9152 | # This may be enabled to debug debugger: |
| 9153 | #$warnLevel = 1 unless defined $warnLevel; |
| 9154 | #$dieLevel = 1 unless defined $dieLevel; |
| 9155 | #$signalLevel = 1 unless defined $signalLevel; |
| 9156 | |
| 9157 | # This is the flag that says "a debugger is running, please call |
| 9158 | # DB::DB and DB::sub". We will turn it on forcibly before we try to |
| 9159 | # execute anything in the user's context, because we always want to |
| 9160 | # get control back. |
| 9161 | $db_stop = 0; # Compiler warning ... |
| 9162 | $db_stop = 1 << 30; # ... because this is only used in an eval() later. |
| 9163 | |
| 9164 | # This variable records how many levels we're nested in debugging. |
| 9165 | # Used in the debugger prompt, and in determining whether it's all over or |
| 9166 | # not. |
| 9167 | $level = 0; # Level of recursive debugging |
| 9168 | |
| 9169 | # "Triggers bug (?) in perl if we postpone this until runtime." |
| 9170 | # XXX No details on this yet, or whether we should fix the bug instead |
| 9171 | # of work around it. Stay tuned. |
| 9172 | @stack = (0); |
| 9173 | |
| 9174 | # Used to track the current stack depth using the auto-stacked-variable |
| 9175 | # trick. |
| 9176 | $stack_depth = 0; # Localized repeatedly; simple way to track $#stack |
| 9177 | |
| 9178 | # Don't print return values on exiting a subroutine. |
| 9179 | $doret = -2; |
| 9180 | |
| 9181 | # No extry/exit tracing. |
| 9182 | $frame = 0; |
| 9183 | |
| 9184 | } ## end BEGIN |
| 9185 | |
| 9186 | BEGIN { $^W = $ini_warn; } # Switch warnings back |
| 9187 | |
| 9188 | =head1 READLINE SUPPORT - COMPLETION FUNCTION |
| 9189 | |
| 9190 | =head2 db_complete |
| 9191 | |
| 9192 | C<readline> support - adds command completion to basic C<readline>. |
| 9193 | |
| 9194 | Returns a list of possible completions to C<readline> when invoked. C<readline> |
| 9195 | will print the longest common substring following the text already entered. |
| 9196 | |
| 9197 | If there is only a single possible completion, C<readline> will use it in full. |
| 9198 | |
| 9199 | This code uses C<map> and C<grep> heavily to create lists of possible |
| 9200 | completion. Think LISP in this section. |
| 9201 | |
| 9202 | =cut |
| 9203 | |
| 9204 | sub db_complete { |
| 9205 | |
| 9206 | # Specific code for b c l V m f O, &blah, $blah, @blah, %blah |
| 9207 | # $text is the text to be completed. |
| 9208 | # $line is the incoming line typed by the user. |
| 9209 | # $start is the start of the text to be completed in the incoming line. |
| 9210 | my ( $text, $line, $start ) = @_; |
| 9211 | |
| 9212 | # Save the initial text. |
| 9213 | # The search pattern is current package, ::, extract the next qualifier |
| 9214 | # Prefix and pack are set to undef. |
| 9215 | my ( $itext, $search, $prefix, $pack ) = |
| 9216 | ( $text, "^\Q${package}::\E([^:]+)\$" ); |
| 9217 | |
| 9218 | =head3 C<b postpone|compile> |
| 9219 | |
| 9220 | =over 4 |
| 9221 | |
| 9222 | =item * |
| 9223 | |
| 9224 | Find all the subroutines that might match in this package |
| 9225 | |
| 9226 | =item * |
| 9227 | |
| 9228 | Add C<postpone>, C<load>, and C<compile> as possibles (we may be completing the keyword itself) |
| 9229 | |
| 9230 | =item * |
| 9231 | |
| 9232 | Include all the rest of the subs that are known |
| 9233 | |
| 9234 | =item * |
| 9235 | |
| 9236 | C<grep> out the ones that match the text we have so far |
| 9237 | |
| 9238 | =item * |
| 9239 | |
| 9240 | Return this as the list of possible completions |
| 9241 | |
| 9242 | =back |
| 9243 | |
| 9244 | =cut |
| 9245 | |
| 9246 | return sort grep /^\Q$text/, ( keys %sub ), |
| 9247 | qw(postpone load compile), # subroutines |
| 9248 | ( map { /$search/ ? ($1) : () } keys %sub ) |
| 9249 | if ( substr $line, 0, $start ) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/; |
| 9250 | |
| 9251 | =head3 C<b load> |
| 9252 | |
| 9253 | Get all the possible files from C<@INC> as it currently stands and |
| 9254 | select the ones that match the text so far. |
| 9255 | |
| 9256 | =cut |
| 9257 | |
| 9258 | return sort grep /^\Q$text/, values %INC # files |
| 9259 | if ( substr $line, 0, $start ) =~ /^\|*b\s+load\s+$/; |
| 9260 | |
| 9261 | =head3 C<V> (list variable) and C<m> (list modules) |
| 9262 | |
| 9263 | There are two entry points for these commands: |
| 9264 | |
| 9265 | =head4 Unqualified package names |
| 9266 | |
| 9267 | Get the top-level packages and grab everything that matches the text |
| 9268 | so far. For each match, recursively complete the partial packages to |
| 9269 | get all possible matching packages. Return this sorted list. |
| 9270 | |
| 9271 | =cut |
| 9272 | |
| 9273 | return sort map { ( $_, db_complete( $_ . "::", "V ", 2 ) ) } |
| 9274 | grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : () } keys %:: # top-packages |
| 9275 | if ( substr $line, 0, $start ) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/; |
| 9276 | |
| 9277 | =head4 Qualified package names |
| 9278 | |
| 9279 | Take a partially-qualified package and find all subpackages for it |
| 9280 | by getting all the subpackages for the package so far, matching all |
| 9281 | the subpackages against the text, and discarding all of them which |
| 9282 | start with 'main::'. Return this list. |
| 9283 | |
| 9284 | =cut |
| 9285 | |
| 9286 | return sort map { ( $_, db_complete( $_ . "::", "V ", 2 ) ) } |
| 9287 | grep !/^main::/, grep /^\Q$text/, |
| 9288 | map { /^(.*)::$/ ? ( $prefix . "::$1" ) : () } |
| 9289 | do { no strict 'refs'; keys %{ $prefix . '::' } } |
| 9290 | if ( substr $line, 0, $start ) =~ /^\|*[Vm]\s+$/ |
| 9291 | and $text =~ /^(.*[^:])::?(\w*)$/ |
| 9292 | and $prefix = $1; |
| 9293 | |
| 9294 | =head3 C<f> - switch files |
| 9295 | |
| 9296 | Here, we want to get a fully-qualified filename for the C<f> command. |
| 9297 | Possibilities are: |
| 9298 | |
| 9299 | =over 4 |
| 9300 | |
| 9301 | =item 1. The original source file itself |
| 9302 | |
| 9303 | =item 2. A file from C<@INC> |
| 9304 | |
| 9305 | =item 3. An C<eval> (the debugger gets a C<(eval N)> fake file for each C<eval>). |
| 9306 | |
| 9307 | =back |
| 9308 | |
| 9309 | =cut |
| 9310 | |
| 9311 | if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files |
| 9312 | # We might possibly want to switch to an eval (which has a "filename" |
| 9313 | # like '(eval 9)'), so we may need to clean up the completion text |
| 9314 | # before proceeding. |
| 9315 | $prefix = length($1) - length($text); |
| 9316 | $text = $1; |
| 9317 | |
| 9318 | =pod |
| 9319 | |
| 9320 | Under the debugger, source files are represented as C<_E<lt>/fullpath/to/file> |
| 9321 | (C<eval>s are C<_E<lt>(eval NNN)>) keys in C<%main::>. We pull all of these |
| 9322 | out of C<%main::>, add the initial source file, and extract the ones that |
| 9323 | match the completion text so far. |
| 9324 | |
| 9325 | =cut |
| 9326 | |
| 9327 | return sort |
| 9328 | map { substr $_, 2 + $prefix } grep /^_<\Q$text/, ( keys %main:: ), |
| 9329 | $0; |
| 9330 | } ## end if ($line =~ /^\|*f\s+(.*)/) |
| 9331 | |
| 9332 | =head3 Subroutine name completion |
| 9333 | |
| 9334 | We look through all of the defined subs (the keys of C<%sub>) and |
| 9335 | return both all the possible matches to the subroutine name plus |
| 9336 | all the matches qualified to the current package. |
| 9337 | |
| 9338 | =cut |
| 9339 | |
| 9340 | if ( ( substr $text, 0, 1 ) eq '&' ) { # subroutines |
| 9341 | $text = substr $text, 1; |
| 9342 | $prefix = "&"; |
| 9343 | return sort map "$prefix$_", grep /^\Q$text/, ( keys %sub ), |
| 9344 | ( |
| 9345 | map { /$search/ ? ($1) : () } |
| 9346 | keys %sub |
| 9347 | ); |
| 9348 | } ## end if ((substr $text, 0, ... |
| 9349 | |
| 9350 | =head3 Scalar, array, and hash completion: partially qualified package |
| 9351 | |
| 9352 | Much like the above, except we have to do a little more cleanup: |
| 9353 | |
| 9354 | =cut |
| 9355 | |
| 9356 | if ( $text =~ /^[\$@%](.*)::(.*)/ ) { # symbols in a package |
| 9357 | |
| 9358 | =pod |
| 9359 | |
| 9360 | =over 4 |
| 9361 | |
| 9362 | =item * |
| 9363 | |
| 9364 | Determine the package that the symbol is in. Put it in C<::> (effectively C<main::>) if no package is specified. |
| 9365 | |
| 9366 | =cut |
| 9367 | |
| 9368 | $pack = ( $1 eq 'main' ? '' : $1 ) . '::'; |
| 9369 | |
| 9370 | =pod |
| 9371 | |
| 9372 | =item * |
| 9373 | |
| 9374 | Figure out the prefix vs. what needs completing. |
| 9375 | |
| 9376 | =cut |
| 9377 | |
| 9378 | $prefix = ( substr $text, 0, 1 ) . $1 . '::'; |
| 9379 | $text = $2; |
| 9380 | |
| 9381 | =pod |
| 9382 | |
| 9383 | =item * |
| 9384 | |
| 9385 | 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. |
| 9386 | |
| 9387 | =cut |
| 9388 | |
| 9389 | my @out = do { |
| 9390 | no strict 'refs'; |
| 9391 | map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, |
| 9392 | keys %$pack; |
| 9393 | }; |
| 9394 | |
| 9395 | =pod |
| 9396 | |
| 9397 | =item * |
| 9398 | |
| 9399 | 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. |
| 9400 | |
| 9401 | =cut |
| 9402 | |
| 9403 | if ( @out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext ) { |
| 9404 | return db_complete( $out[0], $line, $start ); |
| 9405 | } |
| 9406 | |
| 9407 | # Return the list of possibles. |
| 9408 | return sort @out; |
| 9409 | |
| 9410 | } ## end if ($text =~ /^[\$@%](.*)::(.*)/) |
| 9411 | |
| 9412 | =pod |
| 9413 | |
| 9414 | =back |
| 9415 | |
| 9416 | =head3 Symbol completion: current package or package C<main> |
| 9417 | |
| 9418 | =cut |
| 9419 | |
| 9420 | if ( $text =~ /^[\$@%]/ ) { # symbols (in $package + packages in main) |
| 9421 | =pod |
| 9422 | |
| 9423 | =over 4 |
| 9424 | |
| 9425 | =item * |
| 9426 | |
| 9427 | If it's C<main>, delete main to just get C<::> leading. |
| 9428 | |
| 9429 | =cut |
| 9430 | |
| 9431 | $pack = ( $package eq 'main' ? '' : $package ) . '::'; |
| 9432 | |
| 9433 | =pod |
| 9434 | |
| 9435 | =item * |
| 9436 | |
| 9437 | We set the prefix to the item's sigil, and trim off the sigil to get the text to be completed. |
| 9438 | |
| 9439 | =cut |
| 9440 | |
| 9441 | $prefix = substr $text, 0, 1; |
| 9442 | $text = substr $text, 1; |
| 9443 | |
| 9444 | my @out; |
| 9445 | |
| 9446 | =pod |
| 9447 | |
| 9448 | =item * |
| 9449 | |
| 9450 | We look for the lexical scope above DB::DB and auto-complete lexical variables |
| 9451 | if PadWalker could be loaded. |
| 9452 | |
| 9453 | =cut |
| 9454 | |
| 9455 | if (not $text =~ /::/ and eval { |
| 9456 | local @INC = @INC; |
| 9457 | pop @INC if $INC[-1] eq '.'; |
| 9458 | require PadWalker } ) { |
| 9459 | my $level = 1; |
| 9460 | while (1) { |
| 9461 | my @info = caller($level); |
| 9462 | $level++; |
| 9463 | $level = -1, last |
| 9464 | if not @info; |
| 9465 | last if $info[3] eq 'DB::DB'; |
| 9466 | } |
| 9467 | if ($level > 0) { |
| 9468 | my $lexicals = PadWalker::peek_my($level); |
| 9469 | push @out, grep /^\Q$prefix$text/, keys %$lexicals; |
| 9470 | } |
| 9471 | } |
| 9472 | |
| 9473 | =pod |
| 9474 | |
| 9475 | =item * |
| 9476 | |
| 9477 | 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. |
| 9478 | |
| 9479 | =cut |
| 9480 | |
| 9481 | push @out, map "$prefix$_", grep /^\Q$text/, |
| 9482 | ( grep /^_?[a-zA-Z]/, do { no strict 'refs'; keys %$pack } ), |
| 9483 | ( $pack eq '::' ? () : ( grep /::$/, keys %:: ) ); |
| 9484 | |
| 9485 | =item * |
| 9486 | |
| 9487 | If there's only one hit, it's a package qualifier, and it's not equal to the initial text, recomplete using this symbol. |
| 9488 | |
| 9489 | =back |
| 9490 | |
| 9491 | =cut |
| 9492 | |
| 9493 | if ( @out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext ) { |
| 9494 | return db_complete( $out[0], $line, $start ); |
| 9495 | } |
| 9496 | |
| 9497 | # Return the list of possibles. |
| 9498 | return sort @out; |
| 9499 | } ## end if ($text =~ /^[\$@%]/) |
| 9500 | |
| 9501 | =head3 Options |
| 9502 | |
| 9503 | We use C<option_val()> to look up the current value of the option. If there's |
| 9504 | only a single value, we complete the command in such a way that it is a |
| 9505 | complete command for setting the option in question. If there are multiple |
| 9506 | possible values, we generate a command consisting of the option plus a trailing |
| 9507 | question mark, which, if executed, will list the current value of the option. |
| 9508 | |
| 9509 | =cut |
| 9510 | |
| 9511 | if ( ( substr $line, 0, $start ) =~ /^\|*[oO]\b.*\s$/ ) |
| 9512 | { # Options after space |
| 9513 | # We look for the text to be matched in the list of possible options, |
| 9514 | # and fetch the current value. |
| 9515 | my @out = grep /^\Q$text/, @options; |
| 9516 | my $val = option_val( $out[0], undef ); |
| 9517 | |
| 9518 | # Set up a 'query option's value' command. |
| 9519 | my $out = '? '; |
| 9520 | if ( not defined $val or $val =~ /[\n\r]/ ) { |
| 9521 | |
| 9522 | # There's really nothing else we can do. |
| 9523 | } |
| 9524 | |
| 9525 | # We have a value. Create a proper option-setting command. |
| 9526 | elsif ( $val =~ /\s/ ) { |
| 9527 | |
| 9528 | # XXX This may be an extraneous variable. |
| 9529 | my $found; |
| 9530 | |
| 9531 | # We'll want to quote the string (because of the embedded |
| 9532 | # whtespace), but we want to make sure we don't end up with |
| 9533 | # mismatched quote characters. We try several possibilities. |
| 9534 | foreach my $l ( split //, qq/\"\'\#\|/ ) { |
| 9535 | |
| 9536 | # If we didn't find this quote character in the value, |
| 9537 | # quote it using this quote character. |
| 9538 | $out = "$l$val$l ", last if ( index $val, $l ) == -1; |
| 9539 | } |
| 9540 | } ## end elsif ($val =~ /\s/) |
| 9541 | |
| 9542 | # Don't need any quotes. |
| 9543 | else { |
| 9544 | $out = "=$val "; |
| 9545 | } |
| 9546 | |
| 9547 | # If there were multiple possible values, return '? ', which |
| 9548 | # makes the command into a query command. If there was just one, |
| 9549 | # have readline append that. |
| 9550 | $rl_attribs->{completer_terminator_character} = |
| 9551 | ( @out == 1 ? $out : '? ' ); |
| 9552 | |
| 9553 | # Return list of possibilities. |
| 9554 | return sort @out; |
| 9555 | } ## end if ((substr $line, 0, ... |
| 9556 | |
| 9557 | =head3 Filename completion |
| 9558 | |
| 9559 | For entering filenames. We simply call C<readline>'s C<filename_list()> |
| 9560 | method with the completion text to get the possible completions. |
| 9561 | |
| 9562 | =cut |
| 9563 | |
| 9564 | return $term->filename_list($text); # filenames |
| 9565 | |
| 9566 | } ## end sub db_complete |
| 9567 | |
| 9568 | =head1 MISCELLANEOUS SUPPORT FUNCTIONS |
| 9569 | |
| 9570 | Functions that possibly ought to be somewhere else. |
| 9571 | |
| 9572 | =head2 end_report |
| 9573 | |
| 9574 | Say we're done. |
| 9575 | |
| 9576 | =cut |
| 9577 | |
| 9578 | sub end_report { |
| 9579 | local $\ = ''; |
| 9580 | print $OUT "Use 'q' to quit or 'R' to restart. 'h q' for details.\n"; |
| 9581 | } |
| 9582 | |
| 9583 | =head2 clean_ENV |
| 9584 | |
| 9585 | If we have $ini_pids, save it in the environment; else remove it from the |
| 9586 | environment. Used by the C<R> (restart) command. |
| 9587 | |
| 9588 | =cut |
| 9589 | |
| 9590 | sub clean_ENV { |
| 9591 | if ( defined($ini_pids) ) { |
| 9592 | $ENV{PERLDB_PIDS} = $ini_pids; |
| 9593 | } |
| 9594 | else { |
| 9595 | delete( $ENV{PERLDB_PIDS} ); |
| 9596 | } |
| 9597 | } ## end sub clean_ENV |
| 9598 | |
| 9599 | # PERLDBf_... flag names from perl.h |
| 9600 | our ( %DollarCaretP_flags, %DollarCaretP_flags_r ); |
| 9601 | |
| 9602 | BEGIN { |
| 9603 | %DollarCaretP_flags = ( |
| 9604 | PERLDBf_SUB => 0x01, # Debug sub enter/exit |
| 9605 | PERLDBf_LINE => 0x02, # Keep line # |
| 9606 | PERLDBf_NOOPT => 0x04, # Switch off optimizations |
| 9607 | PERLDBf_INTER => 0x08, # Preserve more data |
| 9608 | PERLDBf_SUBLINE => 0x10, # Keep subr source lines |
| 9609 | PERLDBf_SINGLE => 0x20, # Start with single-step on |
| 9610 | PERLDBf_NONAME => 0x40, # For _SUB: no name of the subr |
| 9611 | PERLDBf_GOTO => 0x80, # Report goto: call DB::goto |
| 9612 | PERLDBf_NAMEEVAL => 0x100, # Informative names for evals |
| 9613 | PERLDBf_NAMEANON => 0x200, # Informative names for anon subs |
| 9614 | PERLDBf_SAVESRC => 0x400, # Save source lines into @{"_<$filename"} |
| 9615 | PERLDB_ALL => 0x33f, # No _NONAME, _GOTO |
| 9616 | ); |
| 9617 | # PERLDBf_LINE also enables the actions of PERLDBf_SAVESRC, so the debugger |
| 9618 | # doesn't need to set it. It's provided for the benefit of profilers and |
| 9619 | # other code analysers. |
| 9620 | |
| 9621 | %DollarCaretP_flags_r = reverse %DollarCaretP_flags; |
| 9622 | } |
| 9623 | |
| 9624 | sub parse_DollarCaretP_flags { |
| 9625 | my $flags = shift; |
| 9626 | $flags =~ s/^\s+//; |
| 9627 | $flags =~ s/\s+$//; |
| 9628 | my $acu = 0; |
| 9629 | foreach my $f ( split /\s*\|\s*/, $flags ) { |
| 9630 | my $value; |
| 9631 | if ( $f =~ /^0x([[:xdigit:]]+)$/ ) { |
| 9632 | $value = hex $1; |
| 9633 | } |
| 9634 | elsif ( $f =~ /^(\d+)$/ ) { |
| 9635 | $value = int $1; |
| 9636 | } |
| 9637 | elsif ( $f =~ /^DEFAULT$/i ) { |
| 9638 | $value = $DollarCaretP_flags{PERLDB_ALL}; |
| 9639 | } |
| 9640 | else { |
| 9641 | $f =~ /^(?:PERLDBf_)?(.*)$/i; |
| 9642 | $value = $DollarCaretP_flags{ 'PERLDBf_' . uc($1) }; |
| 9643 | unless ( defined $value ) { |
| 9644 | print $OUT ( |
| 9645 | "Unrecognized \$^P flag '$f'!\n", |
| 9646 | "Acceptable flags are: " |
| 9647 | . join( ', ', sort keys %DollarCaretP_flags ), |
| 9648 | ", and hexadecimal and decimal numbers.\n" |
| 9649 | ); |
| 9650 | return undef; |
| 9651 | } |
| 9652 | } |
| 9653 | $acu |= $value; |
| 9654 | } |
| 9655 | $acu; |
| 9656 | } |
| 9657 | |
| 9658 | sub expand_DollarCaretP_flags { |
| 9659 | my $DollarCaretP = shift; |
| 9660 | my @bits = ( |
| 9661 | map { |
| 9662 | my $n = ( 1 << $_ ); |
| 9663 | ( $DollarCaretP & $n ) |
| 9664 | ? ( $DollarCaretP_flags_r{$n} |
| 9665 | || sprintf( '0x%x', $n ) ) |
| 9666 | : () |
| 9667 | } 0 .. 31 |
| 9668 | ); |
| 9669 | return @bits ? join( '|', @bits ) : 0; |
| 9670 | } |
| 9671 | |
| 9672 | =over 4 |
| 9673 | |
| 9674 | =item rerun |
| 9675 | |
| 9676 | Rerun the current session to: |
| 9677 | |
| 9678 | rerun current position |
| 9679 | |
| 9680 | rerun 4 command number 4 |
| 9681 | |
| 9682 | rerun -4 current command minus 4 (go back 4 steps) |
| 9683 | |
| 9684 | Whether this always makes sense, in the current context is unknowable, and is |
| 9685 | in part left as a useful exercise for the reader. This sub returns the |
| 9686 | appropriate arguments to rerun the current session. |
| 9687 | |
| 9688 | =cut |
| 9689 | |
| 9690 | sub rerun { |
| 9691 | my $i = shift; |
| 9692 | my @args; |
| 9693 | pop(@truehist); # strim |
| 9694 | unless (defined $truehist[$i]) { |
| 9695 | print "Unable to return to non-existent command: $i\n"; |
| 9696 | } else { |
| 9697 | $#truehist = ($i < 0 ? $#truehist + $i : $i > 0 ? $i : $#truehist); |
| 9698 | my @temp = @truehist; # store |
| 9699 | push(@DB::typeahead, @truehist); # saved |
| 9700 | @truehist = @hist = (); # flush |
| 9701 | @args = restart(); # setup |
| 9702 | get_list("PERLDB_HIST"); # clean |
| 9703 | set_list("PERLDB_HIST", @temp); # reset |
| 9704 | } |
| 9705 | return @args; |
| 9706 | } |
| 9707 | |
| 9708 | =item restart |
| 9709 | |
| 9710 | Restarting the debugger is a complex operation that occurs in several phases. |
| 9711 | First, we try to reconstruct the command line that was used to invoke Perl |
| 9712 | and the debugger. |
| 9713 | |
| 9714 | =cut |
| 9715 | |
| 9716 | sub restart { |
| 9717 | # I may not be able to resurrect you, but here goes ... |
| 9718 | print $OUT |
| 9719 | "Warning: some settings and command-line options may be lost!\n"; |
| 9720 | my ( @script, @flags, $cl ); |
| 9721 | |
| 9722 | # If warn was on before, turn it on again. |
| 9723 | push @flags, '-w' if $ini_warn; |
| 9724 | |
| 9725 | # Rebuild the -I flags that were on the initial |
| 9726 | # command line. |
| 9727 | for (@ini_INC) { |
| 9728 | push @flags, '-I', $_; |
| 9729 | } |
| 9730 | |
| 9731 | # Turn on taint if it was on before. |
| 9732 | push @flags, '-T' if ${^TAINT}; |
| 9733 | |
| 9734 | # Arrange for setting the old INC: |
| 9735 | # Save the current @init_INC in the environment. |
| 9736 | set_list( "PERLDB_INC", @ini_INC ); |
| 9737 | |
| 9738 | # If this was a perl one-liner, go to the "file" |
| 9739 | # corresponding to the one-liner read all the lines |
| 9740 | # out of it (except for the first one, which is going |
| 9741 | # to be added back on again when 'perl -d' runs: that's |
| 9742 | # the 'require perl5db.pl;' line), and add them back on |
| 9743 | # to the command line to be executed. |
| 9744 | if ( $0 eq '-e' ) { |
| 9745 | my $lines = *{$main::{'_<-e'}}{ARRAY}; |
| 9746 | for ( 1 .. $#$lines ) { # The first line is PERL5DB |
| 9747 | chomp( $cl = $lines->[$_] ); |
| 9748 | push @script, '-e', $cl; |
| 9749 | } |
| 9750 | } ## end if ($0 eq '-e') |
| 9751 | |
| 9752 | # Otherwise we just reuse the original name we had |
| 9753 | # before. |
| 9754 | else { |
| 9755 | @script = $0; |
| 9756 | } |
| 9757 | |
| 9758 | =pod |
| 9759 | |
| 9760 | After the command line has been reconstructed, the next step is to save |
| 9761 | the debugger's status in environment variables. The C<DB::set_list> routine |
| 9762 | is used to save aggregate variables (both hashes and arrays); scalars are |
| 9763 | just popped into environment variables directly. |
| 9764 | |
| 9765 | =cut |
| 9766 | |
| 9767 | # If the terminal supported history, grab it and |
| 9768 | # save that in the environment. |
| 9769 | set_list( "PERLDB_HIST", |
| 9770 | $term->Features->{getHistory} |
| 9771 | ? $term->GetHistory |
| 9772 | : @hist ); |
| 9773 | |
| 9774 | # Find all the files that were visited during this |
| 9775 | # session (i.e., the debugger had magic hashes |
| 9776 | # corresponding to them) and stick them in the environment. |
| 9777 | my @had_breakpoints = keys %had_breakpoints; |
| 9778 | set_list( "PERLDB_VISITED", @had_breakpoints ); |
| 9779 | |
| 9780 | # Save the debugger options we chose. |
| 9781 | set_list( "PERLDB_OPT", %option ); |
| 9782 | # set_list( "PERLDB_OPT", options2remember() ); |
| 9783 | |
| 9784 | # Save the break-on-loads. |
| 9785 | set_list( "PERLDB_ON_LOAD", %break_on_load ); |
| 9786 | |
| 9787 | =pod |
| 9788 | |
| 9789 | The most complex part of this is the saving of all of the breakpoints. They |
| 9790 | can live in an awful lot of places, and we have to go through all of them, |
| 9791 | find the breakpoints, and then save them in the appropriate environment |
| 9792 | variable via C<DB::set_list>. |
| 9793 | |
| 9794 | =cut |
| 9795 | |
| 9796 | # Go through all the breakpoints and make sure they're |
| 9797 | # still valid. |
| 9798 | my @hard; |
| 9799 | for ( 0 .. $#had_breakpoints ) { |
| 9800 | |
| 9801 | # We were in this file. |
| 9802 | my $file = $had_breakpoints[$_]; |
| 9803 | |
| 9804 | # Grab that file's magic line hash. |
| 9805 | *dbline = $main::{ '_<' . $file }; |
| 9806 | |
| 9807 | # Skip out if it doesn't exist, or if the breakpoint |
| 9808 | # is in a postponed file (we'll do postponed ones |
| 9809 | # later). |
| 9810 | next unless %dbline or $postponed_file{$file}; |
| 9811 | |
| 9812 | # In an eval. This is a little harder, so we'll |
| 9813 | # do more processing on that below. |
| 9814 | ( push @hard, $file ), next |
| 9815 | if $file =~ /^\(\w*eval/; |
| 9816 | |
| 9817 | # XXX I have no idea what this is doing. Yet. |
| 9818 | my @add; |
| 9819 | @add = %{ $postponed_file{$file} } |
| 9820 | if $postponed_file{$file}; |
| 9821 | |
| 9822 | # Save the list of all the breakpoints for this file. |
| 9823 | set_list( "PERLDB_FILE_$_", %dbline, @add ); |
| 9824 | |
| 9825 | # Serialize the extra data %breakpoints_data hash. |
| 9826 | # That's a bug fix. |
| 9827 | set_list( "PERLDB_FILE_ENABLED_$_", |
| 9828 | map { _is_breakpoint_enabled($file, $_) ? 1 : 0 } |
| 9829 | sort { $a <=> $b } keys(%dbline) |
| 9830 | ) |
| 9831 | } ## end for (0 .. $#had_breakpoints) |
| 9832 | |
| 9833 | # The breakpoint was inside an eval. This is a little |
| 9834 | # more difficult. XXX and I don't understand it. |
| 9835 | foreach my $hard_file (@hard) { |
| 9836 | # Get over to the eval in question. |
| 9837 | *dbline = $main::{ '_<' . $hard_file }; |
| 9838 | my $quoted = quotemeta $hard_file; |
| 9839 | my %subs; |
| 9840 | for my $sub ( keys %sub ) { |
| 9841 | if (my ($n1, $n2) = $sub{$sub} =~ /\A$quoted:(\d+)-(\d+)\z/) { |
| 9842 | $subs{$sub} = [ $n1, $n2 ]; |
| 9843 | } |
| 9844 | } |
| 9845 | unless (%subs) { |
| 9846 | print {$OUT} |
| 9847 | "No subroutines in $hard_file, ignoring breakpoints.\n"; |
| 9848 | next; |
| 9849 | } |
| 9850 | LINES: foreach my $line ( keys %dbline ) { |
| 9851 | |
| 9852 | # One breakpoint per sub only: |
| 9853 | my ( $offset, $found ); |
| 9854 | SUBS: foreach my $sub ( keys %subs ) { |
| 9855 | if ( |
| 9856 | $subs{$sub}->[1] >= $line # Not after the subroutine |
| 9857 | and ( |
| 9858 | not defined $offset # Not caught |
| 9859 | or $offset < 0 |
| 9860 | ) |
| 9861 | ) |
| 9862 | { # or badly caught |
| 9863 | $found = $sub; |
| 9864 | $offset = $line - $subs{$sub}->[0]; |
| 9865 | if ($offset >= 0) { |
| 9866 | $offset = "+$offset"; |
| 9867 | last SUBS; |
| 9868 | } |
| 9869 | } ## end if ($subs{$sub}->[1] >=... |
| 9870 | } ## end for $sub (keys %subs) |
| 9871 | if ( defined $offset ) { |
| 9872 | $postponed{$found} = |
| 9873 | "break $offset if $dbline{$line}"; |
| 9874 | } |
| 9875 | else { |
| 9876 | print {$OUT} |
| 9877 | ("Breakpoint in ${hard_file}:$line ignored:" |
| 9878 | . " after all the subroutines.\n"); |
| 9879 | } |
| 9880 | } ## end for $line (keys %dbline) |
| 9881 | } ## end for (@hard) |
| 9882 | |
| 9883 | # Save the other things that don't need to be |
| 9884 | # processed. |
| 9885 | set_list( "PERLDB_POSTPONE", %postponed ); |
| 9886 | set_list( "PERLDB_PRETYPE", @$pretype ); |
| 9887 | set_list( "PERLDB_PRE", @$pre ); |
| 9888 | set_list( "PERLDB_POST", @$post ); |
| 9889 | set_list( "PERLDB_TYPEAHEAD", @typeahead ); |
| 9890 | |
| 9891 | # We are officially restarting. |
| 9892 | $ENV{PERLDB_RESTART} = 1; |
| 9893 | |
| 9894 | # We are junking all child debuggers. |
| 9895 | delete $ENV{PERLDB_PIDS}; # Restore ini state |
| 9896 | |
| 9897 | # Set this back to the initial pid. |
| 9898 | $ENV{PERLDB_PIDS} = $ini_pids if defined $ini_pids; |
| 9899 | |
| 9900 | =pod |
| 9901 | |
| 9902 | After all the debugger status has been saved, we take the command we built up |
| 9903 | and then return it, so we can C<exec()> it. The debugger will spot the |
| 9904 | C<PERLDB_RESTART> environment variable and realize it needs to reload its state |
| 9905 | from the environment. |
| 9906 | |
| 9907 | =cut |
| 9908 | |
| 9909 | # And run Perl again. Add the "-d" flag, all the |
| 9910 | # flags we built up, the script (whether a one-liner |
| 9911 | # or a file), add on the -emacs flag for a client editor, |
| 9912 | # and then the old arguments. |
| 9913 | |
| 9914 | return ($^X, '-d', @flags, @script, ($client_editor ? '-emacs' : ()), @ARGS); |
| 9915 | |
| 9916 | }; # end restart |
| 9917 | |
| 9918 | =back |
| 9919 | |
| 9920 | =head1 END PROCESSING - THE C<END> BLOCK |
| 9921 | |
| 9922 | Come here at the very end of processing. We want to go into a |
| 9923 | loop where we allow the user to enter commands and interact with the |
| 9924 | debugger, but we don't want anything else to execute. |
| 9925 | |
| 9926 | First we set the C<$finished> variable, so that some commands that |
| 9927 | shouldn't be run after the end of program quit working. |
| 9928 | |
| 9929 | We then figure out whether we're truly done (as in the user entered a C<q> |
| 9930 | command, or we finished execution while running nonstop). If we aren't, |
| 9931 | we set C<$single> to 1 (causing the debugger to get control again). |
| 9932 | |
| 9933 | We then call C<DB::fake::at_exit()>, which returns the C<Use 'q' to quit ...> |
| 9934 | message and returns control to the debugger. Repeat. |
| 9935 | |
| 9936 | When the user finally enters a C<q> command, C<$fall_off_end> is set to |
| 9937 | 1 and the C<END> block simply exits with C<$single> set to 0 (don't |
| 9938 | break, run to completion.). |
| 9939 | |
| 9940 | =cut |
| 9941 | |
| 9942 | END { |
| 9943 | $finished = 1 if $inhibit_exit; # So that some commands may be disabled. |
| 9944 | $fall_off_end = 1 unless $inhibit_exit; |
| 9945 | |
| 9946 | # Do not stop in at_exit() and destructors on exit: |
| 9947 | if ($fall_off_end or $runnonstop) { |
| 9948 | save_hist(); |
| 9949 | } else { |
| 9950 | $DB::single = 1; |
| 9951 | DB::fake::at_exit(); |
| 9952 | } |
| 9953 | } ## end END |
| 9954 | |
| 9955 | =head1 PRE-5.8 COMMANDS |
| 9956 | |
| 9957 | Some of the commands changed function quite a bit in the 5.8 command |
| 9958 | realignment, so much so that the old code had to be replaced completely. |
| 9959 | Because we wanted to retain the option of being able to go back to the |
| 9960 | former command set, we moved the old code off to this section. |
| 9961 | |
| 9962 | There's an awful lot of duplicated code here. We've duplicated the |
| 9963 | comments to keep things clear. |
| 9964 | |
| 9965 | =head2 Null command |
| 9966 | |
| 9967 | Does nothing. Used to I<turn off> commands. |
| 9968 | |
| 9969 | =cut |
| 9970 | |
| 9971 | sub cmd_pre580_null { |
| 9972 | |
| 9973 | # do nothing... |
| 9974 | } |
| 9975 | |
| 9976 | =head2 Old C<a> command |
| 9977 | |
| 9978 | This version added actions if you supplied them, and deleted them |
| 9979 | if you didn't. |
| 9980 | |
| 9981 | =cut |
| 9982 | |
| 9983 | sub cmd_pre580_a { |
| 9984 | my $xcmd = shift; |
| 9985 | my $cmd = shift; |
| 9986 | |
| 9987 | # Argument supplied. Add the action. |
| 9988 | if ( $cmd =~ /^(\d*)\s*(.*)/ ) { |
| 9989 | |
| 9990 | # If the line isn't there, use the current line. |
| 9991 | my $i = $1 || $line; |
| 9992 | my $j = $2; |
| 9993 | |
| 9994 | # If there is an action ... |
| 9995 | if ( length $j ) { |
| 9996 | |
| 9997 | # ... but the line isn't breakable, skip it. |
| 9998 | if ( $dbline[$i] == 0 ) { |
| 9999 | print $OUT "Line $i may not have an action.\n"; |
| 10000 | } |
| 10001 | else { |
| 10002 | |
| 10003 | # ... and the line is breakable: |
| 10004 | # Mark that there's an action in this file. |
| 10005 | $had_breakpoints{$filename} |= 2; |
| 10006 | |
| 10007 | # Delete any current action. |
| 10008 | $dbline{$i} =~ s/\0[^\0]*//; |
| 10009 | |
| 10010 | # Add the new action, continuing the line as needed. |
| 10011 | $dbline{$i} .= "\0" . action($j); |
| 10012 | } |
| 10013 | } ## end if (length $j) |
| 10014 | |
| 10015 | # No action supplied. |
| 10016 | else { |
| 10017 | |
| 10018 | # Delete the action. |
| 10019 | $dbline{$i} =~ s/\0[^\0]*//; |
| 10020 | |
| 10021 | # Mark as having no break or action if nothing's left. |
| 10022 | delete $dbline{$i} if $dbline{$i} eq ''; |
| 10023 | } |
| 10024 | } ## end if ($cmd =~ /^(\d*)\s*(.*)/) |
| 10025 | } ## end sub cmd_pre580_a |
| 10026 | |
| 10027 | =head2 Old C<b> command |
| 10028 | |
| 10029 | Add breakpoints. |
| 10030 | |
| 10031 | =cut |
| 10032 | |
| 10033 | sub cmd_pre580_b { |
| 10034 | my $xcmd = shift; |
| 10035 | my $cmd = shift; |
| 10036 | my $dbline = shift; |
| 10037 | |
| 10038 | # Break on load. |
| 10039 | if ( $cmd =~ /^load\b\s*(.*)/ ) { |
| 10040 | my $file = $1; |
| 10041 | $file =~ s/\s+$//; |
| 10042 | cmd_b_load($file); |
| 10043 | } |
| 10044 | |
| 10045 | # b compile|postpone <some sub> [<condition>] |
| 10046 | # The interpreter actually traps this one for us; we just put the |
| 10047 | # necessary condition in the %postponed hash. |
| 10048 | elsif ( $cmd =~ /^(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ ) { |
| 10049 | |
| 10050 | # Capture the condition if there is one. Make it true if none. |
| 10051 | my $cond = length $3 ? $3 : '1'; |
| 10052 | |
| 10053 | # Save the sub name and set $break to 1 if $1 was 'postpone', 0 |
| 10054 | # if it was 'compile'. |
| 10055 | my ( $subname, $break ) = ( $2, $1 eq 'postpone' ); |
| 10056 | |
| 10057 | # De-Perl4-ify the name - ' separators to ::. |
| 10058 | $subname =~ s/\'/::/g; |
| 10059 | |
| 10060 | # Qualify it into the current package unless it's already qualified. |
| 10061 | $subname = "${package}::" . $subname |
| 10062 | unless $subname =~ /::/; |
| 10063 | |
| 10064 | # Add main if it starts with ::. |
| 10065 | $subname = "main" . $subname if substr( $subname, 0, 2 ) eq "::"; |
| 10066 | |
| 10067 | # Save the break type for this sub. |
| 10068 | $postponed{$subname} = $break ? "break +0 if $cond" : "compile"; |
| 10069 | } ## end elsif ($cmd =~ ... |
| 10070 | |
| 10071 | # b <sub name> [<condition>] |
| 10072 | elsif ( $cmd =~ /^([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/ ) { |
| 10073 | my $subname = $1; |
| 10074 | my $cond = length $2 ? $2 : '1'; |
| 10075 | cmd_b_sub( $subname, $cond ); |
| 10076 | } |
| 10077 | # b <line> [<condition>]. |
| 10078 | elsif ( $cmd =~ /^(\d*)\s*(.*)/ ) { |
| 10079 | my $i = $1 || $dbline; |
| 10080 | my $cond = length $2 ? $2 : '1'; |
| 10081 | cmd_b_line( $i, $cond ); |
| 10082 | } |
| 10083 | } ## end sub cmd_pre580_b |
| 10084 | |
| 10085 | =head2 Old C<D> command |
| 10086 | |
| 10087 | Delete all breakpoints unconditionally. |
| 10088 | |
| 10089 | =cut |
| 10090 | |
| 10091 | sub cmd_pre580_D { |
| 10092 | my $xcmd = shift; |
| 10093 | my $cmd = shift; |
| 10094 | if ( $cmd =~ /^\s*$/ ) { |
| 10095 | print $OUT "Deleting all breakpoints...\n"; |
| 10096 | |
| 10097 | # %had_breakpoints lists every file that had at least one |
| 10098 | # breakpoint in it. |
| 10099 | my $file; |
| 10100 | for $file ( keys %had_breakpoints ) { |
| 10101 | |
| 10102 | # Switch to the desired file temporarily. |
| 10103 | local *dbline = $main::{ '_<' . $file }; |
| 10104 | |
| 10105 | $max = $#dbline; |
| 10106 | my $was; |
| 10107 | |
| 10108 | # For all lines in this file ... |
| 10109 | for my $i (1 .. $max) { |
| 10110 | |
| 10111 | # If there's a breakpoint or action on this line ... |
| 10112 | if ( defined $dbline{$i} ) { |
| 10113 | |
| 10114 | # ... remove the breakpoint. |
| 10115 | $dbline{$i} =~ s/^[^\0]+//; |
| 10116 | if ( $dbline{$i} =~ s/^\0?$// ) { |
| 10117 | |
| 10118 | # Remove the entry altogether if no action is there. |
| 10119 | delete $dbline{$i}; |
| 10120 | } |
| 10121 | } ## end if (defined $dbline{$i... |
| 10122 | } ## end for my $i (1 .. $max) |
| 10123 | |
| 10124 | # If, after we turn off the "there were breakpoints in this file" |
| 10125 | # bit, the entry in %had_breakpoints for this file is zero, |
| 10126 | # we should remove this file from the hash. |
| 10127 | if ( not $had_breakpoints{$file} &= ~1 ) { |
| 10128 | delete $had_breakpoints{$file}; |
| 10129 | } |
| 10130 | } ## end for $file (keys %had_breakpoints) |
| 10131 | |
| 10132 | # Kill off all the other breakpoints that are waiting for files that |
| 10133 | # haven't been loaded yet. |
| 10134 | undef %postponed; |
| 10135 | undef %postponed_file; |
| 10136 | undef %break_on_load; |
| 10137 | } ## end if ($cmd =~ /^\s*$/) |
| 10138 | } ## end sub cmd_pre580_D |
| 10139 | |
| 10140 | =head2 Old C<h> command |
| 10141 | |
| 10142 | Print help. Defaults to printing the long-form help; the 5.8 version |
| 10143 | prints the summary by default. |
| 10144 | |
| 10145 | =cut |
| 10146 | |
| 10147 | sub cmd_pre580_h { |
| 10148 | my $xcmd = shift; |
| 10149 | my $cmd = shift; |
| 10150 | |
| 10151 | # Print the *right* help, long format. |
| 10152 | if ( $cmd =~ /^\s*$/ ) { |
| 10153 | print_help($pre580_help); |
| 10154 | } |
| 10155 | |
| 10156 | # 'h h' - explicitly-requested summary. |
| 10157 | elsif ( $cmd =~ /^h\s*/ ) { |
| 10158 | print_help($pre580_summary); |
| 10159 | } |
| 10160 | |
| 10161 | # Find and print a command's help. |
| 10162 | elsif ( $cmd =~ /^h\s+(\S.*)$/ ) { |
| 10163 | my $asked = $1; # for proper errmsg |
| 10164 | my $qasked = quotemeta($asked); # for searching |
| 10165 | # XXX: finds CR but not <CR> |
| 10166 | if ( |
| 10167 | $pre580_help =~ /^ |
| 10168 | <? # Optional '<' |
| 10169 | (?:[IB]<) # Optional markup |
| 10170 | $qasked # The command name |
| 10171 | /mx |
| 10172 | ) |
| 10173 | { |
| 10174 | |
| 10175 | while ( |
| 10176 | $pre580_help =~ /^ |
| 10177 | ( # The command help: |
| 10178 | <? # Optional '<' |
| 10179 | (?:[IB]<) # Optional markup |
| 10180 | $qasked # The command name |
| 10181 | ([\s\S]*?) # Lines starting with tabs |
| 10182 | \n # Final newline |
| 10183 | ) |
| 10184 | (?!\s)/mgx |
| 10185 | ) # Line not starting with space |
| 10186 | # (Next command's help) |
| 10187 | { |
| 10188 | print_help($1); |
| 10189 | } |
| 10190 | } ## end if ($pre580_help =~ /^<?(?:[IB]<)$qasked/m) |
| 10191 | |
| 10192 | # Help not found. |
| 10193 | else { |
| 10194 | print_help("B<$asked> is not a debugger command.\n"); |
| 10195 | } |
| 10196 | } ## end elsif ($cmd =~ /^h\s+(\S.*)$/) |
| 10197 | } ## end sub cmd_pre580_h |
| 10198 | |
| 10199 | =head2 Old C<W> command |
| 10200 | |
| 10201 | C<W E<lt>exprE<gt>> adds a watch expression, C<W> deletes them all. |
| 10202 | |
| 10203 | =cut |
| 10204 | |
| 10205 | sub cmd_pre580_W { |
| 10206 | my $xcmd = shift; |
| 10207 | my $cmd = shift; |
| 10208 | |
| 10209 | # Delete all watch expressions. |
| 10210 | if ( $cmd =~ /^$/ ) { |
| 10211 | |
| 10212 | # No watching is going on. |
| 10213 | $trace &= ~2; |
| 10214 | |
| 10215 | # Kill all the watch expressions and values. |
| 10216 | @to_watch = @old_watch = (); |
| 10217 | } |
| 10218 | |
| 10219 | # Add a watch expression. |
| 10220 | elsif ( $cmd =~ /^(.*)/s ) { |
| 10221 | |
| 10222 | # add it to the list to be watched. |
| 10223 | push @to_watch, $1; |
| 10224 | |
| 10225 | # Get the current value of the expression. |
| 10226 | # Doesn't handle expressions returning list values! |
| 10227 | $evalarg = $1; |
| 10228 | # The &-call is here to ascertain the mutability of @_. |
| 10229 | my ($val) = &DB::eval; |
| 10230 | $val = ( defined $val ) ? "'$val'" : 'undef'; |
| 10231 | |
| 10232 | # Save it. |
| 10233 | push @old_watch, $val; |
| 10234 | |
| 10235 | # We're watching stuff. |
| 10236 | $trace |= 2; |
| 10237 | |
| 10238 | } ## end elsif ($cmd =~ /^(.*)/s) |
| 10239 | } ## end sub cmd_pre580_W |
| 10240 | |
| 10241 | =head1 PRE-AND-POST-PROMPT COMMANDS AND ACTIONS |
| 10242 | |
| 10243 | The debugger used to have a bunch of nearly-identical code to handle |
| 10244 | the pre-and-post-prompt action commands. C<cmd_pre590_prepost> and |
| 10245 | C<cmd_prepost> unify all this into one set of code to handle the |
| 10246 | appropriate actions. |
| 10247 | |
| 10248 | =head2 C<cmd_pre590_prepost> |
| 10249 | |
| 10250 | A small wrapper around C<cmd_prepost>; it makes sure that the default doesn't |
| 10251 | do something destructive. In pre 5.8 debuggers, the default action was to |
| 10252 | delete all the actions. |
| 10253 | |
| 10254 | =cut |
| 10255 | |
| 10256 | sub cmd_pre590_prepost { |
| 10257 | my $cmd = shift; |
| 10258 | my $line = shift || '*'; |
| 10259 | my $dbline = shift; |
| 10260 | |
| 10261 | return cmd_prepost( $cmd, $line, $dbline ); |
| 10262 | } ## end sub cmd_pre590_prepost |
| 10263 | |
| 10264 | =head2 C<cmd_prepost> |
| 10265 | |
| 10266 | Actually does all the handling for C<E<lt>>, C<E<gt>>, C<{{>, C<{>, etc. |
| 10267 | Since the lists of actions are all held in arrays that are pointed to by |
| 10268 | references anyway, all we have to do is pick the right array reference and |
| 10269 | then use generic code to all, delete, or list actions. |
| 10270 | |
| 10271 | =cut |
| 10272 | |
| 10273 | sub cmd_prepost { |
| 10274 | my $cmd = shift; |
| 10275 | |
| 10276 | # No action supplied defaults to 'list'. |
| 10277 | my $line = shift || '?'; |
| 10278 | |
| 10279 | # Figure out what to put in the prompt. |
| 10280 | my $which = ''; |
| 10281 | |
| 10282 | # Make sure we have some array or another to address later. |
| 10283 | # This means that if for some reason the tests fail, we won't be |
| 10284 | # trying to stash actions or delete them from the wrong place. |
| 10285 | my $aref = []; |
| 10286 | |
| 10287 | # < - Perl code to run before prompt. |
| 10288 | if ( $cmd =~ /^\</o ) { |
| 10289 | $which = 'pre-perl'; |
| 10290 | $aref = $pre; |
| 10291 | } |
| 10292 | |
| 10293 | # > - Perl code to run after prompt. |
| 10294 | elsif ( $cmd =~ /^\>/o ) { |
| 10295 | $which = 'post-perl'; |
| 10296 | $aref = $post; |
| 10297 | } |
| 10298 | |
| 10299 | # { - first check for properly-balanced braces. |
| 10300 | elsif ( $cmd =~ /^\{/o ) { |
| 10301 | if ( $cmd =~ /^\{.*\}$/o && unbalanced( substr( $cmd, 1 ) ) ) { |
| 10302 | print $OUT |
| 10303 | "$cmd is now a debugger command\nuse ';$cmd' if you mean Perl code\n"; |
| 10304 | } |
| 10305 | |
| 10306 | # Properly balanced. Pre-prompt debugger actions. |
| 10307 | else { |
| 10308 | $which = 'pre-debugger'; |
| 10309 | $aref = $pretype; |
| 10310 | } |
| 10311 | } ## end elsif ( $cmd =~ /^\{/o ) |
| 10312 | |
| 10313 | # Did we find something that makes sense? |
| 10314 | unless ($which) { |
| 10315 | print $OUT "Confused by command: $cmd\n"; |
| 10316 | } |
| 10317 | |
| 10318 | # Yes. |
| 10319 | else { |
| 10320 | |
| 10321 | # List actions. |
| 10322 | if ( $line =~ /^\s*\?\s*$/o ) { |
| 10323 | unless (@$aref) { |
| 10324 | |
| 10325 | # Nothing there. Complain. |
| 10326 | print $OUT "No $which actions.\n"; |
| 10327 | } |
| 10328 | else { |
| 10329 | |
| 10330 | # List the actions in the selected list. |
| 10331 | print $OUT "$which commands:\n"; |
| 10332 | foreach my $action (@$aref) { |
| 10333 | print $OUT "\t$cmd -- $action\n"; |
| 10334 | } |
| 10335 | } ## end else |
| 10336 | } ## end if ( $line =~ /^\s*\?\s*$/o) |
| 10337 | |
| 10338 | # Might be a delete. |
| 10339 | else { |
| 10340 | if ( length($cmd) == 1 ) { |
| 10341 | if ( $line =~ /^\s*\*\s*$/o ) { |
| 10342 | |
| 10343 | # It's a delete. Get rid of the old actions in the |
| 10344 | # selected list.. |
| 10345 | @$aref = (); |
| 10346 | print $OUT "All $cmd actions cleared.\n"; |
| 10347 | } |
| 10348 | else { |
| 10349 | |
| 10350 | # Replace all the actions. (This is a <, >, or {). |
| 10351 | @$aref = action($line); |
| 10352 | } |
| 10353 | } ## end if ( length($cmd) == 1) |
| 10354 | elsif ( length($cmd) == 2 ) { |
| 10355 | |
| 10356 | # Add the action to the line. (This is a <<, >>, or {{). |
| 10357 | push @$aref, action($line); |
| 10358 | } |
| 10359 | else { |
| 10360 | |
| 10361 | # <<<, >>>>, {{{{{{ ... something not a command. |
| 10362 | print $OUT |
| 10363 | "Confused by strange length of $which command($cmd)...\n"; |
| 10364 | } |
| 10365 | } ## end else [ if ( $line =~ /^\s*\?\s*$/o) |
| 10366 | } ## end else |
| 10367 | } ## end sub cmd_prepost |
| 10368 | |
| 10369 | =head1 C<DB::fake> |
| 10370 | |
| 10371 | Contains the C<at_exit> routine that the debugger uses to issue the |
| 10372 | C<Debugged program terminated ...> message after the program completes. See |
| 10373 | the L<C<END>|/END PROCESSING - THE END BLOCK> block documentation for more |
| 10374 | details. |
| 10375 | |
| 10376 | =cut |
| 10377 | |
| 10378 | package DB::fake; |
| 10379 | |
| 10380 | sub at_exit { |
| 10381 | "Debugged program terminated. Use 'q' to quit or 'R' to restart."; |
| 10382 | } |
| 10383 | |
| 10384 | package DB; # Do not trace this 1; below! |
| 10385 | |
| 10386 | 1; |
| 10387 | |
| 10388 | |