2 # Documentation is at the __END__
9 my ($running, $ready, $deep, $usrctxt, $evalarg,
10 @stack, @saved, @skippkg, @clients);
17 # Globals - must be defined at startup so that clients can refer to
18 # them right after a C<require DB;>
24 # these are hardcoded in perl source (some are magical)
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
37 # other "public" globals
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
44 $DB::VERSION = $DB::VERSION = '1.0';
46 # initialize private globals to avoid warnings
48 $running = 1; # are we running, or are we stopped?
60 # entry point for all subroutine calls
63 push(@stack, $DB::single);
65 $DB::single |= 4 if $#stack == $deep;
66 # print $DB::sub, "\n";
67 if ($DB::sub =~ /(?:^|::)DESTROY$/ or not defined wantarray) {
69 $DB::single |= pop(@stack);
74 $DB::single |= pop(@stack);
79 $DB::single |= pop(@stack);
85 # this is called by perl for every statement
90 ($DB::package, $DB::filename, $DB::lineno) = caller;
92 return if @skippkg and grep { $_ eq $DB::package } @skippkg;
94 $usrctxt = "package $DB::package;"; # this won't let them modify, alas
95 local(*DB::dbline) = "::_<$DB::filename";
97 if (($stop,$action) = split(/\0/,$DB::dbline{$DB::lineno})) {
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
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);
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;
118 &eval if ($evalarg = DB->prestop);
121 # perform any client-specific prestop actions
122 &eval if ($evalarg = $c->cprestop);
124 # Now sit in an event loop until something sets $running
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);
133 # perform any client-specific poststop actions
134 &eval if ($evalarg = $c->cpoststop);
136 &eval if ($evalarg = DB->poststop);
138 ($@, $!, $,, $/, $\, $^W) = @saved;
143 # this takes its argument via $evalarg to preserve current @_
146 ($@, $!, $,, $/, $\, $^W) = @saved;
147 eval "$usrctxt $evalarg; &DB::save";
148 _outputall($@) if $@;
151 ###############################################################################
152 # no compile-time subroutine call allowed before this point #
153 ###############################################################################
155 use strict; # this can run only after DB() and sub() are defined
158 @saved = ($@, $!, $,, $/, $\, $^W);
159 $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
163 for (@clients) { $_->awaken; }
170 # Client callable (read inheritable) methods defined after this point
176 $s = _clientname($s) if ref($s);
182 $s = _clientname($s) if ref($s);
183 @clients = grep {$_ ne $s} @clients;
185 # $running = 3 unless @clients;
186 exit(0) unless @clients;
191 "$name" =~ /^(.+)=[A-Z]+\(.+\)$/;
210 $s->set_tbreak($i) if $i;
211 for ($i = 0; $i <= $#stack;) {
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).
225 my $i = shift; # how many levels to get to DB sub
226 $i = 0 unless defined $i;
227 $stack[$#stack-$i] |= 1;
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).
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++) {
246 s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/;
247 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
248 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
250 $w = $w ? '@ = ' : '$ = ';
251 $a = $h ? '(' . join(', ', @a) . ')' : '';
252 $e =~ s/\n\s*\;\s*\Z// if $e;
253 $e =~ s/[\\\']/\\$1/g if $e;
256 } elsif (defined $r) {
258 } elsif ($s eq '(eval)') {
261 $f = "file `$f'" unless $f eq '-e';
262 push @ret, "$w&$s$a from $f line $l";
277 $DB::trace = !$DB::trace;
282 # without args: returns all defined subroutine names
283 # with subname args: returns a listref [file, start, end]
291 push @ret, [$DB::sub{$name} =~ /^(.*)\:(\d+)-(\d+)$/]
292 if exists $DB::sub{$name};
296 return keys %DB::sub;
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.
307 $fname = $DB::filename unless $fname;
308 return grep { $DB::sub{$_} =~ /^$fname/ } keys %DB::sub;
312 # returns a list of all filenames that DB knows about
316 my(@f) = grep(m|^_<|, keys %main::);
317 return map { substr($_,2) } @f;
321 # returns reference to an array holding the lines in currently
330 # loadfile($file, $line)
334 my($file, $line) = @_;
335 if (!defined $main::{'_<' . $file}) {
337 if (($try) = grep(m|^_<.*$file|, keys %main::)) {
338 $file = substr($try,2);
341 if (defined($main::{'_<' . $file})) {
343 # _outputall("Loading file $file..");
344 *DB::dbline = "::_<$file";
345 $DB::filename = $file;
347 # print "2 ", $file, '|', $line, "\n";
348 $c->showfile($file, $line);
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};
375 $i = _find_subline($i) if ($i =~ /\D/);
376 $s->output("Subroutine not found.\n") unless $i;
378 if ($DB::dbline[$i] == 0) {
379 $s->output("Line $i not breakable.\n");
382 $DB::dbline{$i} =~ s/^[^\0]*/$cond/;
390 $i = _find_subline($i) if ($i =~ /\D/);
391 $s->output("Subroutine not found.\n") unless $i;
393 if ($DB::dbline[$i] == 0) {
394 $s->output("Line $i not breakable.\n");
397 $DB::dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
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+)$/);
409 local *DB::dbline = "::_<$fname";
410 ++$from while $DB::dbline[$from] == 0 && $from < $to;
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};
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};
448 $i = _find_subline($i) if ($i =~ /\D/);
449 $s->output("Subroutine not found.\n") unless $i;
451 if ($DB::dbline[$i] == 0) {
452 $s->output("Line $i not actionable.\n");
455 $DB::dbline{$i} =~ s/\0[^\0]*//;
456 $DB::dbline{$i} .= "\0" . $act;
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?$//;
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?$//;
486 my ($client, $val) = @_;
487 return defined($val) ? $preeval->{$client} = $val : $preeval->{$client};
491 my ($client, $val) = @_;
492 return defined($val) ? $posteval->{$client} = $val : $posteval->{$client};
496 # "pure virtual" methods
499 # client-specific pre/post-stop actions.
503 # client complete startup
508 push @skippkg, @_ if @_;
512 my ($client, $val) = @_;
514 $running = 2; # hand over to DB() to evaluate in its context
515 $ineval->{$client} = $val;
517 return $ineval->{$client};
536 for (@clients) { $_->init }
538 $SIG{'INT'} = \&DB::catch;
540 # disable this if stepping through END blocks is desired
541 # (looks scary and deconstructivist with Swat)
549 DB - programmatic interface to the Perl debugging API (draft, subject to
558 # these (inherited) methods can be called by the client
560 CLIENT->register() # register a client package name
561 CLIENT->done() # de-register from the debugging API
562 CLIENT->skippkg('hide::hide') # ask DB not to stop in this package
563 CLIENT->cont([WHERE]) # run some more (until BREAK or another breakpt)
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
584 # These methods will be called at the appropriate times.
585 # Stub versions provided do nothing.
586 # None of these can block.
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 API must show
596 Perl debug information is frequently required not just by debuggers,
597 but also by modules that need some "special" information to do their
598 job properly, like profilers.
600 This module abstracts and provides all of the hooks into Perl internal
601 debugging functionality, so that various implementations of Perl debuggers
602 (or packages that want to simply get at the "privileged" debugging data)
603 can all benefit from the development of this common code. Currently used
604 by Swat, the perl/Tk GUI debugger.
606 Note that multiple "front-ends" can latch into this debugging API
607 simultaneously. This is intended to facilitate things like
608 debugging with a command line and GUI at the same time, debugging
609 debuggers etc. [Sounds nice, but this needs some serious support -- GSAR]
611 In particular, this API does B<not> provide the following functions:
625 command alias management
629 user interface (tty or graphical)
633 These are intended to be services performed by the clients of this API.
635 This module attempts to be squeaky clean w.r.t C<use strict;> and when
636 warnings are enabled.
639 =head2 Global Variables
641 The following "public" global names can be read by clients of this API.
642 Beware that these should be considered "readonly".
648 Name of current executing subroutine.
652 The keys of this hash are the names of all the known subroutines. Each value
653 is an encoded string that has the sprintf(3) format
654 C<("%s:%d-%d", filename, fromline, toline)>.
658 Single-step flag. Will be true if the API will stop at the next statement.
662 Signal flag. Will be set to a true value if a signal was caught. Clients may
663 check for this flag to abort time-consuming operations.
667 This flag is set to true if the API is tracing through subroutine calls.
671 Contains the arguments of current subroutine, or the C<@ARGV> array if in the
676 List of lines in currently loaded file.
680 Actions in current file (keys are line numbers). The values are strings that
681 have the sprintf(3) format C<("%s\000%s", breakcondition, actioncode)>.
685 Package namespace of currently executing code.
689 Currently loaded filename.
693 Fully qualified name of currently executing subroutine.
697 Line number that will be executed next.
703 The following are methods in the DB base class. A client must
704 access these methods by inheritance (*not* by calling them directly),
705 since the API keeps track of clients through the inheritance
710 =item CLIENT->register()
712 register a client object/package
714 =item CLIENT->evalcode(STRING)
716 eval STRING in executing code context
718 =item CLIENT->skippkg('D::hide')
720 ask DB not to stop in these packages
724 run some more (until a breakpt is reached)
736 de-register from the debugging API
740 =head2 Client Callback Methods
742 The following "virtual" methods can be defined by the client. They will
743 be called by the API at appropriate points. Note that unless specified
744 otherwise, the debug API only defines empty, non-functional default versions
751 Called after debug API inits itself.
753 =item CLIENT->prestop([STRING])
755 Usually inherited from DB package. If no arguments are passed,
756 returns the prestop action string.
760 Called when execution stops (w/ args file, line).
764 Called while stopped (can be a client event loop).
766 =item CLIENT->poststop([STRING])
768 Usually inherited from DB package. If no arguments are passed,
769 returns the poststop action string.
771 =item CLIENT->evalcode(STRING)
773 Usually inherited from DB package. Ask for a STRING to be C<eval>-ed
774 in executing code context.
776 =item CLIENT->cleanup()
778 Called just before exit.
780 =item CLIENT->output(LIST)
782 Called when API must show a message (warnings, errors etc.).
790 The interface defined by this module is missing some of the later additions
791 to perl's debugging functionality. As such, this interface should be considered
792 highly experimental and subject to change.
796 Gurusamy Sarathy gsar@activestate.com
798 This code heavily adapted from an early version of perl5db.pl attributable
799 to Larry Wall and the Perl Porters.