X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2Fperl5db.pl;h=18d52dc88e6890012010a976ed8a92f971fb43b4;hb=71ad7795db6b8d545a629fdaf0efbb677f2f2921;hp=ea072e0f3b8df27a2c5afceaae57acec697fd158;hpb=39e571d41067215a80f26089b260f1418caeb36b;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/perl5db.pl b/lib/perl5db.pl index ea072e0..18d52dc 100644 --- a/lib/perl5db.pl +++ b/lib/perl5db.pl @@ -2,7 +2,7 @@ package DB; # Debugger for Perl 5.00x; perl5db.pl patch level: -$VERSION = 1.02; +$VERSION = 1.0402; $header = "perl5db.pl version $VERSION"; # Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich) @@ -173,26 +173,30 @@ $trace = $signal = $single = 0; # Uninitialized warning suppression # (local $^W cannot help - other packages!). $inhibit_exit = $option{PrintRet} = 1; -@options = qw(hashDepth arrayDepth DumpDBFiles DumpPackages +@options = qw(hashDepth arrayDepth DumpDBFiles DumpPackages DumpReused compactDump veryCompact quote HighBit undefPrint globPrint PrintRet UsageOnly frame AutoTrace TTY noTTY ReadLine NonStop LineInfo maxTraceLen recallCommand ShellBang pager tkRunning ornaments - signalLevel warnLevel dieLevel inhibit_exit); + signalLevel warnLevel dieLevel inhibit_exit + ImmediateStop bareStringify); %optionVars = ( hashDepth => \$dumpvar::hashDepth, arrayDepth => \$dumpvar::arrayDepth, DumpDBFiles => \$dumpvar::dumpDBFiles, DumpPackages => \$dumpvar::dumpPackages, + DumpReused => \$dumpvar::dumpReused, HighBit => \$dumpvar::quoteHighBit, undefPrint => \$dumpvar::printUndef, globPrint => \$dumpvar::globPrint, UsageOnly => \$dumpvar::usageOnly, + bareStringify => \$dumpvar::bareStringify, frame => \$frame, AutoTrace => \$trace, inhibit_exit => \$inhibit_exit, maxTraceLen => \$maxtrace, + ImmediateStop => \$ImmediateStop, ); %optionAction = ( @@ -231,7 +235,11 @@ $pretype = [] unless defined $pretype; warnLevel($warnLevel); dieLevel($dieLevel); signalLevel($signalLevel); -&pager(defined($ENV{PAGER}) ? $ENV{PAGER} : "|more") unless defined $pager; +&pager((defined($ENV{PAGER}) + ? $ENV{PAGER} + : ($^O eq 'os2' + ? 'cmd /c more' + : 'more'))) unless defined $pager; &recallCommand("!") unless defined $prc; &shellBang("!") unless defined $psh; $maxtrace = 400 unless defined $maxtrace; @@ -288,7 +296,10 @@ if ($notty) { #require Term::ReadLine; - if (-e "/dev/tty") { + if ($^O =~ /cygwin/) { + # /dev/tty is binary. use stdin for textmode + undef $console; + } elsif (-e "/dev/tty") { $console = "/dev/tty"; } elsif ($^O eq 'dos' or -e "con" or $^O eq 'MSWin32') { $console = "con"; @@ -305,6 +316,10 @@ if ($notty) { $console = undef; } + if ($^O eq 'epoc') { + $console = undef; + } + $console = $tty if defined $tty; if (defined $console) { @@ -357,18 +372,21 @@ sub DB { # _After_ the perl program is compiled, $single is set to 1: if ($single and not $second_time++) { if ($runnonstop) { # Disable until signal - for ($i=0; $i <= $#stack; ) { + for ($i=0; $i <= $stack_depth; ) { $stack[$i++] &= ~1; } $single = 0; # return; # Would not print trace! + } elsif ($ImmediateStop) { + $ImmediateStop = 0; + $signal = 1; } } $runnonstop = 0 if $single or $signal; # Disable it if interactive. &save; ($package, $filename, $line) = caller; $filename_ini = $filename; - $usercontext = '($@, $!, $,, $/, $\, $^W) = @saved;' . + $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' . "package $package;"; # this won't let them modify, alas local(*dbline) = $main::{'_<' . $filename}; $max = $#dbline; @@ -376,7 +394,7 @@ sub DB { if ($stop eq '1') { $signal |= 1; } elsif ($stop) { - $evalarg = "\$DB::signal |= do {$stop;}"; &eval; + $evalarg = "\$DB::signal |= 1 if do {$stop}"; &eval; $dbline{$line} =~ s/;9($|\0)/$1/; } } @@ -384,14 +402,15 @@ sub DB { if ($trace & 2) { for (my $n = 0; $n <= $#to_watch; $n++) { $evalarg = $to_watch[$n]; + local $onetimeDump; # Do not output results my ($val) = &eval; # Fix context (&eval is doing array)? $val = ( (defined $val) ? "'$val'" : 'undef' ); if ($val ne $old_watch[$n]) { $signal = 1; print $OUT < to quit or B to restart, + use B I to avoid stopping after program termination, + B, B or B to get additional info. +EOP + $package = 'main'; + $usercontext = '($@, $!, $,, $/, $\, $^W) = @saved;' . + "package $package;"; # this won't let them modify, alas } else { $sub =~ s/\'/::/; $prefix = $sub =~ /::/ ? "" : "${'package'}::"; @@ -422,7 +450,7 @@ EOP $position = "$prefix$line$infix$dbline[$line]$after"; } if ($frame) { - print $LINEINFO ' ' x $#stack, "$line:\t$dbline[$line]$after"; + print $LINEINFO ' ' x $stack_depth, "$line:\t$dbline[$line]$after"; } else { print $LINEINFO $position; } @@ -433,7 +461,7 @@ EOP $incr_pos = "$prefix$i$infix$dbline[$i]$after"; $position .= $incr_pos; if ($frame) { - print $LINEINFO ' ' x $#stack, "$i:\t$dbline[$i]$after"; + print $LINEINFO ' ' x $stack_depth, "$i:\t$dbline[$i]$after"; } else { print $LINEINFO $incr_pos; } @@ -446,7 +474,7 @@ EOP foreach $evalarg (@$pre) { &eval; } - print $OUT $#stack . " levels deep in subroutine calls!\n" + print $OUT $stack_depth . " levels deep in subroutine calls!\n" if $single & 4; $start = $line; $incr = -1; # for backward motion. @@ -623,8 +651,9 @@ EOP $arrow .= 'b' if $stop; $arrow .= 'a' if $action; print $OUT "$i$arrow\t", $dbline[$i]; - last if $signal; + $i++, last if $signal; } + print $OUT "\n" unless $dbline[$i-1] =~ /\n$/; } $start = $i; # remember in case they want more $start = $max if $start > $max; @@ -862,14 +891,14 @@ EOP } $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p. } - for ($i=0; $i <= $#stack; ) { + for ($i=0; $i <= $stack_depth; ) { $stack[$i++] &= ~1; } last CMD; }; $cmd =~ /^r$/ && do { end_report(), next CMD if $finished and $level <= 1; - $stack[$#stack] |= 1; - $doret = $option{PrintRet} ? $#stack - 1 : -2; + $stack[$stack_depth] |= 1; + $doret = $option{PrintRet} ? $stack_depth - 1 : -2; last CMD; }; $cmd =~ /^R$/ && do { print $OUT "Warning: some settings and command-line options may be lost!\n"; @@ -1028,8 +1057,8 @@ EOP $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do { pop(@hist) if length($cmd) > 1; $i = $1 ? ($#hist-($2?$2:1)) : ($2?$2:$#hist); - $cmd = $hist[$i] . "\n"; - print $OUT $cmd; + $cmd = $hist[$i]; + print $OUT $cmd, "\n"; redo CMD; }; $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do { &system($1); @@ -1044,8 +1073,8 @@ EOP print $OUT "No such command!\n\n"; next CMD; } - $cmd = $hist[$i] . "\n"; - print $OUT $cmd; + $cmd = $hist[$i]; + print $OUT $cmd, "\n"; redo CMD; }; $cmd =~ /^$sh$/ && do { &system($ENV{SHELL}||"/bin/sh"); @@ -1140,7 +1169,7 @@ EOP &eval; } } # if ($single || $signal) - ($@, $!, $,, $/, $\, $^W) = @saved; + ($@, $!, $^E, $,, $/, $\, $^W) = @saved; (); } @@ -1152,24 +1181,30 @@ sub sub { if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') { $al = " for $$sub"; } - push(@stack, $single); + local $stack_depth = $stack_depth + 1; # Protect from non-local exits + $#stack = $stack_depth; + $stack[-1] = $single; $single &= 1; - $single |= 4 if $#stack == $deep; + $single |= 4 if $stack_depth == $deep; ($frame & 4 - ? ( (print $LINEINFO ' ' x ($#stack - 1), "in "), + ? ( (print $LINEINFO ' ' x ($stack_depth - 1), "in "), # Why -1? But it works! :-( print_trace($LINEINFO, -1, 1, 1, "$sub$al") ) - : print $LINEINFO ' ' x ($#stack - 1), "entering $sub$al\n") if $frame; + : print $LINEINFO ' ' x ($stack_depth - 1), "entering $sub$al\n") if $frame; if (wantarray) { @ret = &$sub; - $single |= pop(@stack); + $single |= $stack[$stack_depth--]; ($frame & 4 - ? ( (print $LINEINFO ' ' x $#stack, "out "), + ? ( (print $LINEINFO ' ' x $stack_depth, "out "), print_trace($LINEINFO, -1, 1, 1, "$sub$al") ) - : print $LINEINFO ' ' x $#stack, "exited $sub$al\n") if $frame & 2; - print ($OUT ($frame & 16 ? ' ' x $#stack : ""), - "list context return from $sub:\n"), dumpit( \@ret ), - $doret = -2 if $doret eq $#stack or $frame & 16; + : print $LINEINFO ' ' x $stack_depth, "exited $sub$al\n") if $frame & 2; + if ($doret eq $stack_depth or $frame & 16) { + my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO); + print $fh ' ' x $stack_depth if $frame & 16; + print $fh "list context return from $sub:\n"; + dumpit($fh, \@ret ); + $doret = -2; + } @ret; } else { if (defined wantarray) { @@ -1177,20 +1212,26 @@ sub sub { } else { &$sub; undef $ret; }; - $single |= pop(@stack); + $single |= $stack[$stack_depth--]; ($frame & 4 - ? ( (print $LINEINFO ' ' x $#stack, "out "), + ? ( (print $LINEINFO ' ' x $stack_depth, "out "), print_trace($LINEINFO, -1, 1, 1, "$sub$al") ) - : print $LINEINFO ' ' x $#stack, "exited $sub$al\n") if $frame & 2; - print ($OUT ($frame & 16 ? ' ' x $#stack : ""), - "scalar context return from $sub: "), dumpit( $ret ), - $doret = -2 if $doret eq $#stack or $frame & 16; + : print $LINEINFO ' ' x $stack_depth, "exited $sub$al\n") if $frame & 2; + if ($doret eq $stack_depth or $frame & 16 and defined wantarray) { + my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO); + print $fh (' ' x $stack_depth) if $frame & 16; + print $fh (defined wantarray + ? "scalar context return from $sub: " + : "void context return from $sub\n"); + dumpit( $fh, $ret ) if defined wantarray; + $doret = -2; + } $ret; } } sub save { - @saved = ($@, $!, $,, $/, $\, $^W); + @saved = ($@, $!, $^E, $,, $/, $\, $^W); $, = ""; $/ = "\n"; $\ = ""; $^W = 0; } @@ -1199,7 +1240,6 @@ sub save { sub eval { my @res; { - local (@stack) = @stack; # guard against recursive debugging my $otrace = $trace; my $osingle = $single; my $od = $^D; @@ -1210,11 +1250,11 @@ sub eval { } my $at = $@; local $saved[0]; # Preserve the old value of $@ - eval "&DB::save"; + eval { &DB::save }; if ($at) { print $OUT $at; } elsif ($onetimeDump eq 'dump') { - dumpit(\@res); + dumpit($OUT, \@res); } elsif ($onetimeDump eq 'methods') { methods($res[0]); } @@ -1245,6 +1285,10 @@ sub postponed_sub { } sub postponed { + if ($ImmediateStop) { + $ImmediateStop = 0; + $signal = 1; + } return &postponed_sub unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled. # Cannot be done before the file is compiled @@ -1253,7 +1297,7 @@ sub postponed { $filename =~ s/^_&OUT") || &warn("Can't save STDOUT"); + open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT"); open(STDIN,"<&IN") || &warn("Can't redirect STDIN"); open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT"); system(@_); @@ -1401,7 +1445,6 @@ sub system { sub setterm { local $frame = 0; local $doret = -2; - local @stack = @stack; # Prevent growth by failing `use'. eval { require Term::ReadLine } or die $@; if ($notty) { if ($tty) { @@ -1460,8 +1503,14 @@ sub resetterm { # We forked, so we need a different TTY TTY($fork_TTY); undef $fork_TTY; } else { - print $OUT "Forked, but do not know how to change a TTY.\n", - "Define \$DB::fork_TTY or get_fork_TTY().\n"; + print_help(< Forked, but do not know how to change a B. I<#########> + Define B<\$DB::fork_TTY> + - or a function B which will set B<\$DB::fork_TTY>. + The value of B<\$DB::fork_TTY> should be the name of I to use. + On I-like systems one can get the name of a I for the given window + by typing B, and disconnect the I from I by B. +EOP } } @@ -1710,13 +1759,7 @@ sub list_versions { } $version{$file} .= $INC{$file}; } - do 'dumpvar.pl' unless defined &main::dumpValue; - if (defined &main::dumpValue) { - local $frame = 0; - &main::dumpValue(\%version); - } else { - print $OUT "dumpvar.pl not available.\n"; - } + dumpit($OUT,\%version); } sub sethelp { @@ -1779,13 +1822,16 @@ B [I[B<=>I]] [IB<\">IB<\">] [IB]... I: run Tk while prompting (with ReadLine); I I I: level of verbosity; I Allows stepping off the end of the script. + I Debugger should stop as early as possible. The following options affect what happens with B, B, and B commands: I, I: print only first N elements ('' for all); I, I: change style of array and hash dump; I: whether to print contents of globs; I: dump arrays holding debugged files; I: dump symbol tables of packages; + I: dump contents of \"reused\" addresses; I, I, I: change style of string dump; + I: Do not print the overload-stringified value; Option I affects printing of return value after B command, I affects printing messages on entry and exit from subroutines. I affects printing messages on every possible breaking point. @@ -1822,7 +1868,7 @@ B Pure-man-restart of debugger, some of debugger state and the following command-line options: I<-w>, I<-I>, I<-e>. B [I] Get help [on a specific debugger command], enter B<|h> to page. B Summary of debugger commands. -B or B<^D> Quit. Set \$DB::finished to 0 to debug global destruction. +B or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction. "; $summary = <<"END_SUM"; @@ -2033,6 +2079,7 @@ BEGIN { # This does not compile, alas. # @stack and $doret are needed in sub sub, which is called for DB::postponed. # Triggers bug (?) in perl is we postpone this until runtime: @postponed = @stack = (0); + $stack_depth = 0; # Localized $#stack $doret = -2; $frame = 0; }