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 # we need to check for pseudofiles on Mac OS (these are files
98 # not attached to a filename, but instead stored in Dev:Pseudo)
99 # since this is done late, $DB::filename will be "wrong" after
101 if ($^O eq 'MacOS' && $#DB::dbline < 0) {
102 $DB::filename = 'Dev:Pseudo';
103 *DB::dbline = "::_<$DB::filename";
107 if (($stop,$action) = split(/\0/,$DB::dbline{$DB::lineno})) {
112 $stop = 0 unless $stop; # avoid un_init warning
113 $evalarg = "\$DB::signal |= do { $stop; }"; &eval;
114 $DB::dbline{$DB::lineno} =~ s/;9($|\0)/$1/; # clear any temp breakpt
117 if ($DB::single || $DB::trace || $DB::signal) {
118 $DB::subname = ($DB::sub =~ /\'|::/) ? $DB::sub : "${DB::package}::$DB::sub"; #';
119 DB->loadfile($DB::filename, $DB::lineno);
121 $evalarg = $action, &eval if $action;
122 if ($DB::single || $DB::signal) {
123 _outputall($#stack . " levels deep in subroutine calls.\n") if $DB::single & 4;
128 &eval if ($evalarg = DB->prestop);
131 # perform any client-specific prestop actions
132 &eval if ($evalarg = $c->cprestop);
134 # Now sit in an event loop until something sets $running
136 $c->idle; # call client event loop; must not block
137 if ($running == 2) { # client wants something eval-ed
138 &eval if ($evalarg = $c->evalcode);
143 # perform any client-specific poststop actions
144 &eval if ($evalarg = $c->cpoststop);
146 &eval if ($evalarg = DB->poststop);
148 ($@, $!, $,, $/, $\, $^W) = @saved;
153 # this takes its argument via $evalarg to preserve current @_
156 ($@, $!, $,, $/, $\, $^W) = @saved;
157 eval "$usrctxt $evalarg; &DB::save";
158 _outputall($@) if $@;
161 ###############################################################################
162 # no compile-time subroutine call allowed before this point #
163 ###############################################################################
165 use strict; # this can run only after DB() and sub() are defined
168 @saved = ($@, $!, $,, $/, $\, $^W);
169 $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
173 for (@clients) { $_->awaken; }
180 # Client callable (read inheritable) methods defined after this point
186 $s = _clientname($s) if ref($s);
192 $s = _clientname($s) if ref($s);
193 @clients = grep {$_ ne $s} @clients;
195 # $running = 3 unless @clients;
196 exit(0) unless @clients;
201 "$name" =~ /^(.+)=[A-Z]+\(.+\)$/;
220 $s->set_tbreak($i) if $i;
221 for ($i = 0; $i <= $#stack;) {
229 # XXX caller must experimentally determine $i (since it depends
230 # on how many client call frames are between this call and the DB call).
235 my $i = shift; # how many levels to get to DB sub
236 $i = 0 unless defined $i;
237 $stack[$#stack-$i] |= 1;
243 # XXX caller must experimentally determine $start (since it depends
244 # on how many client call frames are between this call and the DB call).
250 my($p,$f,$l,$s,$h,$w,$e,$r,$a, @a, @ret,$i);
251 $start = 1 unless $start;
252 for ($i = $start; ($p,$f,$l,$s,$h,$w,$e,$r) = caller($i); $i++) {
256 s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/;
257 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
258 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
260 $w = $w ? '@ = ' : '$ = ';
261 $a = $h ? '(' . join(', ', @a) . ')' : '';
262 $e =~ s/\n\s*\;\s*\Z// if $e;
263 $e =~ s/[\\\']/\\$1/g if $e;
266 } elsif (defined $r) {
268 } elsif ($s eq '(eval)') {
271 $f = "file `$f'" unless $f eq '-e';
272 push @ret, "$w&$s$a from $f line $l";
287 $DB::trace = !$DB::trace;
292 # without args: returns all defined subroutine names
293 # with subname args: returns a listref [file, start, end]
301 push @ret, [$DB::sub{$name} =~ /^(.*)\:(\d+)-(\d+)$/]
302 if exists $DB::sub{$name};
306 return keys %DB::sub;
310 # first argument is a filename whose subs will be returned
311 # if a filename is not supplied, all subs in the current
312 # filename are returned.
317 $fname = $DB::filename unless $fname;
318 return grep { $DB::sub{$_} =~ /^$fname/ } keys %DB::sub;
322 # returns a list of all filenames that DB knows about
326 my(@f) = grep(m|^_<|, keys %main::);
327 return map { substr($_,2) } @f;
331 # returns reference to an array holding the lines in currently
340 # loadfile($file, $line)
344 my($file, $line) = @_;
345 if (!defined $main::{'_<' . $file}) {
347 if (($try) = grep(m|^_<.*$file|, keys %main::)) {
348 $file = substr($try,2);
351 if (defined($main::{'_<' . $file})) {
353 # _outputall("Loading file $file..");
354 *DB::dbline = "::_<$file";
355 $DB::filename = $file;
357 # print "2 ", $file, '|', $line, "\n";
358 $c->showfile($file, $line);
370 $fname = $DB::filename unless $fname;
371 local(*DB::dbline) = "::_<$fname";
372 for ($i = 1; $i <= $#DB::dbline; $i++) {
373 $ret{$i} = [$DB::dbline[$i], split(/\0/, $DB::dbline{$i})]
374 if defined $DB::dbline{$i};
385 $i = _find_subline($i) if ($i =~ /\D/);
386 $s->output("Subroutine not found.\n") unless $i;
388 if ($DB::dbline[$i] == 0) {
389 $s->output("Line $i not breakable.\n");
392 $DB::dbline{$i} =~ s/^[^\0]*/$cond/;
400 $i = _find_subline($i) if ($i =~ /\D/);
401 $s->output("Subroutine not found.\n") unless $i;
403 if ($DB::dbline[$i] == 0) {
404 $s->output("Line $i not breakable.\n");
407 $DB::dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
415 $name = "${DB::package}\:\:" . $name if $name !~ /::/;
416 $name = "main" . $name if substr($name,0,2) eq "::";
417 my($fname, $from, $to) = ($DB::sub{$name} =~ /^(.*):(\d+)-(\d+)$/);
419 local *DB::dbline = "::_<$fname";
420 ++$from while $DB::dbline[$from] == 0 && $from < $to;
432 $i = _find_subline($i) if ($i =~ /\D/);
433 $s->output("Subroutine not found.\n") unless $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};
443 for ($i = 1; $i <= $#DB::dbline ; $i++) {
444 if (defined $DB::dbline{$i}) {
445 $DB::dbline{$i} =~ s/^[^\0]+//;
446 if ($DB::dbline{$i} =~ s/^\0?$//) {
447 delete $DB::dbline{$i};
458 $i = _find_subline($i) if ($i =~ /\D/);
459 $s->output("Subroutine not found.\n") unless $i;
461 if ($DB::dbline[$i] == 0) {
462 $s->output("Line $i not actionable.\n");
465 $DB::dbline{$i} =~ s/\0[^\0]*//;
466 $DB::dbline{$i} .= "\0" . $act;
477 $i = _find_subline($i) if ($i =~ /\D/);
478 $s->output("Subroutine not found.\n") unless $i;
479 if ($i && $DB::dbline[$i] != 0) {
480 $DB::dbline{$i} =~ s/\0[^\0]*//;
481 delete $DB::dbline{$i} if $DB::dbline{$i} =~ s/^\0?$//;
486 for ($i = 1; $i <= $#DB::dbline ; $i++) {
487 if (defined $DB::dbline{$i}) {
488 $DB::dbline{$i} =~ s/\0[^\0]*//;
489 delete $DB::dbline{$i} if $DB::dbline{$i} =~ s/^\0?$//;
496 my ($client, $val) = @_;
497 return defined($val) ? $preeval->{$client} = $val : $preeval->{$client};
501 my ($client, $val) = @_;
502 return defined($val) ? $posteval->{$client} = $val : $posteval->{$client};
506 # "pure virtual" methods
509 # client-specific pre/post-stop actions.
513 # client complete startup
518 push @skippkg, @_ if @_;
522 my ($client, $val) = @_;
524 $running = 2; # hand over to DB() to evaluate in its context
525 $ineval->{$client} = $val;
527 return $ineval->{$client};
546 for (@clients) { $_->init }
548 $SIG{'INT'} = \&DB::catch;
550 # disable this if stepping through END blocks is desired
551 # (looks scary and deconstructivist with Swat)
559 DB - programmatic interface to the Perl debugging API (draft, subject to
568 # these (inherited) methods can be called by the client
570 CLIENT->register() # register a client package name
571 CLIENT->done() # de-register from the debugging API
572 CLIENT->skippkg('hide::hide') # ask DB not to stop in this package
573 CLIENT->cont([WHERE]) # run some more (until BREAK or another breakpt)
574 CLIENT->step() # single step
575 CLIENT->next() # step over
576 CLIENT->ret() # return from current subroutine
577 CLIENT->backtrace() # return the call stack description
578 CLIENT->ready() # call when client setup is done
579 CLIENT->trace_toggle() # toggle subroutine call trace mode
580 CLIENT->subs([SUBS]) # return subroutine information
581 CLIENT->files() # return list of all files known to DB
582 CLIENT->lines() # return lines in currently loaded file
583 CLIENT->loadfile(FILE,LINE) # load a file and let other clients know
584 CLIENT->lineevents() # return info on lines with actions
585 CLIENT->set_break([WHERE],[COND])
586 CLIENT->set_tbreak([WHERE])
587 CLIENT->clr_breaks([LIST])
588 CLIENT->set_action(WHERE,ACTION)
589 CLIENT->clr_actions([LIST])
590 CLIENT->evalcode(STRING) # eval STRING in executing code's context
591 CLIENT->prestop([STRING]) # execute in code context before stopping
592 CLIENT->poststop([STRING])# execute in code context before resuming
594 # These methods will be called at the appropriate times.
595 # Stub versions provided do nothing.
596 # None of these can block.
598 CLIENT->init() # called when debug API inits itself
599 CLIENT->stop(FILE,LINE) # when execution stops
600 CLIENT->idle() # while stopped (can be a client event loop)
601 CLIENT->cleanup() # just before exit
602 CLIENT->output(LIST) # called to print any output that API must show
606 Perl debug information is frequently required not just by debuggers,
607 but also by modules that need some "special" information to do their
608 job properly, like profilers.
610 This module abstracts and provides all of the hooks into Perl internal
611 debugging functionality, so that various implementations of Perl debuggers
612 (or packages that want to simply get at the "privileged" debugging data)
613 can all benefit from the development of this common code. Currently used
614 by Swat, the perl/Tk GUI debugger.
616 Note that multiple "front-ends" can latch into this debugging API
617 simultaneously. This is intended to facilitate things like
618 debugging with a command line and GUI at the same time, debugging
619 debuggers etc. [Sounds nice, but this needs some serious support -- GSAR]
621 In particular, this API does B<not> provide the following functions:
635 command alias management
639 user interface (tty or graphical)
643 These are intended to be services performed by the clients of this API.
645 This module attempts to be squeaky clean w.r.t C<use strict;> and when
646 warnings are enabled.
649 =head2 Global Variables
651 The following "public" global names can be read by clients of this API.
652 Beware that these should be considered "readonly".
658 Name of current executing subroutine.
662 The keys of this hash are the names of all the known subroutines. Each value
663 is an encoded string that has the sprintf(3) format
664 C<("%s:%d-%d", filename, fromline, toline)>.
668 Single-step flag. Will be true if the API will stop at the next statement.
672 Signal flag. Will be set to a true value if a signal was caught. Clients may
673 check for this flag to abort time-consuming operations.
677 This flag is set to true if the API is tracing through subroutine calls.
681 Contains the arguments of current subroutine, or the C<@ARGV> array if in the
686 List of lines in currently loaded file.
690 Actions in current file (keys are line numbers). The values are strings that
691 have the sprintf(3) format C<("%s\000%s", breakcondition, actioncode)>.
695 Package namespace of currently executing code.
699 Currently loaded filename.
703 Fully qualified name of currently executing subroutine.
707 Line number that will be executed next.
713 The following are methods in the DB base class. A client must
714 access these methods by inheritance (*not* by calling them directly),
715 since the API keeps track of clients through the inheritance
720 =item CLIENT->register()
722 register a client object/package
724 =item CLIENT->evalcode(STRING)
726 eval STRING in executing code context
728 =item CLIENT->skippkg('D::hide')
730 ask DB not to stop in these packages
734 run some more (until a breakpt is reached)
746 de-register from the debugging API
750 =head2 Client Callback Methods
752 The following "virtual" methods can be defined by the client. They will
753 be called by the API at appropriate points. Note that unless specified
754 otherwise, the debug API only defines empty, non-functional default versions
761 Called after debug API inits itself.
763 =item CLIENT->prestop([STRING])
765 Usually inherited from DB package. If no arguments are passed,
766 returns the prestop action string.
770 Called when execution stops (w/ args file, line).
774 Called while stopped (can be a client event loop).
776 =item CLIENT->poststop([STRING])
778 Usually inherited from DB package. If no arguments are passed,
779 returns the poststop action string.
781 =item CLIENT->evalcode(STRING)
783 Usually inherited from DB package. Ask for a STRING to be C<eval>-ed
784 in executing code context.
786 =item CLIENT->cleanup()
788 Called just before exit.
790 =item CLIENT->output(LIST)
792 Called when API must show a message (warnings, errors etc.).
800 The interface defined by this module is missing some of the later additions
801 to perl's debugging functionality. As such, this interface should be considered
802 highly experimental and subject to change.
806 Gurusamy Sarathy gsar@activestate.com
808 This code heavily adapted from an early version of perl5db.pl attributable
809 to Larry Wall and the Perl Porters.