home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl501m.zip / lib / open2.pl < prev    next >
Perl Script  |  1992-08-08  |  2KB  |  55 lines
  1. # &open2: tom christiansen, <tchrist@convex.com>
  2. #
  3. # usage: $pid = &open2('rdr', 'wtr', 'some cmd and args');
  4. #    or  $pid = &open2('rdr', 'wtr', 'some', 'cmd', 'and', 'args');
  5. #
  6. # spawn the given $cmd and connect $rdr for
  7. # reading and $wtr for writing.  return pid
  8. # of child, or 0 on failure.  
  9. # 
  10. # WARNING: this is dangerous, as you may block forever
  11. # unless you are very careful.  
  12. # 
  13. # $wtr is left unbuffered.
  14. # 
  15. # abort program if
  16. #    rdr or wtr are null
  17. #     pipe or fork or exec fails
  18.  
  19. package open2;
  20. $fh = 'FHOPEN000';  # package static in case called more than once
  21.  
  22. sub main'open2 {
  23.     local($kidpid);
  24.     local($dad_rdr, $dad_wtr, @cmd) = @_;
  25.  
  26.     $dad_rdr ne ''         || die "open2: rdr should not be null";
  27.     $dad_wtr ne ''         || die "open2: wtr should not be null";
  28.  
  29.     # force unqualified filehandles into callers' package
  30.     local($package) = caller;
  31.     $dad_rdr =~ s/^[^']+$/$package'$&/;
  32.     $dad_wtr =~ s/^[^']+$/$package'$&/;
  33.  
  34.     local($kid_rdr) = ++$fh;
  35.     local($kid_wtr) = ++$fh;
  36.  
  37.     pipe($dad_rdr, $kid_wtr)     || die "open2: pipe 1 failed: $!";
  38.     pipe($kid_rdr, $dad_wtr)     || die "open2: pipe 2 failed: $!";
  39.  
  40.     if (($kidpid = fork) < 0) {
  41.     die "open2: fork failed: $!";
  42.     } elsif ($kidpid == 0) {
  43.     close $dad_rdr; close $dad_wtr;
  44.     open(STDIN,  "<&$kid_rdr");
  45.     open(STDOUT, ">&$kid_wtr");
  46.     warn "execing @cmd\n" if $debug;
  47.     exec @cmd;
  48.     die "open2: exec of @cmd failed";   
  49.     } 
  50.     close $kid_rdr; close $kid_wtr;
  51.     select((select($dad_wtr), $| = 1)[0]); # unbuffer pipe
  52.     $kidpid;
  53. }
  54. 1; # so require is happy
  55.