1# 2# Documentation is at the __END__ 3# 4 5package DB; 6 7# "private" globals 8 9my ($running, $ready, $deep, $usrctxt, $evalarg, 10 @stack, @saved, @skippkg, @clients); 11my $preeval = {}; 12my $posteval = {}; 13my $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 22BEGIN { 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# 62sub 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# 86sub 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# 154sub 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 164use strict; # this can run only after DB() and sub() are defined 165 166sub save { 167 @saved = ($@, $!, $,, $/, $\, $^W); 168 $, = ""; $/ = "\n"; $\ = ""; $^W = 0; 169} 170 171sub 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 183sub register { 184 my $s = shift; 185 $s = _clientname($s) if ref($s); 186 push @clients, $s; 187} 188 189sub 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 198sub _clientname { 199 my $name = shift; 200 "$name" =~ /^(.+)=[A-Z]+\(.+\)$/; 201 return $1; 202} 203 204sub next { 205 my $s = shift; 206 $DB::single = 2; 207 $running = 1; 208} 209 210sub step { 211 my $s = shift; 212 $DB::single = 1; 213 $running = 1; 214} 215 216sub 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# 232sub 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# 246sub 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 277sub _outputall { 278 my $c; 279 for $c (@clients) { 280 $c->output(@_); 281 } 282} 283 284sub 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# 294sub 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# 313sub 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# 323sub 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# 333sub lines { 334 my $s = shift; 335 return \@DB::dbline; 336} 337 338#### 339# loadfile($file, $line) 340# 341sub 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 364sub 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 378sub 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 396sub 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 411sub _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 425sub 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 453sub 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 470sub 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 494sub prestop { 495 my ($client, $val) = @_; 496 return defined($val) ? $preeval->{$client} = $val : $preeval->{$client}; 497} 498 499sub 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. 509sub cprestop {} 510sub cpoststop {} 511 512# client complete startup 513sub awaken {} 514 515sub skippkg { 516 my $s = shift; 517 push @skippkg, @_ if @_; 518} 519 520sub 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 529sub ready { 530 my $s = shift; 531 return $ready = 1; 532} 533 534# stubs 535 536sub init {} 537sub stop {} 538sub idle {} 539sub cleanup {} 540sub output {} 541 542# 543# client init 544# 545for (@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) 551END { $ready = 0 } 552 5531; 554__END__ 555 556=head1 NAME 557 558DB - programmatic interface to the Perl debugging API (draft, subject to 559change) 560 561=head1 SYNOPSIS 562 563 package CLIENT; 564 use DB; 565 @ISA = qw(DB); 566 567 # these (inherited) methods can be called by the client 568 569 CLIENT->register() # register a client package name 570 CLIENT->done() # de-register from the debugging API 571 CLIENT->skippkg('hide::hide') # ask DB not to stop in this package 572 CLIENT->cont([WHERE]) # run some more (until BREAK or another breakpt) 573 CLIENT->step() # single step 574 CLIENT->next() # step over 575 CLIENT->ret() # return from current subroutine 576 CLIENT->backtrace() # return the call stack description 577 CLIENT->ready() # call when client setup is done 578 CLIENT->trace_toggle() # toggle subroutine call trace mode 579 CLIENT->subs([SUBS]) # return subroutine information 580 CLIENT->files() # return list of all files known to DB 581 CLIENT->lines() # return lines in currently loaded file 582 CLIENT->loadfile(FILE,LINE) # load a file and let other clients know 583 CLIENT->lineevents() # return info on lines with actions 584 CLIENT->set_break([WHERE],[COND]) 585 CLIENT->set_tbreak([WHERE]) 586 CLIENT->clr_breaks([LIST]) 587 CLIENT->set_action(WHERE,ACTION) 588 CLIENT->clr_actions([LIST]) 589 CLIENT->evalcode(STRING) # eval STRING in executing code's context 590 CLIENT->prestop([STRING]) # execute in code context before stopping 591 CLIENT->poststop([STRING])# execute in code context before resuming 592 593 # These methods will be called at the appropriate times. 594 # Stub versions provided do nothing. 595 # None of these can block. 596 597 CLIENT->init() # called when debug API inits itself 598 CLIENT->stop(FILE,LINE) # when execution stops 599 CLIENT->idle() # while stopped (can be a client event loop) 600 CLIENT->cleanup() # just before exit 601 CLIENT->output(LIST) # called to print any output that API must show 602 603=head1 DESCRIPTION 604 605Perl debug information is frequently required not just by debuggers, 606but also by modules that need some "special" information to do their 607job properly, like profilers. 608 609This module abstracts and provides all of the hooks into Perl internal 610debugging functionality, so that various implementations of Perl debuggers 611(or packages that want to simply get at the "privileged" debugging data) 612can all benefit from the development of this common code. Currently used 613by Swat, the perl/Tk GUI debugger. 614 615Note that multiple "front-ends" can latch into this debugging API 616simultaneously. This is intended to facilitate things like 617debugging with a command line and GUI at the same time, debugging 618debuggers etc. [Sounds nice, but this needs some serious support -- GSAR] 619 620In particular, this API does B<not> provide the following functions: 621 622=over 4 623 624=item * 625 626data display 627 628=item * 629 630command processing 631 632=item * 633 634command alias management 635 636=item * 637 638user interface (tty or graphical) 639 640=back 641 642These are intended to be services performed by the clients of this API. 643 644This module attempts to be squeaky clean w.r.t C<use strict;> and when 645warnings are enabled. 646 647 648=head2 Global Variables 649 650The following "public" global names can be read by clients of this API. 651Beware that these should be considered "readonly". 652 653=over 8 654 655=item $DB::sub 656 657Name of current executing subroutine. 658 659=item %DB::sub 660 661The keys of this hash are the names of all the known subroutines. Each value 662is an encoded string that has the sprintf(3) format 663C<("%s:%d-%d", filename, fromline, toline)>. 664 665=item $DB::single 666 667Single-step flag. Will be true if the API will stop at the next statement. 668 669=item $DB::signal 670 671Signal flag. Will be set to a true value if a signal was caught. Clients may 672check for this flag to abort time-consuming operations. 673 674=item $DB::trace 675 676This flag is set to true if the API is tracing through subroutine calls. 677 678=item @DB::args 679 680Contains the arguments of current subroutine, or the C<@ARGV> array if in the 681toplevel context. 682 683=item @DB::dbline 684 685List of lines in currently loaded file. 686 687=item %DB::dbline 688 689Actions in current file (keys are line numbers). The values are strings that 690have the sprintf(3) format C<("%s\000%s", breakcondition, actioncode)>. 691 692=item $DB::package 693 694Package namespace of currently executing code. 695 696=item $DB::filename 697 698Currently loaded filename. 699 700=item $DB::subname 701 702Fully qualified name of currently executing subroutine. 703 704=item $DB::lineno 705 706Line number that will be executed next. 707 708=back 709 710=head2 API Methods 711 712The following are methods in the DB base class. A client must 713access these methods by inheritance (*not* by calling them directly), 714since the API keeps track of clients through the inheritance 715mechanism. 716 717=over 8 718 719=item CLIENT->register() 720 721register a client object/package 722 723=item CLIENT->evalcode(STRING) 724 725eval STRING in executing code context 726 727=item CLIENT->skippkg('D::hide') 728 729ask DB not to stop in these packages 730 731=item CLIENT->run() 732 733run some more (until a breakpt is reached) 734 735=item CLIENT->step() 736 737single step 738 739=item CLIENT->next() 740 741step over 742 743=item CLIENT->done() 744 745de-register from the debugging API 746 747=back 748 749=head2 Client Callback Methods 750 751The following "virtual" methods can be defined by the client. They will 752be called by the API at appropriate points. Note that unless specified 753otherwise, the debug API only defines empty, non-functional default versions 754of these methods. 755 756=over 8 757 758=item CLIENT->init() 759 760Called after debug API inits itself. 761 762=item CLIENT->prestop([STRING]) 763 764Usually inherited from DB package. If no arguments are passed, 765returns the prestop action string. 766 767=item CLIENT->stop() 768 769Called when execution stops (w/ args file, line). 770 771=item CLIENT->idle() 772 773Called while stopped (can be a client event loop). 774 775=item CLIENT->poststop([STRING]) 776 777Usually inherited from DB package. If no arguments are passed, 778returns the poststop action string. 779 780=item CLIENT->evalcode(STRING) 781 782Usually inherited from DB package. Ask for a STRING to be C<eval>-ed 783in executing code context. 784 785=item CLIENT->cleanup() 786 787Called just before exit. 788 789=item CLIENT->output(LIST) 790 791Called when API must show a message (warnings, errors etc.). 792 793 794=back 795 796 797=head1 BUGS 798 799The interface defined by this module is missing some of the later additions 800to perl's debugging functionality. As such, this interface should be considered 801highly experimental and subject to change. 802 803=head1 AUTHOR 804 805Gurusamy Sarathy gsar@activestate.com 806 807This code heavily adapted from an early version of perl5db.pl attributable 808to Larry Wall and the Perl Porters. 809 810=cut 811