add draft debugging API implementation

p4raw-id: //depot/perl@2820

1 files changed, 802 insertions, 0 deletions

diff --git a/lib/DB.pm b/lib/DB.pm
new file mode 100644
index 0000000000..1395c81b5a
--- /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<require DB;>
+#
+####
+
+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<not> 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<use strict;> 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<eval>-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