Re: [perl #41691] [PATCH] v5.8.8 pod2html -- Convert RFC links to point ot IETF pages
[p5sagit/p5-mst-13.2.git] / lib / perl5db.pl
index e031ac2..7a6848d 100644 (file)
@@ -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<HistFile>.
+Default is 100.
+
 =back
 
 =head3 SAMPLE RCFILE
@@ -501,7 +511,7 @@ package DB;
 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";
 
@@ -929,6 +939,8 @@ sub eval {
 #   + 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
@@ -1077,7 +1089,7 @@ are to be accepted.
 =cut
 
 @options = qw(
-  CommandSet
+  CommandSet   HistFile      HistSize
   hashDepth    arrayDepth    dumpDepth
   DumpDBFiles  DumpPackages  DumpReused
   compactDump  veryCompact   quote
@@ -1123,6 +1135,8 @@ state.
     RemotePort    => \$remoteport,
     windowSize    => \$window,
     WarnAssertions => \$warnassertions,
+    HistFile      => \$histfile,
+    HistSize      => \$histsize,
 );
 
 =pod
@@ -1237,7 +1251,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<Config.pm>.  If it's not there, we default to C<more>. We
 then call the C<pager()> function to save the pager name.
 
@@ -1849,7 +1863,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.
@@ -2407,7 +2421,7 @@ Uses C<dumpvar.pl> 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
@@ -2606,7 +2620,7 @@ above the current one and then displays then using C<dumpvar.pl>.
                       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;
@@ -4660,7 +4674,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
@@ -4682,7 +4696,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"; 
@@ -5584,7 +5598,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
@@ -6066,6 +6080,8 @@ sub setterm {
 
     $term->MinLine(2);
 
+    &load_hist();
+
     if ( $term->Features->{setHistory} and "@hist" ne "?" ) {
         $term->SetHistory(@hist);
     }
@@ -6076,6 +6092,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
@@ -7238,7 +7282,7 @@ 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);
@@ -7414,7 +7458,7 @@ 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);
@@ -9041,8 +9085,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