X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2Fperl5db.pl;h=b3daaf55abdffa2aee2055ef190609c931dc3b7a;hb=b595cd4b73a6e1bd45865d6446c34d4019c740d1;hp=9f5d3b1258c079a49769372a187df6fab08535e7;hpb=878090d5582120ef9336936d4fc06895b4fd242a;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/perl5db.pl b/lib/perl5db.pl index 9f5d3b1..b3daaf5 100644 --- a/lib/perl5db.pl +++ b/lib/perl5db.pl @@ -221,7 +221,7 @@ file. =item * ReadLine -If false, a dummy ReadLine is used, so you can debug +if false, a dummy ReadLine is used, so you can debug ReadLine applications. =item * NonStop @@ -237,6 +237,16 @@ pipe, a short "emacs like" message is used. host:port to connect to on remote host for remote debugging. +=item * HistFile + +file to store session history to. There is no default and so no +history file is written unless this variable is explicitly set. + +=item * HistSize + +number of commands to store to the file specified in C. +Default is 100. + =back =head3 SAMPLE RCFILE @@ -501,7 +511,7 @@ package DB; BEGIN {eval 'use IO::Handle'}; # Needed for flush only? breaks under miniperl # Debugger for Perl 5.00x; perl5db.pl patch level: -$VERSION = 1.29; +$VERSION = '1.33'; $header = "perl5db.pl version $VERSION"; @@ -929,6 +939,19 @@ sub eval { # + Added threads support (inc. e and E commands) # Changes: 1.29: Nov 28, 2006 Bo Lindbergh # + Added macosx_get_fork_TTY support +# Changes: 1.30: Mar 06, 2007 Andreas Koenig +# + Added HistFile, HistSize +# Changes: 1.31 +# + Remove support for assertions and -A +# + stop NEXT::AUTOLOAD from emitting warnings under the debugger. RT #25053 +# + "update for Mac OS X 10.5" [finding the tty device] +# + "What I needed to get the forked debugger to work" [on VMS] +# + [perl #57016] debugger: o warn=0 die=0 ignored +# + Note, but don't use, PERLDBf_SAVESRC +# + Fix #7013: lvalue subs not working inside debugger +# Changes: 1.32: Jun 03, 2009 Jonathan Leto +# + Fix bug where a key _< with undefined value was put into the symbol table +# + when the $filename variable is not set ######################################################################## =head1 DEBUGGER INITIALIZATION @@ -955,15 +978,6 @@ BEGIN { $^W = 0; } # Switch compilation warnings off until another BEGIN. -# test if assertions are supported and actived: -BEGIN { - $ini_assertion = eval "sub asserting_test : assertion {1}; 1"; - - # $ini_assertion = undef => assertions unsupported, - # " = 1 => assertions supported - # print "\$ini_assertion=$ini_assertion\n"; -} - local ($^W) = 0; # Switch run-time warnings off during init. =head2 THREADS SUPPORT @@ -1042,8 +1056,9 @@ warn( # Do not ;-) ) if 0; +# without threads, $filename is not defined until DB::DB is called foreach my $k (keys (%INC)) { - &share(\$main::{'_<'.$filename}); + &share(\$main::{'_<'.$filename}) if defined $filename; }; # Command-line + PERLLIB: @@ -1077,7 +1092,7 @@ are to be accepted. =cut @options = qw( - CommandSet + CommandSet HistFile HistSize hashDepth arrayDepth dumpDepth DumpDBFiles DumpPackages DumpReused compactDump veryCompact quote @@ -1090,10 +1105,10 @@ are to be accepted. signalLevel warnLevel dieLevel inhibit_exit ImmediateStop bareStringify CreateTTY RemotePort windowSize - DollarCaretP OnlyAssertions WarnAssertions + DollarCaretP ); -@RememberOnROptions = qw(DollarCaretP OnlyAssertions); +@RememberOnROptions = qw(DollarCaretP); =pod @@ -1122,7 +1137,8 @@ state. ImmediateStop => \$ImmediateStop, RemotePort => \$remoteport, windowSize => \$window, - WarnAssertions => \$warnassertions, + HistFile => \$histfile, + HistSize => \$histsize, ); =pod @@ -1151,7 +1167,6 @@ option. ornaments => \&ornaments, RemotePort => \&RemotePort, DollarCaretP => \&DollarCaretP, - OnlyAssertions=> \&OnlyAssertions, ); =pod @@ -1237,7 +1252,7 @@ signalLevel($signalLevel); =pod The pager to be used is needed next. We try to get it from the -environment first. if it's not defined there, we try to find it in +environment first. If it's not defined there, we try to find it in the Perl C. If it's not there, we default to C. We then call the C function to save the pager name. @@ -1360,7 +1375,9 @@ running interactively, this is C<.perldb>; if not, it's C. # As noted, this test really doesn't check accurately that the debugger # is running at a terminal or not. -if ( -e "/dev/tty" ) { # this is the wrong metric! +my $dev_tty = '/dev/tty'; + $dev_tty = 'TT:' if ($^O eq 'VMS'); +if ( -e $dev_tty ) { # this is the wrong metric! $rcfile = ".perldb"; } else { @@ -1833,7 +1850,7 @@ $I_m_init = 1; This gigantic subroutine is the heart of the debugger. Called before every statement, its job is to determine if a breakpoint has been reached, and stop if so; read commands from the user, parse them, and execute -them, and hen send execution off to the next statement. +them, and then send execution off to the next statement. Note that the order in which the commands are processed is very important; some commands earlier in the loop will actually alter the C<$cmd> variable @@ -3622,6 +3639,8 @@ arguments with which the subroutine was invoked =cut sub sub { + # Do not use a regex in this subroutine -> results in corrupted memory + # See: [perl #66110] # lock ourselves under threads lock($DBGR); @@ -3630,14 +3649,14 @@ sub sub { # sub's return value in (if needed), and an array to put the sub's # return value in (if needed). my ( $al, $ret, @ret ) = ""; - if ($sub =~ /^threads::new$/ && $ENV{PERL5DB_THREADED}) { + if ($sub eq 'threads::new' && $ENV{PERL5DB_THREADED}) { print "creating new thread\n"; } - # If the last ten characters are C'::AUTOLOAD', note we've traced + # 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' ) { - $al = " for $$sub"; + $al = " for $$sub" if defined $$sub; } # We stack the stack pointer and then increment it to protect us @@ -3683,17 +3702,7 @@ sub 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. - if ($assertion) { - $assertion = 0; - eval { @ret = &$sub; }; - if ($@) { - print $OUT $@; - $signal = 1 unless $warnassertions; - } - } - else { - @ret = &$sub; - } + @ret = &$sub; # Pop the single-step value back off the stack. $single |= $stack[ $stack_depth-- ]; @@ -3734,32 +3743,17 @@ sub sub { # Scalar context. else { - if ($assertion) { - $assertion = 0; - eval { + if ( defined wantarray ) { - # Save the value if it's wanted at all. - $ret = &$sub; - }; - if ($@) { - print $OUT $@; - $signal = 1 unless $warnassertions; - } - $ret = undef unless defined wantarray; - } - else { - if ( defined wantarray ) { - - # Save the value if it's wanted at all. - $ret = &$sub; - } - else { + # Save the value if it's wanted at all. + $ret = &$sub; + } + else { - # Void return, explicitly. - &$sub; - undef $ret; - } - } # if assertion + # Void return, explicitly. + &$sub; + undef $ret; + } # Pop the single-step value off the stack. $single |= $stack[ $stack_depth-- ]; @@ -3796,6 +3790,69 @@ sub sub { } ## end else [ if (wantarray) } ## end sub sub +sub lsub : lvalue { + + # lock ourselves under threads + lock($DBGR); + + # Whether or not the autoloader was running, a scalar to put the + # sub's return value in (if needed), and an array to put the sub's + # return value in (if needed). + my ( $al, $ret, @ret ) = ""; + if ($sub =~ /^threads::new$/ && $ENV{PERL5DB_THREADED}) { + print "creating new thread\n"; + } + + # If the last ten characters are C'::AUTOLOAD', note we've traced + # into AUTOLOAD for $sub. + if ( length($sub) > 10 && substr( $sub, -10, 10 ) eq '::AUTOLOAD' ) { + $al = " for $$sub"; + } + + # We stack the stack pointer and then increment it to protect us + # from a situation that might unwind a whole bunch of call frames + # at once. Localizing the stack pointer means that it will automatically + # unwind the same amount when multiple stack frames are unwound. + local $stack_depth = $stack_depth + 1; # Protect from non-local exits + + # Expand @stack. + $#stack = $stack_depth; + + # Save current single-step setting. + $stack[-1] = $single; + + # Turn off all flags except single-stepping. + $single &= 1; + + # If we've gotten really deeply recursed, turn on the flag that will + # make us stop with the 'deep recursion' message. + $single |= 4 if $stack_depth == $deep; + + # If frame messages are on ... + ( + $frame & 4 # Extended frame entry message + ? ( + print_lineinfo( ' ' x ( $stack_depth - 1 ), "in " ), + + # Why -1? But it works! :-( + # Because print_trace will call add 1 to it and then call + # dump_trace; this results in our skipping -1+1 = 0 stack frames + # in dump_trace. + print_trace( $LINEINFO, -1, 1, 1, "$sub$al" ) + ) + : print_lineinfo( ' ' x ( $stack_depth - 1 ), "entering $sub$al\n" ) + + # standard frame entry message + ) + if $frame; + + # Pop the single-step value back off the stack. + $single |= $stack[ $stack_depth-- ]; + + # call the original lvalue sub. + &$sub; +} + =head1 EXTENDED COMMAND HANDLING AND THE COMMAND API In Perl 5.8.0, there was a major realignment of the commands and what they did, @@ -4778,30 +4835,21 @@ Display the (nested) parentage of the module or object given. sub cmd_i { my $cmd = shift; my $line = shift; - eval { require Class::ISA }; - if ($@) { - &warn( $@ =~ /locate/ - ? "Class::ISA module not found - please install\n" - : $@ ); - } - else { - ISA: - foreach my $isa ( split( /\s+/, $line ) ) { - $evalarg = $isa; - ($isa) = &eval; - no strict 'refs'; - print join( - ', ', - map { # snaffled unceremoniously from Class::ISA - "$_" - . ( - defined( ${"$_\::VERSION"} ) - ? ' ' . ${"$_\::VERSION"} - : undef ) - } Class::ISA::self_and_super_path(ref($isa) || $isa) - ); - print "\n"; - } + foreach my $isa ( split( /\s+/, $line ) ) { + $evalarg = $isa; + ($isa) = &eval; + no strict 'refs'; + print join( + ', ', + map { + "$_" + . ( + defined( ${"$_\::VERSION"} ) + ? ' ' . ${"$_\::VERSION"} + : undef ) + } @{mro::get_linear_isa(ref($isa) || $isa)} + ); + print "\n"; } } ## end sub cmd_i @@ -5329,38 +5377,6 @@ sub cmd_W { These are general support routines that are used in a number of places throughout the debugger. -=over 4 - -=item cmd_P - -Something to do with assertions - -=back - -=cut - -sub cmd_P { - unless ($ini_assertion) { - print $OUT "Assertions not supported in this Perl interpreter\n"; - } else { - if ( $cmd =~ /^.\b\s*([+-]?)\s*(~?)\s*(\w+(\s*\|\s*\w+)*)\s*$/ ) { - my ( $how, $neg, $flags ) = ( $1, $2, $3 ); - my $acu = parse_DollarCaretP_flags($flags); - if ( defined $acu ) { - $acu = ~$acu if $neg; - if ( $how eq '+' ) { $^P |= $acu } - elsif ( $how eq '-' ) { $^P &= ~$acu } - else { $^P = $acu } - } - - # else { print $OUT "undefined acu\n" } - } - my $expanded = expand_DollarCaretP_flags($^P); - print $OUT "Internal Perl debugger flags:\n\$^P=$expanded\n"; - $expanded; - } -} - =head2 save save() saves the user's versions of globals that would mess us up in C<@saved>, @@ -6066,6 +6082,8 @@ sub setterm { $term->MinLine(2); + &load_hist(); + if ( $term->Features->{setHistory} and "@hist" ne "?" ) { $term->SetHistory(@hist); } @@ -6076,6 +6094,34 @@ sub setterm { $term_pid = $$; } ## end sub setterm +sub load_hist { + $histfile //= option_val("HistFile", undef); + return unless defined $histfile; + open my $fh, "<", $histfile or return; + local $/ = "\n"; + @hist = (); + while (<$fh>) { + chomp; + push @hist, $_; + } + close $fh; +} + +sub save_hist { + return unless defined $histfile; + eval { require File::Path } or return; + eval { require File::Basename } or return; + File::Path::mkpath(File::Basename::dirname($histfile)); + open my $fh, ">", $histfile or die "Could not open '$histfile': $!"; + $histsize //= option_val("HistSize",100); + my @copy = grep { $_ ne '?' } @hist; + my $start = scalar(@copy) > $histsize ? scalar(@copy)-$histsize : 0; + for ($start .. $#copy) { + print $fh "$copy[$_]\n"; + } + close $fh or die "Could not write '$histfile': $!"; +} + =head1 GET_FORK_TTY EXAMPLE FUNCTIONS When the process being debugged forks, or the process invokes a command @@ -6124,6 +6170,16 @@ qq[3>&1 xterm -title "Daughter Perl debugger $pids $name" -e sh -c 'tty 1>&3;\ $pidprompt = ''; # Shown anyway in titlebar + # We need $term defined or we can not switch to the newly created xterm + if ($tty ne '' && !defined $term) { + eval { require Term::ReadLine } or die $@; + if ( !$rl ) { + $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT; + } + else { + $term = new Term::ReadLine 'perldb', $IN, $OUT; + } + } # There's our new TTY. return $tty; } ## end sub xterm_get_fork_TTY @@ -6164,21 +6220,38 @@ a new window. # it creates, but since it appears frontmost and windows are enumerated # front to back, we can use "first window" === "window 1". # -# There's no direct accessor for the tty device name, so we fiddle -# with the window title options until it says what we want. -# # Since "do script" is implemented by supplying the argument (plus a # return character) as terminal input, there's a potential race condition # where the debugger could beat the shell to reading the command. # To prevent this, we wait for the screen to clear before proceeding. # -# Tested and found to be functional in Mac OS X 10.3.9 and 10.4.8. +# 10.3 and 10.4: +# There's no direct accessor for the tty device name, so we fiddle +# with the window title options until it says what we want. +# +# 10.5: +# There _is_ a direct accessor for the tty device name, _and_ there's +# a new possible component of the window title (the name of the settings +# set). A separate version is needed. -sub macosx_get_fork_TTY -{ - my($pipe,$tty); +my @script_versions= - return unless open($pipe,'-|','/usr/bin/osascript','-e',<<'__SCRIPT__'); + ([237, <<'__LEOPARD__'], +tell application "Terminal" + do script "clear;exec sleep 100000" + tell first tab of first window + copy tty to thetty + set custom title to "forked perl debugger" + set title displays custom title to true + repeat while (length of first paragraph of (get contents)) > 0 + delay 0.1 + end repeat + end tell +end tell +thetty +__LEOPARD__ + + [100, <<'__JAGUAR_TIGER__'], tell application "Terminal" do script "clear;exec sleep 100000" tell first window @@ -6188,16 +6261,31 @@ tell application "Terminal" set title displays device name to true set title displays custom title to true set custom title to "" - copy name to thetitle + copy "/dev/" & name to thetty set custom title to "forked perl debugger" repeat while (length of first paragraph of (get contents)) > 0 delay 0.1 end repeat end tell end tell -"/dev/" & thetitle -__SCRIPT__ +thetty +__JAGUAR_TIGER__ + +); + +sub macosx_get_fork_TTY +{ + my($version,$script,$pipe,$tty); + return unless $version=$ENV{TERM_PROGRAM_VERSION}; + foreach my $entry (@script_versions) { + if ($version>=$entry->[0]) { + $script=$entry->[1]; + last; + } + } + return unless defined($script); + return unless open($pipe,'-|','/usr/bin/osascript','-e',$script); $tty=readline($pipe); close($pipe); return unless defined($tty) && $tty =~ m(^/dev/); @@ -6758,18 +6846,6 @@ we go ahead and set C<$console> and C<$tty> to the file indicated. sub TTY { - # With VMS we can get here with $term undefined, so we do not - # switch to this terminal. There may be a better place to make - # sure that $term is defined on VMS - if ( @_ and ($^O eq 'VMS') and !defined($term) ) { - eval { require Term::ReadLine } or die $@; - if ( !$rl ) { - $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT; - } - else { - $term = new Term::ReadLine 'perldb', $IN, $OUT; - } - } if ( @_ and $term and $term->Features->{newTTY} ) { # This terminal supports switching to a new TTY. @@ -6902,33 +6978,6 @@ sub DollarCaretP { expand_DollarCaretP_flags($^P); } -sub OnlyAssertions { - if ($term) { - &warn("Too late to set up OnlyAssertions mode, enabled on next 'R'!\n") - if @_; - } - if (@_) { - unless ( defined $ini_assertion ) { - if ($term) { - &warn("Current Perl interpreter doesn't support assertions"); - } - return 0; - } - if (shift) { - unless ($ini_assertion) { - print "Assertions will be active on next 'R'!\n"; - $ini_assertion = 1; - } - $^P &= ~$DollarCaretP_flags{PERLDBf_SUB}; - $^P |= $DollarCaretP_flags{PERLDBf_ASSERTION}; - } - else { - $^P |= $DollarCaretP_flags{PERLDBf_SUB}; - } - } - !( $^P & $DollarCaretP_flags{PERLDBf_SUB} ) || 0; -} - =head2 C Set up the C<$pager> variable. Adds a pipe to the front unless there's one @@ -7191,7 +7240,6 @@ B I Prints nested parents of given class. B Display current thread id. B Display all thread ids the current one will be identified: . B [I [I]] List lexicals in higher scope . Vars same as B. -B

Something to do with assertions... B<<> ? List Perl commands to run before each prompt. B<<> I Define Perl command to run before each prompt. @@ -7238,7 +7286,7 @@ B Pure-man-restart of debugger, some of debugger state B [I] ... Set boolean option to true B [IB] Query options B [IB<=>I] [I=B<\">IB<\">] ... - Set options. Use quotes in spaces in value. + Set options. Use quotes if spaces in value. I, I chars used to recall command or spawn shell; I program for output of \"|cmd\"; I run Tk while prompting (with ReadLine); @@ -7414,7 +7462,7 @@ B Pure-man-restart of debugger, some of debugger state B [I] ... Set boolean option to true B [IB] Query options B [IB<=>I] [I=B<\">IB<\">] ... - Set options. Use quotes in spaces in value. + Set options. Use quotes if spaces in value. I, I chars used to recall command or spawn shell; I program for output of \"|cmd\"; I run Tk while prompting (with ReadLine); @@ -7755,6 +7803,8 @@ sub warnLevel { } elsif ($prevwarn) { $SIG{__WARN__} = $prevwarn; + } else { + undef $SIG{__WARN__}; } } ## end if (@_) $warnLevel; @@ -7796,6 +7846,9 @@ sub dieLevel { elsif ($prevdie) { $SIG{__DIE__} = $prevdie; print $OUT "Default die handler restored.\n"; + } else { + undef $SIG{__DIE__}; + print $OUT "Die handler removed.\n"; } } ## end if (@_) $dieLevel; @@ -7942,26 +7995,28 @@ sub methods_via { # This is a package that is contributing the methods we're about to print. my $prefix = shift; my $prepend = $prefix ? "via $prefix: " : ''; + my @to_print; + + # Extract from all the symbols in this class. + while (my ($name, $glob) = each %{"${class}::"}) { + # 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 + # to a subroutine reference, which can be tested by defined. + # $glob might also be the value -1 (from sub foo;) + # or (say) '$$' (from sub foo ($$);) + # \$glob will be SCALAR in both cases. + if ((ref $glob || ($glob && ref \$glob eq 'GLOB' && defined &$glob)) + && !$seen{$name}++) { + push @to_print, "$prepend$name\n"; + } + } - my $name; - for $name ( - - # Keep if this is a defined subroutine in this class. - grep { defined &{ ${"${class}::"}{$_} } } - - # Extract from all the symbols in this class. - sort keys %{"${class}::"} - ) { - - # If we printed this already, skip it. - next if $seen{$name}++; - - # Print the new method name. - local $\ = ''; - local $, = ''; - print $DB::OUT "$prepend$name\n"; - } ## end for $name (grep { defined... + local $\ = ''; + local $, = ''; + print $DB::OUT $_ foreach sort @to_print; + } # If the $crawl_upward argument is false, just quit here. return unless shift; @@ -8119,10 +8174,8 @@ my @pods = qw( lexwarn locale lol - machten macos macosx - mint modinstall modlib mod @@ -8137,7 +8190,6 @@ my @pods = qw( os2 os390 os400 - othrtut packtut plan9 pod @@ -8553,7 +8605,6 @@ If there's only one hit, and it's a package qualifier, and it's not equal to the =cut if ( $text =~ /^[\$@%]/ ) { # symbols (in $package + packages in main) - =pod =over 4 @@ -8577,6 +8628,32 @@ We set the prefix to the item's sigil, and trim off the sigil to get the text to $prefix = substr $text, 0, 1; $text = substr $text, 1; + my @out; + +=pod + +=item * + +We look for the lexical scope above DB::DB and auto-complete lexical variables +if PadWalker could be loaded. + +=cut + + if (not $text =~ /::/ and eval "require PadWalker; 1" and not $@ ) { + my $level = 1; + while (1) { + my @info = caller($level); + $level++; + $level = -1, last + if not @info; + last if $info[3] eq 'DB::DB'; + } + if ($level > 0) { + my $lexicals = PadWalker::peek_my($level); + push @out, grep /^\Q$prefix$text/, keys %$lexicals; + } + } + =pod =item * @@ -8585,7 +8662,7 @@ If the package is C<::> (C

), create an empty list; if it's something else, =cut - my @out = map "$prefix$_", grep /^\Q$text/, + push @out, map "$prefix$_", grep /^\Q$text/, ( grep /^_?[a-zA-Z]/, keys %$pack ), ( $pack eq '::' ? () : ( grep /::$/, keys %:: ) ); @@ -8718,9 +8795,12 @@ BEGIN { PERLDBf_GOTO => 0x80, # Report goto: call DB::goto PERLDBf_NAMEEVAL => 0x100, # Informative names for evals PERLDBf_NAMEANON => 0x200, # Informative names for anon subs - PERLDBf_ASSERTION => 0x400, # Debug assertion subs enter/exit - PERLDB_ALL => 0x33f, # No _NONAME, _GOTO, _ASSERTION + PERLDBf_SAVESRC => 0x400, # Save source lines into @{"_<$filename"} + PERLDB_ALL => 0x33f, # No _NONAME, _GOTO ); + # PERLDBf_LINE also enables the actions of PERLDBf_SAVESRC, so the debugger + # doesn't need to set it. It's provided for the benefit of profilers and + # other code analysers. %DollarCaretP_flags_r = reverse %DollarCaretP_flags; } @@ -8825,11 +8905,6 @@ sub restart { # If warn was on before, turn it on again. push @flags, '-w' if $ini_warn; - if ( $ini_assertion and @{^ASSERTING} ) { - push @flags, - ( map { /\:\^\(\?\:(.*)\)\$\)/ ? "-A$1" : "-A$_" } - @{^ASSERTING} ); - } # Rebuild the -I flags that were on the initial # command line. @@ -9041,8 +9116,12 @@ END { $fall_off_end = 1 unless $inhibit_exit; # Do not stop in at_exit() and destructors on exit: - $DB::single = !$fall_off_end && !$runnonstop; - DB::fake::at_exit() unless $fall_off_end or $runnonstop; + if ($fall_off_end or $runnonstop) { + &save_hist(); + } else { + $DB::single = 1; + DB::fake::at_exit(); + } } ## end END =head1 PRE-5.8 COMMANDS