X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2Fperl5db.pl;h=4e7ff9e28a533a8e19a30e484e8511ee7ee2eb17;hb=6b14ceb78325f07f9267f4d0b22adc748311a9a0;hp=7d31adef00234930e331a82e3d9a31c9fbe89162;hpb=04e43a21088e2c6b07ebde9e57007350cfd7310b;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/perl5db.pl b/lib/perl5db.pl index 7d31ade..4e7ff9e 100644 --- a/lib/perl5db.pl +++ b/lib/perl5db.pl @@ -2,13 +2,51 @@ package DB; # Debugger for Perl 5.00x; perl5db.pl patch level: -$VERSION = 1.10; +# It is crucial that there is no lexicals in scope of `eval ""' down below +sub eval { + # 'my' would make it visible from user code + # but so does local! --tchrist [... into @DB::res, not @res. IZ] + local @res; + { + local $otrace = $trace; + local $osingle = $single; + local $od = $^D; + { ($evalarg) = $evalarg =~ /(.*)/s; } + @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug + $trace = $otrace; + $single = $osingle; + $^D = $od; + } + my $at = $@; + local $saved[0]; # Preserve the old value of $@ + eval { &DB::save }; + if ($at) { + print $OUT $at; + } elsif ($onetimeDump) { + if ($onetimeDump eq 'dump') { + local $option{dumpDepth} = $onetimedumpDepth + if defined $onetimedumpDepth; + dumpit($OUT, \@res); + } elsif ($onetimeDump eq 'methods') { + methods($res[0]) ; + } + } + @res; +} + +# After this point it is safe to introduce lexicals +# However, one should not overdo it: leave as much control from outside as possible + +$VERSION = 1.15; $header = "perl5db.pl version $VERSION"; # # This file is automatically included if you do perl -d. # It's probably not useful to include this yourself. # +# Before venturing further into these twisty passages, it is +# wise to read the perldebguts man page or risk the ire of dragons. +# # Perl supplies the values for %sub. It effectively inserts # a &DB'DB(); in front of every place that can have a # breakpoint. Instead of a subroutine call it calls &DB::sub with @@ -25,14 +63,15 @@ $header = "perl5db.pl version $VERSION"; # if caller() is called from the package DB, it provides some # additional data. # -# The array @{$main::{'_<'.$filename}} is the line-by-line contents of -# $filename. +# The array @{$main::{'_<'.$filename}} (herein called @dbline) is the +# line-by-line contents of $filename. # -# The hash %{'_<'.$filename} contains breakpoints and action (it is -# keyed by line number), and individual entries are settable (as -# opposed to the whole hash). Only true/false is important to the -# interpreter, though the values used by perl5db.pl have the form -# "$break_condition\0$action". Values are magical in numeric context. +# The hash %{'_<'.$filename} (herein called %dbline) contains +# breakpoints and action (it is keyed by line number), and individual +# entries are settable (as opposed to the whole hash). Only true/false +# is important to the interpreter, though the values used by +# perl5db.pl have the form "$break_condition\0$action". Values are +# magical in numeric context. # # The scalar ${'_<'.$filename} contains $filename. # @@ -202,7 +241,7 @@ $header = "perl5db.pl version $VERSION"; # I bits control attempts to create a new TTY on events: # 1: on fork() 2: debugger is started inside debugger # 4: on startup -# c) Code to auto-create a new TTY window on OS/2 (currently one one +# c) Code to auto-create a new TTY window on OS/2 (currently one # extra window per session - need named pipes to have more...); # d) Simplified interface for custom createTTY functions (with a backward # compatibility hack); now returns the TTY name to use; return of '' @@ -245,7 +284,25 @@ $header = "perl5db.pl version $VERSION"; # + Fixed warnings generated by "perl -dWe 42" # + Corrected spelling errors # + Squeezed Help (h) output into 80 columns - +# +# Changes: 1.11: May 24, 2001 David Dyck +# + Made "x @INC" work like it used to +# +# Changes: 1.12: May 24, 2001 Daniel Lewart +# + Fixed warnings generated by "O" (Show debugger options) +# + Fixed warnings generated by "p 42" (Print expression) +# Changes: 1.13: Jun 19, 2001 Scott.L.Miller@compaq.com +# + Added windowSize option +# Changes: 1.14: Oct 9, 2001 multiple +# + Clean up after itself on VMS (Charles Lane in 12385) +# + Adding "@ file" syntax (Peter Scott in 12014) +# + Debug reloading selfloaded stuff (Ilya Zakharevich in 11457) +# + $^S and other debugger fixes (Ilya Zakharevich in 11120) +# + Forgot a my() declaration (Ilya Zakharevich in 11085) +# Changes: 1.15: Nov 6, 2001 Michael G Schwern +# + Updated 1.14 change log +# + Added *dbline explainatory comments +# + Mentioning perldebguts man page #################################################################### # Needed for the statement after exec(): @@ -276,14 +333,15 @@ $trace = $signal = $single = 0; # Uninitialized warning suppression # (local $^W cannot help - other packages!). $inhibit_exit = $option{PrintRet} = 1; -@options = qw(hashDepth arrayDepth DumpDBFiles DumpPackages DumpReused +@options = qw(hashDepth arrayDepth dumpDepth + 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 ImmediateStop bareStringify CreateTTY - RemotePort); + RemotePort windowSize); %optionVars = ( hashDepth => \$dumpvar::hashDepth, @@ -303,6 +361,7 @@ $inhibit_exit = $option{PrintRet} = 1; maxTraceLen => \$maxtrace, ImmediateStop => \$ImmediateStop, RemotePort => \$remoteport, + windowSize => \$window, ); %optionAction = ( @@ -333,8 +392,8 @@ $inhibit_exit = $option{PrintRet} = 1; # These guys may be defined in $ENV{PERL5DB} : $rl = 1 unless defined $rl; -$warnLevel = 0 unless defined $warnLevel; -$dieLevel = 0 unless defined $dieLevel; +$warnLevel = 1 unless defined $warnLevel; +$dieLevel = 1 unless defined $dieLevel; $signalLevel = 1 unless defined $signalLevel; $pre = [] unless defined $pre; $post = [] unless defined $post; @@ -345,12 +404,12 @@ warnLevel($warnLevel); dieLevel($dieLevel); signalLevel($signalLevel); -&pager( - (defined($ENV{PAGER}) - ? $ENV{PAGER} - : ($^O eq 'os2' - ? 'cmd /c more' - : 'more'))) unless defined $pager; +pager( + defined $ENV{PAGER} ? $ENV{PAGER} : + eval { require Config } && + defined $Config::Config{pager} ? $Config::Config{pager} + : 'more' + ) unless defined $pager; setman(); &recallCommand("!") unless defined $prc; &shellBang("!") unless defined $psh; @@ -495,6 +554,10 @@ if ($notty) { $console = undef; } + if ($^O eq 'NetWare') { + $console = undef; + } + # Around a bug: if (defined $ENV{OS2_SHELL} and ($slave_editor or $ENV{WINDOWID})) { # In OS/2 $console = undef; @@ -514,34 +577,29 @@ if ($notty) { ); if (!$OUT) { die "Unable to connect to remote host: $remoteport\n"; } $IN = $OUT; - } elsif ($CreateTTY & 4) { - create_IN_OUT(4); } else { - if (defined $console) { + create_IN_OUT(4) if $CreateTTY & 4; + if ($console) { my ($i, $o) = split /,/, $console; $o = $i unless defined $o; open(IN,"+<$i") || open(IN,"<$i") || open(IN,"<&STDIN"); open(OUT,"+>$o") || open(OUT,">$o") || open(OUT,">&STDERR") || open(OUT,">&STDOUT"); # so we don't dongle stdout - } else { + } elsif (not defined $console) { 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; + $IN = \*IN, $OUT = \*OUT if $console or not defined $console; } - select($OUT); + my $previous = select($OUT); $| = 1; # for DB::OUT - select(STDOUT); + select($previous); $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) { if ($term_pid eq '-1') { @@ -710,7 +768,7 @@ EOP next CMD; } } - $cmd =~ /^q$/ && ($fall_off_end = 1) && exit $?; + $cmd =~ /^q$/ && ($fall_off_end = 1) && clean_ENV() && exit $?; $cmd =~ /^h$/ && do { print_help($help); next CMD; }; @@ -768,7 +826,12 @@ EOP select ($savout); next CMD; }; $cmd =~ s/^x\b/ / && do { # So that will be evaled - $onetimeDump = 'dump'; }; + $onetimeDump = 'dump'; + # handle special "x 3 blah" syntax + if ($cmd =~ s/^\s*(\d+)(?=\s)/ /) { + $onetimedumpDepth = $1; + } + }; $cmd =~ s/^m\s+([\w:]+)\s*$/ / && do { methods($1); next CMD}; $cmd =~ s/^m\b/ / && do { # So this will be evaled @@ -878,6 +941,7 @@ EOP $i = $end; } else { for (; $i <= $end; $i++) { + my ($stop,$action); ($stop,$action) = split(/\0/, $dbline{$i}) if $dbline{$i}; $arrow = ($i==$line @@ -1191,6 +1255,7 @@ EOP for (@ini_INC) { push @flags, '-I', $_; } + push @flags, '-T' if ${^TAINT}; # Arrange for setting the old INC: set_list("PERLDB_INC", @ini_INC); if ($0 eq '-e') { @@ -1214,7 +1279,7 @@ EOP *dbline = $main::{'_<' . $file}; next unless %dbline or $postponed_file{$file}; (push @hard, $file), next - if $file =~ /^\(eval \d+\)$/; + if $file =~ /^\(\w*eval/; my @add; @add = %{$postponed_file{$file}} if $postponed_file{$file}; @@ -1421,6 +1486,14 @@ EOP } } next CMD; }; + $cmd =~ /^\@\s*(.*\S)/ && do { + if (open my $fh, $1) { + push @cmdfhs, $fh; + } + else { + &warn("Can't execute `$1': $!\n"); + } + next CMD; }; $cmd =~ /^\|\|?\s*[^|]/ && do { if ($pager =~ /^\|/) { open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT"); @@ -1459,6 +1532,7 @@ EOP $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval; if ($onetimeDump) { $onetimeDump = undef; + $onetimedumpDepth = undef; } elsif ($term_pid == $$) { print $OUT "\n"; } @@ -1623,7 +1697,8 @@ sub break_on_line { my $pl = ''; die "Line $i$filename_error not breakable.\n" if $dbline[$i] == 0; $had_breakpoints{$filename} |= 1; - $dbline{$i} =~ s/^[^\0]*/$cond/ if $dbline{$i}; + if ($dbline{$i}) { $dbline{$i} =~ s/^[^\0]*/$cond/; } + else { $dbline{$i} = $cond; } } sub cmd_b_line { @@ -1705,33 +1780,6 @@ sub print_lineinfo { # The following takes its argument via $evalarg to preserve current @_ -sub eval { - # 'my' would make it visible from user code - # but so does local! --tchrist [... into @DB::res, not @res. IZ] - local @res; - { - local $otrace = $trace; - local $osingle = $single; - local $od = $^D; - { ($evalarg) = $evalarg =~ /(.*)/s; } - @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug - $trace = $otrace; - $single = $osingle; - $^D = $od; - } - my $at = $@; - local $saved[0]; # Preserve the old value of $@ - eval { &DB::save }; - if (defined($at)) { - print $OUT $at; - } elsif ($onetimeDump eq 'dump') { - dumpit($OUT, \@res); - } elsif ($onetimeDump eq 'methods') { - methods($res[0]); - } - @res; -} - sub postponed_sub { my $subname = shift; if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) { @@ -1790,7 +1838,10 @@ sub dumpit { do 'dumpvar.pl'; } if (defined &main::dumpValue) { - &main::dumpValue(shift); + my $v = shift; + my $maxdepth = shift || $option{dumpDepth}; + $maxdepth = -1 unless defined $maxdepth; # -1 means infinite depth + &main::dumpValue($v, $maxdepth); } else { print $OUT "dumpvar.pl not available.\n"; } @@ -1997,24 +2048,26 @@ sub xterm_get_fork_TTY { return $tty; } -# This one resets $IN, $OUT itself +# This example function resets $IN, $OUT itself sub os2_get_fork_TTY { - $^F = 40; # XXXX Fixme! + local $^F = 40; # XXXX Fixme! my ($in1, $out1, $in2, $out2); # Having -d in PERL5OPT would lead to a disaster... local $ENV{PERL5OPT} = $ENV{PERL5OPT} if $ENV{PERL5OPT}; $ENV{PERL5OPT} =~ s/(?:^|(?<=\s))-d\b// if $ENV{PERL5OPT}; $ENV{PERL5OPT} =~ s/(?:^|(?<=\s))-d\B/-/ if $ENV{PERL5OPT}; - print $OUT "Making PERL5OPT->`$ENV{PERL5OPT}'.\n" if $ENV{PERL5OPT}; + print $OUT "Making kid PERL5OPT->`$ENV{PERL5OPT}'.\n" if $ENV{PERL5OPT}; (my $name = $0) =~ s,^.*[/\\],,s; - if ( pipe $in1, $out1 and pipe $in2, $out2 and + my @args; + if ( pipe $in1, $out1 and pipe $in2, $out2 # system P_SESSION will fail if there is another process # in the same session with a "dependent" asynchronous child session. - (($kpid = CORE::system 4, $^X, '-we', <<'ES', fileno $in1, fileno $out2, "Daughter Perl debugger $pids $name") >= 0 or warn "system P_SESSION: $!, $^E" and 0) # P_SESSION -use Term::ReadKey; + and @args = ($rl, fileno $in1, fileno $out2, + "Daughter Perl debugger $pids $name") and + (($kpid = CORE::system 4, $^X, '-we', <<'ES', @args) >= 0 # P_SESSION use OS2::Process; -my $in = shift; # Read from here and pass through +my ($rl, $in) = (shift, shift); # Read from $in and pass through set_title pop; system P_NOWAIT, $^X, '-we', <&=$out" or die "Cannot open &=$out for writing: $!"; select OUT; $| = 1; -ReadMode 4; # Nodelay on kbd. Pipe is automatically nodelay... -print while sysread STDIN, $_, 1<<16; +require Term::ReadKey if $rl; +Term::ReadKey::ReadMode(4) if $rl; # Nodelay on kbd. Pipe is automatically nodelay... +print while sysread STDIN, $_, 1<<($rl ? 16 : 0); ES + or warn "system P_SESSION: $!, $^E" and 0) and close $in1 and close $out2 ) { - $pidprompt = ''; # Shown anyway in titlebar + $pidprompt = ''; # Shown anyway in titlebar reset_IN_OUT($in2, $out1); $tty = '*reset*'; return ''; # Indicate that reset_IN_OUT is called @@ -2063,6 +2118,8 @@ EOP EOP } elsif ($in ne '') { TTY($in); + } else { + $console = ''; # Indicate no need to open-from-the-console } undef $fork_TTY; } @@ -2093,6 +2150,11 @@ sub readline { } local $frame = 0; local $doret = -2; + while (@cmdfhs) { + my $line = CORE::readline($cmdfhs[-1]); + defined $line ? (print $OUT ">> $line" and return $line) + : close pop @cmdfhs; + } if (ref $OUT and UNIVERSAL::isa($OUT, 'IO::Socket::INET')) { $OUT->write(join('', @_)); my $stuff; @@ -2128,6 +2190,7 @@ sub option_val { } else { $val = $option{$opt}; } + $val = $default unless defined $val; $val } @@ -2136,7 +2199,7 @@ sub parse_options { # too dangerous to let intuitive usage overwrite important things # defaultion should never be the default my %opt_needs_val = map { ( $_ => 1 ) } qw{ - arrayDepth hashDepth LineInfo maxTraceLen ornaments + dumpDepth arrayDepth hashDepth LineInfo maxTraceLen ornaments windowSize pager quote ReadLine recallCommand RemotePort ShellBang TTY }; while (length) { @@ -2275,7 +2338,7 @@ sub TTY { } &warn("Too late to set TTY, enabled on next `R'!\n") if $term and @_; # Useful if done through PERLDB_OPTS: - $tty = shift if @_; + $console = $tty = shift if @_; $tty or $console; } @@ -2474,6 +2537,7 @@ B<$psh$psh> I Run cmd in a subprocess (reads from DB::IN, writes to DB::O . ( $rc eq $sh ? "" : " B<$psh> [I] Run I in subshell (forces \"\$SHELL -c 'cmd'\")." ) . " See 'B I' too. +B<@>I Execute I containing debugger commands (may nest). B I<-number> Display last number commands (default all). B

I Same as \"I\" in current package. B<|>I Run debugger command, piping DB::OUT to current pager. @@ -2669,7 +2733,8 @@ sub dbdie { if ($dieLevel < 2) { die @_ if $^S; # in eval propagate } - eval { require Carp } if defined $^S; # If error/warning during compilation, + # No need to check $^S, eval is much more robust nowadays + eval { require Carp }; #if defined $^S;# If error/warning during compilation, # require may be broken. die(@_, "\nCannot print stack trace, load with -MCarp option to see stack") @@ -2679,7 +2744,13 @@ sub dbdie { # inside DB::DB, but not in Carp). my ($mysingle,$mytrace) = ($single,$trace); $single = 0; $trace = 0; - my $mess = Carp::longmess(@_); + my $mess = "@_"; + { + package Carp; # Do not include us in the list + eval { + $mess = Carp::longmess(@_); + }; + } ($single,$trace) = ($mysingle,$mytrace); die $mess; } @@ -2741,6 +2812,7 @@ sub CvGV_name { sub CvGV_name_or_bust { my $in = shift; return if $skipCvGV; # Backdoor to avoid problems if XS broken... + return unless ref $in; $in = \&$in; # Hard reference... eval {require Devel::Peek; 1} or return; my $gv = Devel::Peek::CvGV($in) or return; @@ -2794,7 +2866,7 @@ sub methods_via { } sub setman { - $doccmd = $^O !~ /^(?:MSWin32|VMS|os2|dos|amigaos|riscos|MacOS)\z/s + $doccmd = $^O !~ /^(?:MSWin32|VMS|os2|dos|amigaos|riscos|MacOS|NetWare)\z/s ? "man" # O Happy Day! : "perldoc"; # Alas, poor unfortunates } @@ -2973,6 +3045,14 @@ sub end_report { print $OUT "Use `q' to quit or `R' to restart. `h q' for details.\n" } +sub clean_ENV { + if (defined($ini_pids)) { + $ENV{PERLDB_PIDS} = $ini_pids; + } else { + delete($ENV{PERLDB_PIDS}); + } +} + END { $finished = 1 if $inhibit_exit; # So that some keys may be disabled. $fall_off_end = 1 unless $inhibit_exit;