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