1#!./perl 2 3# 4# test the bit operators '&', '|', '^', '~', '<<', and '>>' 5# 6 7BEGIN { 8 chdir 't' if -d 't'; 9 @INC = '../lib'; 10 require "./test.pl"; 11 require Config; 12} 13 14# Tests don't have names yet. 15# If you find tests are failing, please try adding names to tests to track 16# down where the failure is, and supply your new names as a patch. 17# (Just-in-time test naming) 18plan tests => 174 + (10*13*2) + 5; 19 20# numerics 21ok ((0xdead & 0xbeef) == 0x9ead); 22ok ((0xdead | 0xbeef) == 0xfeef); 23ok ((0xdead ^ 0xbeef) == 0x6042); 24ok ((~0xdead & 0xbeef) == 0x2042); 25 26# shifts 27ok ((257 << 7) == 32896); 28ok ((33023 >> 7) == 257); 29 30# signed vs. unsigned 31ok ((~0 > 0 && do { use integer; ~0 } == -1)); 32 33my $bits = 0; 34for (my $i = ~0; $i; $i >>= 1) { ++$bits; } 35my $cusp = 1 << ($bits - 1); 36 37 38ok (($cusp & -1) > 0 && do { use integer; $cusp & -1 } < 0); 39ok (($cusp | 1) > 0 && do { use integer; $cusp | 1 } < 0); 40ok (($cusp ^ 1) > 0 && do { use integer; $cusp ^ 1 } < 0); 41ok ((1 << ($bits - 1)) == $cusp && 42 do { use integer; 1 << ($bits - 1) } == -$cusp); 43ok (($cusp >> 1) == ($cusp / 2) && 44 do { use integer; abs($cusp >> 1) } == ($cusp / 2)); 45 46$Aaz = chr(ord("A") & ord("z")); 47$Aoz = chr(ord("A") | ord("z")); 48$Axz = chr(ord("A") ^ ord("z")); 49 50# short strings 51is (("AAAAA" & "zzzzz"), ($Aaz x 5)); 52is (("AAAAA" | "zzzzz"), ($Aoz x 5)); 53is (("AAAAA" ^ "zzzzz"), ($Axz x 5)); 54 55# long strings 56$foo = "A" x 150; 57$bar = "z" x 75; 58$zap = "A" x 75; 59# & truncates 60is (($foo & $bar), ($Aaz x 75 )); 61# | does not truncate 62is (($foo | $bar), ($Aoz x 75 . $zap)); 63# ^ does not truncate 64is (($foo ^ $bar), ($Axz x 75 . $zap)); 65 66# string constants 67sub _and($) { $_[0] & "+0" } 68sub _oar($) { $_[0] | "+0" } 69sub _xor($) { $_[0] ^ "+0" } 70is _and "waf", '# ', 'str var & const str'; # These three 71is _and 0, '0', 'num var & const str'; # are from 72is _and "waf", '# ', 'str var & const str again'; # [perl #20661] 73is _oar "yit", '{yt', 'str var | const str'; 74is _oar 0, '0', 'num var | const str'; 75is _oar "yit", '{yt', 'str var | const str again'; 76is _xor "yit", 'RYt', 'str var ^ const str'; 77is _xor 0, '0', 'num var ^ const str'; 78is _xor "yit", 'RYt', 'str var ^ const str again'; 79 80# But don’t mistake a COW for a constant when assigning to it 81%h=(150=>1); 82$i=(keys %h)[0]; 83$i |= 105; 84is $i, 255, '[perl #108480] $cow |= number'; 85$i=(keys %h)[0]; 86$i &= 105; 87is $i, 0, '[perl #108480] $cow &= number'; 88$i=(keys %h)[0]; 89$i ^= 105; 90is $i, 255, '[perl #108480] $cow ^= number'; 91 92# 93is ("ok \xFF\xFF\n" & "ok 19\n", "ok 19\n"); 94is ("ok 20\n" | "ok \0\0\n", "ok 20\n"); 95is ("o\000 \0001\000" ^ "\000k\0002\000\n", "ok 21\n"); 96 97# 98is ("ok \x{FF}\x{FF}\n" & "ok 22\n", "ok 22\n"); 99is ("ok 23\n" | "ok \x{0}\x{0}\n", "ok 23\n"); 100is ("o\x{0} \x{0}4\x{0}" ^ "\x{0}k\x{0}2\x{0}\n", "ok 24\n"); 101 102# 103is (sprintf("%vd", v4095 & v801), 801); 104is (sprintf("%vd", v4095 | v801), 4095); 105is (sprintf("%vd", v4095 ^ v801), 3294); 106 107# 108is (sprintf("%vd", v4095.801.4095 & v801.4095), '801.801'); 109is (sprintf("%vd", v4095.801.4095 | v801.4095), '4095.4095.4095'); 110is (sprintf("%vd", v801.4095 ^ v4095.801.4095), '3294.3294.4095'); 111# 112is (sprintf("%vd", v120.300 & v200.400), '72.256'); 113is (sprintf("%vd", v120.300 | v200.400), '248.444'); 114is (sprintf("%vd", v120.300 ^ v200.400), '176.188'); 115# 116my $a = v120.300; 117my $b = v200.400; 118$a ^= $b; 119is (sprintf("%vd", $a), '176.188'); 120my $a = v120.300; 121my $b = v200.400; 122$a |= $b; 123is (sprintf("%vd", $a), '248.444'); 124 125# 126# UTF8 ~ behaviour 127# 128 129my $Is_EBCDIC = (ord('A') == 193) ? 1 : 0; 130 131my @not36; 132 133for (0x100...0xFFF) { 134 $a = ~(chr $_); 135 if ($Is_EBCDIC) { 136 push @not36, sprintf("%#03X", $_) 137 if $a ne chr(~$_) or length($a) != 1; 138 } 139 else { 140 push @not36, sprintf("%#03X", $_) 141 if $a ne chr(~$_) or length($a) != 1 or ~$a ne chr($_); 142 } 143} 144is (join (', ', @not36), ''); 145 146my @not37; 147 148for my $i (0xEEE...0xF00) { 149 for my $j (0x0..0x120) { 150 $a = ~(chr ($i) . chr $j); 151 if ($Is_EBCDIC) { 152 push @not37, sprintf("%#03X %#03X", $i, $j) 153 if $a ne chr(~$i).chr(~$j) or 154 length($a) != 2; 155 } 156 else { 157 push @not37, sprintf("%#03X %#03X", $i, $j) 158 if $a ne chr(~$i).chr(~$j) or 159 length($a) != 2 or 160 ~$a ne chr($i).chr($j); 161 } 162 } 163} 164is (join (', ', @not37), ''); 165 166SKIP: { 167 skip "EBCDIC" if $Is_EBCDIC; 168 is (~chr(~0), "\0"); 169} 170 171 172my @not39; 173 174for my $i (0x100..0x120) { 175 for my $j (0x100...0x120) { 176 push @not39, sprintf("%#03X %#03X", $i, $j) 177 if ~(chr($i)|chr($j)) ne (~chr($i)&~chr($j)); 178 } 179} 180is (join (', ', @not39), ''); 181 182my @not40; 183 184for my $i (0x100..0x120) { 185 for my $j (0x100...0x120) { 186 push @not40, sprintf("%#03X %#03X", $i, $j) 187 if ~(chr($i)&chr($j)) ne (~chr($i)|~chr($j)); 188 } 189} 190is (join (', ', @not40), ''); 191 192 193# More variations on 19 and 22. 194is ("ok \xFF\x{FF}\n" & "ok 41\n", "ok 41\n"); 195is ("ok \x{FF}\xFF\n" & "ok 42\n", "ok 42\n"); 196 197# Tests to see if you really can do casts negative floats to unsigned properly 198$neg1 = -1.0; 199ok (~ $neg1 == 0); 200$neg7 = -7.0; 201ok (~ $neg7 == 6); 202 203 204# double magic tests 205 206sub TIESCALAR { bless { value => $_[1], orig => $_[1] } } 207sub STORE { $_[0]{store}++; $_[0]{value} = $_[1] } 208sub FETCH { $_[0]{fetch}++; $_[0]{value} } 209sub stores { tied($_[0])->{value} = tied($_[0])->{orig}; 210 delete(tied($_[0])->{store}) || 0 } 211sub fetches { delete(tied($_[0])->{fetch}) || 0 } 212 213# numeric double magic tests 214 215tie $x, "main", 1; 216tie $y, "main", 3; 217 218is(($x | $y), 3); 219is(fetches($x), 1); 220is(fetches($y), 1); 221is(stores($x), 0); 222is(stores($y), 0); 223 224is(($x & $y), 1); 225is(fetches($x), 1); 226is(fetches($y), 1); 227is(stores($x), 0); 228is(stores($y), 0); 229 230is(($x ^ $y), 2); 231is(fetches($x), 1); 232is(fetches($y), 1); 233is(stores($x), 0); 234is(stores($y), 0); 235 236is(($x |= $y), 3); 237is(fetches($x), 2); 238is(fetches($y), 1); 239is(stores($x), 1); 240is(stores($y), 0); 241 242is(($x &= $y), 1); 243is(fetches($x), 2); 244is(fetches($y), 1); 245is(stores($x), 1); 246is(stores($y), 0); 247 248is(($x ^= $y), 2); 249is(fetches($x), 2); 250is(fetches($y), 1); 251is(stores($x), 1); 252is(stores($y), 0); 253 254is(~~$y, 3); 255is(fetches($y), 1); 256is(stores($y), 0); 257 258{ use integer; 259 260is(($x | $y), 3); 261is(fetches($x), 1); 262is(fetches($y), 1); 263is(stores($x), 0); 264is(stores($y), 0); 265 266is(($x & $y), 1); 267is(fetches($x), 1); 268is(fetches($y), 1); 269is(stores($x), 0); 270is(stores($y), 0); 271 272is(($x ^ $y), 2); 273is(fetches($x), 1); 274is(fetches($y), 1); 275is(stores($x), 0); 276is(stores($y), 0); 277 278is(($x |= $y), 3); 279is(fetches($x), 2); 280is(fetches($y), 1); 281is(stores($x), 1); 282is(stores($y), 0); 283 284is(($x &= $y), 1); 285is(fetches($x), 2); 286is(fetches($y), 1); 287is(stores($x), 1); 288is(stores($y), 0); 289 290is(($x ^= $y), 2); 291is(fetches($x), 2); 292is(fetches($y), 1); 293is(stores($x), 1); 294is(stores($y), 0); 295 296is(~$y, -4); 297is(fetches($y), 1); 298is(stores($y), 0); 299 300} # end of use integer; 301 302# stringwise double magic tests 303 304tie $x, "main", "a"; 305tie $y, "main", "c"; 306 307is(($x | $y), ("a" | "c")); 308is(fetches($x), 1); 309is(fetches($y), 1); 310is(stores($x), 0); 311is(stores($y), 0); 312 313is(($x & $y), ("a" & "c")); 314is(fetches($x), 1); 315is(fetches($y), 1); 316is(stores($x), 0); 317is(stores($y), 0); 318 319is(($x ^ $y), ("a" ^ "c")); 320is(fetches($x), 1); 321is(fetches($y), 1); 322is(stores($x), 0); 323is(stores($y), 0); 324 325is(($x |= $y), ("a" | "c")); 326is(fetches($x), 2); 327is(fetches($y), 1); 328is(stores($x), 1); 329is(stores($y), 0); 330 331is(($x &= $y), ("a" & "c")); 332is(fetches($x), 2); 333is(fetches($y), 1); 334is(stores($x), 1); 335is(stores($y), 0); 336 337is(($x ^= $y), ("a" ^ "c")); 338is(fetches($x), 2); 339is(fetches($y), 1); 340is(stores($x), 1); 341is(stores($y), 0); 342 343is(~~$y, "c"); 344is(fetches($y), 1); 345is(stores($y), 0); 346 347$a = "\0\x{100}"; chop($a); 348ok(utf8::is_utf8($a)); # make sure UTF8 flag is still there 349$a = ~$a; 350is($a, "\xFF", "~ works with utf-8"); 351 352# [rt.perl.org 33003] 353# This would cause a segfault without malloc wrap 354SKIP: { 355 skip "No malloc wrap checks" unless $Config::Config{usemallocwrap}; 356 like( runperl(prog => 'eval q($#a>>=1); print 1'), "^1\n?" ); 357} 358 359# [perl #37616] Bug in &= (string) and/or m// 360{ 361 $a = "aa"; 362 $a &= "a"; 363 ok($a =~ /a+$/, 'ASCII "a" is NUL-terminated'); 364 365 $b = "bb\x{100}"; 366 $b &= "b"; 367 ok($b =~ /b+$/, 'Unicode "b" is NUL-terminated'); 368} 369 370{ 371 $a = chr(0x101) x 0x101; 372 $b = chr(0x0FF) x 0x0FF; 373 374 $c = $a | $b; 375 is($c, chr(0x1FF) x 0xFF . chr(0x101) x 2); 376 377 $c = $b | $a; 378 is($c, chr(0x1FF) x 0xFF . chr(0x101) x 2); 379 380 $c = $a & $b; 381 is($c, chr(0x001) x 0x0FF); 382 383 $c = $b & $a; 384 is($c, chr(0x001) x 0x0FF); 385 386 $c = $a ^ $b; 387 is($c, chr(0x1FE) x 0x0FF . chr(0x101) x 2); 388 389 $c = $b ^ $a; 390 is($c, chr(0x1FE) x 0x0FF . chr(0x101) x 2); 391} 392 393{ 394 $a = chr(0x101) x 0x101; 395 $b = chr(0x0FF) x 0x0FF; 396 397 $a |= $b; 398 is($a, chr(0x1FF) x 0xFF . chr(0x101) x 2); 399} 400 401{ 402 $a = chr(0x101) x 0x101; 403 $b = chr(0x0FF) x 0x0FF; 404 405 $b |= $a; 406 is($b, chr(0x1FF) x 0xFF . chr(0x101) x 2); 407} 408 409{ 410 $a = chr(0x101) x 0x101; 411 $b = chr(0x0FF) x 0x0FF; 412 413 $a &= $b; 414 is($a, chr(0x001) x 0x0FF); 415} 416 417{ 418 $a = chr(0x101) x 0x101; 419 $b = chr(0x0FF) x 0x0FF; 420 421 $b &= $a; 422 is($b, chr(0x001) x 0x0FF); 423} 424 425{ 426 $a = chr(0x101) x 0x101; 427 $b = chr(0x0FF) x 0x0FF; 428 429 $a ^= $b; 430 is($a, chr(0x1FE) x 0x0FF . chr(0x101) x 2); 431} 432 433{ 434 $a = chr(0x101) x 0x101; 435 $b = chr(0x0FF) x 0x0FF; 436 437 $b ^= $a; 438 is($b, chr(0x1FE) x 0x0FF . chr(0x101) x 2); 439} 440 441# update to pp_complement() via Coverity 442SKIP: { 443 # UTF-EBCDIC is limited to 0x7fffffff and can't encode ~0. 444 skip "EBCDIC" if $Is_EBCDIC; 445 446 my $str = "\x{10000}\x{800}"; 447 # U+10000 is four bytes in UTF-8/UTF-EBCDIC. 448 # U+0800 is three bytes in UTF-8/UTF-EBCDIC. 449 450 no warnings "utf8"; 451 { use bytes; $str =~ s/\C\C\z//; } 452 453 # it's really bogus that (~~malformed) is \0. 454 my $ref = "\x{10000}\0"; 455 is(~~$str, $ref); 456 457 # same test, but this time with a longer replacement string that 458 # exercises a different branch in pp_subsr() 459 460 $str = "\x{10000}\x{800}"; 461 { use bytes; $str =~ s/\C\C\z/\0\0\0/; } 462 463 # it's also bogus that (~~malformed) is \0\0\0\0. 464 my $ref = "\x{10000}\0\0\0\0"; 465 is(~~$str, $ref, "use bytes with long replacement"); 466} 467 468# ref tests 469 470my %res; 471 472for my $str ("x", "\x{100}") { 473 for my $chr (qw/S A H G X ( * F/) { 474 for my $op (qw/| & ^/) { 475 my $co = ord $chr; 476 my $so = ord $str; 477 $res{"$chr$op$str"} = eval qq/chr($co $op $so)/; 478 } 479 } 480 $res{"undef|$str"} = $str; 481 $res{"undef&$str"} = ""; 482 $res{"undef^$str"} = $str; 483} 484 485sub PVBM () { "X" } 486index "foo", PVBM; 487 488my $warn = 0; 489local $^W = 1; 490local $SIG{__WARN__} = sub { $warn++ }; 491 492sub is_first { 493 my ($got, $orig, $op, $str, $name) = @_; 494 is(substr($got, 0, 1), $res{"$orig$op$str"}, $name); 495} 496 497for ( 498 # [object to test, first char of stringification, name] 499 [undef, "undef", "undef" ], 500 [\1, "S", "scalar ref" ], 501 [[], "A", "array ref" ], 502 [{}, "H", "hash ref" ], 503 [qr/x/, "(", "qr//" ], 504 [*foo, "*", "glob" ], 505 [\*foo, "G", "glob ref" ], 506 [PVBM, "X", "PVBM" ], 507 [\PVBM, "S", "PVBM ref" ], 508 [bless([], "Foo"), "F", "object" ], 509) { 510 my ($val, $orig, $type) = @$_; 511 512 for (["x", "string"], ["\x{100}", "utf8"]) { 513 my ($str, $desc) = @$_; 514 515 $warn = 0; 516 517 is_first($val | $str, $orig, "|", $str, "$type | $desc"); 518 is_first($val & $str, $orig, "&", $str, "$type & $desc"); 519 is_first($val ^ $str, $orig, "^", $str, "$type ^ $desc"); 520 521 is_first($str | $val, $orig, "|", $str, "$desc | $type"); 522 is_first($str & $val, $orig, "&", $str, "$desc & $type"); 523 is_first($str ^ $val, $orig, "^", $str, "$desc ^ $type"); 524 525 my $new; 526 ($new = $val) |= $str; 527 is_first($new, $orig, "|", $str, "$type |= $desc"); 528 ($new = $val) &= $str; 529 is_first($new, $orig, "&", $str, "$type &= $desc"); 530 ($new = $val) ^= $str; 531 is_first($new, $orig, "^", $str, "$type ^= $desc"); 532 533 ($new = $str) |= $val; 534 is_first($new, $orig, "|", $str, "$desc |= $type"); 535 ($new = $str) &= $val; 536 is_first($new, $orig, "&", $str, "$desc &= $type"); 537 ($new = $str) ^= $val; 538 is_first($new, $orig, "^", $str, "$desc ^= $type"); 539 540 if ($orig eq "undef") { 541 # undef |= and undef ^= don't warn 542 is($warn, 10, "no duplicate warnings"); 543 } 544 else { 545 is($warn, 0, "no warnings"); 546 } 547 } 548} 549 550my $strval; 551 552{ 553 package Bar; 554 use overload q/""/ => sub { $strval }; 555 556 package Baz; 557 use overload q/|/ => sub { "y" }; 558} 559 560ok(!eval { bless([], "Bar") | "x"; 1 }, "string overload can't use |"); 561like($@, qr/no method found/, "correct error"); 562is(eval { bless([], "Baz") | "x" }, "y", "| overload works"); 563 564my $obj = bless [], "Bar"; 565$strval = "x"; 566eval { $obj |= "Q" }; 567$strval = "z"; 568is("$obj", "z", "|= doesn't break string overload"); 569 570# [perl #29070] 571$^A .= new version ~$_ for "\xce", v205, "\xcc"; 572is $^A, "123", '~v0 clears vstring magic on retval'; 573