#
# 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.01';
# 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;
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";
# we need to check for pseudofiles on Mac OS (these are files
# not attached to a filename, but instead stored in Dev:Pseudo)
# since this is done late, $DB::filename will be "wrong" after
# skippkg
if ($^O eq 'MacOS' && $#DB::dbline < 0) {
=1= |