X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2Funi%2Foverload.t;h=e4f4e132ea39889c98314dc6b31e75c2a56eecfc;hb=a2309040b8fe324ae09c064137c624b4292d93c1;hp=5812425ca547f7a10a95895b1bf6c7a759d65a4d;hpb=c9cb0f4189a96c284198e261ba3e6a7df9d31f55;p=p5sagit%2Fp5-mst-13.2.git diff --git a/t/uni/overload.t b/t/uni/overload.t index 5812425..e4f4e13 100644 --- a/t/uni/overload.t +++ b/t/uni/overload.t @@ -7,12 +7,12 @@ BEGIN { } } -use Test::More tests => 116; +use Test::More tests => 208; package UTF8Toggle; use strict; -use overload '""' => 'stringify'; +use overload '""' => 'stringify', fallback => 1; sub new { my $class = shift; @@ -48,46 +48,46 @@ foreach my $t ("ASCII", "B\366se") { my $u = UTF8Toggle->new("\311"); my $lc = lc $u; is (length $lc, 1); -is ($lc, "\311", "E accute -> e accute"); +is ($lc, "\311", "E acute -> e acute"); $lc = lc $u; is (length $lc, 1); -is ($lc, "\351", "E accute -> e accute"); +is ($lc, "\351", "E acute -> e acute"); $lc = lc $u; is (length $lc, 1); -is ($lc, "\311", "E accute -> e accute"); +is ($lc, "\311", "E acute -> e acute"); $u = UTF8Toggle->new("\351"); my $uc = uc $u; is (length $uc, 1); -is ($uc, "\351", "e accute -> E accute"); +is ($uc, "\351", "e acute -> E acute"); $uc = uc $u; is (length $uc, 1); -is ($uc, "\311", "e accute -> E accute"); +is ($uc, "\311", "e acute -> E acute"); $uc = uc $u; is (length $uc, 1); -is ($uc, "\351", "e accute -> E accute"); +is ($uc, "\351", "e acute -> E acute"); $u = UTF8Toggle->new("\311"); $lc = lcfirst $u; is (length $lc, 1); -is ($lc, "\311", "E accute -> e accute"); +is ($lc, "\311", "E acute -> e acute"); $lc = lcfirst $u; is (length $lc, 1); -is ($lc, "\351", "E accute -> e accute"); +is ($lc, "\351", "E acute -> e acute"); $lc = lcfirst $u; is (length $lc, 1); -is ($lc, "\311", "E accute -> e accute"); +is ($lc, "\311", "E acute -> e acute"); $u = UTF8Toggle->new("\351"); $uc = ucfirst $u; is (length $uc, 1); -is ($uc, "\351", "e accute -> E accute"); +is ($uc, "\351", "e acute -> E acute"); $uc = ucfirst $u; is (length $uc, 1); -is ($uc, "\311", "e accute -> E accute"); +is ($uc, "\311", "e acute -> E acute"); $uc = ucfirst $u; is (length $uc, 1); -is ($uc, "\351", "e accute -> E accute"); +is ($uc, "\351", "e acute -> E acute"); my $have_setlocale = 0; eval { @@ -101,51 +101,53 @@ SKIP: { skip "No setlocale", 24; } elsif (!setlocale(&POSIX::LC_ALL, "en_GB.ISO8859-1")) { skip "Could not setlocale to en_GB.ISO8859-1", 24; + } elsif ($^O eq 'dec_osf' || $^O eq 'VMS') { + skip "$^O has broken en_GB.ISO8859-1 locale", 24; } else { use locale; my $u = UTF8Toggle->new("\311"); my $lc = lc $u; is (length $lc, 1); - is ($lc, "\351", "E accute -> e accute"); + is ($lc, "\351", "E acute -> e acute"); $lc = lc $u; is (length $lc, 1); - is ($lc, "\351", "E accute -> e accute"); + is ($lc, "\351", "E acute -> e acute"); $lc = lc $u; is (length $lc, 1); - is ($lc, "\351", "E accute -> e accute"); + is ($lc, "\351", "E acute -> e acute"); $u = UTF8Toggle->new("\351"); my $uc = uc $u; is (length $uc, 1); - is ($uc, "\311", "e accute -> E accute"); + is ($uc, "\311", "e acute -> E acute"); $uc = uc $u; is (length $uc, 1); - is ($uc, "\311", "e accute -> E accute"); + is ($uc, "\311", "e acute -> E acute"); $uc = uc $u; is (length $uc, 1); - is ($uc, "\311", "e accute -> E accute"); + is ($uc, "\311", "e acute -> E acute"); $u = UTF8Toggle->new("\311"); $lc = lcfirst $u; is (length $lc, 1); - is ($lc, "\351", "E accute -> e accute"); + is ($lc, "\351", "E acute -> e acute"); $lc = lcfirst $u; is (length $lc, 1); - is ($lc, "\351", "E accute -> e accute"); + is ($lc, "\351", "E acute -> e acute"); $lc = lcfirst $u; is (length $lc, 1); - is ($lc, "\351", "E accute -> e accute"); + is ($lc, "\351", "E acute -> e acute"); $u = UTF8Toggle->new("\351"); $uc = ucfirst $u; is (length $uc, 1); - is ($uc, "\311", "e accute -> E accute"); + is ($uc, "\311", "e acute -> E acute"); $uc = ucfirst $u; is (length $uc, 1); - is ($uc, "\311", "e accute -> E accute"); + is ($uc, "\311", "e acute -> E acute"); $uc = ucfirst $u; is (length $uc, 1); - is ($uc, "\311", "e accute -> E accute"); + is ($uc, "\311", "e acute -> E acute"); } } @@ -160,6 +162,7 @@ foreach my $operator ('print', 'syswrite', 'syswrite len', 'syswrite off', my $u = UTF8Toggle->new("$pad\311\n$trail"); my $l = UTF8Toggle->new("$pad\351\n$trail", 1); if ($operator eq 'print') { + no warnings 'utf8'; print $fh $u; print $fh $u; print $fh $u; @@ -212,6 +215,54 @@ foreach my $operator ('print', 'syswrite', 'syswrite len', 'syswrite off', } } +my $little = "\243\243"; +my $big = " \243 $little ! $little ! $little \243 "; +my $right = rindex $big, $little; +my $right1 = rindex $big, $little, 11; +my $left = index $big, $little; +my $left1 = index $big, $little, 4; + +cmp_ok ($right, ">", $right1, "Sanity check our rindex tests"); +cmp_ok ($left, "<", $left1, "Sanity check our index tests"); + +foreach my $b ($big, UTF8Toggle->new($big)) { + foreach my $l ($little, UTF8Toggle->new($little), + UTF8Toggle->new($little, 1)) { + is (rindex ($b, $l), $right, "rindex"); + is (rindex ($b, $l), $right, "rindex"); + is (rindex ($b, $l), $right, "rindex"); + + is (rindex ($b, $l, 11), $right1, "rindex 11"); + is (rindex ($b, $l, 11), $right1, "rindex 11"); + is (rindex ($b, $l, 11), $right1, "rindex 11"); + + is (index ($b, $l), $left, "index"); + is (index ($b, $l), $left, "index"); + is (index ($b, $l), $left, "index"); + + is (index ($b, $l, 4), $left1, "index 4"); + is (index ($b, $l, 4), $left1, "index 4"); + is (index ($b, $l, 4), $left1, "index 4"); + } +} + +my $bits = "\311"; +foreach my $pieces ($bits, UTF8Toggle->new($bits)) { + like ($bits ^ $pieces, qr/\A\0+\z/, "something xor itself is zeros"); + like ($bits ^ $pieces, qr/\A\0+\z/, "something xor itself is zeros"); + like ($bits ^ $pieces, qr/\A\0+\z/, "something xor itself is zeros"); + + like ($pieces ^ $bits, qr/\A\0+\z/, "something xor itself is zeros"); + like ($pieces ^ $bits, qr/\A\0+\z/, "something xor itself is zeros"); + like ($pieces ^ $bits, qr/\A\0+\z/, "something xor itself is zeros"); +} + +foreach my $value ("\243", UTF8Toggle->new("\243")) { + is (pack ("A/A", $value), pack ("A/A", "\243"), + "pack copes with overloading"); + is (pack ("A/A", $value), pack ("A/A", "\243")); + is (pack ("A/A", $value), pack ("A/A", "\243")); +} END { 1 while -f $tmpfile and unlink $tmpfile || die "unlink '$tmpfile': $!";