1#!perl -w 2 3BEGIN { 4 chdir 't' if -d 't'; 5 require Config; import Config; 6 require './test.pl'; 7 require './charset_tools.pl'; 8 require './loc_tools.pl'; 9 set_up_inc( '../lib' ); 10} 11 12plan(tests => 193); 13 14package UTF8Toggle; 15use strict; 16 17use overload '""' => 'stringify', fallback => 1; 18 19sub new { 20 my $class = shift; 21 my $value = shift; 22 my $state = shift||0; 23 return bless [$value, $state], $class; 24} 25 26sub stringify { 27 my $self = shift; 28 $self->[1] = ! $self->[1]; 29 if ($self->[1]) { 30 utf8::downgrade($self->[0]); 31 } else { 32 utf8::upgrade($self->[0]); 33 } 34 $self->[0]; 35} 36 37package main; 38 39# These tests are based on characters 128-255 not having latin1, and hence 40# Unicode, semantics 41# no feature "unicode_strings"; 42 43# Bug 34297 44foreach my $t ("ASCII", "B" . uni_to_native("\366") . "se") { 45 my $length = length $t; 46 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'"); 52} 53 54my $E_acute = uni_to_native("\311"); 55my $e_acute = uni_to_native("\351"); 56my $u = UTF8Toggle->new($E_acute); 57my $lc = lc $u; 58is (length $lc, 1); 59is ($lc, $E_acute, "E acute -> e acute"); 60$lc = lc $u; 61is (length $lc, 1); 62is ($lc, $e_acute, "E acute -> e acute"); 63$lc = lc $u; 64is (length $lc, 1); 65is ($lc, $E_acute, "E acute -> e acute"); 66 67$u = UTF8Toggle->new($e_acute); 68my $uc = uc $u; 69is (length $uc, 1); 70is ($uc, $e_acute, "e acute -> E acute"); 71$uc = uc $u; 72is (length $uc, 1); 73is ($uc, $E_acute, "e acute -> E acute"); 74$uc = uc $u; 75is (length $uc, 1); 76is ($uc, $e_acute, "e acute -> E acute"); 77 78$u = UTF8Toggle->new($E_acute); 79$lc = lcfirst $u; 80is (length $lc, 1); 81is ($lc, $E_acute, "E acute -> e acute"); 82$lc = lcfirst $u; 83is (length $lc, 1); 84is ($lc, $e_acute, "E acute -> e acute"); 85$lc = lcfirst $u; 86is (length $lc, 1); 87is ($lc, $E_acute, "E acute -> e acute"); 88 89$u = UTF8Toggle->new($e_acute); 90$uc = ucfirst $u; 91is (length $uc, 1); 92is ($uc, $e_acute, "e acute -> E acute"); 93$uc = ucfirst $u; 94is (length $uc, 1); 95is ($uc, $E_acute, "e acute -> E acute"); 96$uc = ucfirst $u; 97is (length $uc, 1); 98is ($uc, $e_acute, "e acute -> E acute"); 99 100my $have_setlocale = locales_enabled('LC_ALL'); 101 102SKIP: { 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; 109 } else { 110 use locale; 111 my $u = UTF8Toggle->new($E_acute); 112 my $lc = lc $u; 113 is (length $lc, 1); 114 is ($lc, $e_acute, "E acute -> e acute"); 115 $lc = lc $u; 116 is (length $lc, 1); 117 is ($lc, $e_acute, "E acute -> e acute"); 118 $lc = lc $u; 119 is (length $lc, 1); 120 is ($lc, $e_acute, "E acute -> e acute"); 121 122 $u = UTF8Toggle->new($e_acute); 123 my $uc = uc $u; 124 is (length $uc, 1); 125 is ($uc, $E_acute, "e acute -> E acute"); 126 $uc = uc $u; 127 is (length $uc, 1); 128 is ($uc, $E_acute, "e acute -> E acute"); 129 $uc = uc $u; 130 is (length $uc, 1); 131 is ($uc, $E_acute, "e acute -> E acute"); 132 133 $u = UTF8Toggle->new($E_acute); 134 $lc = lcfirst $u; 135 is (length $lc, 1); 136 is ($lc, $e_acute, "E acute -> e acute"); 137 $lc = lcfirst $u; 138 is (length $lc, 1); 139 is ($lc, $e_acute, "E acute -> e acute"); 140 $lc = lcfirst $u; 141 is (length $lc, 1); 142 is ($lc, $e_acute, "E acute -> e acute"); 143 144 $u = UTF8Toggle->new($e_acute); 145 $uc = ucfirst $u; 146 is (length $uc, 1); 147 is ($uc, $E_acute, "e acute -> E acute"); 148 $uc = ucfirst $u; 149 is (length $uc, 1); 150 is ($uc, $E_acute, "e acute -> E acute"); 151 $uc = ucfirst $u; 152 is (length $uc, 1); 153 is ($uc, $E_acute, "e acute -> E acute"); 154 } 155} 156 157my $tmpfile = tempfile(); 158 159foreach my $operator ('print', 'syswrite', 'syswrite len', 'syswrite off', 160 'syswrite len off') { 161 foreach my $layer ('', $operator =~ /syswrite/ ? () : (':utf8')) { 162 open my $fh, "+>:raw$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') { 169 no warnings 'utf8'; 170 print $fh $u; 171 print $fh $u; 172 print $fh $u; 173 print $fh $l; 174 print $fh $l; 175 print $fh $l; 176 } elsif ($operator eq 'syswrite') { 177 syswrite $fh, $u; 178 syswrite $fh, $u; 179 syswrite $fh, $u; 180 syswrite $fh, $l; 181 syswrite $fh, $l; 182 syswrite $fh, $l; 183 } elsif ($operator eq 'syswrite len') { 184 syswrite $fh, $u, 2; 185 syswrite $fh, $u, 2; 186 syswrite $fh, $u, 2; 187 syswrite $fh, $l, 2; 188 syswrite $fh, $l, 2; 189 syswrite $fh, $l, 2; 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; 198 } else { 199 die $operator; 200 } 201 202 seek $fh, 0, 0 or die $!; 203 my $line; 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"); 216 217 close $fh or die $!; 218 } 219} 220 221my $little = "\243\243"; 222my $big = " \243 $little ! $little ! $little \243 "; 223my $right = rindex $big, $little; 224my $right1 = rindex $big, $little, 11; 225my $left = index $big, $little; 226my $left1 = index $big, $little, 4; 227 228cmp_ok ($right, ">", $right1, "Sanity check our rindex tests"); 229cmp_ok ($left, "<", $left1, "Sanity check our index tests"); 230 231foreach 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"); 237 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"); 241 242 is (index ($b, $l), $left, "index"); 243 is (index ($b, $l), $left, "index"); 244 is (index ($b, $l), $left, "index"); 245 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"); 249 } 250} 251 252my $bits = $E_acute; 253foreach 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"); 257 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"); 261} 262 263foreach 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")); 268} 269 270foreach my $value ("\243", UTF8Toggle->new("\243")) { 271 my $v; 272 $v = substr $value, 0, 1; 273 is ($v, "\243"); 274 $v = substr $value, 0, 1; 275 is ($v, "\243"); 276 $v = substr $value, 0, 1; 277 is ($v, "\243"); 278} 279 280{ 281 package RT69422; 282 use overload '""' => sub { $_[0]->{data} } 283} 284 285{ 286 my $text = bless { data => "\x{3075}" }, 'RT69422'; 287 my $p = substr $text, 0, 1; 288 is ($p, "\x{3075}"); 289} 290 291TODO: { 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 296 todo_skip($::TODO); 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__; 300 print "ok\n"; 301EOP 302} 303 304TODO: { 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"; 310 $o.foo = "bar"; 311EOP 312} 313