summaryrefslogtreecommitdiffstats
path: root/contrib/perl5/lib/DB.pm
diff options
context:
space:
mode:
Diffstat (limited to 'contrib/perl5/lib/DB.pm')
-rw-r--r--contrib/perl5/lib/DB.pm802
1 files changed, 0 insertions, 802 deletions
diff --git a/contrib/perl5/lib/DB.pm b/contrib/perl5/lib/DB.pm
deleted file mode 100644
index 711acc0..0000000
--- a/contrib/perl5/lib/DB.pm
+++ /dev/null
@@ -1,802 +0,0 @@
-#
-# 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@activestate.com
-
-This code heavily adapted from an early version of perl5db.pl attributable
-to Larry Wall and the Perl Porters.
-
-=cut
OpenPOWER on IntegriCloud