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;
=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
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<HistFile>.
+Default is 100.
+
=back
=head3 SAMPLE RCFILE
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";
# + 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 threads support (inc. e and E commands)
# Changes: 1.29: Nov 28, 2006 Bo Lindbergh <blgl@hagernas.com>
# + 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 {
$^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:
=cut
@options = qw(
- CommandSet
+ CommandSet HistFile HistSize
hashDepth arrayDepth dumpDepth
DumpDBFiles DumpPackages DumpReused
compactDump veryCompact quote
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,
);
=pod
ornaments => \&ornaments,
RemotePort => \&RemotePort,
DollarCaretP => \&DollarCaretP,
- OnlyAssertions=> \&OnlyAssertions,
);
=pod
=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<Config.pm>. If it's not there, we default to C<more>. We
then call the C<pager()> function to save the pager name.
# 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 = $$;
}
# 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 {
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
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.
# 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;
@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
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;
# 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 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
)
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.
# 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-- ];
# 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" )
} ## 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,
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
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";
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>,
# 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 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
# 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} .= '-:+/*,[])}'
$term->MinLine(2);
+ &load_hist();
+
if ( $term->Features->{setHistory} and "@hist" ne "?" ) {
$term->SetHistory(@hist);
}
$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
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>
$pidprompt = ''; # Shown anyway in titlebar
+ # We need $term defined or we can not switch to the newly created xterm
+ if ($tty ne '' && !defined $term) {
+ require Term::ReadLine;
+ if ( !$rl ) {
+ $term = Term::ReadLine::Stub->new( 'perldb', $IN, $OUT );
+ }
+ else {
+ $term = Term::ReadLine->new( 'perldb', $IN, $OUT );
+ }
+ }
# There's our new TTY.
return $tty;
} ## end sub xterm_get_fork_TTY
=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;
-
- 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.
- 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, '</dev/con' or warn "reopen stdin: $!"}
-use OS2::Process;
-
-my ($rl, $in) = (shift, shift); # Read from $in and pass through
-set_title pop;
-system P_NOWAIT, $^X, '-we', <<EOS or die "Cannot start a grandkid";
- open IN, '<&=$in' or die "open <&=$in: \$!";
- \$| = 1; print while sysread IN, \$_, 1<<16;
-EOS
-
-my $out = shift;
-open OUT, ">&=$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;
+ 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
=head3 C<macosx_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/);
# 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;
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.
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
B<o> [I<opt>] ... Set boolean option to true
B<o> [I<opt>B<?>] Query options
B<o> [I<opt>B<=>I<val>] [I<opt>=B<\">I<val>B<\">] ...
- Set options. Use quotes in spaces in value.
+ Set options. Use quotes if spaces in value.
I<recallCommand>, I<ShellBang> chars used to recall command or spawn shell;
I<pager> program for output of \"|cmd\";
I<tkRunning> run Tk while prompting (with ReadLine);
B<O> [I<opt>] ... Set boolean option to true
B<O> [I<opt>B<?>] Query options
B<O> [I<opt>B<=>I<val>] [I<opt>=B<\">I<val>B<\">] ...
- Set options. Use quotes in spaces in value.
+ Set options. Use quotes if spaces in value.
I<recallCommand>, I<ShellBang> chars used to recall command or spawn shell;
I<pager> program for output of \"|cmd\";
I<tkRunning> run Tk while prompting (with ReadLine);
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 };
}
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;
=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 %:: ) );
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;
}
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
# 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.
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.
$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
https://perl5.git.perl.org / perl5.git / blobdiff