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
1 #!./perl
2
3 BEGIN {
4     chdir 't' if -d 't';
5     @INC = qw(. ../lib);
6     require "./test.pl";
7 }
8
9 use Config;
10 no warnings 'once';
11
12 my $test = 1;
13 my $tests_needing_perlio = 17;
14 plan(12 + $tests_needing_perlio);
15 print "ok 1\n";
16
17 open(DUPOUT,">&STDOUT");
18 open(DUPERR,">&STDERR");
19
20 open(STDOUT,">Io.dup")  || die "Can't open stdout";
21 open(STDERR,">&STDOUT") || die "Can't open stderr";
22
23 select(STDERR); $| = 1;
24 select(STDOUT); $| = 1;
25
26 print STDOUT "ok 2\n";
27 print STDERR "ok 3\n";
28
29 # Since some systems don't have echo, we use Perl.
30 $echo = qq{$^X -le "print q(ok %d)"};
31
32 $cmd = sprintf $echo, 4;
33 print `$cmd`;
34
35 $cmd = sprintf "$echo 1>&2", 5;
36 $cmd = sprintf $echo, 5 if $^O eq 'MacOS';  # don't know if we can do this ...
37 print `$cmd`;
38
39 # KNOWN BUG system() does not honor STDOUT redirections on VMS.
40 if( $^O eq 'VMS' ) {
41     print "not ok $_ # TODO system() not honoring STDOUT redirect on VMS\n"
42       for 6..7;
43 }
44 else {
45     system sprintf $echo, 6;
46     if ($^O eq 'MacOS') {
47         system sprintf $echo, 7;
48     }
49     else {
50         system sprintf "$echo 1>&2", 7;
51     }
52 }
53
54 close(STDOUT) or die "Could not close: $!";
55 close(STDERR) or die "Could not close: $!";
56
57 open(STDOUT,">&DUPOUT") or die "Could not open: $!";
58 open(STDERR,">&DUPERR") or die "Could not open: $!";
59
60 if (($^O eq 'MSWin32') || ($^O eq 'NetWare') || ($^O eq 'VMS')) { print `type Io.dup` }
61 elsif ($^O eq 'MacOS') { system 'catenate Io.dup' }
62 else                   { system 'cat Io.dup' }
63 unlink 'Io.dup';
64
65 print STDOUT "ok 8\n";
66
67 open(F,">&",1) or die "Cannot dup to numeric 1: $!";
68 print F "ok 9\n";
69 close(F);
70
71 open(F,">&",'1') or die "Cannot dup to string '1': $!";
72 print F "ok 10\n";
73 close(F);
74
75 open(F,">&=",1) or die "Cannot dup to numeric 1: $!";
76 print F "ok 11\n";
77 close(F);
78
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 }
88
89 # To get STDOUT back.
90 open(F, ">&DUPOUT") or die "Cannot dup stdout back: $!";
91
92 curr_test(13);
93
94 SKIP: {
95     skip("need perlio", $tests_needing_perlio) unless $Config{useperlio};
96     
97     ok(open(F, ">&", STDOUT));
98     isnt(fileno(F), fileno(STDOUT));
99     close F;
100
101     ok(open(F, "<&=STDIN")) or _diag $!;
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;
130     {
131         my $line;
132         $line = <G>; chomp $line; is($line, "ggg");
133         $line = <G>; chomp $line; is($line, "fff");
134     }
135     close G;
136
137     open UTFOUT, '>:utf8', "dup$$" or die $!;
138     open UTFDUP, '>&UTFOUT' or die $!;
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";
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;
155
156     END { 1 while unlink "dup$$" }
157 }