Repost of fork() debugger patch

Here is the repost of what was apparently lost during some turmoil on
p5-p.

Enjoy,

p5p-msgid: 199707252101.RAA11846@monk.mps.ohio-state.edu

1 files changed, 40 insertions, 3 deletions

diff --git a/lib/perl5db.pl b/lib/perl5db.pl
index c09238d16c..fbd36a0374 100644
--- a/lib/perl5db.pl
+++ b/lib/perl5db.pl
@@ -428,6 +428,7 @@ sub DB {
 	@typeahead = @$pretype, @typeahead;
       CMD:
 	while (($term || &setterm),
+	       ($term_pid == $$ or &resetterm),
 	       defined ($cmd=&readline("  DB" . ('<' x $level) .
 				       ($#hist+1) . ('>' x $level) .
 				       " "))) {
@@ -1062,7 +1063,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:
@@ -1386,6 +1387,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 {
@@ -1511,8 +1535,21 @@ sub warn {
 }
 
 sub TTY {
-    if ($term) {
-	&warn("Too late to set TTY, enabled on next `R'!\n") 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;