Commit | Line | Data |
---|---|---|
ddb9d9dc | 1 | #!./perl |
2 | ||
3 | # | |
55497cff | 4 | # test the bit operators '&', '|', '^', '~', '<<', and '>>' |
ddb9d9dc | 5 | # |
6 | ||
d1f8c7a4 CS |
7 | BEGIN { |
8 | chdir 't' if -d 't'; | |
20822f61 | 9 | @INC = '../lib'; |
b35338b6 | 10 | require "./test.pl"; require "./charset_tools.pl"; |
784fea9c | 11 | require Config; |
d1f8c7a4 CS |
12 | } |
13 | ||
add36b05 NC |
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) | |
b69687e7 | 18 | plan tests => 192 + (10*13*2) + 5 + 29; |
ddb9d9dc | 19 | |
20 | # numerics | |
add36b05 NC |
21 | ok ((0xdead & 0xbeef) == 0x9ead); |
22 | ok ((0xdead | 0xbeef) == 0xfeef); | |
23 | ok ((0xdead ^ 0xbeef) == 0x6042); | |
24 | ok ((~0xdead & 0xbeef) == 0x2042); | |
55497cff | 25 | |
26 | # shifts | |
add36b05 NC |
27 | ok ((257 << 7) == 32896); |
28 | ok ((33023 >> 7) == 257); | |
55497cff | 29 | |
30 | # signed vs. unsigned | |
add36b05 | 31 | ok ((~0 > 0 && do { use integer; ~0 } == -1)); |
d1f8c7a4 CS |
32 | |
33 | my $bits = 0; | |
34 | for (my $i = ~0; $i; $i >>= 1) { ++$bits; } | |
35 | my $cusp = 1 << ($bits - 1); | |
36 | ||
add36b05 NC |
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)); | |
ddb9d9dc | 45 | |
9d116dd7 JH |
46 | $Aaz = chr(ord("A") & ord("z")); |
47 | $Aoz = chr(ord("A") | ord("z")); | |
48 | $Axz = chr(ord("A") ^ ord("z")); | |
49 | ||
ddb9d9dc | 50 | # short strings |
add36b05 NC |
51 | is (("AAAAA" & "zzzzz"), ($Aaz x 5)); |
52 | is (("AAAAA" | "zzzzz"), ($Aoz x 5)); | |
53 | is (("AAAAA" ^ "zzzzz"), ($Axz x 5)); | |
ddb9d9dc | 54 | |
55 | # long strings | |
56 | $foo = "A" x 150; | |
57 | $bar = "z" x 75; | |
9d116dd7 JH |
58 | $zap = "A" x 75; |
59 | # & truncates | |
add36b05 | 60 | is (($foo & $bar), ($Aaz x 75 )); |
9d116dd7 | 61 | # | does not truncate |
add36b05 | 62 | is (($foo | $bar), ($Aoz x 75 . $zap)); |
9d116dd7 | 63 | # ^ does not truncate |
add36b05 | 64 | is (($foo ^ $bar), ($Axz x 75 . $zap)); |
9d116dd7 | 65 | |
b35338b6 KW |
66 | # string constants. These tests expect the bit patterns of these strings in |
67 | # ASCII, so convert to that. | |
68 | sub _and($) { $_[0] & native_to_uni("+0") } | |
69 | sub _oar($) { $_[0] | native_to_uni("+0") } | |
70 | sub _xor($) { $_[0] ^ native_to_uni("+0") } | |
71 | is _and native_to_uni("waf"), native_to_uni('# '), 'str var & const str'; # [perl #20661] | |
72 | is _and native_to_uni("waf"), native_to_uni('# '), 'str var & const str again'; # [perl #20661] | |
73 | is _oar native_to_uni("yit"), native_to_uni('{yt'), 'str var | const str'; | |
74 | is _oar native_to_uni("yit"), native_to_uni('{yt'), 'str var | const str again'; | |
75 | is _xor native_to_uni("yit"), native_to_uni('RYt'), 'str var ^ const str'; | |
76 | is _xor native_to_uni("yit"), native_to_uni('RYt'), 'str var ^ const str again'; | |
77 | ||
78 | SKIP: { | |
79 | skip "Converting a numeric doesn't work with EBCDIC unlike the above tests", | |
80 | 3 if $::IS_EBCDIC; | |
81 | is _and 0, '0', 'num var & const str'; # [perl #20661] | |
82 | is _oar 0, '0', 'num var | const str'; | |
83 | is _xor 0, '0', 'num var ^ const str'; | |
84 | } | |
b20c4ee1 | 85 | |
5ee80e13 FC |
86 | # But don’t mistake a COW for a constant when assigning to it |
87 | %h=(150=>1); | |
88 | $i=(keys %h)[0]; | |
89 | $i |= 105; | |
90 | is $i, 255, '[perl #108480] $cow |= number'; | |
91 | $i=(keys %h)[0]; | |
92 | $i &= 105; | |
93 | is $i, 0, '[perl #108480] $cow &= number'; | |
94 | $i=(keys %h)[0]; | |
95 | $i ^= 105; | |
96 | is $i, 255, '[perl #108480] $cow ^= number'; | |
97 | ||
0c57e439 | 98 | # |
add36b05 NC |
99 | is ("ok \xFF\xFF\n" & "ok 19\n", "ok 19\n"); |
100 | is ("ok 20\n" | "ok \0\0\n", "ok 20\n"); | |
101 | is ("o\000 \0001\000" ^ "\000k\0002\000\n", "ok 21\n"); | |
0c57e439 GS |
102 | |
103 | # | |
add36b05 NC |
104 | is ("ok \x{FF}\x{FF}\n" & "ok 22\n", "ok 22\n"); |
105 | is ("ok 23\n" | "ok \x{0}\x{0}\n", "ok 23\n"); | |
106 | is ("o\x{0} \x{0}4\x{0}" ^ "\x{0}k\x{0}2\x{0}\n", "ok 24\n"); | |
0c57e439 GS |
107 | |
108 | # | |
add36b05 NC |
109 | is (sprintf("%vd", v4095 & v801), 801); |
110 | is (sprintf("%vd", v4095 | v801), 4095); | |
111 | is (sprintf("%vd", v4095 ^ v801), 3294); | |
0c57e439 GS |
112 | |
113 | # | |
add36b05 NC |
114 | is (sprintf("%vd", v4095.801.4095 & v801.4095), '801.801'); |
115 | is (sprintf("%vd", v4095.801.4095 | v801.4095), '4095.4095.4095'); | |
116 | is (sprintf("%vd", v801.4095 ^ v4095.801.4095), '3294.3294.4095'); | |
2a4ebaa6 | 117 | # |
add36b05 NC |
118 | is (sprintf("%vd", v120.300 & v200.400), '72.256'); |
119 | is (sprintf("%vd", v120.300 | v200.400), '248.444'); | |
120 | is (sprintf("%vd", v120.300 ^ v200.400), '176.188'); | |
2a4ebaa6 | 121 | # |
51f0b9cd JH |
122 | { |
123 | my $a = v120.300; | |
124 | my $b = v200.400; | |
125 | $a ^= $b; | |
126 | is (sprintf("%vd", $a), '176.188'); | |
127 | } | |
128 | { | |
129 | my $a = v120.300; | |
130 | my $b = v200.400; | |
131 | $a |= $b; | |
132 | is (sprintf("%vd", $a), '248.444'); | |
133 | } | |
3da1940a | 134 | |
1d68d6cd SC |
135 | # |
136 | # UTF8 ~ behaviour | |
3da1940a JH |
137 | # |
138 | ||
b35338b6 KW |
139 | SKIP: { |
140 | skip "Complements exceed maximum representable on EBCDIC ", 5 if $::IS_EBCDIC; | |
210db7fc | 141 | |
b35338b6 | 142 | my @not36; |
3da1940a | 143 | |
b35338b6 KW |
144 | for (0x100...0xFFF) { |
145 | $a = ~(chr $_); | |
146 | push @not36, sprintf("%#03X", $_) | |
147 | if $a ne chr(~$_) or length($a) != 1 or ~$a ne chr($_); | |
148 | } | |
149 | is (join (', ', @not36), ''); | |
1d68d6cd | 150 | |
b35338b6 | 151 | my @not37; |
3da1940a | 152 | |
b35338b6 KW |
153 | for my $i (0xEEE...0xF00) { |
154 | for my $j (0x0..0x120) { | |
155 | $a = ~(chr ($i) . chr $j); | |
156 | push @not37, sprintf("%#03X %#03X", $i, $j) | |
157 | if $a ne chr(~$i).chr(~$j) or | |
158 | length($a) != 2 or | |
159 | ~$a ne chr($i).chr($j); | |
160 | } | |
210db7fc | 161 | } |
b35338b6 | 162 | is (join (', ', @not37), ''); |
add36b05 | 163 | |
b35338b6 | 164 | is (~chr(~0), "\0"); |
f0da931d | 165 | |
a1ca4561 | 166 | |
b35338b6 | 167 | my @not39; |
a1ca4561 | 168 | |
b35338b6 KW |
169 | for my $i (0x100..0x120) { |
170 | for my $j (0x100...0x120) { | |
171 | push @not39, sprintf("%#03X %#03X", $i, $j) | |
172 | if ~(chr($i)|chr($j)) ne (~chr($i)&~chr($j)); | |
173 | } | |
a1ca4561 | 174 | } |
b35338b6 | 175 | is (join (', ', @not39), ''); |
a1ca4561 | 176 | |
b35338b6 | 177 | my @not40; |
a1ca4561 | 178 | |
b35338b6 KW |
179 | for my $i (0x100..0x120) { |
180 | for my $j (0x100...0x120) { | |
181 | push @not40, sprintf("%#03X %#03X", $i, $j) | |
182 | if ~(chr($i)&chr($j)) ne (~chr($i)|~chr($j)); | |
183 | } | |
a1ca4561 | 184 | } |
b35338b6 | 185 | is (join (', ', @not40), ''); |
a1ca4561 | 186 | } |
add36b05 | 187 | |
299b089d JH |
188 | |
189 | # More variations on 19 and 22. | |
add36b05 NC |
190 | is ("ok \xFF\x{FF}\n" & "ok 41\n", "ok 41\n"); |
191 | is ("ok \x{FF}\xFF\n" & "ok 42\n", "ok 42\n"); | |
66a74c25 JO |
192 | |
193 | # Tests to see if you really can do casts negative floats to unsigned properly | |
194 | $neg1 = -1.0; | |
add36b05 | 195 | ok (~ $neg1 == 0); |
66a74c25 | 196 | $neg7 = -7.0; |
add36b05 | 197 | ok (~ $neg7 == 6); |
891f9566 | 198 | |
891f9566 YST |
199 | |
200 | # double magic tests | |
201 | ||
202 | sub TIESCALAR { bless { value => $_[1], orig => $_[1] } } | |
203 | sub STORE { $_[0]{store}++; $_[0]{value} = $_[1] } | |
204 | sub FETCH { $_[0]{fetch}++; $_[0]{value} } | |
205 | sub stores { tied($_[0])->{value} = tied($_[0])->{orig}; | |
206 | delete(tied($_[0])->{store}) || 0 } | |
207 | sub fetches { delete(tied($_[0])->{fetch}) || 0 } | |
208 | ||
209 | # numeric double magic tests | |
210 | ||
211 | tie $x, "main", 1; | |
212 | tie $y, "main", 3; | |
213 | ||
214 | is(($x | $y), 3); | |
215 | is(fetches($x), 1); | |
216 | is(fetches($y), 1); | |
217 | is(stores($x), 0); | |
218 | is(stores($y), 0); | |
219 | ||
220 | is(($x & $y), 1); | |
221 | is(fetches($x), 1); | |
222 | is(fetches($y), 1); | |
223 | is(stores($x), 0); | |
224 | is(stores($y), 0); | |
225 | ||
226 | is(($x ^ $y), 2); | |
227 | is(fetches($x), 1); | |
228 | is(fetches($y), 1); | |
229 | is(stores($x), 0); | |
230 | is(stores($y), 0); | |
231 | ||
232 | is(($x |= $y), 3); | |
233 | is(fetches($x), 2); | |
234 | is(fetches($y), 1); | |
235 | is(stores($x), 1); | |
236 | is(stores($y), 0); | |
237 | ||
238 | is(($x &= $y), 1); | |
239 | is(fetches($x), 2); | |
240 | is(fetches($y), 1); | |
241 | is(stores($x), 1); | |
242 | is(stores($y), 0); | |
243 | ||
244 | is(($x ^= $y), 2); | |
245 | is(fetches($x), 2); | |
246 | is(fetches($y), 1); | |
247 | is(stores($x), 1); | |
248 | is(stores($y), 0); | |
249 | ||
250 | is(~~$y, 3); | |
251 | is(fetches($y), 1); | |
252 | is(stores($y), 0); | |
253 | ||
254 | { use integer; | |
255 | ||
256 | is(($x | $y), 3); | |
257 | is(fetches($x), 1); | |
258 | is(fetches($y), 1); | |
259 | is(stores($x), 0); | |
260 | is(stores($y), 0); | |
261 | ||
262 | is(($x & $y), 1); | |
263 | is(fetches($x), 1); | |
264 | is(fetches($y), 1); | |
265 | is(stores($x), 0); | |
266 | is(stores($y), 0); | |
267 | ||
268 | is(($x ^ $y), 2); | |
269 | is(fetches($x), 1); | |
270 | is(fetches($y), 1); | |
271 | is(stores($x), 0); | |
272 | is(stores($y), 0); | |
273 | ||
274 | is(($x |= $y), 3); | |
275 | is(fetches($x), 2); | |
276 | is(fetches($y), 1); | |
277 | is(stores($x), 1); | |
278 | is(stores($y), 0); | |
279 | ||
280 | is(($x &= $y), 1); | |
281 | is(fetches($x), 2); | |
282 | is(fetches($y), 1); | |
283 | is(stores($x), 1); | |
284 | is(stores($y), 0); | |
285 | ||
286 | is(($x ^= $y), 2); | |
287 | is(fetches($x), 2); | |
288 | is(fetches($y), 1); | |
289 | is(stores($x), 1); | |
290 | is(stores($y), 0); | |
291 | ||
292 | is(~$y, -4); | |
293 | is(fetches($y), 1); | |
294 | is(stores($y), 0); | |
295 | ||
296 | } # end of use integer; | |
297 | ||
298 | # stringwise double magic tests | |
299 | ||
300 | tie $x, "main", "a"; | |
301 | tie $y, "main", "c"; | |
302 | ||
303 | is(($x | $y), ("a" | "c")); | |
304 | is(fetches($x), 1); | |
305 | is(fetches($y), 1); | |
306 | is(stores($x), 0); | |
307 | is(stores($y), 0); | |
308 | ||
309 | is(($x & $y), ("a" & "c")); | |
310 | is(fetches($x), 1); | |
311 | is(fetches($y), 1); | |
312 | is(stores($x), 0); | |
313 | is(stores($y), 0); | |
314 | ||
315 | is(($x ^ $y), ("a" ^ "c")); | |
316 | is(fetches($x), 1); | |
317 | is(fetches($y), 1); | |
318 | is(stores($x), 0); | |
319 | is(stores($y), 0); | |
320 | ||
321 | is(($x |= $y), ("a" | "c")); | |
322 | is(fetches($x), 2); | |
323 | is(fetches($y), 1); | |
324 | is(stores($x), 1); | |
325 | is(stores($y), 0); | |
326 | ||
327 | is(($x &= $y), ("a" & "c")); | |
328 | is(fetches($x), 2); | |
329 | is(fetches($y), 1); | |
330 | is(stores($x), 1); | |
331 | is(stores($y), 0); | |
332 | ||
333 | is(($x ^= $y), ("a" ^ "c")); | |
334 | is(fetches($x), 2); | |
335 | is(fetches($y), 1); | |
336 | is(stores($x), 1); | |
337 | is(stores($y), 0); | |
338 | ||
339 | is(~~$y, "c"); | |
340 | is(fetches($y), 1); | |
341 | is(stores($y), 0); | |
d0a21e00 GA |
342 | |
343 | $a = "\0\x{100}"; chop($a); | |
344 | ok(utf8::is_utf8($a)); # make sure UTF8 flag is still there | |
345 | $a = ~$a; | |
346 | is($a, "\xFF", "~ works with utf-8"); | |
80ff368f RGS |
347 | |
348 | # [rt.perl.org 33003] | |
784fea9c NC |
349 | # This would cause a segfault without malloc wrap |
350 | SKIP: { | |
351 | skip "No malloc wrap checks" unless $Config::Config{usemallocwrap}; | |
aaa63dae | 352 | like( runperl(prog => 'eval q($#a>>=1); print 1'), qr/^1\n?/ ); |
784fea9c | 353 | } |
1a787b95 TS |
354 | |
355 | # [perl #37616] Bug in &= (string) and/or m// | |
356 | { | |
357 | $a = "aa"; | |
358 | $a &= "a"; | |
359 | ok($a =~ /a+$/, 'ASCII "a" is NUL-terminated'); | |
360 | ||
361 | $b = "bb\x{100}"; | |
362 | $b &= "b"; | |
363 | ok($b =~ /b+$/, 'Unicode "b" is NUL-terminated'); | |
364 | } | |
794a0d33 JH |
365 | |
366 | { | |
367 | $a = chr(0x101) x 0x101; | |
368 | $b = chr(0x0FF) x 0x0FF; | |
369 | ||
370 | $c = $a | $b; | |
371 | is($c, chr(0x1FF) x 0xFF . chr(0x101) x 2); | |
372 | ||
373 | $c = $b | $a; | |
374 | is($c, chr(0x1FF) x 0xFF . chr(0x101) x 2); | |
375 | ||
376 | $c = $a & $b; | |
377 | is($c, chr(0x001) x 0x0FF); | |
378 | ||
379 | $c = $b & $a; | |
380 | is($c, chr(0x001) x 0x0FF); | |
381 | ||
382 | $c = $a ^ $b; | |
383 | is($c, chr(0x1FE) x 0x0FF . chr(0x101) x 2); | |
384 | ||
385 | $c = $b ^ $a; | |
386 | is($c, chr(0x1FE) x 0x0FF . chr(0x101) x 2); | |
387 | } | |
388 | ||
389 | { | |
390 | $a = chr(0x101) x 0x101; | |
391 | $b = chr(0x0FF) x 0x0FF; | |
392 | ||
393 | $a |= $b; | |
394 | is($a, chr(0x1FF) x 0xFF . chr(0x101) x 2); | |
395 | } | |
396 | ||
397 | { | |
398 | $a = chr(0x101) x 0x101; | |
399 | $b = chr(0x0FF) x 0x0FF; | |
400 | ||
401 | $b |= $a; | |
402 | is($b, chr(0x1FF) x 0xFF . chr(0x101) x 2); | |
403 | } | |
404 | ||
405 | { | |
406 | $a = chr(0x101) x 0x101; | |
407 | $b = chr(0x0FF) x 0x0FF; | |
408 | ||
409 | $a &= $b; | |
410 | is($a, chr(0x001) x 0x0FF); | |
411 | } | |
412 | ||
413 | { | |
414 | $a = chr(0x101) x 0x101; | |
415 | $b = chr(0x0FF) x 0x0FF; | |
416 | ||
417 | $b &= $a; | |
418 | is($b, chr(0x001) x 0x0FF); | |
419 | } | |
420 | ||
421 | { | |
422 | $a = chr(0x101) x 0x101; | |
423 | $b = chr(0x0FF) x 0x0FF; | |
424 | ||
425 | $a ^= $b; | |
426 | is($a, chr(0x1FE) x 0x0FF . chr(0x101) x 2); | |
427 | } | |
428 | ||
429 | { | |
430 | $a = chr(0x101) x 0x101; | |
431 | $b = chr(0x0FF) x 0x0FF; | |
432 | ||
433 | $b ^= $a; | |
434 | is($b, chr(0x1FE) x 0x0FF . chr(0x101) x 2); | |
435 | } | |
436 | ||
8c8eee82 | 437 | |
b6e8d7fe FC |
438 | # New string- and number-specific bitwise ops |
439 | { | |
440 | use feature "bitwise"; | |
441 | no warnings "experimental::bitwise"; | |
442 | is "22" & "66", 2, 'numeric & with strings'; | |
443 | is "22" | "66", 86, 'numeric | with strings'; | |
444 | is "22" ^ "66", 84, 'numeric ^ with strings'; | |
445 | is ~"22" & 0xff, 233, 'numeric ~ with string'; | |
446 | is 22 &. 66, 22, '&. with numbers'; | |
447 | is 22 |. 66, 66, '|. with numbers'; | |
448 | is 22 ^. 66, "\4\4", '^. with numbers'; | |
b35338b6 KW |
449 | if ($::IS_EBCDIC) { |
450 | # ord('2') is 0xF2 on EBCDIC | |
451 | is ~.22, "\x0d\x0d", '~. with number'; | |
452 | } | |
453 | else { | |
454 | # ord('2') is 0x32 on ASCII | |
455 | is ~.22, "\xcd\xcd", '~. with number'; | |
456 | } | |
b6e8d7fe FC |
457 | $_ = "22"; |
458 | is $_ &= "66", 2, 'numeric &= with strings'; | |
459 | $_ = "22"; | |
460 | is $_ |= "66", 86, 'numeric |= with strings'; | |
461 | $_ = "22"; | |
462 | is $_ ^= "66", 84, 'numeric ^= with strings'; | |
463 | $_ = 22; | |
464 | is $_ &.= 66, 22, '&.= with numbers'; | |
465 | $_ = 22; | |
466 | is $_ |.= 66, 66, '|.= with numbers'; | |
467 | $_ = 22; | |
468 | is $_ ^.= 66, "\4\4", '^.= with numbers'; | |
469 | ||
470 | # signed vs. unsigned | |
471 | ok ((~0 > 0 && do { use integer; ~0 } == -1)); | |
472 | ||
473 | my $bits = 0; | |
474 | for (my $i = ~0; $i; $i >>= 1) { ++$bits; } | |
475 | my $cusp = 1 << ($bits - 1); | |
476 | ||
477 | ok (($cusp & -1) > 0 && do { use integer; $cusp & -1 } < 0); | |
478 | ok (($cusp | 1) > 0 && do { use integer; $cusp | 1 } < 0); | |
479 | ok (($cusp ^ 1) > 0 && do { use integer; $cusp ^ 1 } < 0); | |
480 | ok ((1 << ($bits - 1)) == $cusp && | |
481 | do { use integer; 1 << ($bits - 1) } == -$cusp); | |
482 | ok (($cusp >> 1) == ($cusp / 2) && | |
483 | do { use integer; abs($cusp >> 1) } == ($cusp / 2)); | |
484 | } | |
485 | ||
8c8eee82 BM |
486 | # ref tests |
487 | ||
488 | my %res; | |
489 | ||
490 | for my $str ("x", "\x{100}") { | |
491 | for my $chr (qw/S A H G X ( * F/) { | |
492 | for my $op (qw/| & ^/) { | |
493 | my $co = ord $chr; | |
494 | my $so = ord $str; | |
495 | $res{"$chr$op$str"} = eval qq/chr($co $op $so)/; | |
496 | } | |
497 | } | |
498 | $res{"undef|$str"} = $str; | |
499 | $res{"undef&$str"} = ""; | |
500 | $res{"undef^$str"} = $str; | |
501 | } | |
502 | ||
503 | sub PVBM () { "X" } | |
51f0b9cd | 504 | 1 if index "foo", PVBM; |
8c8eee82 BM |
505 | |
506 | my $warn = 0; | |
507 | local $^W = 1; | |
508 | local $SIG{__WARN__} = sub { $warn++ }; | |
509 | ||
510 | sub is_first { | |
511 | my ($got, $orig, $op, $str, $name) = @_; | |
512 | is(substr($got, 0, 1), $res{"$orig$op$str"}, $name); | |
513 | } | |
514 | ||
515 | for ( | |
516 | # [object to test, first char of stringification, name] | |
517 | [undef, "undef", "undef" ], | |
518 | [\1, "S", "scalar ref" ], | |
519 | [[], "A", "array ref" ], | |
520 | [{}, "H", "hash ref" ], | |
521 | [qr/x/, "(", "qr//" ], | |
522 | [*foo, "*", "glob" ], | |
523 | [\*foo, "G", "glob ref" ], | |
524 | [PVBM, "X", "PVBM" ], | |
525 | [\PVBM, "S", "PVBM ref" ], | |
526 | [bless([], "Foo"), "F", "object" ], | |
527 | ) { | |
528 | my ($val, $orig, $type) = @$_; | |
529 | ||
530 | for (["x", "string"], ["\x{100}", "utf8"]) { | |
531 | my ($str, $desc) = @$_; | |
532 | ||
533 | $warn = 0; | |
534 | ||
535 | is_first($val | $str, $orig, "|", $str, "$type | $desc"); | |
536 | is_first($val & $str, $orig, "&", $str, "$type & $desc"); | |
537 | is_first($val ^ $str, $orig, "^", $str, "$type ^ $desc"); | |
538 | ||
539 | is_first($str | $val, $orig, "|", $str, "$desc | $type"); | |
540 | is_first($str & $val, $orig, "&", $str, "$desc & $type"); | |
541 | is_first($str ^ $val, $orig, "^", $str, "$desc ^ $type"); | |
542 | ||
543 | my $new; | |
544 | ($new = $val) |= $str; | |
545 | is_first($new, $orig, "|", $str, "$type |= $desc"); | |
546 | ($new = $val) &= $str; | |
547 | is_first($new, $orig, "&", $str, "$type &= $desc"); | |
548 | ($new = $val) ^= $str; | |
549 | is_first($new, $orig, "^", $str, "$type ^= $desc"); | |
550 | ||
551 | ($new = $str) |= $val; | |
552 | is_first($new, $orig, "|", $str, "$desc |= $type"); | |
553 | ($new = $str) &= $val; | |
554 | is_first($new, $orig, "&", $str, "$desc &= $type"); | |
555 | ($new = $str) ^= $val; | |
556 | is_first($new, $orig, "^", $str, "$desc ^= $type"); | |
557 | ||
558 | if ($orig eq "undef") { | |
559 | # undef |= and undef ^= don't warn | |
560 | is($warn, 10, "no duplicate warnings"); | |
561 | } | |
562 | else { | |
563 | is($warn, 0, "no warnings"); | |
564 | } | |
565 | } | |
566 | } | |
567 | ||
568 | my $strval; | |
569 | ||
570 | { | |
571 | package Bar; | |
572 | use overload q/""/ => sub { $strval }; | |
573 | ||
574 | package Baz; | |
575 | use overload q/|/ => sub { "y" }; | |
576 | } | |
577 | ||
51f0b9cd | 578 | ok(!eval { 1 if bless([], "Bar") | "x"; 1 },"string overload can't use |"); |
8c8eee82 BM |
579 | like($@, qr/no method found/, "correct error"); |
580 | is(eval { bless([], "Baz") | "x" }, "y", "| overload works"); | |
581 | ||
582 | my $obj = bless [], "Bar"; | |
583 | $strval = "x"; | |
584 | eval { $obj |= "Q" }; | |
585 | $strval = "z"; | |
586 | is("$obj", "z", "|= doesn't break string overload"); | |
1e6bda93 FC |
587 | |
588 | # [perl #29070] | |
b35338b6 KW |
589 | $^A .= new version ~$_ for eval sprintf('"\\x%02x"', 0xff - ord("1")), |
590 | $::IS_EBCDIC ? v13 : v205, # 255 - ord('2') | |
591 | eval sprintf('"\\x%02x"', 0xff - ord("3")); | |
1e6bda93 | 592 | is $^A, "123", '~v0 clears vstring magic on retval'; |
b3498293 JH |
593 | |
594 | { | |
595 | my $w = $Config::Config{ivsize} * 8; | |
596 | ||
597 | fail("unexpected w $w") unless $w == 32 || $w == 64; | |
598 | ||
599 | is(1 << 1, 2, "UV 1 left shift 1"); | |
600 | is(1 >> 1, 0, "UV 1 right shift 1"); | |
601 | ||
602 | is(0x7b << -4, 0x007, "UV left negative shift == right shift"); | |
603 | is(0x7b >> -4, 0x7b0, "UV right negative shift == left shift"); | |
604 | ||
605 | is(0x7b << 0, 0x07b, "UV left zero shift == identity"); | |
606 | is(0x7b >> 0, 0x07b, "UV right zero shift == identity"); | |
607 | ||
608 | is(0x0 << -1, 0x0, "zero left negative shift == zero"); | |
609 | is(0x0 >> -1, 0x0, "zero right negative shift == zero"); | |
610 | ||
611 | cmp_ok(1 << $w - 1, '==', 2 ** ($w - 1), # not is() because NV stringify. | |
612 | "UV left $w - 1 shift == 2 ** ($w - 1)"); | |
613 | is(1 << $w, 0, "UV left shift $w == zero"); | |
614 | is(1 << $w + 1, 0, "UV left shift $w + 1 == zero"); | |
615 | ||
616 | is(1 >> $w - 1, 0, "UV right shift $w - 1 == zero"); | |
617 | is(1 >> $w, 0, "UV right shift $w == zero"); | |
618 | is(1 >> $w + 1, 0, "UV right shift $w + 1 == zero"); | |
619 | ||
620 | # Negative shiftees get promoted to UVs before shifting. This is | |
621 | # not necessarily the ideal behavior, but that is what is happening. | |
622 | if ($w == 64) { | |
623 | no warnings "portable"; | |
b69687e7 JH |
624 | is(-1 << 1, 0xFFFF_FFFF_FFFF_FFFE, |
625 | "neg UV (sic) left shift = 0xFF..E"); | |
626 | is(-1 >> 1, 0x7FFF_FFFF_FFFF_FFFF, | |
627 | "neg UV (sic) right right = 0x7F..F"); | |
b3498293 JH |
628 | } elsif ($w == 32) { |
629 | no warnings "portable"; | |
b69687e7 JH |
630 | is(-1 << 1, 0xFFFF_FFFE, "neg left shift == 0xFF..E"); |
631 | is(-1 >> 1, 0x7FFF_FFFF, "neg right right == 0x7F..F"); | |
b3498293 JH |
632 | } |
633 | ||
634 | { | |
635 | # 'use integer' means use IVs instead of UVs. | |
636 | use integer; | |
637 | ||
b69687e7 JH |
638 | # No surprises here. |
639 | is(1 << 1, 2, "IV 1 left shift 1 == 2"); | |
640 | is(1 >> 1, 0, "IV 1 right shift 1 == 0"); | |
b3498293 | 641 | |
b69687e7 JH |
642 | # The left overshift should behave like without 'use integer', |
643 | # that is, return zero. | |
644 | is(1 << $w, 0, "IV 1 left shift $w == 0"); | |
645 | is(1 << $w + 1, 0, "IV 1 left shift $w + 1 == 0"); | |
646 | is(-1 << $w, 0, "IV -1 left shift $w == 0"); | |
647 | is(-1 << $w + 1, 0, "IV -1 left shift $w + 1 == 0"); | |
b3498293 | 648 | |
b69687e7 JH |
649 | # Even for negative IVs, left shift is multiplication. |
650 | # But right shift should display the stuckiness to -1. | |
651 | is(-1 << 1, -2, "IV -1 left shift 1 == -2"); | |
b3498293 JH |
652 | is(-1 >> 1, -1, "IV -1 right shift 1 == -1"); |
653 | ||
654 | # As for UVs, negative shifting means the reverse shift. | |
655 | is(-1 << -1, -1, "IV -1 left shift -1 == -1"); | |
656 | is(-1 >> -1, -2, "IV -1 right shift -1 == -2"); | |
657 | ||
658 | # Test also at and around wordsize, expect stuckiness to -1. | |
659 | is(-1 >> $w - 1, -1, "IV -1 right shift $w - 1 == -1"); | |
660 | is(-1 >> $w, -1, "IV -1 right shift $w == -1"); | |
661 | is(-1 >> $w + 1, -1, "IV -1 right shift $w + 1 == -1"); | |
662 | } | |
663 | } |