BEGIN {eval 'use IO::Handle'}; # Needed for flush only? breaks under miniperl
# Debugger for Perl 5.00x; perl5db.pl patch level:
-$VERSION = 1.30;
+$VERSION = '1.33';
$header = "perl5db.pl version $VERSION";
# + Added macosx_get_fork_TTY support
# Changes: 1.30: Mar 06, 2007 Andreas Koenig <andk@cpan.org>
# + 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 <jonathan@leto.net>
+# + Fix bug where a key _< with undefined value was put into the symbol table
+# + when the $filename variable is not set
########################################################################
=head1 DEBUGGER INITIALIZATION
$^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
)
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:
signalLevel warnLevel dieLevel
inhibit_exit ImmediateStop bareStringify
CreateTTY RemotePort windowSize
- DollarCaretP OnlyAssertions WarnAssertions
+ DollarCaretP
);
-@RememberOnROptions = qw(DollarCaretP OnlyAssertions);
+@RememberOnROptions = qw(DollarCaretP);
=pod
ImmediateStop => \$ImmediateStop,
RemotePort => \$remoteport,
windowSize => \$window,
- WarnAssertions => \$warnassertions,
HistFile => \$histfile,
HistSize => \$histsize,
);
ornaments => \&ornaments,
RemotePort => \&RemotePort,
DollarCaretP => \&DollarCaretP,
- OnlyAssertions=> \&OnlyAssertions,
);
=pod
# 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 {
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
=cut
sub sub {
+ # Do not use a regex in this subroutine -> results in corrupted memory
+ # See: [perl #66110]
# lock ourselves under threads
lock($DBGR);
# 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
# 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-- ];
# 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-- ];
} ## 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,
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
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>,
$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
# 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
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/);
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.
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<pager>
Set up the C<$pager> variable. Adds a pipe to the front unless there's one
B<e> Display current thread id.
B<E> Display all thread ids the current one will be identified: <n>.
B<y> [I<n> [I<Vars>]] List lexicals in higher scope <n>. Vars same as B<V>.
-B<P> Something to do with assertions...
B<<> ? List Perl commands to run before each prompt.
B<<> I<expr> Define Perl command to run before each prompt.
}
elsif ($prevwarn) {
$SIG{__WARN__} = $prevwarn;
+ } else {
+ undef $SIG{__WARN__};
}
} ## end if (@_)
$warnLevel;
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;
# 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;
lexwarn
locale
lol
- machten
macos
macosx
- mint
modinstall
modlib
mod
os2
os390
os400
- othrtut
packtut
plan9
pod
=cut
if ( $text =~ /^[\$@%]/ ) { # symbols (in $package + packages in main)
-
=pod
=over 4
$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 *
=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 %:: ) );
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;
}
# 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.
projects / p5sagit/p5-mst-13.2.git / blobdiff