Commit | Line | Data |
---|---|---|
378cc40b LW |
1 | #!./perl |
2 | ||
ba553610 MS |
3 | BEGIN { |
4 | chdir 't' if -d 't'; | |
ff8b5bfb JH |
5 | @INC = qw(. ../lib); |
6 | require "./test.pl"; | |
ba553610 | 7 | } |
378cc40b | 8 | |
1bb0a50f | 9 | use Config; |
1031ca5c | 10 | no warnings 'once'; |
1bb0a50f | 11 | |
ba553610 | 12 | my $test = 1; |
ad1c9500 | 13 | print "1..26\n"; |
378cc40b LW |
14 | print "ok 1\n"; |
15 | ||
ba553610 MS |
16 | open(DUPOUT,">&STDOUT"); |
17 | open(DUPERR,">&STDERR"); | |
378cc40b | 18 | |
ba553610 | 19 | open(STDOUT,">Io.dup") || die "Can't open stdout"; |
a687059c | 20 | open(STDERR,">&STDOUT") || die "Can't open stderr"; |
378cc40b | 21 | |
a687059c LW |
22 | select(STDERR); $| = 1; |
23 | select(STDOUT); $| = 1; | |
378cc40b | 24 | |
a687059c LW |
25 | print STDOUT "ok 2\n"; |
26 | print STDERR "ok 3\n"; | |
ba553610 MS |
27 | |
28 | # Since some systems don't have echo, we use Perl. | |
dc459aad | 29 | $echo = qq{$^X -le "print q(ok %d)"}; |
ba553610 | 30 | |
dc459aad | 31 | $cmd = sprintf $echo, 4; |
ba553610 MS |
32 | print `$cmd`; |
33 | ||
dc459aad JH |
34 | $cmd = sprintf "$echo 1>&2", 5; |
35 | $cmd = sprintf $echo, 5 if $^O eq 'MacOS'; # don't know if we can do this ... | |
ba553610 MS |
36 | print `$cmd`; |
37 | ||
38 | # KNOWN BUG system() does not honor STDOUT redirections on VMS. | |
39 | if( $^O eq 'VMS' ) { | |
31775886 | 40 | print "not ok $_ # TODO system() not honoring STDOUT redirect on VMS\n" |
ba553610 MS |
41 | for 6..7; |
42 | } | |
43 | else { | |
44 | system sprintf $echo, 6; | |
dc459aad JH |
45 | if ($^O eq 'MacOS') { |
46 | system sprintf $echo, 7; | |
47 | } | |
48 | else { | |
49 | system sprintf "$echo 1>&2", 7; | |
50 | } | |
ba553610 | 51 | } |
378cc40b | 52 | |
d1e4d418 A |
53 | close(STDOUT) or die "Could not close: $!"; |
54 | close(STDERR) or die "Could not close: $!"; | |
378cc40b | 55 | |
d1e4d418 A |
56 | open(STDOUT,">&DUPOUT") or die "Could not open: $!"; |
57 | open(STDERR,">&DUPERR") or die "Could not open: $!"; | |
378cc40b | 58 | |
cda41bc1 | 59 | if (($^O eq 'MSWin32') || ($^O eq 'NetWare') || ($^O eq 'VMS')) { print `type Io.dup` } |
dc459aad JH |
60 | elsif ($^O eq 'MacOS') { system 'catenate Io.dup' } |
61 | else { system 'cat Io.dup' } | |
378cc40b LW |
62 | unlink 'Io.dup'; |
63 | ||
e4a4387c | 64 | print STDOUT "ok 8\n"; |
9394203c | 65 | |
1bb0a50f | 66 | open(F,">&",1) or die "Cannot dup to numeric 1: $!"; |
31775886 NIS |
67 | print F "ok 9\n"; |
68 | close(F); | |
69 | ||
1bb0a50f | 70 | open(F,">&",'1') or die "Cannot dup to string '1': $!"; |
31775886 NIS |
71 | print F "ok 10\n"; |
72 | close(F); | |
73 | ||
1bb0a50f | 74 | open(F,">&=",1) or die "Cannot dup to numeric 1: $!"; |
31775886 NIS |
75 | print F "ok 11\n"; |
76 | close(F); | |
77 | ||
1bb0a50f JH |
78 | if ($Config{useperlio}) { |
79 | open(F,">&=",'1') or die "Cannot dup to string '1': $!"; | |
80 | print F "ok 12\n"; | |
81 | close(F); | |
82 | } else { | |
83 | open(F, ">&DUPOUT") or die "Cannot dup stdout back: $!"; | |
84 | print F "ok 12\n"; | |
85 | close(F); | |
86 | } | |
31775886 | 87 | |
939b405b JH |
88 | # To get STDOUT back. |
89 | open(F, ">&DUPOUT") or die "Cannot dup stdout back: $!"; | |
90 | ||
ff8b5bfb JH |
91 | curr_test(13); |
92 | ||
93 | SKIP: { | |
ad1c9500 | 94 | skip("need perlio", 14) unless $Config{useperlio}; |
ff8b5bfb JH |
95 | |
96 | ok(open(F, ">&", STDOUT)); | |
97 | isnt(fileno(F), fileno(STDOUT)); | |
98 | close F; | |
99 | ||
0685228b | 100 | ok(open(F, "<&=STDIN")) or _diag $!; |
ff8b5bfb JH |
101 | is(fileno(F), fileno(STDIN)); |
102 | close F; | |
103 | ||
104 | ok(open(F, ">&=STDOUT")); | |
105 | is(fileno(F), fileno(STDOUT)); | |
106 | close F; | |
107 | ||
108 | ok(open(F, ">&=STDERR")); | |
109 | is(fileno(F), fileno(STDERR)); | |
110 | close F; | |
111 | ||
112 | open(G, ">dup$$") or die; | |
113 | my $g = fileno(G); | |
114 | ||
115 | ok(open(F, ">&=$g")); | |
116 | is(fileno(F), $g); | |
117 | close F; | |
118 | ||
119 | ok(open(F, ">&=G")); | |
120 | is(fileno(F), $g); | |
121 | ||
122 | print G "ggg\n"; | |
123 | print F "fff\n"; | |
124 | ||
125 | close G; # flush first | |
126 | close F; # flush second | |
127 | ||
128 | open(G, "<dup$$") or die; | |
ad1c9500 JH |
129 | { |
130 | my $line; | |
131 | $line = <G>; chomp $line; is($line, "ggg"); | |
132 | $line = <G>; chomp $line; is($line, "fff"); | |
133 | } | |
ff8b5bfb JH |
134 | close G; |
135 | ||
136 | END { 1 while unlink "dup$$" } | |
137 | } |