This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Make utf8::encode respect magic
[perl5.git] / t / io / layers.t
1 #!./perl
2
3 my $PERLIO;
4
5 BEGIN {
6     chdir 't' if -d 't';
7     @INC = '../lib';
8     require './test.pl';
9     skip_all_without_perlio();
10     # FIXME - more of these could be tested without Encode or full perl
11     skip_all_without_dynamic_extension('Encode');
12
13     # Makes testing easier.
14     $ENV{PERLIO} = 'stdio' if exists $ENV{PERLIO} && $ENV{PERLIO} eq '';
15     skip_all("PERLIO='$ENV{PERLIO}' unknown")
16         if exists $ENV{PERLIO} && $ENV{PERLIO} !~ /^(stdio|perlio|mmap)$/;
17     $PERLIO = exists $ENV{PERLIO} ? $ENV{PERLIO} : "(undef)";
18 }
19
20 use Config;
21
22 my $DOSISH    = $^O =~ /^(?:MSWin32|os2|dos|NetWare)$/ ? 1 : 0;
23    $DOSISH    = 1 if !$DOSISH and $^O =~ /^uwin/;
24 my $NONSTDIO  = exists $ENV{PERLIO} && $ENV{PERLIO} ne 'stdio'     ? 1 : 0;
25 my $FASTSTDIO = $Config{d_faststdio} && $Config{usefaststdio}      ? 1 : 0;
26 my $UTF8_STDIN;
27 if (${^UNICODE} & 1) {
28     if (${^UNICODE} & 64) {
29         # Conditional on the locale
30         $UTF8_STDIN = ${^UTF8LOCALE};
31     } else {
32         # Unconditional
33         $UTF8_STDIN = 1;
34     }
35 } else {
36     $UTF8_STDIN = 0;
37 }
38 my $NTEST = 60 - (($DOSISH || !$FASTSTDIO) ? 7 : 0) - ($DOSISH ? 7 : 0)
39     + $UTF8_STDIN;
40
41 sub PerlIO::F_UTF8 () { 0x00008000 } # from perliol.h
42
43 plan tests => $NTEST;
44
45 print <<__EOH__;
46 # PERLIO        = $PERLIO
47 # DOSISH        = $DOSISH
48 # NONSTDIO      = $NONSTDIO
49 # FASTSTDIO     = $FASTSTDIO
50 # UNICODE       = ${^UNICODE}
51 # UTF8LOCALE    = ${^UTF8LOCALE}
52 # UTF8_STDIN = $UTF8_STDIN
53 __EOH__
54
55 {
56     sub check {
57         my ($result, $expected, $id) = @_;
58         # An interesting dance follows where we try to make the following
59         # IO layer stack setups to compare equal:
60         #
61         # PERLIO     UNIX-like                   DOS-like
62         #
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
67         #
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"
70         #
71         if ($NONSTDIO) {
72             # Get rid of "unix".
73             shift @$result if $result->[0] eq "unix";
74             # Change expectations.
75             if ($FASTSTDIO) {
76                 $expected->[0] = $ENV{PERLIO};
77             } else {
78                 $expected->[0] = $ENV{PERLIO} if $expected->[0] eq "stdio";
79             }
80         } elsif (!$FASTSTDIO && !$DOSISH) {
81             splice(@$result, 0, 2, "stdio")
82                 if @$result >= 2 &&
83                    $result->[0] eq "unix" &&
84                    $result->[1] eq "perlio";
85         } elsif ($DOSISH) {
86             splice(@$result, 0, 2, "stdio")
87                 if @$result >= 2 &&
88                    $result->[0] eq "unix" &&
89                    $result->[1] eq "crlf";
90         }
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.
95             splice @$expected, 1, 1 if $expected->[1] eq 'crlf';
96         }
97         my $n = scalar @$expected;
98         is(scalar @$result, $n, "$id - layers == $n");
99         for (my $i = 0; $i < $n; $i++) {
100             my $j = $expected->[$i];
101             if (ref $j eq 'CODE') {
102                 ok($j->($result->[$i]), "$id - $i is ok");
103             } else {
104                 is($result->[$i], $j,
105                    sprintf("$id - $i is %s",
106                            defined $j ? $j : "undef"));
107             }
108         }
109     }
110
111     check([ PerlIO::get_layers(STDIN) ],
112           $UTF8_STDIN ? [ "stdio", "utf8" ] : [ "stdio" ],
113           "STDIN");
114
115     my $afile = tempfile();
116     open(F, ">:crlf", $afile);
117
118     check([ PerlIO::get_layers(F) ],
119           [ qw(stdio crlf) ],
120           "open :crlf");
121
122     binmode(F, ":crlf");
123
124     check([ PerlIO::get_layers(F) ],
125           [ qw(stdio crlf) ],
126           "binmode :crlf");
127
128     binmode(F, ":encoding(cp1047)"); 
129
130     check([ PerlIO::get_layers(F) ],
131           [ qw[stdio crlf encoding(cp1047) utf8] ],
132           ":encoding(cp1047)");
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");
139     
140     binmode(F, ":pop:pop");
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
178     # 7 tests potentially skipped.
179     unless ($DOSISH || !$FASTSTDIO) {
180         my @results = PerlIO::get_layers(F, details => 1);
181
182         # Get rid of the args and the flags.
183         splice(@results, 1, 2) if $NONSTDIO;
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     }
190
191     binmode(F);
192
193     check([ PerlIO::get_layers(F) ],
194           [ "stdio" ],
195           "binmode");
196
197     # RT78844
198     {
199         local $@ = "foo";
200         binmode(F, ":encoding(utf8)");
201         is( $@, "foo", '$@ not clobbered by binmode and :encoding');
202     }
203
204     close F;
205
206     {
207         use open(IN => ":crlf", OUT => ":encoding(cp1252)");
208
209         open F, '<', $afile;
210         open G, '>', $afile;
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
224     # Check that PL_sigwarn's reference count is correct, and that 
225     # &PerlIO::Layer::NoWarnings isn't prematurely freed.
226     fresh_perl_like (<<"EOT", qr/^CODE/);
227 open(UTF, "<:raw:encoding(utf8)", '$afile') or die \$!;
228 print ref *PerlIO::Layer::NoWarnings{CODE};
229 EOT
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';
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';
253 }