[perl5.git] / lib / DB.pm

#
# 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 (fully qualified name)
  $DB::lineno = '';     # current line number

  $DB::VERSION = $DB::VERSION = '1.08';

  # initialize private globals to avoid warnings

  $running = 1;         # are we running, or are we stopped?
  @stack = (0);
  @clients = ();
  $deep = 1000;
  $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;
  if ($DB::sub eq 'DESTROY' or substr($DB::sub, -9) eq '::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.]+$/;
      require 'meta_notation.pm';
      $_ = _meta_notation($_) if /[[:^print:]]/a;
    }
    $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) {
    local *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

=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 breakpointt)
    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
                            # the 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@activestate.com

This code heavily adapted from an early version of perl5db.pl attributable
to Larry Wall and the Perl Porters.

=cut
Commit	Line	Data
43d8869b GS	1	#
	2	# Documentation is at the __END__
	3	#
	4
	5	package DB;
	6
	7	# "private" globals
	8
	9	my ($running, $ready, $deep, $usrctxt, $evalarg,
	10	@stack, @saved, @skippkg, @clients);
	11	my $preeval = {};
	12	my $posteval = {};
	13	my $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
	22	BEGIN {
	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
c0b43560	41	$DB::subname = ''; # currently executing sub (fully qualified name)
43d8869b GS	42	$DB::lineno = ''; # current line number
43d8869b GS	43
4b6af431	44	$DB::VERSION = $DB::VERSION = '1.08';
43d8869b GS	45
	46	# initialize private globals to avoid warnings
	47
	48	$running = 1; # are we running, or are we stopped?
	49	@stack = (0);
	50	@clients = ();
7aeefbb3	51	$deep = 1000;
43d8869b GS	52	$ready = 0;
	53	@saved = ();
	54	@skippkg = ();
	55	$usrctxt = '';
	56	$evalarg = '';
	57	}
	58
	59	####
	60	# entry point for all subroutine calls
	61	#
	62	sub sub {
	63	push(@stack, $DB::single);
	64	$DB::single &= 1;
	65	$DB::single \|= 4 if $#stack == $deep;
1e006cbb	66	if ($DB::sub eq 'DESTROY' or substr($DB::sub, -9) eq '::DESTROY' or not defined wantarray) {
43d8869b GS	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	#
	86	sub 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";
aa057b67	95
43d8869b GS	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	#
	145	sub 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
	155	use strict; # this can run only after DB() and sub() are defined
	156
	157	sub save {
	158	@saved = ($@, $!, $,, $/, $\, $^W);
	159	$, = ""; $/ = "\n"; $\ = ""; $^W = 0;
160	}
161
162	sub 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
174	sub register {
175	my $s = shift;
176	$s = _clientname($s) if ref($s);
177	push @clients, $s;
178	}
179
180	sub 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
189	sub _clientname {
190	my $name = shift;
191	"$name" =~ /^(.+)=[A-Z]+\(.+\)$/;
192	return $1;
193	}
194
195	sub next {
196	my $s = shift;
197	$DB::single = 2;
198	$running = 1;
199	}
200
201	sub step {
202	my $s = shift;
203	$DB::single = 1;
204	$running = 1;
205	}
206
207	sub 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	#
223	sub 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	#
237	sub 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.]+$/;
4b6af431 KW	247	require 'meta_notation.pm';
4b6af431 KW	248	$_ = _meta_notation($_) if /[[:^print:]]/a;
43d8869b GS	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	}
1f874cb6	261	$f = "file '$f'" unless $f eq '-e';
43d8869b GS	262	push @ret, "$w&$s$a from $f line $l";
	263	last if $DB::signal;
	264	}
	265	return @ret;
	266	}
	267
	268	sub _outputall {
	269	my $c;
	270	for $c (@clients) {
	271	$c->output(@_);
	272	}
	273	}
	274
	275	sub 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	#
	285	sub 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	#
	304	sub 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	#
	314	sub 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	#
	324	sub lines {
	325	my $s = shift;
326	return \@DB::dbline;
327	}
328
329	####
330	# loadfile($file, $line)
331	#
332	sub 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
355	sub 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
369	sub 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
387	sub 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
402	sub _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) {
c95f170b	409	local *DB::dbline = "::_<$fname";
43d8869b GS	410	++$from while $DB::dbline[$from] == 0 && $from < $to;
	411	return $from;
	412	}
	413	return undef;
	414	}
	415
	416	sub 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
	444	sub 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
	461	sub 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
485	sub prestop {
486	my ($client, $val) = @_;
487	return defined($val) ? $preeval->{$client} = $val : $preeval->{$client};
488	}
489
490	sub 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.
500	sub cprestop {}
501	sub cpoststop {}
502
503	# client complete startup
504	sub awaken {}
505
506	sub skippkg {
507	my $s = shift;
508	push @skippkg, @_ if @_;
509	}
510
511	sub 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
520	sub ready {
521	my $s = shift;
522	return $ready = 1;
523	}
524
525	# stubs
526
527	sub init {}
528	sub stop {}
529	sub idle {}
530	sub cleanup {}
531	sub output {}
532
533	#
534	# client init
535	#
536	for (@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)
542	END { $ready = 0 }
543
544	1;
545	__END__
546
547	=head1 NAME
548
538c5554	549	DB - programmatic interface to the Perl debugging API
43d8869b GS	550
	551	=head1 SYNOPSIS
	552
	553	package CLIENT;
	554	use DB;
	555	@ISA = qw(DB);
3cb6de81	556
43d8869b	557	# these (inherited) methods can be called by the client
3cb6de81	558
43d8869b GS	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
555bd962 BG	562	CLIENT->cont([WHERE]) # run some more (until BREAK or
555bd962 BG	563	# another breakpointt)
43d8869b GS	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.
3cb6de81	587
43d8869b GS	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
555bd962 BG	592	CLIENT->output(LIST) # called to print any output that
555bd962 BG	593	# the API must show
43d8869b GS	594
	595	=head1 DESCRIPTION
	596
	597	Perl debug information is frequently required not just by debuggers,
	598	but also by modules that need some "special" information to do their
	599	job properly, like profilers.
	600
	601	This module abstracts and provides all of the hooks into Perl internal
	602	debugging functionality, so that various implementations of Perl debuggers
	603	(or packages that want to simply get at the "privileged" debugging data)
	604	can all benefit from the development of this common code. Currently used
	605	by Swat, the perl/Tk GUI debugger.
	606
	607	Note that multiple "front-ends" can latch into this debugging API
	608	simultaneously. This is intended to facilitate things like
	609	debugging with a command line and GUI at the same time, debugging
	610	debuggers etc. [Sounds nice, but this needs some serious support -- GSAR]
	611
	612	In particular, this API does B<not> provide the following functions:
	613
	614	=over 4
	615
	616	=item *
	617
	618	data display
	619
	620	=item *
	621
	622	command processing
	623
	624	=item *
	625
	626	command alias management
	627
	628	=item *
	629
	630	user interface (tty or graphical)
	631
	632	=back
	633
	634	These are intended to be services performed by the clients of this API.
	635
	636	This module attempts to be squeaky clean w.r.t C<use strict;> and when
	637	warnings are enabled.
	638
	639
	640	=head2 Global Variables
	641
	642	The following "public" global names can be read by clients of this API.
	643	Beware that these should be considered "readonly".
	644
	645	=over 8
	646
	647	=item $DB::sub
	648
	649	Name of current executing subroutine.
	650
	651	=item %DB::sub
	652
	653	The keys of this hash are the names of all the known subroutines. Each value
	654	is an encoded string that has the sprintf(3) format
	655	C<("%s:%d-%d", filename, fromline, toline)>.
	656
	657	=item $DB::single
658
659	Single-step flag. Will be true if the API will stop at the next statement.
660
661	=item $DB::signal
662
663	Signal flag. Will be set to a true value if a signal was caught. Clients may
664	check for this flag to abort time-consuming operations.
665
666	=item $DB::trace
667
668	This flag is set to true if the API is tracing through subroutine calls.
669
670	=item @DB::args
671
672	Contains the arguments of current subroutine, or the C<@ARGV> array if in the
673	toplevel context.
674
675	=item @DB::dbline
676
677	List of lines in currently loaded file.
678
679	=item %DB::dbline
680
681	Actions in current file (keys are line numbers). The values are strings that
682	have the sprintf(3) format C<("%s\000%s", breakcondition, actioncode)>.
683
684	=item $DB::package
685
686	Package namespace of currently executing code.
687
688	=item $DB::filename
689
690	Currently loaded filename.
691
692	=item $DB::subname
693
694	Fully qualified name of currently executing subroutine.
695
696	=item $DB::lineno
697
698	Line number that will be executed next.
699
700	=back
701
702	=head2 API Methods
703
704	The following are methods in the DB base class. A client must
705	access these methods by inheritance (not by calling them directly),
706	since the API keeps track of clients through the inheritance
707	mechanism.
708
709	=over 8
710
711	=item CLIENT->register()
712
713	register a client object/package
714
715	=item CLIENT->evalcode(STRING)
716
717	eval STRING in executing code context
718
719	=item CLIENT->skippkg('D::hide')
720
721	ask DB not to stop in these packages
722
723	=item CLIENT->run()
724
725	run some more (until a breakpt is reached)
726
727	=item CLIENT->step()
728
729	single step
730
731	=item CLIENT->next()
732
733	step over
734
735	=item CLIENT->done()
736
737	de-register from the debugging API
738
739	=back
740
741	=head2 Client Callback Methods
742
743	The following "virtual" methods can be defined by the client. They will
744	be called by the API at appropriate points. Note that unless specified
745	otherwise, the debug API only defines empty, non-functional default versions
746	of these methods.
747
748	=over 8
749
750	=item CLIENT->init()
751
752	Called after debug API inits itself.
753
754	=item CLIENT->prestop([STRING])
755
756	Usually inherited from DB package. If no arguments are passed,
757	returns the prestop action string.
758
759	=item CLIENT->stop()
760
761	Called when execution stops (w/ args file, line).
762
763	=item CLIENT->idle()
764
765	Called while stopped (can be a client event loop).
766
767	=item CLIENT->poststop([STRING])
768
769	Usually inherited from DB package. If no arguments are passed,
770	returns the poststop action string.
771
772	=item CLIENT->evalcode(STRING)
773
774	Usually inherited from DB package. Ask for a STRING to be C<eval>-ed
775	in executing code context.
776
777	=item CLIENT->cleanup()
778
779	Called just before exit.
780
781	=item CLIENT->output(LIST)
782
783	Called when API must show a message (warnings, errors etc.).
784
785
786	=back
787
788
789	=head1 BUGS
790
791	The interface defined by this module is missing some of the later additions
792	to perl's debugging functionality. As such, this interface should be considered
793	highly experimental and subject to change.
794
795	=head1 AUTHOR
796
6e238990	797	Gurusamy Sarathy gsar@activestate.com
43d8869b GS	798
	799	This code heavily adapted from an early version of perl5db.pl attributable
	800	to Larry Wall and the Perl Porters.
	801
	802	=cut