5 require Config; import Config;
7 require './charset_tools.pl';
8 require './loc_tools.pl';
9 set_up_inc( '../lib' );
17 use overload '""' => 'stringify', fallback => 1;
23 return bless [$value, $state], $class;
28 $self->[1] = ! $self->[1];
30 utf8::downgrade($self->[0]);
32 utf8::upgrade($self->[0]);
39 # These tests are based on characters 128-255 not having latin1, and hence
41 # no feature "unicode_strings";
44 foreach my $t ("ASCII", "B" . uni_to_native("\366") . "se") {
45 my $length = length $t;
47 my $u = UTF8Toggle->new($t);
48 is (length $u, $length, "length of '$t'");
49 is (length $u, $length, "length of '$t'");
50 is (length $u, $length, "length of '$t'");
51 is (length $u, $length, "length of '$t'");
54 my $E_acute = uni_to_native("\311");
55 my $e_acute = uni_to_native("\351");
56 my $u = UTF8Toggle->new($E_acute);
59 is ($lc, $E_acute, "E acute -> e acute");
62 is ($lc, $e_acute, "E acute -> e acute");
65 is ($lc, $E_acute, "E acute -> e acute");
67 $u = UTF8Toggle->new($e_acute);
70 is ($uc, $e_acute, "e acute -> E acute");
73 is ($uc, $E_acute, "e acute -> E acute");
76 is ($uc, $e_acute, "e acute -> E acute");
78 $u = UTF8Toggle->new($E_acute);
81 is ($lc, $E_acute, "E acute -> e acute");
84 is ($lc, $e_acute, "E acute -> e acute");
87 is ($lc, $E_acute, "E acute -> e acute");
89 $u = UTF8Toggle->new($e_acute);
92 is ($uc, $e_acute, "e acute -> E acute");
95 is ($uc, $E_acute, "e acute -> E acute");
98 is ($uc, $e_acute, "e acute -> E acute");
100 my $have_setlocale = locales_enabled('LC_ALL');
103 if (!$have_setlocale) {
104 skip "No setlocale", 24;
105 } elsif (!setlocale(&POSIX::LC_ALL, "en_GB.ISO8859-1")) {
106 skip "Could not setlocale to en_GB.ISO8859-1", 24;
107 } elsif ($^O eq 'dec_osf' || $^O eq 'VMS') {
108 skip "$^O has broken en_GB.ISO8859-1 locale", 24;
111 my $u = UTF8Toggle->new($E_acute);
114 is ($lc, $e_acute, "E acute -> e acute");
117 is ($lc, $e_acute, "E acute -> e acute");
120 is ($lc, $e_acute, "E acute -> e acute");
122 $u = UTF8Toggle->new($e_acute);
125 is ($uc, $E_acute, "e acute -> E acute");
128 is ($uc, $E_acute, "e acute -> E acute");
131 is ($uc, $E_acute, "e acute -> E acute");
133 $u = UTF8Toggle->new($E_acute);
136 is ($lc, $e_acute, "E acute -> e acute");
139 is ($lc, $e_acute, "E acute -> e acute");
142 is ($lc, $e_acute, "E acute -> e acute");
144 $u = UTF8Toggle->new($e_acute);
147 is ($uc, $E_acute, "e acute -> E acute");
150 is ($uc, $E_acute, "e acute -> E acute");
153 is ($uc, $E_acute, "e acute -> E acute");
157 my $tmpfile = tempfile();
159 foreach my $operator ('print', 'syswrite', 'syswrite len', 'syswrite off',
160 'syswrite len off') {
161 foreach my $layer ('', ':utf8') {
162 open my $fh, "+>$layer", $tmpfile or die $!;
163 my $pad = $operator =~ /\boff\b/ ? "\243" : "";
164 my $trail = $operator =~ /\blen\b/ ? "!" : "";
165 my $u = UTF8Toggle->new("$pad$E_acute\n$trail");
166 my $l = UTF8Toggle->new("$pad$e_acute\n$trail", 1);
167 no warnings 'deprecated';
168 if ($operator eq 'print') {
176 } elsif ($operator eq 'syswrite') {
183 } elsif ($operator eq 'syswrite len') {
190 } elsif ($operator eq 'syswrite off'
191 || $operator eq 'syswrite len off') {
192 syswrite $fh, $u, 2, 1;
193 syswrite $fh, $u, 2, 1;
194 syswrite $fh, $u, 2, 1;
195 syswrite $fh, $l, 2, 1;
196 syswrite $fh, $l, 2, 1;
197 syswrite $fh, $l, 2, 1;
202 seek $fh, 0, 0 or die $!;
204 chomp ($line = <$fh>);
205 is ($line, $E_acute, "$operator $layer");
206 chomp ($line = <$fh>);
207 is ($line, $E_acute, "$operator $layer");
208 chomp ($line = <$fh>);
209 is ($line, $E_acute, "$operator $layer");
210 chomp ($line = <$fh>);
211 is ($line, $e_acute, "$operator $layer");
212 chomp ($line = <$fh>);
213 is ($line, $e_acute, "$operator $layer");
214 chomp ($line = <$fh>);
215 is ($line, $e_acute, "$operator $layer");
221 my $little = "\243\243";
222 my $big = " \243 $little ! $little ! $little \243 ";
223 my $right = rindex $big, $little;
224 my $right1 = rindex $big, $little, 11;
225 my $left = index $big, $little;
226 my $left1 = index $big, $little, 4;
228 cmp_ok ($right, ">", $right1, "Sanity check our rindex tests");
229 cmp_ok ($left, "<", $left1, "Sanity check our index tests");
231 foreach my $b ($big, UTF8Toggle->new($big)) {
232 foreach my $l ($little, UTF8Toggle->new($little),
233 UTF8Toggle->new($little, 1)) {
234 is (rindex ($b, $l), $right, "rindex");
235 is (rindex ($b, $l), $right, "rindex");
236 is (rindex ($b, $l), $right, "rindex");
238 is (rindex ($b, $l, 11), $right1, "rindex 11");
239 is (rindex ($b, $l, 11), $right1, "rindex 11");
240 is (rindex ($b, $l, 11), $right1, "rindex 11");
242 is (index ($b, $l), $left, "index");
243 is (index ($b, $l), $left, "index");
244 is (index ($b, $l), $left, "index");
246 is (index ($b, $l, 4), $left1, "index 4");
247 is (index ($b, $l, 4), $left1, "index 4");
248 is (index ($b, $l, 4), $left1, "index 4");
253 foreach my $pieces ($bits, UTF8Toggle->new($bits)) {
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 like ($bits ^ $pieces, 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 like ($pieces ^ $bits, qr/\A\0+\z/, "something xor itself is zeros");
263 foreach my $value ("\243", UTF8Toggle->new("\243")) {
264 is (pack ("A/A", $value), pack ("A/A", "\243"),
265 "pack copes with overloading");
266 is (pack ("A/A", $value), pack ("A/A", "\243"));
267 is (pack ("A/A", $value), pack ("A/A", "\243"));
270 foreach my $value ("\243", UTF8Toggle->new("\243")) {
272 $v = substr $value, 0, 1;
274 $v = substr $value, 0, 1;
276 $v = substr $value, 0, 1;
282 use overload '""' => sub { $_[0]->{data} }
286 my $text = bless { data => "\x{3075}" }, 'RT69422';
287 my $p = substr $text, 0, 1;
292 local $::TODO = 'RT #3054: Recursive operator overloading overflows the C stack';
293 # XXX this test is expected to SEGV, and can produce
294 # sh: line 1: 5106 Segmentation fault
295 # on STDERR. So just completely disable for now
297 fresh_perl_is(<<'EOP', "ok\n", {}, 'RT #3054: Recursive operator overloading should not crash the interpreter');
298 use overload '""' => sub { "$_[0]" };
299 print bless {}, __PACKAGE__;
305 local $::TODO = 'RT #3270: Overloaded operators can not be treated as lvalues';
306 fresh_perl_is(<<'EOP', '', {stderr => 1}, 'RT #3270: Overloaded operator that returns an lvalue can be used as an lvalue');
307 use overload '.' => \˙
308 sub dot : lvalue {my ($obj, $method) = @_; $obj -> {$method};}
309 my $o = bless {} => "main";