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