t/uni/overload.t

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