Document that File::Find doesn't follow symlinks

[p5sagit/p5-mst-13.2.git] / lib / perl5db.pl

diff --git a/lib/perl5db.pl b/lib/perl5db.pl
index d0a7125..469ebff 100644 (file)
--- a/lib/perl5db.pl
+++ b/lib/perl5db.pl
@@ -2,8 +2,8 @@ package DB;
 
 # Debugger for Perl 5.00x; perl5db.pl patch level:
 
-$VERSION = 0.9911;
-$header = "perl5db.pl patch level $VERSION";
+$VERSION = 1.00;
+$header = "perl5db.pl version $VERSION";
 
 # Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich)
 # Latest version available: ftp://ftp.math.ohio-state.edu/pub/users/ilya/perl
@@ -273,6 +273,10 @@ if (exists $ENV{PERLDB_RESTART}) {
   }
   @INC = get_list("PERLDB_INC");
   @ini_INC = @INC;
+  $pretype = [get_list("PERLDB_PRETYPE")];
+  $pre = [get_list("PERLDB_PRE")];
+  $post = [get_list("PERLDB_POST")];
+  @typeahead = get_list("PERLDB_TYPEAHEAD", @typeahead);
 }
 
 if ($notty) {
@@ -292,6 +296,10 @@ if ($notty) {
     $console = "sys\$command";
   }
 
+  if (($^O eq 'MSWin32') and ($emacs or defined $ENV{EMACS})) {
+    $console = undef;
+  }
+
   # Around a bug:
   if (defined $ENV{OS2_SHELL} and ($emacs or $ENV{WINDOWID})) { # In OS/2
     $console = undef;
@@ -341,6 +349,8 @@ if (defined &afterinit) {   # May be defined in $rcfile
   &afterinit();
 }
 
+$I_m_init = 1;
+
 ############################################################ Subroutines
 
 sub DB {
@@ -422,6 +432,7 @@ sub DB {
        @typeahead = @$pretype, @typeahead;
       CMD:
        while (($term || &setterm),
+              ($term_pid == $$ or &resetterm),
               defined ($cmd=&readline("  DB" . ('<' x $level) .
                                       ($#hist+1) . ('>' x $level) .
                                       " "))) {
@@ -900,6 +911,10 @@ sub DB {
                          }
                        }
                        set_list("PERLDB_POSTPONE", %postponed);
+                       set_list("PERLDB_PRETYPE", @$pretype);
+                       set_list("PERLDB_PRE", @$pre);
+                       set_list("PERLDB_POST", @$post);
+                       set_list("PERLDB_TYPEAHEAD", @typeahead);
                        $ENV{PERLDB_RESTART} = 1;
                        #print "$^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS";
                        exec $^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS;
@@ -1052,7 +1067,7 @@ sub DB {
            $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
            if ($onetimeDump) {
                $onetimeDump = undef;
-           } else {
+           } elsif ($term_pid == $$) {
                print $OUT "\n";
            }
        } continue {            # CMD:
@@ -1376,6 +1391,29 @@ sub setterm {
       $term->SetHistory(@hist);
     }
     ornaments($ornaments) if defined $ornaments;
+    $term_pid = $$;
+}
+
+sub resetterm {                        # We forked, so we need a different TTY
+    $term_pid = $$;
+    if (defined &get_fork_TTY) {
+      &get_fork_TTY;
+    } elsif (not defined $fork_TTY 
+            and defined $ENV{TERM} and $ENV{TERM} eq 'xterm' 
+            and defined $ENV{WINDOWID} and defined $ENV{DISPLAY}) { 
+        # Possibly _inside_ XTERM
+        open XT, q[3>&1 xterm -title 'Forked Perl debugger' -e sh -c 'tty 1>&3;\
+ sleep 10000000' |];
+        $fork_TTY = <XT>;
+        chomp $fork_TTY;
+    }
+    if (defined $fork_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";
+    }
 }
 
 sub readline {
@@ -1501,29 +1539,39 @@ sub warn {
 }
 
 sub TTY {
-    if ($term) {
-       &warn("Too late to set TTY!\n") if @_;
-    } else {
-       $tty = shift if @_;
-    }
+    if (@_ and $term and $term->Features->{newTTY}) {
+      my ($in, $out) = shift;
+      if ($in =~ /,/) {
+       ($in, $out) = split /,/, $in, 2;
+      } else {
+       $out = $in;
+      }
+      open IN, $in or die "cannot open `$in' for read: $!";
+      open OUT, ">$out" or die "cannot open `$out' for write: $!";
+      $term->newTTY(\*IN, \*OUT);
+      $IN      = \*IN;
+      $OUT     = \*OUT;
+      return $tty = $in;
+    } elsif ($term and @_) {
+       &warn("Too late to set TTY, enabled on next `R'!\n");
+    } 
+    $tty = shift if @_;
     $tty or $console;
 }
 
 sub noTTY {
     if ($term) {
-       &warn("Too late to set noTTY!\n") if @_;
-    } else {
-       $notty = shift if @_;
+       &warn("Too late to set noTTY, enabled on next `R'!\n") if @_;
     }
+    $notty = shift if @_;
     $notty;
 }
 
 sub ReadLine {
     if ($term) {
-       &warn("Too late to set ReadLine!\n") if @_;
-    } else {
-       $rl = shift if @_;
+       &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_;
     }
+    $rl = shift if @_;
     $rl;
 }
 
@@ -1538,10 +1586,9 @@ sub tkRunning {
 
 sub NonStop {
     if ($term) {
-       &warn("Too late to set up NonStop mode!\n") if @_;
-    } else {
-       $runnonstop = shift if @_;
+       &warn("Too late to set up NonStop mode, enabled on next `R'!\n") if @_;
     }
+    $runnonstop = shift if @_;
     $runnonstop;
 }
 
@@ -1694,7 +1741,7 @@ O [opt[=val]] [opt\"val\"] [opt?]...
         ornaments affects screen appearance of the command line.
                During startup options are initialized from \$ENV{PERLDB_OPTS}.
                You can put additional initialization options TTY, noTTY,
-               ReadLine, and NonStop there.
+               ReadLine, and NonStop there (or use `R' after you set them).
 < command      Define Perl command to run before each prompt.
 << command     Add to the list of Perl commands to run before each prompt.
 > command      Define Perl command to run after each prompt.
@@ -1841,7 +1888,8 @@ sub dieLevel {
       $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
       #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
       print $OUT "Stack dump during die enabled", 
-        ( $dieLevel == 1 ? " outside of evals" : ""), ".\n";
+        ( $dieLevel == 1 ? " outside of evals" : ""), ".\n"
+         if $I_m_init;
       print $OUT "Dump printed too.\n" if $dieLevel > 2;
     } else {
       $SIG{__DIE__} = $prevdie;
@@ -2019,7 +2067,9 @@ sub db_complete {
   return $term->filename_list($text); # filenames
 }
 
-sub end_report { print $OUT "Use `q' to quit and `R' to restart. `h q' for details.\n" }
+sub end_report {
+  print $OUT "Use `q' to quit or `R' to restart.  `h q' for details.\n"
+}
 
 END {
   $finished = $inhibit_exit;   # So that some keys may be disabled.
@@ -2031,7 +2081,7 @@ END {
 package DB::fake;
 
 sub at_exit {
-  "Debuggee terminated. Use `q' to quit and `R' to restart.";
+  "Debugged program terminated.  Use `q' to quit or `R' to restart.";
 }
 
 package DB;                    # Do not trace this 1; below!