home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
BURKS 2
/
BURKS_AUG97.ISO
/
SLAKWARE
/
D12
/
PERL1.TGZ
/
perl1.tar
/
usr
/
lib
/
perl5
/
perl5db.pl
< prev
next >
Wrap
Perl Script
|
1996-06-28
|
42KB
|
1,447 lines
package DB;
# Debugger for Perl 5.00x; perl5db.pl patch level:
$header = 'perl5db.pl patch level 0.94';
# Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich)
# Latest version available: ftp://ftp.math.ohio-state.edu/pub/users/ilya/perl
# modified Perl debugger, to be run from Emacs in perldb-mode
# Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990
# Johan Vromans -- upgrade to 4.0 pl 10
# Ilya Zakharevich -- patches after 5.001 (and some before ;-)
#
# This file is automatically included if you do perl -d.
# It's probably not useful to include this yourself.
#
# Perl supplies the values for @line and %sub. It effectively inserts
# a &DB'DB(<linenum>); in front of every place that can have a
# breakpoint. Instead of a subroutine call it calls &DB::sub with
# $DB::sub being the called subroutine. It also inserts a BEGIN
# {require 'perl5db.pl'} before the first line.
#
# Note that no subroutine call is possible until &DB::sub is defined
# (for subroutines defined outside this file). In fact the same is
# true if $deep is not defined.
#
# $Log: perldb.pl,v $
#
# At start reads $rcfile that may set important options. This file
# may define a subroutine &afterinit that will be executed after the
# debugger is initialized.
#
# After $rcfile is read reads environment variable PERLDB_OPTS and parses
# it as a rest of `O ...' line in debugger prompt.
#
# The options that can be specified only at startup:
# [To set in $rcfile, call &parse_options("optionName=new_value").]
#
# TTY - the TTY to use for debugging i/o.
#
# noTTY - if set, goes in NonStop mode. On interrupt if TTY is not set
# uses the value of noTTY or "/tmp/perldbtty$$" to find TTY using
# Term::Rendezvous. Current variant is to have the name of TTY in this
# file.
#
# ReadLine - If false, dummy ReadLine is used, so you can debug
# ReadLine applications.
#
# NonStop - if true, no i/o is performed until interrupt.
#
# LineInfo - file or pipe to print line number info to. If it is a
# pipe, a short "emacs like" message is used.
#
# Example $rcfile: (delete leading hashes!)
#
# &parse_options("NonStop=1 LineInfo=db.out");
# sub afterinit { $trace = 1; }
#
# The script will run without human intervention, putting trace
# information into db.out. (If you interrupt it, you would better
# reset LineInfo to something "interactive"!)
#
# Needed for the statement after exec():
BEGIN { $ini_warn = $^W; $^W = 0 } # Switch compilation warnings off until another BEGIN.
local($^W) = 0; # Switch run-time warnings off during init.
warn ( # Do not ;-)
$dumpvar::hashDepth,
$dumpvar::arrayDepth,
$dumpvar::dumpDBFiles,
$dumpvar::dumpPackages,
$dumpvar::quoteHighBit,
$dumpvar::printUndef,
$dumpvar::globPrint,
$readline::Tk_toloop,
$dumpvar::usageOnly,
@ARGS,
$Carp::CarpLevel,
$panic,
$first_time,
) if 0;
# Command-line + PERLLIB:
@ini_INC = @INC;
# $prevwarn = $prevdie = $prevbus = $prevsegv = ''; # Does not help?!
$trace = $signal = $single = 0; # Uninitialized warning suppression
# (local $^W cannot help - other packages!).
@stack = (0);
$option{PrintRet} = 1;
@options = qw(hashDepth arrayDepth DumpDBFiles DumpPackages
compactDump veryCompact quote HighBit undefPrint
globPrint PrintRet UsageOnly frame
TTY noTTY ReadLine NonStop LineInfo
recallCommand ShellBang pager tkRunning
signalLevel warnLevel dieLevel);
%optionVars = (
hashDepth => \$dumpvar::hashDepth,
arrayDepth => \$dumpvar::arrayDepth,
DumpDBFiles => \$dumpvar::dumpDBFiles,
DumpPackages => \$dumpvar::dumpPackages,
HighBit => \$dumpvar::quoteHighBit,
undefPrint => \$dumpvar::printUndef,
globPrint => \$dumpvar::globPrint,
tkRunning => \$readline::Tk_toloop,
UsageOnly => \$dumpvar::usageOnly,
frame => \$frame,
);
%optionAction = (
compactDump => \&dumpvar::compactDump,
veryCompact => \&dumpvar::veryCompact,
quote => \&dumpvar::quote,
TTY => \&TTY,
noTTY => \&noTTY,
ReadLine => \&ReadLine,
NonStop => \&NonStop,
LineInfo => \&LineInfo,
recallCommand => \&recallCommand,
ShellBang => \&shellBang,
pager => \&pager,
signalLevel => \&signalLevel,
warnLevel => \&warnLevel,
dieLevel => \&dieLevel,
);
%optionRequire = (
compactDump => 'dumpvar.pl',
veryCompact => 'dumpvar.pl',
quote => 'dumpvar.pl',
);
# These guys may be defined in $ENV{PERL5DB} :
$rl = 1 unless defined $rl;
warnLevel($warnLevel);
dieLevel($dieLevel);
signalLevel($signalLevel);
&pager(defined($ENV{PAGER}) ? $ENV{PAGER} : "|more") unless defined $pager;
&recallCommand("!") unless defined $prc;
&shellBang("!") unless defined $psh;
if (-e "/dev/tty") {
$rcfile=".perldb";
} else {
$rcfile="perldb.ini";
}
if (-f $rcfile) {
do "./$rcfile";
} elsif (defined $ENV{LOGDIR} and -f "$ENV{LOGDIR}/$rcfile") {
do "$ENV{LOGDIR}/$rcfile";
} elsif (defined $ENV{HOME} and -f "$ENV{HOME}/$rcfile") {
do "$ENV{HOME}/$rcfile";
}
if (defined $ENV{PERLDB_OPTS}) {
parse_options($ENV{PERLDB_OPTS});
}
if (exists $ENV{PERLDB_RESTART}) {
delete $ENV{PERLDB_RESTART};
# $restart = 1;
@hist = get_list('PERLDB_HIST');
my @visited = get_list("PERLDB_VISITED");
for (0 .. $#visited) {
%{$postponed{$visited[$_]}} = get_list("PERLDB_FILE_$_");
}
my %opt = get_list("PERLDB_OPT");
my ($opt,$val);
while (($opt,$val) = each %opt) {
$val =~ s/[\\\']/\\$1/g;
parse_options("$opt'$val'");
}
@INC = get_list("PERLDB_INC");
@ini_INC = @INC;
}
if ($notty) {
$runnonstop = 1;
} else {
# Is Perl being run from Emacs?
$emacs = ((defined $main::ARGV[0]) and ($main::ARGV[0] eq '-emacs'));
$rl = 0, shift(@main::ARGV) if $emacs;
#require Term::ReadLine;
if (-e "/dev/tty") {
$console = "/dev/tty";
} elsif (-e "con") {
$console = "con";
} else {
$console = "sys\$command";
}
# Around a bug:
if (defined $ENV{OS2_SHELL} and $emacs) { # In OS/2
$console = undef;
}
$console = $tty if defined $tty;
if (defined $console) {
open(IN,"+<$console") || open(IN,"<$console") || open(IN,"<&STDIN");
open(OUT,"+>$console") || open(OUT,">$console") || open(OUT,">&STDERR")
|| open(OUT,">&STDOUT"); # so we don't dongle stdout
} else {
open(IN,"<&STDIN");
open(OUT,">&STDERR") || open(OUT,">&STDOUT"); # so we don't dongle stdout
$console = 'STDIN/OUT';
}
# so open("|more") can read from STDOUT and so we don't dingle stdin
$IN = \*IN;
$OUT = \*OUT;
select($OUT);
$| = 1; # for DB::OUT
select(STDOUT);
$LINEINFO = $OUT unless defined $LINEINFO;
$lineinfo = $console unless defined $lineinfo;
$| = 1; # for real STDOUT
$header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
unless ($runnonstop) {
print $OUT "\nLoading DB routines from $header\n";
print $OUT ("Emacs support ",
$emacs ? "enabled" : "available",
".\n");
print $OUT "\nEnter h or `h h' for help.\n\n";
}
}
@ARGS = @ARGV;
for (@args) {
s/\'/\\\'/g;
s/(.*)/'$1'/ unless /^-?[\d.]+$/;
}
if (defined &afterinit) { # May be defined in $rcfile
&afterinit();
}
############################################################ Subroutines
sub DB {
unless ($first_time++) { # Do when-running init
if ($runnonstop) { # Disable until signal
for ($i=0; $i <= $#stack; ) {
$stack[$i++] &= ~1;
}
$single = 0;
return;
}
# Define a subroutine in which we will stop
# eval <<'EOE';
# sub at_end::db {"Debuggee terminating";}
# END {
# $DB::step = 1;
# print $OUT "Debuggee terminating.\n";
# &at_end::db;}
# EOE
}
&save;
if ($doret) {
$doret = 0;
if ($option{PrintRet}) {
print $OUT "$retctx context return from $lastsub:",
($retctx eq 'list') ? "\n" : " " ;
dumpit( ($retctx eq 'list') ? \@ret : $ret );
}
}
($package, $filename, $line) = caller;
$filename_ini = $filename;
$usercontext = '($@, $!, $,, $/, $\, $^W) = @saved;' .
"package $package;"; # this won't let them modify, alas
local(*dbline) = "::_<$filename";
install_