Commit | Line | Data |
30500b05 |
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" } |