package DB;
+use strict;
+
BEGIN {eval 'use IO::Handle'}; # Needed for flush only? breaks under miniperl
BEGIN {
}
# Debugger for Perl 5.00x; perl5db.pl patch level:
-$VERSION = '1.38';
+use vars qw($VERSION $header);
+
+$VERSION = '1.39';
$header = "perl5db.pl version $VERSION";
# Fiddling with the debugger's context could be Bad. We insulate things as
# much as we can.
+use vars qw(
+ @args
+ %break_on_load
+ @cmdfhs
+ $CommandSet
+ $CreateTTY
+ $DBGR
+ @dbline
+ $dbline
+ %dbline
+ $dieLevel
+ $evalarg
+ $filename
+ $frame
+ $hist
+ $histfile
+ $histsize
+ $ImmediateStop
+ $IN
+ $inhibit_exit
+ @ini_INC
+ $ini_warn
+ $line
+ $maxtrace
+ $od
+ $onetimeDump
+ $onetimedumpDepth
+ %option
+ @options
+ $osingle
+ $otrace
+ $OUT
+ $packname
+ $pager
+ $post
+ %postponed
+ $prc
+ $pre
+ $pretype
+ $psh
+ @RememberOnROptions
+ $remoteport
+ @res
+ $rl
+ @saved
+ $signal
+ $signalLevel
+ $single
+ $start
+ $sub
+ %sub
+ $subname
+ $term
+ $trace
+ $usercontext
+ $warnLevel
+ $window
+);
+
+# Used to save @ARGV and extract any debugger-related flags.
+use vars qw(@ARGS);
+
+# Used to prevent multiple entries to diesignal()
+# (if for instance diesignal() itself dies)
+use vars qw($panic);
+
+# Used to prevent the debugger from running nonstop
+# after a restart
+use vars qw($second_time);
+
+sub _calc_usercontext {
+ my ($package) = @_;
+
+ # Cancel strict completely for the evaluated code, so the code
+ # the user evaluates won't be affected by it. (Shlomi Fish)
+ return 'no strict; ($@, $!, $^E, $,, $/, $\, $^W) = @saved;'
+ . "package $package;"; # this won't let them modify, alas
+}
+
sub eval {
# 'my' would make it visible from user code
$dumpvar::globPrint,
$dumpvar::usageOnly,
- # used to save @ARGV and extract any debugger-related flags.
- @ARGS,
-
# used to control die() reporting in diesignal()
$Carp::CarpLevel,
- # used to prevent multiple entries to diesignal()
- # (if for instance diesignal() itself dies)
- $panic,
- # used to prevent the debugger from running nonstop
- # after a restart
- $second_time,
)
if 0;
# value when the 'r' command is used to return from a subroutine.
$inhibit_exit = $option{PrintRet} = 1;
+use vars qw($trace_to_depth);
+
# Default to 1 so the prompt will display the first line.
$trace_to_depth = 1;
=cut
+use vars qw(%optionVars);
+
%optionVars = (
hashDepth => \$dumpvar::hashDepth,
arrayDepth => \$dumpvar::arrayDepth,
=cut
+use vars qw(%optionAction);
+
%optionAction = (
compactDump => \&dumpvar::compactDump,
veryCompact => \&dumpvar::veryCompact,
# not in the table. A subsequent patch will correct this problem; for
# the moment, we're just recommenting, and we are NOT going to change
# function.
+use vars qw(%optionRequire);
+
%optionRequire = (
compactDump => 'dumpvar.pl',
veryCompact => 'dumpvar.pl',
# Save the current contents of the environment; we're about to
# much with it. We'll need this if we have to restart.
+use vars qw($ini_pids);
$ini_pids = $ENV{PERLDB_PIDS};
+use vars qw ($pids $term_pid);
+
if ( defined $ENV{PERLDB_PIDS} ) {
# We're a child. Make us a label out of the current PID structure
$term_pid = $$;
}
+use vars qw($pidprompt);
$pidprompt = '';
# Sets up $emacs as a synonym for $slave_editor.
+use vars qw($slave_editor);
*emacs = $slave_editor if $slave_editor; # May be used in afterinit()...
=head2 READING THE RC FILE
my $dev_tty = '/dev/tty';
$dev_tty = 'TT:' if ($^O eq 'VMS');
+use vars qw($rcfile);
if ( -e $dev_tty ) { # this is the wrong metric!
$rcfile = ".perldb";
}
=cut
+use vars qw(@hist @truehist %postponed_file @typeahead);
+
if ( exists $ENV{PERLDB_RESTART} ) {
# We're restarting, so we don't need the flag that says to restart anymore.
=cut
+use vars qw($notty $runnonstop $console $tty $LINEINFO);
+use vars qw($lineinfo $doccmd);
+
if ($notty) {
$runnonstop = 1;
share($runnonstop);
# XXX This looks like a bug to me.
# Why copy to @ARGS and then futz with @args?
@ARGS = @ARGV;
-for (@args) {
+# for (@args) {
# Make sure backslashes before single quotes are stripped out, and
# keep args unless they are numeric (XXX why?)
# s/\'/\\\'/g; # removed while not justified understandably
# s/(.*)/'$1'/ unless /^-?[\d.]+$/; # ditto
-}
+# }
# If there was an afterinit() sub defined, call it. It will get
# executed in our scope, so it can fiddle with debugger globals.
}
# Inform us about "Stack dump during die enabled ..." in dieLevel().
+use vars qw($I_m_init);
+
$I_m_init = 1;
############################################################ Subroutines
=cut
+use vars qw(
+ $action
+ %alias
+ $cmd
+ $doret
+ $fall_off_end
+ $file
+ $filename_ini
+ $finished
+ %had_breakpoints
+ $incr
+ $laststep
+ $level
+ $max
+ @old_watch
+ $package
+ $rc
+ $sh
+ @stack
+ $stack_depth
+ @to_watch
+ $try
+);
+
sub DB {
# lock the debugger and get the thread id for the prompt
lock($DBGR);
my $tid;
+ my $position;
+ my ($prefix, $after, $infix);
+ my $pat;
+ my $end;
+
if ($ENV{PERL5DB_THREADED}) {
$tid = eval { "[".threads->tid."]" };
}
if ($runnonstop) { # Disable until signal
# If there's any call stack in place, turn off single
# stepping into subs throughout the stack.
- for ( $i = 0 ; $i <= $stack_depth ; ) {
+ for ( my $i = 0 ; $i <= $stack_depth ; ) {
$stack[ $i++ ] &= ~1;
}
# caller is returning all the extra information when called from the
# debugger.
local ( $package, $filename, $line ) = caller;
- local $filename_ini = $filename;
+ $filename_ini = $filename;
# set up the context for DB::eval, so it can properly execute
# code on behalf of the user. We add the package in so that the
# code is eval'ed in the proper package (not in the debugger!).
- local $usercontext =
- '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' . "package $package;";
+ local $usercontext = _calc_usercontext($package);
# Create an alias to the active file magical array to simplify
# the code here.
local (*dbline) = $main::{ '_<' . $filename };
# Last line in the program.
- local $max = $#dbline;
+ my $max = $#dbline;
# if we have something here, see if we should break.
if ( $dbline{$line}
&& _is_breakpoint_enabled($filename, $line)
- && ( ( $stop, $action ) = split( /\0/, $dbline{$line} ) ) )
+ && ( my ( $stop, $action ) = split( /\0/, $dbline{$line} ) ) )
{
# Stop if the stop criterion says to just stop.
# Set the DB::eval context appropriately.
$package = 'main';
- $usercontext =
- '($@, $!, $^E, $,, $/, $\, $^W) = @saved;'
- . "package $package;"; # this won't let them modify, alas
+ $usercontext = _calc_usercontext($package);
} ## end elsif ($package eq 'DB::fake')
=pod
# Perl 5 ones (sorry, we don't print Klingon
#module names)
- $prefix = $sub =~ /::/ ? "" : "${'package'}::";
+ $prefix = $sub =~ /::/ ? "" : ($package . '::');
$prefix .= "$sub($filename:";
$after = ( $dbline[$line] =~ /\n$/ ? '' : "\n" );
# Scan forward, stopping at either the end or the next
# unbreakable line.
- for ( $i = $line + 1 ; $i <= $max && $dbline[$i] == 0 ; ++$i )
+ for ( my $i = $line + 1 ; $i <= $max && $dbline[$i] == 0 ; ++$i )
{ #{ vi
# Drop out on null statements, block closers, and comments.
$after = ( $dbline[$i] =~ /\n$/ ? '' : "\n" );
# Next executable line.
- $incr_pos = "$prefix$i$infix$dbline[$i]$after";
+ my $incr_pos = "$prefix$i$infix$dbline[$i]$after";
$position .= $incr_pos;
if ($frame) {
#
# If we have a terminal for input, and we get something back
# from readline(), keep on processing.
+ my $piped;
+ my $selected;
+
CMD:
while (
PIPE: {
$cmd =~ s/^\s+//s; # trim annoying leading whitespace
$cmd =~ s/\s+$//s; # trim annoying trailing whitespace
- ($i) = split( /\s+/, $cmd );
+ my ($i) = split( /\s+/, $cmd );
=head3 COMMAND ALIASES
$cmd =~ /^S(\s+(!)?(.+))?$/ && do {
- $Srev = defined $2; # Reverse scan?
- $Spatt = $3; # The pattern (if any) to use.
- $Snocheck = !defined $1; # No args - print all subs.
+ my $Srev = defined $2; # Reverse scan?
+ my $Spatt = $3; # The pattern (if any) to use.
+ my $Snocheck = !defined $1; # No args - print all subs.
# Need to make these sane here.
local $\ = '';
# Save the currently selected filehandle and
# force output to debugger's filehandle (dumpvar
# just does "print" for output).
- local ($savout) = select($OUT);
+ my $savout = select($OUT);
# Grab package name and variables to dump.
$packname = $1;
- @vars = split( ' ', $2 );
+ my @vars = split( ' ', $2 );
# If main::dumpvar isn't here, get it.
do 'dumpvar.pl' || die $@ unless defined &main::dumpvar;
$cmd =~ /^\/(.*)$/ && do {
# The pattern as a string.
- $inpat = $1;
+ my $inpat = $1;
# Remove the final slash.
$inpat =~ s:([^\\])/$:$1:;
$cmd =~ /^\?(.*)$/ && do {
# Get the pattern, remove trailing question mark.
- $inpat = $1;
+ my $inpat = $1;
$inpat =~ s:([^\\])\?$:$1:;
# If we've got one ...
=cut
-sub sub {
+use vars qw($deep);
+
+# We need to fully qualify the name ("DB::sub") to make "use strict;"
+# happy. -- Shlomi Fish
+sub DB::sub {
# Do not use a regex in this subroutine -> results in corrupted memory
# See: [perl #66110]
# If the last ten characters are '::AUTOLOAD', note we've traced
# into AUTOLOAD for $sub.
if ( length($sub) > 10 && substr( $sub, -10, 10 ) eq '::AUTOLOAD' ) {
+ no strict 'refs';
$al = " for $$sub" if defined $$sub;
}
# Called in array context. call sub and capture output.
# DB::DB will recursively get control again if appropriate; we'll come
# back here when the sub is finished.
- @ret = &$sub;
+ {
+ no strict 'refs';
+ @ret = &$sub;
+ }
# Pop the single-step value back off the stack.
$single |= $stack[ $stack_depth-- ];
# Scalar context.
else {
if ( defined wantarray ) {
-
+ no strict 'refs';
# Save the value if it's wanted at all.
$ret = &$sub;
}
else {
-
+ no strict 'refs';
# Void return, explicitly.
&$sub;
undef $ret;
# Return the appropriate scalar value.
$ret;
} ## end else [ if (wantarray)
-} ## end sub sub
+} ## end sub _sub
sub lsub : lvalue {
+ no strict 'refs';
+
# lock ourselves under threads
lock($DBGR);
|| ( $cmd =~ /^[<>{]+/o ? 'prepost' : $cmd ) );
# Call the command subroutine, call it by name.
- return &$call( $cmd, $line, $dblineno );
+ return __PACKAGE__->can($call)->( $cmd, $line, $dblineno );
} ## end sub cmd_wrapper
=head3 C<cmd_a> (command)
#
$subname = $1;
- $cond = length $2 ? $2 : '1';
+ my $cond = length $2 ? $2 : '1';
&cmd_b_sub( $subname, $cond );
}
$line = $1 || $dbline;
# If there's no condition, make it '1'.
- $cond = length $2 ? $2 : '1';
+ my $cond = length $2 ? $2 : '1';
# Break on line.
&cmd_b_line( $line, $cond );
=cut
+use vars qw($filename_error);
$filename_error = '';
=head3 breakable_line(from, to) (API)
my ( $file, $s, $e ) = subroutine_filename_lines($subname)
or die "Subroutine $subname not found.\n";
+
# Null condition changes to '1' (always true).
- $cond = 1 unless @_ >= 2;
+ my $cond = @_ ? shift(@_) : 1;
# Put a break the first place possible in the range of lines
# that make up this subroutine.
- break_on_filename_line_range( $file, $s, $e, @_ );
+ break_on_filename_line_range( $file, $s, $e, $cond );
} ## end sub break_subroutine
=head3 cmd_b_sub(subname, [condition]) (command)
=cut
+use vars qw($help);
+use vars qw($summary);
+
sub cmd_h {
my $cmd = shift;
# Get name:start-stop from find_sub, and break this up at
# colons.
- @pieces = split( /:/, find_sub($subname) || $sub{$subname} );
+ my @pieces = split( /:/, find_sub($subname) || $sub{$subname} );
# Pull off start-stop.
- $subrange = pop @pieces;
+ my $subrange = pop @pieces;
# If the name contained colons, the split broke it up.
# Put it back together.
elsif ( $line =~ /^((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/ ) {
# Determine end point; use end of file if not specified.
- $end = ( !defined $2 ) ? $max : ( $4 ? $4 : $2 );
+ my $end = ( !defined $2 ) ? $max : ( $4 ? $4 : $2 );
# Go on to the end, and then stop.
$end = $max if $end > $max;
# Determine start line.
- $i = $2;
+ my $i = $2;
$i = $line if $i eq '.';
$i = 1 if $i < 1;
$incr = $end - $i;
# ==> if this is the current line in execution,
# : if it's breakable.
- $arrow =
+ my $arrow =
( $i == $current_line and $filename eq $filename_ini )
? '==>'
: ( $dbline[$i] + 0 ? ':' : ' ' );
# in this file?
# For each line in the file ...
- for ( $i = 1 ; $i <= $max ; $i++ ) {
+ for ( my $i = 1 ; $i <= $max ; $i++ ) {
# We've got something on this line.
if ( defined $dbline{$i} ) {
print $OUT " $i:\t", $dbline[$i];
# Pull out the condition and the action.
- ( $stop, $action ) = split( /\0/, $dbline{$i} );
+ my ( $stop, $action ) = split( /\0/, $dbline{$i} );
# Print the break if there is one and it's wanted.
print $OUT " break if (", $stop, ")\n"
=cut
+use vars qw($preview);
+
sub cmd_v {
my $cmd = shift;
my $line = shift;
# Save the current output filehandle and switch to the one
# passed in as the first parameter.
- local ($savout) = select(shift);
+ my $savout = select(shift);
# Save current settings of $single and $trace, and then turn them off.
my $osingle = $single;
# Run through the traceback info, format it, and print it.
my $s;
- for ( $i = 0 ; $i <= $#sub ; $i++ ) {
+ for ( my $i = 0 ; $i <= $#sub ; $i++ ) {
# Drop out if the user has lost interest and hit control-C.
last if $signal;
# quit.
# Up the stack frame index to go back one more level each time.
for (
- $i = $skip ;
+ my $i = $skip ;
$i < $count
and ( $p, $file, $line, $sub, $h, $context, $e, $r ) = caller($i) ;
$i++
# Go through the arguments and save them for later.
@a = ();
- for $arg (@args) {
+ for my $arg (@args) {
my $type;
if ( not defined $arg ) { # undefined parameter
push @a, "undef";
=cut
+use vars qw($balanced_brace_re);
+
sub unbalanced {
# I hate using globals!
=cut
+use vars qw($ornaments);
+use vars qw($rl_attribs);
+
sub setterm {
# Load Term::Readline, but quietly; don't debug it and don't trace it.
=cut
+use vars qw($fork_TTY);
+
sub create_IN_OUT { # Create a window with IN/OUT handles redirected there
# If we know how to get a new TTY, do it! $in will have
$OUT->write( join( '', @_ ) );
# Receive anything there is to receive.
- $stuff;
my $stuff = '';
my $buf;
do {
local ($_) = @_;
local $\ = '';
+ my $option;
+
# These options need a value. Don't allow them to be clobbered by accident.
my %opt_needs_val = map { ( $_ => 1 ) } qw{
dumpDepth arrayDepth hashDepth LineInfo maxTraceLen ornaments windowSize
# Grab each item in the list, escape the backslashes, encode the non-ASCII
# as hex, and then save in the appropriate VAR_0, VAR_1, etc.
- for $i ( 0 .. $#list ) {
+ for my $i ( 0 .. $#list ) {
$val = $list[$i];
$val =~ s/\\/\\\\/g;
$val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
my @list;
my $n = delete $ENV{"${stem}_n"};
my $val;
- for $i ( 0 .. $n - 1 ) {
+ for my $i ( 0 .. $n - 1 ) {
$val = delete $ENV{"${stem}_$i"};
$val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
push @list, $val;
=cut
+use vars qw($pre580_help);
+use vars qw($pre580_summary);
+
sub sethelp {
# XXX: make sure there are tabs between the command and explanation,
=cut
+use vars qw($fixed_less);
+
sub fix_less {
# We already know if this is set.
sub warnLevel {
if (@_) {
- $prevwarn = $SIG{__WARN__} unless $warnLevel;
+ my $prevwarn = $SIG{__WARN__} unless $warnLevel;
$warnLevel = shift;
if ($warnLevel) {
$SIG{__WARN__} = \&DB::dbwarn;
sub dieLevel {
local $\ = '';
if (@_) {
- $prevdie = $SIG{__DIE__} unless $dieLevel;
+ my $prevdie = $SIG{__DIE__} unless $dieLevel;
$dieLevel = shift;
if ($dieLevel) {
sub signalLevel {
if (@_) {
- $prevsegv = $SIG{SEGV} unless $signalLevel;
- $prevbus = $SIG{BUS} unless $signalLevel;
+ my $prevsegv = $SIG{SEGV} unless $signalLevel;
+ my $prevbus = $SIG{BUS} unless $signalLevel;
$signalLevel = shift;
if ($signalLevel) {
$SIG{SEGV} = \&DB::diesignal;
=cut
+use vars qw($skipCvGV);
+
sub CvGV_name_or_bust {
my $in = shift;
return if $skipCvGV; # Backdoor to avoid problems if XS broken...
=cut
+use vars qw(%seen);
+
sub methods {
# Figure out the class - either this is the class or it's a reference
my @to_print;
# Extract from all the symbols in this class.
- while (my ($name, $glob) = each %{"${class}::"}) {
+ my $class_ref = do { no strict "refs"; \%{$class . '::'} };
+ while (my ($name, $glob) = each %$class_ref) {
# references directly in the symbol table are Proxy Constant
# Subroutines, and are by their very nature defined
# Otherwise, check if the thing is a typeglob, and if it is, it decays
# $crawl_upward true: keep going up the tree.
# Find all the classes this one is a subclass of.
- for $name ( @{"${class}::ISA"} ) {
+ my $class_ISA_ref = do { no strict "refs"; \@{"${class}::ISA"} };
+ for my $name ( @$class_ISA_ref ) {
# Set up the new prefix.
$prepend = $prefix ? $prefix . " -> $name" : $name;
# The following BEGIN is very handy if debugger goes havoc, debugging debugger?
+use vars qw($db_stop);
+
BEGIN { # This does not compile, alas. (XXX eh?)
$IN = \*STDIN; # For bugs before DB::OUT has been opened
$OUT = \*STDERR; # For errors before DB::OUT has been opened
# "Triggers bug (?) in perl if we postpone this until runtime."
# XXX No details on this yet, or whether we should fix the bug instead
# of work around it. Stay tuned.
- @postponed = @stack = (0);
+ @stack = (0);
# Used to track the current stack depth using the auto-stacked-variable
# trick.
# We'll want to quote the string (because of the embedded
# whtespace), but we want to make sure we don't end up with
# mismatched quote characters. We try several possibilities.
- foreach $l ( split //, qq/\"\'\#\|/ ) {
+ foreach my $l ( split //, qq/\"\'\#\|/ ) {
# If we didn't find this quote character in the value,
# quote it using this quote character.
if ( $cmd =~ /^(\d*)\s*(.*)/ ) {
# If the line isn't there, use the current line.
- $i = $1 || $line;
- $j = $2;
+ my $i = $1 || $line;
+ my $j = $2;
# If there is an action ...
if ( length $j ) {
my $was;
# For all lines in this file ...
- for ( $i = 1 ; $i <= $max ; $i++ ) {
+ for ( my $i = 1 ; $i <= $max ; $i++ ) {
# If there's a breakpoint or action on this line ...
if ( defined $dbline{$i} ) {
projects / platform / upstream / perl.git / commitdiff