There are a number of special data structures provided to the debugger by
the Perl interpreter.
-The array C<@{$main::{'_<'.$filename}}> (aliased locally to C<@dbline> via glob
-assignment) contains the text from C<$filename>, with each element
-corresponding to a single line of C<$filename>.
+The array C<@{$main::{'_<'.$filename}}> (aliased locally to C<@dbline>
+via glob assignment) contains the text from C<$filename>, with each
+element corresponding to a single line of C<$filename>. Additionally,
+breakable lines will be dualvars with the numeric component being the
+memory address of a COP node. Non-breakable lines are dualvar to 0.
The hash C<%{'_<'.$filename}> (aliased locally to C<%dbline> via glob
assignment) contains breakpoints and actions. The keys are line numbers;
BEGIN {eval 'use IO::Handle'}; # Needed for flush only? breaks under miniperl
# Debugger for Perl 5.00x; perl5db.pl patch level:
-$VERSION = 1.32;
+$VERSION = '1.33';
$header = "perl5db.pl version $VERSION";
# + Forgot a my() declaration (Ilya Zakharevich in 11085)
# Changes: 1.15: Nov 6, 2001 Michael G Schwern <schwern@pobox.com>
# + Updated 1.14 change log
-# + Added *dbline explainatory comments
+# + Added *dbline explanatory comments
# + Mentioning perldebguts man page
# Changes: 1.16: Feb 15, 2002 Mark-Jason Dominus <mjd@plover.com>
# + $onetimeDump improvements
# + 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
+# Changes: 1.33:
+# + Debugger prints lines to the remote port when it forks and openes a new port (f633fd2)
+# + The debugger now continues to use RemotePort when it's been configured to use it. (11653f7)
+# + Stop using $ENV{LESS} for parameters not intended for less (d463cf2)
+# + Configure has a path to less and perl5db.pl can use it (bf320d6)
+# + Die with $@ instead of empty message (86755f4)
+# + Remove extra/useless $@ check after eval { require PadWalker } (which is still checked) (dab8d6d)
+# + Promote eval( "require ..." ) to eval { require ... } (4a49187)
+# + Promote eval { require( ... )} || die to mere require( ... ) (999f23b)
+# + Remove indirect object notation from debugger (bee4b46)
+# + Document that @{$main::{'_<'.$filename}} lines are dualvar to (COP*). (7e17a74)
+# + Remove MacOS classic support from the debugger. (2b894b7)
########################################################################
=head1 DEBUGGER INITIALIZATION
# Needed for the statement after exec():
#
# This BEGIN block is simply used to switch off warnings during debugger
-# compiliation. Probably it would be better practice to fix the warnings,
+# compilation. Probably it would be better practice to fix the warnings,
# but this is how it's done at the moment.
BEGIN {
)
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:
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, OS/2, and Mac OS X (darwin).
+the debugger only handles TCP sockets, X Windows, OS/2, amd Mac OS X
+(darwin).
=cut
if (not defined &get_fork_TTY) # only if no routine exists
{
- if (defined $ENV{TERM} # If we know what kind
+ if ( defined $remoteport ) {
+ # Expect an inetd-like server
+ *get_fork_TTY = \&socket_get_fork_TTY; # to listen to us
+ }
+ elsif (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,
$console = "con";
}
-=item * MacOS - use C<Dev:Console:Perl Debug> if this is the MPW version; C<Dev:
-Console> if not.
-
-Note that Mac OS X returns C<darwin>, not C<MacOS>. Also note that the debugger doesn't do anything special for C<darwin>. Maybe it should.
-
-=cut
-
- elsif ( $^O eq 'MacOS' ) {
- if ( $MacPerl::Version !~ /MPW/ ) {
- $console =
- "Dev:Console:Perl Debug"; # Separate window for application
- }
- else {
- $console = "Dev:Console";
- }
- } ## end elsif ($^O eq 'MacOS')
-
=item * VMS - use C<sys$command>.
=cut
# If RemotePort was defined in the options, connect input and output
# to the socket.
- require IO::Socket;
- $OUT = new IO::Socket::INET(
- Timeout => '10',
- PeerAddr => $remoteport,
- Proto => 'tcp',
- );
- if ( !$OUT ) { die "Unable to connect to remote host: $remoteport\n"; }
- $IN = $OUT;
+ $IN = $OUT = connect_remoteport();
} ## end if (defined $remoteport)
=pod
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
# the code here.
local (*dbline) = $main::{ '_<' . $filename };
- # we need to check for pseudofiles on Mac OS (these are files
- # not attached to a filename, but instead stored in Dev:Pseudo)
- if ( $^O eq 'MacOS' && $#dbline < 0 ) {
- $filename_ini = $filename = 'Dev:Pseudo';
- *dbline = $main::{ '_<' . $filename };
- }
-
# Last line in the program.
local $max = $#dbline;
# r - return from the current subroutine.
$cmd =~ /^r$/ && do {
- # Can't do anythign if the program's over.
+ # Can't do anything if the program's over.
end_report(), next CMD if $finished and $level <= 1;
# Turn on stack trace.
# List aliases.
for my $k (@keys) {
- # Messy metaquoting: Trim the substiution code off.
+ # Messy metaquoting: Trim the substitution code off.
# We use control-G as the delimiter because it's not
# likely to appear in the alias.
if ( ( my $v = $alias{$k} ) =~ s\as\a$k\a(.*)\a$\a1\a ) {
=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 $frame;
- # Determine the sub's return type,and capture approppriately.
+ # Determine the sub's return type, and capture appropriately.
if (wantarray) {
# Called in array context. call sub and capture output.
# If we're doing exit messages...
(
- $frame & 4 # Extended messsages
+ $frame & 4 # Extended messages
? (
print_lineinfo( ' ' x $stack_depth, "out " ),
print_trace( $LINEINFO, -1, 1, 1, "$sub$al" )
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
# Yes. Mark this file as having breakpoints.
$had_breakpoints{$filename} |= 1;
- # "Cannot be done: unsufficient magic" - we can't just put the
+ # "Cannot be done: insufficient magic" - we can't just put the
# breakpoints saved in %postponed_file into %dbline by assigning
# the whole hash; we have to do it one item at a time for the
# breakpoints to be set properly.
# Load Term::Readline, but quietly; don't debug it and don't trace it.
local $frame = 0;
local $doret = -2;
- eval { require Term::ReadLine } or die $@;
+ require Term::ReadLine;
# If noTTY is set, but we have a TTY name, go ahead and hook up to it.
if ($notty) {
# We don't have a TTY - try to find one via Term::Rendezvous.
else {
- eval "require Term::Rendezvous;" or die;
+ require Term::Rendezvous;
# See if we have anything to pass to Term::Rendezvous.
# Use $HOME/.perldbtty$$ if not.
my $rv = $ENV{PERLDB_NOTTY} || "$ENV{HOME}/.perldbtty$$";
# Rendezvous and get the filehandles.
- my $term_rv = new Term::Rendezvous $rv;
+ my $term_rv = Term::Rendezvous->new( $rv );
$IN = $term_rv->IN;
$OUT = $term_rv->OUT;
} ## end else [ if ($tty)
# If we shouldn't use Term::ReadLine, don't.
if ( !$rl ) {
- $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
+ $term = Term::ReadLine::Stub->new( 'perldb', $IN, $OUT );
}
# We're using Term::ReadLine. Get all the attributes for this terminal.
else {
- $term = new Term::ReadLine 'perldb', $IN, $OUT;
+ $term = Term::ReadLine->new( 'perldb', $IN, $OUT );
$rl_attribs = $term->Attribs;
$rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}'
TTY (and probably another window) and to direct the new debugger to read and
write there.
-The debugger provides C<get_fork_TTY> functions which work for X Windows,
-OS/2, and Mac OS X. Other systems are not supported. You are encouraged
-to write C<get_fork_TTY> functions which work for I<your> platform
-and contribute them.
+The debugger provides C<get_fork_TTY> functions which work for TCP
+socket servers, X Windows, OS/2, and Mac OS X. Other systems are not
+supported. You are encouraged to write C<get_fork_TTY> functions which
+work for I<your> platform and contribute them.
+
+=head3 C<socket_get_fork_TTY>
+
+=cut
+
+sub connect_remoteport {
+ require IO::Socket;
+
+ my $socket = IO::Socket::INET->new(
+ Timeout => '10',
+ PeerAddr => $remoteport,
+ Proto => 'tcp',
+ );
+ if ( ! $socket ) {
+ die "Unable to connect to remote host: $remoteport\n";
+ }
+ return $socket;
+}
+
+sub socket_get_fork_TTY {
+ $tty = $LINEINFO = $IN = $OUT = connect_remoteport();
+
+ # Do I need to worry about setting $term?
+
+ reset_IN_OUT( $IN, $OUT );
+ return '';
+}
=head3 C<xterm_get_fork_TTY>
# 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 $@;
+ require Term::ReadLine;
if ( !$rl ) {
- $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
+ $term = Term::ReadLine::Stub->new( 'perldb', $IN, $OUT );
}
else {
- $term = new Term::ReadLine 'perldb', $IN, $OUT;
+ $term = Term::ReadLine->new( 'perldb', $IN, $OUT );
}
}
# There's our new TTY.
# Nothing on the filehandle stack. Socket?
if ( ref $OUT and UNIVERSAL::isa( $OUT, 'IO::Socket::INET' ) ) {
- # Send anyting we have to send.
+ # Send anything we have to send.
$OUT->write( join( '', @_ ) );
# Receive anything there is to receive.
local \$doret = -2;
require '$optionRequire{$option}';
1;
- } || die # XXX: shouldn't happen
+ } || die $@ # XXX: shouldn't happen
if defined $optionRequire{$option}
&& defined $val;
B<H> I<*> Delete complete history.
B<p> I<expr> Same as \"I<print {DB::OUT} expr>\" in current package.
B<|>I<dbcmd> Run debugger command, piping DB::OUT to current pager.
-B<||>I<dbcmd> Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
+B<||>I<dbcmd> Same as B<|>I<dbcmd> but DB::OUT is temporarily select()ed as well.
B<\=> [I<alias> I<value>] Define a command alias, or list current aliases.
I<command> Execute as a perl statement in current package.
B<R> Pure-man-restart of debugger, some of debugger state
This routine does a lot of gyrations to be sure that the pager is C<less>.
It checks for C<less> masquerading as C<more> and records the result in
-C<$ENV{LESS}> so we don't have to go through doing the stats again.
+C<$fixed_less> so we don't have to go through doing the stats again.
=cut
sub fix_less {
# We already know if this is set.
- return if defined $ENV{LESS} && $ENV{LESS} =~ /r/;
+ return if $fixed_less;
# Pager is less for sure.
my $is_less = $pager =~ /\bless\b/;
# changes environment!
# 'r' added so we don't do (slow) stats again.
- $ENV{LESS} .= 'r' if $is_less;
+ $fixed_less = 1 if $is_less;
} ## end sub fix_less
=head1 DIE AND WARN MANAGEMENT
die @_ if $^S; # in eval propagate
}
- # The code used to check $^S to see if compiliation of the current thing
+ # The code used to check $^S to see if compilation of the current thing
# hadn't finished. We don't do it anymore, figuring eval is pretty stable.
eval { require Carp };
=cut
sub setman {
- $doccmd = $^O !~ /^(?:MSWin32|VMS|os2|dos|amigaos|riscos|MacOS|NetWare)\z/s
+ $doccmd = $^O !~ /^(?:MSWin32|VMS|os2|dos|amigaos|riscos|NetWare)\z/s
? "man" # O Happy Day!
: "perldoc"; # Alas, poor unfortunates
} ## end sub setman
amiga
apio
api
- apollo
artistic
beos
book
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 } ) {
+ 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 %:: ) );
rerun -4 current command minus 4 (go back 4 steps)
Whether this always makes sense, in the current context is unknowable, and is
-in part left as a useful exersize for the reader. This sub returns the
+in part left as a useful exercise for the reader. This sub returns the
appropriate arguments to rerun the current session.
=cut
set_list( "PERLDB_POST", @$post );
set_list( "PERLDB_TYPEAHEAD", @typeahead );
- # We are oficially restarting.
+ # We are officially restarting.
$ENV{PERLDB_RESTART} = 1;
# We are junking all child debuggers.
https://perl5.git.perl.org / perl5.git / blobdiff