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

diff --git a/lib/Term/ReadLine.pm b/lib/Term/ReadLine.pm
index 105e6dd..a9df784 100644 (file)
--- a/lib/Term/ReadLine.pm
+++ b/lib/Term/ReadLine.pm
@@ -105,14 +105,33 @@ support reacher set of commands.
 All these commands are callable via method interface and have names
 which conform to standard conventions with the leading C<rl_> stripped.
 
-The stub package included with the perl distribution allows two
-additional methods: C<tkRunning> and C<ornaments>.  The first one
+The stub package included with the perl distribution allows some
+additional methods: 
+
+=over 12
+
+=item C<tkRunning>
+
 makes Tk event loop run when waiting for user input (i.e., during
-C<readline> method), the second one makes the command line stand out
-by using termcap data.  The argument to C<ornaments> should be 0, 1,
-or a string of a form "aa,bb,cc,dd".  Four components of this string
-should be names of I<terminal capacities>, first two will be issued to
-make the prompt standout, last two to make the input line standout.
+C<readline> method).
+
+=item C<ornaments>
+
+makes the command line stand out by using termcap data.  The argument
+to C<ornaments> should be 0, 1, or a string of a form
+C<"aa,bb,cc,dd">.  Four components of this string should be names of
+I<terminal capacities>, first two will be issued to make the prompt
+standout, last two to make the input line standout.
+
+=item C<newTTY>
+
+takes two arguments which are input filehandle and output filehandle.
+Switches to use these filehandles.
+
+=back
+
+One can check whether the currently loaded ReadLine package supports
+these methods by checking for corresponding C<Features>.
 
 =head1 EXPORTS
 
@@ -206,12 +225,22 @@ sub new {
     bless [$FIN, $FOUT];
   }
 }
+
+sub newTTY {
+  my ($self, $in, $out) = @_;
+  $self->[0] = $in;
+  $self->[1] = $out;
+  my $sel = select($out);
+  $| = 1;                              # for DB::OUT
+  select($sel);
+}
+
 sub IN { shift->[0] }
 sub OUT { shift->[1] }
 sub MinLine { undef }
 sub Attribs { {} }
 
-my %features = (tkRunning => 1, ornaments => 1);
+my %features = (tkRunning => 1, ornaments => 1, newTTY => 1);
 sub Features { \%features }
 
 package Term::ReadLine;                # So late to allow the above code be defined?

diff --git a/lib/perl5db.pl b/lib/perl5db.pl
index c09238d..fbd36a0 100644 (file)
--- 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;