Re: [PATCH] 5.004_04 or 5.004_64: Benchmark.pm: add run-for-some-time

[perl5.git] / lib / perl5db.pl

diff --git a/lib/perl5db.pl b/lib/perl5db.pl
index ea072e0..3ca0adc 100644 (file)
--- a/lib/perl5db.pl
+++ b/lib/perl5db.pl
@@ -173,18 +173,20 @@ $trace = $signal = $single = 0;   # Uninitialized warning suppression
                                 # (local $^W cannot help - other packages!).
 $inhibit_exit = $option{PrintRet} = 1;
 
-@options     = qw(hashDepth arrayDepth DumpDBFiles DumpPackages 
+@options     = qw(hashDepth arrayDepth DumpDBFiles DumpPackages DumpReused
                  compactDump veryCompact quote HighBit undefPrint
                  globPrint PrintRet UsageOnly frame AutoTrace
                  TTY noTTY ReadLine NonStop LineInfo maxTraceLen
                  recallCommand ShellBang pager tkRunning ornaments
-                 signalLevel warnLevel dieLevel inhibit_exit);
+                 signalLevel warnLevel dieLevel inhibit_exit
+                 ImmediateStop);
 
 %optionVars    = (
                 hashDepth      => \$dumpvar::hashDepth,
                 arrayDepth     => \$dumpvar::arrayDepth,
                 DumpDBFiles    => \$dumpvar::dumpDBFiles,
                 DumpPackages   => \$dumpvar::dumpPackages,
+                DumpReused     => \$dumpvar::dumpReused,
                 HighBit        => \$dumpvar::quoteHighBit,
                 undefPrint     => \$dumpvar::printUndef,
                 globPrint      => \$dumpvar::globPrint,
@@ -193,6 +195,7 @@ $inhibit_exit = $option{PrintRet} = 1;
                 AutoTrace      => \$trace,
                 inhibit_exit   => \$inhibit_exit,
                 maxTraceLen    => \$maxtrace,
+                ImmediateStop  => \$ImmediateStop,
 );
 
 %optionAction  = (
@@ -362,13 +365,16 @@ sub DB {
        }
        $single = 0;
        # return;                       # Would not print trace!
+      } elsif ($ImmediateStop) {
+       $ImmediateStop = 0;
+       $signal = 1;
       }
     }
     $runnonstop = 0 if $single or $signal; # Disable it if interactive.
     &save;
     ($package, $filename, $line) = caller;
     $filename_ini = $filename;
-    $usercontext = '($@, $!, $,, $/, $\, $^W) = @saved;' .
+    $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
       "package $package;";     # this won't let them modify, alas
     local(*dbline) = $main::{'_<' . $filename};
     $max = $#dbline;
@@ -389,9 +395,9 @@ sub DB {
        if ($val ne $old_watch[$n]) {
          $signal = 1;
          print $OUT <<EOP;
-Watchpoint $n: $to_watch[$n] changed:
-old value: $old_watch[$n]
-new value: $val
+Watchpoint $n:\t$to_watch[$n] changed:
+    old value:\t$old_watch[$n]
+    new value:\t$val
 EOP
          $old_watch[$n] = $val;
        }
@@ -408,6 +414,15 @@ EOP
        if ($emacs) {
            $position = "\032\032$filename:$line:0\n";
            print $LINEINFO $position;
+       } elsif ($package eq 'DB::fake') {
+         print_help(<<EOP);
+Debugged program terminated.  Use B<q> to quit or B<R> to restart,
+  use B<O> I<inhibit_exit> to avoid stopping after program termination,
+  B<h q>, B<h R> or B<h O> to get additional info.  
+EOP
+         $package = 'main';
+         $usercontext = '($@, $!, $,, $/, $\, $^W) = @saved;' .
+           "package $package;";        # this won't let them modify, alas
        } else {
            $sub =~ s/\'/::/;
            $prefix = $sub =~ /::/ ? "" : "${'package'}::";
@@ -1140,7 +1155,7 @@ EOP
          &eval;
        }
     }                          # if ($single || $signal)
-    ($@, $!, $,, $/, $\, $^W) = @saved;
+    ($@, $!, $^E, $,, $/, $\, $^W) = @saved;
     ();
 }
 
@@ -1190,7 +1205,7 @@ sub sub {
 }
 
 sub save {
-    @saved = ($@, $!, $,, $/, $\, $^W);
+    @saved = ($@, $!, $^E, $,, $/, $\, $^W);
     $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
 }
 
@@ -1210,7 +1225,7 @@ sub eval {
     }
     my $at = $@;
     local $saved[0];           # Preserve the old value of $@
-    eval "&DB::save";
+    eval { &DB::save };
     if ($at) {
        print $OUT $at;
     } elsif ($onetimeDump eq 'dump') {
@@ -1245,6 +1260,10 @@ sub postponed_sub {
 }
 
 sub postponed {
+  if ($ImmediateStop) {
+    $ImmediateStop = 0;
+    $signal = 1;
+  }
   return &postponed_sub
     unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
   # Cannot be done before the file is compiled
@@ -1385,7 +1404,7 @@ sub system {
     # We save, change, then restore STDIN and STDOUT to avoid fork() since
     # many non-Unix systems can do system() but have problems with fork().
     open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
-    open(SAVEOUT,">&OUT") || &warn("Can't save STDOUT");
+    open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
     open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
     open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
     system(@_);
@@ -1460,8 +1479,14 @@ sub resetterm {                  # We forked, so we need a different TTY
       TTY($fork_TTY);
       undef $fork_TTY;
     } else {
-      print $OUT "Forked, but do not know how to change a TTY.\n",
-          "Define \$DB::fork_TTY or get_fork_TTY().\n";
+      print_help(<<EOP);
+I<#########> Forked, but do not know how to change a B<TTY>. I<#########>
+  Define B<\$DB::fork_TTY> 
+       - or a function B<DB::get_fork_TTY()> which will set B<\$DB::fork_TTY>.
+  The value of B<\$DB::fork_TTY> should be the name of I<TTY> to use.
+  On I<UNIX>-like systems one can get the name of a I<TTY> for the given window
+  by typing B<tty>, and disconnect the I<shell> from I<TTY> by B<sleep 1000000>.
+EOP
     }
 }
 
@@ -1779,12 +1804,14 @@ B<O> [I<opt>[B<=>I<val>]] [I<opt>B<\">I<val>B<\">] [I<opt>B<?>]...
     I<tkRunning>:                      run Tk while prompting (with ReadLine);
     I<signalLevel> I<warnLevel> I<dieLevel>:   level of verbosity;
     I<inhibit_exit>            Allows stepping off the end of the script.
+    I<ImmediateStop>           Debugger should stop as early as possible.
   The following options affect what happens with B<V>, B<X>, and B<x> commands:
     I<arrayDepth>, I<hashDepth>:       print only first N elements ('' for all);
     I<compactDump>, I<veryCompact>:    change style of array and hash dump;
     I<globPrint>:                      whether to print contents of globs;
     I<DumpDBFiles>:            dump arrays holding debugged files;
     I<DumpPackages>:           dump symbol tables of packages;
+    I<DumpReused>:             dump contents of \"reused\" addresses;
     I<quote>, I<HighBit>, I<undefPrint>:       change style of string dump;
   Option I<PrintRet> affects printing of return value after B<r> command,
          I<frame>    affects printing messages on entry and exit from subroutines.
@@ -1822,7 +1849,7 @@ B<R>              Pure-man-restart of debugger, some of debugger state
                and the following command-line options: I<-w>, I<-I>, I<-e>.
 B<h> [I<db_command>]   Get help [on a specific debugger command], enter B<|h> to page.
 B<h h>         Summary of debugger commands.
-B<q> or B<^D>          Quit. Set \$DB::finished to 0 to debug global destruction.
+B<q> or B<^D>          Quit. Set B<\$DB::finished = 0> to debug global destruction.
 
 ";
     $summary = <<"END_SUM";