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 | |
3ba0e062 |
12 | no utf8; # so that the naked 8-bit chars won't gripe under use utf8 |
13 | |
7d59b7e4 |
14 | $| = 1; |
d2f5bb60 |
15 | my $total_tests = 25; |
16 | if (ord('A') == 193) { $total_tests = 24; } # EBCDIC platforms do not warn on UTF-8 |
17 | print "1..$total_tests\n"; |
7d59b7e4 |
18 | |
19 | open(F,"+>:utf8",'a'); |
20 | print F chr(0x100).'£'; |
21 | print '#'.tell(F)."\n"; |
22 | print "not " unless tell(F) == 4; |
23 | print "ok 1\n"; |
24 | print F "\n"; |
25 | print '#'.tell(F)."\n"; |
26 | print "not " unless tell(F) >= 5; |
27 | print "ok 2\n"; |
28 | seek(F,0,0); |
29 | print "not " unless getc(F) eq chr(0x100); |
30 | print "ok 3\n"; |
31 | print "not " unless getc(F) eq "£"; |
32 | print "ok 4\n"; |
33 | print "not " unless getc(F) eq "\n"; |
34 | print "ok 5\n"; |
35 | seek(F,0,0); |
36 | binmode(F,":bytes"); |
d2f5bb60 |
37 | my $chr = chr(0xc4); |
38 | if (ord('A') == 193) { $chr = chr(0x8c); } # EBCDIC |
39 | print "not " unless getc(F) eq $chr; |
7d59b7e4 |
40 | print "ok 6\n"; |
d2f5bb60 |
41 | $chr = chr(0x80); |
42 | if (ord('A') == 193) { $chr = chr(0x41); } # EBCDIC |
43 | print "not " unless getc(F) eq $chr; |
7d59b7e4 |
44 | print "ok 7\n"; |
d2f5bb60 |
45 | $chr = chr(0xc2); |
46 | if (ord('A') == 193) { $chr = chr(0x80); } # EBCDIC |
47 | print "not " unless getc(F) eq $chr; |
7d59b7e4 |
48 | print "ok 8\n"; |
d2f5bb60 |
49 | $chr = chr(0xa3); |
50 | if (ord('A') == 193) { $chr = chr(0x44); } # EBCDIC |
51 | print "not " unless getc(F) eq $chr; |
7d59b7e4 |
52 | print "ok 9\n"; |
53 | print "not " unless getc(F) eq "\n"; |
54 | print "ok 10\n"; |
55 | seek(F,0,0); |
56 | binmode(F,":utf8"); |
57 | print "not " unless scalar(<F>) eq "\x{100}£\n"; |
58 | print "ok 11\n"; |
eb5c063a |
59 | seek(F,0,0); |
60 | $buf = chr(0x200); |
61 | $count = read(F,$buf,2,1); |
62 | print "not " unless $count == 2; |
63 | print "ok 12\n"; |
64 | print "not " unless $buf eq "\x{200}\x{100}£"; |
65 | print "ok 13\n"; |
7d59b7e4 |
66 | close(F); |
67 | |
360eb788 |
68 | { |
69 | $a = chr(300); # This *is* UTF-encoded |
70 | $b = chr(130); # This is not. |
71 | |
72 | open F, ">:utf8", 'a' or die $!; |
73 | print F $a,"\n"; |
74 | close F; |
75 | |
76 | open F, "<:utf8", 'a' or die $!; |
77 | $x = <F>; |
78 | chomp($x); |
79 | print "not " unless $x eq chr(300); |
80 | print "ok 14\n"; |
81 | |
82 | open F, "a" or die $!; # Not UTF |
83 | $x = <F>; |
84 | chomp($x); |
d2f5bb60 |
85 | $chr = chr(196).chr(172); |
86 | if (ord('A') == 193) { $chr = chr(141).chr(83); } # EBCDIC |
87 | print "not " unless $x eq $chr; |
360eb788 |
88 | print "ok 15\n"; |
89 | close F; |
90 | |
91 | open F, ">:utf8", 'a' or die $!; |
79086a00 |
92 | binmode(F); # we write a "\n" and then tell() - avoid CRLF issues. |
360eb788 |
93 | print F $a; |
94 | my $y; |
f6c77cf1 |
95 | { my $x = tell(F); |
360eb788 |
96 | { use bytes; $y = length($a);} |
97 | print "not " unless $x == $y; |
98 | print "ok 16\n"; |
99 | } |
100 | |
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 | } |
106 | |
f9a63242 |
107 | print F $b,"\n"; # Don't upgrades $b |
360eb788 |
108 | |
109 | { # Check byte length of $b |
110 | use bytes; my $y = length($b); |
f9a63242 |
111 | print "not ($y) " unless $y == 1; |
360eb788 |
112 | print "ok 18\n"; |
113 | } |
114 | |
f6c77cf1 |
115 | { my $x = tell(F); |
d2f5bb60 |
116 | { use bytes; if (ord('A')==193){$y += 2;}else{$y += 3;}} # EBCDIC ASCII |
f9a63242 |
117 | print "not ($x,$y) " unless $x == $y; |
360eb788 |
118 | print "ok 19\n"; |
119 | } |
120 | |
121 | close F; |
122 | |
123 | open F, "a" or die $!; # Not UTF |
124 | $x = <F>; |
125 | chomp($x); |
d2f5bb60 |
126 | $chr = v196.172.194.130; |
127 | if (ord('A') == 193) { $chr = v141.83.130; } # EBCDIC |
128 | printf "not (%vd) ", $x unless $x eq $chr; |
360eb788 |
129 | print "ok 20\n"; |
130 | |
131 | open F, "<:utf8", "a" or die $!; |
132 | $x = <F>; |
133 | chomp($x); |
134 | close F; |
f9a63242 |
135 | printf "not (%vd) ", $x unless $x eq chr(300).chr(130); |
360eb788 |
136 | print "ok 21\n"; |
137 | |
138 | # Now let's make it suffer. |
139 | open F, ">", "a" or die $!; |
ae798467 |
140 | my $w; |
141 | eval {local $SIG{__WARN__} = sub { $w = $_[0] }; print F $a; }; |
142 | print "not " if ($@ || $w !~ /Wide character in print/i); |
360eb788 |
143 | print "ok 22\n"; |
144 | } |
145 | |
146 | # Hm. Time to get more evil. |
147 | open F, ">:utf8", "a" or die $!; |
148 | print F $a; |
149 | binmode(F, ":bytes"); |
150 | print F chr(130)."\n"; |
151 | close F; |
152 | |
153 | open F, "<", "a" or die $!; |
154 | $x = <F>; chomp $x; |
d2f5bb60 |
155 | $chr = v196.172.130; |
156 | if (ord('A') == 193) { $chr = v141.83.130; } # EBCDIC |
157 | print "not " unless $x eq $chr; |
360eb788 |
158 | print "ok 23\n"; |
159 | |
160 | # Right. |
161 | open F, ">:utf8", "a" or die $!; |
162 | print F $a; |
163 | close F; |
164 | open F, ">>", "a" or die $!; |
165 | print F chr(130)."\n"; |
166 | close F; |
167 | |
168 | open F, "<", "a" or die $!; |
169 | $x = <F>; chomp $x; |
d2f5bb60 |
170 | print "not " unless $x eq $chr; |
360eb788 |
171 | print "ok 24\n"; |
172 | |
173 | # Now we have a deformed file. |
174 | open F, "<:utf8", "a" or die $!; |
175 | $x = <F>; chomp $x; |
176 | { local $SIG{__WARN__} = sub { print "ok 25\n"; }; |
177 | eval { sprintf "%vd\n", $x; } |
178 | } |
179 | |
4f0c37ba |
180 | close F; |
360eb788 |
181 | unlink('a'); |
7d59b7e4 |
182 | |