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