1=head1 NAME 2 3C<perl5db.pl> - the perl debugger 4 5=head1 SYNOPSIS 6 7 perl -d your_Perl_script 8 9=head1 DESCRIPTION 10 11C<perl5db.pl> is the perl debugger. It is loaded automatically by Perl when 12you invoke a script with C<perl -d>. This documentation tries to outline the 13structure and services provided by C<perl5db.pl>, and to describe how you 14can use them. 15 16=head1 GENERAL NOTES 17 18The debugger can look pretty forbidding to many Perl programmers. There are 19a number of reasons for this, many stemming out of the debugger's history. 20 21When the debugger was first written, Perl didn't have a lot of its nicer 22features - no references, no lexical variables, no closures, no object-oriented 23programming. So a lot of the things one would normally have done using such 24features was done using global variables, globs and the C<local()> operator 25in creative ways. 26 27Some of these have survived into the current debugger; a few of the more 28interesting and still-useful idioms are noted in this section, along with notes 29on the comments themselves. 30 31=head2 Why not use more lexicals? 32 33Experienced Perl programmers will note that the debugger code tends to use 34mostly package globals rather than lexically-scoped variables. This is done 35to allow a significant amount of control of the debugger from outside the 36debugger itself. 37 38Unfortunately, though the variables are accessible, they're not well 39documented, so it's generally been a decision that hasn't made a lot of 40difference to most users. Where appropriate, comments have been added to 41make variables more accessible and usable, with the understanding that these 42i<are> debugger internals, and are therefore subject to change. Future 43development should probably attempt to replace the globals with a well-defined 44API, but for now, the variables are what we've got. 45 46=head2 Automated variable stacking via C<local()> 47 48As you may recall from reading C<perlfunc>, the C<local()> operator makes a 49temporary copy of a variable in the current scope. When the scope ends, the 50old copy is restored. This is often used in the debugger to handle the 51automatic stacking of variables during recursive calls: 52 53 sub foo { 54 local $some_global++; 55 56 # Do some stuff, then ... 57 return; 58 } 59 60What happens is that on entry to the subroutine, C<$some_global> is localized, 61then altered. When the subroutine returns, Perl automatically undoes the 62localization, restoring the previous value. Voila, automatic stack management. 63 64The debugger uses this trick a I<lot>. Of particular note is C<DB::eval>, 65which lets the debugger get control inside of C<eval>'ed code. The debugger 66localizes a saved copy of C<$@> inside the subroutine, which allows it to 67keep C<$@> safe until it C<DB::eval> returns, at which point the previous 68value of C<$@> is restored. This makes it simple (well, I<simpler>) to keep 69track of C<$@> inside C<eval>s which C<eval> other C<eval's>. 70 71In any case, watch for this pattern. It occurs fairly often. 72 73=head2 The C<^> trick 74 75This is used to cleverly reverse the sense of a logical test depending on 76the value of an auxiliary variable. For instance, the debugger's C<S> 77(search for subroutines by pattern) allows you to negate the pattern 78like this: 79 80 # Find all non-'foo' subs: 81 S !/foo/ 82 83Boolean algebra states that the truth table for XOR looks like this: 84 85=over 4 86 87=item * 0 ^ 0 = 0 88 89(! not present and no match) --> false, don't print 90 91=item * 0 ^ 1 = 1 92 93(! not present and matches) --> true, print 94 95=item * 1 ^ 0 = 1 96 97(! present and no match) --> true, print 98 99=item * 1 ^ 1 = 0 100 101(! present and matches) --> false, don't print 102 103=back 104 105As you can see, the first pair applies when C<!> isn't supplied, and 106the second pair applies when it isn't. The XOR simply allows us to 107compact a more complicated if-then-elseif-else into a more elegant 108(but perhaps overly clever) single test. After all, it needed this 109explanation... 110 111=head2 FLAGS, FLAGS, FLAGS 112 113There is a certain C programming legacy in the debugger. Some variables, 114such as C<$single>, C<$trace>, and C<$frame>, have "magical" values composed 115of 1, 2, 4, etc. (powers of 2) OR'ed together. This allows several pieces 116of state to be stored independently in a single scalar. 117 118A test like 119 120 if ($scalar & 4) ... 121 122is checking to see if the appropriate bit is on. Since each bit can be 123"addressed" independently in this way, C<$scalar> is acting sort of like 124an array of bits. Obviously, since the contents of C<$scalar> are just a 125bit-pattern, we can save and restore it easily (it will just look like 126a number). 127 128The problem, is of course, that this tends to leave magic numbers scattered 129all over your program whenever a bit is set, cleared, or checked. So why do 130it? 131 132=over 4 133 134 135=item * First, doing an arithmetical or bitwise operation on a scalar is 136just about the fastest thing you can do in Perl: C<use constant> actually 137creates a subroutine call, and array hand hash lookups are much slower. Is 138this over-optimization at the expense of readability? Possibly, but the 139debugger accesses these variables a I<lot>. Any rewrite of the code will 140probably have to benchmark alternate implementations and see which is the 141best balance of readability and speed, and then document how it actually 142works. 143 144=item * Second, it's very easy to serialize a scalar number. This is done in 145the restart code; the debugger state variables are saved in C<%ENV> and then 146restored when the debugger is restarted. Having them be just numbers makes 147this trivial. 148 149=item * Third, some of these variables are being shared with the Perl core 150smack in the middle of the interpreter's execution loop. It's much faster for 151a C program (like the interpreter) to check a bit in a scalar than to access 152several different variables (or a Perl array). 153 154=back 155 156=head2 What are those C<XXX> comments for? 157 158Any comment containing C<XXX> means that the comment is either somewhat 159speculative - it's not exactly clear what a given variable or chunk of 160code is doing, or that it is incomplete - the basics may be clear, but the 161subtleties are not completely documented. 162 163Send in a patch if you can clear up, fill out, or clarify an C<XXX>. 164 165=head1 DATA STRUCTURES MAINTAINED BY CORE 166 167There are a number of special data structures provided to the debugger by 168the Perl interpreter. 169 170The array C<@{$main::{'_<'.$filename}}> (aliased locally to C<@dbline> via glob 171assignment) contains the text from C<$filename>, with each element 172corresponding to a single line of C<$filename>. 173 174The hash C<%{'_<'.$filename}> (aliased locally to C<%dbline> via glob 175assignment) contains breakpoints and actions. The keys are line numbers; 176you can set individual values, but not the whole hash. The Perl interpreter 177uses this hash to determine where breakpoints have been set. Any true value is 178considered to be a breakpoint; C<perl5db.pl> uses "$break_condition\0$action". 179Values are magical in numeric context: 1 if the line is breakable, 0 if not. 180 181The scalar ${'_<'.$filename} contains $filename XXX What? 182 183=head1 DEBUGGER STARTUP 184 185When C<perl5db.pl> starts, it reads an rcfile (C<perl5db.ini> for 186non-interactive sessions, C<.perldb> for interactive ones) that can set a number 187of options. In addition, this file may define a subroutine C<&afterinit> 188that will be executed (in the debugger's context) after the debugger has 189initialized itself. 190 191Next, it checks the C<PERLDB_OPTS> environment variable and treats its 192contents as the argument of a debugger <C<o> command. 193 194=head2 STARTUP-ONLY OPTIONS 195 196The following options can only be specified at startup. 197To set them in your rcfile, add a call to 198C<&parse_options("optionName=new_value")>. 199 200=over 4 201 202=item * TTY 203 204the TTY to use for debugging i/o. 205 206=item * noTTY 207 208if set, goes in NonStop mode. On interrupt, if TTY is not set, 209uses the value of noTTY or "/tmp/perldbtty$$" to find TTY using 210Term::Rendezvous. Current variant is to have the name of TTY in this 211file. 212 213=item * ReadLine 214 215If false, a dummy ReadLine is used, so you can debug 216ReadLine applications. 217 218=item * NonStop 219 220if true, no i/o is performed until interrupt. 221 222=item * LineInfo 223 224file or pipe to print line number info to. If it is a 225pipe, a short "emacs like" message is used. 226 227=item * RemotePort 228 229host:port to connect to on remote host for remote debugging. 230 231=back 232 233=head3 SAMPLE RCFILE 234 235 &parse_options("NonStop=1 LineInfo=db.out"); 236 sub afterinit { $trace = 1; } 237 238The script will run without human intervention, putting trace 239information into C<db.out>. (If you interrupt it, you had better 240reset C<LineInfo> to something "interactive"!) 241 242=head1 INTERNALS DESCRIPTION 243 244=head2 DEBUGGER INTERFACE VARIABLES 245 246Perl supplies the values for C<%sub>. It effectively inserts 247a C<&DB'DB();> in front of each place that can have a 248breakpoint. At each subroutine call, it calls C<&DB::sub> with 249C<$DB::sub> set to the called subroutine. It also inserts a C<BEGIN 250{require 'perl5db.pl'}> before the first line. 251 252After each C<require>d file is compiled, but before it is executed, a 253call to C<&DB::postponed($main::{'_<'.$filename})> is done. C<$filename> 254is the expanded name of the C<require>d file (as found via C<%INC>). 255 256=head3 IMPORTANT INTERNAL VARIABLES 257 258=head4 C<$CreateTTY> 259 260Used to control when the debugger will attempt to acquire another TTY to be 261used for input. 262 263=over 264 265=item * 1 - on C<fork()> 266 267=item * 2 - debugger is started inside debugger 268 269=item * 4 - on startup 270 271=back 272 273=head4 C<$doret> 274 275The value -2 indicates that no return value should be printed. 276Any other positive value causes C<DB::sub> to print return values. 277 278=head4 C<$evalarg> 279 280The item to be eval'ed by C<DB::eval>. Used to prevent messing with the current 281contents of C<@_> when C<DB::eval> is called. 282 283=head4 C<$frame> 284 285Determines what messages (if any) will get printed when a subroutine (or eval) 286is entered or exited. 287 288=over 4 289 290=item * 0 - No enter/exit messages 291 292=item * 1 - Print "entering" messages on subroutine entry 293 294=item * 2 - Adds exit messages on subroutine exit. If no other flag is on, acts like 1+2. 295 296=item * 4 - Extended messages: C<in|out> I<context>=I<fully-qualified sub name> from I<file>:I<line>>. If no other flag is on, acts like 1+4. 297 298=item * 8 - Adds parameter information to messages, and overloaded stringify and tied FETCH is enabled on the printed arguments. Ignored if C<4> is not on. 299 300=item * 16 - Adds C<I<context> return from I<subname>: I<value>> messages on subroutine/eval exit. Ignored if C<4> is is not on. 301 302=back 303 304To get everything, use C<$frame=30> (or C<o f-30> as a debugger command). 305The debugger internally juggles the value of C<$frame> during execution to 306protect external modules that the debugger uses from getting traced. 307 308=head4 C<$level> 309 310Tracks current debugger nesting level. Used to figure out how many 311C<E<lt>E<gt>> pairs to surround the line number with when the debugger 312outputs a prompt. Also used to help determine if the program has finished 313during command parsing. 314 315=head4 C<$onetimeDump> 316 317Controls what (if anything) C<DB::eval()> will print after evaluating an 318expression. 319 320=over 4 321 322=item * C<undef> - don't print anything 323 324=item * C<dump> - use C<dumpvar.pl> to display the value returned 325 326=item * C<methods> - print the methods callable on the first item returned 327 328=back 329 330=head4 C<$onetimeDumpDepth> 331 332Controls how far down C<dumpvar.pl> will go before printing '...' while 333dumping a structure. Numeric. If C<undef>, print all levels. 334 335=head4 C<$signal> 336 337Used to track whether or not an C<INT> signal has been detected. C<DB::DB()>, 338which is called before every statement, checks this and puts the user into 339command mode if it finds C<$signal> set to a true value. 340 341=head4 C<$single> 342 343Controls behavior during single-stepping. Stacked in C<@stack> on entry to 344each subroutine; popped again at the end of each subroutine. 345 346=over 4 347 348=item * 0 - run continuously. 349 350=item * 1 - single-step, go into subs. The 's' command. 351 352=item * 2 - single-step, don't go into subs. The 'n' command. 353 354=item * 4 - print current sub depth (turned on to force this when "too much 355recursion" occurs. 356 357=back 358 359=head4 C<$trace> 360 361Controls the output of trace information. 362 363=over 4 364 365=item * 1 - The C<t> command was entered to turn on tracing (every line executed is printed) 366 367=item * 2 - watch expressions are active 368 369=item * 4 - user defined a C<watchfunction()> in C<afterinit()> 370 371=back 372 373=head4 C<$slave_editor> 374 3751 if C<LINEINFO> was directed to a pipe; 0 otherwise. 376 377=head4 C<@cmdfhs> 378 379Stack of filehandles that C<DB::readline()> will read commands from. 380Manipulated by the debugger's C<source> command and C<DB::readline()> itself. 381 382=head4 C<@dbline> 383 384Local alias to the magical line array, C<@{$main::{'_<'.$filename}}> , 385supplied by the Perl interpreter to the debugger. Contains the source. 386 387=head4 C<@old_watch> 388 389Previous values of watch expressions. First set when the expression is 390entered; reset whenever the watch expression changes. 391 392=head4 C<@saved> 393 394Saves important globals (C<$@>, C<$!>, C<$^E>, C<$,>, C<$/>, C<$\>, C<$^W>) 395so that the debugger can substitute safe values while it's running, and 396restore them when it returns control. 397 398=head4 C<@stack> 399 400Saves the current value of C<$single> on entry to a subroutine. 401Manipulated by the C<c> command to turn off tracing in all subs above the 402current one. 403 404=head4 C<@to_watch> 405 406The 'watch' expressions: to be evaluated before each line is executed. 407 408=head4 C<@typeahead> 409 410The typeahead buffer, used by C<DB::readline>. 411 412=head4 C<%alias> 413 414Command aliases. Stored as character strings to be substituted for a command 415entered. 416 417=head4 C<%break_on_load> 418 419Keys are file names, values are 1 (break when this file is loaded) or undef 420(don't break when it is loaded). 421 422=head4 C<%dbline> 423 424Keys are line numbers, values are "condition\0action". If used in numeric 425context, values are 0 if not breakable, 1 if breakable, no matter what is 426in the actual hash entry. 427 428=head4 C<%had_breakpoints> 429 430Keys are file names; values are bitfields: 431 432=over 4 433 434=item * 1 - file has a breakpoint in it. 435 436=item * 2 - file has an action in it. 437 438=back 439 440A zero or undefined value means this file has neither. 441 442=head4 C<%option> 443 444Stores the debugger options. These are character string values. 445 446=head4 C<%postponed> 447 448Saves breakpoints for code that hasn't been compiled yet. 449Keys are subroutine names, values are: 450 451=over 4 452 453=item * 'compile' - break when this sub is compiled 454 455=item * 'break +0 if <condition>' - break (conditionally) at the start of this routine. The condition will be '1' if no condition was specified. 456 457=back 458 459=head4 C<%postponed_file> 460 461This hash keeps track of breakpoints that need to be set for files that have 462not yet been compiled. Keys are filenames; values are references to hashes. 463Each of these hashes is keyed by line number, and its values are breakpoint 464definitions ("condition\0action"). 465 466=head1 DEBUGGER INITIALIZATION 467 468The debugger's initialization actually jumps all over the place inside this 469package. This is because there are several BEGIN blocks (which of course 470execute immediately) spread through the code. Why is that? 471 472The debugger needs to be able to change some things and set some things up 473before the debugger code is compiled; most notably, the C<$deep> variable that 474C<DB::sub> uses to tell when a program has recursed deeply. In addition, the 475debugger has to turn off warnings while the debugger code is compiled, but then 476restore them to their original setting before the program being debugged begins 477executing. 478 479The first C<BEGIN> block simply turns off warnings by saving the current 480setting of C<$^W> and then setting it to zero. The second one initializes 481the debugger variables that are needed before the debugger begins executing. 482The third one puts C<$^X> back to its former value. 483 484We'll detail the second C<BEGIN> block later; just remember that if you need 485to initialize something before the debugger starts really executing, that's 486where it has to go. 487 488=cut 489 490package DB; 491 492use IO::Handle; 493 494# Debugger for Perl 5.00x; perl5db.pl patch level: 495$VERSION = 1.25; 496 497$header = "perl5db.pl version $VERSION"; 498 499=head1 DEBUGGER ROUTINES 500 501=head2 C<DB::eval()> 502 503This function replaces straight C<eval()> inside the debugger; it simplifies 504the process of evaluating code in the user's context. 505 506The code to be evaluated is passed via the package global variable 507C<$DB::evalarg>; this is done to avoid fiddling with the contents of C<@_>. 508 509We preserve the current settings of X<C<$trace>>, X<C<$single>>, and X<C<$^D>>; 510add the X<C<$usercontext>> (that's the preserved values of C<$@>, C<$!>, 511C<$^E>, C<$,>, C<$/>, C<$\>, and C<$^W>, grabbed when C<DB::DB> got control, 512and the user's current package) and a add a newline before we do the C<eval()>. 513This causes the proper context to be used when the eval is actually done. 514Afterward, we restore C<$trace>, C<$single>, and C<$^D>. 515 516Next we need to handle C<$@> without getting confused. We save C<$@> in a 517local lexical, localize C<$saved[0]> (which is where C<save()> will put 518C<$@>), and then call C<save()> to capture C<$@>, C<$!>, C<$^E>, C<$,>, 519C<$/>, C<$\>, and C<$^W>) and set C<$,>, C<$/>, C<$\>, and C<$^W> to values 520considered sane by the debugger. If there was an C<eval()> error, we print 521it on the debugger's output. If X<C<$onetimedump>> is defined, we call 522X<C<dumpit>> if it's set to 'dump', or X<C<methods>> if it's set to 523'methods'. Setting it to something else causes the debugger to do the eval 524but not print the result - handy if you want to do something else with it 525(the "watch expressions" code does this to get the value of the watch 526expression but not show it unless it matters). 527 528In any case, we then return the list of output from C<eval> to the caller, 529and unwinding restores the former version of C<$@> in C<@saved> as well 530(the localization of C<$saved[0]> goes away at the end of this scope). 531 532=head3 Parameters and variables influencing execution of DB::eval() 533 534C<DB::eval> isn't parameterized in the standard way; this is to keep the 535debugger's calls to C<DB::eval()> from mucking with C<@_>, among other things. 536The variables listed below influence C<DB::eval()>'s execution directly. 537 538=over 4 539 540=item C<$evalarg> - the thing to actually be eval'ed 541 542=item C<$trace> - Current state of execution tracing (see X<$trace>) 543 544=item C<$single> - Current state of single-stepping (see X<$single>) 545 546=item C<$onetimeDump> - what is to be displayed after the evaluation 547 548=item C<$onetimeDumpDepth> - how deep C<dumpit()> should go when dumping results 549 550=back 551 552The following variables are altered by C<DB::eval()> during its execution. They 553are "stacked" via C<local()>, enabling recursive calls to C<DB::eval()>. 554 555=over 4 556 557=item C<@res> - used to capture output from actual C<eval>. 558 559=item C<$otrace> - saved value of C<$trace>. 560 561=item C<$osingle> - saved value of C<$single>. 562 563=item C<$od> - saved value of C<$^D>. 564 565=item C<$saved[0]> - saved value of C<$@>. 566 567=item $\ - for output of C<$@> if there is an evaluation error. 568 569=back 570 571=head3 The problem of lexicals 572 573The context of C<DB::eval()> presents us with some problems. Obviously, 574we want to be 'sandboxed' away from the debugger's internals when we do 575the eval, but we need some way to control how punctuation variables and 576debugger globals are used. 577 578We can't use local, because the code inside C<DB::eval> can see localized 579variables; and we can't use C<my> either for the same reason. The code 580in this routine compromises and uses C<my>. 581 582After this routine is over, we don't have user code executing in the debugger's 583context, so we can use C<my> freely. 584 585=cut 586 587############################################## Begin lexical danger zone 588 589# 'my' variables used here could leak into (that is, be visible in) 590# the context that the code being evaluated is executing in. This means that 591# the code could modify the debugger's variables. 592# 593# Fiddling with the debugger's context could be Bad. We insulate things as 594# much as we can. 595 596sub eval { 597 598 # 'my' would make it visible from user code 599 # but so does local! --tchrist 600 # Remember: this localizes @DB::res, not @main::res. 601 local @res; 602 { 603 # Try to keep the user code from messing with us. Save these so that 604 # even if the eval'ed code changes them, we can put them back again. 605 # Needed because the user could refer directly to the debugger's 606 # package globals (and any 'my' variables in this containing scope) 607 # inside the eval(), and we want to try to stay safe. 608 local $otrace = $trace; 609 local $osingle = $single; 610 local $od = $^D; 611 612 # Untaint the incoming eval() argument. 613 { ($evalarg) = $evalarg =~ /(.*)/s; } 614 615 # $usercontext built in DB::DB near the comment 616 # "set up the context for DB::eval ..." 617 # Evaluate and save any results. 618 @res = 619 eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug 620 621 # Restore those old values. 622 $trace = $otrace; 623 $single = $osingle; 624 $^D = $od; 625 } 626 627 # Save the current value of $@, and preserve it in the debugger's copy 628 # of the saved precious globals. 629 my $at = $@; 630 631 # Since we're only saving $@, we only have to localize the array element 632 # that it will be stored in. 633 local $saved[0]; # Preserve the old value of $@ 634 eval { &DB::save }; 635 636 # Now see whether we need to report an error back to the user. 637 if ($at) { 638 local $\ = ''; 639 print $OUT $at; 640 } 641 642 # Display as required by the caller. $onetimeDump and $onetimedumpDepth 643 # are package globals. 644 elsif ($onetimeDump) { 645 if ($onetimeDump eq 'dump') { 646 local $option{dumpDepth} = $onetimedumpDepth 647 if defined $onetimedumpDepth; 648 dumpit($OUT, \@res); 649 } 650 elsif ($onetimeDump eq 'methods') { 651 methods($res[0]); 652 } 653 } ## end elsif ($onetimeDump) 654 @res; 655} ## end sub eval 656 657############################################## End lexical danger zone 658 659# After this point it is safe to introduce lexicals. 660# The code being debugged will be executing in its own context, and 661# can't see the inside of the debugger. 662# 663# However, one should not overdo it: leave as much control from outside as 664# possible. If you make something a lexical, it's not going to be addressable 665# from outside the debugger even if you know its name. 666 667# This file is automatically included if you do perl -d. 668# It's probably not useful to include this yourself. 669# 670# Before venturing further into these twisty passages, it is 671# wise to read the perldebguts man page or risk the ire of dragons. 672# 673# (It should be noted that perldebguts will tell you a lot about 674# the underlying mechanics of how the debugger interfaces into the 675# Perl interpreter, but not a lot about the debugger itself. The new 676# comments in this code try to address this problem.) 677 678# Note that no subroutine call is possible until &DB::sub is defined 679# (for subroutines defined outside of the package DB). In fact the same is 680# true if $deep is not defined. 681# 682# $Log: perldb.pl,v $ 683 684# Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich) 685 686# modified Perl debugger, to be run from Emacs in perldb-mode 687# Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990 688# Johan Vromans -- upgrade to 4.0 pl 10 689# Ilya Zakharevich -- patches after 5.001 (and some before ;-) 690 691# (We have made efforts to clarify the comments in the change log 692# in other places; some of them may seem somewhat obscure as they 693# were originally written, and explaining them away from the code 694# in question seems conterproductive.. -JM) 695 696######################################################################## 697# Changes: 0.94 698# + A lot of things changed after 0.94. First of all, core now informs 699# debugger about entry into XSUBs, overloaded operators, tied operations, 700# BEGIN and END. Handy with `O f=2'. 701# + This can make debugger a little bit too verbose, please be patient 702# and report your problems promptly. 703# + Now the option frame has 3 values: 0,1,2. XXX Document! 704# + Note that if DESTROY returns a reference to the object (or object), 705# the deletion of data may be postponed until the next function call, 706# due to the need to examine the return value. 707# 708# Changes: 0.95 709# + `v' command shows versions. 710# 711# Changes: 0.96 712# + `v' command shows version of readline. 713# primitive completion works (dynamic variables, subs for `b' and `l', 714# options). Can `p %var' 715# + Better help (`h <' now works). New commands <<, >>, {, {{. 716# {dump|print}_trace() coded (to be able to do it from <<cmd). 717# + `c sub' documented. 718# + At last enough magic combined to stop after the end of debuggee. 719# + !! should work now (thanks to Emacs bracket matching an extra 720# `]' in a regexp is caught). 721# + `L', `D' and `A' span files now (as documented). 722# + Breakpoints in `require'd code are possible (used in `R'). 723# + Some additional words on internal work of debugger. 724# + `b load filename' implemented. 725# + `b postpone subr' implemented. 726# + now only `q' exits debugger (overwritable on $inhibit_exit). 727# + When restarting debugger breakpoints/actions persist. 728# + Buglet: When restarting debugger only one breakpoint/action per 729# autoloaded function persists. 730# 731# Changes: 0.97: NonStop will not stop in at_exit(). 732# + Option AutoTrace implemented. 733# + Trace printed differently if frames are printed too. 734# + new `inhibitExit' option. 735# + printing of a very long statement interruptible. 736# Changes: 0.98: New command `m' for printing possible methods 737# + 'l -' is a synonym for `-'. 738# + Cosmetic bugs in printing stack trace. 739# + `frame' & 8 to print "expanded args" in stack trace. 740# + Can list/break in imported subs. 741# + new `maxTraceLen' option. 742# + frame & 4 and frame & 8 granted. 743# + new command `m' 744# + nonstoppable lines do not have `:' near the line number. 745# + `b compile subname' implemented. 746# + Will not use $` any more. 747# + `-' behaves sane now. 748# Changes: 0.99: Completion for `f', `m'. 749# + `m' will remove duplicate names instead of duplicate functions. 750# + `b load' strips trailing whitespace. 751# completion ignores leading `|'; takes into account current package 752# when completing a subroutine name (same for `l'). 753# Changes: 1.07: Many fixed by tchrist 13-March-2000 754# BUG FIXES: 755# + Added bare minimal security checks on perldb rc files, plus 756# comments on what else is needed. 757# + Fixed the ornaments that made "|h" completely unusable. 758# They are not used in print_help if they will hurt. Strip pod 759# if we're paging to less. 760# + Fixed mis-formatting of help messages caused by ornaments 761# to restore Larry's original formatting. 762# + Fixed many other formatting errors. The code is still suboptimal, 763# and needs a lot of work at restructuring. It's also misindented 764# in many places. 765# + Fixed bug where trying to look at an option like your pager 766# shows "1". 767# + Fixed some $? processing. Note: if you use csh or tcsh, you will 768# lose. You should consider shell escapes not using their shell, 769# or else not caring about detailed status. This should really be 770# unified into one place, too. 771# + Fixed bug where invisible trailing whitespace on commands hoses you, 772# tricking Perl into thinking you weren't calling a debugger command! 773# + Fixed bug where leading whitespace on commands hoses you. (One 774# suggests a leading semicolon or any other irrelevant non-whitespace 775# to indicate literal Perl code.) 776# + Fixed bugs that ate warnings due to wrong selected handle. 777# + Fixed a precedence bug on signal stuff. 778# + Fixed some unseemly wording. 779# + Fixed bug in help command trying to call perl method code. 780# + Fixed to call dumpvar from exception handler. SIGPIPE killed us. 781# ENHANCEMENTS: 782# + Added some comments. This code is still nasty spaghetti. 783# + Added message if you clear your pre/post command stacks which was 784# very easy to do if you just typed a bare >, <, or {. (A command 785# without an argument should *never* be a destructive action; this 786# API is fundamentally screwed up; likewise option setting, which 787# is equally buggered.) 788# + Added command stack dump on argument of "?" for >, <, or {. 789# + Added a semi-built-in doc viewer command that calls man with the 790# proper %Config::Config path (and thus gets caching, man -k, etc), 791# or else perldoc on obstreperous platforms. 792# + Added to and rearranged the help information. 793# + Detected apparent misuse of { ... } to declare a block; this used 794# to work but now is a command, and mysteriously gave no complaint. 795# 796# Changes: 1.08: Apr 25, 2001 Jon Eveland <jweveland@yahoo.com> 797# BUG FIX: 798# + This patch to perl5db.pl cleans up formatting issues on the help 799# summary (h h) screen in the debugger. Mostly columnar alignment 800# issues, plus converted the printed text to use all spaces, since 801# tabs don't seem to help much here. 802# 803# Changes: 1.09: May 19, 2001 Ilya Zakharevich <ilya@math.ohio-state.edu> 804# Minor bugs corrected; 805# + Support for auto-creation of new TTY window on startup, either 806# unconditionally, or if started as a kid of another debugger session; 807# + New `O'ption CreateTTY 808# I<CreateTTY> bits control attempts to create a new TTY on events: 809# 1: on fork() 810# 2: debugger is started inside debugger 811# 4: on startup 812# + Code to auto-create a new TTY window on OS/2 (currently one 813# extra window per session - need named pipes to have more...); 814# + Simplified interface for custom createTTY functions (with a backward 815# compatibility hack); now returns the TTY name to use; return of '' 816# means that the function reset the I/O handles itself; 817# + Better message on the semantic of custom createTTY function; 818# + Convert the existing code to create a TTY into a custom createTTY 819# function; 820# + Consistent support for TTY names of the form "TTYin,TTYout"; 821# + Switch line-tracing output too to the created TTY window; 822# + make `b fork' DWIM with CORE::GLOBAL::fork; 823# + High-level debugger API cmd_*(): 824# cmd_b_load($filenamepart) # b load filenamepart 825# cmd_b_line($lineno [, $cond]) # b lineno [cond] 826# cmd_b_sub($sub [, $cond]) # b sub [cond] 827# cmd_stop() # Control-C 828# cmd_d($lineno) # d lineno (B) 829# The cmd_*() API returns FALSE on failure; in this case it outputs 830# the error message to the debugging output. 831# + Low-level debugger API 832# break_on_load($filename) # b load filename 833# @files = report_break_on_load() # List files with load-breakpoints 834# breakable_line_in_filename($name, $from [, $to]) 835# # First breakable line in the 836# # range $from .. $to. $to defaults 837# # to $from, and may be less than 838# # $to 839# breakable_line($from [, $to]) # Same for the current file 840# break_on_filename_line($name, $lineno [, $cond]) 841# # Set breakpoint,$cond defaults to 842# # 1 843# break_on_filename_line_range($name, $from, $to [, $cond]) 844# # As above, on the first 845# # breakable line in range 846# break_on_line($lineno [, $cond]) # As above, in the current file 847# break_subroutine($sub [, $cond]) # break on the first breakable line 848# ($name, $from, $to) = subroutine_filename_lines($sub) 849# # The range of lines of the text 850# The low-level API returns TRUE on success, and die()s on failure. 851# 852# Changes: 1.10: May 23, 2001 Daniel Lewart <d-lewart@uiuc.edu> 853# BUG FIXES: 854# + Fixed warnings generated by "perl -dWe 42" 855# + Corrected spelling errors 856# + Squeezed Help (h) output into 80 columns 857# 858# Changes: 1.11: May 24, 2001 David Dyck <dcd@tc.fluke.com> 859# + Made "x @INC" work like it used to 860# 861# Changes: 1.12: May 24, 2001 Daniel Lewart <d-lewart@uiuc.edu> 862# + Fixed warnings generated by "O" (Show debugger options) 863# + Fixed warnings generated by "p 42" (Print expression) 864# Changes: 1.13: Jun 19, 2001 Scott.L.Miller@compaq.com 865# + Added windowSize option 866# Changes: 1.14: Oct 9, 2001 multiple 867# + Clean up after itself on VMS (Charles Lane in 12385) 868# + Adding "@ file" syntax (Peter Scott in 12014) 869# + Debug reloading selfloaded stuff (Ilya Zakharevich in 11457) 870# + $^S and other debugger fixes (Ilya Zakharevich in 11120) 871# + Forgot a my() declaration (Ilya Zakharevich in 11085) 872# Changes: 1.15: Nov 6, 2001 Michael G Schwern <schwern@pobox.com> 873# + Updated 1.14 change log 874# + Added *dbline explainatory comments 875# + Mentioning perldebguts man page 876# Changes: 1.16: Feb 15, 2002 Mark-Jason Dominus <mjd@plover.com> 877# + $onetimeDump improvements 878# Changes: 1.17: Feb 20, 2002 Richard Foley <richard.foley@rfi.net> 879# Moved some code to cmd_[.]()'s for clarity and ease of handling, 880# rationalised the following commands and added cmd_wrapper() to 881# enable switching between old and frighteningly consistent new 882# behaviours for diehards: 'o CommandSet=pre580' (sigh...) 883# a(add), A(del) # action expr (added del by line) 884# + b(add), B(del) # break [line] (was b,D) 885# + w(add), W(del) # watch expr (was W,W) 886# # added del by expr 887# + h(summary), h h(long) # help (hh) (was h h,h) 888# + m(methods), M(modules) # ... (was m,v) 889# + o(option) # lc (was O) 890# + v(view code), V(view Variables) # ... (was w,V) 891# Changes: 1.18: Mar 17, 2002 Richard Foley <richard.foley@rfi.net> 892# + fixed missing cmd_O bug 893# Changes: 1.19: Mar 29, 2002 Spider Boardman 894# + Added missing local()s -- DB::DB is called recursively. 895# Changes: 1.20: Feb 17, 2003 Richard Foley <richard.foley@rfi.net> 896# + pre'n'post commands no longer trashed with no args 897# + watch val joined out of eval() 898# Changes: 1.21: Jun 04, 2003 Joe McMahon <mcmahon@ibiblio.org> 899# + Added comments and reformatted source. No bug fixes/enhancements. 900# + Includes cleanup by Robin Barker and Jarkko Hietaniemi. 901# Changes: 1.22 Jun 09, 2003 Alex Vandiver <alexmv@MIT.EDU> 902# + Flush stdout/stderr before the debugger prompt is printed. 903# Changes: 1.23: Dec 21, 2003 Dominique Quatravaux 904# + Fix a side-effect of bug #24674 in the perl debugger ("odd taint bug") 905# Changes: 1.24: Mar 03, 2004 Richard Foley <richard.foley@rfi.net> 906# + Added command to save all debugger commands for sourcing later. 907# + Added command to display parent inheritence tree of given class. 908# + Fixed minor newline in history bug. 909# Changes: 1.25: Apr 17, 2004 Richard Foley <richard.foley@rfi.net> 910# + Fixed option bug (setting invalid options + not recognising valid short forms) 911#################################################################### 912 913=head1 DEBUGGER INITIALIZATION 914 915The debugger starts up in phases. 916 917=head2 BASIC SETUP 918 919First, it initializes the environment it wants to run in: turning off 920warnings during its own compilation, defining variables which it will need 921to avoid warnings later, setting itself up to not exit when the program 922terminates, and defaulting to printing return values for the C<r> command. 923 924=cut 925 926# Needed for the statement after exec(): 927# 928# This BEGIN block is simply used to switch off warnings during debugger 929# compiliation. Probably it would be better practice to fix the warnings, 930# but this is how it's done at the moment. 931 932BEGIN { 933 $ini_warn = $^W; 934 $^W = 0; 935} # Switch compilation warnings off until another BEGIN. 936 937local ($^W) = 0; # Switch run-time warnings off during init. 938 939# This would probably be better done with "use vars", but that wasn't around 940# when this code was originally written. (Neither was "use strict".) And on 941# the principle of not fiddling with something that was working, this was 942# left alone. 943warn( # Do not ;-) 944 # These variables control the execution of 'dumpvar.pl'. 945 $dumpvar::hashDepth, 946 $dumpvar::arrayDepth, 947 $dumpvar::dumpDBFiles, 948 $dumpvar::dumpPackages, 949 $dumpvar::quoteHighBit, 950 $dumpvar::printUndef, 951 $dumpvar::globPrint, 952 $dumpvar::usageOnly, 953 954 # used to save @ARGV and extract any debugger-related flags. 955 @ARGS, 956 957 # used to control die() reporting in diesignal() 958 $Carp::CarpLevel, 959 960 # used to prevent multiple entries to diesignal() 961 # (if for instance diesignal() itself dies) 962 $panic, 963 964 # used to prevent the debugger from running nonstop 965 # after a restart 966 $second_time, 967 ) 968 if 0; 969 970# Command-line + PERLLIB: 971# Save the contents of @INC before they are modified elsewhere. 972@ini_INC = @INC; 973 974# This was an attempt to clear out the previous values of various 975# trapped errors. Apparently it didn't help. XXX More info needed! 976# $prevwarn = $prevdie = $prevbus = $prevsegv = ''; # Does not help?! 977 978# We set these variables to safe values. We don't want to blindly turn 979# off warnings, because other packages may still want them. 980$trace = $signal = $single = 0; # Uninitialized warning suppression 981 # (local $^W cannot help - other packages!). 982 983# Default to not exiting when program finishes; print the return 984# value when the 'r' command is used to return from a subroutine. 985$inhibit_exit = $option{PrintRet} = 1; 986 987=head1 OPTION PROCESSING 988 989The debugger's options are actually spread out over the debugger itself and 990C<dumpvar.pl>; some of these are variables to be set, while others are 991subs to be called with a value. To try to make this a little easier to 992manage, the debugger uses a few data structures to define what options 993are legal and how they are to be processed. 994 995First, the C<@options> array defines the I<names> of all the options that 996are to be accepted. 997 998=cut 999 1000@options = qw( 1001 CommandSet 1002 hashDepth arrayDepth dumpDepth 1003 DumpDBFiles DumpPackages DumpReused 1004 compactDump veryCompact quote 1005 HighBit undefPrint globPrint 1006 PrintRet UsageOnly frame 1007 AutoTrace TTY noTTY 1008 ReadLine NonStop LineInfo 1009 maxTraceLen recallCommand ShellBang 1010 pager tkRunning ornaments 1011 signalLevel warnLevel dieLevel 1012 inhibit_exit ImmediateStop bareStringify 1013 CreateTTY RemotePort windowSize 1014 ); 1015 1016=pod 1017 1018Second, C<optionVars> lists the variables that each option uses to save its 1019state. 1020 1021=cut 1022 1023%optionVars = ( 1024 hashDepth => \$dumpvar::hashDepth, 1025 arrayDepth => \$dumpvar::arrayDepth, 1026 CommandSet => \$CommandSet, 1027 DumpDBFiles => \$dumpvar::dumpDBFiles, 1028 DumpPackages => \$dumpvar::dumpPackages, 1029 DumpReused => \$dumpvar::dumpReused, 1030 HighBit => \$dumpvar::quoteHighBit, 1031 undefPrint => \$dumpvar::printUndef, 1032 globPrint => \$dumpvar::globPrint, 1033 UsageOnly => \$dumpvar::usageOnly, 1034 CreateTTY => \$CreateTTY, 1035 bareStringify => \$dumpvar::bareStringify, 1036 frame => \$frame, 1037 AutoTrace => \$trace, 1038 inhibit_exit => \$inhibit_exit, 1039 maxTraceLen => \$maxtrace, 1040 ImmediateStop => \$ImmediateStop, 1041 RemotePort => \$remoteport, 1042 windowSize => \$window, 1043 ); 1044 1045=pod 1046 1047Third, C<%optionAction> defines the subroutine to be called to process each 1048option. 1049 1050=cut 1051 1052%optionAction = ( 1053 compactDump => \&dumpvar::compactDump, 1054 veryCompact => \&dumpvar::veryCompact, 1055 quote => \&dumpvar::quote, 1056 TTY => \&TTY, 1057 noTTY => \&noTTY, 1058 ReadLine => \&ReadLine, 1059 NonStop => \&NonStop, 1060 LineInfo => \&LineInfo, 1061 recallCommand => \&recallCommand, 1062 ShellBang => \&shellBang, 1063 pager => \&pager, 1064 signalLevel => \&signalLevel, 1065 warnLevel => \&warnLevel, 1066 dieLevel => \&dieLevel, 1067 tkRunning => \&tkRunning, 1068 ornaments => \&ornaments, 1069 RemotePort => \&RemotePort, 1070 ); 1071 1072=pod 1073 1074Last, the C<%optionRequire> notes modules that must be C<require>d if an 1075option is used. 1076 1077=cut 1078 1079# Note that this list is not complete: several options not listed here 1080# actually require that dumpvar.pl be loaded for them to work, but are 1081# not in the table. A subsequent patch will correct this problem; for 1082# the moment, we're just recommenting, and we are NOT going to change 1083# function. 1084%optionRequire = ( 1085 compactDump => 'dumpvar.pl', 1086 veryCompact => 'dumpvar.pl', 1087 quote => 'dumpvar.pl', 1088 ); 1089 1090=pod 1091 1092There are a number of initialization-related variables which can be set 1093by putting code to set them in a BEGIN block in the C<PERL5DB> environment 1094variable. These are: 1095 1096=over 4 1097 1098=item C<$rl> - readline control XXX needs more explanation 1099 1100=item C<$warnLevel> - whether or not debugger takes over warning handling 1101 1102=item C<$dieLevel> - whether or not debugger takes over die handling 1103 1104=item C<$signalLevel> - whether or not debugger takes over signal handling 1105 1106=item C<$pre> - preprompt actions (array reference) 1107 1108=item C<$post> - postprompt actions (array reference) 1109 1110=item C<$pretype> 1111 1112=item C<$CreateTTY> - whether or not to create a new TTY for this debugger 1113 1114=item C<$CommandSet> - which command set to use (defaults to new, documented set) 1115 1116=back 1117 1118=cut 1119 1120# These guys may be defined in $ENV{PERL5DB} : 1121$rl = 1 unless defined $rl; 1122$warnLevel = 1 unless defined $warnLevel; 1123$dieLevel = 1 unless defined $dieLevel; 1124$signalLevel = 1 unless defined $signalLevel; 1125$pre = [] unless defined $pre; 1126$post = [] unless defined $post; 1127$pretype = [] unless defined $pretype; 1128$CreateTTY = 3 unless defined $CreateTTY; 1129$CommandSet = '580' unless defined $CommandSet; 1130 1131=pod 1132 1133The default C<die>, C<warn>, and C<signal> handlers are set up. 1134 1135=cut 1136 1137warnLevel($warnLevel); 1138dieLevel($dieLevel); 1139signalLevel($signalLevel); 1140 1141=pod 1142 1143The pager to be used is needed next. We try to get it from the 1144environment first. if it's not defined there, we try to find it in 1145the Perl C<Config.pm>. If it's not there, we default to C<more>. We 1146then call the C<pager()> function to save the pager name. 1147 1148=cut 1149 1150# This routine makes sure $pager is set up so that '|' can use it. 1151pager( 1152 # If PAGER is defined in the environment, use it. 1153 defined $ENV{PAGER} 1154 ? $ENV{PAGER} 1155 1156 # If not, see if Config.pm defines it. 1157 : eval { require Config } && defined $Config::Config{pager} 1158 ? $Config::Config{pager} 1159 1160 # If not, fall back to 'more'. 1161 : 'more' 1162 ) 1163 unless defined $pager; 1164 1165=pod 1166 1167We set up the command to be used to access the man pages, the command 1168recall character ("!" unless otherwise defined) and the shell escape 1169character ("!" unless otherwise defined). Yes, these do conflict, and 1170neither works in the debugger at the moment. 1171 1172=cut 1173 1174setman(); 1175 1176# Set up defaults for command recall and shell escape (note: 1177# these currently don't work in linemode debugging). 1178&recallCommand("!") unless defined $prc; 1179&shellBang("!") unless defined $psh; 1180 1181=pod 1182 1183We then set up the gigantic string containing the debugger help. 1184We also set the limit on the number of arguments we'll display during a 1185trace. 1186 1187=cut 1188 1189sethelp(); 1190 1191# If we didn't get a default for the length of eval/stack trace args, 1192# set it here. 1193$maxtrace = 400 unless defined $maxtrace; 1194 1195=head2 SETTING UP THE DEBUGGER GREETING 1196 1197The debugger 'greeting' helps to inform the user how many debuggers are 1198running, and whether the current debugger is the primary or a child. 1199 1200If we are the primary, we just hang onto our pid so we'll have it when 1201or if we start a child debugger. If we are a child, we'll set things up 1202so we'll have a unique greeting and so the parent will give us our own 1203TTY later. 1204 1205We save the current contents of the C<PERLDB_PIDS> environment variable 1206because we mess around with it. We'll also need to hang onto it because 1207we'll need it if we restart. 1208 1209Child debuggers make a label out of the current PID structure recorded in 1210PERLDB_PIDS plus the new PID. They also mark themselves as not having a TTY 1211yet so the parent will give them one later via C<resetterm()>. 1212 1213=cut 1214 1215# Save the current contents of the environment; we're about to 1216# much with it. We'll need this if we have to restart. 1217$ini_pids = $ENV{PERLDB_PIDS}; 1218 1219if (defined $ENV{PERLDB_PIDS}) { 1220 # We're a child. Make us a label out of the current PID structure 1221 # recorded in PERLDB_PIDS plus our (new) PID. Mark us as not having 1222 # a term yet so the parent will give us one later via resetterm(). 1223 $pids = "[$ENV{PERLDB_PIDS}]"; 1224 $ENV{PERLDB_PIDS} .= "->$$"; 1225 $term_pid = -1; 1226} ## end if (defined $ENV{PERLDB_PIDS... 1227else { 1228 # We're the parent PID. Initialize PERLDB_PID in case we end up with a 1229 # child debugger, and mark us as the parent, so we'll know to set up 1230 # more TTY's is we have to. 1231 $ENV{PERLDB_PIDS} = "$$"; 1232 $pids = "{pid=$$}"; 1233 $term_pid = $$; 1234} 1235 1236$pidprompt = ''; 1237 1238# Sets up $emacs as a synonym for $slave_editor. 1239*emacs = $slave_editor if $slave_editor; # May be used in afterinit()... 1240 1241=head2 READING THE RC FILE 1242 1243The debugger will read a file of initialization options if supplied. If 1244running interactively, this is C<.perldb>; if not, it's C<perldb.ini>. 1245 1246=cut 1247 1248# As noted, this test really doesn't check accurately that the debugger 1249# is running at a terminal or not. 1250if (-e "/dev/tty") { # this is the wrong metric! 1251 $rcfile = ".perldb"; 1252} 1253else { 1254 $rcfile = "perldb.ini"; 1255} 1256 1257=pod 1258 1259The debugger does a safety test of the file to be read. It must be owned 1260either by the current user or root, and must only be writable by the owner. 1261 1262=cut 1263 1264# This wraps a safety test around "do" to read and evaluate the init file. 1265# 1266# This isn't really safe, because there's a race 1267# between checking and opening. The solution is to 1268# open and fstat the handle, but then you have to read and 1269# eval the contents. But then the silly thing gets 1270# your lexical scope, which is unfortunate at best. 1271sub safe_do { 1272 my $file = shift; 1273 1274 # Just exactly what part of the word "CORE::" don't you understand? 1275 local $SIG{__WARN__}; 1276 local $SIG{__DIE__}; 1277 1278 unless (is_safe_file($file)) { 1279 CORE::warn <<EO_GRIPE; 1280perldb: Must not source insecure rcfile $file. 1281 You or the superuser must be the owner, and it must not 1282 be writable by anyone but its owner. 1283EO_GRIPE 1284 return; 1285 } ## end unless (is_safe_file($file... 1286 1287 do $file; 1288 CORE::warn("perldb: couldn't parse $file: $@") if $@; 1289} ## end sub safe_do 1290 1291# This is the safety test itself. 1292# 1293# Verifies that owner is either real user or superuser and that no 1294# one but owner may write to it. This function is of limited use 1295# when called on a path instead of upon a handle, because there are 1296# no guarantees that filename (by dirent) whose file (by ino) is 1297# eventually accessed is the same as the one tested. 1298# Assumes that the file's existence is not in doubt. 1299sub is_safe_file { 1300 my $path = shift; 1301 stat($path) || return; # mysteriously vaporized 1302 my ($dev, $ino, $mode, $nlink, $uid, $gid) = stat(_); 1303 1304 return 0 if $uid != 0 && $uid != $<; 1305 return 0 if $mode & 022; 1306 return 1; 1307} ## end sub is_safe_file 1308 1309# If the rcfile (whichever one we decided was the right one to read) 1310# exists, we safely do it. 1311if (-f $rcfile) { 1312 safe_do("./$rcfile"); 1313} 1314# If there isn't one here, try the user's home directory. 1315elsif (defined $ENV{HOME} && -f "$ENV{HOME}/$rcfile") { 1316 safe_do("$ENV{HOME}/$rcfile"); 1317} 1318# Else try the login directory. 1319elsif (defined $ENV{LOGDIR} && -f "$ENV{LOGDIR}/$rcfile") { 1320 safe_do("$ENV{LOGDIR}/$rcfile"); 1321} 1322 1323# If the PERLDB_OPTS variable has options in it, parse those out next. 1324if (defined $ENV{PERLDB_OPTS}) { 1325 parse_options($ENV{PERLDB_OPTS}); 1326} 1327 1328=pod 1329 1330The last thing we do during initialization is determine which subroutine is 1331to be used to obtain a new terminal when a new debugger is started. Right now, 1332the debugger only handles X Windows and OS/2. 1333 1334=cut 1335 1336# Set up the get_fork_TTY subroutine to be aliased to the proper routine. 1337# Works if you're running an xterm or xterm-like window, or you're on 1338# OS/2. This may need some expansion: for instance, this doesn't handle 1339# OS X Terminal windows. 1340 1341if (not defined &get_fork_TTY # no routine exists, 1342 and defined $ENV{TERM} # and we know what kind 1343 # of terminal this is, 1344 and $ENV{TERM} eq 'xterm' # and it's an xterm, 1345 and defined $ENV{WINDOWID} # and we know what 1346 # window this is, 1347 and defined $ENV{DISPLAY}) # and what display it's 1348 # on, 1349{ 1350 *get_fork_TTY = \&xterm_get_fork_TTY; # use the xterm version 1351} ## end if (not defined &get_fork_TTY... 1352elsif ($^O eq 'os2') { # If this is OS/2, 1353 *get_fork_TTY = \&os2_get_fork_TTY; # use the OS/2 version 1354} 1355# untaint $^O, which may have been tainted by the last statement. 1356# see bug [perl #24674] 1357$^O =~ m/^(.*)\z/; $^O = $1; 1358 1359# "Here begin the unreadable code. It needs fixing." 1360 1361=head2 RESTART PROCESSING 1362 1363This section handles the restart command. When the C<R> command is invoked, it 1364tries to capture all of the state it can into environment variables, and 1365then sets C<PERLDB_RESTART>. When we start executing again, we check to see 1366if C<PERLDB_RESTART> is there; if so, we reload all the information that 1367the R command stuffed into the environment variables. 1368 1369 PERLDB_RESTART - flag only, contains no restart data itself. 1370 PERLDB_HIST - command history, if it's available 1371 PERLDB_ON_LOAD - breakpoints set by the rc file 1372 PERLDB_POSTPONE - subs that have been loaded/not executed, and have actions 1373 PERLDB_VISITED - files that had breakpoints 1374 PERLDB_FILE_... - breakpoints for a file 1375 PERLDB_OPT - active options 1376 PERLDB_INC - the original @INC 1377 PERLDB_PRETYPE - preprompt debugger actions 1378 PERLDB_PRE - preprompt Perl code 1379 PERLDB_POST - post-prompt Perl code 1380 PERLDB_TYPEAHEAD - typeahead captured by readline() 1381 1382We chug through all these variables and plug the values saved in them 1383back into the appropriate spots in the debugger. 1384 1385=cut 1386 1387if (exists $ENV{PERLDB_RESTART}) { 1388 # We're restarting, so we don't need the flag that says to restart anymore. 1389 delete $ENV{PERLDB_RESTART}; 1390 # $restart = 1; 1391 @hist = get_list('PERLDB_HIST'); 1392 %break_on_load = get_list("PERLDB_ON_LOAD"); 1393 %postponed = get_list("PERLDB_POSTPONE"); 1394 1395 # restore breakpoints/actions 1396 my @had_breakpoints = get_list("PERLDB_VISITED"); 1397 for (0 .. $#had_breakpoints) { 1398 my %pf = get_list("PERLDB_FILE_$_"); 1399 $postponed_file{ $had_breakpoints[$_] } = \%pf if %pf; 1400 } 1401 1402 # restore options 1403 my %opt = get_list("PERLDB_OPT"); 1404 my ($opt, $val); 1405 while (($opt, $val) = each %opt) { 1406 $val =~ s/[\\\']/\\$1/g; 1407 parse_options("$opt'$val'"); 1408 } 1409 1410 # restore original @INC 1411 @INC = get_list("PERLDB_INC"); 1412 @ini_INC = @INC; 1413 1414 # return pre/postprompt actions and typeahead buffer 1415 $pretype = [get_list("PERLDB_PRETYPE")]; 1416 $pre = [get_list("PERLDB_PRE")]; 1417 $post = [get_list("PERLDB_POST")]; 1418 @typeahead = get_list("PERLDB_TYPEAHEAD", @typeahead); 1419} ## end if (exists $ENV{PERLDB_RESTART... 1420 1421=head2 SETTING UP THE TERMINAL 1422 1423Now, we'll decide how the debugger is going to interact with the user. 1424If there's no TTY, we set the debugger to run non-stop; there's not going 1425to be anyone there to enter commands. 1426 1427=cut 1428 1429if ($notty) { 1430 $runnonstop = 1; 1431} 1432 1433=pod 1434 1435If there is a TTY, we have to determine who it belongs to before we can 1436proceed. If this is a slave editor or graphical debugger (denoted by 1437the first command-line switch being '-emacs'), we shift this off and 1438set C<$rl> to 0 (XXX ostensibly to do straight reads). 1439 1440=cut 1441 1442else { 1443 # Is Perl being run from a slave editor or graphical debugger? 1444 # If so, don't use readline, and set $slave_editor = 1. 1445 $slave_editor = 1446 ((defined $main::ARGV[0]) and ($main::ARGV[0] eq '-emacs')); 1447 $rl = 0, shift (@main::ARGV) if $slave_editor; 1448 #require Term::ReadLine; 1449 1450=pod 1451 1452We then determine what the console should be on various systems: 1453 1454=over 4 1455 1456=item * Cygwin - We use C<stdin> instead of a separate device. 1457 1458=cut 1459 1460 1461 if ($^O eq 'cygwin') { 1462 # /dev/tty is binary. use stdin for textmode 1463 undef $console; 1464 } 1465 1466=item * Unix - use C</dev/tty>. 1467 1468=cut 1469 1470 elsif (-e "/dev/tty") { 1471 $console = "/dev/tty"; 1472 } 1473 1474=item * Windows or MSDOS - use C<con>. 1475 1476=cut 1477 1478 elsif ($^O eq 'dos' or -e "con" or $^O eq 'MSWin32') { 1479 $console = "con"; 1480 } 1481 1482=item * MacOS - use C<Dev:Console:Perl Debug> if this is the MPW version; C<Dev: 1483Console> if not. (Note that Mac OS X returns 'darwin', not 'MacOS'. Also note that the debugger doesn't do anything special for 'darwin'. Maybe it should.) 1484 1485=cut 1486 1487 elsif ($^O eq 'MacOS') { 1488 if ($MacPerl::Version !~ /MPW/) { 1489 $console = 1490 "Dev:Console:Perl Debug"; # Separate window for application 1491 } 1492 else { 1493 $console = "Dev:Console"; 1494 } 1495 } ## end elsif ($^O eq 'MacOS') 1496 1497=item * VMS - use C<sys$command>. 1498 1499=cut 1500 1501 else { 1502 # everything else is ... 1503 $console = "sys\$command"; 1504 } 1505 1506=pod 1507 1508=back 1509 1510Several other systems don't use a specific console. We C<undef $console> 1511for those (Windows using a slave editor/graphical debugger, NetWare, OS/2 1512with a slave editor, Epoc). 1513 1514=cut 1515 1516 if (($^O eq 'MSWin32') and ($slave_editor or defined $ENV{EMACS})) { 1517 # /dev/tty is binary. use stdin for textmode 1518 $console = undef; 1519 } 1520 1521 if ($^O eq 'NetWare') { 1522 # /dev/tty is binary. use stdin for textmode 1523 $console = undef; 1524 } 1525 1526 # In OS/2, we need to use STDIN to get textmode too, even though 1527 # it pretty much looks like Unix otherwise. 1528 if (defined $ENV{OS2_SHELL} and ($slave_editor or $ENV{WINDOWID})) 1529 { # In OS/2 1530 $console = undef; 1531 } 1532 # EPOC also falls into the 'got to use STDIN' camp. 1533 if ($^O eq 'epoc') { 1534 $console = undef; 1535 } 1536 1537=pod 1538 1539If there is a TTY hanging around from a parent, we use that as the console. 1540 1541=cut 1542 1543 $console = $tty if defined $tty; 1544 1545=head2 SOCKET HANDLING 1546 1547The debugger is capable of opening a socket and carrying out a debugging 1548session over the socket. 1549 1550If C<RemotePort> was defined in the options, the debugger assumes that it 1551should try to start a debugging session on that port. It builds the socket 1552and then tries to connect the input and output filehandles to it. 1553 1554=cut 1555 1556 # Handle socket stuff. 1557 if (defined $remoteport) { 1558 # If RemotePort was defined in the options, connect input and output 1559 # to the socket. 1560 require IO::Socket; 1561 $OUT = new IO::Socket::INET( 1562 Timeout => '10', 1563 PeerAddr => $remoteport, 1564 Proto => 'tcp', 1565 ); 1566 if (!$OUT) { die "Unable to connect to remote host: $remoteport\n"; } 1567 $IN = $OUT; 1568 } ## end if (defined $remoteport) 1569 1570=pod 1571 1572If no C<RemotePort> was defined, and we want to create a TTY on startup, 1573this is probably a situation where multiple debuggers are running (for example, 1574a backticked command that starts up another debugger). We create a new IN and 1575OUT filehandle, and do the necessary mojo to create a new TTY if we know how 1576and if we can. 1577 1578=cut 1579 1580 # Non-socket. 1581 else { 1582 # Two debuggers running (probably a system or a backtick that invokes 1583 # the debugger itself under the running one). create a new IN and OUT 1584 # filehandle, and do the necessary mojo to create a new tty if we 1585 # know how, and we can. 1586 create_IN_OUT(4) if $CreateTTY & 4; 1587 if ($console) { 1588 # If we have a console, check to see if there are separate ins and 1589 # outs to open. (They are assumed identiical if not.) 1590 my ($i, $o) = split /,/, $console; 1591 $o = $i unless defined $o; 1592 1593 # read/write on in, or just read, or read on STDIN. 1594 open(IN, "+<$i") || 1595 open(IN, "<$i") || 1596 open(IN, "<&STDIN"); 1597 1598 # read/write/create/clobber out, or write/create/clobber out, 1599 # or merge with STDERR, or merge with STDOUT. 1600 open(OUT, "+>$o") || 1601 open(OUT, ">$o") || 1602 open(OUT, ">&STDERR") || 1603 open(OUT, ">&STDOUT"); # so we don't dongle stdout 1604 1605 } ## end if ($console) 1606 elsif (not defined $console) { 1607 # No console. Open STDIN. 1608 open(IN, "<&STDIN"); 1609 1610 # merge with STDERR, or with STDOUT. 1611 open(OUT, ">&STDERR") || 1612 open(OUT, ">&STDOUT"); # so we don't dongle stdout 1613 1614 $console = 'STDIN/OUT'; 1615 } ## end elsif (not defined $console) 1616 1617 # Keep copies of the filehandles so that when the pager runs, it 1618 # can close standard input without clobbering ours. 1619 $IN = \*IN, $OUT = \*OUT if $console or not defined $console; 1620 } ## end elsif (from if(defined $remoteport)) 1621 1622 # Unbuffer DB::OUT. We need to see responses right away. 1623 my $previous = select($OUT); 1624 $| = 1; # for DB::OUT 1625 select($previous); 1626 1627 # Line info goes to debugger output unless pointed elsewhere. 1628 # Pointing elsewhere makes it possible for slave editors to 1629 # keep track of file and position. We have both a filehandle 1630 # and a I/O description to keep track of. 1631 $LINEINFO = $OUT unless defined $LINEINFO; 1632 $lineinfo = $console unless defined $lineinfo; 1633 1634=pod 1635 1636To finish initialization, we show the debugger greeting, 1637and then call the C<afterinit()> subroutine if there is one. 1638 1639=cut 1640 1641 # Show the debugger greeting. 1642 $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/; 1643 unless ($runnonstop) { 1644 local $\ = ''; 1645 local $, = ''; 1646 if ($term_pid eq '-1') { 1647 print $OUT "\nDaughter DB session started...\n"; 1648 } 1649 else { 1650 print $OUT "\nLoading DB routines from $header\n"; 1651 print $OUT ( 1652 "Editor support ", 1653 $slave_editor ? "enabled" : "available", ".\n" 1654 ); 1655 print $OUT 1656"\nEnter h or `h h' for help, or `$doccmd perldebug' for more help.\n\n"; 1657 } ## end else [ if ($term_pid eq '-1') 1658 } ## end unless ($runnonstop) 1659} ## end else [ if ($notty) 1660 1661# XXX This looks like a bug to me. 1662# Why copy to @ARGS and then futz with @args? 1663@ARGS = @ARGV; 1664for (@args) { 1665 # Make sure backslashes before single quotes are stripped out, and 1666 # keep args unless they are numeric (XXX why?) 1667 s/\'/\\\'/g; 1668 s/(.*)/'$1'/ unless /^-?[\d.]+$/; 1669} 1670 1671# If there was an afterinit() sub defined, call it. It will get 1672# executed in our scope, so it can fiddle with debugger globals. 1673if (defined &afterinit) { # May be defined in $rcfile 1674 &afterinit(); 1675} 1676# Inform us about "Stack dump during die enabled ..." in dieLevel(). 1677$I_m_init = 1; 1678 1679############################################################ Subroutines 1680 1681=head1 SUBROUTINES 1682 1683=head2 DB 1684 1685This gigantic subroutine is the heart of the debugger. Called before every 1686statement, its job is to determine if a breakpoint has been reached, and 1687stop if so; read commands from the user, parse them, and execute 1688them, and hen send execution off to the next statement. 1689 1690Note that the order in which the commands are processed is very important; 1691some commands earlier in the loop will actually alter the C<$cmd> variable 1692to create other commands to be executed later. This is all highly "optimized" 1693but can be confusing. Check the comments for each C<$cmd ... && do {}> to 1694see what's happening in any given command. 1695 1696=cut 1697 1698sub DB { 1699 1700 # Check for whether we should be running continuously or not. 1701 # _After_ the perl program is compiled, $single is set to 1: 1702 if ($single and not $second_time++) { 1703 # Options say run non-stop. Run until we get an interrupt. 1704 if ($runnonstop) { # Disable until signal 1705 # If there's any call stack in place, turn off single 1706 # stepping into subs throughout the stack. 1707 for ($i = 0 ; $i <= $stack_depth ;) { 1708 $stack[$i++] &= ~1; 1709 } 1710 # And we are now no longer in single-step mode. 1711 $single = 0; 1712 1713 # If we simply returned at this point, we wouldn't get 1714 # the trace info. Fall on through. 1715 # return; 1716 } ## end if ($runnonstop) 1717 1718 elsif ($ImmediateStop) { 1719 # We are supposed to stop here; XXX probably a break. 1720 $ImmediateStop = 0; # We've processed it; turn it off 1721 $signal = 1; # Simulate an interrupt to force 1722 # us into the command loop 1723 } 1724 } ## end if ($single and not $second_time... 1725 1726 # If we're in single-step mode, or an interrupt (real or fake) 1727 # has occurred, turn off non-stop mode. 1728 $runnonstop = 0 if $single or $signal; 1729 1730 # Preserve current values of $@, $!, $^E, $,, $/, $\, $^W. 1731 # The code being debugged may have altered them. 1732 &save; 1733 1734 # Since DB::DB gets called after every line, we can use caller() to 1735 # figure out where we last were executing. Sneaky, eh? This works because 1736 # caller is returning all the extra information when called from the 1737 # debugger. 1738 local ($package, $filename, $line) = caller; 1739 local $filename_ini = $filename; 1740 1741 # set up the context for DB::eval, so it can properly execute 1742 # code on behalf of the user. We add the package in so that the 1743 # code is eval'ed in the proper package (not in the debugger!). 1744 local $usercontext = 1745 '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' . 1746 "package $package;"; 1747 1748 # Create an alias to the active file magical array to simplify 1749 # the code here. 1750 local (*dbline) = $main::{ '_<' . $filename }; 1751 1752 # we need to check for pseudofiles on Mac OS (these are files 1753 # not attached to a filename, but instead stored in Dev:Pseudo) 1754 if ($^O eq 'MacOS' && $#dbline < 0) { 1755 $filename_ini = $filename = 'Dev:Pseudo'; 1756 *dbline = $main::{ '_<' . $filename }; 1757 } 1758 1759 # Last line in the program. 1760 local $max = $#dbline; 1761 1762 # if we have something here, see if we should break. 1763 if ($dbline{$line} && (($stop, $action) = split (/\0/, $dbline{$line}))) { 1764 # Stop if the stop criterion says to just stop. 1765 if ($stop eq '1') { 1766 $signal |= 1; 1767 } 1768 # It's a conditional stop; eval it in the user's context and 1769 # see if we should stop. If so, remove the one-time sigil. 1770 elsif ($stop) { 1771 $evalarg = "\$DB::signal |= 1 if do {$stop}"; 1772 &eval; 1773 $dbline{$line} =~ s/;9($|\0)/$1/; 1774 } 1775 } ## end if ($dbline{$line} && ... 1776 1777 # Preserve the current stop-or-not, and see if any of the W 1778 # (watch expressions) has changed. 1779 my $was_signal = $signal; 1780 1781 # If we have any watch expressions ... 1782 if ($trace & 2) { 1783 for (my $n = 0 ; $n <= $#to_watch ; $n++) { 1784 $evalarg = $to_watch[$n]; 1785 local $onetimeDump; # Tell DB::eval() to not output results 1786 1787 # Fix context DB::eval() wants to return an array, but 1788 # we need a scalar here. 1789 my ($val) = 1790 join ( "', '", &eval ); 1791 $val = ((defined $val) ? "'$val'" : 'undef'); 1792 1793 # Did it change? 1794 if ($val ne $old_watch[$n]) { 1795 # Yep! Show the difference, and fake an interrupt. 1796 $signal = 1; 1797 print $OUT <<EOP; 1798Watchpoint $n:\t$to_watch[$n] changed: 1799 old value:\t$old_watch[$n] 1800 new value:\t$val 1801EOP 1802 $old_watch[$n] = $val; 1803 } ## end if ($val ne $old_watch... 1804 } ## end for (my $n = 0 ; $n <= ... 1805 } ## end if ($trace & 2) 1806 1807=head2 C<watchfunction()> 1808 1809C<watchfunction()> is a function that can be defined by the user; it is a 1810function which will be run on each entry to C<DB::DB>; it gets the 1811current package, filename, and line as its parameters. 1812 1813The watchfunction can do anything it likes; it is executing in the 1814debugger's context, so it has access to all of the debugger's internal 1815data structures and functions. 1816 1817C<watchfunction()> can control the debugger's actions. Any of the following 1818will cause the debugger to return control to the user's program after 1819C<watchfunction()> executes: 1820 1821=over 4 1822 1823=item * Returning a false value from the C<watchfunction()> itself. 1824 1825=item * Altering C<$single> to a false value. 1826 1827=item * Altering C<$signal> to a false value. 1828 1829=item * Turning off the '4' bit in C<$trace> (this also disables the 1830check for C<watchfunction()>. This can be done with 1831 1832 $trace &= ~4; 1833 1834=back 1835 1836=cut 1837 1838 # If there's a user-defined DB::watchfunction, call it with the 1839 # current package, filename, and line. The function executes in 1840 # the DB:: package. 1841 if ($trace & 4) { # User-installed watch 1842 return 1843 if watchfunction($package, $filename, $line) 1844 and not $single 1845 and not $was_signal 1846 and not($trace & ~4); 1847 } ## end if ($trace & 4) 1848 1849 1850 # Pick up any alteration to $signal in the watchfunction, and 1851 # turn off the signal now. 1852 $was_signal = $signal; 1853 $signal = 0; 1854 1855=head2 GETTING READY TO EXECUTE COMMANDS 1856 1857The debugger decides to take control if single-step mode is on, the 1858C<t> command was entered, or the user generated a signal. If the program 1859has fallen off the end, we set things up so that entering further commands 1860won't cause trouble, and we say that the program is over. 1861 1862=cut 1863 1864 # Check to see if we should grab control ($single true, 1865 # trace set appropriately, or we got a signal). 1866 if ($single || ($trace & 1) || $was_signal) { 1867 # Yes, grab control. 1868 if ($slave_editor) { 1869 # Tell the editor to update its position. 1870 $position = "\032\032$filename:$line:0\n"; 1871 print_lineinfo($position); 1872 } 1873 1874=pod 1875 1876Special check: if we're in package C<DB::fake>, we've gone through the 1877C<END> block at least once. We set up everything so that we can continue 1878to enter commands and have a valid context to be in. 1879 1880=cut 1881 1882 elsif ($package eq 'DB::fake') { 1883 # Fallen off the end already. 1884 $term || &setterm; 1885 print_help(<<EOP); 1886Debugged program terminated. Use B<q> to quit or B<R> to restart, 1887 use B<O> I<inhibit_exit> to avoid stopping after program termination, 1888 B<h q>, B<h R> or B<h O> to get additional info. 1889EOP 1890 1891 # Set the DB::eval context appropriately. 1892 $package = 'main'; 1893 $usercontext = 1894 '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' . 1895 "package $package;"; # this won't let them modify, alas 1896 } ## end elsif ($package eq 'DB::fake') 1897 1898=pod 1899 1900If the program hasn't finished executing, we scan forward to the 1901next executable line, print that out, build the prompt from the file and line 1902number information, and print that. 1903 1904=cut 1905 1906 else { 1907 # Still somewhere in the midst of execution. Set up the 1908 # debugger prompt. 1909 $sub =~ s/\'/::/; # Swap Perl 4 package separators (') to 1910 # Perl 5 ones (sorry, we don't print Klingon 1911 #module names) 1912 1913 $prefix = $sub =~ /::/ ? "" : "${'package'}::"; 1914 $prefix .= "$sub($filename:"; 1915 $after = ($dbline[$line] =~ /\n$/ ? '' : "\n"); 1916 1917 # Break up the prompt if it's really long. 1918 if (length($prefix) > 30) { 1919 $position = "$prefix$line):\n$line:\t$dbline[$line]$after"; 1920 $prefix = ""; 1921 $infix = ":\t"; 1922 } 1923 else { 1924 $infix = "):\t"; 1925 $position = "$prefix$line$infix$dbline[$line]$after"; 1926 } 1927 1928 # Print current line info, indenting if necessary. 1929 if ($frame) { 1930 print_lineinfo(' ' x $stack_depth, 1931 "$line:\t$dbline[$line]$after"); 1932 } 1933 else { 1934 print_lineinfo($position); 1935 } 1936 1937 # Scan forward, stopping at either the end or the next 1938 # unbreakable line. 1939 for ($i = $line + 1 ; $i <= $max && $dbline[$i] == 0 ; ++$i) 1940 { #{ vi 1941 1942 # Drop out on null statements, block closers, and comments. 1943 last if $dbline[$i] =~ /^\s*[\;\}\#\n]/; 1944 1945 # Drop out if the user interrupted us. 1946 last if $signal; 1947 1948 # Append a newline if the line doesn't have one. Can happen 1949 # in eval'ed text, for instance. 1950 $after = ($dbline[$i] =~ /\n$/ ? '' : "\n"); 1951 1952 # Next executable line. 1953 $incr_pos = "$prefix$i$infix$dbline[$i]$after"; 1954 $position .= $incr_pos; 1955 if ($frame) { 1956 # Print it indented if tracing is on. 1957 print_lineinfo(' ' x $stack_depth, 1958 "$i:\t$dbline[$i]$after"); 1959 } 1960 else { 1961 print_lineinfo($incr_pos); 1962 } 1963 } ## end for ($i = $line + 1 ; $i... 1964 } ## end else [ if ($slave_editor) 1965 } ## end if ($single || ($trace... 1966 1967=pod 1968 1969If there's an action to be executed for the line we stopped at, execute it. 1970If there are any preprompt actions, execute those as well. 1971 1972=cut 1973 1974 # If there's an action, do it now. 1975 $evalarg = $action, &eval if $action; 1976 1977 # Are we nested another level (e.g., did we evaluate a function 1978 # that had a breakpoint in it at the debugger prompt)? 1979 if ($single || $was_signal) { 1980 # Yes, go down a level. 1981 local $level = $level + 1; 1982 1983 # Do any pre-prompt actions. 1984 foreach $evalarg (@$pre) { 1985 &eval; 1986 } 1987 1988 # Complain about too much recursion if we passed the limit. 1989 print $OUT $stack_depth . " levels deep in subroutine calls!\n" 1990 if $single & 4; 1991 1992 # The line we're currently on. Set $incr to -1 to stay here 1993 # until we get a command that tells us to advance. 1994 $start = $line; 1995 $incr = -1; # for backward motion. 1996 1997 # Tack preprompt debugger actions ahead of any actual input. 1998 @typeahead = (@$pretype, @typeahead); 1999 2000=head2 WHERE ARE WE? 2001 2002XXX Relocate this section? 2003 2004The debugger normally shows the line corresponding to the current line of 2005execution. Sometimes, though, we want to see the next line, or to move elsewhere 2006in the file. This is done via the C<$incr>, C<$start>, and C<$max> variables. 2007 2008C<$incr> controls by how many lines the "current" line should move forward 2009after a command is executed. If set to -1, this indicates that the "current" 2010line shouldn't change. 2011 2012C<$start> is the "current" line. It is used for things like knowing where to 2013move forwards or backwards from when doing an C<L> or C<-> command. 2014 2015C<$max> tells the debugger where the last line of the current file is. It's 2016used to terminate loops most often. 2017 2018=head2 THE COMMAND LOOP 2019 2020Most of C<DB::DB> is actually a command parsing and dispatch loop. It comes 2021in two parts: 2022 2023=over 4 2024 2025=item * The outer part of the loop, starting at the C<CMD> label. This loop 2026reads a command and then executes it. 2027 2028=item * The inner part of the loop, starting at the C<PIPE> label. This part 2029is wholly contained inside the C<CMD> block and only executes a command. 2030Used to handle commands running inside a pager. 2031 2032=back 2033 2034So why have two labels to restart the loop? Because sometimes, it's easier to 2035have a command I<generate> another command and then re-execute the loop to do 2036the new command. This is faster, but perhaps a bit more convoluted. 2037 2038=cut 2039 2040 # The big command dispatch loop. It keeps running until the 2041 # user yields up control again. 2042 # 2043 # If we have a terminal for input, and we get something back 2044 # from readline(), keep on processing. 2045 CMD: 2046 while ( 2047 # We have a terminal, or can get one ... 2048 ($term || &setterm), 2049 # ... and it belogs to this PID or we get one for this PID ... 2050 ($term_pid == $$ or resetterm(1)), 2051 # ... and we got a line of command input ... 2052 defined( 2053 $cmd = &readline( 2054 "$pidprompt DB" . ('<' x $level) . ($#hist + 1) . 2055 ('>' x $level) . " " 2056 ) 2057 ) 2058 ) 2059 { 2060 # ... try to execute the input as debugger commands. 2061 2062 # Don't stop running. 2063 $single = 0; 2064 2065 # No signal is active. 2066 $signal = 0; 2067 2068 # Handle continued commands (ending with \): 2069 $cmd =~ s/\\$/\n/ && do { 2070 $cmd .= &readline(" cont: "); 2071 redo CMD; 2072 }; 2073 2074=head4 The null command 2075 2076A newline entered by itself means "re-execute the last command". We grab the 2077command out of C<$laststep> (where it was recorded previously), and copy it 2078back into C<$cmd> to be executed below. If there wasn't any previous command, 2079we'll do nothing below (no command will match). If there was, we also save it 2080in the command history and fall through to allow the command parsing to pick 2081it up. 2082 2083=cut 2084 2085 # Empty input means repeat the last command. 2086 $cmd =~ /^$/ && ($cmd = $laststep); 2087 chomp($cmd); # get rid of the annoying extra newline 2088 push (@hist, $cmd) if length($cmd) > 1; 2089 push (@truehist, $cmd); 2090 2091 # This is a restart point for commands that didn't arrive 2092 # via direct user input. It allows us to 'redo PIPE' to 2093 # re-execute command processing without reading a new command. 2094 PIPE: { 2095 $cmd =~ s/^\s+//s; # trim annoying leading whitespace 2096 $cmd =~ s/\s+$//s; # trim annoying trailing whitespace 2097 ($i) = split (/\s+/, $cmd); 2098 2099=head3 COMMAND ALIASES 2100 2101The debugger can create aliases for commands (these are stored in the 2102C<%alias> hash). Before a command is executed, the command loop looks it up 2103in the alias hash and substitutes the contents of the alias for the command, 2104completely replacing it. 2105 2106=cut 2107 2108 # See if there's an alias for the command, and set it up if so. 2109 if ($alias{$i}) { 2110 # Squelch signal handling; we want to keep control here 2111 # if something goes loco during the alias eval. 2112 local $SIG{__DIE__}; 2113 local $SIG{__WARN__}; 2114 2115 # This is a command, so we eval it in the DEBUGGER's 2116 # scope! Otherwise, we can't see the special debugger 2117 # variables, or get to the debugger's subs. (Well, we 2118 # _could_, but why make it even more complicated?) 2119 eval "\$cmd =~ $alias{$i}"; 2120 if ($@) { 2121 local $\ = ''; 2122 print $OUT "Couldn't evaluate `$i' alias: $@"; 2123 next CMD; 2124 } 2125 } ## end if ($alias{$i}) 2126 2127=head3 MAIN-LINE COMMANDS 2128 2129All of these commands work up to and after the program being debugged has 2130terminated. 2131 2132=head4 C<q> - quit 2133 2134Quit the debugger. This entails setting the C<$fall_off_end> flag, so we don't 2135try to execute further, cleaning any restart-related stuff out of the 2136environment, and executing with the last value of C<$?>. 2137 2138=cut 2139 2140 $cmd =~ /^q$/ && do { 2141 $fall_off_end = 1; 2142 clean_ENV(); 2143 exit $?; 2144 }; 2145 2146=head4 C<t> - trace 2147 2148Turn tracing on or off. Inverts the appropriate bit in C<$trace> (q.v.). 2149 2150=cut 2151 2152 $cmd =~ /^t$/ && do { 2153 $trace ^= 1; 2154 local $\ = ''; 2155 print $OUT "Trace = " . (($trace & 1) ? "on" : "off") . 2156 "\n"; 2157 next CMD; 2158 }; 2159 2160=head4 C<S> - list subroutines matching/not matching a pattern 2161 2162Walks through C<%sub>, checking to see whether or not to print the name. 2163 2164=cut 2165 2166 $cmd =~ /^S(\s+(!)?(.+))?$/ && do { 2167 2168 $Srev = defined $2; # Reverse scan? 2169 $Spatt = $3; # The pattern (if any) to use. 2170 $Snocheck = !defined $1; # No args - print all subs. 2171 2172 # Need to make these sane here. 2173 local $\ = ''; 2174 local $, = ''; 2175 2176 # Search through the debugger's magical hash of subs. 2177 # If $nocheck is true, just print the sub name. 2178 # Otherwise, check it against the pattern. We then use 2179 # the XOR trick to reverse the condition as required. 2180 foreach $subname (sort(keys %sub)) { 2181 if ($Snocheck or $Srev ^ ($subname =~ /$Spatt/)) { 2182 print $OUT $subname, "\n"; 2183 } 2184 } 2185 next CMD; 2186 }; 2187 2188=head4 C<X> - list variables in current package 2189 2190Since the C<V> command actually processes this, just change this to the 2191appropriate C<V> command and fall through. 2192 2193=cut 2194 2195 $cmd =~ s/^X\b/V $package/; 2196 2197=head4 C<V> - list variables 2198 2199Uses C<dumpvar.pl> to dump out the current values for selected variables. 2200 2201=cut 2202 2203 # Bare V commands get the currently-being-debugged package 2204 # added. 2205 $cmd =~ /^V$/ && do { 2206 $cmd = "V $package"; 2207 }; 2208 2209 2210 # V - show variables in package. 2211 $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do { 2212 # Save the currently selected filehandle and 2213 # force output to debugger's filehandle (dumpvar 2214 # just does "print" for output). 2215 local ($savout) = select($OUT); 2216 2217 # Grab package name and variables to dump. 2218 $packname = $1; 2219 @vars = split (' ', $2); 2220 2221 # If main::dumpvar isn't here, get it. 2222 do 'dumpvar.pl' unless defined &main::dumpvar; 2223 if (defined &main::dumpvar) { 2224 # We got it. Turn off subroutine entry/exit messages 2225 # for the moment, along with return values. 2226 local $frame = 0; 2227 local $doret = -2; 2228 2229 # must detect sigpipe failures - not catching 2230 # then will cause the debugger to die. 2231 eval { 2232 &main::dumpvar( 2233 $packname, 2234 defined $option{dumpDepth} 2235 ? $option{dumpDepth} 2236 : -1, # assume -1 unless specified 2237 @vars 2238 ); 2239 }; 2240 2241 # The die doesn't need to include the $@, because 2242 # it will automatically get propagated for us. 2243 if ($@) { 2244 die unless $@ =~ /dumpvar print failed/; 2245 } 2246 } ## end if (defined &main::dumpvar) 2247 else { 2248 # Couldn't load dumpvar. 2249 print $OUT "dumpvar.pl not available.\n"; 2250 } 2251 # Restore the output filehandle, and go round again. 2252 select($savout); 2253 next CMD; 2254 }; 2255 2256=head4 C<x> - evaluate and print an expression 2257 2258Hands the expression off to C<DB::eval>, setting it up to print the value 2259via C<dumpvar.pl> instead of just printing it directly. 2260 2261=cut 2262 2263 $cmd =~ s/^x\b/ / && do { # Remainder gets done by DB::eval() 2264 $onetimeDump = 'dump'; # main::dumpvar shows the output 2265 2266 # handle special "x 3 blah" syntax XXX propagate 2267 # doc back to special variables. 2268 if ($cmd =~ s/^\s*(\d+)(?=\s)/ /) { 2269 $onetimedumpDepth = $1; 2270 } 2271 }; 2272 2273=head4 C<m> - print methods 2274 2275Just uses C<DB::methods> to determine what methods are available. 2276 2277=cut 2278 2279 $cmd =~ s/^m\s+([\w:]+)\s*$/ / && do { 2280 methods($1); 2281 next CMD; 2282 }; 2283 2284 # m expr - set up DB::eval to do the work 2285 $cmd =~ s/^m\b/ / && do { # Rest gets done by DB::eval() 2286 $onetimeDump = 'methods'; # method output gets used there 2287 }; 2288 2289=head4 C<f> - switch files 2290 2291=cut 2292 2293 $cmd =~ /^f\b\s*(.*)/ && do { 2294 $file = $1; 2295 $file =~ s/\s+$//; 2296 2297 # help for no arguments (old-style was return from sub). 2298 if (!$file) { 2299 print $OUT 2300 "The old f command is now the r command.\n"; # hint 2301 print $OUT "The new f command switches filenames.\n"; 2302 next CMD; 2303 } ## end if (!$file) 2304 2305 # if not in magic file list, try a close match. 2306 if (!defined $main::{ '_<' . $file }) { 2307 if (($try) = grep(m#^_<.*$file#, keys %main::)) { 2308 { 2309 $try = substr($try, 2); 2310 print $OUT 2311 "Choosing $try matching `$file':\n"; 2312 $file = $try; 2313 } 2314 } ## end if (($try) = grep(m#^_<.*$file#... 2315 } ## end if (!defined $main::{ ... 2316 2317 # If not successfully switched now, we failed. 2318 if (!defined $main::{ '_<' . $file }) { 2319 print $OUT "No file matching `$file' is loaded.\n"; 2320 next CMD; 2321 } 2322 2323 # We switched, so switch the debugger internals around. 2324 elsif ($file ne $filename) { 2325 *dbline = $main::{ '_<' . $file }; 2326 $max = $#dbline; 2327 $filename = $file; 2328 $start = 1; 2329 $cmd = "l"; 2330 } ## end elsif ($file ne $filename) 2331 2332 # We didn't switch; say we didn't. 2333 else { 2334 print $OUT "Already in $file.\n"; 2335 next CMD; 2336 } 2337 }; 2338 2339=head4 C<.> - return to last-executed line. 2340 2341We set C<$incr> to -1 to indicate that the debugger shouldn't move ahead, 2342and then we look up the line in the magical C<%dbline> hash. 2343 2344=cut 2345 2346 # . command. 2347 $cmd =~ /^\.$/ && do { 2348 $incr = -1; # stay at current line 2349 2350 # Reset everything to the old location. 2351 $start = $line; 2352 $filename = $filename_ini; 2353 *dbline = $main::{ '_<' . $filename }; 2354 $max = $#dbline; 2355 2356 # Now where are we? 2357 print_lineinfo($position); 2358 next CMD; 2359 }; 2360 2361=head4 C<-> - back one window 2362 2363We change C<$start> to be one window back; if we go back past the first line, 2364we set it to be the first line. We ser C<$incr> to put us back at the 2365currently-executing line, and then put a C<l $start +> (list one window from 2366C<$start>) in C<$cmd> to be executed later. 2367 2368=cut 2369 2370 # - - back a window. 2371 $cmd =~ /^-$/ && do { 2372 # back up by a window; go to 1 if back too far. 2373 $start -= $incr + $window + 1; 2374 $start = 1 if $start <= 0; 2375 $incr = $window - 1; 2376 2377 # Generate and execute a "l +" command (handled below). 2378 $cmd = 'l ' . ($start) . '+'; 2379 }; 2380 2381=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>, {, {{> 2382 2383In Perl 5.8.0, a realignment of the commands was done to fix up a number of 2384problems, most notably that the default case of several commands destroying 2385the user's work in setting watchpoints, actions, etc. We wanted, however, to 2386retain the old commands for those who were used to using them or who preferred 2387them. At this point, we check for the new commands and call C<cmd_wrapper> to 2388deal with them instead of processing them in-line. 2389 2390=cut 2391 2392 # All of these commands were remapped in perl 5.8.0; 2393 # we send them off to the secondary dispatcher (see below). 2394 $cmd =~ /^([aAbBhilLMoOvwW]\b|[<>\{]{1,2})\s*(.*)/so && do { 2395 &cmd_wrapper($1, $2, $line); 2396 next CMD; 2397 }; 2398 2399=head4 C<y> - List lexicals in higher scope 2400 2401Uses C<PadWalker> to find the lexicals supplied as arguments in a scope 2402above the current one and then displays then using C<dumpvar.pl>. 2403 2404=cut 2405 2406 $cmd =~ /^y(?:\s+(\d*)\s*(.*))?$/ && do { 2407 2408 # See if we've got the necessary support. 2409 eval { require PadWalker; PadWalker->VERSION(0.08) } 2410 or &warn( 2411 $@ =~ /locate/ 2412 ? "PadWalker module not found - please install\n" 2413 : $@ 2414 ) 2415 and next CMD; 2416 2417 # Load up dumpvar if we don't have it. If we can, that is. 2418 do 'dumpvar.pl' unless defined &main::dumpvar; 2419 defined &main::dumpvar 2420 or print $OUT "dumpvar.pl not available.\n" 2421 and next CMD; 2422 2423 # Got all the modules we need. Find them and print them. 2424 my @vars = split (' ', $2 || ''); 2425 2426 # Find the pad. 2427 my $h = eval { PadWalker::peek_my(($1 || 0) + 1) }; 2428 2429 # Oops. Can't find it. 2430 $@ and $@ =~ s/ at .*//, &warn($@), next CMD; 2431 2432 # Show the desired vars with dumplex(). 2433 my $savout = select($OUT); 2434 2435 # Have dumplex dump the lexicals. 2436 dumpvar::dumplex( 2437 $_, 2438 $h->{$_}, 2439 defined $option{dumpDepth} ? $option{dumpDepth} : -1, 2440 @vars 2441 ) for sort keys %$h; 2442 select($savout); 2443 next CMD; 2444 }; 2445 2446=head3 COMMANDS NOT WORKING AFTER PROGRAM ENDS 2447 2448All of the commands below this point don't work after the program being 2449debugged has ended. All of them check to see if the program has ended; this 2450allows the commands to be relocated without worrying about a 'line of 2451demarcation' above which commands can be entered anytime, and below which 2452they can't. 2453 2454=head4 C<n> - single step, but don't trace down into subs 2455 2456Done by setting C<$single> to 2, which forces subs to execute straight through 2457when entered (see X<DB::sub>). We also save the C<n> command in C<$laststep>, 2458so a null command knows what to re-execute. 2459 2460=cut 2461 2462 # n - next 2463 $cmd =~ /^n$/ && do { 2464 end_report(), next CMD if $finished and $level <= 1; 2465 # Single step, but don't enter subs. 2466 $single = 2; 2467 # Save for empty command (repeat last). 2468 $laststep = $cmd; 2469 last CMD; 2470 }; 2471 2472=head4 C<s> - single-step, entering subs 2473 2474Sets C<$single> to 1, which causes X<DB::sub> to continue tracing inside 2475subs. Also saves C<s> as C<$lastcmd>. 2476 2477=cut 2478 2479 # s - single step. 2480 $cmd =~ /^s$/ && do { 2481 # Get out and restart the command loop if program 2482 # has finished. 2483 end_report(), next CMD if $finished and $level <= 1; 2484 # Single step should enter subs. 2485 $single = 1; 2486 # Save for empty command (repeat last). 2487 $laststep = $cmd; 2488 last CMD; 2489 }; 2490 2491=head4 C<c> - run continuously, setting an optional breakpoint 2492 2493Most of the code for this command is taken up with locating the optional 2494breakpoint, which is either a subroutine name or a line number. We set 2495the appropriate one-time-break in C<@dbline> and then turn off single-stepping 2496in this and all call levels above this one. 2497 2498=cut 2499 2500 # c - start continuous execution. 2501 $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do { 2502 # Hey, show's over. The debugged program finished 2503 # executing already. 2504 end_report(), next CMD if $finished and $level <= 1; 2505 2506 # Capture the place to put a one-time break. 2507 $subname = $i = $1; 2508 2509 # Probably not needed, since we finish an interactive 2510 # sub-session anyway... 2511 # local $filename = $filename; 2512 # local *dbline = *dbline; # XXX Would this work?! 2513 # 2514 # The above question wonders if localizing the alias 2515 # to the magic array works or not. Since it's commented 2516 # out, we'll just leave that to speculation for now. 2517 2518 # If the "subname" isn't all digits, we'll assume it 2519 # is a subroutine name, and try to find it. 2520 if ($subname =~ /\D/) { # subroutine name 2521 # Qualify it to the current package unless it's 2522 # already qualified. 2523 $subname = $package . "::" . $subname 2524 unless $subname =~ /::/; 2525 # find_sub will return "file:line_number" corresponding 2526 # to where the subroutine is defined; we call find_sub, 2527 # break up the return value, and assign it in one 2528 # operation. 2529 ($file, $i) = (find_sub($subname) =~ /^(.*):(.*)$/); 2530 2531 # Force the line number to be numeric. 2532 $i += 0; 2533 2534 # If we got a line number, we found the sub. 2535 if ($i) { 2536 # Switch all the debugger's internals around so 2537 # we're actually working with that file. 2538 $filename = $file; 2539 *dbline = $main::{ '_<' . $filename }; 2540 # Mark that there's a breakpoint in this file. 2541 $had_breakpoints{$filename} |= 1; 2542 # Scan forward to the first executable line 2543 # after the 'sub whatever' line. 2544 $max = $#dbline; 2545 ++$i while $dbline[$i] == 0 && $i < $max; 2546 } ## end if ($i) 2547 2548 # We didn't find a sub by that name. 2549 else { 2550 print $OUT "Subroutine $subname not found.\n"; 2551 next CMD; 2552 } 2553 } ## end if ($subname =~ /\D/) 2554 2555 # At this point, either the subname was all digits (an 2556 # absolute line-break request) or we've scanned through 2557 # the code following the definition of the sub, looking 2558 # for an executable, which we may or may not have found. 2559 # 2560 # If $i (which we set $subname from) is non-zero, we 2561 # got a request to break at some line somewhere. On 2562 # one hand, if there wasn't any real subroutine name 2563 # involved, this will be a request to break in the current 2564 # file at the specified line, so we have to check to make 2565 # sure that the line specified really is breakable. 2566 # 2567 # On the other hand, if there was a subname supplied, the 2568 # preceeding block has moved us to the proper file and 2569 # location within that file, and then scanned forward 2570 # looking for the next executable line. We have to make 2571 # sure that one was found. 2572 # 2573 # On the gripping hand, we can't do anything unless the 2574 # current value of $i points to a valid breakable line. 2575 # Check that. 2576 if ($i) { 2577 # Breakable? 2578 if ($dbline[$i] == 0) { 2579 print $OUT "Line $i not breakable.\n"; 2580 next CMD; 2581 } 2582 # Yes. Set up the one-time-break sigil. 2583 $dbline{$i} =~ 2584 s/($|\0)/;9$1/; # add one-time-only b.p. 2585 } ## end if ($i) 2586 2587 # Turn off stack tracing from here up. 2588 for ($i = 0 ; $i <= $stack_depth ;) { 2589 $stack[$i++] &= ~1; 2590 } 2591 last CMD; 2592 }; 2593 2594=head4 C<r> - return from a subroutine 2595 2596For C<r> to work properly, the debugger has to stop execution again 2597immediately after the return is executed. This is done by forcing 2598single-stepping to be on in the call level above the current one. If 2599we are printing return values when a C<r> is executed, set C<$doret> 2600appropriately, and force us out of the command loop. 2601 2602=cut 2603 2604 # r - return from the current subroutine. 2605 $cmd =~ /^r$/ && do { 2606 # Can't do anythign if the program's over. 2607 end_report(), next CMD if $finished and $level <= 1; 2608 # Turn on stack trace. 2609 $stack[$stack_depth] |= 1; 2610 # Print return value unless the stack is empty. 2611 $doret = $option{PrintRet} ? $stack_depth - 1 : -2; 2612 last CMD; 2613 }; 2614 2615=head4 C<R> - restart 2616 2617Restarting the debugger is a complex operation that occurs in several phases. 2618First, we try to reconstruct the command line that was used to invoke Perl 2619and the debugger. 2620 2621=cut 2622 2623 # R - restart execution. 2624 $cmd =~ /^R$/ && do { 2625 # I may not be able to resurrect you, but here goes ... 2626 print $OUT 2627"Warning: some settings and command-line options may be lost!\n"; 2628 my (@script, @flags, $cl); 2629 2630 # If warn was on before, turn it on again. 2631 push @flags, '-w' if $ini_warn; 2632 2633 # Rebuild the -I flags that were on the initial 2634 # command line. 2635 for (@ini_INC) { 2636 push @flags, '-I', $_; 2637 } 2638 2639 # Turn on taint if it was on before. 2640 push @flags, '-T' if ${^TAINT}; 2641 2642 # Arrange for setting the old INC: 2643 # Save the current @init_INC in the environment. 2644 set_list("PERLDB_INC", @ini_INC); 2645 2646 # If this was a perl one-liner, go to the "file" 2647 # corresponding to the one-liner read all the lines 2648 # out of it (except for the first one, which is going 2649 # to be added back on again when 'perl -d' runs: that's 2650 # the 'require perl5db.pl;' line), and add them back on 2651 # to the command line to be executed. 2652 if ($0 eq '-e') { 2653 for (1 .. $#{'::_<-e'}) { # The first line is PERL5DB 2654 chomp($cl = ${'::_<-e'}[$_]); 2655 push @script, '-e', $cl; 2656 } 2657 } ## end if ($0 eq '-e') 2658 2659 # Otherwise we just reuse the original name we had 2660 # before. 2661 else { 2662 @script = $0; 2663 } 2664 2665=pod 2666 2667After the command line has been reconstructed, the next step is to save 2668the debugger's status in environment variables. The C<DB::set_list> routine 2669is used to save aggregate variables (both hashes and arrays); scalars are 2670just popped into environment variables directly. 2671 2672=cut 2673 2674 # If the terminal supported history, grab it and 2675 # save that in the environment. 2676 set_list("PERLDB_HIST", 2677 $term->Features->{getHistory} 2678 ? $term->GetHistory 2679 : @hist); 2680 # Find all the files that were visited during this 2681 # session (i.e., the debugger had magic hashes 2682 # corresponding to them) and stick them in the environment. 2683 my @had_breakpoints = keys %had_breakpoints; 2684 set_list("PERLDB_VISITED", @had_breakpoints); 2685 2686 # Save the debugger options we chose. 2687 set_list("PERLDB_OPT", %option); 2688 2689 # Save the break-on-loads. 2690 set_list("PERLDB_ON_LOAD", %break_on_load); 2691 2692=pod 2693 2694The most complex part of this is the saving of all of the breakpoints. They 2695can live in an awful lot of places, and we have to go through all of them, 2696find the breakpoints, and then save them in the appropriate environment 2697variable via C<DB::set_list>. 2698 2699=cut 2700 2701 # Go through all the breakpoints and make sure they're 2702 # still valid. 2703 my @hard; 2704 for (0 .. $#had_breakpoints) { 2705 # We were in this file. 2706 my $file = $had_breakpoints[$_]; 2707 2708 # Grab that file's magic line hash. 2709 *dbline = $main::{ '_<' . $file }; 2710 2711 # Skip out if it doesn't exist, or if the breakpoint 2712 # is in a postponed file (we'll do postponed ones 2713 # later). 2714 next unless %dbline or $postponed_file{$file}; 2715 2716 # In an eval. This is a little harder, so we'll 2717 # do more processing on that below. 2718 (push @hard, $file), next 2719 if $file =~ /^\(\w*eval/; 2720 # XXX I have no idea what this is doing. Yet. 2721 my @add; 2722 @add = %{ $postponed_file{$file} } 2723 if $postponed_file{$file}; 2724 2725 # Save the list of all the breakpoints for this file. 2726 set_list("PERLDB_FILE_$_", %dbline, @add); 2727 } ## end for (0 .. $#had_breakpoints) 2728 2729 # The breakpoint was inside an eval. This is a little 2730 # more difficult. XXX and I don't understand it. 2731 for (@hard) { 2732 # Get over to the eval in question. 2733 *dbline = $main::{ '_<' . $_ }; 2734 my ($quoted, $sub, %subs, $line) = quotemeta $_; 2735 for $sub (keys %sub) { 2736 next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/; 2737 $subs{$sub} = [$1, $2]; 2738 } 2739 unless (%subs) { 2740 print $OUT 2741 "No subroutines in $_, ignoring breakpoints.\n"; 2742 next; 2743 } 2744 LINES: for $line (keys %dbline) { 2745 2746 # One breakpoint per sub only: 2747 my ($offset, $sub, $found); 2748 SUBS: for $sub (keys %subs) { 2749 if ( 2750 $subs{$sub}->[1] >= 2751 $line # Not after the subroutine 2752 and ( 2753 not defined $offset # Not caught 2754 or $offset < 0 2755 ) 2756 ) 2757 { # or badly caught 2758 $found = $sub; 2759 $offset = $line - $subs{$sub}->[0]; 2760 $offset = "+$offset", last SUBS 2761 if $offset >= 0; 2762 } ## end if ($subs{$sub}->[1] >=... 2763 } ## end for $sub (keys %subs) 2764 if (defined $offset) { 2765 $postponed{$found} = 2766 "break $offset if $dbline{$line}"; 2767 } 2768 else { 2769 print $OUT 2770"Breakpoint in $_:$line ignored: after all the subroutines.\n"; 2771 } 2772 } ## end for $line (keys %dbline) 2773 } ## end for (@hard) 2774 2775 # Save the other things that don't need to be 2776 # processed. 2777 set_list("PERLDB_POSTPONE", %postponed); 2778 set_list("PERLDB_PRETYPE", @$pretype); 2779 set_list("PERLDB_PRE", @$pre); 2780 set_list("PERLDB_POST", @$post); 2781 set_list("PERLDB_TYPEAHEAD", @typeahead); 2782 2783 # We are oficially restarting. 2784 $ENV{PERLDB_RESTART} = 1; 2785 2786 # We are junking all child debuggers. 2787 delete $ENV{PERLDB_PIDS}; # Restore ini state 2788 2789 # Set this back to the initial pid. 2790 $ENV{PERLDB_PIDS} = $ini_pids if defined $ini_pids; 2791 2792=pod 2793 2794After all the debugger status has been saved, we take the command we built 2795up and then C<exec()> it. The debugger will spot the C<PERLDB_RESTART> 2796environment variable and realize it needs to reload its state from the 2797environment. 2798 2799=cut 2800 2801 # And run Perl again. Add the "-d" flag, all the 2802 # flags we built up, the script (whether a one-liner 2803 # or a file), add on the -emacs flag for a slave editor, 2804 # and then the old arguments. We use exec() to keep the 2805 # PID stable (and that way $ini_pids is still valid). 2806 exec($^X, '-d', @flags, @script, 2807 ($slave_editor ? '-emacs' : ()), @ARGS) || 2808 print $OUT "exec failed: $!\n"; 2809 last CMD; 2810 }; 2811 2812=head4 C<T> - stack trace 2813 2814Just calls C<DB::print_trace>. 2815 2816=cut 2817 2818 $cmd =~ /^T$/ && do { 2819 print_trace($OUT, 1); # skip DB 2820 next CMD; 2821 }; 2822 2823=head4 C<w> - List window around current line. 2824 2825Just calls C<DB::cmd_w>. 2826 2827=cut 2828 2829 $cmd =~ /^w\b\s*(.*)/s && do { &cmd_w('w', $1); next CMD; }; 2830 2831=head4 C<W> - watch-expression processing. 2832 2833Just calls C<DB::cmd_W>. 2834 2835=cut 2836 2837 $cmd =~ /^W\b\s*(.*)/s && do { &cmd_W('W', $1); next CMD; }; 2838 2839=head4 C</> - search forward for a string in the source 2840 2841We take the argument and treat it as a pattern. If it turns out to be a 2842bad one, we return the error we got from trying to C<eval> it and exit. 2843If not, we create some code to do the search and C<eval> it so it can't 2844mess us up. 2845 2846=cut 2847 2848 $cmd =~ /^\/(.*)$/ && do { 2849 2850 # The pattern as a string. 2851 $inpat = $1; 2852 2853 # Remove the final slash. 2854 $inpat =~ s:([^\\])/$:$1:; 2855 2856 # If the pattern isn't null ... 2857 if ($inpat ne "") { 2858 2859 # Turn of warn and die procesing for a bit. 2860 local $SIG{__DIE__}; 2861 local $SIG{__WARN__}; 2862 2863 # Create the pattern. 2864 eval '$inpat =~ m' . "\a$inpat\a"; 2865 if ($@ ne "") { 2866 # Oops. Bad pattern. No biscuit. 2867 # Print the eval error and go back for more 2868 # commands. 2869 print $OUT "$@"; 2870 next CMD; 2871 } 2872 $pat = $inpat; 2873 } ## end if ($inpat ne "") 2874 2875 # Set up to stop on wrap-around. 2876 $end = $start; 2877 2878 # Don't move off the current line. 2879 $incr = -1; 2880 2881 # Done in eval so nothing breaks if the pattern 2882 # does something weird. 2883 eval ' 2884 for (;;) { 2885 # Move ahead one line. 2886 ++$start; 2887 2888 # Wrap if we pass the last line. 2889 $start = 1 if ($start > $max); 2890 2891 # Stop if we have gotten back to this line again, 2892 last if ($start == $end); 2893 2894 # A hit! (Note, though, that we are doing 2895 # case-insensitive matching. Maybe a qr// 2896 # expression would be better, so the user could 2897 # do case-sensitive matching if desired. 2898 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) { 2899 if ($slave_editor) { 2900 # Handle proper escaping in the slave. 2901 print $OUT "\032\032$filename:$start:0\n"; 2902 } 2903 else { 2904 # Just print the line normally. 2905 print $OUT "$start:\t",$dbline[$start],"\n"; 2906 } 2907 # And quit since we found something. 2908 last; 2909 } 2910 } '; 2911 # If we wrapped, there never was a match. 2912 print $OUT "/$pat/: not found\n" if ($start == $end); 2913 next CMD; 2914 }; 2915 2916=head4 C<?> - search backward for a string in the source 2917 2918Same as for C</>, except the loop runs backwards. 2919 2920=cut 2921 2922 # ? - backward pattern search. 2923 $cmd =~ /^\?(.*)$/ && do { 2924 2925 # Get the pattern, remove trailing question mark. 2926 $inpat = $1; 2927 $inpat =~ s:([^\\])\?$:$1:; 2928 2929 # If we've got one ... 2930 if ($inpat ne "") { 2931 2932 # Turn off die & warn handlers. 2933 local $SIG{__DIE__}; 2934 local $SIG{__WARN__}; 2935 eval '$inpat =~ m' . "\a$inpat\a"; 2936 2937 if ($@ ne "") { 2938 # Ouch. Not good. Print the error. 2939 print $OUT $@; 2940 next CMD; 2941 } 2942 $pat = $inpat; 2943 } ## end if ($inpat ne "") 2944 2945 # Where we are now is where to stop after wraparound. 2946 $end = $start; 2947 2948 # Don't move away from this line. 2949 $incr = -1; 2950 2951 # Search inside the eval to prevent pattern badness 2952 # from killing us. 2953 eval ' 2954 for (;;) { 2955 # Back up a line. 2956 --$start; 2957 2958 # Wrap if we pass the first line. 2959 $start = $max if ($start <= 0); 2960 2961 # Quit if we get back where we started, 2962 last if ($start == $end); 2963 2964 # Match? 2965 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) { 2966 if ($slave_editor) { 2967 # Yep, follow slave editor requirements. 2968 print $OUT "\032\032$filename:$start:0\n"; 2969 } 2970 else { 2971 # Yep, just print normally. 2972 print $OUT "$start:\t",$dbline[$start],"\n"; 2973 } 2974 2975 # Found, so done. 2976 last; 2977 } 2978 } '; 2979 2980 # Say we failed if the loop never found anything, 2981 print $OUT "?$pat?: not found\n" if ($start == $end); 2982 next CMD; 2983 }; 2984 2985=head4 C<$rc> - Recall command 2986 2987Manages the commands in C<@hist> (which is created if C<Term::ReadLine> reports 2988that the terminal supports history). It find the the command required, puts it 2989into C<$cmd>, and redoes the loop to execute it. 2990 2991=cut 2992 2993 # $rc - recall command. 2994 $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do { 2995 2996 # No arguments, take one thing off history. 2997 pop (@hist) if length($cmd) > 1; 2998 2999 # Relative (- found)? 3000 # Y - index back from most recent (by 1 if bare minus) 3001 # N - go to that particular command slot or the last 3002 # thing if nothing following. 3003 $i = $1 ? ($#hist - ($2 || 1)) : ($2 || $#hist); 3004 3005 # Pick out the command desired. 3006 $cmd = $hist[$i]; 3007 3008 # Print the command to be executed and restart the loop 3009 # with that command in the buffer. 3010 print $OUT $cmd, "\n"; 3011 redo CMD; 3012 }; 3013 3014=head4 C<$sh$sh> - C<system()> command 3015 3016Calls the C<DB::system()> to handle the command. This keeps the C<STDIN> and 3017C<STDOUT> from getting messed up. 3018 3019=cut 3020 3021 # $sh$sh - run a shell command (if it's all ASCII). 3022 # Can't run shell commands with Unicode in the debugger, hmm. 3023 $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do { 3024 # System it. 3025 &system($1); 3026 next CMD; 3027 }; 3028 3029=head4 C<$rc I<pattern> $rc> - Search command history 3030 3031Another command to manipulate C<@hist>: this one searches it with a pattern. 3032If a command is found, it is placed in C<$cmd> and executed via <redo>. 3033 3034=cut 3035 3036 # $rc pattern $rc - find a command in the history. 3037 $cmd =~ /^$rc([^$rc].*)$/ && do { 3038 # Create the pattern to use. 3039 $pat = "^$1"; 3040 3041 # Toss off last entry if length is >1 (and it always is). 3042 pop (@hist) if length($cmd) > 1; 3043 3044 # Look backward through the history. 3045 for ($i = $#hist ; $i ; --$i) { 3046 # Stop if we find it. 3047 last if $hist[$i] =~ /$pat/; 3048 } 3049 3050 if (!$i) { 3051 # Never found it. 3052 print $OUT "No such command!\n\n"; 3053 next CMD; 3054 } 3055 3056 # Found it. Put it in the buffer, print it, and process it. 3057 $cmd = $hist[$i]; 3058 print $OUT $cmd, "\n"; 3059 redo CMD; 3060 }; 3061 3062=head4 C<$sh> - Invoke a shell 3063 3064Uses C<DB::system> to invoke a shell. 3065 3066=cut 3067 3068 # $sh - start a shell. 3069 $cmd =~ /^$sh$/ && do { 3070 # Run the user's shell. If none defined, run Bourne. 3071 # We resume execution when the shell terminates. 3072 &system($ENV{SHELL} || "/bin/sh"); 3073 next CMD; 3074 }; 3075 3076=head4 C<$sh I<command>> - Force execution of a command in a shell 3077 3078Like the above, but the command is passed to the shell. Again, we use 3079C<DB::system> to avoid problems with C<STDIN> and C<STDOUT>. 3080 3081=cut 3082 3083 # $sh command - start a shell and run a command in it. 3084 $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do { 3085 # XXX: using csh or tcsh destroys sigint retvals! 3086 #&system($1); # use this instead 3087 3088 # use the user's shell, or Bourne if none defined. 3089 &system($ENV{SHELL} || "/bin/sh", "-c", $1); 3090 next CMD; 3091 }; 3092 3093=head4 C<H> - display commands in history 3094 3095Prints the contents of C<@hist> (if any). 3096 3097=cut 3098 3099 $cmd =~ /^H\b\s*(-(\d+))?/ && do { 3100 # Anything other than negative numbers is ignored by 3101 # the (incorrect) pattern, so this test does nothing. 3102 $end = $2 ? ($#hist - $2) : 0; 3103 3104 # Set to the minimum if less than zero. 3105 $hist = 0 if $hist < 0; 3106 3107 # Start at the end of the array. 3108 # Stay in while we're still above the ending value. 3109 # Tick back by one each time around the loop. 3110 for ($i = $#hist ; $i > $end ; $i--) { 3111 3112 # Print the command unless it has no arguments. 3113 print $OUT "$i: ", $hist[$i], "\n" 3114 unless $hist[$i] =~ /^.?$/; 3115 } 3116 next CMD; 3117 }; 3118 3119=head4 C<man, doc, perldoc> - look up documentation 3120 3121Just calls C<runman()> to print the appropriate document. 3122 3123=cut 3124 3125 # man, perldoc, doc - show manual pages. 3126 $cmd =~ /^(?:man|(?:perl)?doc)\b(?:\s+([^(]*))?$/ && do { 3127 runman($1); 3128 next CMD; 3129 }; 3130 3131=head4 C<p> - print 3132 3133Builds a C<print EXPR> expression in the C<$cmd>; this will get executed at 3134the bottom of the loop. 3135 3136=cut 3137 3138 # p - print (no args): print $_. 3139 $cmd =~ s/^p$/print {\$DB::OUT} \$_/; 3140 3141 # p - print the given expression. 3142 $cmd =~ s/^p\b/print {\$DB::OUT} /; 3143 3144=head4 C<=> - define command alias 3145 3146Manipulates C<%alias> to add or list command aliases. 3147 3148=cut 3149 3150 # = - set up a command alias. 3151 $cmd =~ s/^=\s*// && do { 3152 my @keys; 3153 if (length $cmd == 0) { 3154 # No args, get current aliases. 3155 @keys = sort keys %alias; 3156 } 3157 elsif (my ($k, $v) = ($cmd =~ /^(\S+)\s+(\S.*)/)) { 3158 # Creating a new alias. $k is alias name, $v is 3159 # alias value. 3160 3161 # can't use $_ or kill //g state 3162 for my $x ($k, $v) { 3163 # Escape "alarm" characters. 3164 $x =~ s/\a/\\a/g 3165 } 3166 3167 # Substitute key for value, using alarm chars 3168 # as separators (which is why we escaped them in 3169 # the command). 3170 $alias{$k} = "s\a$k\a$v\a"; 3171 3172 # Turn off standard warn and die behavior. 3173 local $SIG{__DIE__}; 3174 local $SIG{__WARN__}; 3175 3176 # Is it valid Perl? 3177 unless (eval "sub { s\a$k\a$v\a }; 1") { 3178 # Nope. Bad alias. Say so and get out. 3179 print $OUT "Can't alias $k to $v: $@\n"; 3180 delete $alias{$k}; 3181 next CMD; 3182 } 3183 # We'll only list the new one. 3184 @keys = ($k); 3185 } ## end elsif (my ($k, $v) = ($cmd... 3186 3187 # The argument is the alias to list. 3188 else { 3189 @keys = ($cmd); 3190 } 3191 3192 # List aliases. 3193 for my $k (@keys) { 3194 # Messy metaquoting: Trim the substiution code off. 3195 # We use control-G as the delimiter because it's not 3196 # likely to appear in the alias. 3197 if ((my $v = $alias{$k}) =~ ss\a$k\a(.*)\a$1) { 3198 # Print the alias. 3199 print $OUT "$k\t= $1\n"; 3200 } 3201 elsif (defined $alias{$k}) { 3202 # Couldn't trim it off; just print the alias code. 3203 print $OUT "$k\t$alias{$k}\n"; 3204 } 3205 else { 3206 # No such, dude. 3207 print "No alias for $k\n"; 3208 } 3209 } ## end for my $k (@keys) 3210 next CMD; 3211 }; 3212 3213=head4 C<source> - read commands from a file. 3214 3215Opens a lexical filehandle and stacks it on C<@cmdfhs>; C<DB::readline> will 3216pick it up. 3217 3218=cut 3219 3220 # source - read commands from a file (or pipe!) and execute. 3221 $cmd =~ /^source\s+(.*\S)/ && do { 3222 if (open my $fh, $1) { 3223 # Opened OK; stick it in the list of file handles. 3224 push @cmdfhs, $fh; 3225 } 3226 else { 3227 # Couldn't open it. 3228 &warn("Can't execute `$1': $!\n"); 3229 } 3230 next CMD; 3231 }; 3232 3233=head4 C<save> - send current history to a file 3234 3235Takes the complete history, (not the shrunken version you see with C<H>), 3236and saves it to the given filename, so it can be replayed using C<source>. 3237 3238Note that all C<^(save|source)>'s are commented out with a view to minimise recursion. 3239 3240=cut 3241 3242 # save source - write commands to a file for later use 3243 $cmd =~ /^save\s*(.*)$/ && do { 3244 my $file = $1 || '.perl5dbrc'; # default? 3245 if (open my $fh, "> $file") { 3246 # chomp to remove extraneous newlines from source'd files 3247 chomp(my @truelist = map { m/^\s*(save|source)/ ? "#$_": $_ } @truehist); 3248 print $fh join("\n", @truelist); 3249 print "commands saved in $file\n"; 3250 } else { 3251 &warn("Can't save debugger commands in '$1': $!\n"); 3252 } 3253 next CMD; 3254 }; 3255 3256=head4 C<|, ||> - pipe output through the pager. 3257 3258FOR C<|>, we save C<OUT> (the debugger's output filehandle) and C<STDOUT> 3259(the program's standard output). For C<||>, we only save C<OUT>. We open a 3260pipe to the pager (restoring the output filehandles if this fails). If this 3261is the C<|> command, we also set up a C<SIGPIPE> handler which will simply 3262set C<$signal>, sending us back into the debugger. 3263 3264We then trim off the pipe symbols and C<redo> the command loop at the 3265C<PIPE> label, causing us to evaluate the command in C<$cmd> without 3266reading another. 3267 3268=cut 3269 3270 # || - run command in the pager, with output to DB::OUT. 3271 $cmd =~ /^\|\|?\s*[^|]/ && do { 3272 if ($pager =~ /^\|/) { 3273 # Default pager is into a pipe. Redirect I/O. 3274 open(SAVEOUT, ">&STDOUT") || 3275 &warn("Can't save STDOUT"); 3276 open(STDOUT, ">&OUT") || 3277 &warn("Can't redirect STDOUT"); 3278 } ## end if ($pager =~ /^\|/) 3279 else { 3280 # Not into a pipe. STDOUT is safe. 3281 open(SAVEOUT, ">&OUT") || &warn("Can't save DB::OUT"); 3282 } 3283 3284 # Fix up environment to record we have less if so. 3285 fix_less(); 3286 3287 unless ($piped = open(OUT, $pager)) { 3288 # Couldn't open pipe to pager. 3289 &warn("Can't pipe output to `$pager'"); 3290 if ($pager =~ /^\|/) { 3291 # Redirect I/O back again. 3292 open(OUT, ">&STDOUT") # XXX: lost message 3293 || &warn("Can't restore DB::OUT"); 3294 open(STDOUT, ">&SAVEOUT") || 3295 &warn("Can't restore STDOUT"); 3296 close(SAVEOUT); 3297 } ## end if ($pager =~ /^\|/) 3298 else { 3299 # Redirect I/O. STDOUT already safe. 3300 open(OUT, ">&STDOUT") # XXX: lost message 3301 || &warn("Can't restore DB::OUT"); 3302 } 3303 next CMD; 3304 } ## end unless ($piped = open(OUT,... 3305 3306 # Set up broken-pipe handler if necessary. 3307 $SIG{PIPE} = \&DB::catch 3308 if $pager =~ /^\|/ && 3309 ("" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE}); 3310 3311 # Save current filehandle, unbuffer out, and put it back. 3312 $selected = select(OUT); 3313 $| = 1; 3314 3315 # Don't put it back if pager was a pipe. 3316 select($selected), $selected = "" unless $cmd =~ /^\|\|/; 3317 3318 # Trim off the pipe symbols and run the command now. 3319 $cmd =~ s/^\|+\s*//; 3320 redo PIPE; 3321 }; 3322 3323 3324=head3 END OF COMMAND PARSING 3325 3326Anything left in C<$cmd> at this point is a Perl expression that we want to 3327evaluate. We'll always evaluate in the user's context, and fully qualify 3328any variables we might want to address in the C<DB> package. 3329 3330=cut 3331 3332 # t - turn trace on. 3333 $cmd =~ s/^t\s/\$DB::trace |= 1;\n/; 3334 3335 # s - single-step. Remember the last command was 's'. 3336 $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do { $laststep = 's' }; 3337 3338 # n - single-step, but not into subs. Remember last command 3339 # was 'n'. 3340 $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do { $laststep = 'n' }; 3341 3342 } # PIPE: 3343 3344 # Make sure the flag that says "the debugger's running" is 3345 # still on, to make sure we get control again. 3346 $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; 3347 3348 # Run *our* eval that executes in the caller's context. 3349 &eval; 3350 3351 # Turn off the one-time-dump stuff now. 3352 if ($onetimeDump) { 3353 $onetimeDump = undef; 3354 $onetimedumpDepth = undef; 3355 } 3356 elsif ($term_pid == $$) { 3357 STDOUT->flush(); 3358 STDERR->flush(); 3359 # XXX If this is the master pid, print a newline. 3360 print $OUT "\n"; 3361 } 3362 } ## end while (($term || &setterm... 3363 3364=head3 POST-COMMAND PROCESSING 3365 3366After each command, we check to see if the command output was piped anywhere. 3367If so, we go through the necessary code to unhook the pipe and go back to 3368our standard filehandles for input and output. 3369 3370=cut 3371 3372 continue { # CMD: 3373 3374 # At the end of every command: 3375 if ($piped) { 3376 # Unhook the pipe mechanism now. 3377 if ($pager =~ /^\|/) { 3378 # No error from the child. 3379 $? = 0; 3380 3381 # we cannot warn here: the handle is missing --tchrist 3382 close(OUT) || print SAVEOUT "\nCan't close DB::OUT\n"; 3383 3384 # most of the $? crud was coping with broken cshisms 3385 # $? is explicitly set to 0, so this never runs. 3386 if ($?) { 3387 print SAVEOUT "Pager `$pager' failed: "; 3388 if ($? == -1) { 3389 print SAVEOUT "shell returned -1\n"; 3390 } 3391 elsif ($? >> 8) { 3392 print SAVEOUT ($? & 127) 3393 ? " (SIG#" . ($? & 127) . ")" 3394 : "", ($? & 128) ? " -- core dumped" : "", "\n"; 3395 } 3396 else { 3397 print SAVEOUT "status ", ($? >> 8), "\n"; 3398 } 3399 } ## end if ($?) 3400 3401 # Reopen filehandle for our output (if we can) and 3402 # restore STDOUT (if we can). 3403 open(OUT, ">&STDOUT") || &warn("Can't restore DB::OUT"); 3404 open(STDOUT, ">&SAVEOUT") || 3405 &warn("Can't restore STDOUT"); 3406 3407 # Turn off pipe exception handler if necessary. 3408 $SIG{PIPE} = "DEFAULT" if $SIG{PIPE} eq \&DB::catch; 3409 3410 # Will stop ignoring SIGPIPE if done like nohup(1) 3411 # does SIGINT but Perl doesn't give us a choice. 3412 } ## end if ($pager =~ /^\|/) 3413 else { 3414 # Non-piped "pager". Just restore STDOUT. 3415 open(OUT, ">&SAVEOUT") || &warn("Can't restore DB::OUT"); 3416 } 3417 3418 # Close filehandle pager was using, restore the normal one 3419 # if necessary, 3420 close(SAVEOUT); 3421 select($selected), $selected = "" unless $selected eq ""; 3422 3423 # No pipes now. 3424 $piped = ""; 3425 } ## end if ($piped) 3426 } # CMD: 3427 3428=head3 COMMAND LOOP TERMINATION 3429 3430When commands have finished executing, we come here. If the user closed the 3431input filehandle, we turn on C<$fall_off_end> to emulate a C<q> command. We 3432evaluate any post-prompt items. We restore C<$@>, C<$!>, C<$^E>, C<$,>, C<$/>, 3433C<$\>, and C<$^W>, and return a null list as expected by the Perl interpreter. 3434The interpreter will then execute the next line and then return control to us 3435again. 3436 3437=cut 3438 3439 # No more commands? Quit. 3440 $fall_off_end = 1 unless defined $cmd; # Emulate `q' on EOF 3441 3442 # Evaluate post-prompt commands. 3443 foreach $evalarg (@$post) { 3444 &eval; 3445 } 3446 } # if ($single || $signal) 3447 3448 # Put the user's globals back where you found them. 3449 ($@, $!, $^E, $,, $/, $\, $^W) = @saved; 3450 (); 3451} ## end sub DB 3452 3453# The following code may be executed now: 3454# BEGIN {warn 4} 3455 3456=head2 sub 3457 3458C<sub> is called whenever a subroutine call happens in the program being 3459debugged. The variable C<$DB::sub> contains the name of the subroutine 3460being called. 3461 3462The core function of this subroutine is to actually call the sub in the proper 3463context, capturing its output. This of course causes C<DB::DB> to get called 3464again, repeating until the subroutine ends and returns control to C<DB::sub> 3465again. Once control returns, C<DB::sub> figures out whether or not to dump the 3466return value, and returns its captured copy of the return value as its own 3467return value. The value then feeds back into the program being debugged as if 3468C<DB::sub> hadn't been there at all. 3469 3470C<sub> does all the work of printing the subroutine entry and exit messages 3471enabled by setting C<$frame>. It notes what sub the autoloader got called for, 3472and also prints the return value if needed (for the C<r> command and if 3473the 16 bit is set in C<$frame>). 3474 3475It also tracks the subroutine call depth by saving the current setting of 3476C<$single> in the C<@stack> package global; if this exceeds the value in 3477C<$deep>, C<sub> automatically turns on printing of the current depth by 3478setting the 4 bit in C<$single>. In any case, it keeps the current setting 3479of stop/don't stop on entry to subs set as it currently is set. 3480 3481=head3 C<caller()> support 3482 3483If C<caller()> is called from the package C<DB>, it provides some 3484additional data, in the following order: 3485 3486=over 4 3487 3488=item * C<$package> 3489 3490The package name the sub was in 3491 3492=item * C<$filename> 3493 3494The filename it was defined in 3495 3496=item * C<$line> 3497 3498The line number it was defined on 3499 3500=item * C<$subroutine> 3501 3502The subroutine name; C<'(eval)'> if an C<eval>(). 3503 3504=item * C<$hasargs> 3505 35061 if it has arguments, 0 if not 3507 3508=item * C<$wantarray> 3509 35101 if array context, 0 if scalar context 3511 3512=item * C<$evaltext> 3513 3514The C<eval>() text, if any (undefined for C<eval BLOCK>) 3515 3516=item * C<$is_require> 3517 3518frame was created by a C<use> or C<require> statement 3519 3520=item * C<$hints> 3521 3522pragma information; subject to change between versions 3523 3524=item * C<$bitmask> 3525 3526pragma information: subject to change between versions 3527 3528=item * C<@DB::args> 3529 3530arguments with which the subroutine was invoked 3531 3532=back 3533 3534=cut 3535 3536sub sub { 3537 3538 # Whether or not the autoloader was running, a scalar to put the 3539 # sub's return value in (if needed), and an array to put the sub's 3540 # return value in (if needed). 3541 my ($al, $ret, @ret) = ""; 3542 3543 # If the last ten characters are C'::AUTOLOAD', note we've traced 3544 # into AUTOLOAD for $sub. 3545 if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') { 3546 $al = " for $$sub"; 3547 } 3548 3549 # We stack the stack pointer and then increment it to protect us 3550 # from a situation that might unwind a whole bunch of call frames 3551 # at once. Localizing the stack pointer means that it will automatically 3552 # unwind the same amount when multiple stack frames are unwound. 3553 local $stack_depth = $stack_depth + 1; # Protect from non-local exits 3554 3555 # Expand @stack. 3556 $#stack = $stack_depth; 3557 3558 # Save current single-step setting. 3559 $stack[-1] = $single; 3560 3561 # Turn off all flags except single-stepping. 3562 $single &= 1; 3563 3564 # If we've gotten really deeply recursed, turn on the flag that will 3565 # make us stop with the 'deep recursion' message. 3566 $single |= 4 if $stack_depth == $deep; 3567 3568 # If frame messages are on ... 3569 ( 3570 $frame & 4 # Extended frame entry message 3571 ? ( 3572 print_lineinfo(' ' x ($stack_depth - 1), "in "), 3573 3574 # Why -1? But it works! :-( 3575 # Because print_trace will call add 1 to it and then call 3576 # dump_trace; this results in our skipping -1+1 = 0 stack frames 3577 # in dump_trace. 3578 print_trace($LINEINFO, -1, 1, 1, "$sub$al") 3579 ) 3580 : print_lineinfo(' ' x ($stack_depth - 1), "entering $sub$al\n") 3581 # standard frame entry message 3582 ) 3583 if $frame; 3584 3585 # Determine the sub's return type,and capture approppriately. 3586 if (wantarray) { 3587 # Called in array context. call sub and capture output. 3588 # DB::DB will recursively get control again if appropriate; we'll come 3589 # back here when the sub is finished. 3590 @ret = &$sub; 3591 3592 # Pop the single-step value back off the stack. 3593 $single |= $stack[$stack_depth--]; 3594 3595 # Check for exit trace messages... 3596 ( 3597 $frame & 4 # Extended exit message 3598 ? ( 3599 print_lineinfo(' ' x $stack_depth, "out "), 3600 print_trace($LINEINFO, -1, 1, 1, "$sub$al") 3601 ) 3602 : print_lineinfo(' ' x $stack_depth, "exited $sub$al\n") 3603 # Standard exit message 3604 ) 3605 if $frame & 2; 3606 3607 # Print the return info if we need to. 3608 if ($doret eq $stack_depth or $frame & 16) { 3609 # Turn off output record separator. 3610 local $\ = ''; 3611 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO); 3612 3613 # Indent if we're printing because of $frame tracing. 3614 print $fh ' ' x $stack_depth if $frame & 16; 3615 3616 # Print the return value. 3617 print $fh "list context return from $sub:\n"; 3618 dumpit($fh, \@ret); 3619 3620 # And don't print it again. 3621 $doret = -2; 3622 } ## end if ($doret eq $stack_depth... 3623 # And we have to return the return value now. 3624 @ret; 3625 3626 } ## end if (wantarray) 3627 3628 # Scalar context. 3629 else { 3630 if (defined wantarray) { 3631 # Save the value if it's wanted at all. 3632 $ret = &$sub; 3633 } 3634 else { 3635 # Void return, explicitly. 3636 &$sub; 3637 undef $ret; 3638 } 3639 3640 # Pop the single-step value off the stack. 3641 $single |= $stack[$stack_depth--]; 3642 3643 # If we're doing exit messages... 3644 ( 3645 $frame & 4 # Extended messsages 3646 ? ( 3647 print_lineinfo(' ' x $stack_depth, "out "), 3648 print_trace($LINEINFO, -1, 1, 1, "$sub$al") 3649 ) 3650 : print_lineinfo(' ' x $stack_depth, "exited $sub$al\n") 3651 # Standard messages 3652 ) 3653 if $frame & 2; 3654 3655 # If we are supposed to show the return value... same as before. 3656 if ($doret eq $stack_depth or $frame & 16 and defined wantarray) { 3657 local $\ = ''; 3658 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO); 3659 print $fh (' ' x $stack_depth) if $frame & 16; 3660 print $fh ( 3661 defined wantarray 3662 ? "scalar context return from $sub: " 3663 : "void context return from $sub\n" 3664 ); 3665 dumpit($fh, $ret) if defined wantarray; 3666 $doret = -2; 3667 } ## end if ($doret eq $stack_depth... 3668 3669 # Return the appropriate scalar value. 3670 $ret; 3671 } ## end else [ if (wantarray) 3672} ## end sub sub 3673 3674=head1 EXTENDED COMMAND HANDLING AND THE COMMAND API 3675 3676In Perl 5.8.0, there was a major realignment of the commands and what they did, 3677Most of the changes were to systematize the command structure and to eliminate 3678commands that threw away user input without checking. 3679 3680The following sections describe the code added to make it easy to support 3681multiple command sets with conflicting command names. This section is a start 3682at unifying all command processing to make it simpler to develop commands. 3683 3684Note that all the cmd_[a-zA-Z] subroutines require the command name, a line 3685number, and C<$dbline> (the current line) as arguments. 3686 3687Support functions in this section which have multiple modes of failure C<die> 3688on error; the rest simply return a false value. 3689 3690The user-interface functions (all of the C<cmd_*> functions) just output 3691error messages. 3692 3693=head2 C<%set> 3694 3695The C<%set> hash defines the mapping from command letter to subroutine 3696name suffix. 3697 3698C<%set> is a two-level hash, indexed by set name and then by command name. 3699Note that trying to set the CommandSet to 'foobar' simply results in the 37005.8.0 command set being used, since there's no top-level entry for 'foobar'. 3701 3702=cut 3703 3704### The API section 3705 3706my %set = ( # 3707 'pre580' => { 3708 'a' => 'pre580_a', 3709 'A' => 'pre580_null', 3710 'b' => 'pre580_b', 3711 'B' => 'pre580_null', 3712 'd' => 'pre580_null', 3713 'D' => 'pre580_D', 3714 'h' => 'pre580_h', 3715 'M' => 'pre580_null', 3716 'O' => 'o', 3717 'o' => 'pre580_null', 3718 'v' => 'M', 3719 'w' => 'v', 3720 'W' => 'pre580_W', 3721 }, 3722 'pre590' => { 3723 '<' => 'pre590_prepost', 3724 '<<' => 'pre590_prepost', 3725 '>' => 'pre590_prepost', 3726 '>>' => 'pre590_prepost', 3727 '{' => 'pre590_prepost', 3728 '{{' => 'pre590_prepost', 3729 }, 3730 ); 3731 3732=head2 C<cmd_wrapper()> (API) 3733 3734C<cmd_wrapper()> allows the debugger to switch command sets 3735depending on the value of the C<CommandSet> option. 3736 3737It tries to look up the command in the X<C<%set>> package-level I<lexical> 3738(which means external entities can't fiddle with it) and create the name of 3739the sub to call based on the value found in the hash (if it's there). I<All> 3740of the commands to be handled in a set have to be added to C<%set>; if they 3741aren't found, the 5.8.0 equivalent is called (if there is one). 3742 3743This code uses symbolic references. 3744 3745=cut 3746 3747sub cmd_wrapper { 3748 my $cmd = shift; 3749 my $line = shift; 3750 my $dblineno = shift; 3751 3752 # Assemble the command subroutine's name by looking up the 3753 # command set and command name in %set. If we can't find it, 3754 # default to the older version of the command. 3755 my $call = 'cmd_' 3756 . ( $set{$CommandSet}{$cmd} 3757 || ( $cmd =~ /^[<>{]+/o ? 'prepost' : $cmd ) ); 3758 3759 # Call the command subroutine, call it by name. 3760 return &$call($cmd, $line, $dblineno); 3761} ## end sub cmd_wrapper 3762 3763=head3 C<cmd_a> (command) 3764 3765The C<a> command handles pre-execution actions. These are associated with a 3766particular line, so they're stored in C<%dbline>. We default to the current 3767line if none is specified. 3768 3769=cut 3770 3771sub cmd_a { 3772 my $cmd = shift; 3773 my $line = shift || ''; # [.|line] expr 3774 my $dbline = shift; 3775 3776 # If it's dot (here), or not all digits, use the current line. 3777 $line =~ s/^(\.|(?:[^\d]))/$dbline/; 3778 3779 # Should be a line number followed by an expression. 3780 if ($line =~ /^\s*(\d*)\s*(\S.+)/) { 3781 my ($lineno, $expr) = ($1, $2); 3782 3783 # If we have an expression ... 3784 if (length $expr) { 3785 # ... but the line isn't breakable, complain. 3786 if ($dbline[$lineno] == 0) { 3787 print $OUT 3788 "Line $lineno($dbline[$lineno]) does not have an action?\n"; 3789 } 3790 else { 3791 # It's executable. Record that the line has an action. 3792 $had_breakpoints{$filename} |= 2; 3793 3794 # Remove any action, temp breakpoint, etc. 3795 $dbline{$lineno} =~ s/\0[^\0]*//; 3796 3797 # Add the action to the line. 3798 $dbline{$lineno} .= "\0" . action($expr); 3799 } 3800 } ## end if (length $expr) 3801 } ## end if ($line =~ /^\s*(\d*)\s*(\S.+)/) 3802 else { 3803 # Syntax wrong. 3804 print $OUT 3805 "Adding an action requires an optional lineno and an expression\n" 3806 ; # hint 3807 } 3808} ## end sub cmd_a 3809 3810=head3 C<cmd_A> (command) 3811 3812Delete actions. Similar to above, except the delete code is in a separate 3813subroutine, C<delete_action>. 3814 3815=cut 3816 3817sub cmd_A { 3818 my $cmd = shift; 3819 my $line = shift || ''; 3820 my $dbline = shift; 3821 3822 # Dot is this line. 3823 $line =~ s/^\./$dbline/; 3824 3825 # Call delete_action with a null param to delete them all. 3826 # The '1' forces the eval to be true. It'll be false only 3827 # if delete_action blows up for some reason, in which case 3828 # we print $@ and get out. 3829 if ($line eq '*') { 3830 eval { &delete_action(); 1 } or print $OUT $@ and return; 3831 } 3832 3833 # There's a real line number. Pass it to delete_action. 3834 # Error trapping is as above. 3835 elsif ($line =~ /^(\S.*)/) { 3836 eval { &delete_action($1); 1 } or print $OUT $@ and return; 3837 } 3838 3839 # Swing and a miss. Bad syntax. 3840 else { 3841 print $OUT 3842 "Deleting an action requires a line number, or '*' for all\n" 3843 ; # hint 3844 } 3845} ## end sub cmd_A 3846 3847=head3 C<delete_action> (API) 3848 3849C<delete_action> accepts either a line number or C<undef>. If a line number 3850is specified, we check for the line being executable (if it's not, it 3851couldn't have had an action). If it is, we just take the action off (this 3852will get any kind of an action, including breakpoints). 3853 3854=cut 3855 3856sub delete_action { 3857 my $i = shift; 3858 if (defined($i)) { 3859 # Can there be one? 3860 die "Line $i has no action .\n" if $dbline[$i] == 0; 3861 3862 # Nuke whatever's there. 3863 $dbline{$i} =~ s/\0[^\0]*//; # \^a 3864 delete $dbline{$i} if $dbline{$i} eq ''; 3865 } 3866 else { 3867 print $OUT "Deleting all actions...\n"; 3868 for my $file (keys %had_breakpoints) { 3869 local *dbline = $main::{ '_<' . $file }; 3870 my $max = $#dbline; 3871 my $was; 3872 for ($i = 1 ; $i <= $max ; $i++) { 3873 if (defined $dbline{$i}) { 3874 $dbline{$i} =~ s/\0[^\0]*//; 3875 delete $dbline{$i} if $dbline{$i} eq ''; 3876 } 3877 unless ($had_breakpoints{$file} &= ~2) { 3878 delete $had_breakpoints{$file}; 3879 } 3880 } ## end for ($i = 1 ; $i <= $max... 3881 } ## end for my $file (keys %had_breakpoints) 3882 } ## end else [ if (defined($i)) 3883} ## end sub delete_action 3884 3885=head3 C<cmd_b> (command) 3886 3887Set breakpoints. Since breakpoints can be set in so many places, in so many 3888ways, conditionally or not, the breakpoint code is kind of complex. Mostly, 3889we try to parse the command type, and then shuttle it off to an appropriate 3890subroutine to actually do the work of setting the breakpoint in the right 3891place. 3892 3893=cut 3894 3895sub cmd_b { 3896 my $cmd = shift; 3897 my $line = shift; # [.|line] [cond] 3898 my $dbline = shift; 3899 3900 # Make . the current line number if it's there.. 3901 $line =~ s/^\./$dbline/; 3902 3903 # No line number, no condition. Simple break on current line. 3904 if ($line =~ /^\s*$/) { 3905 &cmd_b_line($dbline, 1); 3906 } 3907 3908 # Break on load for a file. 3909 elsif ($line =~ /^load\b\s*(.*)/) { 3910 my $file = $1; 3911 $file =~ s/\s+$//; 3912 &cmd_b_load($file); 3913 } 3914 3915 # b compile|postpone <some sub> [<condition>] 3916 # The interpreter actually traps this one for us; we just put the 3917 # necessary condition in the %postponed hash. 3918 elsif ($line =~ /^(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/) { 3919 # Capture the condition if there is one. Make it true if none. 3920 my $cond = length $3 ? $3 : '1'; 3921 3922 # Save the sub name and set $break to 1 if $1 was 'postpone', 0 3923 # if it was 'compile'. 3924 my ($subname, $break) = ($2, $1 eq 'postpone'); 3925 3926 # De-Perl4-ify the name - ' separators to ::. 3927 $subname =~ s/\'/::/g; 3928 3929 # Qualify it into the current package unless it's already qualified. 3930 $subname = "${'package'}::" . $subname unless $subname =~ /::/; 3931 3932 # Add main if it starts with ::. 3933 $subname = "main" . $subname if substr($subname, 0, 2) eq "::"; 3934 3935 # Save the break type for this sub. 3936 $postponed{$subname} = $break ? "break +0 if $cond" : "compile"; 3937 } ## end elsif ($line =~ ... 3938 3939 # b <sub name> [<condition>] 3940 elsif ($line =~ /^([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/) { 3941 # 3942 $subname = $1; 3943 $cond = length $2 ? $2 : '1'; 3944 &cmd_b_sub($subname, $cond); 3945 } 3946 3947 # b <line> [<condition>]. 3948 elsif ($line =~ /^(\d*)\s*(.*)/) { 3949 # Capture the line. If none, it's the current line. 3950 $line = $1 || $dbline; 3951 3952 # If there's no condition, make it '1'. 3953 $cond = length $2 ? $2 : '1'; 3954 3955 # Break on line. 3956 &cmd_b_line($line, $cond); 3957 } 3958 3959 # Line didn't make sense. 3960 else { 3961 print "confused by line($line)?\n"; 3962 } 3963} ## end sub cmd_b 3964 3965=head3 C<break_on_load> (API) 3966 3967We want to break when this file is loaded. Mark this file in the 3968C<%break_on_load> hash, and note that it has a breakpoint in 3969C<%had_breakpoints>. 3970 3971=cut 3972 3973sub break_on_load { 3974 my $file = shift; 3975 $break_on_load{$file} = 1; 3976 $had_breakpoints{$file} |= 1; 3977} 3978 3979=head3 C<report_break_on_load> (API) 3980 3981Gives us an array of filenames that are set to break on load. Note that 3982only files with break-on-load are in here, so simply showing the keys 3983suffices. 3984 3985=cut 3986 3987sub report_break_on_load { 3988 sort keys %break_on_load; 3989} 3990 3991=head3 C<cmd_b_load> (command) 3992 3993We take the file passed in and try to find it in C<%INC> (which maps modules 3994to files they came from). We mark those files for break-on-load via 3995C<break_on_load> and then report that it was done. 3996 3997=cut 3998 3999sub cmd_b_load { 4000 my $file = shift; 4001 my @files; 4002 4003 # This is a block because that way we can use a redo inside it 4004 # even without there being any looping structure at all outside it. 4005 { 4006 # Save short name and full path if found. 4007 push @files, $file; 4008 push @files, $::INC{$file} if $::INC{$file}; 4009 4010 # Tack on .pm and do it again unless there was a '.' in the name 4011 # already. 4012 $file .= '.pm', redo unless $file =~ /\./; 4013 } 4014 4015 # Do the real work here. 4016 break_on_load($_) for @files; 4017 4018 # All the files that have break-on-load breakpoints. 4019 @files = report_break_on_load; 4020 4021 # Normalize for the purposes of our printing this. 4022 local $\ = ''; 4023 local $" = ' '; 4024 print $OUT "Will stop on load of `@files'.\n"; 4025} ## end sub cmd_b_load 4026 4027=head3 C<$filename_error> (API package global) 4028 4029Several of the functions we need to implement in the API need to work both 4030on the current file and on other files. We don't want to duplicate code, so 4031C<$filename_error> is used to contain the name of the file that's being 4032worked on (if it's not the current one). 4033 4034We can now build functions in pairs: the basic function works on the current 4035file, and uses C<$filename_error> as part of its error message. Since this is 4036initialized to C<''>, no filename will appear when we are working on the 4037current file. 4038 4039The second function is a wrapper which does the following: 4040 4041=over 4 4042 4043=item * Localizes C<$filename_error> and sets it to the name of the file to be processed. 4044 4045=item * Localizes the C<*dbline> glob and reassigns it to point to the file we want to process. 4046 4047=item * Calls the first function. 4048 4049The first function works on the "current" (i.e., the one we changed to) file, 4050and prints C<$filename_error> in the error message (the name of the other file) 4051if it needs to. When the functions return, C<*dbline> is restored to point to the actual current file (the one we're executing in) and C<$filename_error> is 4052restored to C<''>. This restores everything to the way it was before the 4053second function was called at all. 4054 4055See the comments in C<breakable_line> and C<breakable_line_in_file> for more 4056details. 4057 4058=back 4059 4060=cut 4061 4062$filename_error = ''; 4063 4064=head3 breakable_line($from, $to) (API) 4065 4066The subroutine decides whether or not a line in the current file is breakable. 4067It walks through C<@dbline> within the range of lines specified, looking for 4068the first line that is breakable. 4069 4070If C<$to> is greater than C<$from>, the search moves forwards, finding the 4071first line I<after> C<$to> that's breakable, if there is one. 4072 4073If C<$from> is greater than C<$to>, the search goes I<backwards>, finding the 4074first line I<before> C<$to> that's breakable, if there is one. 4075 4076=cut 4077 4078sub breakable_line { 4079 4080 my ($from, $to) = @_; 4081 4082 # $i is the start point. (Where are the FORTRAN programs of yesteryear?) 4083 my $i = $from; 4084 4085 # If there are at least 2 arguments, we're trying to search a range. 4086 if (@_ >= 2) { 4087 4088 # $delta is positive for a forward search, negative for a backward one. 4089 my $delta = $from < $to ? +1 : -1; 4090 4091 # Keep us from running off the ends of the file. 4092 my $limit = $delta > 0 ? $#dbline : 1; 4093 4094 # Clever test. If you're a mathematician, it's obvious why this 4095 # test works. If not: 4096 # If $delta is positive (going forward), $limit will be $#dbline. 4097 # If $to is less than $limit, ($limit - $to) will be positive, times 4098 # $delta of 1 (positive), so the result is > 0 and we should use $to 4099 # as the stopping point. 4100 # 4101 # If $to is greater than $limit, ($limit - $to) is negative, 4102 # times $delta of 1 (positive), so the result is < 0 and we should 4103 # use $limit ($#dbline) as the stopping point. 4104 # 4105 # If $delta is negative (going backward), $limit will be 1. 4106 # If $to is zero, ($limit - $to) will be 1, times $delta of -1 4107 # (negative) so the result is > 0, and we use $to as the stopping 4108 # point. 4109 # 4110 # If $to is less than zero, ($limit - $to) will be positive, 4111 # times $delta of -1 (negative), so the result is not > 0, and 4112 # we use $limit (1) as the stopping point. 4113 # 4114 # If $to is 1, ($limit - $to) will zero, times $delta of -1 4115 # (negative), still giving zero; the result is not > 0, and 4116 # we use $limit (1) as the stopping point. 4117 # 4118 # if $to is >1, ($limit - $to) will be negative, times $delta of -1 4119 # (negative), giving a positive (>0) value, so we'll set $limit to 4120 # $to. 4121 4122 $limit = $to if ($limit - $to) * $delta > 0; 4123 4124 # The real search loop. 4125 # $i starts at $from (the point we want to start searching from). 4126 # We move through @dbline in the appropriate direction (determined 4127 # by $delta: either -1 (back) or +1 (ahead). 4128 # We stay in as long as we haven't hit an executable line 4129 # ($dbline[$i] == 0 means not executable) and we haven't reached 4130 # the limit yet (test similar to the above). 4131 $i += $delta while $dbline[$i] == 0 and ($limit - $i) * $delta > 0; 4132 4133 } ## end if (@_ >= 2) 4134 4135 # If $i points to a line that is executable, return that. 4136 return $i unless $dbline[$i] == 0; 4137 4138 # Format the message and print it: no breakable lines in range. 4139 my ($pl, $upto) = ('', ''); 4140 ($pl, $upto) = ('s', "..$to") if @_ >= 2 and $from != $to; 4141 4142 # If there's a filename in filename_error, we'll see it. 4143 # If not, not. 4144 die "Line$pl $from$upto$filename_error not breakable\n"; 4145} ## end sub breakable_line 4146 4147=head3 breakable_line_in_filename($file, $from, $to) (API) 4148 4149Like C<breakable_line>, but look in another file. 4150 4151=cut 4152 4153sub breakable_line_in_filename { 4154 # Capture the file name. 4155 my ($f) = shift; 4156 4157 # Swap the magic line array over there temporarily. 4158 local *dbline = $main::{ '_<' . $f }; 4159 4160 # If there's an error, it's in this other file. 4161 local $filename_error = " of `$f'"; 4162 4163 # Find the breakable line. 4164 breakable_line(@_); 4165 4166 # *dbline and $filename_error get restored when this block ends. 4167 4168} ## end sub breakable_line_in_filename 4169 4170=head3 break_on_line(lineno, [condition]) (API) 4171 4172Adds a breakpoint with the specified condition (or 1 if no condition was 4173specified) to the specified line. Dies if it can't. 4174 4175=cut 4176 4177sub break_on_line { 4178 my ($i, $cond) = @_; 4179 4180 # Always true if no condition supplied. 4181 $cond = 1 unless @_ >= 2; 4182 4183 my $inii = $i; 4184 my $after = ''; 4185 my $pl = ''; 4186 4187 # Woops, not a breakable line. $filename_error allows us to say 4188 # if it was in a different file. 4189 die "Line $i$filename_error not breakable.\n" if $dbline[$i] == 0; 4190 4191 # Mark this file as having breakpoints in it. 4192 $had_breakpoints{$filename} |= 1; 4193 4194 # If there is an action or condition here already ... 4195 if ($dbline{$i}) { 4196 # ... swap this condition for the existing one. 4197 $dbline{$i} =~ s/^[^\0]*/$cond/; 4198 } 4199 else { 4200 # Nothing here - just add the condition. 4201 $dbline{$i} = $cond; 4202 } 4203} ## end sub break_on_line 4204 4205=head3 cmd_b_line(line, [condition]) (command) 4206 4207Wrapper for C<break_on_line>. Prints the failure message if it 4208doesn't work. 4209 4210=cut 4211 4212sub cmd_b_line { 4213 eval { break_on_line(@_); 1 } or do { 4214 local $\ = ''; 4215 print $OUT $@ and return; 4216 }; 4217} ## end sub cmd_b_line 4218 4219=head3 break_on_filename_line(file, line, [condition]) (API) 4220 4221Switches to the file specified and then calls C<break_on_line> to set 4222the breakpoint. 4223 4224=cut 4225 4226sub break_on_filename_line { 4227 my ($f, $i, $cond) = @_; 4228 4229 # Always true if condition left off. 4230 $cond = 1 unless @_ >= 3; 4231 4232 # Switch the magical hash temporarily. 4233 local *dbline = $main::{ '_<' . $f }; 4234 4235 # Localize the variables that break_on_line uses to make its message. 4236 local $filename_error = " of `$f'"; 4237 local $filename = $f; 4238 4239 # Add the breakpoint. 4240 break_on_line($i, $cond); 4241} ## end sub break_on_filename_line 4242 4243=head3 break_on_filename_line_range(file, from, to, [condition]) (API) 4244 4245Switch to another file, search the range of lines specified for an 4246executable one, and put a breakpoint on the first one you find. 4247 4248=cut 4249 4250sub break_on_filename_line_range { 4251 my ($f, $from, $to, $cond) = @_; 4252 4253 # Find a breakable line if there is one. 4254 my $i = breakable_line_in_filename($f, $from, $to); 4255 4256 # Always true if missing. 4257 $cond = 1 unless @_ >= 3; 4258 4259 # Add the breakpoint. 4260 break_on_filename_line($f, $i, $cond); 4261} ## end sub break_on_filename_line_range 4262 4263=head3 subroutine_filename_lines(subname, [condition]) (API) 4264 4265Search for a subroutine within a given file. The condition is ignored. 4266Uses C<find_sub> to locate the desired subroutine. 4267 4268=cut 4269 4270sub subroutine_filename_lines { 4271 my ($subname, $cond) = @_; 4272 4273 # Returned value from find_sub() is fullpathname:startline-endline. 4274 # The match creates the list (fullpathname, start, end). Falling off 4275 # the end of the subroutine returns this implicitly. 4276 find_sub($subname) =~ /^(.*):(\d+)-(\d+)$/; 4277} ## end sub subroutine_filename_lines 4278 4279=head3 break_subroutine(subname) (API) 4280 4281Places a break on the first line possible in the specified subroutine. Uses 4282C<subroutine_filename_lines> to find the subroutine, and 4283C<break_on_filename_line_range> to place the break. 4284 4285=cut 4286 4287sub break_subroutine { 4288 my $subname = shift; 4289 4290 # Get filename, start, and end. 4291 my ($file, $s, $e) = subroutine_filename_lines($subname) 4292 or die "Subroutine $subname not found.\n"; 4293 4294 # Null condition changes to '1' (always true). 4295 $cond = 1 unless @_ >= 2; 4296 4297 # Put a break the first place possible in the range of lines 4298 # that make up this subroutine. 4299 break_on_filename_line_range($file, $s, $e, @_); 4300} ## end sub break_subroutine 4301 4302=head3 cmd_b_sub(subname, [condition]) (command) 4303 4304We take the incoming subroutine name and fully-qualify it as best we can. 4305 4306=over 4 4307 4308=item 1. If it's already fully-qualified, leave it alone. 4309 4310=item 2. Try putting it in the current package. 4311 4312=item 3. If it's not there, try putting it in CORE::GLOBAL if it exists there. 4313 4314=item 4. If it starts with '::', put it in 'main::'. 4315 4316=back 4317 4318After all this cleanup, we call C<break_subroutine> to try to set the 4319breakpoint. 4320 4321=cut 4322 4323sub cmd_b_sub { 4324 my ($subname, $cond) = @_; 4325 4326 # Add always-true condition if we have none. 4327 $cond = 1 unless @_ >= 2; 4328 4329 # If the subname isn't a code reference, qualify it so that 4330 # break_subroutine() will work right. 4331 unless (ref $subname eq 'CODE') { 4332 # Not Perl4. 4333 $subname =~ s/\'/::/g; 4334 my $s = $subname; 4335 4336 # Put it in this package unless it's already qualified. 4337 $subname = "${'package'}::" . $subname 4338 unless $subname =~ /::/; 4339 4340 # Requalify it into CORE::GLOBAL if qualifying it into this 4341 # package resulted in its not being defined, but only do so 4342 # if it really is in CORE::GLOBAL. 4343 $subname = "CORE::GLOBAL::$s" 4344 if not defined &$subname 4345 and $s !~ /::/ 4346 and defined &{"CORE::GLOBAL::$s"}; 4347 4348 # Put it in package 'main' if it has a leading ::. 4349 $subname = "main" . $subname if substr($subname, 0, 2) eq "::"; 4350 4351 } ## end unless (ref $subname eq 'CODE') 4352 4353 # Try to set the breakpoint. 4354 eval { break_subroutine($subname, $cond); 1 } or do { 4355 local $\ = ''; 4356 print $OUT $@ and return; 4357 } 4358} ## end sub cmd_b_sub 4359 4360=head3 C<cmd_B> - delete breakpoint(s) (command) 4361 4362The command mostly parses the command line and tries to turn the argument 4363into a line spec. If it can't, it uses the current line. It then calls 4364C<delete_breakpoint> to actually do the work. 4365 4366If C<*> is specified, C<cmd_B> calls C<delete_breakpoint> with no arguments, 4367thereby deleting all the breakpoints. 4368 4369=cut 4370 4371sub cmd_B { 4372 my $cmd = shift; 4373 4374 # No line spec? Use dbline. 4375 # If there is one, use it if it's non-zero, or wipe it out if it is. 4376 my $line = ($_[0] =~ /^\./) ? $dbline : shift || ''; 4377 my $dbline = shift; 4378 4379 # If the line was dot, make the line the current one. 4380 $line =~ s/^\./$dbline/; 4381 4382 # If it's * we're deleting all the breakpoints. 4383 if ($line eq '*') { 4384 eval { &delete_breakpoint(); 1 } or print $OUT $@ and return; 4385 } 4386 4387 # If there is a line spec, delete the breakpoint on that line. 4388 elsif ($line =~ /^(\S.*)/) { 4389 eval { &delete_breakpoint($line || $dbline); 1 } or do { 4390 local $\ = ''; 4391 print $OUT $@ and return; 4392 }; 4393 } ## end elsif ($line =~ /^(\S.*)/) 4394 4395 # No line spec. 4396 else { 4397 print $OUT 4398 "Deleting a breakpoint requires a line number, or '*' for all\n" 4399 ; # hint 4400 } 4401} ## end sub cmd_B 4402 4403=head3 delete_breakpoint([line]) (API) 4404 4405This actually does the work of deleting either a single breakpoint, or all 4406of them. 4407 4408For a single line, we look for it in C<@dbline>. If it's nonbreakable, we 4409just drop out with a message saying so. If it is, we remove the condition 4410part of the 'condition\0action' that says there's a breakpoint here. If, 4411after we've done that, there's nothing left, we delete the corresponding 4412line in C<%dbline> to signal that no action needs to be taken for this line. 4413 4414For all breakpoints, we iterate through the keys of C<%had_breakpoints>, 4415which lists all currently-loaded files which have breakpoints. We then look 4416at each line in each of these files, temporarily switching the C<%dbline> 4417and C<@dbline> structures to point to the files in question, and do what 4418we did in the single line case: delete the condition in C<@dbline>, and 4419delete the key in C<%dbline> if nothing's left. 4420 4421We then wholesale delete C<%postponed>, C<%postponed_file>, and 4422C<%break_on_load>, because these structures contain breakpoints for files 4423and code that haven't been loaded yet. We can just kill these off because there 4424are no magical debugger structures associated with them. 4425 4426=cut 4427 4428sub delete_breakpoint { 4429 my $i = shift; 4430 4431 # If we got a line, delete just that one. 4432 if (defined($i)) { 4433 4434 # Woops. This line wasn't breakable at all. 4435 die "Line $i not breakable.\n" if $dbline[$i] == 0; 4436 4437 # Kill the condition, but leave any action. 4438 $dbline{$i} =~ s/^[^\0]*//; 4439 4440 # Remove the entry entirely if there's no action left. 4441 delete $dbline{$i} if $dbline{$i} eq ''; 4442 } 4443 4444 # No line; delete them all. 4445 else { 4446 print $OUT "Deleting all breakpoints...\n"; 4447 4448 # %had_breakpoints lists every file that had at least one 4449 # breakpoint in it. 4450 for my $file (keys %had_breakpoints) { 4451 # Switch to the desired file temporarily. 4452 local *dbline = $main::{ '_<' . $file }; 4453 4454 my $max = $#dbline; 4455 my $was; 4456 4457 # For all lines in this file ... 4458 for ($i = 1 ; $i <= $max ; $i++) { 4459 # If there's a breakpoint or action on this line ... 4460 if (defined $dbline{$i}) { 4461 # ... remove the breakpoint. 4462 $dbline{$i} =~ s/^[^\0]+//; 4463 if ($dbline{$i} =~ s/^\0?$//) { 4464 # Remove the entry altogether if no action is there. 4465 delete $dbline{$i}; 4466 } 4467 } ## end if (defined $dbline{$i... 4468 } ## end for ($i = 1 ; $i <= $max... 4469 4470 # If, after we turn off the "there were breakpoints in this file" 4471 # bit, the entry in %had_breakpoints for this file is zero, 4472 # we should remove this file from the hash. 4473 if (not $had_breakpoints{$file} &= ~1) { 4474 delete $had_breakpoints{$file}; 4475 } 4476 } ## end for my $file (keys %had_breakpoints) 4477 4478 # Kill off all the other breakpoints that are waiting for files that 4479 # haven't been loaded yet. 4480 undef %postponed; 4481 undef %postponed_file; 4482 undef %break_on_load; 4483 } ## end else [ if (defined($i)) 4484} ## end sub delete_breakpoint 4485 4486=head3 cmd_stop (command) 4487 4488This is meant to be part of the new command API, but it isn't called or used 4489anywhere else in the debugger. XXX It is probably meant for use in development 4490of new commands. 4491 4492=cut 4493 4494sub cmd_stop { # As on ^C, but not signal-safy. 4495 $signal = 1; 4496} 4497 4498=head3 C<cmd_h> - help command (command) 4499 4500Does the work of either 4501 4502=over 4 4503 4504=item * Showing all the debugger help 4505 4506=item * Showing help for a specific command 4507 4508=back 4509 4510=cut 4511 4512sub cmd_h { 4513 my $cmd = shift; 4514 4515 # If we have no operand, assume null. 4516 my $line = shift || ''; 4517 4518 # 'h h'. Print the long-format help. 4519 if ($line =~ /^h\s*/) { 4520 print_help($help); 4521 } 4522 4523 # 'h <something>'. Search for the command and print only its help. 4524 elsif ($line =~ /^(\S.*)$/) { 4525 4526 # support long commands; otherwise bogus errors 4527 # happen when you ask for h on <CR> for example 4528 my $asked = $1; # the command requested 4529 # (for proper error message) 4530 4531 my $qasked = quotemeta($asked); # for searching; we don't 4532 # want to use it as a pattern. 4533 # XXX: finds CR but not <CR> 4534 4535 # Search the help string for the command. 4536 if ($help =~ /^ # Start of a line 4537 <? # Optional '<' 4538 (?:[IB]<) # Optional markup 4539 $qasked # The requested command 4540 /mx) { 4541 # It's there; pull it out and print it. 4542 while ($help =~ /^ 4543 (<? # Optional '<' 4544 (?:[IB]<) # Optional markup 4545 $qasked # The command 4546 ([\s\S]*?) # Description line(s) 4547 \n) # End of last description line 4548 (?!\s) # Next line not starting with 4549 # whitespace 4550 /mgx) { 4551 print_help($1); 4552 } 4553 } 4554 4555 # Not found; not a debugger command. 4556 else { 4557 print_help("B<$asked> is not a debugger command.\n"); 4558 } 4559 } ## end elsif ($line =~ /^(\S.*)$/) 4560 4561 # 'h' - print the summary help. 4562 else { 4563 print_help($summary); 4564 } 4565} ## end sub cmd_h 4566 4567=head3 C<cmd_i> - inheritance display 4568 4569Display the (nested) parentage of the module or object given. 4570 4571=cut 4572 4573sub cmd_i { 4574 my $cmd = shift; 4575 my $line = shift; 4576 eval { require Class::ISA }; 4577 if ($@) { 4578 &warn($@ =~ /locate/ ? "Class::ISA module not found - please install\n" : $@); 4579 } else { 4580 ISA: 4581 foreach my $isa (split(/\s+/, $line)) { 4582 no strict 'refs'; 4583 print join(', ', map { # snaffled unceremoniously from Class::ISA 4584 "$_".(defined(${"$_\::VERSION"}) ? ' '.${"$_\::VERSION"} : undef) 4585 } Class::ISA::self_and_super_path($isa)); 4586 print "\n"; 4587 } 4588 } 4589} ## end sub cmd_i 4590 4591=head3 C<cmd_l> - list lines (command) 4592 4593Most of the command is taken up with transforming all the different line 4594specification syntaxes into 'start-stop'. After that is done, the command 4595runs a loop over C<@dbline> for the specified range of lines. It handles 4596the printing of each line and any markers (C<==E<gt>> for current line, 4597C<b> for break on this line, C<a> for action on this line, C<:> for this 4598line breakable). 4599 4600We save the last line listed in the C<$start> global for further listing 4601later. 4602 4603=cut 4604 4605sub cmd_l { 4606 my $current_line = $line; 4607 4608 my $cmd = shift; 4609 my $line = shift; 4610 4611 # If this is '-something', delete any spaces after the dash. 4612 $line =~ s/^-\s*$/-/; 4613 4614 # If the line is '$something', assume this is a scalar containing a 4615 # line number. 4616 if ($line =~ /^(\$.*)/s) { 4617 4618 # Set up for DB::eval() - evaluate in *user* context. 4619 $evalarg = $1; 4620 my ($s) = &eval; 4621 4622 # Ooops. Bad scalar. 4623 print($OUT "Error: $@\n"), next CMD if $@; 4624 4625 # Good scalar. If it's a reference, find what it points to. 4626 $s = CvGV_name($s); 4627 print($OUT "Interpreted as: $1 $s\n"); 4628 $line = "$1 $s"; 4629 4630 # Call self recursively to really do the command. 4631 &cmd_l('l', $s); 4632 } ## end if ($line =~ /^(\$.*)/s) 4633 4634 # l name. Try to find a sub by that name. 4635 elsif ($line =~ /^([\':A-Za-z_][\':\w]*(\[.*\])?)/s) { 4636 my $s = $subname = $1; 4637 4638 # De-Perl4. 4639 $subname =~ s/\'/::/; 4640 4641 # Put it in this package unless it starts with ::. 4642 $subname = $package . "::" . $subname unless $subname =~ /::/; 4643 4644 # Put it in CORE::GLOBAL if t doesn't start with :: and 4645 # it doesn't live in this package and it lives in CORE::GLOBAL. 4646 $subname = "CORE::GLOBAL::$s" 4647 if not defined &$subname 4648 and $s !~ /::/ 4649 and defined &{"CORE::GLOBAL::$s"}; 4650 4651 # Put leading '::' names into 'main::'. 4652 $subname = "main" . $subname if substr($subname, 0, 2) eq "::"; 4653 4654 # Get name:start-stop from find_sub, and break this up at 4655 # colons. 4656 @pieces = split (/:/, find_sub($subname) || $sub{$subname}); 4657 4658 # Pull off start-stop. 4659 $subrange = pop @pieces; 4660 4661 # If the name contained colons, the split broke it up. 4662 # Put it back together. 4663 $file = join (':', @pieces); 4664 4665 # If we're not in that file, switch over to it. 4666 if ($file ne $filename) { 4667 print $OUT "Switching to file '$file'.\n" 4668 unless $slave_editor; 4669 4670 # Switch debugger's magic structures. 4671 *dbline = $main::{ '_<' . $file }; 4672 $max = $#dbline; 4673 $filename = $file; 4674 } ## end if ($file ne $filename) 4675 4676 # Subrange is 'start-stop'. If this is less than a window full, 4677 # swap it to 'start+', which will list a window from the start point. 4678 if ($subrange) { 4679 if (eval($subrange) < -$window) { 4680 $subrange =~ s/-.*/+/; 4681 } 4682 # Call self recursively to list the range. 4683 $line = $subrange; 4684 &cmd_l('l', $subrange); 4685 } ## end if ($subrange) 4686 4687 # Couldn't find it. 4688 else { 4689 print $OUT "Subroutine $subname not found.\n"; 4690 } 4691 } ## end elsif ($line =~ /^([\':A-Za-z_][\':\w]*(\[.*\])?)/s) 4692 4693 # Bare 'l' command. 4694 elsif ($line =~ /^\s*$/) { 4695 # Compute new range to list. 4696 $incr = $window - 1; 4697 $line = $start . '-' . ($start + $incr); 4698 # Recurse to do it. 4699 &cmd_l('l', $line); 4700 } 4701 4702 # l [start]+number_of_lines 4703 elsif ($line =~ /^(\d*)\+(\d*)$/) { 4704 # Don't reset start for 'l +nnn'. 4705 $start = $1 if $1; 4706 4707 # Increment for list. Use window size if not specified. 4708 # (Allows 'l +' to work.) 4709 $incr = $2; 4710 $incr = $window - 1 unless $incr; 4711 4712 # Create a line range we'll understand, and recurse to do it. 4713 $line = $start . '-' . ($start + $incr); 4714 &cmd_l('l', $line); 4715 } ## end elsif ($line =~ /^(\d*)\+(\d*)$/) 4716 4717 # l start-stop or l start,stop 4718 elsif ($line =~ /^((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/) { 4719 4720 # Determine end point; use end of file if not specified. 4721 $end = (!defined $2) ? $max : ($4 ? $4 : $2); 4722 4723 # Go on to the end, and then stop. 4724 $end = $max if $end > $max; 4725 4726 # Determine start line. 4727 $i = $2; 4728 $i = $line if $i eq '.'; 4729 $i = 1 if $i < 1; 4730 $incr = $end - $i; 4731 4732 # If we're running under a slave editor, force it to show the lines. 4733 if ($slave_editor) { 4734 print $OUT "\032\032$filename:$i:0\n"; 4735 $i = $end; 4736 } 4737 4738 # We're doing it ourselves. We want to show the line and special 4739 # markers for: 4740 # - the current line in execution 4741 # - whether a line is breakable or not 4742 # - whether a line has a break or not 4743 # - whether a line has an action or not 4744 else { 4745 for (; $i <= $end ; $i++) { 4746 # Check for breakpoints and actions. 4747 my ($stop, $action); 4748 ($stop, $action) = split (/\0/, $dbline{$i}) 4749 if $dbline{$i}; 4750 4751 # ==> if this is the current line in execution, 4752 # : if it's breakable. 4753 $arrow = 4754 ($i == $current_line and $filename eq $filename_ini) 4755 ? '==>' 4756 : ($dbline[$i] + 0 ? ':' : ' '); 4757 4758 # Add break and action indicators. 4759 $arrow .= 'b' if $stop; 4760 $arrow .= 'a' if $action; 4761 4762 # Print the line. 4763 print $OUT "$i$arrow\t", $dbline[$i]; 4764 4765 # Move on to the next line. Drop out on an interrupt. 4766 $i++, last if $signal; 4767 } ## end for (; $i <= $end ; $i++) 4768 4769 # Line the prompt up; print a newline if the last line listed 4770 # didn't have a newline. 4771 print $OUT "\n" unless $dbline[$i - 1] =~ /\n$/; 4772 } ## end else [ if ($slave_editor) 4773 4774 # Save the point we last listed to in case another relative 'l' 4775 # command is desired. Don't let it run off the end. 4776 $start = $i; 4777 $start = $max if $start > $max; 4778 } ## end elsif ($line =~ /^((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/) 4779} ## end sub cmd_l 4780 4781=head3 C<cmd_L> - list breakpoints, actions, and watch expressions (command) 4782 4783To list breakpoints, the command has to look determine where all of them are 4784first. It starts a C<%had_breakpoints>, which tells us what all files have 4785breakpoints and/or actions. For each file, we switch the C<*dbline> glob (the 4786magic source and breakpoint data structures) to the file, and then look 4787through C<%dbline> for lines with breakpoints and/or actions, listing them 4788out. We look through C<%postponed> not-yet-compiled subroutines that have 4789breakpoints, and through C<%postponed_file> for not-yet-C<require>'d files 4790that have breakpoints. 4791 4792Watchpoints are simpler: we just list the entries in C<@to_watch>. 4793 4794=cut 4795 4796sub cmd_L { 4797 my $cmd = shift; 4798 4799 # If no argument, list everything. Pre-5.8.0 version always lists 4800 # everything 4801 my $arg = shift || 'abw'; 4802 $arg = 'abw' unless $CommandSet eq '580'; # sigh... 4803 4804 # See what is wanted. 4805 my $action_wanted = ($arg =~ /a/) ? 1 : 0; 4806 my $break_wanted = ($arg =~ /b/) ? 1 : 0; 4807 my $watch_wanted = ($arg =~ /w/) ? 1 : 0; 4808 4809 # Breaks and actions are found together, so we look in the same place 4810 # for both. 4811 if ($break_wanted or $action_wanted) { 4812 # Look in all the files with breakpoints... 4813 for my $file (keys %had_breakpoints) { 4814 # Temporary switch to this file. 4815 local *dbline = $main::{ '_<' . $file }; 4816 4817 # Set up to look through the whole file. 4818 my $max = $#dbline; 4819 my $was; # Flag: did we print something 4820 # in this file? 4821 4822 # For each line in the file ... 4823 for ($i = 1 ; $i <= $max ; $i++) { 4824 # We've got something on this line. 4825 if (defined $dbline{$i}) { 4826 # Print the header if we haven't. 4827 print $OUT "$file:\n" unless $was++; 4828 4829 # Print the line. 4830 print $OUT " $i:\t", $dbline[$i]; 4831 4832 # Pull out the condition and the action. 4833 ($stop, $action) = split (/\0/, $dbline{$i}); 4834 4835 # Print the break if there is one and it's wanted. 4836 print $OUT " break if (", $stop, ")\n" 4837 if $stop 4838 and $break_wanted; 4839 4840 # Print the action if there is one and it's wanted. 4841 print $OUT " action: ", $action, "\n" 4842 if $action 4843 and $action_wanted; 4844 4845 # Quit if the user hit interrupt. 4846 last if $signal; 4847 } ## end if (defined $dbline{$i... 4848 } ## end for ($i = 1 ; $i <= $max... 4849 } ## end for my $file (keys %had_breakpoints) 4850 } ## end if ($break_wanted or $action_wanted) 4851 4852 # Look for breaks in not-yet-compiled subs: 4853 if (%postponed and $break_wanted) { 4854 print $OUT "Postponed breakpoints in subroutines:\n"; 4855 my $subname; 4856 for $subname (keys %postponed) { 4857 print $OUT " $subname\t$postponed{$subname}\n"; 4858 last if $signal; 4859 } 4860 } ## end if (%postponed and $break_wanted) 4861 4862 # Find files that have not-yet-loaded breaks: 4863 my @have = map { # Combined keys 4864 keys %{ $postponed_file{$_} } 4865 } keys %postponed_file; 4866 4867 # If there are any, list them. 4868 if (@have and ($break_wanted or $action_wanted)) { 4869 print $OUT "Postponed breakpoints in files:\n"; 4870 my ($file, $line); 4871 4872 for $file (keys %postponed_file) { 4873 my $db = $postponed_file{$file}; 4874 print $OUT " $file:\n"; 4875 for $line (sort { $a <=> $b } keys %$db) { 4876 print $OUT " $line:\n"; 4877 my ($stop, $action) = split (/\0/, $$db{$line}); 4878 print $OUT " break if (", $stop, ")\n" 4879 if $stop 4880 and $break_wanted; 4881 print $OUT " action: ", $action, "\n" 4882 if $action 4883 and $action_wanted; 4884 last if $signal; 4885 } ## end for $line (sort { $a <=>... 4886 last if $signal; 4887 } ## end for $file (keys %postponed_file) 4888 } ## end if (@have and ($break_wanted... 4889 if (%break_on_load and $break_wanted) { 4890 print $OUT "Breakpoints on load:\n"; 4891 my $file; 4892 for $file (keys %break_on_load) { 4893 print $OUT " $file\n"; 4894 last if $signal; 4895 } 4896 } ## end if (%break_on_load and... 4897 if ($watch_wanted) { 4898 if ($trace & 2) { 4899 print $OUT "Watch-expressions:\n" if @to_watch; 4900 for my $expr (@to_watch) { 4901 print $OUT " $expr\n"; 4902 last if $signal; 4903 } 4904 } ## end if ($trace & 2) 4905 } ## end if ($watch_wanted) 4906} ## end sub cmd_L 4907 4908=head3 C<cmd_M> - list modules (command) 4909 4910Just call C<list_modules>. 4911 4912=cut 4913 4914sub cmd_M { 4915 &list_modules(); 4916} 4917 4918=head3 C<cmd_o> - options (command) 4919 4920If this is just C<o> by itself, we list the current settings via 4921C<dump_option>. If there's a nonblank value following it, we pass that on to 4922C<parse_options> for processing. 4923 4924=cut 4925 4926sub cmd_o { 4927 my $cmd = shift; 4928 my $opt = shift || ''; # opt[=val] 4929 4930 # Nonblank. Try to parse and process. 4931 if ($opt =~ /^(\S.*)/) { 4932 &parse_options($1); 4933 } 4934 4935 # Blank. List the current option settings. 4936 else { 4937 for (@options) { 4938 &dump_option($_); 4939 } 4940 } 4941} ## end sub cmd_o 4942 4943=head3 C<cmd_O> - nonexistent in 5.8.x (command) 4944 4945Advises the user that the O command has been renamed. 4946 4947=cut 4948 4949sub cmd_O { 4950 print $OUT "The old O command is now the o command.\n"; # hint 4951 print $OUT "Use 'h' to get current command help synopsis or\n"; # 4952 print $OUT "use 'o CommandSet=pre580' to revert to old usage\n"; # 4953} 4954 4955=head3 C<cmd_v> - view window (command) 4956 4957Uses the C<$preview> variable set in the second C<BEGIN> block (q.v.) to 4958move back a few lines to list the selected line in context. Uses C<cmd_l> 4959to do the actual listing after figuring out the range of line to request. 4960 4961=cut 4962 4963sub cmd_v { 4964 my $cmd = shift; 4965 my $line = shift; 4966 4967 # Extract the line to list around. (Astute readers will have noted that 4968 # this pattern will match whether or not a numeric line is specified, 4969 # which means that we'll always enter this loop (though a non-numeric 4970 # argument results in no action at all)). 4971 if ($line =~ /^(\d*)$/) { 4972 # Total number of lines to list (a windowful). 4973 $incr = $window - 1; 4974 4975 # Set the start to the argument given (if there was one). 4976 $start = $1 if $1; 4977 4978 # Back up by the context amount. 4979 $start -= $preview; 4980 4981 # Put together a linespec that cmd_l will like. 4982 $line = $start . '-' . ($start + $incr); 4983 4984 # List the lines. 4985 &cmd_l('l', $line); 4986 } ## end if ($line =~ /^(\d*)$/) 4987} ## end sub cmd_v 4988 4989=head3 C<cmd_w> - add a watch expression (command) 4990 4991The 5.8 version of this command adds a watch expression if one is specified; 4992it does nothing if entered with no operands. 4993 4994We extract the expression, save it, evaluate it in the user's context, and 4995save the value. We'll re-evaluate it each time the debugger passes a line, 4996and will stop (see the code at the top of the command loop) if the value 4997of any of the expressions changes. 4998 4999=cut 5000 5001sub cmd_w { 5002 my $cmd = shift; 5003 5004 # Null expression if no arguments. 5005 my $expr = shift || ''; 5006 5007 # If expression is not null ... 5008 if ($expr =~ /^(\S.*)/) { 5009 # ... save it. 5010 push @to_watch, $expr; 5011 5012 # Parameterize DB::eval and call it to get the expression's value 5013 # in the user's context. This version can handle expressions which 5014 # return a list value. 5015 $evalarg = $expr; 5016 my ($val) = join(' ', &eval); 5017 $val = (defined $val) ? "'$val'" : 'undef'; 5018 5019 # Save the current value of the expression. 5020 push @old_watch, $val; 5021 5022 # We are now watching expressions. 5023 $trace |= 2; 5024 } ## end if ($expr =~ /^(\S.*)/) 5025 5026 # You have to give one to get one. 5027 else { 5028 print $OUT 5029 "Adding a watch-expression requires an expression\n"; # hint 5030 } 5031} ## end sub cmd_w 5032 5033=head3 C<cmd_W> - delete watch expressions (command) 5034 5035This command accepts either a watch expression to be removed from the list 5036of watch expressions, or C<*> to delete them all. 5037 5038If C<*> is specified, we simply empty the watch expression list and the 5039watch expression value list. We also turn off the bit that says we've got 5040watch expressions. 5041 5042If an expression (or partial expression) is specified, we pattern-match 5043through the expressions and remove the ones that match. We also discard 5044the corresponding values. If no watch expressions are left, we turn off 5045the 'watching expressions' bit. 5046 5047=cut 5048 5049sub cmd_W { 5050 my $cmd = shift; 5051 my $expr = shift || ''; 5052 5053 # Delete them all. 5054 if ($expr eq '*') { 5055 # Not watching now. 5056 $trace &= ~2; 5057 5058 print $OUT "Deleting all watch expressions ...\n"; 5059 5060 # And all gone. 5061 @to_watch = @old_watch = (); 5062 } 5063 5064 # Delete one of them. 5065 elsif ($expr =~ /^(\S.*)/) { 5066 # Where we are in the list. 5067 my $i_cnt = 0; 5068 5069 # For each expression ... 5070 foreach (@to_watch) { 5071 my $val = $to_watch[$i_cnt]; 5072 5073 # Does this one match the command argument? 5074 if ($val eq $expr) { # =~ m/^\Q$i$/) { 5075 # Yes. Turn it off, and its value too. 5076 splice(@to_watch, $i_cnt, 1); 5077 splice(@old_watch, $i_cnt, 1); 5078 } 5079 $i_cnt++; 5080 } ## end foreach (@to_watch) 5081 5082 # We don't bother to turn watching off because 5083 # a) we don't want to stop calling watchfunction() it it exists 5084 # b) foreach over a null list doesn't do anything anyway 5085 5086 } ## end elsif ($expr =~ /^(\S.*)/) 5087 5088 # No command arguments entered. 5089 else { 5090 print $OUT 5091"Deleting a watch-expression requires an expression, or '*' for all\n" 5092 ; # hint 5093 } 5094} ## end sub cmd_W 5095 5096### END of the API section 5097 5098=head1 SUPPORT ROUTINES 5099 5100These are general support routines that are used in a number of places 5101throughout the debugger. 5102 5103=head2 save 5104 5105save() saves the user's versions of globals that would mess us up in C<@saved>, 5106and installs the versions we like better. 5107 5108=cut 5109 5110sub save { 5111 # Save eval failure, command failure, extended OS error, output field 5112 # separator, input record separator, output record separator and 5113 # the warning setting. 5114 @saved = ($@, $!, $^E, $,, $/, $\, $^W); 5115 5116 $, = ""; # output field separator is null string 5117 $/ = "\n"; # input record separator is newline 5118 $\ = ""; # output record separator is null string 5119 $^W = 0; # warnings are off 5120} ## end sub save 5121 5122=head2 C<print_lineinfo> - show where we are now 5123 5124print_lineinfo prints whatever it is that it is handed; it prints it to the 5125C<$LINEINFO> filehandle instead of just printing it to STDOUT. This allows 5126us to feed line information to a slave editor without messing up the 5127debugger output. 5128 5129=cut 5130 5131sub print_lineinfo { 5132 # Make the terminal sensible if we're not the primary debugger. 5133 resetterm(1) if $LINEINFO eq $OUT and $term_pid != $$; 5134 local $\ = ''; 5135 local $, = ''; 5136 print $LINEINFO @_; 5137} ## end sub print_lineinfo 5138 5139=head2 C<postponed_sub> 5140 5141Handles setting postponed breakpoints in subroutines once they're compiled. 5142For breakpoints, we use C<DB::find_sub> to locate the source file and line 5143range for the subroutine, then mark the file as having a breakpoint, 5144temporarily switch the C<*dbline> glob over to the source file, and then 5145search the given range of lines to find a breakable line. If we find one, 5146we set the breakpoint on it, deleting the breakpoint from C<%postponed>. 5147 5148=cut 5149 5150# The following takes its argument via $evalarg to preserve current @_ 5151 5152sub postponed_sub { 5153 # Get the subroutine name. 5154 my $subname = shift; 5155 5156 # If this is a 'break +<n> if <condition>' ... 5157 if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) { 5158 # If there's no offset, use '+0'. 5159 my $offset = $1 || 0; 5160 5161 # find_sub's value is 'fullpath-filename:start-stop'. It's 5162 # possible that the filename might have colons in it too. 5163 my ($file, $i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/); 5164 if ($i) { 5165 # We got the start line. Add the offset '+<n>' from 5166 # $postponed{subname}. 5167 $i += $offset; 5168 5169 # Switch to the file this sub is in, temporarily. 5170 local *dbline = $main::{ '_<' . $file }; 5171 5172 # No warnings, please. 5173 local $^W = 0; # != 0 is magical below 5174 5175 # This file's got a breakpoint in it. 5176 $had_breakpoints{$file} |= 1; 5177 5178 # Last line in file. 5179 my $max = $#dbline; 5180 5181 # Search forward until we hit a breakable line or get to 5182 # the end of the file. 5183 ++$i until $dbline[$i] != 0 or $i >= $max; 5184 5185 # Copy the breakpoint in and delete it from %postponed. 5186 $dbline{$i} = delete $postponed{$subname}; 5187 } ## end if ($i) 5188 5189 # find_sub didn't find the sub. 5190 else { 5191 local $\ = ''; 5192 print $OUT "Subroutine $subname not found.\n"; 5193 } 5194 return; 5195 } ## end if ($postponed{$subname... 5196 elsif ($postponed{$subname} eq 'compile') { $signal = 1 } 5197 5198 #print $OUT "In postponed_sub for `$subname'.\n"; 5199} ## end sub postponed_sub 5200 5201=head2 C<postponed> 5202 5203Called after each required file is compiled, but before it is executed; 5204also called if the name of a just-compiled subroutine is a key of 5205C<%postponed>. Propagates saved breakpoints (from C<b compile>, C<b load>, 5206etc.) into the just-compiled code. 5207 5208If this is a C<require>'d file, the incoming parameter is the glob 5209C<*{"_<$filename"}>, with C<$filename> the name of the C<require>'d file. 5210 5211If it's a subroutine, the incoming parameter is the subroutine name. 5212 5213=cut 5214 5215sub postponed { 5216 # If there's a break, process it. 5217 if ($ImmediateStop) { 5218 # Right, we've stopped. Turn it off. 5219 $ImmediateStop = 0; 5220 5221 # Enter the command loop when DB::DB gets called. 5222 $signal = 1; 5223 } 5224 5225 # If this is a subroutine, let postponed_sub() deal with it. 5226 return &postponed_sub unless ref \$_[0] eq 'GLOB'; 5227 5228 # Not a subroutine. Deal with the file. 5229 local *dbline = shift; 5230 my $filename = $dbline; 5231 $filename =~ s/^_<//; 5232 local $\ = ''; 5233 $signal = 1, print $OUT "'$filename' loaded...\n" 5234 if $break_on_load{$filename}; 5235 print_lineinfo(' ' x $stack_depth, "Package $filename.\n") if $frame; 5236 5237 # Do we have any breakpoints to put in this file? 5238 return unless $postponed_file{$filename}; 5239 5240 # Yes. Mark this file as having breakpoints. 5241 $had_breakpoints{$filename} |= 1; 5242 5243 # "Cannot be done: unsufficient magic" - we can't just put the 5244 # breakpoints saved in %postponed_file into %dbline by assigning 5245 # the whole hash; we have to do it one item at a time for the 5246 # breakpoints to be set properly. 5247 #%dbline = %{$postponed_file{$filename}}; 5248 5249 # Set the breakpoints, one at a time. 5250 my $key; 5251 5252 for $key (keys %{ $postponed_file{$filename} }) { 5253 # Stash the saved breakpoint into the current file's magic line array. 5254 $dbline{$key} = ${ $postponed_file{$filename} }{$key}; 5255 } 5256 5257 # This file's been compiled; discard the stored breakpoints. 5258 delete $postponed_file{$filename}; 5259 5260} ## end sub postponed 5261 5262=head2 C<dumpit> 5263 5264C<dumpit> is the debugger's wrapper around dumpvar.pl. 5265 5266It gets a filehandle (to which C<dumpvar.pl>'s output will be directed) and 5267a reference to a variable (the thing to be dumped) as its input. 5268 5269The incoming filehandle is selected for output (C<dumpvar.pl> is printing to 5270the currently-selected filehandle, thank you very much). The current 5271values of the package globals C<$single> and C<$trace> are backed up in 5272lexicals, and they are turned off (this keeps the debugger from trying 5273to single-step through C<dumpvar.pl> (I think.)). C<$frame> is localized to 5274preserve its current value and it is set to zero to prevent entry/exit 5275messages from printing, and C<$doret> is localized as well and set to -2 to 5276prevent return values from being shown. 5277 5278C<dumpit()> then checks to see if it needs to load C<dumpvar.pl> and 5279tries to load it (note: if you have a C<dumpvar.pl> ahead of the 5280installed version in @INC, yours will be used instead. Possible security 5281problem?). 5282 5283It then checks to see if the subroutine C<main::dumpValue> is now defined 5284(it should have been defined by C<dumpvar.pl>). If it has, C<dumpit()> 5285localizes the globals necessary for things to be sane when C<main::dumpValue()> 5286is called, and picks up the variable to be dumped from the parameter list. 5287 5288It checks the package global C<%options> to see if there's a C<dumpDepth> 5289specified. If not, -1 is assumed; if so, the supplied value gets passed on to 5290C<dumpvar.pl>. This tells C<dumpvar.pl> where to leave off when dumping a 5291structure: -1 means dump everything. 5292 5293C<dumpValue()> is then called if possible; if not, C<dumpit()>just prints a 5294warning. 5295 5296In either case, C<$single>, C<$trace>, C<$frame>, and C<$doret> are restored 5297and we then return to the caller. 5298 5299=cut 5300 5301sub dumpit { 5302 # Save the current output filehandle and switch to the one 5303 # passed in as the first parameter. 5304 local ($savout) = select(shift); 5305 5306 # Save current settings of $single and $trace, and then turn them off. 5307 my $osingle = $single; 5308 my $otrace = $trace; 5309 $single = $trace = 0; 5310 5311 # XXX Okay, what do $frame and $doret do, again? 5312 local $frame = 0; 5313 local $doret = -2; 5314 5315 # Load dumpvar.pl unless we've already got the sub we need from it. 5316 unless (defined &main::dumpValue) { 5317 do 'dumpvar.pl'; 5318 } 5319 5320 # If the load succeeded (or we already had dumpvalue()), go ahead 5321 # and dump things. 5322 if (defined &main::dumpValue) { 5323 local $\ = ''; 5324 local $, = ''; 5325 local $" = ' '; 5326 my $v = shift; 5327 my $maxdepth = shift || $option{dumpDepth}; 5328 $maxdepth = -1 unless defined $maxdepth; # -1 means infinite depth 5329 &main::dumpValue($v, $maxdepth); 5330 } ## end if (defined &main::dumpValue) 5331 5332 # Oops, couldn't load dumpvar.pl. 5333 else { 5334 local $\ = ''; 5335 print $OUT "dumpvar.pl not available.\n"; 5336 } 5337 5338 # Reset $single and $trace to their old values. 5339 $single = $osingle; 5340 $trace = $otrace; 5341 5342 # Restore the old filehandle. 5343 select($savout); 5344} ## end sub dumpit 5345 5346=head2 C<print_trace> 5347 5348C<print_trace>'s job is to print a stack trace. It does this via the 5349C<dump_trace> routine, which actually does all the ferreting-out of the 5350stack trace data. C<print_trace> takes care of formatting it nicely and 5351printing it to the proper filehandle. 5352 5353Parameters: 5354 5355=over 4 5356 5357=item * The filehandle to print to. 5358 5359=item * How many frames to skip before starting trace. 5360 5361=item * How many frames to print. 5362 5363=item * A flag: if true, print a "short" trace without filenames, line numbers, or arguments 5364 5365=back 5366 5367The original comment below seems to be noting that the traceback may not be 5368correct if this routine is called in a tied method. 5369 5370=cut 5371 5372# Tied method do not create a context, so may get wrong message: 5373 5374sub print_trace { 5375 local $\ = ''; 5376 my $fh = shift; 5377 # If this is going to a slave editor, but we're not the primary 5378 # debugger, reset it first. 5379 resetterm(1) 5380 if $fh eq $LINEINFO # slave editor 5381 and $LINEINFO eq $OUT # normal output 5382 and $term_pid != $$; # not the primary 5383 5384 # Collect the actual trace information to be formatted. 5385 # This is an array of hashes of subroutine call info. 5386 my @sub = dump_trace($_[0] + 1, $_[1]); 5387 5388 # Grab the "short report" flag from @_. 5389 my $short = $_[2]; # Print short report, next one for sub name 5390 5391 # Run through the traceback info, format it, and print it. 5392 my $s; 5393 for ($i = 0 ; $i <= $#sub ; $i++) { 5394 # Drop out if the user has lost interest and hit control-C. 5395 last if $signal; 5396 5397 # Set the separator so arrys print nice. 5398 local $" = ', '; 5399 5400 # Grab and stringify the arguments if they are there. 5401 my $args = 5402 defined $sub[$i]{args} 5403 ? "(@{ $sub[$i]{args} })" 5404 : ''; 5405 # Shorten them up if $maxtrace says they're too long. 5406 $args = (substr $args, 0, $maxtrace - 3) . '...' 5407 if length $args > $maxtrace; 5408 5409 # Get the file name. 5410 my $file = $sub[$i]{file}; 5411 5412 # Put in a filename header if short is off. 5413 $file = $file eq '-e' ? $file : "file `$file'" unless $short; 5414 5415 # Get the actual sub's name, and shorten to $maxtrace's requirement. 5416 $s = $sub[$i]{sub}; 5417 $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace; 5418 5419 # Short report uses trimmed file and sub names. 5420 if ($short) { 5421 my $sub = @_ >= 4 ? $_[3] : $s; 5422 print $fh 5423 "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n"; 5424 } ## end if ($short) 5425 5426 # Non-short report includes full names. 5427 else { 5428 print $fh "$sub[$i]{context} = $s$args" . " called from $file" . 5429 " line $sub[$i]{line}\n"; 5430 } 5431 } ## end for ($i = 0 ; $i <= $#sub... 5432} ## end sub print_trace 5433 5434=head2 dump_trace(skip[,count]) 5435 5436Actually collect the traceback information available via C<caller()>. It does 5437some filtering and cleanup of the data, but mostly it just collects it to 5438make C<print_trace()>'s job easier. 5439 5440C<skip> defines the number of stack frames to be skipped, working backwards 5441from the most current. C<count> determines the total number of frames to 5442be returned; all of them (well, the first 10^9) are returned if C<count> 5443is omitted. 5444 5445This routine returns a list of hashes, from most-recent to least-recent 5446stack frame. Each has the following keys and values: 5447 5448=over 4 5449 5450=item * C<context> - C<.> (null), C<$> (scalar), or C<@> (array) 5451 5452=item * C<sub> - subroutine name, or C<eval> information 5453 5454=item * C<args> - undef, or a reference to an array of arguments 5455 5456=item * C<file> - the file in which this item was defined (if any) 5457 5458=item * C<line> - the line on which it was defined 5459 5460=back 5461 5462=cut 5463 5464sub dump_trace { 5465 5466 # How many levels to skip. 5467 my $skip = shift; 5468 5469 # How many levels to show. (1e9 is a cheap way of saying "all of them"; 5470 # it's unlikely that we'll have more than a billion stack frames. If you 5471 # do, you've got an awfully big machine...) 5472 my $count = shift || 1e9; 5473 5474 # We increment skip because caller(1) is the first level *back* from 5475 # the current one. Add $skip to the count of frames so we have a 5476 # simple stop criterion, counting from $skip to $count+$skip. 5477 $skip++; 5478 $count += $skip; 5479 5480 # These variables are used to capture output from caller(); 5481 my ($p, $file, $line, $sub, $h, $context); 5482 5483 my ($e, $r, @a, @sub, $args); 5484 5485 # XXX Okay... why'd we do that? 5486 my $nothard = not $frame & 8; 5487 local $frame = 0; 5488 5489 # Do not want to trace this. 5490 my $otrace = $trace; 5491 $trace = 0; 5492 5493 # Start out at the skip count. 5494 # If we haven't reached the number of frames requested, and caller() is 5495 # still returning something, stay in the loop. (If we pass the requested 5496 # number of stack frames, or we run out - caller() returns nothing - we 5497 # quit. 5498 # Up the stack frame index to go back one more level each time. 5499 for ( 5500 $i = $skip ; 5501 $i < $count 5502 and ($p, $file, $line, $sub, $h, $context, $e, $r) = caller($i) ; 5503 $i++ 5504 ) 5505 { 5506 5507 # Go through the arguments and save them for later. 5508 @a = (); 5509 for $arg (@args) { 5510 my $type; 5511 if (not defined $arg) { # undefined parameter 5512 push @a, "undef"; 5513 } 5514 5515 elsif ($nothard and tied $arg) { # tied parameter 5516 push @a, "tied"; 5517 } 5518 elsif ($nothard and $type = ref $arg) { # reference 5519 push @a, "ref($type)"; 5520 } 5521 else { # can be stringified 5522 local $_ = 5523 "$arg"; # Safe to stringify now - should not call f(). 5524 5525 # Backslash any single-quotes or backslashes. 5526 s/([\'\\])/\\$1/g; 5527 5528 # Single-quote it unless it's a number or a colon-separated 5529 # name. 5530 s/(.*)/'$1'/s 5531 unless /^(?: -?[\d.]+ | \*[\w:]* )$/x; 5532 5533 # Turn high-bit characters into meta-whatever. 5534 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg; 5535 5536 # Turn control characters into ^-whatever. 5537 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg; 5538 5539 push (@a, $_); 5540 } ## end else [ if (not defined $arg) 5541 } ## end for $arg (@args) 5542 5543 # If context is true, this is array (@)context. 5544 # If context is false, this is scalar ($) context. 5545 # If neither, context isn't defined. (This is apparently a 'can't 5546 # happen' trap.) 5547 $context = $context ? '@' : (defined $context ? "\$" : '.'); 5548 5549 # if the sub has args ($h true), make an anonymous array of the 5550 # dumped args. 5551 $args = $h ? [@a] : undef; 5552 5553 # remove trailing newline-whitespace-semicolon-end of line sequence 5554 # from the eval text, if any. 5555 $e =~ s/\n\s*\;\s*\Z// if $e; 5556 5557 # Escape backslashed single-quotes again if necessary. 5558 $e =~ s/([\\\'])/\\$1/g if $e; 5559 5560 # if the require flag is true, the eval text is from a require. 5561 if ($r) { 5562 $sub = "require '$e'"; 5563 } 5564 # if it's false, the eval text is really from an eval. 5565 elsif (defined $r) { 5566 $sub = "eval '$e'"; 5567 } 5568 5569 # If the sub is '(eval)', this is a block eval, meaning we don't 5570 # know what the eval'ed text actually was. 5571 elsif ($sub eq '(eval)') { 5572 $sub = "eval {...}"; 5573 } 5574 5575 # Stick the collected information into @sub as an anonymous hash. 5576 push ( 5577 @sub, 5578 { 5579 context => $context, 5580 sub => $sub, 5581 args => $args, 5582 file => $file, 5583 line => $line 5584 } 5585 ); 5586 5587 # Stop processing frames if the user hit control-C. 5588 last if $signal; 5589 } ## end for ($i = $skip ; $i < ... 5590 5591 # Restore the trace value again. 5592 $trace = $otrace; 5593 @sub; 5594} ## end sub dump_trace 5595 5596=head2 C<action()> 5597 5598C<action()> takes input provided as the argument to an add-action command, 5599either pre- or post-, and makes sure it's a complete command. It doesn't do 5600any fancy parsing; it just keeps reading input until it gets a string 5601without a trailing backslash. 5602 5603=cut 5604 5605sub action { 5606 my $action = shift; 5607 5608 while ($action =~ s/\\$//) { 5609 # We have a backslash on the end. Read more. 5610 $action .= &gets; 5611 } ## end while ($action =~ s/\\$//) 5612 5613 # Return the assembled action. 5614 $action; 5615} ## end sub action 5616 5617=head2 unbalanced 5618 5619This routine mostly just packages up a regular expression to be used 5620to check that the thing it's being matched against has properly-matched 5621curly braces. 5622 5623Of note is the definition of the $balanced_brace_re global via ||=, which 5624speeds things up by only creating the qr//'ed expression once; if it's 5625already defined, we don't try to define it again. A speed hack. 5626 5627=cut 5628 5629sub unbalanced { 5630 5631 # I hate using globals! 5632 $balanced_brace_re ||= qr{ 5633 ^ \{ 5634 (?: 5635 (?> [^{}] + ) # Non-parens without backtracking 5636 | 5637 (??{ $balanced_brace_re }) # Group with matching parens 5638 ) * 5639 \} $ 5640 }x; 5641 return $_[0] !~ m/$balanced_brace_re/; 5642} ## end sub unbalanced 5643 5644=head2 C<gets()> 5645 5646C<gets()> is a primitive (very primitive) routine to read continuations. 5647It was devised for reading continuations for actions. 5648it just reads more input with X<C<readline()>> and returns it. 5649 5650=cut 5651 5652sub gets { 5653 &readline("cont: "); 5654} 5655 5656=head2 C<DB::system()> - handle calls to<system()> without messing up the debugger 5657 5658The C<system()> function assumes that it can just go ahead and use STDIN and 5659STDOUT, but under the debugger, we want it to use the debugger's input and 5660outout filehandles. 5661 5662C<DB::system()> socks away the program's STDIN and STDOUT, and then substitutes 5663the debugger's IN and OUT filehandles for them. It does the C<system()> call, 5664and then puts everything back again. 5665 5666=cut 5667 5668sub system { 5669 5670 # We save, change, then restore STDIN and STDOUT to avoid fork() since 5671 # some non-Unix systems can do system() but have problems with fork(). 5672 open(SAVEIN, "<&STDIN") || &warn("Can't save STDIN"); 5673 open(SAVEOUT, ">&STDOUT") || &warn("Can't save STDOUT"); 5674 open(STDIN, "<&IN") || &warn("Can't redirect STDIN"); 5675 open(STDOUT, ">&OUT") || &warn("Can't redirect STDOUT"); 5676 5677 # XXX: using csh or tcsh destroys sigint retvals! 5678 system(@_); 5679 open(STDIN, "<&SAVEIN") || &warn("Can't restore STDIN"); 5680 open(STDOUT, ">&SAVEOUT") || &warn("Can't restore STDOUT"); 5681 close(SAVEIN); 5682 close(SAVEOUT); 5683 5684 # most of the $? crud was coping with broken cshisms 5685 if ($? >> 8) { 5686 &warn("(Command exited ", ($? >> 8), ")\n"); 5687 } 5688 elsif ($?) { 5689 &warn( 5690 "(Command died of SIG#", 5691 ($? & 127), 5692 (($? & 128) ? " -- core dumped" : ""), 5693 ")", "\n" 5694 ); 5695 } ## end elsif ($?) 5696 5697 return $?; 5698 5699} ## end sub system 5700 5701=head1 TTY MANAGEMENT 5702 5703The subs here do some of the terminal management for multiple debuggers. 5704 5705=head2 setterm 5706 5707Top-level function called when we want to set up a new terminal for use 5708by the debugger. 5709 5710If the C<noTTY> debugger option was set, we'll either use the terminal 5711supplied (the value of the C<noTTY> option), or we'll use C<Term::Rendezvous> 5712to find one. If we're a forked debugger, we call C<resetterm> to try to 5713get a whole new terminal if we can. 5714 5715In either case, we set up the terminal next. If the C<ReadLine> option was 5716true, we'll get a C<Term::ReadLine> object for the current terminal and save 5717the appropriate attributes. We then 5718 5719=cut 5720 5721sub setterm { 5722 # Load Term::Readline, but quietly; don't debug it and don't trace it. 5723 local $frame = 0; 5724 local $doret = -2; 5725 eval { require Term::ReadLine } or die $@; 5726 5727 # If noTTY is set, but we have a TTY name, go ahead and hook up to it. 5728 if ($notty) { 5729 if ($tty) { 5730 my ($i, $o) = split $tty, /,/; 5731 $o = $i unless defined $o; 5732 open(IN, "<$i") or die "Cannot open TTY `$i' for read: $!"; 5733 open(OUT, ">$o") or die "Cannot open TTY `$o' for write: $!"; 5734 $IN = \*IN; 5735 $OUT = \*OUT; 5736 my $sel = select($OUT); 5737 $| = 1; 5738 select($sel); 5739 } ## end if ($tty) 5740 5741 # We don't have a TTY - try to find one via Term::Rendezvous. 5742 else { 5743 eval "require Term::Rendezvous;" or die; 5744 # See if we have anything to pass to Term::Rendezvous. 5745 # Use /tmp/perldbtty$$ if not. 5746 my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$"; 5747 5748 # Rendezvous and get the filehandles. 5749 my $term_rv = new Term::Rendezvous $rv; 5750 $IN = $term_rv->IN; 5751 $OUT = $term_rv->OUT; 5752 } ## end else [ if ($tty) 5753 } ## end if ($notty) 5754 5755 5756 # We're a daughter debugger. Try to fork off another TTY. 5757 if ($term_pid eq '-1') { # In a TTY with another debugger 5758 resetterm(2); 5759 } 5760 5761 # If we shouldn't use Term::ReadLine, don't. 5762 if (!$rl) { 5763 $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT; 5764 } 5765 5766 # We're using Term::ReadLine. Get all the attributes for this terminal. 5767 else { 5768 $term = new Term::ReadLine 'perldb', $IN, $OUT; 5769 5770 $rl_attribs = $term->Attribs; 5771 $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}' 5772 if defined $rl_attribs->{basic_word_break_characters} 5773 and index($rl_attribs->{basic_word_break_characters}, ":") == -1; 5774 $rl_attribs->{special_prefixes} = '$@&%'; 5775 $rl_attribs->{completer_word_break_characters} .= '$@&%'; 5776 $rl_attribs->{completion_function} = \&db_complete; 5777 } ## end else [ if (!$rl) 5778 5779 # Set up the LINEINFO filehandle. 5780 $LINEINFO = $OUT unless defined $LINEINFO; 5781 $lineinfo = $console unless defined $lineinfo; 5782 5783 $term->MinLine(2); 5784 5785 if ($term->Features->{setHistory} and "@hist" ne "?") { 5786 $term->SetHistory(@hist); 5787 } 5788 5789 # XXX Ornaments are turned on unconditionally, which is not 5790 # always a good thing. 5791 ornaments($ornaments) if defined $ornaments; 5792 $term_pid = $$; 5793} ## end sub setterm 5794 5795=head1 GET_FORK_TTY EXAMPLE FUNCTIONS 5796 5797When the process being debugged forks, or the process invokes a command 5798via C<system()> which starts a new debugger, we need to be able to get a new 5799C<IN> and C<OUT> filehandle for the new debugger. Otherwise, the two processes 5800fight over the terminal, and you can never quite be sure who's going to get the 5801input you're typing. 5802 5803C<get_fork_TTY> is a glob-aliased function which calls the real function that 5804is tasked with doing all the necessary operating system mojo to get a new 5805TTY (and probably another window) and to direct the new debugger to read and 5806write there. 5807 5808The debugger provides C<get_fork_TTY> functions which work for X Windows and 5809OS/2. Other systems are not supported. You are encouraged to write 5810C<get_fork_TTY> functions which work for I<your> platform and contribute them. 5811 5812=head3 C<xterm_get_fork_TTY> 5813 5814This function provides the C<get_fork_TTY> function for X windows. If a 5815program running under the debugger forks, a new <xterm> window is opened and 5816the subsidiary debugger is directed there. 5817 5818The C<open()> call is of particular note here. We have the new C<xterm> 5819we're spawning route file number 3 to STDOUT, and then execute the C<tty> 5820command (which prints the device name of the TTY we'll want to use for input 5821and output to STDOUT, then C<sleep> for a very long time, routing this output 5822to file number 3. This way we can simply read from the <XT> filehandle (which 5823is STDOUT from the I<commands> we ran) to get the TTY we want to use. 5824 5825Only works if C<xterm> is in your path and C<$ENV{DISPLAY}>, etc. are 5826properly set up. 5827 5828=cut 5829 5830sub xterm_get_fork_TTY { 5831 (my $name = $0) =~ s,^.*[/\\],,s; 5832 open XT, 5833qq[3>&1 xterm -title "Daughter Perl debugger $pids $name" -e sh -c 'tty 1>&3;\ 5834 sleep 10000000' |]; 5835 5836 # Get the output from 'tty' and clean it up a little. 5837 my $tty = <XT>; 5838 chomp $tty; 5839 5840 $pidprompt = ''; # Shown anyway in titlebar 5841 5842 # There's our new TTY. 5843 return $tty; 5844} ## end sub xterm_get_fork_TTY 5845 5846=head3 C<os2_get_fork_TTY> 5847 5848XXX It behooves an OS/2 expert to write the necessary documentation for this! 5849 5850=cut 5851 5852# This example function resets $IN, $OUT itself 5853sub os2_get_fork_TTY { 5854 local $^F = 40; # XXXX Fixme! 5855 local $\ = ''; 5856 my ($in1, $out1, $in2, $out2); 5857 5858 # Having -d in PERL5OPT would lead to a disaster... 5859 local $ENV{PERL5OPT} = $ENV{PERL5OPT} if $ENV{PERL5OPT}; 5860 $ENV{PERL5OPT} =~ s/(?:^|(?<=\s))-d\b// if $ENV{PERL5OPT}; 5861 $ENV{PERL5OPT} =~ s/(?:^|(?<=\s))-d\B/-/ if $ENV{PERL5OPT}; 5862 print $OUT "Making kid PERL5OPT->`$ENV{PERL5OPT}'.\n" if $ENV{PERL5OPT}; 5863 local $ENV{PERL5LIB} = $ENV{PERL5LIB} ? $ENV{PERL5LIB} : $ENV{PERLLIB}; 5864 $ENV{PERL5LIB} = '' unless defined $ENV{PERL5LIB}; 5865 $ENV{PERL5LIB} = join ';', @ini_INC, split /;/, $ENV{PERL5LIB}; 5866 (my $name = $0) =~ s,^.*[/\\],,s; 5867 my @args; 5868 5869 if ( 5870 pipe $in1, $out1 5871 and pipe $in2, $out2 5872 5873 # system P_SESSION will fail if there is another process 5874 # in the same session with a "dependent" asynchronous child session. 5875 and @args = ( 5876 $rl, fileno $in1, fileno $out2, 5877 "Daughter Perl debugger $pids $name" 5878 ) 5879 and ( 5880 ($kpid = CORE::system 4, $^X, '-we', 5881 <<'ES', @args) >= 0 # P_SESSION 5882END {sleep 5 unless $loaded} 5883BEGIN {open STDIN, '</dev/con' or warn "reopen stdin: $!"} 5884use OS2::Process; 5885 5886my ($rl, $in) = (shift, shift); # Read from $in and pass through 5887set_title pop; 5888system P_NOWAIT, $^X, '-we', <<EOS or die "Cannot start a grandkid"; 5889 open IN, '<&=$in' or die "open <&=$in: \$!"; 5890 \$| = 1; print while sysread IN, \$_, 1<<16; 5891EOS 5892 5893my $out = shift; 5894open OUT, ">&=$out" or die "Cannot open &=$out for writing: $!"; 5895select OUT; $| = 1; 5896require Term::ReadKey if $rl; 5897Term::ReadKey::ReadMode(4) if $rl; # Nodelay on kbd. Pipe is automatically nodelay... 5898print while sysread STDIN, $_, 1<<($rl ? 16 : 0); 5899ES 5900 or warn "system P_SESSION: $!, $^E" and 0 5901 ) 5902 and close $in1 5903 and close $out2 5904 ) 5905 { 5906 $pidprompt = ''; # Shown anyway in titlebar 5907 reset_IN_OUT($in2, $out1); 5908 $tty = '*reset*'; 5909 return ''; # Indicate that reset_IN_OUT is called 5910 } ## end if (pipe $in1, $out1 and... 5911 return; 5912} ## end sub os2_get_fork_TTY 5913 5914=head2 C<create_IN_OUT($flags)> 5915 5916Create a new pair of filehandles, pointing to a new TTY. If impossible, 5917try to diagnose why. 5918 5919Flags are: 5920 5921=over 4 5922 5923=item * 1 - Don't know how to create a new TTY. 5924 5925=item * 2 - Debugger has forked, but we can't get a new TTY. 5926 5927=item * 4 - standard debugger startup is happening. 5928 5929=back 5930 5931=cut 5932 5933sub create_IN_OUT { # Create a window with IN/OUT handles redirected there 5934 5935 # If we know how to get a new TTY, do it! $in will have 5936 # the TTY name if get_fork_TTY works. 5937 my $in = &get_fork_TTY if defined &get_fork_TTY; 5938 5939 # It used to be that 5940 $in = $fork_TTY if defined $fork_TTY; # Backward compatibility 5941 5942 if (not defined $in) { 5943 my $why = shift; 5944 5945 # We don't know how. 5946 print_help(<<EOP) if $why == 1; 5947I<#########> Forked, but do not know how to create a new B<TTY>. I<#########> 5948EOP 5949 5950 # Forked debugger. 5951 print_help(<<EOP) if $why == 2; 5952I<#########> Daughter session, do not know how to change a B<TTY>. I<#########> 5953 This may be an asynchronous session, so the parent debugger may be active. 5954EOP 5955 5956 # Note that both debuggers are fighting over the same input. 5957 print_help(<<EOP) if $why != 4; 5958 Since two debuggers fight for the same TTY, input is severely entangled. 5959 5960EOP 5961 print_help(<<EOP); 5962 I know how to switch the output to a different window in xterms 5963 and OS/2 consoles only. For a manual switch, put the name of the created I<TTY> 5964 in B<\$DB::fork_TTY>, or define a function B<DB::get_fork_TTY()> returning this. 5965 5966 On I<UNIX>-like systems one can get the name of a I<TTY> for the given window 5967 by typing B<tty>, and disconnect the I<shell> from I<TTY> by B<sleep 1000000>. 5968 5969EOP 5970 } ## end if (not defined $in) 5971 elsif ($in ne '') { 5972 TTY($in); 5973 } 5974 else { 5975 $console = ''; # Indicate no need to open-from-the-console 5976 } 5977 undef $fork_TTY; 5978} ## end sub create_IN_OUT 5979 5980=head2 C<resetterm> 5981 5982Handles rejiggering the prompt when we've forked off a new debugger. 5983 5984If the new debugger happened because of a C<system()> that invoked a 5985program under the debugger, the arrow between the old pid and the new 5986in the prompt has I<two> dashes instead of one. 5987 5988We take the current list of pids and add this one to the end. If there 5989isn't any list yet, we make one up out of the initial pid associated with 5990the terminal and our new pid, sticking an arrow (either one-dashed or 5991two dashed) in between them. 5992 5993If C<CreateTTY> is off, or C<resetterm> was called with no arguments, 5994we don't try to create a new IN and OUT filehandle. Otherwise, we go ahead 5995and try to do that. 5996 5997=cut 5998 5999sub resetterm { # We forked, so we need a different TTY 6000 6001 # Needs to be passed to create_IN_OUT() as well. 6002 my $in = shift; 6003 6004 # resetterm(2): got in here because of a system() starting a debugger. 6005 # resetterm(1): just forked. 6006 my $systemed = $in > 1 ? '-' : ''; 6007 6008 # If there's already a list of pids, add this to the end. 6009 if ($pids) { 6010 $pids =~ s/\]/$systemed->$$]/; 6011 } 6012 6013 # No pid list. Time to make one. 6014 else { 6015 $pids = "[$term_pid->$$]"; 6016 } 6017 6018 # The prompt we're going to be using for this debugger. 6019 $pidprompt = $pids; 6020 6021 # We now 0wnz this terminal. 6022 $term_pid = $$; 6023 6024 # Just return if we're not supposed to try to create a new TTY. 6025 return unless $CreateTTY & $in; 6026 6027 # Try to create a new IN/OUT pair. 6028 create_IN_OUT($in); 6029} ## end sub resetterm 6030 6031=head2 C<readline> 6032 6033First, we handle stuff in the typeahead buffer. If there is any, we shift off 6034the next line, print a message saying we got it, add it to the terminal 6035history (if possible), and return it. 6036 6037If there's nothing in the typeahead buffer, check the command filehandle stack. 6038If there are any filehandles there, read from the last one, and return the line 6039if we got one. If not, we pop the filehandle off and close it, and try the 6040next one up the stack. 6041 6042If we've emptied the filehandle stack, we check to see if we've got a socket 6043open, and we read that and return it if we do. If we don't, we just call the 6044core C<readline()> and return its value. 6045 6046=cut 6047 6048sub readline { 6049 6050 # Localize to prevent it from being smashed in the program being debugged. 6051 local $.; 6052 6053 # Pull a line out of the typeahead if there's stuff there. 6054 if (@typeahead) { 6055 # How many lines left. 6056 my $left = @typeahead; 6057 6058 # Get the next line. 6059 my $got = shift @typeahead; 6060 6061 # Print a message saying we got input from the typeahead. 6062 local $\ = ''; 6063 print $OUT "auto(-$left)", shift, $got, "\n"; 6064 6065 # Add it to the terminal history (if possible). 6066 $term->AddHistory($got) 6067 if length($got) > 1 6068 and defined $term->Features->{addHistory}; 6069 return $got; 6070 } ## end if (@typeahead) 6071 6072 # We really need to read some input. Turn off entry/exit trace and 6073 # return value printing. 6074 local $frame = 0; 6075 local $doret = -2; 6076 6077 # If there are stacked filehandles to read from ... 6078 while (@cmdfhs) { 6079 # Read from the last one in the stack. 6080 my $line = CORE::readline($cmdfhs[-1]); 6081 # If we got a line ... 6082 defined $line 6083 ? (print $OUT ">> $line" and return $line) # Echo and return 6084 : close pop @cmdfhs; # Pop and close 6085 } ## end while (@cmdfhs) 6086 6087 # Nothing on the filehandle stack. Socket? 6088 if (ref $OUT and UNIVERSAL::isa($OUT, 'IO::Socket::INET')) { 6089 # Send anyting we have to send. 6090 $OUT->write(join ('', @_)); 6091 6092 # Receive anything there is to receive. 6093 my $stuff; 6094 $IN->recv($stuff, 2048); # XXX "what's wrong with sysread?" 6095 # XXX Don't know. You tell me. 6096 6097 # What we got. 6098 $stuff; 6099 } ## end if (ref $OUT and UNIVERSAL::isa... 6100 6101 # No socket. Just read from the terminal. 6102 else { 6103 $term->readline(@_); 6104 } 6105} ## end sub readline 6106 6107=head1 OPTIONS SUPPORT ROUTINES 6108 6109These routines handle listing and setting option values. 6110 6111=head2 C<dump_option> - list the current value of an option setting 6112 6113This routine uses C<option_val> to look up the value for an option. 6114It cleans up escaped single-quotes and then displays the option and 6115its value. 6116 6117=cut 6118 6119sub dump_option { 6120 my ($opt, $val) = @_; 6121 $val = option_val($opt, 'N/A'); 6122 $val =~ s/([\\\'])/\\$1/g; 6123 printf $OUT "%20s = '%s'\n", $opt, $val; 6124} ## end sub dump_option 6125 6126=head2 C<option_val> - find the current value of an option 6127 6128This can't just be a simple hash lookup because of the indirect way that 6129the option values are stored. Some are retrieved by calling a subroutine, 6130some are just variables. 6131 6132You must supply a default value to be used in case the option isn't set. 6133 6134=cut 6135 6136sub option_val { 6137 my ($opt, $default) = @_; 6138 my $val; 6139 6140 # Does this option exist, and is it a variable? 6141 # If so, retrieve the value via the value in %optionVars. 6142 if ( defined $optionVars{$opt} 6143 and defined ${ $optionVars{$opt} }) { 6144 $val = ${ $optionVars{$opt} }; 6145 } 6146 6147 # Does this option exist, and it's a subroutine? 6148 # If so, call the subroutine via the ref in %optionAction 6149 # and capture the value. 6150 elsif ( defined $optionAction{$opt} 6151 and defined &{ $optionAction{$opt} }) { 6152 $val = &{ $optionAction{$opt} }(); 6153 } 6154 6155 # If there's an action or variable for the supplied option, 6156 # but no value was set, use the default. 6157 elsif (defined $optionAction{$opt} and not defined $option{$opt} 6158 or defined $optionVars{$opt} and not defined ${ $optionVars{$opt} }) 6159 { 6160 $val = $default; 6161 } 6162 6163 # Otherwise, do the simple hash lookup. 6164 else { 6165 $val = $option{$opt}; 6166 } 6167 6168 # If the value isn't defined, use the default. 6169 # Then return whatever the value is. 6170 $val = $default unless defined $val; 6171 $val; 6172} ## end sub option_val 6173 6174=head2 C<parse_options> 6175 6176Handles the parsing and execution of option setting/displaying commands. 6177 6178An option entered by itself is assumed to be 'set me to 1' (the default value) 6179if the option is a boolean one. If not, the user is prompted to enter a valid 6180value or to query the current value (via 'option? '). 6181 6182If 'option=value' is entered, we try to extract a quoted string from the 6183value (if it is quoted). If it's not, we just use the whole value as-is. 6184 6185We load any modules required to service this option, and then we set it: if 6186it just gets stuck in a variable, we do that; if there's a subroutine to 6187handle setting the option, we call that. 6188 6189Finally, if we're running in interactive mode, we display the effect of the 6190user's command back to the terminal, skipping this if we're setting things 6191during initialization. 6192 6193=cut 6194 6195sub parse_options { 6196 local ($_) = @_; 6197 local $\ = ''; 6198 6199 # These options need a value. Don't allow them to be clobbered by accident. 6200 my %opt_needs_val = map { ($_ => 1) } qw{ 6201 dumpDepth arrayDepth hashDepth LineInfo maxTraceLen ornaments windowSize 6202 pager quote ReadLine recallCommand RemotePort ShellBang TTY CommandSet 6203 }; 6204 6205 while (length) { 6206 my $val_defaulted; 6207 6208 # Clean off excess leading whitespace. 6209 s/^\s+// && next; 6210 6211 # Options are always all word characters, followed by a non-word 6212 # separator. 6213 s/^(\w+)(\W?)// or print($OUT "Invalid option `$_'\n"), last; 6214 my ($opt, $sep) = ($1, $2); 6215 6216 # Make sure that such an option exists. 6217 my $matches = grep(/^\Q$opt/ && ($option = $_), @options) || 6218 grep(/^\Q$opt/i && ($option = $_), @options); 6219 6220 print($OUT "Unknown option `$opt'\n"), next unless $matches; 6221 print($OUT "Ambiguous option `$opt'\n"), next if $matches > 1; 6222 6223 my $val; 6224 6225 # '?' as separator means query, but must have whitespace after it. 6226 if ("?" eq $sep) { 6227 print($OUT "Option query `$opt?' followed by non-space `$_'\n"), 6228 last 6229 if /^\S/; 6230 6231 #&dump_option($opt); 6232 } ## end if ("?" eq $sep) 6233 6234 # Separator is whitespace (or just a carriage return). 6235 # They're going for a default, which we assume is 1. 6236 elsif ($sep !~ /\S/) { 6237 $val_defaulted = 1; 6238 $val = "1"; # this is an evil default; make 'em set it! 6239 } 6240 6241 # Separator is =. Trying to set a value. 6242 elsif ($sep eq "=") { 6243 # If quoted, extract a quoted string. 6244 if (s/ (["']) ( (?: \\. | (?! \1 ) [^\\] )* ) \1 //x) { 6245 my $quote = $1; 6246 ($val = $2) =~ s/\\([$quote\\])/$1/g; 6247 } 6248 6249 # Not quoted. Use the whole thing. Warn about 'option='. 6250 else { 6251 s/^(\S*)//; 6252 $val = $1; 6253 print OUT qq(Option better cleared using $opt=""\n) 6254 unless length $val; 6255 } ## end else [ if (s/ (["']) ( (?: \\. | (?! \1 ) [^\\] )* ) \1 //x) 6256 6257 } ## end elsif ($sep eq "=") 6258 6259 # "Quoted" with [], <>, or {}. 6260 else { #{ to "let some poor schmuck bounce on the % key in B<vi>." 6261 my ($end) = "\\" . substr(")]>}$sep", index("([<{", $sep), 1); #} 6262 s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// 6263 or print($OUT "Unclosed option value `$opt$sep$_'\n"), last; 6264 ($val = $1) =~ s/\\([\\$end])/$1/g; 6265 } ## end else [ if ("?" eq $sep) 6266 6267 # Exclude non-booleans from getting set to 1 by default. 6268 if ($opt_needs_val{$option} && $val_defaulted) { 6269 my $cmd = ($CommandSet eq '580') ? 'o' : 'O'; 6270 print $OUT 6271"Option `$opt' is non-boolean. Use `$cmd $option=VAL' to set, `$cmd $option?' to query\n"; 6272 next; 6273 } ## end if ($opt_needs_val{$option... 6274 6275 # Save the option value. 6276 $option{$option} = $val if defined $val; 6277 6278 # Load any module that this option requires. 6279 eval qq{ 6280 local \$frame = 0; 6281 local \$doret = -2; 6282 require '$optionRequire{$option}'; 6283 1; 6284 } || die # XXX: shouldn't happen 6285 if defined $optionRequire{$option} && 6286 defined $val; 6287 6288 # Set it. 6289 # Stick it in the proper variable if it goes in a variable. 6290 ${ $optionVars{$option} } = $val 6291 if defined $optionVars{$option} && 6292 defined $val; 6293 6294 # Call the appropriate sub if it gets set via sub. 6295 &{ $optionAction{$option} }($val) 6296 if defined $optionAction{$option} && 6297 defined &{ $optionAction{$option} } && 6298 defined $val; 6299 6300 # Not initialization - echo the value we set it to. 6301 dump_option($option) unless $OUT eq \*STDERR; 6302 } ## end while (length) 6303} ## end sub parse_options 6304 6305=head1 RESTART SUPPORT 6306 6307These routines are used to store (and restore) lists of items in environment 6308variables during a restart. 6309 6310=head2 set_list 6311 6312Set_list packages up items to be stored in a set of environment variables 6313(VAR_n, containing the number of items, and VAR_0, VAR_1, etc., containing 6314the values). Values outside the standard ASCII charset are stored by encoding 6315then as hexadecimal values. 6316 6317=cut 6318 6319sub set_list { 6320 my ($stem, @list) = @_; 6321 my $val; 6322 6323 # VAR_n: how many we have. Scalar assignment gets the number of items. 6324 $ENV{"${stem}_n"} = @list; 6325 6326 # Grab each item in the list, escape the backslashes, encode the non-ASCII 6327 # as hex, and then save in the appropriate VAR_0, VAR_1, etc. 6328 for $i (0 .. $#list) { 6329 $val = $list[$i]; 6330 $val =~ s/\\/\\\\/g; 6331 $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg; 6332 $ENV{"${stem}_$i"} = $val; 6333 } ## end for $i (0 .. $#list) 6334} ## end sub set_list 6335 6336=head2 get_list 6337 6338Reverse the set_list operation: grab VAR_n to see how many we should be getting 6339back, and then pull VAR_0, VAR_1. etc. back out. 6340 6341=cut 6342 6343sub get_list { 6344 my $stem = shift; 6345 my @list; 6346 my $n = delete $ENV{"${stem}_n"}; 6347 my $val; 6348 for $i (0 .. $n - 1) { 6349 $val = delete $ENV{"${stem}_$i"}; 6350 $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge; 6351 push @list, $val; 6352 } 6353 @list; 6354} ## end sub get_list 6355 6356=head1 MISCELLANEOUS SIGNAL AND I/O MANAGEMENT 6357 6358=head2 catch() 6359 6360The C<catch()> subroutine is the essence of fast and low-impact. We simply 6361set an already-existing global scalar variable to a constant value. This 6362avoids allocating any memory possibly in the middle of something that will 6363get all confused if we do. 6364 6365=cut 6366 6367sub catch { 6368 $signal = 1; 6369 return; # Put nothing on the stack - malloc/free land! 6370} 6371 6372=head2 C<warn()> 6373 6374C<warn> emits a warning, by joining together its arguments and printing 6375them, with couple of fillips. 6376 6377If the composited message I<doesn't> end with a newline, we automatically 6378add C<$!> and a newline to the end of the message. The subroutine expects $OUT 6379to be set to the filehandle to be used to output warnings; it makes no 6380assumptions about what filehandles are available. 6381 6382=cut 6383 6384sub warn { 6385 my ($msg) = join ("", @_); 6386 $msg .= ": $!\n" unless $msg =~ /\n$/; 6387 local $\ = ''; 6388 print $OUT $msg; 6389} ## end sub warn 6390 6391=head1 INITIALIZATION TTY SUPPORT 6392 6393=head2 C<reset_IN_OUT> 6394 6395This routine handles restoring the debugger's input and output filehandles 6396after we've tried and failed to move them elsewhere. In addition, it assigns 6397the debugger's output filehandle to $LINEINFO if it was already open there. 6398 6399=cut 6400 6401sub reset_IN_OUT { 6402 my $switch_li = $LINEINFO eq $OUT; 6403 6404 # If there's a term and it's able to get a new tty, try to get one. 6405 if ($term and $term->Features->{newTTY}) { 6406 ($IN, $OUT) = (shift, shift); 6407 $term->newTTY($IN, $OUT); 6408 } 6409 6410 # This term can't get a new tty now. Better luck later. 6411 elsif ($term) { 6412 &warn("Too late to set IN/OUT filehandles, enabled on next `R'!\n"); 6413 } 6414 6415 # Set the filehndles up as they were. 6416 else { 6417 ($IN, $OUT) = (shift, shift); 6418 } 6419 6420 # Unbuffer the output filehandle. 6421 my $o = select $OUT; 6422 $| = 1; 6423 select $o; 6424 6425 # Point LINEINFO to the same output filehandle if it was there before. 6426 $LINEINFO = $OUT if $switch_li; 6427} ## end sub reset_IN_OUT 6428 6429=head1 OPTION SUPPORT ROUTINES 6430 6431The following routines are used to process some of the more complicated 6432debugger options. 6433 6434=head2 C<TTY> 6435 6436Sets the input and output filehandles to the specified files or pipes. 6437If the terminal supports switching, we go ahead and do it. If not, and 6438there's already a terminal in place, we save the information to take effect 6439on restart. 6440 6441If there's no terminal yet (for instance, during debugger initialization), 6442we go ahead and set C<$console> and C<$tty> to the file indicated. 6443 6444=cut 6445 6446sub TTY { 6447 if (@_ and $term and $term->Features->{newTTY}) { 6448 # This terminal supports switching to a new TTY. 6449 # Can be a list of two files, or on string containing both names, 6450 # comma-separated. 6451 # XXX Should this perhaps be an assignment from @_? 6452 my ($in, $out) = shift; 6453 if ($in =~ /,/) { 6454 # Split list apart if supplied. 6455 ($in, $out) = split /,/, $in, 2; 6456 } 6457 else { 6458 # Use the same file for both input and output. 6459 $out = $in; 6460 } 6461 6462 # Open file onto the debugger's filehandles, if you can. 6463 open IN, $in or die "cannot open `$in' for read: $!"; 6464 open OUT, ">$out" or die "cannot open `$out' for write: $!"; 6465 6466 # Swap to the new filehandles. 6467 reset_IN_OUT(\*IN, \*OUT); 6468 6469 # Save the setting for later. 6470 return $tty = $in; 6471 } ## end if (@_ and $term and $term... 6472 6473 # Terminal doesn't support new TTY, or doesn't support readline. 6474 # Can't do it now, try restarting. 6475 &warn("Too late to set TTY, enabled on next `R'!\n") if $term and @_; 6476 6477 # Useful if done through PERLDB_OPTS: 6478 $console = $tty = shift if @_; 6479 6480 # Return whatever the TTY is. 6481 $tty or $console; 6482} ## end sub TTY 6483 6484=head2 C<noTTY> 6485 6486Sets the C<$notty> global, controlling whether or not the debugger tries to 6487get a terminal to read from. If called after a terminal is already in place, 6488we save the value to use it if we're restarted. 6489 6490=cut 6491 6492sub noTTY { 6493 if ($term) { 6494 &warn("Too late to set noTTY, enabled on next `R'!\n") if @_; 6495 } 6496 $notty = shift if @_; 6497 $notty; 6498} ## end sub noTTY 6499 6500=head2 C<ReadLine> 6501 6502Sets the C<$rl> option variable. If 0, we use C<Term::ReadLine::Stub> 6503(essentially, no C<readline> processing on this "terminal"). Otherwise, we 6504use C<Term::ReadLine>. Can't be changed after a terminal's in place; we save 6505the value in case a restart is done so we can change it then. 6506 6507=cut 6508 6509sub ReadLine { 6510 if ($term) { 6511 &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_; 6512 } 6513 $rl = shift if @_; 6514 $rl; 6515} ## end sub ReadLine 6516 6517=head2 C<RemotePort> 6518 6519Sets the port that the debugger will try to connect to when starting up. 6520If the terminal's already been set up, we can't do it, but we remember the 6521setting in case the user does a restart. 6522 6523=cut 6524 6525sub RemotePort { 6526 if ($term) { 6527 &warn("Too late to set RemotePort, enabled on next 'R'!\n") if @_; 6528 } 6529 $remoteport = shift if @_; 6530 $remoteport; 6531} ## end sub RemotePort 6532 6533=head2 C<tkRunning> 6534 6535Checks with the terminal to see if C<Tk> is running, and returns true or 6536false. Returns false if the current terminal doesn't support C<readline>. 6537 6538=cut 6539 6540sub tkRunning { 6541 if (${ $term->Features }{tkRunning}) { 6542 return $term->tkRunning(@_); 6543 } 6544 else { 6545 local $\ = ''; 6546 print $OUT "tkRunning not supported by current ReadLine package.\n"; 6547 0; 6548 } 6549} ## end sub tkRunning 6550 6551=head2 C<NonStop> 6552 6553Sets nonstop mode. If a terminal's already been set up, it's too late; the 6554debugger remembers the setting in case you restart, though. 6555 6556=cut 6557 6558sub NonStop { 6559 if ($term) { 6560 &warn("Too late to set up NonStop mode, enabled on next `R'!\n") 6561 if @_; 6562 } 6563 $runnonstop = shift if @_; 6564 $runnonstop; 6565} ## end sub NonStop 6566 6567=head2 C<pager> 6568 6569Set up the C<$pager> variable. Adds a pipe to the front unless there's one 6570there already. 6571 6572=cut 6573 6574sub pager { 6575 if (@_) { 6576 $pager = shift; 6577 $pager = "|" . $pager unless $pager =~ /^(\+?\>|\|)/; 6578 } 6579 $pager; 6580} ## end sub pager 6581 6582=head2 C<shellBang> 6583 6584Sets the shell escape command, and generates a printable copy to be used 6585in the help. 6586 6587=cut 6588 6589sub shellBang { 6590 6591 # If we got an argument, meta-quote it, and add '\b' if it 6592 # ends in a word character. 6593 if (@_) { 6594 $sh = quotemeta shift; 6595 $sh .= "\\b" if $sh =~ /\w$/; 6596 } 6597 6598 # Generate the printable version for the help: 6599 $psh = $sh; # copy it 6600 $psh =~ s/\\b$//; # Take off trailing \b if any 6601 $psh =~ s/\\(.)/$1/g; # De-escape 6602 $psh; # return the printable version 6603} ## end sub shellBang 6604 6605=head2 C<ornaments> 6606 6607If the terminal has its own ornaments, fetch them. Otherwise accept whatever 6608was passed as the argument. (This means you can't override the terminal's 6609ornaments.) 6610 6611=cut 6612 6613sub ornaments { 6614 if (defined $term) { 6615 # We don't want to show warning backtraces, but we do want die() ones. 6616 local ($warnLevel, $dieLevel) = (0, 1); 6617 6618 # No ornaments if the terminal doesn't support them. 6619 return '' unless $term->Features->{ornaments}; 6620 eval { $term->ornaments(@_) } || ''; 6621 } 6622 6623 # Use what was passed in if we can't determine it ourselves. 6624 else { 6625 $ornaments = shift; 6626 } 6627} ## end sub ornaments 6628 6629=head2 C<recallCommand> 6630 6631Sets the recall command, and builds a printable version which will appear in 6632the help text. 6633 6634=cut 6635 6636sub recallCommand { 6637 6638 # If there is input, metaquote it. Add '\b' if it ends with a word 6639 # character. 6640 if (@_) { 6641 $rc = quotemeta shift; 6642 $rc .= "\\b" if $rc =~ /\w$/; 6643 } 6644 6645 # Build it into a printable version. 6646 $prc = $rc; # Copy it 6647 $prc =~ s/\\b$//; # Remove trailing \b 6648 $prc =~ s/\\(.)/$1/g; # Remove escapes 6649 $prc; # Return the printable version 6650} ## end sub recallCommand 6651 6652=head2 C<LineInfo> - where the line number information goes 6653 6654Called with no arguments, returns the file or pipe that line info should go to. 6655 6656Called with an argument (a file or a pipe), it opens that onto the 6657C<LINEINFO> filehandle, unbuffers the filehandle, and then returns the 6658file or pipe again to the caller. 6659 6660=cut 6661 6662sub LineInfo { 6663 return $lineinfo unless @_; 6664 $lineinfo = shift; 6665 6666 # If this is a valid "thing to be opened for output", tack a 6667 # '>' onto the front. 6668 my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo"; 6669 6670 # If this is a pipe, the stream points to a slave editor. 6671 $slave_editor = ($stream =~ /^\|/); 6672 6673 # Open it up and unbuffer it. 6674 open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write"); 6675 $LINEINFO = \*LINEINFO; 6676 my $save = select($LINEINFO); 6677 $| = 1; 6678 select($save); 6679 6680 # Hand the file or pipe back again. 6681 $lineinfo; 6682} ## end sub LineInfo 6683 6684=head1 COMMAND SUPPORT ROUTINES 6685 6686These subroutines provide functionality for various commands. 6687 6688=head2 C<list_modules> 6689 6690For the C<M> command: list modules loaded and their versions. 6691Essentially just runs through the keys in %INC, picks up the 6692$VERSION package globals from each package, gets the file name, and formats the 6693information for output. 6694 6695=cut 6696 6697sub list_modules { # versions 6698 my %version; 6699 my $file; 6700 # keys are the "as-loaded" name, values are the fully-qualified path 6701 # to the file itself. 6702 for (keys %INC) { 6703 $file = $_; # get the module name 6704 s,\.p[lm]$,,i; # remove '.pl' or '.pm' 6705 s,/,::,g; # change '/' to '::' 6706 s/^perl5db$/DB/; # Special case: debugger 6707 # moves to package DB 6708 s/^Term::ReadLine::readline$/readline/; # simplify readline 6709 6710 # If the package has a $VERSION package global (as all good packages 6711 # should!) decode it and save as partial message. 6712 if (defined ${ $_ . '::VERSION' }) { 6713 $version{$file} = "${ $_ . '::VERSION' } from "; 6714 } 6715 6716 # Finish up the message with the file the package came from. 6717 $version{$file} .= $INC{$file}; 6718 } ## end for (keys %INC) 6719 6720 # Hey, dumpit() formats a hash nicely, so why not use it? 6721 dumpit($OUT, \%version); 6722} ## end sub list_modules 6723 6724=head2 C<sethelp()> 6725 6726Sets up the monster string used to format and print the help. 6727 6728=head3 HELP MESSAGE FORMAT 6729 6730The help message is a peculiar format unto itself; it mixes C<pod> 'ornaments' 6731(BE<lt>E<gt>, IE<gt>E<lt>) with tabs to come up with a format that's fairly 6732easy to parse and portable, but which still allows the help to be a little 6733nicer than just plain text. 6734 6735Essentially, you define the command name (usually marked up with BE<gt>E<lt> 6736and IE<gt>E<lt>), followed by a tab, and then the descriptive text, ending in a newline. The descriptive text can also be marked up in the same way. If you 6737need to continue the descriptive text to another line, start that line with 6738just tabs and then enter the marked-up text. 6739 6740If you are modifying the help text, I<be careful>. The help-string parser is 6741not very sophisticated, and if you don't follow these rules it will mangle the 6742help beyond hope until you fix the string. 6743 6744=cut 6745 6746sub sethelp { 6747 6748 # XXX: make sure there are tabs between the command and explanation, 6749 # or print_help will screw up your formatting if you have 6750 # eeevil ornaments enabled. This is an insane mess. 6751 6752 $help = " 6753Help is currently only available for the new 5.8 command set. 6754No help is available for the old command set. 6755We assume you know what you're doing if you switch to it. 6756 6757B<T> Stack trace. 6758B<s> [I<expr>] Single step [in I<expr>]. 6759B<n> [I<expr>] Next, steps over subroutine calls [in I<expr>]. 6760<B<CR>> Repeat last B<n> or B<s> command. 6761B<r> Return from current subroutine. 6762B<c> [I<line>|I<sub>] Continue; optionally inserts a one-time-only breakpoint 6763 at the specified position. 6764B<l> I<min>B<+>I<incr> List I<incr>+1 lines starting at I<min>. 6765B<l> I<min>B<->I<max> List lines I<min> through I<max>. 6766B<l> I<line> List single I<line>. 6767B<l> I<subname> List first window of lines from subroutine. 6768B<l> I<\$var> List first window of lines from subroutine referenced by I<\$var>. 6769B<l> List next window of lines. 6770B<-> List previous window of lines. 6771B<v> [I<line>] View window around I<line>. 6772B<.> Return to the executed line. 6773B<f> I<filename> Switch to viewing I<filename>. File must be already loaded. 6774 I<filename> may be either the full name of the file, or a regular 6775 expression matching the full file name: 6776 B<f> I</home/me/foo.pl> and B<f> I<oo\\.> may access the same file. 6777 Evals (with saved bodies) are considered to be filenames: 6778 B<f> I<(eval 7)> and B<f> I<eval 7\\b> access the body of the 7th eval 6779 (in the order of execution). 6780B</>I<pattern>B</> Search forwards for I<pattern>; final B</> is optional. 6781B<?>I<pattern>B<?> Search backwards for I<pattern>; final B<?> is optional. 6782B<L> [I<a|b|w>] List actions and or breakpoints and or watch-expressions. 6783B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>. 6784B<t> Toggle trace mode. 6785B<t> I<expr> Trace through execution of I<expr>. 6786B<b> Sets breakpoint on current line) 6787B<b> [I<line>] [I<condition>] 6788 Set breakpoint; I<line> defaults to the current execution line; 6789 I<condition> breaks if it evaluates to true, defaults to '1'. 6790B<b> I<subname> [I<condition>] 6791 Set breakpoint at first line of subroutine. 6792B<b> I<\$var> Set breakpoint at first line of subroutine referenced by I<\$var>. 6793B<b> B<load> I<filename> Set breakpoint on 'require'ing the given file. 6794B<b> B<postpone> I<subname> [I<condition>] 6795 Set breakpoint at first line of subroutine after 6796 it is compiled. 6797B<b> B<compile> I<subname> 6798 Stop after the subroutine is compiled. 6799B<B> [I<line>] Delete the breakpoint for I<line>. 6800B<B> I<*> Delete all breakpoints. 6801B<a> [I<line>] I<command> 6802 Set an action to be done before the I<line> is executed; 6803 I<line> defaults to the current execution line. 6804 Sequence is: check for breakpoint/watchpoint, print line 6805 if necessary, do action, prompt user if necessary, 6806 execute line. 6807B<a> Does nothing 6808B<A> [I<line>] Delete the action for I<line>. 6809B<A> I<*> Delete all actions. 6810B<w> I<expr> Add a global watch-expression. 6811B<w> Does nothing 6812B<W> I<expr> Delete a global watch-expression. 6813B<W> I<*> Delete all watch-expressions. 6814B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current). 6815 Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps. 6816B<X> [I<vars>] Same as \"B<V> I<currentpackage> [I<vars>]\". 6817B<x> I<expr> Evals expression in list context, dumps the result. 6818B<m> I<expr> Evals expression in list context, prints methods callable 6819 on the first element of the result. 6820B<m> I<class> Prints methods callable via the given class. 6821B<M> Show versions of loaded modules. 6822B<i> I<class> Prints nested parents of given class. 6823B<y> [I<n> [I<Vars>]] List lexicals in higher scope <n>. Vars same as B<V>. 6824 6825B<<> ? List Perl commands to run before each prompt. 6826B<<> I<expr> Define Perl command to run before each prompt. 6827B<<<> I<expr> Add to the list of Perl commands to run before each prompt. 6828B<< *> Delete the list of perl commands to run before each prompt. 6829B<>> ? List Perl commands to run after each prompt. 6830B<>> I<expr> Define Perl command to run after each prompt. 6831B<>>B<>> I<expr> Add to the list of Perl commands to run after each prompt. 6832B<>>B< *> Delete the list of Perl commands to run after each prompt. 6833B<{> I<db_command> Define debugger command to run before each prompt. 6834B<{> ? List debugger commands to run before each prompt. 6835B<{ *> Delete the list of debugger commands to run before each prompt. 6836B<{{> I<db_command> Add to the list of debugger commands to run before each prompt. 6837B<$prc> I<number> Redo a previous command (default previous command). 6838B<$prc> I<-number> Redo number'th-to-last command. 6839B<$prc> I<pattern> Redo last command that started with I<pattern>. 6840 See 'B<O> I<recallCommand>' too. 6841B<$psh$psh> I<cmd> Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)" 6842 . ( 6843 $rc eq $sh 6844 ? "" 6845 : " 6846B<$psh> [I<cmd>] Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." 6847 ) 6848 . " 6849 See 'B<O> I<shellBang>' too. 6850B<source> I<file> Execute I<file> containing debugger commands (may nest). 6851B<save> I<file> Save current debugger session (actual history) to I<file>. 6852B<H> I<-number> Display last number commands (default all). 6853B<p> I<expr> Same as \"I<print {DB::OUT} expr>\" in current package. 6854B<|>I<dbcmd> Run debugger command, piping DB::OUT to current pager. 6855B<||>I<dbcmd> Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well. 6856B<\=> [I<alias> I<value>] Define a command alias, or list current aliases. 6857I<command> Execute as a perl statement in current package. 6858B<R> Pure-man-restart of debugger, some of debugger state 6859 and command-line options may be lost. 6860 Currently the following settings are preserved: 6861 history, breakpoints and actions, debugger B<O>ptions 6862 and the following command-line options: I<-w>, I<-I>, I<-e>. 6863 6864B<o> [I<opt>] ... Set boolean option to true 6865B<o> [I<opt>B<?>] Query options 6866B<o> [I<opt>B<=>I<val>] [I<opt>=B<\">I<val>B<\">] ... 6867 Set options. Use quotes in spaces in value. 6868 I<recallCommand>, I<ShellBang> chars used to recall command or spawn shell; 6869 I<pager> program for output of \"|cmd\"; 6870 I<tkRunning> run Tk while prompting (with ReadLine); 6871 I<signalLevel> I<warnLevel> I<dieLevel> level of verbosity; 6872 I<inhibit_exit> Allows stepping off the end of the script. 6873 I<ImmediateStop> Debugger should stop as early as possible. 6874 I<RemotePort> Remote hostname:port for remote debugging 6875 The following options affect what happens with B<V>, B<X>, and B<x> commands: 6876 I<arrayDepth>, I<hashDepth> print only first N elements ('' for all); 6877 I<compactDump>, I<veryCompact> change style of array and hash dump; 6878 I<globPrint> whether to print contents of globs; 6879 I<DumpDBFiles> dump arrays holding debugged files; 6880 I<DumpPackages> dump symbol tables of packages; 6881 I<DumpReused> dump contents of \"reused\" addresses; 6882 I<quote>, I<HighBit>, I<undefPrint> change style of string dump; 6883 I<bareStringify> Do not print the overload-stringified value; 6884 Other options include: 6885 I<PrintRet> affects printing of return value after B<r> command, 6886 I<frame> affects printing messages on subroutine entry/exit. 6887 I<AutoTrace> affects printing messages on possible breaking points. 6888 I<maxTraceLen> gives max length of evals/args listed in stack trace. 6889 I<ornaments> affects screen appearance of the command line. 6890 I<CreateTTY> bits control attempts to create a new TTY on events: 6891 1: on fork() 2: debugger is started inside debugger 6892 4: on startup 6893 During startup options are initialized from \$ENV{PERLDB_OPTS}. 6894 You can put additional initialization options I<TTY>, I<noTTY>, 6895 I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use 6896 `B<R>' after you set them). 6897 6898B<q> or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction. 6899B<h> Summary of debugger commands. 6900B<h> [I<db_command>] Get help [on a specific debugger command], enter B<|h> to page. 6901B<h h> Long help for debugger commands 6902B<$doccmd> I<manpage> Runs the external doc viewer B<$doccmd> command on the 6903 named Perl I<manpage>, or on B<$doccmd> itself if omitted. 6904 Set B<\$DB::doccmd> to change viewer. 6905 6906Type `|h h' for a paged display if this was too hard to read. 6907 6908"; # Fix balance of vi % matching: }}}} 6909 6910 # note: tabs in the following section are not-so-helpful 6911 $summary = <<"END_SUM"; 6912I<List/search source lines:> I<Control script execution:> 6913 B<l> [I<ln>|I<sub>] List source code B<T> Stack trace 6914 B<-> or B<.> List previous/current line B<s> [I<expr>] Single step [in expr] 6915 B<v> [I<line>] View around line B<n> [I<expr>] Next, steps over subs 6916 B<f> I<filename> View source in file <B<CR>/B<Enter>> Repeat last B<n> or B<s> 6917 B</>I<pattern>B</> B<?>I<patt>B<?> Search forw/backw B<r> Return from subroutine 6918 B<M> Show module versions B<c> [I<ln>|I<sub>] Continue until position 6919I<Debugger controls:> B<L> List break/watch/actions 6920 B<o> [...] Set debugger options B<t> [I<expr>] Toggle trace [trace expr] 6921 B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I<cmd>] Do pre/post-prompt B<b> [I<ln>|I<event>|I<sub>] [I<cnd>] Set breakpoint 6922 B<$prc> [I<N>|I<pat>] Redo a previous command B<B> I<ln|*> Delete a/all breakpoints 6923 B<H> [I<-num>] Display last num commands B<a> [I<ln>] I<cmd> Do cmd before line 6924 B<=> [I<a> I<val>] Define/list an alias B<A> I<ln|*> Delete a/all actions 6925 B<h> [I<db_cmd>] Get help on command B<w> I<expr> Add a watch expression 6926 B<h h> Complete help page B<W> I<expr|*> Delete a/all watch exprs 6927 B<|>[B<|>]I<db_cmd> Send output to pager B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess 6928 B<q> or B<^D> Quit B<R> Attempt a restart 6929I<Data Examination:> B<expr> Execute perl code, also see: B<s>,B<n>,B<t> I<expr> 6930 B<x>|B<m> I<expr> Evals expr in list context, dumps the result or lists methods. 6931 B<p> I<expr> Print expression (uses script's current package). 6932 B<S> [[B<!>]I<pat>] List subroutine names [not] matching pattern 6933 B<V> [I<Pk> [I<Vars>]] List Variables in Package. Vars can be ~pattern or !pattern. 6934 B<X> [I<Vars>] Same as \"B<V> I<current_package> [I<Vars>]\". B<i> I<class> inheritance tree. 6935 B<y> [I<n> [I<Vars>]] List lexicals in higher scope <n>. Vars same as B<V>. 6936For more help, type B<h> I<cmd_letter>, or run B<$doccmd perldebug> for all docs. 6937END_SUM 6938 6939 # ')}}; # Fix balance of vi % matching 6940 6941 # and this is really numb... 6942 $pre580_help = " 6943B<T> Stack trace. 6944B<s> [I<expr>] Single step [in I<expr>]. 6945B<n> [I<expr>] Next, steps over subroutine calls [in I<expr>]. 6946B<CR>> Repeat last B<n> or B<s> command. 6947B<r> Return from current subroutine. 6948B<c> [I<line>|I<sub>] Continue; optionally inserts a one-time-only breakpoint 6949 at the specified position. 6950B<l> I<min>B<+>I<incr> List I<incr>+1 lines starting at I<min>. 6951B<l> I<min>B<->I<max> List lines I<min> through I<max>. 6952B<l> I<line> List single I<line>. 6953B<l> I<subname> List first window of lines from subroutine. 6954B<l> I<\$var> List first window of lines from subroutine referenced by I<\$var>. 6955B<l> List next window of lines. 6956B<-> List previous window of lines. 6957B<w> [I<line>] List window around I<line>. 6958B<.> Return to the executed line. 6959B<f> I<filename> Switch to viewing I<filename>. File must be already loaded. 6960 I<filename> may be either the full name of the file, or a regular 6961 expression matching the full file name: 6962 B<f> I</home/me/foo.pl> and B<f> I<oo\\.> may access the same file. 6963 Evals (with saved bodies) are considered to be filenames: 6964 B<f> I<(eval 7)> and B<f> I<eval 7\\b> access the body of the 7th eval 6965 (in the order of execution). 6966B</>I<pattern>B</> Search forwards for I<pattern>; final B</> is optional. 6967B<?>I<pattern>B<?> Search backwards for I<pattern>; final B<?> is optional. 6968B<L> List all breakpoints and actions. 6969B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>. 6970B<t> Toggle trace mode. 6971B<t> I<expr> Trace through execution of I<expr>. 6972B<b> [I<line>] [I<condition>] 6973 Set breakpoint; I<line> defaults to the current execution line; 6974 I<condition> breaks if it evaluates to true, defaults to '1'. 6975B<b> I<subname> [I<condition>] 6976 Set breakpoint at first line of subroutine. 6977B<b> I<\$var> Set breakpoint at first line of subroutine referenced by I<\$var>. 6978B<b> B<load> I<filename> Set breakpoint on `require'ing the given file. 6979B<b> B<postpone> I<subname> [I<condition>] 6980 Set breakpoint at first line of subroutine after 6981 it is compiled. 6982B<b> B<compile> I<subname> 6983 Stop after the subroutine is compiled. 6984B<d> [I<line>] Delete the breakpoint for I<line>. 6985B<D> Delete all breakpoints. 6986B<a> [I<line>] I<command> 6987 Set an action to be done before the I<line> is executed; 6988 I<line> defaults to the current execution line. 6989 Sequence is: check for breakpoint/watchpoint, print line 6990 if necessary, do action, prompt user if necessary, 6991 execute line. 6992B<a> [I<line>] Delete the action for I<line>. 6993B<A> Delete all actions. 6994B<W> I<expr> Add a global watch-expression. 6995B<W> Delete all watch-expressions. 6996B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current). 6997 Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps. 6998B<X> [I<vars>] Same as \"B<V> I<currentpackage> [I<vars>]\". 6999B<x> I<expr> Evals expression in list context, dumps the result. 7000B<m> I<expr> Evals expression in list context, prints methods callable 7001 on the first element of the result. 7002B<m> I<class> Prints methods callable via the given class. 7003 7004B<<> ? List Perl commands to run before each prompt. 7005B<<> I<expr> Define Perl command to run before each prompt. 7006B<<<> I<expr> Add to the list of Perl commands to run before each prompt. 7007B<>> ? List Perl commands to run after each prompt. 7008B<>> I<expr> Define Perl command to run after each prompt. 7009B<>>B<>> I<expr> Add to the list of Perl commands to run after each prompt. 7010B<{> I<db_command> Define debugger command to run before each prompt. 7011B<{> ? List debugger commands to run before each prompt. 7012B<{{> I<db_command> Add to the list of debugger commands to run before each prompt. 7013B<$prc> I<number> Redo a previous command (default previous command). 7014B<$prc> I<-number> Redo number'th-to-last command. 7015B<$prc> I<pattern> Redo last command that started with I<pattern>. 7016 See 'B<O> I<recallCommand>' too. 7017B<$psh$psh> I<cmd> Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)" 7018 . ( 7019 $rc eq $sh 7020 ? "" 7021 : " 7022B<$psh> [I<cmd>] Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." 7023 ) . 7024 " 7025 See 'B<O> I<shellBang>' too. 7026B<source> I<file> Execute I<file> containing debugger commands (may nest). 7027B<H> I<-number> Display last number commands (default all). 7028B<p> I<expr> Same as \"I<print {DB::OUT} expr>\" in current package. 7029B<|>I<dbcmd> Run debugger command, piping DB::OUT to current pager. 7030B<||>I<dbcmd> Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well. 7031B<\=> [I<alias> I<value>] Define a command alias, or list current aliases. 7032I<command> Execute as a perl statement in current package. 7033B<v> Show versions of loaded modules. 7034B<R> Pure-man-restart of debugger, some of debugger state 7035 and command-line options may be lost. 7036 Currently the following settings are preserved: 7037 history, breakpoints and actions, debugger B<O>ptions 7038 and the following command-line options: I<-w>, I<-I>, I<-e>. 7039 7040B<O> [I<opt>] ... Set boolean option to true 7041B<O> [I<opt>B<?>] Query options 7042B<O> [I<opt>B<=>I<val>] [I<opt>=B<\">I<val>B<\">] ... 7043 Set options. Use quotes in spaces in value. 7044 I<recallCommand>, I<ShellBang> chars used to recall command or spawn shell; 7045 I<pager> program for output of \"|cmd\"; 7046 I<tkRunning> run Tk while prompting (with ReadLine); 7047 I<signalLevel> I<warnLevel> I<dieLevel> level of verbosity; 7048 I<inhibit_exit> Allows stepping off the end of the script. 7049 I<ImmediateStop> Debugger should stop as early as possible. 7050 I<RemotePort> Remote hostname:port for remote debugging 7051 The following options affect what happens with B<V>, B<X>, and B<x> commands: 7052 I<arrayDepth>, I<hashDepth> print only first N elements ('' for all); 7053 I<compactDump>, I<veryCompact> change style of array and hash dump; 7054 I<globPrint> whether to print contents of globs; 7055 I<DumpDBFiles> dump arrays holding debugged files; 7056 I<DumpPackages> dump symbol tables of packages; 7057 I<DumpReused> dump contents of \"reused\" addresses; 7058 I<quote>, I<HighBit>, I<undefPrint> change style of string dump; 7059 I<bareStringify> Do not print the overload-stringified value; 7060 Other options include: 7061 I<PrintRet> affects printing of return value after B<r> command, 7062 I<frame> affects printing messages on subroutine entry/exit. 7063 I<AutoTrace> affects printing messages on possible breaking points. 7064 I<maxTraceLen> gives max length of evals/args listed in stack trace. 7065 I<ornaments> affects screen appearance of the command line. 7066 I<CreateTTY> bits control attempts to create a new TTY on events: 7067 1: on fork() 2: debugger is started inside debugger 7068 4: on startup 7069 During startup options are initialized from \$ENV{PERLDB_OPTS}. 7070 You can put additional initialization options I<TTY>, I<noTTY>, 7071 I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use 7072 `B<R>' after you set them). 7073 7074B<q> or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction. 7075B<h> [I<db_command>] Get help [on a specific debugger command], enter B<|h> to page. 7076B<h h> Summary of debugger commands. 7077B<$doccmd> I<manpage> Runs the external doc viewer B<$doccmd> command on the 7078 named Perl I<manpage>, or on B<$doccmd> itself if omitted. 7079 Set B<\$DB::doccmd> to change viewer. 7080 7081Type `|h' for a paged display if this was too hard to read. 7082 7083"; # Fix balance of vi % matching: }}}} 7084 7085 # note: tabs in the following section are not-so-helpful 7086 $pre580_summary = <<"END_SUM"; 7087I<List/search source lines:> I<Control script execution:> 7088 B<l> [I<ln>|I<sub>] List source code B<T> Stack trace 7089 B<-> or B<.> List previous/current line B<s> [I<expr>] Single step [in expr] 7090 B<w> [I<line>] List around line B<n> [I<expr>] Next, steps over subs 7091 B<f> I<filename> View source in file <B<CR>/B<Enter>> Repeat last B<n> or B<s> 7092 B</>I<pattern>B</> B<?>I<patt>B<?> Search forw/backw B<r> Return from subroutine 7093 B<v> Show versions of modules B<c> [I<ln>|I<sub>] Continue until position 7094I<Debugger controls:> B<L> List break/watch/actions 7095 B<O> [...] Set debugger options B<t> [I<expr>] Toggle trace [trace expr] 7096 B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I<cmd>] Do pre/post-prompt B<b> [I<ln>|I<event>|I<sub>] [I<cnd>] Set breakpoint 7097 B<$prc> [I<N>|I<pat>] Redo a previous command B<d> [I<ln>] or B<D> Delete a/all breakpoints 7098 B<H> [I<-num>] Display last num commands B<a> [I<ln>] I<cmd> Do cmd before line 7099 B<=> [I<a> I<val>] Define/list an alias B<W> I<expr> Add a watch expression 7100 B<h> [I<db_cmd>] Get help on command B<A> or B<W> Delete all actions/watch 7101 B<|>[B<|>]I<db_cmd> Send output to pager B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess 7102 B<q> or B<^D> Quit B<R> Attempt a restart 7103I<Data Examination:> B<expr> Execute perl code, also see: B<s>,B<n>,B<t> I<expr> 7104 B<x>|B<m> I<expr> Evals expr in list context, dumps the result or lists methods. 7105 B<p> I<expr> Print expression (uses script's current package). 7106 B<S> [[B<!>]I<pat>] List subroutine names [not] matching pattern 7107 B<V> [I<Pk> [I<Vars>]] List Variables in Package. Vars can be ~pattern or !pattern. 7108 B<X> [I<Vars>] Same as \"B<V> I<current_package> [I<Vars>]\". 7109 B<y> [I<n> [I<Vars>]] List lexicals in higher scope <n>. Vars same as B<V>. 7110For more help, type B<h> I<cmd_letter>, or run B<$doccmd perldebug> for all docs. 7111END_SUM 7112 7113 # ')}}; # Fix balance of vi % matching 7114 7115} ## end sub sethelp 7116 7117=head2 C<print_help()> 7118 7119Most of what C<print_help> does is just text formatting. It finds the 7120C<B> and C<I> ornaments, cleans them off, and substitutes the proper 7121terminal control characters to simulate them (courtesy of 7122<Term::ReadLine::TermCap>). 7123 7124=cut 7125 7126sub print_help { 7127 local $_ = shift; 7128 7129 # Restore proper alignment destroyed by eeevil I<> and B<> 7130 # ornaments: A pox on both their houses! 7131 # 7132 # A help command will have everything up to and including 7133 # the first tab sequence padded into a field 16 (or if indented 20) 7134 # wide. If it's wider than that, an extra space will be added. 7135 s{ 7136 ^ # only matters at start of line 7137 ( \040{4} | \t )* # some subcommands are indented 7138 ( < ? # so <CR> works 7139 [BI] < [^\t\n] + ) # find an eeevil ornament 7140 ( \t+ ) # original separation, discarded 7141 ( .* ) # this will now start (no earlier) than 7142 # column 16 7143 } { 7144 my($leadwhite, $command, $midwhite, $text) = ($1, $2, $3, $4); 7145 my $clean = $command; 7146 $clean =~ s/[BI]<([^>]*)>/$1/g; 7147 7148 # replace with this whole string: 7149 ($leadwhite ? " " x 4 : "") 7150 . $command 7151 . ((" " x (16 + ($leadwhite ? 4 : 0) - length($clean))) || " ") 7152 . $text; 7153 7154 }mgex; 7155 7156 s{ # handle bold ornaments 7157 B < ( [^>] + | > ) > 7158 } { 7159 $Term::ReadLine::TermCap::rl_term_set[2] 7160 . $1 7161 . $Term::ReadLine::TermCap::rl_term_set[3] 7162 }gex; 7163 7164 s{ # handle italic ornaments 7165 I < ( [^>] + | > ) > 7166 } { 7167 $Term::ReadLine::TermCap::rl_term_set[0] 7168 . $1 7169 . $Term::ReadLine::TermCap::rl_term_set[1] 7170 }gex; 7171 7172 local $\ = ''; 7173 print $OUT $_; 7174} ## end sub print_help 7175 7176=head2 C<fix_less> 7177 7178This routine does a lot of gyrations to be sure that the pager is C<less>. 7179It checks for C<less> masquerading as C<more> and records the result in 7180C<$ENV{LESS}> so we don't have to go through doing the stats again. 7181 7182=cut 7183 7184sub fix_less { 7185 7186 # We already know if this is set. 7187 return if defined $ENV{LESS} && $ENV{LESS} =~ /r/; 7188 7189 # Pager is less for sure. 7190 my $is_less = $pager =~ /\bless\b/; 7191 if ($pager =~ /\bmore\b/) { 7192 # Nope, set to more. See what's out there. 7193 my @st_more = stat('/usr/bin/more'); 7194 my @st_less = stat('/usr/bin/less'); 7195 7196 # is it really less, pretending to be more? 7197 $is_less = @st_more && 7198 @st_less && 7199 $st_more[0] == $st_less[0] && 7200 $st_more[1] == $st_less[1]; 7201 } ## end if ($pager =~ /\bmore\b/) 7202 7203 # changes environment! 7204 # 'r' added so we don't do (slow) stats again. 7205 $ENV{LESS} .= 'r' if $is_less; 7206} ## end sub fix_less 7207 7208=head1 DIE AND WARN MANAGEMENT 7209 7210=head2 C<diesignal> 7211 7212C<diesignal> is a just-drop-dead C<die> handler. It's most useful when trying 7213to debug a debugger problem. 7214 7215It does its best to report the error that occurred, and then forces the 7216program, debugger, and everything to die. 7217 7218=cut 7219 7220sub diesignal { 7221 # No entry/exit messages. 7222 local $frame = 0; 7223 7224 # No return value prints. 7225 local $doret = -2; 7226 7227 # set the abort signal handling to the default (just terminate). 7228 $SIG{'ABRT'} = 'DEFAULT'; 7229 7230 # If we enter the signal handler recursively, kill myself with an 7231 # abort signal (so we just terminate). 7232 kill 'ABRT', $$ if $panic++; 7233 7234 # If we can show detailed info, do so. 7235 if (defined &Carp::longmess) { 7236 # Don't recursively enter the warn handler, since we're carping. 7237 local $SIG{__WARN__} = ''; 7238 7239 # Skip two levels before reporting traceback: we're skipping 7240 # mydie and confess. 7241 local $Carp::CarpLevel = 2; # mydie + confess 7242 7243 # Tell us all about it. 7244 &warn(Carp::longmess("Signal @_")); 7245 } 7246 7247 # No Carp. Tell us about the signal as best we can. 7248 else { 7249 local $\ = ''; 7250 print $DB::OUT "Got signal @_\n"; 7251 } 7252 7253 # Drop dead. 7254 kill 'ABRT', $$; 7255} ## end sub diesignal 7256 7257=head2 C<dbwarn> 7258 7259The debugger's own default C<$SIG{__WARN__}> handler. We load C<Carp> to 7260be able to get a stack trace, and output the warning message vi C<DB::dbwarn()>. 7261 7262=cut 7263 7264sub dbwarn { 7265 # No entry/exit trace. 7266 local $frame = 0; 7267 7268 # No return value printing. 7269 local $doret = -2; 7270 7271 # Turn off warn and die handling to prevent recursive entries to this 7272 # routine. 7273 local $SIG{__WARN__} = ''; 7274 local $SIG{__DIE__} = ''; 7275 7276 # Load Carp if we can. If $^S is false (current thing being compiled isn't 7277 # done yet), we may not be able to do a require. 7278 eval { require Carp } 7279 if defined $^S; # If error/warning during compilation, 7280 # require may be broken. 7281 7282 # Use the core warn() unless Carp loaded OK. 7283 CORE::warn(@_, 7284 "\nCannot print stack trace, load with -MCarp option to see stack"), 7285 return 7286 unless defined &Carp::longmess; 7287 7288 # Save the current values of $single and $trace, and then turn them off. 7289 my ($mysingle, $mytrace) = ($single, $trace); 7290 $single = 0; 7291 $trace = 0; 7292 7293 # We can call Carp::longmess without its being "debugged" (which we 7294 # don't want - we just want to use it!). Capture this for later. 7295 my $mess = Carp::longmess(@_); 7296 7297 # Restore $single and $trace to their original values. 7298 ($single, $trace) = ($mysingle, $mytrace); 7299 7300 # Use the debugger's own special way of printing warnings to print 7301 # the stack trace message. 7302 &warn($mess); 7303} ## end sub dbwarn 7304 7305=head2 C<dbdie> 7306 7307The debugger's own C<$SIG{__DIE__}> handler. Handles providing a stack trace 7308by loading C<Carp> and calling C<Carp::longmess()> to get it. We turn off 7309single stepping and tracing during the call to C<Carp::longmess> to avoid 7310debugging it - we just want to use it. 7311 7312If C<dieLevel> is zero, we let the program being debugged handle the 7313exceptions. If it's 1, you get backtraces for any exception. If it's 2, 7314the debugger takes over all exception handling, printing a backtrace and 7315displaying the exception via its C<dbwarn()> routine. 7316 7317=cut 7318 7319sub dbdie { 7320 local $frame = 0; 7321 local $doret = -2; 7322 local $SIG{__DIE__} = ''; 7323 local $SIG{__WARN__} = ''; 7324 my $i = 0; 7325 my $ineval = 0; 7326 my $sub; 7327 if ($dieLevel > 2) { 7328 local $SIG{__WARN__} = \&dbwarn; 7329 &warn(@_); # Yell no matter what 7330 return; 7331 } 7332 if ($dieLevel < 2) { 7333 die @_ if $^S; # in eval propagate 7334 } 7335 7336 # The code used to check $^S to see if compiliation of the current thing 7337 # hadn't finished. We don't do it anymore, figuring eval is pretty stable. 7338 eval { require Carp }; 7339 7340 die (@_, 7341 "\nCannot print stack trace, load with -MCarp option to see stack") 7342 unless defined &Carp::longmess; 7343 7344 # We do not want to debug this chunk (automatic disabling works 7345 # inside DB::DB, but not in Carp). Save $single and $trace, turn them off, 7346 # get the stack trace from Carp::longmess (if possible), restore $signal 7347 # and $trace, and then die with the stack trace. 7348 my ($mysingle, $mytrace) = ($single, $trace); 7349 $single = 0; 7350 $trace = 0; 7351 my $mess = "@_"; 7352 { 7353 7354 package Carp; # Do not include us in the list 7355 eval { $mess = Carp::longmess(@_); }; 7356 } 7357 ($single, $trace) = ($mysingle, $mytrace); 7358 die $mess; 7359} ## end sub dbdie 7360 7361=head2 C<warnlevel()> 7362 7363Set the C<$DB::warnLevel> variable that stores the value of the 7364C<warnLevel> option. Calling C<warnLevel()> with a positive value 7365results in the debugger taking over all warning handlers. Setting 7366C<warnLevel> to zero leaves any warning handlers set up by the program 7367being debugged in place. 7368 7369=cut 7370 7371sub warnLevel { 7372 if (@_) { 7373 $prevwarn = $SIG{__WARN__} unless $warnLevel; 7374 $warnLevel = shift; 7375 if ($warnLevel) { 7376 $SIG{__WARN__} = \&DB::dbwarn; 7377 } 7378 elsif ($prevwarn) { 7379 $SIG{__WARN__} = $prevwarn; 7380 } 7381 } ## end if (@_) 7382 $warnLevel; 7383} ## end sub warnLevel 7384 7385=head2 C<dielevel> 7386 7387Similar to C<warnLevel>. Non-zero values for C<dieLevel> result in the 7388C<DB::dbdie()> function overriding any other C<die()> handler. Setting it to 7389zero lets you use your own C<die()> handler. 7390 7391=cut 7392 7393sub dieLevel { 7394 local $\ = ''; 7395 if (@_) { 7396 $prevdie = $SIG{__DIE__} unless $dieLevel; 7397 $dieLevel = shift; 7398 if ($dieLevel) { 7399 # Always set it to dbdie() for non-zero values. 7400 $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2; 7401 7402 # No longer exists, so don't try to use it. 7403 #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2; 7404 7405 # If we've finished initialization, mention that stack dumps 7406 # are enabled, If dieLevel is 1, we won't stack dump if we die 7407 # in an eval(). 7408 print $OUT "Stack dump during die enabled", 7409 ($dieLevel == 1 ? " outside of evals" : ""), ".\n" 7410 if $I_m_init; 7411 7412 # XXX This is probably obsolete, given that diehard() is gone. 7413 print $OUT "Dump printed too.\n" if $dieLevel > 2; 7414 } ## end if ($dieLevel) 7415 7416 # Put the old one back if there was one. 7417 elsif ($prevdie) { 7418 $SIG{__DIE__} = $prevdie; 7419 print $OUT "Default die handler restored.\n"; 7420 } 7421 } ## end if (@_) 7422 $dieLevel; 7423} ## end sub dieLevel 7424 7425=head2 C<signalLevel> 7426 7427Number three in a series: set C<signalLevel> to zero to keep your own 7428signal handler for C<SIGSEGV> and/or C<SIGBUS>. Otherwise, the debugger 7429takes over and handles them with C<DB::diesignal()>. 7430 7431=cut 7432 7433sub signalLevel { 7434 if (@_) { 7435 $prevsegv = $SIG{SEGV} unless $signalLevel; 7436 $prevbus = $SIG{BUS} unless $signalLevel; 7437 $signalLevel = shift; 7438 if ($signalLevel) { 7439 $SIG{SEGV} = \&DB::diesignal; 7440 $SIG{BUS} = \&DB::diesignal; 7441 } 7442 else { 7443 $SIG{SEGV} = $prevsegv; 7444 $SIG{BUS} = $prevbus; 7445 } 7446 } ## end if (@_) 7447 $signalLevel; 7448} ## end sub signalLevel 7449 7450=head1 SUBROUTINE DECODING SUPPORT 7451 7452These subroutines are used during the C<x> and C<X> commands to try to 7453produce as much information as possible about a code reference. They use 7454L<Devel::Peek> to try to find the glob in which this code reference lives 7455(if it does) - this allows us to actually code references which correspond 7456to named subroutines (including those aliased via glob assignment). 7457 7458=head2 C<CvGV_name()> 7459 7460Wrapper for X<CvGV_name_or_bust>; tries to get the name of a reference 7461via that routine. If this fails, return the reference again (when the 7462reference is stringified, it'll come out as "SOMETHING(0X...)"). 7463 7464=cut 7465 7466sub CvGV_name { 7467 my $in = shift; 7468 my $name = CvGV_name_or_bust($in); 7469 defined $name ? $name : $in; 7470} 7471 7472=head2 C<CvGV_name_or_bust> I<coderef> 7473 7474Calls L<Devel::Peek> to try to find the glob the ref lives in; returns 7475C<undef> if L<Devel::Peek> can't be loaded, or if C<Devel::Peek::CvGV> can't 7476find a glob for this ref. 7477 7478Returns "I<package>::I<glob name>" if the code ref is found in a glob. 7479 7480=cut 7481 7482sub CvGV_name_or_bust { 7483 my $in = shift; 7484 return if $skipCvGV; # Backdoor to avoid problems if XS broken... 7485 return unless ref $in; 7486 $in = \&$in; # Hard reference... 7487 eval { require Devel::Peek; 1 } or return; 7488 my $gv = Devel::Peek::CvGV($in) or return; 7489 *$gv{PACKAGE} . '::' . *$gv{NAME}; 7490} ## end sub CvGV_name_or_bust 7491 7492=head2 C<find_sub> 7493 7494A utility routine used in various places; finds the file where a subroutine 7495was defined, and returns that filename and a line-number range. 7496 7497Tries to use X<@sub> first; if it can't find it there, it tries building a 7498reference to the subroutine and uses X<CvGV_name_or_bust> to locate it, 7499loading it into X<@sub> as a side effect (XXX I think). If it can't find it 7500this way, it brute-force searches X<%sub>, checking for identical references. 7501 7502=cut 7503 7504sub find_sub { 7505 my $subr = shift; 7506 $sub{$subr} or do { 7507 return unless defined &$subr; 7508 my $name = CvGV_name_or_bust($subr); 7509 my $data; 7510 $data = $sub{$name} if defined $name; 7511 return $data if defined $data; 7512 7513 # Old stupid way... 7514 $subr = \&$subr; # Hard reference 7515 my $s; 7516 for (keys %sub) { 7517 $s = $_, last if $subr eq \&$_; 7518 } 7519 $sub{$s} if $s; 7520 } ## end do 7521} ## end sub find_sub 7522 7523=head2 C<methods> 7524 7525A subroutine that uses the utility function X<methods_via> to find all the 7526methods in the class corresponding to the current reference and in 7527C<UNIVERSAL>. 7528 7529=cut 7530 7531sub methods { 7532 7533 # Figure out the class - either this is the class or it's a reference 7534 # to something blessed into that class. 7535 my $class = shift; 7536 $class = ref $class if ref $class; 7537 7538 local %seen; 7539 local %packs; 7540 7541 # Show the methods that this class has. 7542 methods_via($class, '', 1); 7543 7544 # Show the methods that UNIVERSAL has. 7545 methods_via('UNIVERSAL', 'UNIVERSAL', 0); 7546} ## end sub methods 7547 7548=head2 C<methods_via($class, $prefix, $crawl_upward)> 7549 7550C<methods_via> does the work of crawling up the C<@ISA> tree and reporting 7551all the parent class methods. C<$class> is the name of the next class to 7552try; C<$prefix> is the message prefix, which gets built up as we go up the 7553C<@ISA> tree to show parentage; C<$crawl_upward> is 1 if we should try to go 7554higher in the C<@ISA> tree, 0 if we should stop. 7555 7556=cut 7557 7558sub methods_via { 7559 # If we've processed this class already, just quit. 7560 my $class = shift; 7561 return if $seen{$class}++; 7562 7563 # This is a package that is contributing the methods we're about to print. 7564 my $prefix = shift; 7565 my $prepend = $prefix ? "via $prefix: " : ''; 7566 7567 my $name; 7568 for $name ( 7569 # Keep if this is a defined subroutine in this class. 7570 grep { defined &{ ${"${class}::"}{$_} } } 7571 # Extract from all the symbols in this class. 7572 sort keys %{"${class}::"} 7573 ) { 7574 # If we printed this already, skip it. 7575 next if $seen{$name}++; 7576 7577 # Print the new method name. 7578 local $\ = ''; 7579 local $, = ''; 7580 print $DB::OUT "$prepend$name\n"; 7581 } ## end for $name (grep { defined... 7582 7583 # If the $crawl_upward argument is false, just quit here. 7584 return unless shift; 7585 7586 # $crawl_upward true: keep going up the tree. 7587 # Find all the classes this one is a subclass of. 7588 for $name (@{"${class}::ISA"}) { 7589 # Set up the new prefix. 7590 $prepend = $prefix ? $prefix . " -> $name" : $name; 7591 # Crawl up the tree and keep trying to crawl up. 7592 methods_via($name, $prepend, 1); 7593 } 7594} ## end sub methods_via 7595 7596=head2 C<setman> - figure out which command to use to show documentation 7597 7598Just checks the contents of C<$^O> and sets the C<$doccmd> global accordingly. 7599 7600=cut 7601 7602sub setman { 7603 $doccmd = 7604 $^O !~ /^(?:MSWin32|VMS|os2|dos|amigaos|riscos|MacOS|NetWare)\z/s 7605 ? "man" # O Happy Day! 7606 : "perldoc"; # Alas, poor unfortunates 7607} ## end sub setman 7608 7609=head2 C<runman> - run the appropriate command to show documentation 7610 7611Accepts a man page name; runs the appropriate command to display it (set up 7612during debugger initialization). Uses C<DB::system> to avoid mucking up the 7613program's STDIN and STDOUT. 7614 7615=cut 7616 7617sub runman { 7618 my $page = shift; 7619 unless ($page) { 7620 &system("$doccmd $doccmd"); 7621 return; 7622 } 7623 7624 # this way user can override, like with $doccmd="man -Mwhatever" 7625 # or even just "man " to disable the path check. 7626 unless ($doccmd eq 'man') { 7627 &system("$doccmd $page"); 7628 return; 7629 } 7630 7631 $page = 'perl' if lc($page) eq 'help'; 7632 7633 require Config; 7634 my $man1dir = $Config::Config{'man1dir'}; 7635 my $man3dir = $Config::Config{'man3dir'}; 7636 for ($man1dir, $man3dir) { s#/[^/]*\z## if /\S/ } 7637 my $manpath = ''; 7638 $manpath .= "$man1dir:" if $man1dir =~ /\S/; 7639 $manpath .= "$man3dir:" if $man3dir =~ /\S/ && $man1dir ne $man3dir; 7640 chop $manpath if $manpath; 7641 7642 # harmless if missing, I figure 7643 my $oldpath = $ENV{MANPATH}; 7644 $ENV{MANPATH} = $manpath if $manpath; 7645 my $nopathopt = $^O =~ /dunno what goes here/; 7646 if ( 7647 CORE::system( 7648 $doccmd, 7649 7650 # I just *know* there are men without -M 7651 (($manpath && !$nopathopt) ? ("-M", $manpath) : ()), 7652 split ' ', $page 7653 ) 7654 ) 7655 { 7656 unless ($page =~ /^perl\w/) { 7657 if ( 7658 grep { $page eq $_ } 7659 qw{ 7660 5004delta 5005delta amiga api apio book boot bot call compile 7661 cygwin data dbmfilter debug debguts delta diag doc dos dsc embed 7662 faq faq1 faq2 faq3 faq4 faq5 faq6 faq7 faq8 faq9 filter fork 7663 form func guts hack hist hpux intern ipc lexwarn locale lol mod 7664 modinstall modlib number obj op opentut os2 os390 pod port 7665 ref reftut run sec style sub syn thrtut tie toc todo toot tootc 7666 trap unicode var vms win32 xs xstut 7667 } 7668 ) 7669 { 7670 $page =~ s/^/perl/; 7671 CORE::system($doccmd, 7672 (($manpath && !$nopathopt) ? ("-M", $manpath) : ()), 7673 $page); 7674 } ## end if (grep { $page eq $_... 7675 } ## end unless ($page =~ /^perl\w/) 7676 } ## end if (CORE::system($doccmd... 7677 if (defined $oldpath) { 7678 $ENV{MANPATH} = $manpath; 7679 } 7680 else { 7681 delete $ENV{MANPATH}; 7682 } 7683} ## end sub runman 7684 7685#use Carp; # This did break, left for debugging 7686 7687=head1 DEBUGGER INITIALIZATION - THE SECOND BEGIN BLOCK 7688 7689Because of the way the debugger interface to the Perl core is designed, any 7690debugger package globals that C<DB::sub()> requires have to be defined before 7691any subroutines can be called. These are defined in the second C<BEGIN> block. 7692 7693This block sets things up so that (basically) the world is sane 7694before the debugger starts executing. We set up various variables that the 7695debugger has to have set up before the Perl core starts running: 7696 7697=over 4 7698 7699=item * The debugger's own filehandles (copies of STD and STDOUT for now). 7700 7701=item * Characters for shell escapes, the recall command, and the history command. 7702 7703=item * The maximum recursion depth. 7704 7705=item * The size of a C<w> command's window. 7706 7707=item * The before-this-line context to be printed in a C<v> (view a window around this line) command. 7708 7709=item * The fact that we're not in a sub at all right now. 7710 7711=item * The default SIGINT handler for the debugger. 7712 7713=item * The appropriate value of the flag in C<$^D> that says the debugger is running 7714 7715=item * The current debugger recursion level 7716 7717=item * The list of postponed (XXX define) items and the C<$single> stack 7718 7719=item * That we want no return values and no subroutine entry/exit trace. 7720 7721=back 7722 7723=cut 7724 7725# The following BEGIN is very handy if debugger goes havoc, debugging debugger? 7726 7727BEGIN { # This does not compile, alas. (XXX eh?) 7728 $IN = \*STDIN; # For bugs before DB::OUT has been opened 7729 $OUT = \*STDERR; # For errors before DB::OUT has been opened 7730 7731 # Define characters used by command parsing. 7732 $sh = '!'; # Shell escape (does not work) 7733 $rc = ','; # Recall command (does not work) 7734 @hist = ('?'); # Show history (does not work) 7735 @truehist=(); # Can be saved for replay (per session) 7736 7737 # This defines the point at which you get the 'deep recursion' 7738 # warning. It MUST be defined or the debugger will not load. 7739 $deep = 100; 7740 7741 # Number of lines around the current one that are shown in the 7742 # 'w' command. 7743 $window = 10; 7744 7745 # How much before-the-current-line context the 'v' command should 7746 # use in calculating the start of the window it will display. 7747 $preview = 3; 7748 7749 # We're not in any sub yet, but we need this to be a defined value. 7750 $sub = ''; 7751 7752 # Set up the debugger's interrupt handler. It simply sets a flag 7753 # ($signal) that DB::DB() will check before each command is executed. 7754 $SIG{INT} = \&DB::catch; 7755 7756 # The following lines supposedly, if uncommented, allow the debugger to 7757 # debug itself. Perhaps we can try that someday. 7758 # This may be enabled to debug debugger: 7759 #$warnLevel = 1 unless defined $warnLevel; 7760 #$dieLevel = 1 unless defined $dieLevel; 7761 #$signalLevel = 1 unless defined $signalLevel; 7762 7763 # This is the flag that says "a debugger is running, please call 7764 # DB::DB and DB::sub". We will turn it on forcibly before we try to 7765 # execute anything in the user's context, because we always want to 7766 # get control back. 7767 $db_stop = 0; # Compiler warning ... 7768 $db_stop = 1 << 30; # ... because this is only used in an eval() later. 7769 7770 # This variable records how many levels we're nested in debugging. Used 7771 # Used in the debugger prompt, and in determining whether it's all over or 7772 # not. 7773 $level = 0; # Level of recursive debugging 7774 7775 # "Triggers bug (?) in perl if we postpone this until runtime." 7776 # XXX No details on this yet, or whether we should fix the bug instead 7777 # of work around it. Stay tuned. 7778 @postponed = @stack = (0); 7779 7780 # Used to track the current stack depth using the auto-stacked-variable 7781 # trick. 7782 $stack_depth = 0; # Localized repeatedly; simple way to track $#stack 7783 7784 # Don't print return values on exiting a subroutine. 7785 $doret = -2; 7786 7787 # No extry/exit tracing. 7788 $frame = 0; 7789 7790} ## end BEGIN 7791 7792BEGIN { $^W = $ini_warn; } # Switch warnings back 7793 7794=head1 READLINE SUPPORT - COMPLETION FUNCTION 7795 7796=head2 db_complete 7797 7798C<readline> support - adds command completion to basic C<readline>. 7799 7800Returns a list of possible completions to C<readline> when invoked. C<readline> 7801will print the longest common substring following the text already entered. 7802 7803If there is only a single possible completion, C<readline> will use it in full. 7804 7805This code uses C<map> and C<grep> heavily to create lists of possible 7806completion. Think LISP in this section. 7807 7808=cut 7809 7810sub db_complete { 7811 7812 # Specific code for b c l V m f O, &blah, $blah, @blah, %blah 7813 # $text is the text to be completed. 7814 # $line is the incoming line typed by the user. 7815 # $start is the start of the text to be completed in the incoming line. 7816 my ($text, $line, $start) = @_; 7817 7818 # Save the initial text. 7819 # The search pattern is current package, ::, extract the next qualifier 7820 # Prefix and pack are set to undef. 7821 my ($itext, $search, $prefix, $pack) = 7822 ($text, "^\Q${'package'}::\E([^:]+)\$"); 7823 7824=head3 C<b postpone|compile> 7825 7826=over 4 7827 7828=item * Find all the subroutines that might match in this package 7829 7830=item * Add "postpone", "load", and "compile" as possibles (we may be completing the keyword itself 7831 7832=item * Include all the rest of the subs that are known 7833 7834=item * C<grep> out the ones that match the text we have so far 7835 7836=item * Return this as the list of possible completions 7837 7838=back 7839 7840=cut 7841 7842 return sort grep /^\Q$text/, (keys %sub), 7843 qw(postpone load compile), # subroutines 7844 (map { /$search/ ? ($1) : () } keys %sub) 7845 if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/; 7846 7847=head3 C<b load> 7848 7849Get all the possible files from @INC as it currently stands and 7850select the ones that match the text so far. 7851 7852=cut 7853 7854 return sort grep /^\Q$text/, values %INC # files 7855 if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/; 7856 7857=head3 C<V> (list variable) and C<m> (list modules) 7858 7859There are two entry points for these commands: 7860 7861=head4 Unqualified package names 7862 7863Get the top-level packages and grab everything that matches the text 7864so far. For each match, recursively complete the partial packages to 7865get all possible matching packages. Return this sorted list. 7866 7867=cut 7868 7869 return sort map { ($_, db_complete($_ . "::", "V ", 2)) } 7870 grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : () } keys %:: # top-packages 7871 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/; 7872 7873=head4 Qualified package names 7874 7875Take a partially-qualified package and find all subpackages for it 7876by getting all the subpackages for the package so far, matching all 7877the subpackages against the text, and discarding all of them which 7878start with 'main::'. Return this list. 7879 7880=cut 7881 7882 return sort map { ($_, db_complete($_ . "::", "V ", 2)) } 7883 grep !/^main::/, grep /^\Q$text/, 7884 map { /^(.*)::$/ ? ($prefix . "::$1") : () } keys %{ $prefix . '::' } 7885 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ 7886 and $text =~ /^(.*[^:])::?(\w*)$/ 7887 and $prefix = $1; 7888 7889=head3 C<f> - switch files 7890 7891Here, we want to get a fully-qualified filename for the C<f> command. 7892Possibilities are: 7893 7894=over 4 7895 7896=item 1. The original source file itself 7897 7898=item 2. A file from C<@INC> 7899 7900=item 3. An C<eval> (the debugger gets a C<(eval N)> fake file for each C<eval>). 7901 7902=back 7903 7904=cut 7905 7906 if ($line =~ /^\|*f\s+(.*)/) { # Loaded files 7907 # We might possibly want to switch to an eval (which has a "filename" 7908 # like '(eval 9)'), so we may need to clean up the completion text 7909 # before proceeding. 7910 $prefix = length($1) - length($text); 7911 $text = $1; 7912 7913=pod 7914 7915Under the debugger, source files are represented as C<_E<lt>/fullpath/to/file> 7916(C<eval>s are C<_E<lt>(eval NNN)>) keys in C<%main::>. We pull all of these 7917out of C<%main::>, add the initial source file, and extract the ones that 7918match the completion text so far. 7919 7920=cut 7921 7922 return sort 7923 map { substr $_, 2 + $prefix } grep /^_<\Q$text/, (keys %main::), 7924 $0; 7925 } ## end if ($line =~ /^\|*f\s+(.*)/) 7926 7927=head3 Subroutine name completion 7928 7929We look through all of the defined subs (the keys of C<%sub>) and 7930return both all the possible matches to the subroutine name plus 7931all the matches qualified to the current package. 7932 7933=cut 7934 7935 if ((substr $text, 0, 1) eq '&') { # subroutines 7936 $text = substr $text, 1; 7937 $prefix = "&"; 7938 return sort map "$prefix$_", grep /^\Q$text/, (keys %sub), 7939 ( 7940 map { /$search/ ? ($1) : () } 7941 keys %sub 7942 ); 7943 } ## end if ((substr $text, 0, ... 7944 7945=head3 Scalar, array, and hash completion: partially qualified package 7946 7947Much like the above, except we have to do a little more cleanup: 7948 7949=cut 7950 7951 if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package 7952 7953=pod 7954 7955=over 4 7956 7957=item * Determine the package that the symbol is in. Put it in C<::> (effectively C<main::>) if no package is specified. 7958 7959=cut 7960 7961 $pack = ($1 eq 'main' ? '' : $1) . '::'; 7962 7963=pod 7964 7965=item * Figure out the prefix vs. what needs completing. 7966 7967=cut 7968 7969 $prefix = (substr $text, 0, 1) . $1 . '::'; 7970 $text = $2; 7971 7972=pod 7973 7974=item * 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. 7975 7976=cut 7977 7978 my @out = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, 7979 keys %$pack; 7980 7981=pod 7982 7983=item * 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. 7984 7985=cut 7986 7987 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) { 7988 return db_complete($out[0], $line, $start); 7989 } 7990 7991 # Return the list of possibles. 7992 return sort @out; 7993 7994 } ## end if ($text =~ /^[\$@%](.*)::(.*)/) 7995 7996=pod 7997 7998=back 7999 8000=head3 Symbol completion: current package or package C<main>. 8001 8002=cut 8003 8004 8005 if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main) 8006 8007=pod 8008 8009=over 4 8010 8011=item * If it's C<main>, delete main to just get C<::> leading. 8012 8013=cut 8014 8015 $pack = ($package eq 'main' ? '' : $package) . '::'; 8016 8017=pod 8018 8019=item * We set the prefix to the item's sigil, and trim off the sigil to get the text to be completed. 8020 8021=cut 8022 8023 $prefix = substr $text, 0, 1; 8024 $text = substr $text, 1; 8025 8026=pod 8027 8028=item * 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. 8029 8030=cut 8031 8032 my @out = map "$prefix$_", grep /^\Q$text/, 8033 (grep /^_?[a-zA-Z]/, keys %$pack), 8034 ($pack eq '::' ? () : (grep /::$/, keys %::)); 8035 8036=item * If there's only one hit, it's a package qualifier, and it's not equal to the initial text, recomplete using this symbol. 8037 8038=back 8039 8040=cut 8041 8042 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) { 8043 return db_complete($out[0], $line, $start); 8044 } 8045 8046 # Return the list of possibles. 8047 return sort @out; 8048 } ## end if ($text =~ /^[\$@%]/) 8049 8050=head3 Options 8051 8052We use C<option_val()> to look up the current value of the option. If there's 8053only a single value, we complete the command in such a way that it is a 8054complete command for setting the option in question. If there are multiple 8055possible values, we generate a command consisting of the option plus a trailing 8056question mark, which, if executed, will list the current value of the option. 8057 8058=cut 8059 8060 my $cmd = ($CommandSet eq '580') ? 'o' : 'O'; 8061 if ((substr $line, 0, $start) =~ /^\|*$cmd\b.*\s$/) { # Options after space 8062 # We look for the text to be matched in the list of possible options, 8063 # and fetch the current value. 8064 my @out = grep /^\Q$text/, @options; 8065 my $val = option_val($out[0], undef); 8066 8067 # Set up a 'query option's value' command. 8068 my $out = '? '; 8069 if (not defined $val or $val =~ /[\n\r]/) { 8070 # There's really nothing else we can do. 8071 } 8072 8073 # We have a value. Create a proper option-setting command. 8074 elsif ($val =~ /\s/) { 8075 # XXX This may be an extraneous variable. 8076 my $found; 8077 8078 # We'll want to quote the string (because of the embedded 8079 # whtespace), but we want to make sure we don't end up with 8080 # mismatched quote characters. We try several possibilities. 8081 foreach $l (split //, qq/\"\'\#\|/) { 8082 # If we didn't find this quote character in the value, 8083 # quote it using this quote character. 8084 $out = "$l$val$l ", last if (index $val, $l) == -1; 8085 } 8086 } ## end elsif ($val =~ /\s/) 8087 8088 # Don't need any quotes. 8089 else { 8090 $out = "=$val "; 8091 } 8092 8093 # If there were multiple possible values, return '? ', which 8094 # makes the command into a query command. If there was just one, 8095 # have readline append that. 8096 $rl_attribs->{completer_terminator_character} = 8097 (@out == 1 ? $out : '? '); 8098 8099 # Return list of possibilities. 8100 return sort @out; 8101 } ## end if ((substr $line, 0, ... 8102 8103=head3 Filename completion 8104 8105For entering filenames. We simply call C<readline>'s C<filename_list()> 8106method with the completion text to get the possible completions. 8107 8108=cut 8109 8110 return $term->filename_list($text); # filenames 8111 8112} ## end sub db_complete 8113 8114=head1 MISCELLANEOUS SUPPORT FUNCTIONS 8115 8116Functions that possibly ought to be somewhere else. 8117 8118=head2 end_report 8119 8120Say we're done. 8121 8122=cut 8123 8124sub end_report { 8125 local $\ = ''; 8126 print $OUT "Use `q' to quit or `R' to restart. `h q' for details.\n"; 8127} 8128 8129=head2 clean_ENV 8130 8131If we have $ini_pids, save it in the environment; else remove it from the 8132environment. Used by the C<R> (restart) command. 8133 8134=cut 8135 8136sub clean_ENV { 8137 if (defined($ini_pids)) { 8138 $ENV{PERLDB_PIDS} = $ini_pids; 8139 } 8140 else { 8141 delete($ENV{PERLDB_PIDS}); 8142 } 8143} ## end sub clean_ENV 8144 8145=head1 END PROCESSING - THE C<END> BLOCK 8146 8147Come here at the very end of processing. We want to go into a 8148loop where we allow the user to enter commands and interact with the 8149debugger, but we don't want anything else to execute. 8150 8151First we set the C<$finished> variable, so that some commands that 8152shouldn't be run after the end of program quit working. 8153 8154We then figure out whether we're truly done (as in the user entered a C<q> 8155command, or we finished execution while running nonstop). If we aren't, 8156we set C<$single> to 1 (causing the debugger to get control again). 8157 8158We then call C<DB::fake::at_exit()>, which returns the C<Use 'q' to quit ..."> 8159message and returns control to the debugger. Repeat. 8160 8161When the user finally enters a C<q> command, C<$fall_off_end> is set to 81621 and the C<END> block simply exits with C<$single> set to 0 (don't 8163break, run to completion.). 8164 8165=cut 8166 8167END { 8168 $finished = 1 if $inhibit_exit; # So that some commands may be disabled. 8169 $fall_off_end = 1 unless $inhibit_exit; 8170 8171 # Do not stop in at_exit() and destructors on exit: 8172 $DB::single = !$fall_off_end && !$runnonstop; 8173 DB::fake::at_exit() unless $fall_off_end or $runnonstop; 8174} ## end END 8175 8176=head1 PRE-5.8 COMMANDS 8177 8178Some of the commands changed function quite a bit in the 5.8 command 8179realignment, so much so that the old code had to be replaced completely. 8180Because we wanted to retain the option of being able to go back to the 8181former command set, we moved the old code off to this section. 8182 8183There's an awful lot of duplicated code here. We've duplicated the 8184comments to keep things clear. 8185 8186=head2 Null command 8187 8188Does nothing. Used to 'turn off' commands. 8189 8190=cut 8191 8192sub cmd_pre580_null { 8193 8194 # do nothing... 8195} 8196 8197=head2 Old C<a> command. 8198 8199This version added actions if you supplied them, and deleted them 8200if you didn't. 8201 8202=cut 8203 8204sub cmd_pre580_a { 8205 my $xcmd = shift; 8206 my $cmd = shift; 8207 8208 # Argument supplied. Add the action. 8209 if ($cmd =~ /^(\d*)\s*(.*)/) { 8210 8211 # If the line isn't there, use the current line. 8212 $i = $1 || $line; 8213 $j = $2; 8214 8215 # If there is an action ... 8216 if (length $j) { 8217 8218 # ... but the line isn't breakable, skip it. 8219 if ($dbline[$i] == 0) { 8220 print $OUT "Line $i may not have an action.\n"; 8221 } 8222 else { 8223 # ... and the line is breakable: 8224 # Mark that there's an action in this file. 8225 $had_breakpoints{$filename} |= 2; 8226 8227 # Delete any current action. 8228 $dbline{$i} =~ s/\0[^\0]*//; 8229 8230 # Add the new action, continuing the line as needed. 8231 $dbline{$i} .= "\0" . action($j); 8232 } 8233 } ## end if (length $j) 8234 8235 # No action supplied. 8236 else { 8237 # Delete the action. 8238 $dbline{$i} =~ s/\0[^\0]*//; 8239 # Mark as having no break or action if nothing's left. 8240 delete $dbline{$i} if $dbline{$i} eq ''; 8241 } 8242 } ## end if ($cmd =~ /^(\d*)\s*(.*)/) 8243} ## end sub cmd_pre580_a 8244 8245=head2 Old C<b> command 8246 8247Add breakpoints. 8248 8249=cut 8250 8251sub cmd_pre580_b { 8252 my $xcmd = shift; 8253 my $cmd = shift; 8254 my $dbline = shift; 8255 8256 # Break on load. 8257 if ($cmd =~ /^load\b\s*(.*)/) { 8258 my $file = $1; 8259 $file =~ s/\s+$//; 8260 &cmd_b_load($file); 8261 } 8262 8263 # b compile|postpone <some sub> [<condition>] 8264 # The interpreter actually traps this one for us; we just put the 8265 # necessary condition in the %postponed hash. 8266 elsif ($cmd =~ /^(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/) { 8267 # Capture the condition if there is one. Make it true if none. 8268 my $cond = length $3 ? $3 : '1'; 8269 8270 # Save the sub name and set $break to 1 if $1 was 'postpone', 0 8271 # if it was 'compile'. 8272 my ($subname, $break) = ($2, $1 eq 'postpone'); 8273 8274 # De-Perl4-ify the name - ' separators to ::. 8275 $subname =~ s/\'/::/g; 8276 8277 # Qualify it into the current package unless it's already qualified. 8278 $subname = "${'package'}::" . $subname 8279 unless $subname =~ /::/; 8280 8281 # Add main if it starts with ::. 8282 $subname = "main" . $subname if substr($subname, 0, 2) eq "::"; 8283 8284 # Save the break type for this sub. 8285 $postponed{$subname} = $break ? "break +0 if $cond" : "compile"; 8286 } ## end elsif ($cmd =~ ... 8287 8288 # b <sub name> [<condition>] 8289 elsif ($cmd =~ /^([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/) { 8290 my $subname = $1; 8291 my $cond = length $2 ? $2 : '1'; 8292 &cmd_b_sub($subname, $cond); 8293 } 8294 8295 # b <line> [<condition>]. 8296 elsif ($cmd =~ /^(\d*)\s*(.*)/) { 8297 my $i = $1 || $dbline; 8298 my $cond = length $2 ? $2 : '1'; 8299 &cmd_b_line($i, $cond); 8300 } 8301} ## end sub cmd_pre580_b 8302 8303=head2 Old C<D> command. 8304 8305Delete all breakpoints unconditionally. 8306 8307=cut 8308 8309sub cmd_pre580_D { 8310 my $xcmd = shift; 8311 my $cmd = shift; 8312 if ($cmd =~ /^\s*$/) { 8313 print $OUT "Deleting all breakpoints...\n"; 8314 8315 # %had_breakpoints lists every file that had at least one 8316 # breakpoint in it. 8317 my $file; 8318 for $file (keys %had_breakpoints) { 8319 # Switch to the desired file temporarily. 8320 local *dbline = $main::{ '_<' . $file }; 8321 8322 my $max = $#dbline; 8323 my $was; 8324 8325 # For all lines in this file ... 8326 for ($i = 1 ; $i <= $max ; $i++) { 8327 # If there's a breakpoint or action on this line ... 8328 if (defined $dbline{$i}) { 8329 # ... remove the breakpoint. 8330 $dbline{$i} =~ s/^[^\0]+//; 8331 if ($dbline{$i} =~ s/^\0?$//) { 8332 # Remove the entry altogether if no action is there. 8333 delete $dbline{$i}; 8334 } 8335 } ## end if (defined $dbline{$i... 8336 } ## end for ($i = 1 ; $i <= $max... 8337 8338 # If, after we turn off the "there were breakpoints in this file" 8339 # bit, the entry in %had_breakpoints for this file is zero, 8340 # we should remove this file from the hash. 8341 if (not $had_breakpoints{$file} &= ~1) { 8342 delete $had_breakpoints{$file}; 8343 } 8344 } ## end for $file (keys %had_breakpoints) 8345 8346 # Kill off all the other breakpoints that are waiting for files that 8347 # haven't been loaded yet. 8348 undef %postponed; 8349 undef %postponed_file; 8350 undef %break_on_load; 8351 } ## end if ($cmd =~ /^\s*$/) 8352} ## end sub cmd_pre580_D 8353 8354=head2 Old C<h> command 8355 8356Print help. Defaults to printing the long-form help; the 5.8 version 8357prints the summary by default. 8358 8359=cut 8360 8361sub cmd_pre580_h { 8362 my $xcmd = shift; 8363 my $cmd = shift; 8364 8365 # Print the *right* help, long format. 8366 if ($cmd =~ /^\s*$/) { 8367 print_help($pre580_help); 8368 } 8369 8370 # 'h h' - explicitly-requested summary. 8371 elsif ($cmd =~ /^h\s*/) { 8372 print_help($pre580_summary); 8373 } 8374 8375 # Find and print a command's help. 8376 elsif ($cmd =~ /^h\s+(\S.*)$/) { 8377 my $asked = $1; # for proper errmsg 8378 my $qasked = quotemeta($asked); # for searching 8379 # XXX: finds CR but not <CR> 8380 if ($pre580_help =~ /^ 8381 <? # Optional '<' 8382 (?:[IB]<) # Optional markup 8383 $qasked # The command name 8384 /mx) { 8385 8386 while ( 8387 $pre580_help =~ /^ 8388 ( # The command help: 8389 <? # Optional '<' 8390 (?:[IB]<) # Optional markup 8391 $qasked # The command name 8392 ([\s\S]*?) # Lines starting with tabs 8393 \n # Final newline 8394 ) 8395 (?!\s)/mgx) # Line not starting with space 8396 # (Next command's help) 8397 { 8398 print_help($1); 8399 } 8400 } ## end if ($pre580_help =~ /^<?(?:[IB]<)$qasked/m) 8401 8402 # Help not found. 8403 else { 8404 print_help("B<$asked> is not a debugger command.\n"); 8405 } 8406 } ## end elsif ($cmd =~ /^h\s+(\S.*)$/) 8407} ## end sub cmd_pre580_h 8408 8409=head2 Old C<W> command 8410 8411C<W E<lt>exprE<gt>> adds a watch expression, C<W> deletes them all. 8412 8413=cut 8414 8415sub cmd_pre580_W { 8416 my $xcmd = shift; 8417 my $cmd = shift; 8418 8419 # Delete all watch expressions. 8420 if ($cmd =~ /^$/) { 8421 # No watching is going on. 8422 $trace &= ~2; 8423 # Kill all the watch expressions and values. 8424 @to_watch = @old_watch = (); 8425 } 8426 8427 # Add a watch expression. 8428 elsif ($cmd =~ /^(.*)/s) { 8429 # add it to the list to be watched. 8430 push @to_watch, $1; 8431 8432 # Get the current value of the expression. 8433 # Doesn't handle expressions returning list values! 8434 $evalarg = $1; 8435 my ($val) = &eval; 8436 $val = (defined $val) ? "'$val'" : 'undef'; 8437 8438 # Save it. 8439 push @old_watch, $val; 8440 8441 # We're watching stuff. 8442 $trace |= 2; 8443 8444 } ## end elsif ($cmd =~ /^(.*)/s) 8445} ## end sub cmd_pre580_W 8446 8447=head1 PRE-AND-POST-PROMPT COMMANDS AND ACTIONS 8448 8449The debugger used to have a bunch of nearly-identical code to handle 8450the pre-and-post-prompt action commands. C<cmd_pre590_prepost> and 8451C<cmd_prepost> unify all this into one set of code to handle the 8452appropriate actions. 8453 8454=head2 C<cmd_pre590_prepost> 8455 8456A small wrapper around C<cmd_prepost>; it makes sure that the default doesn't 8457do something destructive. In pre 5.8 debuggers, the default action was to 8458delete all the actions. 8459 8460=cut 8461 8462sub cmd_pre590_prepost { 8463 my $cmd = shift; 8464 my $line = shift || '*'; 8465 my $dbline = shift; 8466 8467 return &cmd_prepost( $cmd, $line, $dbline ); 8468} ## end sub cmd_pre590_prepost 8469 8470=head2 C<cmd_prepost> 8471 8472Actually does all the handling foe C<E<lt>>, C<E<gt>>, C<{{>, C<{>, etc. 8473Since the lists of actions are all held in arrays that are pointed to by 8474references anyway, all we have to do is pick the right array reference and 8475then use generic code to all, delete, or list actions. 8476 8477=cut 8478 8479sub cmd_prepost { my $cmd = shift; 8480 8481 # No action supplied defaults to 'list'. 8482 my $line = shift || '?'; 8483 8484 # Figure out what to put in the prompt. 8485 my $which = ''; 8486 8487 # Make sure we have some array or another to address later. 8488 # This means that if ssome reason the tests fail, we won't be 8489 # trying to stash actions or delete them from the wrong place. 8490 my $aref = []; 8491 8492 # < - Perl code to run before prompt. 8493 if ( $cmd =~ /^\</o ) { 8494 $which = 'pre-perl'; 8495 $aref = $pre; 8496 } 8497 8498 # > - Perl code to run after prompt. 8499 elsif ( $cmd =~ /^\>/o ) { 8500 $which = 'post-perl'; 8501 $aref = $post; 8502 } 8503 8504 # { - first check for properly-balanced braces. 8505 elsif ( $cmd =~ /^\{/o ) { 8506 if ( $cmd =~ /^\{.*\}$/o && unbalanced( substr( $cmd, 1 ) ) ) { 8507 print $OUT 8508"$cmd is now a debugger command\nuse `;$cmd' if you mean Perl code\n"; 8509 } 8510 8511 # Properly balanced. Pre-prompt debugger actions. 8512 else { 8513 $which = 'pre-debugger'; 8514 $aref = $pretype; 8515 } 8516 } ## end elsif ( $cmd =~ /^\{/o ) 8517 8518 # Did we find something that makes sense? 8519 unless ($which) { 8520 print $OUT "Confused by command: $cmd\n"; 8521 } 8522 8523 # Yes. 8524 else { 8525 # List actions. 8526 if ( $line =~ /^\s*\?\s*$/o ) { 8527 unless (@$aref) { 8528 # Nothing there. Complain. 8529 print $OUT "No $which actions.\n"; 8530 } 8531 else { 8532 # List the actions in the selected list. 8533 print $OUT "$which commands:\n"; 8534 foreach my $action (@$aref) { 8535 print $OUT "\t$cmd -- $action\n"; 8536 } 8537 } ## end else 8538 } ## end if ( $line =~ /^\s*\?\s*$/o) 8539 8540 # Might be a delete. 8541 else { 8542 if ( length($cmd) == 1 ) { 8543 if ( $line =~ /^\s*\*\s*$/o ) { 8544 # It's a delete. Get rid of the old actions in the 8545 # selected list.. 8546 @$aref = (); 8547 print $OUT "All $cmd actions cleared.\n"; 8548 } 8549 else { 8550 # Replace all the actions. (This is a <, >, or {). 8551 @$aref = action($line); 8552 } 8553 } ## end if ( length($cmd) == 1) 8554 elsif ( length($cmd) == 2 ) { 8555 # Add the action to the line. (This is a <<, >>, or {{). 8556 push @$aref, action($line); 8557 } 8558 else { 8559 # <<<, >>>>, {{{{{{ ... something not a command. 8560 print $OUT 8561 "Confused by strange length of $which command($cmd)...\n"; 8562 } 8563 } ## end else [ if ( $line =~ /^\s*\?\s*$/o) 8564 } ## end else 8565} ## end sub cmd_prepost 8566 8567 8568=head1 C<DB::fake> 8569 8570Contains the C<at_exit> routine that the debugger uses to issue the 8571C<Debugged program terminated ...> message after the program completes. See 8572the C<END> block documentation for more details. 8573 8574=cut 8575 8576package DB::fake; 8577 8578sub at_exit { 8579 "Debugged program terminated. Use `q' to quit or `R' to restart."; 8580} 8581 8582package DB; # Do not trace this 1; below! 8583 85841; 8585 8586