Commit | Line | Data |
7d59b7e4 |
1 | #!./perl |
2 | |
3 | BEGIN { |
4 | chdir 't' if -d 't'; |
5 | @INC = '../lib'; |
0c4f7ff0 |
6 | unless (find PerlIO::Layer 'perlio') { |
7d59b7e4 |
7 | print "1..0 # Skip: not perlio\n"; |
8 | exit 0; |
9 | } |
10 | } |
11 | |
169da838 |
12 | no utf8; # needed for use utf8 not griping about the raw octets |
3ba0e062 |
13 | |
7d59b7e4 |
14 | $| = 1; |
b5d30a84 |
15 | print "1..49\n"; |
7d59b7e4 |
16 | |
17 | open(F,"+>:utf8",'a'); |
18 | print F chr(0x100).'£'; |
19 | print '#'.tell(F)."\n"; |
20 | print "not " unless tell(F) == 4; |
21 | print "ok 1\n"; |
22 | print F "\n"; |
23 | print '#'.tell(F)."\n"; |
24 | print "not " unless tell(F) >= 5; |
25 | print "ok 2\n"; |
26 | seek(F,0,0); |
27 | print "not " unless getc(F) eq chr(0x100); |
28 | print "ok 3\n"; |
29 | print "not " unless getc(F) eq "£"; |
30 | print "ok 4\n"; |
31 | print "not " unless getc(F) eq "\n"; |
32 | print "ok 5\n"; |
33 | seek(F,0,0); |
34 | binmode(F,":bytes"); |
d2f5bb60 |
35 | my $chr = chr(0xc4); |
36 | if (ord('A') == 193) { $chr = chr(0x8c); } # EBCDIC |
37 | print "not " unless getc(F) eq $chr; |
7d59b7e4 |
38 | print "ok 6\n"; |
d2f5bb60 |
39 | $chr = chr(0x80); |
40 | if (ord('A') == 193) { $chr = chr(0x41); } # EBCDIC |
41 | print "not " unless getc(F) eq $chr; |
7d59b7e4 |
42 | print "ok 7\n"; |
d2f5bb60 |
43 | $chr = chr(0xc2); |
44 | if (ord('A') == 193) { $chr = chr(0x80); } # EBCDIC |
45 | print "not " unless getc(F) eq $chr; |
7d59b7e4 |
46 | print "ok 8\n"; |
d2f5bb60 |
47 | $chr = chr(0xa3); |
48 | if (ord('A') == 193) { $chr = chr(0x44); } # EBCDIC |
49 | print "not " unless getc(F) eq $chr; |
7d59b7e4 |
50 | print "ok 9\n"; |
51 | print "not " unless getc(F) eq "\n"; |
52 | print "ok 10\n"; |
53 | seek(F,0,0); |
54 | binmode(F,":utf8"); |
55 | print "not " unless scalar(<F>) eq "\x{100}£\n"; |
56 | print "ok 11\n"; |
eb5c063a |
57 | seek(F,0,0); |
58 | $buf = chr(0x200); |
59 | $count = read(F,$buf,2,1); |
60 | print "not " unless $count == 2; |
61 | print "ok 12\n"; |
62 | print "not " unless $buf eq "\x{200}\x{100}£"; |
63 | print "ok 13\n"; |
7d59b7e4 |
64 | close(F); |
65 | |
360eb788 |
66 | { |
7b89fb7c |
67 | $a = chr(300); # This *is* UTF-encoded |
68 | $b = chr(130); # This is not. |
6874a2de |
69 | |
7b89fb7c |
70 | open F, ">:utf8", 'a' or die $!; |
71 | print F $a,"\n"; |
72 | close F; |
6874a2de |
73 | |
7b89fb7c |
74 | open F, "<:utf8", 'a' or die $!; |
75 | $x = <F>; |
76 | chomp($x); |
77 | print "not " unless $x eq chr(300); |
78 | print "ok 14\n"; |
6874a2de |
79 | |
7b89fb7c |
80 | open F, "a" or die $!; # Not UTF |
81 | binmode(F, ":bytes"); |
82 | $x = <F>; |
83 | chomp($x); |
84 | $chr = chr(196).chr(172); |
85 | if (ord('A') == 193) { $chr = chr(141).chr(83); } # EBCDIC |
86 | print "not " unless $x eq $chr; |
87 | print "ok 15\n"; |
88 | close F; |
6874a2de |
89 | |
7b89fb7c |
90 | open F, ">:utf8", 'a' or die $!; |
91 | binmode(F); # we write a "\n" and then tell() - avoid CRLF issues. |
6874a2de |
92 | binmode(F,":utf8"); # turn UTF-8-ness back on |
7b89fb7c |
93 | print F $a; |
94 | my $y; |
95 | { my $x = tell(F); |
96 | { use bytes; $y = length($a);} |
97 | print "not " unless $x == $y; |
98 | print "ok 16\n"; |
99 | } |
6874a2de |
100 | |
7b89fb7c |
101 | { # Check byte length of $b |
102 | use bytes; my $y = length($b); |
103 | print "not " unless $y == 1; |
104 | print "ok 17\n"; |
105 | } |
6874a2de |
106 | |
7b89fb7c |
107 | print F $b,"\n"; # Don't upgrades $b |
6874a2de |
108 | |
7b89fb7c |
109 | { # Check byte length of $b |
110 | use bytes; my $y = length($b); |
111 | print "not ($y) " unless $y == 1; |
112 | print "ok 18\n"; |
113 | } |
6874a2de |
114 | |
7b89fb7c |
115 | { |
116 | my $x = tell(F); |
117 | { use bytes; if (ord('A')==193){$y += 2;}else{$y += 3;}} # EBCDIC ASCII |
118 | print "not ($x,$y) " unless $x == $y; |
119 | print "ok 19\n"; |
120 | } |
6874a2de |
121 | |
7b89fb7c |
122 | close F; |
6874a2de |
123 | |
7b89fb7c |
124 | open F, "a" or die $!; # Not UTF |
125 | binmode(F, ":bytes"); |
126 | $x = <F>; |
127 | chomp($x); |
128 | $chr = v196.172.194.130; |
129 | if (ord('A') == 193) { $chr = v141.83.130; } # EBCDIC |
130 | printf "not (%vd) ", $x unless $x eq $chr; |
131 | print "ok 20\n"; |
6874a2de |
132 | |
7b89fb7c |
133 | open F, "<:utf8", "a" or die $!; |
134 | $x = <F>; |
135 | chomp($x); |
136 | close F; |
137 | printf "not (%vd) ", $x unless $x eq chr(300).chr(130); |
138 | print "ok 21\n"; |
6874a2de |
139 | |
3eb9224a |
140 | open F, ">", "a" or die $!; |
7b89fb7c |
141 | if (${^OPEN} =~ /:utf8/) { |
142 | binmode(F, ":bytes:"); |
143 | } |
144 | |
145 | # Now let's make it suffer. |
3eb9224a |
146 | my $w; |
147 | { |
148 | use warnings 'utf8'; |
149 | local $SIG{__WARN__} = sub { $w = $_[0] }; |
150 | print F $a; |
7b89fb7c |
151 | print "not " if ($@ || $w !~ /Wide character in print/i); |
3eb9224a |
152 | } |
3eb9224a |
153 | print "ok 22\n"; |
54d2e5f1 |
154 | } |
360eb788 |
155 | |
156 | # Hm. Time to get more evil. |
157 | open F, ">:utf8", "a" or die $!; |
158 | print F $a; |
159 | binmode(F, ":bytes"); |
160 | print F chr(130)."\n"; |
161 | close F; |
6874a2de |
162 | |
360eb788 |
163 | open F, "<", "a" or die $!; |
3eb9224a |
164 | binmode(F, ":bytes"); |
360eb788 |
165 | $x = <F>; chomp $x; |
d2f5bb60 |
166 | $chr = v196.172.130; |
167 | if (ord('A') == 193) { $chr = v141.83.130; } # EBCDIC |
168 | print "not " unless $x eq $chr; |
360eb788 |
169 | print "ok 23\n"; |
170 | |
171 | # Right. |
172 | open F, ">:utf8", "a" or die $!; |
173 | print F $a; |
174 | close F; |
175 | open F, ">>", "a" or die $!; |
176 | print F chr(130)."\n"; |
177 | close F; |
178 | |
179 | open F, "<", "a" or die $!; |
180 | $x = <F>; chomp $x; |
d2f5bb60 |
181 | print "not " unless $x eq $chr; |
360eb788 |
182 | print "ok 24\n"; |
183 | |
184 | # Now we have a deformed file. |
d0965105 |
185 | |
186 | if (ord('A') == 193) { |
187 | print "ok 25 # Skip: EBCDIC\n"; # EBCDIC doesn't complain |
188 | } else { |
189 | open F, "<:utf8", "a" or die $!; |
190 | $x = <F>; chomp $x; |
191 | local $SIG{__WARN__} = sub { print "ok 25\n" }; |
192 | eval { sprintf "%vd\n", $x }; |
360eb788 |
193 | } |
194 | |
4f0c37ba |
195 | close F; |
360eb788 |
196 | unlink('a'); |
7d59b7e4 |
197 | |
62961d2e |
198 | open F, ">:utf8", "a"; |
d0965105 |
199 | @a = map { chr(1 << ($_ << 2)) } 0..5; # 0x1, 0x10, .., 0x100000 |
c36dfd09 |
200 | unshift @a, chr(0); # ... and a null byte in front just for fun |
d0965105 |
201 | print F @a; |
202 | close F; |
c36dfd09 |
203 | |
c88828dc |
204 | my $c; |
205 | |
206 | # read() should work on characters, not bytes |
d0965105 |
207 | open F, "<:utf8", "a"; |
208 | $a = 0; |
209 | for (@a) { |
c88828dc |
210 | unless (($c = read(F, $b, 1) == 1) && |
211 | length($b) == 1 && |
212 | ord($b) == ord($_) && |
213 | tell(F) == ($a += bytes::length($b))) { |
34fce102 |
214 | print '# ord($_) == ', ord($_), "\n"; |
215 | print '# ord($b) == ', ord($b), "\n"; |
216 | print '# length($b) == ', length($b), "\n"; |
217 | print '# bytes::length($b) == ', bytes::length($b), "\n"; |
218 | print '# tell(F) == ', tell(F), "\n"; |
219 | print '# $a == ', $a, "\n"; |
220 | print '# $c == ', $c, "\n"; |
d0965105 |
221 | print "not "; |
222 | last; |
223 | } |
224 | } |
c36dfd09 |
225 | close F; |
d0965105 |
226 | print "ok 26\n"; |
227 | |
62961d2e |
228 | { |
229 | # Check that warnings are on on I/O, and that they can be muffled. |
230 | |
231 | local $SIG{__WARN__} = sub { $@ = shift }; |
232 | |
233 | undef $@; |
234 | open F, ">a"; |
3eb9224a |
235 | binmode(F, ":bytes"); |
62961d2e |
236 | print F chr(0x100); |
237 | close(F); |
238 | |
239 | print $@ =~ /Wide character in print/ ? "ok 27\n" : "not ok 27\n"; |
240 | |
241 | undef $@; |
2b1ff55a |
242 | open F, ">:utf8", "a"; |
62961d2e |
243 | print F chr(0x100); |
244 | close(F); |
245 | |
246 | print defined $@ ? "not ok 28\n" : "ok 28\n"; |
247 | |
248 | undef $@; |
249 | open F, ">a"; |
250 | binmode(F, ":utf8"); |
251 | print F chr(0x100); |
252 | close(F); |
253 | |
254 | print defined $@ ? "not ok 29\n" : "ok 29\n"; |
255 | |
256 | no warnings 'utf8'; |
257 | |
258 | undef $@; |
259 | open F, ">a"; |
260 | print F chr(0x100); |
261 | close(F); |
262 | |
263 | print defined $@ ? "not ok 30\n" : "ok 30\n"; |
264 | |
265 | use warnings 'utf8'; |
266 | |
267 | undef $@; |
268 | open F, ">a"; |
3eb9224a |
269 | binmode(F, ":bytes"); |
62961d2e |
270 | print F chr(0x100); |
271 | close(F); |
272 | |
273 | print $@ =~ /Wide character in print/ ? "ok 31\n" : "not ok 31\n"; |
274 | } |
275 | |
efd8b2ba |
276 | { |
277 | open F, ">:bytes","a"; print F "\xde"; close F; |
278 | |
279 | open F, "<:bytes", "a"; |
280 | my $b = chr 0x100; |
281 | $b .= <F>; |
282 | print $b eq chr(0x100).chr(0xde) ? "ok 32" : "not ok 32"; |
283 | print " \#21395 '.= <>' utf8 vs. bytes\n"; |
284 | close F; |
285 | } |
286 | |
287 | { |
288 | open F, ">:utf8","a"; print F chr 0x100; close F; |
289 | |
290 | open F, "<:utf8", "a"; |
291 | my $b = "\xde"; |
292 | $b .= <F>; |
293 | print $b eq chr(0xde).chr(0x100) ? "ok 33" : "not ok 33"; |
294 | print " \#21395 '.= <>' bytes vs. utf8\n"; |
295 | close F; |
296 | } |
297 | |
b5d30a84 |
298 | { |
299 | my @a = ( [ 0x007F, "bytes" ], |
300 | [ 0x0080, "bytes" ], |
301 | [ 0x0080, "utf8" ], |
302 | [ 0x0100, "utf8" ] ); |
303 | my $t = 34; |
304 | for my $u (@a) { |
305 | for my $v (@a) { |
306 | # print "# @$u - @$v\n"; |
307 | open F, ">a"; |
308 | binmode(F, ":" . $u->[1]); |
309 | print F chr($u->[0]); |
310 | close F; |
311 | |
312 | open F, "<a"; |
313 | binmode(F, ":" . $u->[1]); |
314 | |
315 | my $s = chr($v->[0]); |
316 | utf8::upgrade($s) if $v->[1] eq "utf8"; |
317 | |
318 | $s .= <F>; |
319 | print $s eq chr($v->[0]) . chr($u->[0]) ? |
320 | "ok $t # rcatline utf8\n" : "not ok $t # rcatline utf8\n"; |
321 | close F; |
322 | $t++; |
323 | } |
324 | } |
11c2f0cf |
325 | # last test here 49 |
b5d30a84 |
326 | } |
327 | |
e111333b |
328 | # sysread() and syswrite() tested in lib/open.t since Fnctl is used |
c88828dc |
329 | |
330 | END { |
331 | 1 while unlink "a"; |
332 | 1 while unlink "b"; |
333 | } |
e111333b |
334 | |