os2/OS2/Process/t/os2_process_kid.t

   1 #! /usr/bin/perl -w
   2
   3 use strict;
   4 use OS2::Process;               # qw(P_SESSION P_UNRELATED P_NOWAIT);
   5
   6 my $pl = $0;
   7 $pl =~ s/_kid\.t$/.t/i;
   8 die "Can't find the kid script" unless -r $pl;
   9
  10 my $inc = $ENV{PERL5LIB};
  11 $inc = $ENV{PERLLIB} unless defined $inc;
  12 $inc = '' unless defined $inc;
  13 $ENV{PERL5LIB} = join ';', @INC, split /;/, $inc;
  14
  15 # The thest in $pl modify the session too bad.  We run the tests
  16 # in a different session to keep the current session cleaner
  17
  18 # Apparently, this affects things at open() time, not at system() time
  19 $^F = 40;
  20
  21 # These do not work...  Apparently, the kid "interprets" file handles
  22 # open to CON as output to *its* CON (shortcut in the kernel via the
  23 # device flags?).
  24
  25 #my @fh = ('<&STDIN', '>&STDOUT', '>&STDERR');
  26 #my @nfd;
  27 #open $nfd[$_], $fh[$_] or die "Cannot remap FH" for 0..2;
  28 #my @fn = map fileno $_, @nfd;
  29 #$ENV{NEW_FD} = "@fn";
  30
  31 my ($stdout_r,$stdout_w,$stderr_r,$stderr_w);
  32 pipe $stderr_r, $stderr_w or die;
  33
  34 # Duper for $stderr_r to STDERR
  35 my ($e_r, $e_w) = map fileno $_, $stderr_r,  $stderr_w;
  36 my $k = system P_NOWAIT, $^X, '-we', <<'EOS', $e_r, $e_w or die "Cannot start a STDERR duper";
  37   my ($e_r, $e_w) = @ARGV;
  38   # close the other end by the implicit close:
  39   { open my $closeit, ">&=$e_w" or die "kid: open >&=$e_w: $!, `$^E'" }
  40   open IN, "<&=$e_r" or die "kid: open <&=$e_r: $!, `$^E'";
  41   select STDERR; $| = 1; print while sysread IN, $_, 1<<16;
  42 EOS
  43 close $stderr_r or die;         # Now the kid is the owner
  44
  45 pipe $stdout_r, $stdout_w or die;
  46
  47 my @fn = (map fileno $_, $stdout_w, $stderr_w);
  48 $ENV{NEW_FD} = "@fn";
  49 # print "# fns=@fn\n";
  50
  51 $ENV{OS2_PROCESS_TEST_SEPARATE_SESSION} = 1;
  52 my $pid = system P_SESSION, $^X, $pl, @ARGV or die;
  53 close $stderr_w or die;         # Leave these two FH to the kid only
  54 close $stdout_w or die;
  55
  56 # Duplicate the STDOUT of the kid:
  57 # These are workarounds for bug in sysread: it is reading in binary...
  58 binmode $stdout_r;
  59 binmode STDOUT;
  60 $| = 1;  print while sysread $stdout_r, $_, 1<<16;
  61
  62 waitpid($pid, 0) >= 0 or die;
  63
  64 # END { print "# parent finished\r\n" }