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