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