Commit | Line | Data |
---|---|---|
92331800 NC |
1 | #!perl -w |
2 | ||
3 | BEGIN { | |
e4206093 NC |
4 | chdir 't'; |
5 | @INC = '../lib'; | |
6 | require './test.pl'; | |
92331800 NC |
7 | } |
8 | ||
e4206093 | 9 | plan(tests => 215); |
92331800 | 10 | |
ec9af7d4 | 11 | package UTF8Toggle; |
92331800 NC |
12 | use strict; |
13 | ||
12abf4f0 | 14 | use overload '""' => 'stringify', fallback => 1; |
92331800 NC |
15 | |
16 | sub new { | |
17 | my $class = shift; | |
676f44e7 NC |
18 | my $value = shift; |
19 | my $state = shift||0; | |
20 | return bless [$value, $state], $class; | |
92331800 NC |
21 | } |
22 | ||
23 | sub stringify { | |
24 | my $self = shift; | |
25 | $self->[1] = ! $self->[1]; | |
26 | if ($self->[1]) { | |
27 | utf8::downgrade($self->[0]); | |
28 | } else { | |
29 | utf8::upgrade($self->[0]); | |
30 | } | |
31 | $self->[0]; | |
32 | } | |
33 | ||
34 | package main; | |
35 | ||
36 | # Bug 34297 | |
37 | foreach my $t ("ASCII", "B\366se") { | |
38 | my $length = length $t; | |
39 | ||
ec9af7d4 | 40 | my $u = UTF8Toggle->new($t); |
92331800 NC |
41 | is (length $u, $length, "length of '$t'"); |
42 | is (length $u, $length, "length of '$t'"); | |
43 | is (length $u, $length, "length of '$t'"); | |
44 | is (length $u, $length, "length of '$t'"); | |
45 | } | |
ec9af7d4 | 46 | |
6e08b83d NC |
47 | my $u = UTF8Toggle->new("\311"); |
48 | my $lc = lc $u; | |
49 | is (length $lc, 1); | |
bce8aa37 | 50 | is ($lc, "\311", "E acute -> e acute"); |
6e08b83d NC |
51 | $lc = lc $u; |
52 | is (length $lc, 1); | |
bce8aa37 | 53 | is ($lc, "\351", "E acute -> e acute"); |
6e08b83d NC |
54 | $lc = lc $u; |
55 | is (length $lc, 1); | |
bce8aa37 | 56 | is ($lc, "\311", "E acute -> e acute"); |
6e08b83d NC |
57 | |
58 | $u = UTF8Toggle->new("\351"); | |
59 | my $uc = uc $u; | |
60 | is (length $uc, 1); | |
bce8aa37 | 61 | is ($uc, "\351", "e acute -> E acute"); |
6e08b83d NC |
62 | $uc = uc $u; |
63 | is (length $uc, 1); | |
bce8aa37 | 64 | is ($uc, "\311", "e acute -> E acute"); |
6e08b83d NC |
65 | $uc = uc $u; |
66 | is (length $uc, 1); | |
bce8aa37 | 67 | is ($uc, "\351", "e acute -> E acute"); |
6e08b83d NC |
68 | |
69 | $u = UTF8Toggle->new("\311"); | |
70 | $lc = lcfirst $u; | |
71 | is (length $lc, 1); | |
bce8aa37 | 72 | is ($lc, "\311", "E acute -> e acute"); |
6e08b83d NC |
73 | $lc = lcfirst $u; |
74 | is (length $lc, 1); | |
bce8aa37 | 75 | is ($lc, "\351", "E acute -> e acute"); |
6e08b83d NC |
76 | $lc = lcfirst $u; |
77 | is (length $lc, 1); | |
bce8aa37 | 78 | is ($lc, "\311", "E acute -> e acute"); |
6e08b83d NC |
79 | |
80 | $u = UTF8Toggle->new("\351"); | |
81 | $uc = ucfirst $u; | |
82 | is (length $uc, 1); | |
bce8aa37 | 83 | is ($uc, "\351", "e acute -> E acute"); |
6e08b83d NC |
84 | $uc = ucfirst $u; |
85 | is (length $uc, 1); | |
bce8aa37 | 86 | is ($uc, "\311", "e acute -> E acute"); |
6e08b83d NC |
87 | $uc = ucfirst $u; |
88 | is (length $uc, 1); | |
bce8aa37 | 89 | is ($uc, "\351", "e acute -> E acute"); |
6e08b83d | 90 | |
ec9af7d4 NC |
91 | my $have_setlocale = 0; |
92 | eval { | |
93 | require POSIX; | |
94 | import POSIX ':locale_h'; | |
95 | $have_setlocale++; | |
96 | }; | |
97 | ||
98 | SKIP: { | |
99 | if (!$have_setlocale) { | |
6e08b83d | 100 | skip "No setlocale", 24; |
ec9af7d4 | 101 | } elsif (!setlocale(&POSIX::LC_ALL, "en_GB.ISO8859-1")) { |
6e08b83d | 102 | skip "Could not setlocale to en_GB.ISO8859-1", 24; |
23ae3dfb | 103 | } elsif ($^O eq 'dec_osf' || $^O eq 'VMS') { |
bce8aa37 | 104 | skip "$^O has broken en_GB.ISO8859-1 locale", 24; |
ec9af7d4 NC |
105 | } else { |
106 | use locale; | |
107 | my $u = UTF8Toggle->new("\311"); | |
108 | my $lc = lc $u; | |
109 | is (length $lc, 1); | |
bce8aa37 | 110 | is ($lc, "\351", "E acute -> e acute"); |
ec9af7d4 NC |
111 | $lc = lc $u; |
112 | is (length $lc, 1); | |
bce8aa37 | 113 | is ($lc, "\351", "E acute -> e acute"); |
6e08b83d NC |
114 | $lc = lc $u; |
115 | is (length $lc, 1); | |
bce8aa37 | 116 | is ($lc, "\351", "E acute -> e acute"); |
67306194 NC |
117 | |
118 | $u = UTF8Toggle->new("\351"); | |
119 | my $uc = uc $u; | |
120 | is (length $uc, 1); | |
bce8aa37 | 121 | is ($uc, "\311", "e acute -> E acute"); |
67306194 NC |
122 | $uc = uc $u; |
123 | is (length $uc, 1); | |
bce8aa37 | 124 | is ($uc, "\311", "e acute -> E acute"); |
6e08b83d NC |
125 | $uc = uc $u; |
126 | is (length $uc, 1); | |
bce8aa37 | 127 | is ($uc, "\311", "e acute -> E acute"); |
d54190f6 NC |
128 | |
129 | $u = UTF8Toggle->new("\311"); | |
130 | $lc = lcfirst $u; | |
131 | is (length $lc, 1); | |
bce8aa37 | 132 | is ($lc, "\351", "E acute -> e acute"); |
d54190f6 NC |
133 | $lc = lcfirst $u; |
134 | is (length $lc, 1); | |
bce8aa37 | 135 | is ($lc, "\351", "E acute -> e acute"); |
6e08b83d NC |
136 | $lc = lcfirst $u; |
137 | is (length $lc, 1); | |
bce8aa37 | 138 | is ($lc, "\351", "E acute -> e acute"); |
d54190f6 NC |
139 | |
140 | $u = UTF8Toggle->new("\351"); | |
141 | $uc = ucfirst $u; | |
142 | is (length $uc, 1); | |
bce8aa37 | 143 | is ($uc, "\311", "e acute -> E acute"); |
d54190f6 NC |
144 | $uc = ucfirst $u; |
145 | is (length $uc, 1); | |
bce8aa37 | 146 | is ($uc, "\311", "e acute -> E acute"); |
6e08b83d NC |
147 | $uc = ucfirst $u; |
148 | is (length $uc, 1); | |
bce8aa37 | 149 | is ($uc, "\311", "e acute -> E acute"); |
ec9af7d4 NC |
150 | } |
151 | } | |
676f44e7 | 152 | |
6ddfe9e8 | 153 | my $tmpfile = tempfile(); |
676f44e7 | 154 | |
c9cb0f41 NC |
155 | foreach my $operator ('print', 'syswrite', 'syswrite len', 'syswrite off', |
156 | 'syswrite len off') { | |
676f44e7 NC |
157 | foreach my $layer ('', ':utf8') { |
158 | open my $fh, "+>$layer", $tmpfile or die $!; | |
c9cb0f41 NC |
159 | my $pad = $operator =~ /\boff\b/ ? "\243" : ""; |
160 | my $trail = $operator =~ /\blen\b/ ? "!" : ""; | |
161 | my $u = UTF8Toggle->new("$pad\311\n$trail"); | |
162 | my $l = UTF8Toggle->new("$pad\351\n$trail", 1); | |
163 | if ($operator eq 'print') { | |
b3c6e229 | 164 | no warnings 'utf8'; |
c9cb0f41 NC |
165 | print $fh $u; |
166 | print $fh $u; | |
167 | print $fh $u; | |
168 | print $fh $l; | |
169 | print $fh $l; | |
170 | print $fh $l; | |
171 | } elsif ($operator eq 'syswrite') { | |
172 | syswrite $fh, $u; | |
173 | syswrite $fh, $u; | |
174 | syswrite $fh, $u; | |
175 | syswrite $fh, $l; | |
176 | syswrite $fh, $l; | |
177 | syswrite $fh, $l; | |
178 | } elsif ($operator eq 'syswrite len') { | |
179 | syswrite $fh, $u, 2; | |
180 | syswrite $fh, $u, 2; | |
181 | syswrite $fh, $u, 2; | |
182 | syswrite $fh, $l, 2; | |
183 | syswrite $fh, $l, 2; | |
184 | syswrite $fh, $l, 2; | |
185 | } elsif ($operator eq 'syswrite off' | |
186 | || $operator eq 'syswrite len off') { | |
187 | syswrite $fh, $u, 2, 1; | |
188 | syswrite $fh, $u, 2, 1; | |
189 | syswrite $fh, $u, 2, 1; | |
190 | syswrite $fh, $l, 2, 1; | |
191 | syswrite $fh, $l, 2, 1; | |
192 | syswrite $fh, $l, 2, 1; | |
193 | } else { | |
194 | die $operator; | |
195 | } | |
676f44e7 NC |
196 | |
197 | seek $fh, 0, 0 or die $!; | |
198 | my $line; | |
199 | chomp ($line = <$fh>); | |
200 | is ($line, "\311", "$operator $layer"); | |
201 | chomp ($line = <$fh>); | |
202 | is ($line, "\311", "$operator $layer"); | |
203 | chomp ($line = <$fh>); | |
204 | is ($line, "\311", "$operator $layer"); | |
205 | chomp ($line = <$fh>); | |
206 | is ($line, "\351", "$operator $layer"); | |
207 | chomp ($line = <$fh>); | |
208 | is ($line, "\351", "$operator $layer"); | |
209 | chomp ($line = <$fh>); | |
210 | is ($line, "\351", "$operator $layer"); | |
211 | ||
212 | close $fh or die $!; | |
676f44e7 NC |
213 | } |
214 | } | |
215 | ||
73ee8be2 NC |
216 | my $little = "\243\243"; |
217 | my $big = " \243 $little ! $little ! $little \243 "; | |
218 | my $right = rindex $big, $little; | |
219 | my $right1 = rindex $big, $little, 11; | |
220 | my $left = index $big, $little; | |
221 | my $left1 = index $big, $little, 4; | |
222 | ||
223 | cmp_ok ($right, ">", $right1, "Sanity check our rindex tests"); | |
224 | cmp_ok ($left, "<", $left1, "Sanity check our index tests"); | |
225 | ||
226 | foreach my $b ($big, UTF8Toggle->new($big)) { | |
227 | foreach my $l ($little, UTF8Toggle->new($little), | |
228 | UTF8Toggle->new($little, 1)) { | |
229 | is (rindex ($b, $l), $right, "rindex"); | |
230 | is (rindex ($b, $l), $right, "rindex"); | |
231 | is (rindex ($b, $l), $right, "rindex"); | |
232 | ||
233 | is (rindex ($b, $l, 11), $right1, "rindex 11"); | |
234 | is (rindex ($b, $l, 11), $right1, "rindex 11"); | |
235 | is (rindex ($b, $l, 11), $right1, "rindex 11"); | |
236 | ||
237 | is (index ($b, $l), $left, "index"); | |
238 | is (index ($b, $l), $left, "index"); | |
239 | is (index ($b, $l), $left, "index"); | |
240 | ||
241 | is (index ($b, $l, 4), $left1, "index 4"); | |
242 | is (index ($b, $l, 4), $left1, "index 4"); | |
243 | is (index ($b, $l, 4), $left1, "index 4"); | |
244 | } | |
245 | } | |
676f44e7 | 246 | |
12abf4f0 NC |
247 | my $bits = "\311"; |
248 | foreach my $pieces ($bits, UTF8Toggle->new($bits)) { | |
249 | like ($bits ^ $pieces, qr/\A\0+\z/, "something xor itself is zeros"); | |
250 | like ($bits ^ $pieces, qr/\A\0+\z/, "something xor itself is zeros"); | |
251 | like ($bits ^ $pieces, qr/\A\0+\z/, "something xor itself is zeros"); | |
252 | ||
253 | like ($pieces ^ $bits, qr/\A\0+\z/, "something xor itself is zeros"); | |
254 | like ($pieces ^ $bits, qr/\A\0+\z/, "something xor itself is zeros"); | |
255 | like ($pieces ^ $bits, qr/\A\0+\z/, "something xor itself is zeros"); | |
256 | } | |
257 | ||
ce399ba6 NC |
258 | foreach my $value ("\243", UTF8Toggle->new("\243")) { |
259 | is (pack ("A/A", $value), pack ("A/A", "\243"), | |
260 | "pack copes with overloading"); | |
261 | is (pack ("A/A", $value), pack ("A/A", "\243")); | |
262 | is (pack ("A/A", $value), pack ("A/A", "\243")); | |
263 | } | |
264 | ||
ab8be49d NC |
265 | foreach my $value ("\243", UTF8Toggle->new("\243")) { |
266 | my $v; | |
267 | $v = substr $value, 0, 1; | |
268 | is ($v, "\243"); | |
269 | $v = substr $value, 0, 1; | |
270 | is ($v, "\243"); | |
271 | $v = substr $value, 0, 1; | |
272 | is ($v, "\243"); | |
273 | } | |
274 | ||
275 | { | |
276 | package RT69422; | |
277 | use overload '""' => sub { $_[0]->{data} } | |
278 | } | |
279 | ||
280 | { | |
281 | my $text = bless { data => "\x{3075}" }, 'RT69422'; | |
282 | my $p = substr $text, 0, 1; | |
283 | is ($p, "\x{3075}"); | |
284 | } |