Commit | Line | Data |
---|---|---|
7d59b7e4 NIS |
1 | #!./perl |
2 | ||
3 | BEGIN { | |
4 | chdir 't' if -d 't'; | |
5 | @INC = '../lib'; | |
0c4f7ff0 | 6 | unless (find PerlIO::Layer 'perlio') { |
7d59b7e4 NIS |
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; |
d2f5bb60 PP |
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 NIS |
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 PP |
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 PP |
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 PP |
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 PP |
49 | $chr = chr(0xa3); |
50 | if (ord('A') == 193) { $chr = chr(0x44); } # EBCDIC | |
51 | print "not " unless getc(F) eq $chr; | |
7d59b7e4 NIS |
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 NIS |
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 NIS |
66 | close(F); |
67 | ||
360eb788 NIS |
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 PP |
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 NIS |
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 NIS |
93 | print F $a; |
94 | my $y; | |
f6c77cf1 | 95 | { my $x = tell(F); |
360eb788 NIS |
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 NIS |
108 | |
109 | { # Check byte length of $b | |
110 | use bytes; my $y = length($b); | |
f9a63242 | 111 | print "not ($y) " unless $y == 1; |
360eb788 NIS |
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 NIS |
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 PP |
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 NIS |
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 NIS |
136 | print "ok 21\n"; |
137 | ||
138 | # Now let's make it suffer. | |
139 | open F, ">", "a" or die $!; | |
ae798467 | 140 | my $w; |
54d2e5f1 JH |
141 | { |
142 | use warnings 'utf8'; | |
143 | local $SIG{__WARN__} = sub { $w = $_[0] }; | |
144 | print F $a; | |
145 | } | |
ae798467 | 146 | print "not " if ($@ || $w !~ /Wide character in print/i); |
360eb788 NIS |
147 | print "ok 22\n"; |
148 | } | |
149 | ||
150 | # Hm. Time to get more evil. | |
151 | open F, ">:utf8", "a" or die $!; | |
152 | print F $a; | |
153 | binmode(F, ":bytes"); | |
154 | print F chr(130)."\n"; | |
155 | close F; | |
156 | ||
157 | open F, "<", "a" or die $!; | |
158 | $x = <F>; chomp $x; | |
d2f5bb60 PP |
159 | $chr = v196.172.130; |
160 | if (ord('A') == 193) { $chr = v141.83.130; } # EBCDIC | |
161 | print "not " unless $x eq $chr; | |
360eb788 NIS |
162 | print "ok 23\n"; |
163 | ||
164 | # Right. | |
165 | open F, ">:utf8", "a" or die $!; | |
166 | print F $a; | |
167 | close F; | |
168 | open F, ">>", "a" or die $!; | |
169 | print F chr(130)."\n"; | |
170 | close F; | |
171 | ||
172 | open F, "<", "a" or die $!; | |
173 | $x = <F>; chomp $x; | |
d2f5bb60 | 174 | print "not " unless $x eq $chr; |
360eb788 NIS |
175 | print "ok 24\n"; |
176 | ||
177 | # Now we have a deformed file. | |
178 | open F, "<:utf8", "a" or die $!; | |
179 | $x = <F>; chomp $x; | |
180 | { local $SIG{__WARN__} = sub { print "ok 25\n"; }; | |
181 | eval { sprintf "%vd\n", $x; } | |
182 | } | |
183 | ||
4f0c37ba | 184 | close F; |
360eb788 | 185 | unlink('a'); |
7d59b7e4 | 186 |