This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Tidy t/io/layers.t
[perl5.git] / t / io / layers.t
CommitLineData
39f7a870
JH
1#!./perl
2
046e4a6a
JH
3my $PERLIO;
4
39f7a870
JH
5BEGIN {
6 chdir 't' if -d 't';
7 @INC = '../lib';
8 require './test.pl';
21da8bce
NC
9 skip_all('not perlio') unless (find PerlIO::Layer 'perlio');
10 # FIXME - more of these could be tested without Encode or full perl
11 skip_all_if_miniperl("no dynamic loading on miniperl, no Encode");
12 require Config; Config->import;
13 skip_all('Encode was not built')
14 unless ($Config::Config{extensions} =~ /\bEncode\b/);
15
3b0db4f9
JH
16 # Makes testing easier.
17 $ENV{PERLIO} = 'stdio' if exists $ENV{PERLIO} && $ENV{PERLIO} eq '';
8d3a61d9 18 if (exists $ENV{PERLIO} && $ENV{PERLIO} !~ /^(stdio|perlio|mmap)$/) {
3b0db4f9 19 # We are not prepared for anything else.
8d3a61d9
JH
20 print "1..0 # PERLIO='$ENV{PERLIO}' unknown\n";
21 exit 0;
22 }
046e4a6a 23 $PERLIO = exists $ENV{PERLIO} ? $ENV{PERLIO} : "(undef)";
39f7a870
JH
24}
25
39f7a870 26
cd86ed9d 27my $DOSISH = $^O =~ /^(?:MSWin32|os2|dos|NetWare)$/ ? 1 : 0;
cebd85e6 28 $DOSISH = 1 if !$DOSISH and $^O =~ /^uwin/;
15b61c98
JH
29my $NONSTDIO = exists $ENV{PERLIO} && $ENV{PERLIO} ne 'stdio' ? 1 : 0;
30my $FASTSTDIO = $Config{d_faststdio} && $Config{usefaststdio} ? 1 : 0;
a45f1ba0 31my $UTF8_STDIN;
7a403565
NC
32if (${^UNICODE} & 1) {
33 if (${^UNICODE} & 64) {
34 # Conditional on the locale
a45f1ba0 35 $UTF8_STDIN = ${^UTF8LOCALE};
7a403565
NC
36 } else {
37 # Unconditional
a45f1ba0 38 $UTF8_STDIN = 1;
7a403565 39 }
1031ca5c 40} else {
a45f1ba0 41 $UTF8_STDIN = 0;
7a403565 42}
7826b36f 43my $NTEST = 55 - (($DOSISH || !$FASTSTDIO) ? 7 : 0) - ($DOSISH ? 7 : 0)
a45f1ba0 44 + $UTF8_STDIN;
8229d19f 45
7c0e976d
JH
46sub PerlIO::F_UTF8 () { 0x00008000 } # from perliol.h
47
8229d19f
JH
48plan tests => $NTEST;
49
046e4a6a 50print <<__EOH__;
7a403565
NC
51# PERLIO = $PERLIO
52# DOSISH = $DOSISH
53# NONSTDIO = $NONSTDIO
54# FASTSTDIO = $FASTSTDIO
55# UNICODE = ${^UNICODE}
56# UTF8LOCALE = ${^UTF8LOCALE}
a45f1ba0 57# UTF8_STDIN = $UTF8_STDIN
046e4a6a 58__EOH__
52f03692 59
21da8bce 60{
39f7a870
JH
61 sub check {
62 my ($result, $expected, $id) = @_;
3b0db4f9
JH
63 # An interesting dance follows where we try to make the following
64 # IO layer stack setups to compare equal:
65 #
f0fd62e2 66 # PERLIO UNIX-like DOS-like
3b0db4f9 67 #
f0fd62e2
JH
68 # unset / "" unix perlio / stdio [1] unix crlf
69 # stdio unix perlio / stdio [1] stdio
70 # perlio unix perlio unix perlio
71 # mmap unix mmap unix mmap
3b0db4f9 72 #
f0fd62e2
JH
73 # [1] "stdio" if Configure found out how to do "fast stdio" (depends
74 # on the stdio implementation) and in Perl 5.8, otherwise "unix perlio"
046e4a6a 75 #
52f03692 76 if ($NONSTDIO) {
79d9a4d7
JH
77 # Get rid of "unix".
78 shift @$result if $result->[0] eq "unix";
fb189484 79 # Change expectations.
046e4a6a
JH
80 if ($FASTSTDIO) {
81 $expected->[0] = $ENV{PERLIO};
82 } else {
83 $expected->[0] = $ENV{PERLIO} if $expected->[0] eq "stdio";
84 }
e29b014f 85 } elsif (!$FASTSTDIO && !$DOSISH) {
046e4a6a
JH
86 splice(@$result, 0, 2, "stdio")
87 if @$result >= 2 &&
88 $result->[0] eq "unix" &&
89 $result->[1] eq "perlio";
79d9a4d7
JH
90 } elsif ($DOSISH) {
91 splice(@$result, 0, 2, "stdio")
046e4a6a
JH
92 if @$result >= 2 &&
93 $result->[0] eq "unix" &&
79d9a4d7 94 $result->[1] eq "crlf";
fb189484 95 }
8229d19f
JH
96 if ($DOSISH && grep { $_ eq 'crlf' } @$expected) {
97 # 5 tests potentially skipped because
98 # DOSISH systems already have a CRLF layer
99 # which will make new ones not stick.
7826b36f 100 splice @$expected, 1, 1 if $expected->[1] eq 'crlf';
8229d19f 101 }
79d9a4d7 102 my $n = scalar @$expected;
e662ed2b 103 is(scalar @$result, $n, "$id - layers == $n");
39f7a870
JH
104 for (my $i = 0; $i < $n; $i++) {
105 my $j = $expected->[$i];
106 if (ref $j eq 'CODE') {
fb189484 107 ok($j->($result->[$i]), "$id - $i is ok");
39f7a870
JH
108 } else {
109 is($result->[$i], $j,
8d3a61d9
JH
110 sprintf("$id - $i is %s",
111 defined $j ? $j : "undef"));
39f7a870
JH
112 }
113 }
114 }
115
116 check([ PerlIO::get_layers(STDIN) ],
a45f1ba0 117 $UTF8_STDIN ? [ "stdio", "utf8" ] : [ "stdio" ],
39f7a870
JH
118 "STDIN");
119
62a28c97
NC
120 my $afile = tempfile();
121 open(F, ">:crlf", $afile);
39f7a870
JH
122
123 check([ PerlIO::get_layers(F) ],
124 [ qw(stdio crlf) ],
125 "open :crlf");
126
7826b36f
LT
127 binmode(F, ":crlf");
128
129 check([ PerlIO::get_layers(F) ],
130 [ qw(stdio crlf) ],
131 "binmode :crlf");
132
78b7ef06 133 binmode(F, ":encoding(cp1047)");
39f7a870
JH
134
135 check([ PerlIO::get_layers(F) ],
78b7ef06
SP
136 [ qw[stdio crlf encoding(cp1047) utf8] ],
137 ":encoding(cp1047)");
7826b36f
LT
138
139 binmode(F, ":crlf");
140
141 check([ PerlIO::get_layers(F) ],
142 [ qw[stdio crlf encoding(cp1047) utf8 crlf utf8] ],
143 ":encoding(cp1047):crlf");
39f7a870 144
7826b36f 145 binmode(F, ":pop:pop");
39f7a870
JH
146
147 check([ PerlIO::get_layers(F) ],
148 [ qw(stdio crlf) ],
149 ":pop");
150
151 binmode(F, ":raw");
152
153 check([ PerlIO::get_layers(F) ],
154 [ "stdio" ],
155 ":raw");
156
157 binmode(F, ":utf8");
158
159 check([ PerlIO::get_layers(F) ],
160 [ qw(stdio utf8) ],
161 ":utf8");
162
163 binmode(F, ":bytes");
164
165 check([ PerlIO::get_layers(F) ],
166 [ "stdio" ],
167 ":bytes");
168
169 binmode(F, ":encoding(utf8)");
170
171 check([ PerlIO::get_layers(F) ],
172 [ qw[stdio encoding(utf8) utf8] ],
173 ":encoding(utf8)");
174
175 binmode(F, ":raw :crlf");
176
177 check([ PerlIO::get_layers(F) ],
178 [ qw(stdio crlf) ],
179 ":raw:crlf");
180
181 binmode(F, ":raw :encoding(latin1)"); # "latin1" will be canonized
182
8229d19f
JH
183 # 7 tests potentially skipped.
184 unless ($DOSISH || !$FASTSTDIO) {
fb189484
JH
185 my @results = PerlIO::get_layers(F, details => 1);
186
79d9a4d7
JH
187 # Get rid of the args and the flags.
188 splice(@results, 1, 2) if $NONSTDIO;
fb189484
JH
189
190 check([ @results ],
191 [ "stdio", undef, sub { $_[0] > 0 },
192 "encoding", "iso-8859-1", sub { $_[0] & PerlIO::F_UTF8() } ],
193 ":raw:encoding(latin1)");
194 }
39f7a870
JH
195
196 binmode(F);
197
198 check([ PerlIO::get_layers(F) ],
199 [ "stdio" ],
200 "binmode");
201
54f31609
DG
202 # RT78844
203 {
54f31609
DG
204 local $@ = "foo";
205 binmode(F, ":encoding(utf8)");
206 is( $@, "foo", '$@ not clobbered by binmode and :encoding');
207 }
208
39f7a870
JH
209 close F;
210
211 {
212 use open(IN => ":crlf", OUT => ":encoding(cp1252)");
491abfa0 213
62a28c97
NC
214 open F, '<', $afile;
215 open G, '>', $afile;
39f7a870
JH
216
217 check([ PerlIO::get_layers(F, input => 1) ],
218 [ qw(stdio crlf) ],
219 "use open IN");
220
221 check([ PerlIO::get_layers(G, output => 1) ],
222 [ qw[stdio encoding(cp1252) utf8] ],
223 "use open OUT");
224
225 close F;
226 close G;
227 }
228
9cfa90c0
NC
229 # Check that PL_sigwarn's reference count is correct, and that
230 # &PerlIO::Layer::NoWarnings isn't prematurely freed.
62a28c97
NC
231 fresh_perl_like (<<"EOT", qr/^CODE/);
232open(UTF, "<:raw:encoding(utf8)", '$afile') or die \$!;
9cfa90c0
NC
233print ref *PerlIO::Layer::NoWarnings{CODE};
234EOT
39f7a870 235}