X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2Fperl5db.pl;h=4e7ff9e28a533a8e19a30e484e8511ee7ee2eb17;hb=6b14ceb78325f07f9267f4d0b22adc748311a9a0;hp=a1eaf09a38d309bdadb0f2d49b65eb4103db133b;hpb=43c8efd8a96392ed0e720af5c06ab52c6d53fcc4;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/perl5db.pl b/lib/perl5db.pl index a1eaf09..4e7ff9e 100644 --- a/lib/perl5db.pl +++ b/lib/perl5db.pl @@ -2,6 +2,41 @@ package DB; # Debugger for Perl 5.00x; perl5db.pl patch level: +# 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"; @@ -298,7 +333,8 @@ $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 @@ -368,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; @@ -543,21 +579,19 @@ if ($notty) { $IN = $OUT; } else { create_IN_OUT(4) if $CreateTTY & 4; - if (defined $console) { + 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; } my $previous = select($OUT); $| = 1; # for DB::OUT @@ -792,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 @@ -1216,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') { @@ -1492,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"; } @@ -1739,32 +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 ($at) { - print $OUT $at; - } elsif ($onetimeDump) { - dumpit($OUT, \@res) if $onetimeDump eq 'dump'; - methods($res[0]) if $onetimeDump eq 'methods'; - } - @res; -} - sub postponed_sub { my $subname = shift; if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) { @@ -1823,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"; } @@ -2030,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 @@ -2096,6 +2118,8 @@ EOP EOP } elsif ($in ne '') { TTY($in); + } else { + $console = ''; # Indicate no need to open-from-the-console } undef $fork_TTY; } @@ -2175,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 windowSize + dumpDepth arrayDepth hashDepth LineInfo maxTraceLen ornaments windowSize pager quote ReadLine recallCommand RemotePort ShellBang TTY }; while (length) {