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