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