From: Gurusamy Sarathy Date: Sun, 7 Feb 1999 10:20:35 +0000 (+0000) Subject: add draft debugging API implementation X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=43d8869b61f38e2bcba70315c30436a0b25ba2d5;p=p5sagit%2Fp5-mst-13.2.git add draft debugging API implementation p4raw-id: //depot/perl@2820 --- diff --git a/MANIFEST b/MANIFEST index fecc311..8e114a2 100644 --- a/MANIFEST +++ b/MANIFEST @@ -512,6 +512,7 @@ lib/CPAN/Nox.pm Runs CPAN while avoiding compiled extensions lib/Carp.pm Error message base class lib/Class/Struct.pm Declare struct-like datatypes as Perl classes lib/Cwd.pm Various cwd routines (getcwd, fastcwd, chdir) +lib/DB.pm Debugger API (draft) lib/Devel/SelfStubber.pm Generate stubs for SelfLoader.pm lib/DirHandle.pm like FileHandle only for directories lib/Dumpvalue.pm Screen dump of perl values diff --git a/lib/DB.pm b/lib/DB.pm new file mode 100644 index 0000000..1395c81 --- /dev/null +++ b/lib/DB.pm @@ -0,0 +1,802 @@ +# +# Documentation is at the __END__ +# + +package DB; + +# "private" globals + +my ($running, $ready, $deep, $usrctxt, $evalarg, + @stack, @saved, @skippkg, @clients); +my $preeval = {}; +my $posteval = {}; +my $ineval = {}; + +#### +# +# Globals - must be defined at startup so that clients can refer to +# them right after a C +# +#### + +BEGIN { + + # these are hardcoded in perl source (some are magical) + + $DB::sub = ''; # name of current subroutine + %DB::sub = (); # "filename:fromline-toline" for every known sub + $DB::single = 0; # single-step flag (set it to 1 to enable stops in BEGIN/use) + $DB::signal = 0; # signal flag (will cause a stop at the next line) + $DB::trace = 0; # are we tracing through subroutine calls? + @DB::args = (); # arguments of current subroutine or @ARGV array + @DB::dbline = (); # list of lines in currently loaded file + %DB::dbline = (); # actions in current file (keyed by line number) + @DB::ret = (); # return value of last sub executed in list context + $DB::ret = ''; # return value of last sub executed in scalar context + + # other "public" globals + + $DB::package = ''; # current package space + $DB::filename = ''; # current filename + $DB::subname = ''; # currently executing sub (fullly qualified name) + $DB::lineno = ''; # current line number + + $DB::VERSION = $DB::VERSION = '1.0'; + + # initialize private globals to avoid warnings + + $running = 1; # are we running, or are we stopped? + @stack = (0); + @clients = (); + $deep = 100; + $ready = 0; + @saved = (); + @skippkg = (); + $usrctxt = ''; + $evalarg = ''; +} + +#### +# entry point for all subroutine calls +# +sub sub { + push(@stack, $DB::single); + $DB::single &= 1; + $DB::single |= 4 if $#stack == $deep; +# print $DB::sub, "\n"; + if ($DB::sub =~ /(?:^|::)DESTROY$/ or not defined wantarray) { + &$DB::sub; + $DB::single |= pop(@stack); + $DB::ret = undef; + } + elsif (wantarray) { + @DB::ret = &$DB::sub; + $DB::single |= pop(@stack); + @DB::ret; + } + else { + $DB::ret = &$DB::sub; + $DB::single |= pop(@stack); + $DB::ret; + } +} + +#### +# this is called by perl for every statement +# +sub DB { + return unless $ready; + &save; + ($DB::package, $DB::filename, $DB::lineno) = caller; + + return if @skippkg and grep { $_ eq $DB::package } @skippkg; + + $usrctxt = "package $DB::package;"; # this won't let them modify, alas + local(*DB::dbline) = "::_<$DB::filename"; + my ($stop, $action); + if (($stop,$action) = split(/\0/,$DB::dbline{$DB::lineno})) { + if ($stop eq '1') { + $DB::signal |= 1; + } + else { + $stop = 0 unless $stop; # avoid un_init warning + $evalarg = "\$DB::signal |= do { $stop; }"; &eval; + $DB::dbline{$DB::lineno} =~ s/;9($|\0)/$1/; # clear any temp breakpt + } + } + if ($DB::single || $DB::trace || $DB::signal) { + $DB::subname = ($DB::sub =~ /\'|::/) ? $DB::sub : "${DB::package}::$DB::sub"; #'; + DB->loadfile($DB::filename, $DB::lineno); + } + $evalarg = $action, &eval if $action; + if ($DB::single || $DB::signal) { + _outputall($#stack . " levels deep in subroutine calls.\n") if $DB::single & 4; + $DB::single = 0; + $DB::signal = 0; + $running = 0; + + &eval if ($evalarg = DB->prestop); + my $c; + for $c (@clients) { + # perform any client-specific prestop actions + &eval if ($evalarg = $c->cprestop); + + # Now sit in an event loop until something sets $running + do { + $c->idle; # call client event loop; must not block + if ($running == 2) { # client wants something eval-ed + &eval if ($evalarg = $c->evalcode); + $running = 0; + } + } until $running; + + # perform any client-specific poststop actions + &eval if ($evalarg = $c->cpoststop); + } + &eval if ($evalarg = DB->poststop); + } + ($@, $!, $,, $/, $\, $^W) = @saved; + (); +} + +#### +# this takes its argument via $evalarg to preserve current @_ +# +sub eval { + ($@, $!, $,, $/, $\, $^W) = @saved; + eval "$usrctxt $evalarg; &DB::save"; + _outputall($@) if $@; +} + +############################################################################### +# no compile-time subroutine call allowed before this point # +############################################################################### + +use strict; # this can run only after DB() and sub() are defined + +sub save { + @saved = ($@, $!, $,, $/, $\, $^W); + $, = ""; $/ = "\n"; $\ = ""; $^W = 0; +} + +sub catch { + for (@clients) { $_->awaken; } + $DB::signal = 1; + $ready = 1; +} + +#### +# +# Client callable (read inheritable) methods defined after this point +# +#### + +sub register { + my $s = shift; + $s = _clientname($s) if ref($s); + push @clients, $s; +} + +sub done { + my $s = shift; + $s = _clientname($s) if ref($s); + @clients = grep {$_ ne $s} @clients; + $s->cleanup; +# $running = 3 unless @clients; + exit(0) unless @clients; +} + +sub _clientname { + my $name = shift; + "$name" =~ /^(.+)=[A-Z]+\(.+\)$/; + return $1; +} + +sub next { + my $s = shift; + $DB::single = 2; + $running = 1; +} + +sub step { + my $s = shift; + $DB::single = 1; + $running = 1; +} + +sub cont { + my $s = shift; + my $i = shift; + $s->set_tbreak($i) if $i; + for ($i = 0; $i <= $#stack;) { + $stack[$i++] &= ~1; + } + $DB::single = 0; + $running = 1; +} + +#### +# XXX caller must experimentally determine $i (since it depends +# on how many client call frames are between this call and the DB call). +# Such is life. +# +sub ret { + my $s = shift; + my $i = shift; # how many levels to get to DB sub + $i = 0 unless defined $i; + $stack[$#stack-$i] |= 1; + $DB::single = 0; + $running = 1; +} + +#### +# XXX caller must experimentally determine $start (since it depends +# on how many client call frames are between this call and the DB call). +# Such is life. +# +sub backtrace { + my $self = shift; + my $start = shift; + my($p,$f,$l,$s,$h,$w,$e,$r,$a, @a, @ret,$i); + $start = 1 unless $start; + for ($i = $start; ($p,$f,$l,$s,$h,$w,$e,$r) = caller($i); $i++) { + @a = @DB::args; + for (@a) { + s/'/\\'/g; + s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/; + s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg; + s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg; + } + $w = $w ? '@ = ' : '$ = '; + $a = $h ? '(' . join(', ', @a) . ')' : ''; + $e =~ s/\n\s*\;\s*\Z// if $e; + $e =~ s/[\\\']/\\$1/g if $e; + if ($r) { + $s = "require '$e'"; + } elsif (defined $r) { + $s = "eval '$e'"; + } elsif ($s eq '(eval)') { + $s = "eval {...}"; + } + $f = "file `$f'" unless $f eq '-e'; + push @ret, "$w&$s$a from $f line $l"; + last if $DB::signal; + } + return @ret; +} + +sub _outputall { + my $c; + for $c (@clients) { + $c->output(@_); + } +} + +sub trace_toggle { + my $s = shift; + $DB::trace = !$DB::trace; +} + + +#### +# without args: returns all defined subroutine names +# with subname args: returns a listref [file, start, end] +# +sub subs { + my $s = shift; + if (@_) { + my(@ret) = (); + while (@_) { + my $name = shift; + push @ret, [$DB::sub{$name} =~ /^(.*)\:(\d+)-(\d+)$/] + if exists $DB::sub{$name}; + } + return @ret; + } + return keys %DB::sub; +} + +#### +# first argument is a filename whose subs will be returned +# if a filename is not supplied, all subs in the current +# filename are returned. +# +sub filesubs { + my $s = shift; + my $fname = shift; + $fname = $DB::filename unless $fname; + return grep { $DB::sub{$_} =~ /^$fname/ } keys %DB::sub; +} + +#### +# returns a list of all filenames that DB knows about +# +sub files { + my $s = shift; + my(@f) = grep(m|^_<|, keys %main::); + return map { substr($_,2) } @f; +} + +#### +# returns reference to an array holding the lines in currently +# loaded file +# +sub lines { + my $s = shift; + return \@DB::dbline; +} + +#### +# loadfile($file, $line) +# +sub loadfile { + my $s = shift; + my($file, $line) = @_; + if (!defined $main::{'_<' . $file}) { + my $try; + if (($try) = grep(m|^_<.*$file|, keys %main::)) { + $file = substr($try,2); + } + } + if (defined($main::{'_<' . $file})) { + my $c; +# _outputall("Loading file $file.."); + *DB::dbline = "::_<$file"; + $DB::filename = $file; + for $c (@clients) { +# print "2 ", $file, '|', $line, "\n"; + $c->showfile($file, $line); + } + return $file; + } + return undef; +} + +sub lineevents { + my $s = shift; + my $fname = shift; + my(%ret) = (); + my $i; + $fname = $DB::filename unless $fname; + local(*DB::dbline) = "::_<$fname"; + for ($i = 1; $i <= $#DB::dbline; $i++) { + $ret{$i} = [$DB::dbline[$i], split(/\0/, $DB::dbline{$i})] + if defined $DB::dbline{$i}; + } + return %ret; +} + +sub set_break { + my $s = shift; + my $i = shift; + my $cond = shift; + $i ||= $DB::lineno; + $cond ||= '1'; + $i = _find_subline($i) if ($i =~ /\D/); + $s->output("Subroutine not found.\n") unless $i; + if ($i) { + if ($DB::dbline[$i] == 0) { + $s->output("Line $i not breakable.\n"); + } + else { + $DB::dbline{$i} =~ s/^[^\0]*/$cond/; + } + } +} + +sub set_tbreak { + my $s = shift; + my $i = shift; + $i = _find_subline($i) if ($i =~ /\D/); + $s->output("Subroutine not found.\n") unless $i; + if ($i) { + if ($DB::dbline[$i] == 0) { + $s->output("Line $i not breakable.\n"); + } + else { + $DB::dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p. + } + } +} + +sub _find_subline { + my $name = shift; + $name =~ s/\'/::/; + $name = "${DB::package}\:\:" . $name if $name !~ /::/; + $name = "main" . $name if substr($name,0,2) eq "::"; + my($fname, $from, $to) = ($DB::sub{$name} =~ /^(.*):(\d+)-(\d+)$/); + if ($from) { + # XXX this needs local()-ization of some sort + *DB::dbline = "::_<$fname"; + ++$from while $DB::dbline[$from] == 0 && $from < $to; + return $from; + } + return undef; +} + +sub clr_breaks { + my $s = shift; + my $i; + if (@_) { + while (@_) { + $i = shift; + $i = _find_subline($i) if ($i =~ /\D/); + $s->output("Subroutine not found.\n") unless $i; + if (defined $DB::dbline{$i}) { + $DB::dbline{$i} =~ s/^[^\0]+//; + if ($DB::dbline{$i} =~ s/^\0?$//) { + delete $DB::dbline{$i}; + } + } + } + } + else { + for ($i = 1; $i <= $#DB::dbline ; $i++) { + if (defined $DB::dbline{$i}) { + $DB::dbline{$i} =~ s/^[^\0]+//; + if ($DB::dbline{$i} =~ s/^\0?$//) { + delete $DB::dbline{$i}; + } + } + } + } +} + +sub set_action { + my $s = shift; + my $i = shift; + my $act = shift; + $i = _find_subline($i) if ($i =~ /\D/); + $s->output("Subroutine not found.\n") unless $i; + if ($i) { + if ($DB::dbline[$i] == 0) { + $s->output("Line $i not actionable.\n"); + } + else { + $DB::dbline{$i} =~ s/\0[^\0]*//; + $DB::dbline{$i} .= "\0" . $act; + } + } +} + +sub clr_actions { + my $s = shift; + my $i; + if (@_) { + while (@_) { + my $i = shift; + $i = _find_subline($i) if ($i =~ /\D/); + $s->output("Subroutine not found.\n") unless $i; + if ($i && $DB::dbline[$i] != 0) { + $DB::dbline{$i} =~ s/\0[^\0]*//; + delete $DB::dbline{$i} if $DB::dbline{$i} =~ s/^\0?$//; + } + } + } + else { + for ($i = 1; $i <= $#DB::dbline ; $i++) { + if (defined $DB::dbline{$i}) { + $DB::dbline{$i} =~ s/\0[^\0]*//; + delete $DB::dbline{$i} if $DB::dbline{$i} =~ s/^\0?$//; + } + } + } +} + +sub prestop { + my ($client, $val) = @_; + return defined($val) ? $preeval->{$client} = $val : $preeval->{$client}; +} + +sub poststop { + my ($client, $val) = @_; + return defined($val) ? $posteval->{$client} = $val : $posteval->{$client}; +} + +# +# "pure virtual" methods +# + +# client-specific pre/post-stop actions. +sub cprestop {} +sub cpoststop {} + +# client complete startup +sub awaken {} + +sub skippkg { + my $s = shift; + push @skippkg, @_ if @_; +} + +sub evalcode { + my ($client, $val) = @_; + if (defined $val) { + $running = 2; # hand over to DB() to evaluate in its context + $ineval->{$client} = $val; + } + return $ineval->{$client}; +} + +sub ready { + my $s = shift; + return $ready = 1; +} + +# stubs + +sub init {} +sub stop {} +sub idle {} +sub cleanup {} +sub output {} + +# +# client init +# +for (@clients) { $_->init } + +$SIG{'INT'} = \&DB::catch; + +# disable this if stepping through END blocks is desired +# (looks scary and deconstructivist with Swat) +END { $ready = 0 } + +1; +__END__ + +=head1 NAME + +DB - programmatic interface to the Perl debugging API (draft, subject to +change) + +=head1 SYNOPSIS + + package CLIENT; + use DB; + @ISA = qw(DB); + + # these (inherited) methods can be called by the client + + CLIENT->register() # register a client package name + CLIENT->done() # de-register from the debugging API + CLIENT->skippkg('hide::hide') # ask DB not to stop in this package + CLIENT->cont([WHERE]) # run some more (until BREAK or another breakpt) + CLIENT->step() # single step + CLIENT->next() # step over + CLIENT->ret() # return from current subroutine + CLIENT->backtrace() # return the call stack description + CLIENT->ready() # call when client setup is done + CLIENT->trace_toggle() # toggle subroutine call trace mode + CLIENT->subs([SUBS]) # return subroutine information + CLIENT->files() # return list of all files known to DB + CLIENT->lines() # return lines in currently loaded file + CLIENT->loadfile(FILE,LINE) # load a file and let other clients know + CLIENT->lineevents() # return info on lines with actions + CLIENT->set_break([WHERE],[COND]) + CLIENT->set_tbreak([WHERE]) + CLIENT->clr_breaks([LIST]) + CLIENT->set_action(WHERE,ACTION) + CLIENT->clr_actions([LIST]) + CLIENT->evalcode(STRING) # eval STRING in executing code's context + CLIENT->prestop([STRING]) # execute in code context before stopping + CLIENT->poststop([STRING])# execute in code context before resuming + + # These methods will be called at the appropriate times. + # Stub versions provided do nothing. + # None of these can block. + + CLIENT->init() # called when debug API inits itself + CLIENT->stop(FILE,LINE) # when execution stops + CLIENT->idle() # while stopped (can be a client event loop) + CLIENT->cleanup() # just before exit + CLIENT->output(LIST) # called to print any output that API must show + +=head1 DESCRIPTION + +Perl debug information is frequently required not just by debuggers, +but also by modules that need some "special" information to do their +job properly, like profilers. + +This module abstracts and provides all of the hooks into Perl internal +debugging functionality, so that various implementations of Perl debuggers +(or packages that want to simply get at the "privileged" debugging data) +can all benefit from the development of this common code. Currently used +by Swat, the perl/Tk GUI debugger. + +Note that multiple "front-ends" can latch into this debugging API +simultaneously. This is intended to facilitate things like +debugging with a command line and GUI at the same time, debugging +debuggers etc. [Sounds nice, but this needs some serious support -- GSAR] + +In particular, this API does B provide the following functions: + +=over 4 + +=item * + +data display + +=item * + +command processing + +=item * + +command alias management + +=item * + +user interface (tty or graphical) + +=back + +These are intended to be services performed by the clients of this API. + +This module attempts to be squeaky clean w.r.t C and when +warnings are enabled. + + +=head2 Global Variables + +The following "public" global names can be read by clients of this API. +Beware that these should be considered "readonly". + +=over 8 + +=item $DB::sub + +Name of current executing subroutine. + +=item %DB::sub + +The keys of this hash are the names of all the known subroutines. Each value +is an encoded string that has the sprintf(3) format +C<("%s:%d-%d", filename, fromline, toline)>. + +=item $DB::single + +Single-step flag. Will be true if the API will stop at the next statement. + +=item $DB::signal + +Signal flag. Will be set to a true value if a signal was caught. Clients may +check for this flag to abort time-consuming operations. + +=item $DB::trace + +This flag is set to true if the API is tracing through subroutine calls. + +=item @DB::args + +Contains the arguments of current subroutine, or the C<@ARGV> array if in the +toplevel context. + +=item @DB::dbline + +List of lines in currently loaded file. + +=item %DB::dbline + +Actions in current file (keys are line numbers). The values are strings that +have the sprintf(3) format C<("%s\000%s", breakcondition, actioncode)>. + +=item $DB::package + +Package namespace of currently executing code. + +=item $DB::filename + +Currently loaded filename. + +=item $DB::subname + +Fully qualified name of currently executing subroutine. + +=item $DB::lineno + +Line number that will be executed next. + +=back + +=head2 API Methods + +The following are methods in the DB base class. A client must +access these methods by inheritance (*not* by calling them directly), +since the API keeps track of clients through the inheritance +mechanism. + +=over 8 + +=item CLIENT->register() + +register a client object/package + +=item CLIENT->evalcode(STRING) + +eval STRING in executing code context + +=item CLIENT->skippkg('D::hide') + +ask DB not to stop in these packages + +=item CLIENT->run() + +run some more (until a breakpt is reached) + +=item CLIENT->step() + +single step + +=item CLIENT->next() + +step over + +=item CLIENT->done() + +de-register from the debugging API + +=back + +=head2 Client Callback Methods + +The following "virtual" methods can be defined by the client. They will +be called by the API at appropriate points. Note that unless specified +otherwise, the debug API only defines empty, non-functional default versions +of these methods. + +=over 8 + +=item CLIENT->init() + +Called after debug API inits itself. + +=item CLIENT->prestop([STRING]) + +Usually inherited from DB package. If no arguments are passed, +returns the prestop action string. + +=item CLIENT->stop() + +Called when execution stops (w/ args file, line). + +=item CLIENT->idle() + +Called while stopped (can be a client event loop). + +=item CLIENT->poststop([STRING]) + +Usually inherited from DB package. If no arguments are passed, +returns the poststop action string. + +=item CLIENT->evalcode(STRING) + +Usually inherited from DB package. Ask for a STRING to be C-ed +in executing code context. + +=item CLIENT->cleanup() + +Called just before exit. + +=item CLIENT->output(LIST) + +Called when API must show a message (warnings, errors etc.). + + +=back + + +=head1 BUGS + +The interface defined by this module is missing some of the later additions +to perl's debugging functionality. As such, this interface should be considered +highly experimental and subject to change. + +=head1 AUTHOR + +Gurusamy Sarathy gsar@umich.edu + +This code heavily adapted from an early version of perl5db.pl attributable +to Larry Wall and the Perl Porters. + +=cut