=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.30;
$header = "perl5db.pl version $VERSION";
# + 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
########################################################################
=head1 DEBUGGER INITIALIZATION
=cut
@options = qw(
- CommandSet
+ CommandSet HistFile HistSize
hashDepth arrayDepth dumpDepth
DumpDBFiles DumpPackages DumpReused
compactDump veryCompact quote
RemotePort => \$remoteport,
windowSize => \$window,
WarnAssertions => \$warnassertions,
+ HistFile => \$histfile,
+ HistSize => \$histsize,
);
=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 = $$;
}
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.
@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;
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";
# 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
$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
=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>
# 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.
sub macosx_get_fork_TTY
set custom title to ""
copy name to thetitle
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
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);
$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
projects / p5sagit/p5-mst-13.2.git / blobdiff