X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2Fperl5db.pl;h=03ef2a2c6bf90a02a9e223d67e38099463de8990;hb=55ec0dff636c2a8ee5225314d7d46f928ab7f6da;hp=2b022d44808d99593453631e12230b21737b7fdb;hpb=cd1191f1e03afafd6ab152fc2335758ab5cd3235;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/perl5db.pl b/lib/perl5db.pl index 2b022d4..03ef2a2 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 @@ -498,10 +508,10 @@ where it has to go. package DB; -use IO::Handle; +BEGIN {eval 'use IO::Handle'}; # Needed for flush only? breaks under miniperl # Debugger for Perl 5.00x; perl5db.pl patch level: -$VERSION = 1.28; +$VERSION = '1.33'; $header = "perl5db.pl version $VERSION"; @@ -927,7 +937,22 @@ sub eval { # + wrapped restart and enabled rerun [-n] (go back n steps) command. # Changes: 1.28: Oct 12, 2004 Richard Foley # + 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 @@ -953,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 @@ -1040,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: @@ -1075,7 +1092,7 @@ are to be accepted. =cut @options = qw( - CommandSet + CommandSet HistFile HistSize hashDepth arrayDepth dumpDepth DumpDBFiles DumpPackages DumpReused compactDump veryCompact quote @@ -1088,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 @@ -1120,7 +1137,8 @@ state. ImmediateStop => \$ImmediateStop, RemotePort => \$remoteport, windowSize => \$window, - WarnAssertions => \$warnassertions, + HistFile => \$histfile, + HistSize => \$histsize, ); =pod @@ -1149,7 +1167,6 @@ option. ornaments => \&ornaments, RemotePort => \&RemotePort, DollarCaretP => \&DollarCaretP, - OnlyAssertions=> \&OnlyAssertions, ); =pod @@ -1235,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. @@ -1339,7 +1356,7 @@ else { # child debugger, and mark us as the parent, so we'll know to set up # more TTY's is we have to. $ENV{PERLDB_PIDS} = "$$"; - $pids = "{pid=$$}"; + $pids = "[pid=$$]"; $term_pid = $$; } @@ -1358,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 { @@ -1442,29 +1461,36 @@ if ( defined $ENV{PERLDB_OPTS} ) { The last thing we do during initialization is determine which subroutine is to be used to obtain a new terminal when a new debugger is started. Right now, -the debugger only handles X Windows and OS/2. +the debugger only handles X Windows, OS/2, and Mac OS X (darwin). =cut # Set up the get_fork_TTY subroutine to be aliased to the proper routine. # Works if you're running an xterm or xterm-like window, or you're on -# OS/2. This may need some expansion: for instance, this doesn't handle -# OS X Terminal windows. - -if ( - not defined &get_fork_TTY # no routine exists, - and defined $ENV{TERM} # and we know what kind - # of terminal this is, - and $ENV{TERM} eq 'xterm' # and it's an xterm, -# and defined $ENV{WINDOWID} # and we know what window this is, <- wrong metric - and defined $ENV{DISPLAY} # and what display it's on, - ) +# OS/2, or on Mac OS X. This may need some expansion. + +if (not defined &get_fork_TTY) # only if no routine exists { - *get_fork_TTY = \&xterm_get_fork_TTY; # use the xterm version + if (defined $ENV{TERM} # If we know what kind + # of terminal this is, + and $ENV{TERM} eq 'xterm' # and it's an xterm, + and defined $ENV{DISPLAY} # and what display it's on, + ) + { + *get_fork_TTY = \&xterm_get_fork_TTY; # use the xterm version + } + elsif ( $^O eq 'os2' ) { # If this is OS/2, + *get_fork_TTY = \&os2_get_fork_TTY; # use the OS/2 version + } + elsif ( $^O eq 'darwin' # If this is Mac OS X + and defined $ENV{TERM_PROGRAM} # and we're running inside + and $ENV{TERM_PROGRAM} + eq 'Apple_Terminal' # Terminal.app + ) + { + *get_fork_TTY = \&macosx_get_fork_TTY; # use the Mac OS X version + } } ## end if (not defined &get_fork_TTY... -elsif ( $^O eq 'os2' ) { # If this is OS/2, - *get_fork_TTY = \&os2_get_fork_TTY; # use the OS/2 version -} # untaint $^O, which may have been tainted by the last statement. # see bug [perl #24674] @@ -1824,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 @@ -1840,7 +1866,7 @@ sub DB { lock($DBGR); my $tid; if ($ENV{PERL5DB_THREADED}) { - $tid = eval { "[".threads->self->tid."]" }; + $tid = eval { "[".threads->tid."]" }; } # Check for whether we should be running continuously or not. @@ -2398,7 +2424,7 @@ Uses C to dump out the current values for selected variables. @vars = split( ' ', $2 ); # If main::dumpvar isn't here, get it. - do 'dumpvar.pl' unless defined &main::dumpvar; + do 'dumpvar.pl' || die $@ unless defined &main::dumpvar; if ( defined &main::dumpvar ) { # We got it. Turn off subroutine entry/exit messages @@ -2597,7 +2623,7 @@ above the current one and then displays then using C. and next CMD; # Load up dumpvar if we don't have it. If we can, that is. - do 'dumpvar.pl' unless defined &main::dumpvar; + do 'dumpvar.pl' || die $@ unless defined &main::dumpvar; defined &main::dumpvar or print $OUT "dumpvar.pl not available.\n" and next CMD; @@ -3427,8 +3453,10 @@ any variables we might want to address in the C package. $onetimedumpDepth = undef; } elsif ( $term_pid == $$ ) { - STDOUT->flush(); - STDERR->flush(); + eval { # May run under miniperl, when not available... + STDOUT->flush(); + STDERR->flush(); + }; # XXX If this is the master pid, print a newline. print $OUT "\n"; @@ -3623,10 +3651,10 @@ sub sub { 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 @@ -3672,17 +3700,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-- ]; @@ -3723,32 +3741,17 @@ sub sub { # Scalar context. else { - if ($assertion) { - $assertion = 0; - eval { - - # 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 ) { + 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-- ]; @@ -3785,6 +3788,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, @@ -4649,7 +4715,7 @@ sub cmd_e { print "threads not loaded($ENV{PERL5DB_THREADED}) please run the debugger with PERL5DB_THREADED=1 set in the environment\n"; } else { - my $tid = threads->self->tid; + my $tid = threads->tid; print "thread id: $tid\n"; } } ## end sub cmd_e @@ -4671,7 +4737,7 @@ sub cmd_E { print "threads not loaded($ENV{PERL5DB_THREADED}) please run the debugger with PERL5DB_THREADED=1 set in the environment\n"; } else { - my $tid = threads->self->tid; + my $tid = threads->tid; print "thread ids: ".join(', ', map { ($tid == $_->tid ? '<'.$_->tid.'>' : $_->tid) } threads->list )."\n"; @@ -5318,38 +5384,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>, @@ -5573,7 +5607,7 @@ sub dumpit { # Load dumpvar.pl unless we've already got the sub we need from it. unless ( defined &main::dumpValue ) { - do 'dumpvar.pl'; + do 'dumpvar.pl' or die $@; } # If the load succeeded (or we already had dumpvalue()), go ahead @@ -6055,6 +6089,8 @@ sub setterm { $term->MinLine(2); + &load_hist(); + if ( $term->Features->{setHistory} and "@hist" ne "?" ) { $term->SetHistory(@hist); } @@ -6065,6 +6101,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 @@ -6078,9 +6142,10 @@ is tasked with doing all the necessary operating system mojo to get a new TTY (and probably another window) and to direct the new debugger to read and write there. -The debugger provides C functions which work for X Windows and -OS/2. Other systems are not supported. You are encouraged to write -C functions which work for I platform and contribute them. +The debugger provides C functions which work for X Windows, +OS/2, and Mac OS X. Other systems are not supported. You are encouraged +to write C functions which work for I platform +and contribute them. =head3 C @@ -6112,6 +6177,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 @@ -6123,65 +6198,107 @@ XXX It behooves an OS/2 expert to write the necessary documentation for this! =cut # This example function resets $IN, $OUT itself -sub os2_get_fork_TTY { - local $^F = 40; # XXXX Fixme! +my $c_pipe = 0; +sub os2_get_fork_TTY { # A simplification of the following (and works without): local $\ = ''; - 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 kid PERL5OPT->`$ENV{PERL5OPT}'.\n" if $ENV{PERL5OPT}; - local $ENV{PERL5LIB} = $ENV{PERL5LIB} ? $ENV{PERL5LIB} : $ENV{PERLLIB}; - $ENV{PERL5LIB} = '' unless defined $ENV{PERL5LIB}; - $ENV{PERL5LIB} = join ';', @ini_INC, split /;/, $ENV{PERL5LIB}; ( my $name = $0 ) =~ s,^.*[/\\],,s; - my @args; + my %opt = ( title => "Daughter Perl debugger $pids $name", + ($rl ? (read_by_key => 1) : ()) ); + require OS2::Process; + my ($in, $out, $pid) = eval { OS2::Process::io_term(related => 0, %opt) } + or return; + $pidprompt = ''; # Shown anyway in titlebar + reset_IN_OUT($in, $out); + $tty = '*reset*'; + return ''; # Indicate that reset_IN_OUT is called +} ## end sub os2_get_fork_TTY - if ( - pipe $in1, $out1 - and pipe $in2, $out2 +=head3 C - # system P_SESSION will fail if there is another process - # in the same session with a "dependent" asynchronous child session. - and @args = ( - $rl, fileno $in1, fileno $out2, "Daughter Perl debugger $pids $name" - ) - and ( - ( $kpid = CORE::system 4, $^X, '-we', - <<'ES', @args ) >= 0 # P_SESSION -END {sleep 5 unless $loaded} -BEGIN {open STDIN, '&=$out" or die "Cannot open &=$out for writing: $!"; -select OUT; $| = 1; -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 - reset_IN_OUT( $in2, $out1 ); - $tty = '*reset*'; - return ''; # Indicate that reset_IN_OUT is called - } ## end if (pipe $in1, $out1 and... - return; -} ## end sub os2_get_fork_TTY +The Mac OS X version uses AppleScript to tell Terminal.app to create +a new window. + +=cut + +# Notes about Terminal.app's AppleScript support, +# (aka things that might break in future OS versions). +# +# The "do script" command doesn't return a reference to the new window +# it creates, but since it appears frontmost and windows are enumerated +# front to back, we can use "first window" === "window 1". +# +# 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. +# +# 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. + +my @script_versions= + + ([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 + set title displays shell path to false + set title displays window size to false + set title displays file name to false + set title displays device name to true + set title displays custom title to true + set custom title to "" + 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 +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/); + chomp $tty; + return $tty; +} =head2 C @@ -6231,9 +6348,10 @@ EOP EOP print_help(< - in B<\$DB::fork_TTY>, or define a function B returning this. + I know how to switch the output to a different window in xterms, OS/2 + consoles, and Mac OS X Terminal.app only. For a manual switch, put the name + of the created I in B<\$DB::fork_TTY>, or define a function + B returning this. 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. @@ -6735,18 +6853,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. @@ -6879,33 +6985,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 @@ -7168,7 +7247,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. @@ -7215,7 +7293,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); @@ -7391,7 +7469,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); @@ -7732,6 +7810,8 @@ sub warnLevel { } elsif ($prevwarn) { $SIG{__WARN__} = $prevwarn; + } else { + undef $SIG{__WARN__}; } } ## end if (@_) $warnLevel; @@ -7773,6 +7853,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; @@ -7919,26 +8002,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; @@ -8114,7 +8199,6 @@ my @pods = qw( os2 os390 os400 - othrtut packtut plan9 pod @@ -8530,7 +8614,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 @@ -8554,6 +8637,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 * @@ -8562,7 +8671,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 %:: ) ); @@ -8695,9 +8804,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; } @@ -8802,11 +8914,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. @@ -9018,8 +9125,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