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