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