This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Adjust the skip count for t/io/dup.t for the -Uuseperlio case, in a way
[perl5.git] / t / io / dup.t
CommitLineData
378cc40b
LW
1#!./perl
2
ba553610
MS
3BEGIN {
4 chdir 't' if -d 't';
ff8b5bfb
JH
5 @INC = qw(. ../lib);
6 require "./test.pl";
ba553610 7}
378cc40b 8
1bb0a50f 9use Config;
1031ca5c 10no warnings 'once';
1bb0a50f 11
ba553610 12my $test = 1;
1d341aad
NC
13my $tests_needing_perlio = 17;
14plan(12 + $tests_needing_perlio);
378cc40b
LW
15print "ok 1\n";
16
ba553610
MS
17open(DUPOUT,">&STDOUT");
18open(DUPERR,">&STDERR");
378cc40b 19
ba553610 20open(STDOUT,">Io.dup") || die "Can't open stdout";
a687059c 21open(STDERR,">&STDOUT") || die "Can't open stderr";
378cc40b 22
a687059c
LW
23select(STDERR); $| = 1;
24select(STDOUT); $| = 1;
378cc40b 25
a687059c
LW
26print STDOUT "ok 2\n";
27print 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
33print `$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
37print `$cmd`;
38
39# KNOWN BUG system() does not honor STDOUT redirections on VMS.
40if( $^O eq 'VMS' ) {
31775886 41 print "not ok $_ # TODO system() not honoring STDOUT redirect on VMS\n"
ba553610
MS
42 for 6..7;
43}
44else {
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
54close(STDOUT) or die "Could not close: $!";
55close(STDERR) or die "Could not close: $!";
378cc40b 56
d1e4d418
A
57open(STDOUT,">&DUPOUT") or die "Could not open: $!";
58open(STDERR,">&DUPERR") or die "Could not open: $!";
378cc40b 59
cda41bc1 60if (($^O eq 'MSWin32') || ($^O eq 'NetWare') || ($^O eq 'VMS')) { print `type Io.dup` }
dc459aad
JH
61elsif ($^O eq 'MacOS') { system 'catenate Io.dup' }
62else { system 'cat Io.dup' }
378cc40b
LW
63unlink 'Io.dup';
64
e4a4387c 65print STDOUT "ok 8\n";
9394203c 66
1bb0a50f 67open(F,">&",1) or die "Cannot dup to numeric 1: $!";
31775886
NIS
68print F "ok 9\n";
69close(F);
70
1bb0a50f 71open(F,">&",'1') or die "Cannot dup to string '1': $!";
31775886
NIS
72print F "ok 10\n";
73close(F);
74
1bb0a50f 75open(F,">&=",1) or die "Cannot dup to numeric 1: $!";
31775886
NIS
76print F "ok 11\n";
77close(F);
78
1bb0a50f
JH
79if ($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.
90open(F, ">&DUPOUT") or die "Cannot dup stdout back: $!";
91
ff8b5bfb
JH
92curr_test(13);
93
94SKIP: {
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}