| [ Index ] |
PHP Cross Reference of Unnamed Project |
[Summary view] [Print] [Text view]
1 # 2 # Documentation is at the __END__ 3 # 4 5 package DB; 6 7 # "private" globals 8 9 my ($running, $ready, $deep, $usrctxt, $evalarg, 10 @stack, @saved, @skippkg, @clients); 11 my $preeval = {}; 12 my $posteval = {}; 13 my $ineval = {}; 14 15 #### 16 # 17 # Globals - must be defined at startup so that clients can refer to 18 # them right after a C<require DB;> 19 # 20 #### 21 22 BEGIN { 23 24 # these are hardcoded in perl source (some are magical) 25 26 $DB::sub = ''; # name of current subroutine 27 %DB::sub = (); # "filename:fromline-toline" for every known sub 28 $DB::single = 0; # single-step flag (set it to 1 to enable stops in BEGIN/use) 29 $DB::signal = 0; # signal flag (will cause a stop at the next line) 30 $DB::trace = 0; # are we tracing through subroutine calls? 31 @DB::args = (); # arguments of current subroutine or @ARGV array 32 @DB::dbline = (); # list of lines in currently loaded file 33 %DB::dbline = (); # actions in current file (keyed by line number) 34 @DB::ret = (); # return value of last sub executed in list context 35 $DB::ret = ''; # return value of last sub executed in scalar context 36 37 # other "public" globals 38 39 $DB::package = ''; # current package space 40 $DB::filename = ''; # current filename 41 $DB::subname = ''; # currently executing sub (fullly qualified name) 42 $DB::lineno = ''; # current line number 43 44 $DB::VERSION = $DB::VERSION = '1.01'; 45 46 # initialize private globals to avoid warnings 47 48 $running = 1; # are we running, or are we stopped? 49 @stack = (0); 50 @clients = (); 51 $deep = 100; 52 $ready = 0; 53 @saved = (); 54 @skippkg = (); 55 $usrctxt = ''; 56 $evalarg = ''; 57 } 58 59 #### 60 # entry point for all subroutine calls 61 # 62 sub sub { 63 push(@stack, $DB::single); 64 $DB::single &= 1; 65 $DB::single |= 4 if $#stack == $deep; 66 if ($DB::sub eq 'DESTROY' or substr($DB::sub, -9) eq '::DESTROY' or not defined wantarray) { 67 &$DB::sub; 68 $DB::single |= pop(@stack); 69 $DB::ret = undef; 70 } 71 elsif (wantarray) { 72 @DB::ret = &$DB::sub; 73 $DB::single |= pop(@stack); 74 @DB::ret; 75 } 76 else { 77 $DB::ret = &$DB::sub; 78 $DB::single |= pop(@stack); 79 $DB::ret; 80 } 81 } 82 83 #### 84 # this is called by perl for every statement 85 # 86 sub DB { 87 return unless $ready; 88 &save; 89 ($DB::package, $DB::filename, $DB::lineno) = caller; 90 91 return if @skippkg and grep { $_ eq $DB::package } @skippkg; 92 93 $usrctxt = "package $DB::package;"; # this won't let them modify, alas 94 local(*DB::dbline) = "::_<$DB::filename"; 95 96 # we need to check for pseudofiles on Mac OS (these are files 97 # not attached to a filename, but instead stored in Dev:Pseudo) 98 # since this is done late, $DB::filename will be "wrong" after 99 # skippkg 100 if ($^O eq 'MacOS' && $#DB::dbline < 0) { 101 $DB::filename = 'Dev:Pseudo'; 102 *DB::dbline = "::_<$DB::filename"; 103 } 104 105 my ($stop, $action); 106 if (($stop,$action) = split(/\0/,$DB::dbline{$DB::lineno})) { 107 if ($stop eq '1') { 108 $DB::signal |= 1; 109 } 110 else { 111 $stop = 0 unless $stop; # avoid un_init warning 112 $evalarg = "\$DB::signal |= do { $stop; }"; &eval; 113 $DB::dbline{$DB::lineno} =~ s/;9($|\0)/$1/; # clear any temp breakpt 114 } 115 } 116 if ($DB::single || $DB::trace || $DB::signal) { 117 $DB::subname = ($DB::sub =~ /\'|::/) ? $DB::sub : "$DB::package}::$DB::sub"; #'; 118 DB->loadfile($DB::filename, $DB::lineno); 119 } 120 $evalarg = $action, &eval if $action; 121 if ($DB::single || $DB::signal) { 122 _outputall($#stack . " levels deep in subroutine calls.\n") if $DB::single & 4; 123 $DB::single = 0; 124 $DB::signal = 0; 125 $running = 0; 126 127 &eval if ($evalarg = DB->prestop); 128 my $c; 129 for $c (@clients) { 130 # perform any client-specific prestop actions 131 &eval if ($evalarg = $c->cprestop); 132 133 # Now sit in an event loop until something sets $running 134 do { 135 $c->idle; # call client event loop; must not block 136 if ($running == 2) { # client wants something eval-ed 137 &eval if ($evalarg = $c->evalcode); 138 $running = 0; 139 } 140 } until $running; 141 142 # perform any client-specific poststop actions 143 &eval if ($evalarg = $c->cpoststop); 144 } 145 &eval if ($evalarg = DB->poststop); 146 } 147 ($@, $!, $,, $/, $\, $^W) = @saved; 148 (); 149 } 150 151 #### 152 # this takes its argument via $evalarg to preserve current @_ 153 # 154 sub eval { 155 ($@, $!, $,, $/, $\, $^W) = @saved; 156 eval "$usrctxt $evalarg; &DB::save"; 157 _outputall($@) if $@; 158 } 159 160 ############################################################################### 161 # no compile-time subroutine call allowed before this point # 162 ############################################################################### 163 164 use strict; # this can run only after DB() and sub() are defined 165 166 sub save { 167 @saved = ($@, $!, $,, $/, $\, $^W); 168 $, = ""; $/ = "\n"; $\ = ""; $^W = 0; 169 } 170 171 sub catch { 172 for (@clients) { $_->awaken; } 173 $DB::signal = 1; 174 $ready = 1; 175 } 176 177 #### 178 # 179 # Client callable (read inheritable) methods defined after this point 180 # 181 #### 182 183 sub register { 184 my $s = shift; 185 $s = _clientname($s) if ref($s); 186 push @clients, $s; 187 } 188 189 sub done { 190 my $s = shift; 191 $s = _clientname($s) if ref($s); 192 @clients = grep {$_ ne $s} @clients; 193 $s->cleanup; 194 # $running = 3 unless @clients; 195 exit(0) unless @clients; 196 } 197 198 sub _clientname { 199 my $name = shift; 200 "$name" =~ /^(.+)=[A-Z]+\(.+\)$/; 201 return $1; 202 } 203 204 sub next { 205 my $s = shift; 206 $DB::single = 2; 207 $running = 1; 208 } 209 210 sub step { 211 my $s = shift; 212 $DB::single = 1; 213 $running = 1; 214 } 215 216 sub cont { 217 my $s = shift; 218 my $i = shift; 219 $s->set_tbreak($i) if $i; 220 for ($i = 0; $i <= $#stack;) { 221 $stack[$i++] &= ~1; 222 } 223 $DB::single = 0; 224 $running = 1; 225 } 226 227 #### 228 # XXX caller must experimentally determine $i (since it depends 229 # on how many client call frames are between this call and the DB call). 230 # Such is life. 231 # 232 sub ret { 233 my $s = shift; 234 my $i = shift; # how many levels to get to DB sub 235 $i = 0 unless defined $i; 236 $stack[$#stack-$i] |= 1; 237 $DB::single = 0; 238 $running = 1; 239 } 240 241 #### 242 # XXX caller must experimentally determine $start (since it depends 243 # on how many client call frames are between this call and the DB call). 244 # Such is life. 245 # 246 sub backtrace { 247 my $self = shift; 248 my $start = shift; 249 my($p,$f,$l,$s,$h,$w,$e,$r,$a, @a, @ret,$i); 250 $start = 1 unless $start; 251 for ($i = $start; ($p,$f,$l,$s,$h,$w,$e,$r) = caller($i); $i++) { 252 @a = @DB::args; 253 for (@a) { 254 s/'/\\'/g; 255 s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/; 256 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg; 257 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg; 258 } 259 $w = $w ? '@ = ' : '$ = '; 260 $a = $h ? '(' . join(', ', @a) . ')' : ''; 261 $e =~ s/\n\s*\;\s*\Z// if $e; 262 $e =~ s/[\\\']/\\$1/g if $e; 263 if ($r) { 264 $s = "require '$e'"; 265 } elsif (defined $r) { 266 $s = "eval '$e'"; 267 } elsif ($s eq '(eval)') { 268 $s = "eval {...}"; 269 } 270 $f = "file `$f'" unless $f eq '-e'; 271 push @ret, "$w&$s$a from $f line $l"; 272 last if $DB::signal; 273 } 274 return @ret; 275 } 276 277 sub _outputall { 278 my $c; 279 for $c (@clients) { 280 $c->output(@_); 281 } 282 } 283 284 sub trace_toggle { 285 my $s = shift; 286 $DB::trace = !$DB::trace; 287 } 288 289 290 #### 291 # without args: returns all defined subroutine names 292 # with subname args: returns a listref [file, start, end] 293 # 294 sub subs { 295 my $s = shift; 296 if (@_) { 297 my(@ret) = (); 298 while (@_) { 299 my $name = shift; 300 push @ret, [$DB::sub{$name} =~ /^(.*)\:(\d+)-(\d+)$/] 301 if exists $DB::sub{$name}; 302 } 303 return @ret; 304 } 305 return keys %DB::sub; 306 } 307 308 #### 309 # first argument is a filename whose subs will be returned 310 # if a filename is not supplied, all subs in the current 311 # filename are returned. 312 # 313 sub filesubs { 314 my $s = shift; 315 my $fname = shift; 316 $fname = $DB::filename unless $fname; 317 return grep { $DB::sub{$_} =~ /^$fname/ } keys %DB::sub; 318 } 319 320 #### 321 # returns a list of all filenames that DB knows about 322 # 323 sub files { 324 my $s = shift; 325 my(@f) = grep(m|^_<|, keys %main::); 326 return map { substr($_,2) } @f; 327 } 328 329 #### 330 # returns reference to an array holding the lines in currently 331 # loaded file 332 # 333 sub lines { 334 my $s = shift; 335 return \@DB::dbline; 336 } 337 338 #### 339 # loadfile($file, $line) 340 # 341 sub loadfile { 342 my $s = shift; 343 my($file, $line) = @_; 344 if (!defined $main::{'_<' . $file}) { 345 my $try; 346 if (($try) = grep(m|^_<.*$file|, keys %main::)) { 347 $file = substr($try,2); 348 } 349 } 350 if (defined($main::{'_<' . $file})) { 351 my $c; 352 # _outputall("Loading file $file.."); 353 *DB::dbline = "::_<$file"; 354 $DB::filename = $file; 355 for $c (@clients) { 356 # print "2 ", $file, '|', $line, "\n"; 357 $c->showfile($file, $line); 358 } 359 return $file; 360 } 361 return undef; 362 } 363 364 sub lineevents { 365 my $s = shift; 366 my $fname = shift; 367 my(%ret) = (); 368 my $i; 369 $fname = $DB::filename unless $fname; 370 local(*DB::dbline) = "::_<$fname"; 371 for ($i = 1; $i <= $#DB::dbline; $i++) { 372 $ret{$i} = [$DB::dbline[$i], split(/\0/, $DB::dbline{$i})] 373 if defined $DB::dbline{$i}; 374 } 375 return %ret; 376 } 377 378 sub set_break { 379 my $s = shift; 380 my $i = shift; 381 my $cond = shift; 382 $i ||= $DB::lineno; 383 $cond ||= '1'; 384 $i = _find_subline($i) if ($i =~ /\D/); 385 $s->output("Subroutine not found.\n") unless $i; 386 if ($i) { 387 if ($DB::dbline[$i] == 0) { 388 $s->output("Line $i not breakable.\n"); 389 } 390 else { 391 $DB::dbline{$i} =~ s/^[^\0]*/$cond/; 392 } 393 } 394 } 395 396 sub set_tbreak { 397 my $s = shift; 398 my $i = shift; 399 $i = _find_subline($i) if ($i =~ /\D/); 400 $s->output("Subroutine not found.\n") unless $i; 401 if ($i) { 402 if ($DB::dbline[$i] == 0) { 403 $s->output("Line $i not breakable.\n"); 404 } 405 else { 406 $DB::dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p. 407 } 408 } 409 } 410 411 sub _find_subline { 412 my $name = shift; 413 $name =~ s/\'/::/; 414 $name = "$DB::package}\:\:" . $name if $name !~ /::/; 415 $name = "main" . $name if substr($name,0,2) eq "::"; 416 my($fname, $from, $to) = ($DB::sub{$name} =~ /^(.*):(\d+)-(\d+)$/); 417 if ($from) { 418 local *DB::dbline = "::_<$fname"; 419 ++$from while $DB::dbline[$from] == 0 && $from < $to; 420 return $from; 421 } 422 return undef; 423 } 424 425 sub clr_breaks { 426 my $s = shift; 427 my $i; 428 if (@_) { 429 while (@_) { 430 $i = shift; 431 $i = _find_subline($i) if ($i =~ /\D/); 432 $s->output("Subroutine not found.\n") unless $i; 433 if (defined $DB::dbline{$i}) { 434 $DB::dbline{$i} =~ s/^[^\0]+//; 435 if ($DB::dbline{$i} =~ s/^\0?$//) { 436 delete $DB::dbline{$i}; 437 } 438 } 439 } 440 } 441 else { 442 for ($i = 1; $i <= $#DB::dbline ; $i++) { 443 if (defined $DB::dbline{$i}) { 444 $DB::dbline{$i} =~ s/^[^\0]+//; 445 if ($DB::dbline{$i} =~ s/^\0?$//) { 446 delete $DB::dbline{$i}; 447 } 448 } 449 } 450 } 451 } 452 453 sub set_action { 454 my $s = shift; 455 my $i = shift; 456 my $act = shift; 457 $i = _find_subline($i) if ($i =~ /\D/); 458 $s->output("Subroutine not found.\n") unless $i; 459 if ($i) { 460 if ($DB::dbline[$i] == 0) { 461 $s->output("Line $i not actionable.\n"); 462 } 463 else { 464 $DB::dbline{$i} =~ s/\0[^\0]*//; 465 $DB::dbline{$i} .= "\0" . $act; 466 } 467 } 468 } 469 470 sub clr_actions { 471 my $s = shift; 472 my $i; 473 if (@_) { 474 while (@_) { 475 my $i = shift; 476 $i = _find_subline($i) if ($i =~ /\D/); 477 $s->output("Subroutine not found.\n") unless $i; 478 if ($i && $DB::dbline[$i] != 0) { 479 $DB::dbline{$i} =~ s/\0[^\0]*//; 480 delete $DB::dbline{$i} if $DB::dbline{$i} =~ s/^\0?$//; 481 } 482 } 483 } 484 else { 485 for ($i = 1; $i <= $#DB::dbline ; $i++) { 486 if (defined $DB::dbline{$i}) { 487 $DB::dbline{$i} =~ s/\0[^\0]*//; 488 delete $DB::dbline{$i} if $DB::dbline{$i} =~ s/^\0?$//; 489 } 490 } 491 } 492 } 493 494 sub prestop { 495 my ($client, $val) = @_; 496 return defined($val) ? $preeval->{$client} = $val : $preeval->{$client}; 497 } 498 499 sub poststop { 500 my ($client, $val) = @_; 501 return defined($val) ? $posteval->{$client} = $val : $posteval->{$client}; 502 } 503 504 # 505 # "pure virtual" methods 506 # 507 508 # client-specific pre/post-stop actions. 509 sub cprestop {} 510 sub cpoststop {} 511 512 # client complete startup 513 sub awaken {} 514 515 sub skippkg { 516 my $s = shift; 517 push @skippkg, @_ if @_; 518 } 519 520 sub evalcode { 521 my ($client, $val) = @_; 522 if (defined $val) { 523 $running = 2; # hand over to DB() to evaluate in its context 524 $ineval->{$client} = $val; 525 } 526 return $ineval->{$client}; 527 } 528 529 sub ready { 530 my $s = shift; 531 return $ready = 1; 532 } 533 534 # stubs 535 536 sub init {} 537 sub stop {} 538 sub idle {} 539 sub cleanup {} 540 sub output {} 541 542 # 543 # client init 544 # 545 for (@clients) { $_->init } 546 547 $SIG{'INT'} = \&DB::catch; 548 549 # disable this if stepping through END blocks is desired 550 # (looks scary and deconstructivist with Swat) 551 END { $ready = 0 } 552 553 1; 554 __END__ 555 556 =head1 NAME 557 558 DB - programmatic interface to the Perl debugging API 559 560 =head1 SYNOPSIS 561 562 package CLIENT; 563 use DB; 564 @ISA = qw(DB); 565 566 # these (inherited) methods can be called by the client 567 568 CLIENT->register() # register a client package name 569 CLIENT->done() # de-register from the debugging API 570 CLIENT->skippkg('hide::hide') # ask DB not to stop in this package 571 CLIENT->cont([WHERE]) # run some more (until BREAK or another breakpt) 572 CLIENT->step() # single step 573 CLIENT->next() # step over 574 CLIENT->ret() # return from current subroutine 575 CLIENT->backtrace() # return the call stack description 576 CLIENT->ready() # call when client setup is done 577 CLIENT->trace_toggle() # toggle subroutine call trace mode 578 CLIENT->subs([SUBS]) # return subroutine information 579 CLIENT->files() # return list of all files known to DB 580 CLIENT->lines() # return lines in currently loaded file 581 CLIENT->loadfile(FILE,LINE) # load a file and let other clients know 582 CLIENT->lineevents() # return info on lines with actions 583 CLIENT->set_break([WHERE],[COND]) 584 CLIENT->set_tbreak([WHERE]) 585 CLIENT->clr_breaks([LIST]) 586 CLIENT->set_action(WHERE,ACTION) 587 CLIENT->clr_actions([LIST]) 588 CLIENT->evalcode(STRING) # eval STRING in executing code's context 589 CLIENT->prestop([STRING]) # execute in code context before stopping 590 CLIENT->poststop([STRING])# execute in code context before resuming 591 592 # These methods will be called at the appropriate times. 593 # Stub versions provided do nothing. 594 # None of these can block. 595 596 CLIENT->init() # called when debug API inits itself 597 CLIENT->stop(FILE,LINE) # when execution stops 598 CLIENT->idle() # while stopped (can be a client event loop) 599 CLIENT->cleanup() # just before exit 600 CLIENT->output(LIST) # called to print any output that API must show 601 602 =head1 DESCRIPTION 603 604 Perl debug information is frequently required not just by debuggers, 605 but also by modules that need some "special" information to do their 606 job properly, like profilers. 607 608 This module abstracts and provides all of the hooks into Perl internal 609 debugging functionality, so that various implementations of Perl debuggers 610 (or packages that want to simply get at the "privileged" debugging data) 611 can all benefit from the development of this common code. Currently used 612 by Swat, the perl/Tk GUI debugger. 613 614 Note that multiple "front-ends" can latch into this debugging API 615 simultaneously. This is intended to facilitate things like 616 debugging with a command line and GUI at the same time, debugging 617 debuggers etc. [Sounds nice, but this needs some serious support -- GSAR] 618 619 In particular, this API does B<not> provide the following functions: 620 621 =over 4 622 623 =item * 624 625 data display 626 627 =item * 628 629 command processing 630 631 =item * 632 633 command alias management 634 635 =item * 636 637 user interface (tty or graphical) 638 639 =back 640 641 These are intended to be services performed by the clients of this API. 642 643 This module attempts to be squeaky clean w.r.t C<use strict;> and when 644 warnings are enabled. 645 646 647 =head2 Global Variables 648 649 The following "public" global names can be read by clients of this API. 650 Beware that these should be considered "readonly". 651 652 =over 8 653 654 =item $DB::sub 655 656 Name of current executing subroutine. 657 658 =item %DB::sub 659 660 The keys of this hash are the names of all the known subroutines. Each value 661 is an encoded string that has the sprintf(3) format 662 C<("%s:%d-%d", filename, fromline, toline)>. 663 664 =item $DB::single 665 666 Single-step flag. Will be true if the API will stop at the next statement. 667 668 =item $DB::signal 669 670 Signal flag. Will be set to a true value if a signal was caught. Clients may 671 check for this flag to abort time-consuming operations. 672 673 =item $DB::trace 674 675 This flag is set to true if the API is tracing through subroutine calls. 676 677 =item @DB::args 678 679 Contains the arguments of current subroutine, or the C<@ARGV> array if in the 680 toplevel context. 681 682 =item @DB::dbline 683 684 List of lines in currently loaded file. 685 686 =item %DB::dbline 687 688 Actions in current file (keys are line numbers). The values are strings that 689 have the sprintf(3) format C<("%s\000%s", breakcondition, actioncode)>. 690 691 =item $DB::package 692 693 Package namespace of currently executing code. 694 695 =item $DB::filename 696 697 Currently loaded filename. 698 699 =item $DB::subname 700 701 Fully qualified name of currently executing subroutine. 702 703 =item $DB::lineno 704 705 Line number that will be executed next. 706 707 =back 708 709 =head2 API Methods 710 711 The following are methods in the DB base class. A client must 712 access these methods by inheritance (*not* by calling them directly), 713 since the API keeps track of clients through the inheritance 714 mechanism. 715 716 =over 8 717 718 =item CLIENT->register() 719 720 register a client object/package 721 722 =item CLIENT->evalcode(STRING) 723 724 eval STRING in executing code context 725 726 =item CLIENT->skippkg('D::hide') 727 728 ask DB not to stop in these packages 729 730 =item CLIENT->run() 731 732 run some more (until a breakpt is reached) 733 734 =item CLIENT->step() 735 736 single step 737 738 =item CLIENT->next() 739 740 step over 741 742 =item CLIENT->done() 743 744 de-register from the debugging API 745 746 =back 747 748 =head2 Client Callback Methods 749 750 The following "virtual" methods can be defined by the client. They will 751 be called by the API at appropriate points. Note that unless specified 752 otherwise, the debug API only defines empty, non-functional default versions 753 of these methods. 754 755 =over 8 756 757 =item CLIENT->init() 758 759 Called after debug API inits itself. 760 761 =item CLIENT->prestop([STRING]) 762 763 Usually inherited from DB package. If no arguments are passed, 764 returns the prestop action string. 765 766 =item CLIENT->stop() 767 768 Called when execution stops (w/ args file, line). 769 770 =item CLIENT->idle() 771 772 Called while stopped (can be a client event loop). 773 774 =item CLIENT->poststop([STRING]) 775 776 Usually inherited from DB package. If no arguments are passed, 777 returns the poststop action string. 778 779 =item CLIENT->evalcode(STRING) 780 781 Usually inherited from DB package. Ask for a STRING to be C<eval>-ed 782 in executing code context. 783 784 =item CLIENT->cleanup() 785 786 Called just before exit. 787 788 =item CLIENT->output(LIST) 789 790 Called when API must show a message (warnings, errors etc.). 791 792 793 =back 794 795 796 =head1 BUGS 797 798 The interface defined by this module is missing some of the later additions 799 to perl's debugging functionality. As such, this interface should be considered 800 highly experimental and subject to change. 801 802 =head1 AUTHOR 803 804 Gurusamy Sarathy gsar@activestate.com 805 806 This code heavily adapted from an early version of perl5db.pl attributable 807 to Larry Wall and the Perl Porters. 808 809 =cut
title
Description
Body
title
Description
Body
title
Description
Body
title
Body
| Generated: Tue Mar 17 22:47:18 2015 | Cross-referenced by PHPXref 0.7.1 |