1#!./perl 2 3# 4# test the bit operators '&', '|', '^', '~', '<<', and '>>' 5# 6 7BEGIN { 8 chdir 't' if -d 't'; 9 require "./test.pl"; 10 set_up_inc('../lib'); 11 require "./charset_tools.pl"; 12 require Config; 13} 14 15use warnings; 16 17# Tests don't have names yet. 18# If you find tests are failing, please try adding names to tests to track 19# down where the failure is, and supply your new names as a patch. 20# (Just-in-time test naming) 21plan tests => 510; 22 23# numerics 24ok ((0xdead & 0xbeef) == 0x9ead); 25ok ((0xdead | 0xbeef) == 0xfeef); 26ok ((0xdead ^ 0xbeef) == 0x6042); 27ok ((~0xdead & 0xbeef) == 0x2042); 28 29# shifts 30ok ((257 << 7) == 32896); 31ok ((33023 >> 7) == 257); 32 33# signed vs. unsigned 34ok ((~0 > 0 && do { use integer; ~0 } == -1)); 35 36{ # GH #18639 37 my $iv_min = -(~0 >> 1) - 1; 38 my $shifted; 39 { use integer; $shifted = $iv_min << 0 }; 40 is($shifted, $iv_min, "IV_MIN << 0 yields IV_MIN under 'use integer'"); 41} 42 43# GH #18691 44# Exercise some corner cases on shifting more bits than the size of IV/UV. 45# All these should work even if the shift amount doesn't fit in IV or UV. 46is(4 << 2147483648, 0, "4 << 2147483648 yields 0"); 47is(16 << 4294967295, 0, "16 << 4294967295 yields 0"); 48is(8 >> 4294967296, 0, "8 >> 4294967296 yields 0"); 49is(11 << 18446744073709551615, 0, "11 << 18446744073709551615 yields 0"); 50is(do { use integer; -9 >> 18446744073709551616 }, -1, 51 "-9 >> 18446744073709551616 under 'use integer' yields -1"); 52is(do { use integer; -4 << -2147483648 }, -1, 53 "-4 << -2147483648 under 'use integer' yields -1"); 54# Quotes around -9223372036854775808 below are to make it a single term. 55# Without quotes, it will be parsed as an expression with an unary minus 56# operator which will clip the result to IV range under "use integer". 57is(do { use integer; -5 >> '-9223372036854775808' }, 0, 58 "-5 >> -9223372036854775808 under 'use integer' yields 0"); 59 60my $bits = 0; 61for (my $i = ~0; $i; $i >>= 1) { ++$bits; } 62my $cusp = 1 << ($bits - 1); 63 64 65ok (($cusp & -1) > 0 && do { use integer; $cusp & -1 } < 0); 66ok (($cusp | 1) > 0 && do { use integer; $cusp | 1 } < 0); 67ok (($cusp ^ 1) > 0 && do { use integer; $cusp ^ 1 } < 0); 68ok ((1 << ($bits - 1)) == $cusp && 69 do { use integer; 1 << ($bits - 1) } == -$cusp); 70ok (($cusp >> 1) == ($cusp / 2) && 71 do { use integer; abs($cusp >> 1) } == ($cusp / 2)); 72 73$Aaz = chr(ord("A") & ord("z")); 74$Aoz = chr(ord("A") | ord("z")); 75$Axz = chr(ord("A") ^ ord("z")); 76 77# short strings 78is (("AAAAA" & "zzzzz"), ($Aaz x 5)); 79is (("AAAAA" | "zzzzz"), ($Aoz x 5)); 80is (("AAAAA" ^ "zzzzz"), ($Axz x 5)); 81 82# long strings 83$foo = "A" x 150; 84$bar = "z" x 75; 85$zap = "A" x 75; 86# & truncates 87is (($foo & $bar), ($Aaz x 75 )); 88# | does not truncate 89is (($foo | $bar), ($Aoz x 75 . $zap)); 90# ^ does not truncate 91is (($foo ^ $bar), ($Axz x 75 . $zap)); 92 93# string constants. These tests expect the bit patterns of these strings in 94# ASCII, so convert to that. 95sub _and($) { $_[0] & native_to_uni("+0") } 96sub _oar($) { $_[0] | native_to_uni("+0") } 97sub _xor($) { $_[0] ^ native_to_uni("+0") } 98is _and native_to_uni("waf"), native_to_uni('# '), 'str var & const str'; # [perl #20661] 99is _and native_to_uni("waf"), native_to_uni('# '), 'str var & const str again'; # [perl #20661] 100is _oar native_to_uni("yit"), native_to_uni('{yt'), 'str var | const str'; 101is _oar native_to_uni("yit"), native_to_uni('{yt'), 'str var | const str again'; 102is _xor native_to_uni("yit"), native_to_uni('RYt'), 'str var ^ const str'; 103is _xor native_to_uni("yit"), native_to_uni('RYt'), 'str var ^ const str again'; 104 105SKIP: { 106 skip "Converting a numeric doesn't work with EBCDIC unlike the above tests", 107 3 if $::IS_EBCDIC; 108 is _and 0, '0', 'num var & const str'; # [perl #20661] 109 is _oar 0, '0', 'num var | const str'; 110 is _xor 0, '0', 'num var ^ const str'; 111} 112 113# But don’t mistake a COW for a constant when assigning to it 114%h=(150=>1); 115$i=(keys %h)[0]; 116$i |= 105; 117is $i, 255, '[perl #108480] $cow |= number'; 118$i=(keys %h)[0]; 119$i &= 105; 120is $i, 0, '[perl #108480] $cow &= number'; 121$i=(keys %h)[0]; 122$i ^= 105; 123is $i, 255, '[perl #108480] $cow ^= number'; 124 125# 126is ("ok \xFF\xFF\n" & "ok 19\n", "ok 19\n"); 127is ("ok 20\n" | "ok \0\0\n", "ok 20\n"); 128is ("o\000 \0001\000" ^ "\000k\0002\000\n", "ok 21\n"); 129 130# 131is ("ok \x{FF}\x{FF}\n" & "ok 22\n", "ok 22\n"); 132is ("ok 23\n" | "ok \x{0}\x{0}\n", "ok 23\n"); 133is ("o\x{0} \x{0}4\x{0}" ^ "\x{0}k\x{0}2\x{0}\n", "ok 24\n"); 134 135# More variations on 19 and 22. 136is ("ok \xFF\x{FF}\n" & "ok 41\n", "ok 41\n"); 137is ("ok \x{FF}\xFF\n" & "ok 42\n", "ok 42\n"); 138 139# Tests to see if you really can do casts negative floats to unsigned properly 140$neg1 = -1.0; 141ok (~ $neg1 == 0); 142$neg7 = -7.0; 143ok (~ $neg7 == 6); 144 145 146# double magic tests 147 148sub TIESCALAR { bless { value => $_[1], orig => $_[1] } } 149sub STORE { $_[0]{store}++; $_[0]{value} = $_[1] } 150sub FETCH { $_[0]{fetch}++; $_[0]{value} } 151sub stores { tied($_[0])->{value} = tied($_[0])->{orig}; 152 delete(tied($_[0])->{store}) || 0 } 153sub fetches { delete(tied($_[0])->{fetch}) || 0 } 154 155# numeric double magic tests 156 157tie $x, "main", 1; 158tie $y, "main", 3; 159 160is(($x | $y), 3); 161is(fetches($x), 1); 162is(fetches($y), 1); 163is(stores($x), 0); 164is(stores($y), 0); 165 166is(($x & $y), 1); 167is(fetches($x), 1); 168is(fetches($y), 1); 169is(stores($x), 0); 170is(stores($y), 0); 171 172is(($x ^ $y), 2); 173is(fetches($x), 1); 174is(fetches($y), 1); 175is(stores($x), 0); 176is(stores($y), 0); 177 178is(($x |= $y), 3); 179is(fetches($x), 2); 180is(fetches($y), 1); 181is(stores($x), 1); 182is(stores($y), 0); 183 184is(($x &= $y), 1); 185is(fetches($x), 2); 186is(fetches($y), 1); 187is(stores($x), 1); 188is(stores($y), 0); 189 190is(($x ^= $y), 2); 191is(fetches($x), 2); 192is(fetches($y), 1); 193is(stores($x), 1); 194is(stores($y), 0); 195 196is(~~$y, 3); 197is(fetches($y), 1); 198is(stores($y), 0); 199 200{ use integer; 201 202is(($x | $y), 3); 203is(fetches($x), 1); 204is(fetches($y), 1); 205is(stores($x), 0); 206is(stores($y), 0); 207 208is(($x & $y), 1); 209is(fetches($x), 1); 210is(fetches($y), 1); 211is(stores($x), 0); 212is(stores($y), 0); 213 214is(($x ^ $y), 2); 215is(fetches($x), 1); 216is(fetches($y), 1); 217is(stores($x), 0); 218is(stores($y), 0); 219 220is(($x |= $y), 3); 221is(fetches($x), 2); 222is(fetches($y), 1); 223is(stores($x), 1); 224is(stores($y), 0); 225 226is(($x &= $y), 1); 227is(fetches($x), 2); 228is(fetches($y), 1); 229is(stores($x), 1); 230is(stores($y), 0); 231 232is(($x ^= $y), 2); 233is(fetches($x), 2); 234is(fetches($y), 1); 235is(stores($x), 1); 236is(stores($y), 0); 237 238is(~$y, -4); 239is(fetches($y), 1); 240is(stores($y), 0); 241 242} # end of use integer; 243 244# stringwise double magic tests 245 246tie $x, "main", "a"; 247tie $y, "main", "c"; 248 249is(($x | $y), ("a" | "c")); 250is(fetches($x), 1); 251is(fetches($y), 1); 252is(stores($x), 0); 253is(stores($y), 0); 254 255is(($x & $y), ("a" & "c")); 256is(fetches($x), 1); 257is(fetches($y), 1); 258is(stores($x), 0); 259is(stores($y), 0); 260 261is(($x ^ $y), ("a" ^ "c")); 262is(fetches($x), 1); 263is(fetches($y), 1); 264is(stores($x), 0); 265is(stores($y), 0); 266 267is(($x |= $y), ("a" | "c")); 268is(fetches($x), 2); 269is(fetches($y), 1); 270is(stores($x), 1); 271is(stores($y), 0); 272 273is(($x &= $y), ("a" & "c")); 274is(fetches($x), 2); 275is(fetches($y), 1); 276is(stores($x), 1); 277is(stores($y), 0); 278 279is(($x ^= $y), ("a" ^ "c")); 280is(fetches($x), 2); 281is(fetches($y), 1); 282is(stores($x), 1); 283is(stores($y), 0); 284 285is(~~$y, "c"); 286is(fetches($y), 1); 287is(stores($y), 0); 288 289my $g; 290# Note: if the vec() reads are part of the is() calls it's treated as 291# in lvalue context, so we save it separately 292$g = vec($x, 0, 1); 293is($g, (ord("a") & 0x01), "check vec value"); 294is(fetches($x), 1, "fetches for vec read"); 295is(stores($x), 0, "stores for vec read"); 296# similarly here, and code like: 297# $g = (vec($x, 0, 1) = 0) 298# results in an extra fetch, since the inner assignment returns the LV 299vec($x, 0, 1) = 0; 300# one fetch in vec() another when the LV is assigned to 301is(fetches($x), 2, "fetches for vec write"); 302is(stores($x), 1, "stores for vec write"); 303 304{ 305 my $a = "a"; 306 utf8::upgrade($a); 307 tie $x, "main", $a; 308 $g = vec($x, 0, 1); 309 is($g, (ord("a") & 0x01), "check vec value (utf8)"); 310 is(fetches($x), 1, "fetches for vec read (utf8)"); 311 is(stores($x), 0, "stores for vec read (utf8)"); 312 vec($x, 0, 1) = 0; 313 # one fetch in vec() another when the LV is assigned to 314 is(fetches($x), 2, "fetches for vec write (utf8)"); 315 is(stores($x), 1, "stores for vec write (utf8)"); 316} 317 318$a = "\0\x{100}"; chop($a); 319ok(utf8::is_utf8($a)); # make sure UTF8 flag is still there 320$a = ~$a; 321is($a, "\xFF", "~ works with utf-8"); 322ok(! utf8::is_utf8($a), " and turns off the UTF-8 flag"); 323 324$a = "\0\x{100}"; chop($a); 325undef $b; 326$b = $a | "\xFF"; 327ok(utf8::is_utf8($b), "Verify UTF-8 | non-UTF-8 retains UTF-8 flag"); 328undef $b; 329$b = "\xFF" | $a; 330ok(utf8::is_utf8($b), "Verify non-UTF-8 | UTF-8 retains UTF-8 flag"); 331undef $b; 332$b = $a & "\xFF"; 333ok(utf8::is_utf8($b), "Verify UTF-8 & non-UTF-8 retains UTF-8 flag"); 334undef $b; 335$b = "\xFF" & $a; 336ok(utf8::is_utf8($b), "Verify non-UTF-8 & UTF-8 retains UTF-8 flag"); 337undef $b; 338$b = $a ^ "\xFF"; 339ok(utf8::is_utf8($b), "Verify UTF-8 ^ non-UTF-8 retains UTF-8 flag"); 340undef $b; 341$b = "\xFF" ^ $a; 342ok(utf8::is_utf8($b), "Verify non-UTF-8 ^ UTF-8 retains UTF-8 flag"); 343 344 345# [rt.perl.org 33003] 346# This would cause a segfault without malloc wrap 347SKIP: { 348 skip "No malloc wrap checks" unless $Config::Config{usemallocwrap}; 349 like( runperl(prog => 'eval q($#a>>=1); print 1'), qr/^1\n?/ ); 350} 351 352# [perl #37616] Bug in &= (string) and/or m// 353{ 354 $a = "aa"; 355 $a &= "a"; 356 ok($a =~ /a+$/, 'ASCII "a" is NUL-terminated'); 357 358 $b = "bb\x{FF}"; 359 utf8::upgrade($b); 360 $b &= "b"; 361 ok($b =~ /b+$/, 'Unicode "b" is NUL-terminated'); 362} 363 364# New string- and number-specific bitwise ops 365{ 366 use feature "bitwise"; 367 no warnings "experimental::bitwise"; 368 is "22" & "66", 2, 'numeric & with strings'; 369 is "22" | "66", 86, 'numeric | with strings'; 370 is "22" ^ "66", 84, 'numeric ^ with strings'; 371 is ~"22" & 0xff, 233, 'numeric ~ with string'; 372 is 22 &. 66, 22, '&. with numbers'; 373 is 22 |. 66, 66, '|. with numbers'; 374 is 22 ^. 66, "\4\4", '^. with numbers'; 375 if ($::IS_EBCDIC) { 376 # ord('2') is 0xF2 on EBCDIC 377 is ~.22, "\x0d\x0d", '~. with number'; 378 } 379 else { 380 # ord('2') is 0x32 on ASCII 381 is ~.22, "\xcd\xcd", '~. with number'; 382 } 383 $_ = "22"; 384 is $_ &= "66", 2, 'numeric &= with strings'; 385 $_ = "22"; 386 is $_ |= "66", 86, 'numeric |= with strings'; 387 $_ = "22"; 388 is $_ ^= "66", 84, 'numeric ^= with strings'; 389 $_ = 22; 390 is $_ &.= 66, 22, '&.= with numbers'; 391 $_ = 22; 392 is $_ |.= 66, 66, '|.= with numbers'; 393 $_ = 22; 394 is $_ ^.= 66, "\4\4", '^.= with numbers'; 395 396 # signed vs. unsigned 397 ok ((~0 > 0 && do { use integer; ~0 } == -1)); 398 399 my $bits = 0; 400 for (my $i = ~0; $i; $i >>= 1) { ++$bits; } 401 my $cusp = 1 << ($bits - 1); 402 403 ok (($cusp & -1) > 0 && do { use integer; $cusp & -1 } < 0); 404 ok (($cusp | 1) > 0 && do { use integer; $cusp | 1 } < 0); 405 ok (($cusp ^ 1) > 0 && do { use integer; $cusp ^ 1 } < 0); 406 ok ((1 << ($bits - 1)) == $cusp && 407 do { use integer; 1 << ($bits - 1) } == -$cusp); 408 ok (($cusp >> 1) == ($cusp / 2) && 409 do { use integer; abs($cusp >> 1) } == ($cusp / 2)); 410} 411# Repeat some of those, with 'use v5.27' 412{ 413 use v5.27; 414 415 is "22" & "66", 2, 'numeric & with strings'; 416 is "22" | "66", 86, 'numeric | with strings'; 417 is "22" ^ "66", 84, 'numeric ^ with strings'; 418 is ~"22" & 0xff, 233, 'numeric ~ with string'; 419 is 22 &. 66, 22, '&. with numbers'; 420 is 22 |. 66, 66, '|. with numbers'; 421 is 22 ^. 66, "\4\4", '^. with numbers'; 422 if ($::IS_EBCDIC) { 423 # ord('2') is 0xF2 on EBCDIC 424 is ~.22, "\x0d\x0d", '~. with number'; 425 } 426 else { 427 # ord('2') is 0x32 on ASCII 428 is ~.22, "\xcd\xcd", '~. with number'; 429 } 430 $_ = "22"; 431 is $_ &= "66", 2, 'numeric &= with strings'; 432 $_ = "22"; 433 is $_ |= "66", 86, 'numeric |= with strings'; 434 $_ = "22"; 435 is $_ ^= "66", 84, 'numeric ^= with strings'; 436 $_ = 22; 437 is $_ &.= 66, 22, '&.= with numbers'; 438 $_ = 22; 439 is $_ |.= 66, 66, '|.= with numbers'; 440 $_ = 22; 441 is $_ ^.= 66, "\4\4", '^.= with numbers'; 442} 443 444# ref tests 445 446my %res; 447 448for my $str ("x", "\x{B6}") { 449 utf8::upgrade($str) if $str !~ /x/; 450 for my $chr (qw/S A H G X ( * F/) { 451 for my $op (qw/| & ^/) { 452 my $co = ord $chr; 453 my $so = ord $str; 454 $res{"$chr$op$str"} = eval qq/chr($co $op $so)/; 455 } 456 } 457 $res{"undef|$str"} = $str; 458 $res{"undef&$str"} = ""; 459 $res{"undef^$str"} = $str; 460} 461 462sub PVBM () { "X" } 4631 if index "foo", PVBM; 464 465my $warn = 0; 466local $^W = 1; 467local $SIG{__WARN__} = sub { $warn++ }; 468 469sub is_first { 470 my ($got, $orig, $op, $str, $name) = @_; 471 is(substr($got, 0, 1), $res{"$orig$op$str"}, $name); 472} 473 474for ( 475 # [object to test, first char of stringification, name] 476 [undef, "undef", "undef" ], 477 [\1, "S", "scalar ref" ], 478 [[], "A", "array ref" ], 479 [{}, "H", "hash ref" ], 480 [qr/x/, "(", "qr//" ], 481 [*foo, "*", "glob" ], 482 [\*foo, "G", "glob ref" ], 483 [PVBM, "X", "PVBM" ], 484 [\PVBM, "S", "PVBM ref" ], 485 [bless([], "Foo"), "F", "object" ], 486) { 487 my ($val, $orig, $type) = @$_; 488 489 for (["x", "string"], ["\x{B6}", "utf8"]) { 490 my ($str, $desc) = @$_; 491 utf8::upgrade($str) if $desc =~ /utf8/; 492 493 $warn = 0; 494 495 is_first($val | $str, $orig, "|", $str, "$type | $desc"); 496 is_first($val & $str, $orig, "&", $str, "$type & $desc"); 497 is_first($val ^ $str, $orig, "^", $str, "$type ^ $desc"); 498 499 is_first($str | $val, $orig, "|", $str, "$desc | $type"); 500 is_first($str & $val, $orig, "&", $str, "$desc & $type"); 501 is_first($str ^ $val, $orig, "^", $str, "$desc ^ $type"); 502 503 my $new; 504 ($new = $val) |= $str; 505 is_first($new, $orig, "|", $str, "$type |= $desc"); 506 ($new = $val) &= $str; 507 is_first($new, $orig, "&", $str, "$type &= $desc"); 508 ($new = $val) ^= $str; 509 is_first($new, $orig, "^", $str, "$type ^= $desc"); 510 511 ($new = $str) |= $val; 512 is_first($new, $orig, "|", $str, "$desc |= $type"); 513 ($new = $str) &= $val; 514 is_first($new, $orig, "&", $str, "$desc &= $type"); 515 ($new = $str) ^= $val; 516 is_first($new, $orig, "^", $str, "$desc ^= $type"); 517 518 if ($orig eq "undef") { 519 # undef |= and undef ^= don't warn 520 is($warn, 10, "no duplicate warnings"); 521 } 522 else { 523 is($warn, 0, "no warnings"); 524 } 525 } 526} 527 528delete $SIG{__WARN__}; 529 530my $strval; 531 532{ 533 package Bar; 534 use overload q/""/ => sub { $strval }; 535 536 package Baz; 537 use overload q/|/ => sub { "y" }; 538} 539 540ok(!eval { 1 if bless([], "Bar") | "x"; 1 },"string overload can't use |"); 541like($@, qr/no method found/, "correct error"); 542is(eval { bless([], "Baz") | "x" }, "y", "| overload works"); 543 544my $obj = bless [], "Bar"; 545$strval = "x"; 546eval { $obj |= "Q" }; 547$strval = "z"; 548is("$obj", "z", "|= doesn't break string overload"); 549 550# [perl #29070] 551$^A .= new version ~$_ for eval sprintf('"\\x%02x"', 0xff - ord("1")), 552 $::IS_EBCDIC ? v13 : v205, # 255 - ord('2') 553 eval sprintf('"\\x%02x"', 0xff - ord("3")); 554is $^A, "123", '~v0 clears vstring magic on retval'; 555 556{ 557 my $w = $Config::Config{ivsize} * 8; 558 559 fail("unexpected w $w") unless $w == 32 || $w == 64; 560 561 is(1 << 1, 2, "UV 1 left shift 1"); 562 is(1 >> 1, 0, "UV 1 right shift 1"); 563 564 is(0x7b << -4, 0x007, "UV left negative shift == right shift"); 565 is(0x7b >> -4, 0x7b0, "UV right negative shift == left shift"); 566 567 is(0x7b << 0, 0x07b, "UV left zero shift == identity"); 568 is(0x7b >> 0, 0x07b, "UV right zero shift == identity"); 569 570 is(0x0 << -1, 0x0, "zero left negative shift == zero"); 571 is(0x0 >> -1, 0x0, "zero right negative shift == zero"); 572 573 cmp_ok(1 << $w - 1, '==', 2 ** ($w - 1), # not is() because NV stringify. 574 "UV left $w - 1 shift == 2 ** ($w - 1)"); 575 is(1 << $w, 0, "UV left shift $w == zero"); 576 is(1 << $w + 1, 0, "UV left shift $w + 1 == zero"); 577 578 is(1 >> $w - 1, 0, "UV right shift $w - 1 == zero"); 579 is(1 >> $w, 0, "UV right shift $w == zero"); 580 is(1 >> $w + 1, 0, "UV right shift $w + 1 == zero"); 581 582 # Negative shiftees get promoted to UVs before shifting. This is 583 # not necessarily the ideal behavior, but that is what is happening. 584 if ($w == 64) { 585 no warnings "portable"; 586 no warnings "overflow"; # prevent compile-time warning for ivsize=4 587 is(-1 << 1, 0xFFFF_FFFF_FFFF_FFFE, 588 "neg UV (sic) left shift = 0xFF..E"); 589 is(-1 >> 1, 0x7FFF_FFFF_FFFF_FFFF, 590 "neg UV (sic) right shift = 0x7F..F"); 591 } elsif ($w == 32) { 592 no warnings "portable"; 593 is(-1 << 1, 0xFFFF_FFFE, "neg left shift == 0xFF..E"); 594 is(-1 >> 1, 0x7FFF_FFFF, "neg right shift == 0x7F..F"); 595 } 596 597 { 598 # 'use integer' means use IVs instead of UVs. 599 use integer; 600 601 # No surprises here. 602 is(1 << 1, 2, "IV 1 left shift 1 == 2"); 603 is(1 >> 1, 0, "IV 1 right shift 1 == 0"); 604 605 # The left overshift should behave like without 'use integer', 606 # that is, return zero. 607 is(1 << $w, 0, "IV 1 left shift $w == 0"); 608 is(1 << $w + 1, 0, "IV 1 left shift $w + 1 == 0"); 609 is(-1 << $w, 0, "IV -1 left shift $w == 0"); 610 is(-1 << $w + 1, 0, "IV -1 left shift $w + 1 == 0"); 611 612 # Even for negative IVs, left shift is multiplication. 613 # But right shift should display the stuckiness to -1. 614 is(-1 << 1, -2, "IV -1 left shift 1 == -2"); 615 is(-1 >> 1, -1, "IV -1 right shift 1 == -1"); 616 617 # As for UVs, negative shifting means the reverse shift. 618 is(-1 << -1, -1, "IV -1 left shift -1 == -1"); 619 is(-1 >> -1, -2, "IV -1 right shift -1 == -2"); 620 621 # Test also at and around wordsize, expect stuckiness to -1. 622 is(-1 >> $w - 1, -1, "IV -1 right shift $w - 1 == -1"); 623 is(-1 >> $w, -1, "IV -1 right shift $w == -1"); 624 is(-1 >> $w + 1, -1, "IV -1 right shift $w + 1 == -1"); 625 } 626} 627 628# [perl #129287] UTF8 & was not providing a trailing null byte. 629# This test is a bit convoluted, as we want to make sure that the string 630# allocated for &’s target contains memory initialised to something other 631# than a null byte. Uninitialised memory does not make for a reliable 632# test. So we do &. on a longer non-utf8 string first. 633for (["aaa","aaa"],[substr ("a\x{100}",0,1), "a"]) { 634 use feature "bitwise"; 635 no warnings "experimental::bitwise", "pack"; 636 $byte = substr unpack("P2", pack "P", $$_[0] &. $$_[1]), -1; 637} 638is $byte, "\0", "utf8 &. appends null byte"; 639 640# only visible under sanitize 641fresh_perl_is('$x = "UUUUUUUV"; $y = "xxxxxxx"; $x |= $y; print $x', 642 ( $::IS_EBCDIC) ? 'XXXXXXXV' : '}}}}}}}V', 643 {}, "[perl #129995] access to freed memory"); 644 645 646# 647# Using code points above 0xFF is fatal 648# 649foreach my $op_info ([and => "&"], [or => "|"], [xor => "^"]) { 650 my ($op_name, $op) = @$op_info; 651 local $@; 652 eval '$_ = "\xFF" ' . $op . ' "\x{100}";'; 653 like $@, qr /^Use of strings with code points over 0xFF as arguments (?# 654 )to bitwise $op_name \Q($op)\E operator is not allowed/, 655 "Use of code points above 0xFF as arguments to bitwise " . 656 "$op_name ($op) is not allowed"; 657} 658 659{ 660 local $@; 661 eval '$_ = ~ "\x{100}";'; 662 like $@, qr /^Use of strings with code points over 0xFF as arguments (?# 663 )to 1's complement \(~\) operator is not allowed/, 664 "Use of code points above 0xFF as argument to 1's complement " . 665 "(~) is not allowed"; 666} 667 668{ 669 # RT 134140 fatalizations 670 my %op_pairs = ( 671 and => { low => 'and', high => '&', regex => qr/&/ }, 672 or => { low => 'or', high => '|', regex => qr/\|/ }, 673 xor => { low => 'xor', high => '^', regex => qr/\^/ }, 674 ); 675 my @combos = ( 676 { string => '"abc" & "abc\x{100}"', op_pair => $op_pairs{and} }, 677 { string => '"abc" | "abc\x{100}"', op_pair => $op_pairs{or} }, 678 { string => '"abc" ^ "abc\x{100}"', op_pair => $op_pairs{xor} }, 679 { string => '"abc\x{100}" & "abc"', op_pair => $op_pairs{and} }, 680 { string => '"abc\x{100}" | "abc"', op_pair => $op_pairs{or} }, 681 { string => '"abc\x{100}" ^ "abc"', op_pair => $op_pairs{xor} }, 682 683 ); 684 685 # Use of strings with code points over 0xFF as arguments to %s operator is not allowed 686 for my $h (@combos) { 687 my $s1 = "Use of strings with code points over 0xFF as arguments to bitwise"; 688 my $s2 = "operator is not allowed"; 689 my $expected = qr/$s1 $h->{op_pair}->{low} \($h->{op_pair}->{regex}\) $s2/; 690 my $description = "$s1 $h->{op_pair}->{low} ($h->{op_pair}->{high}) operator is not allowed"; 691 local $@; 692 eval $h->{string}; 693 like $@, $expected, $description; 694 } 695} 696 697{ 698 # perl #17844 - only visible with valgrind/ASAN 699 fresh_perl_is(<<'EOS', 700formline X000n^\\0,\\0^\\0for\0,0..10 701EOS 702 '', 703 {}, "[perl #17844] access beyond end of block"); 704} 705