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'; | |
624c42e2 N |
9 | require "./test.pl"; |
10 | set_up_inc('../lib'); | |
11 | require "./charset_tools.pl"; | |
784fea9c | 12 | require Config; |
d1f8c7a4 CS |
13 | } |
14 | ||
19a1a075 TK |
15 | use warnings; |
16 | ||
add36b05 NC |
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) | |
640be82a | 21 | plan tests => 510; |
ddb9d9dc | 22 | |
23 | # numerics | |
add36b05 NC |
24 | ok ((0xdead & 0xbeef) == 0x9ead); |
25 | ok ((0xdead | 0xbeef) == 0xfeef); | |
26 | ok ((0xdead ^ 0xbeef) == 0x6042); | |
27 | ok ((~0xdead & 0xbeef) == 0x2042); | |
55497cff | 28 | |
29 | # shifts | |
add36b05 NC |
30 | ok ((257 << 7) == 32896); |
31 | ok ((33023 >> 7) == 257); | |
55497cff | 32 | |
33 | # signed vs. unsigned | |
add36b05 | 34 | ok ((~0 > 0 && do { use integer; ~0 } == -1)); |
d1f8c7a4 | 35 | |
4e82c85b KW |
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 | ||
640be82a TK |
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. | |
46 | is(4 << 2147483648, 0, "4 << 2147483648 yields 0"); | |
47 | is(16 << 4294967295, 0, "16 << 4294967295 yields 0"); | |
48 | is(8 >> 4294967296, 0, "8 >> 4294967296 yields 0"); | |
49 | is(11 << 18446744073709551615, 0, "11 << 18446744073709551615 yields 0"); | |
50 | is(do { use integer; -9 >> 18446744073709551616 }, -1, | |
51 | "-9 >> 18446744073709551616 under 'use integer' yields -1"); | |
52 | is(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". | |
57 | is(do { use integer; -5 >> '-9223372036854775808' }, 0, | |
58 | "-5 >> -9223372036854775808 under 'use integer' yields 0"); | |
59 | ||
d1f8c7a4 CS |
60 | my $bits = 0; |
61 | for (my $i = ~0; $i; $i >>= 1) { ++$bits; } | |
62 | my $cusp = 1 << ($bits - 1); | |
63 | ||
add36b05 NC |
64 | |
65 | ok (($cusp & -1) > 0 && do { use integer; $cusp & -1 } < 0); | |
66 | ok (($cusp | 1) > 0 && do { use integer; $cusp | 1 } < 0); | |
67 | ok (($cusp ^ 1) > 0 && do { use integer; $cusp ^ 1 } < 0); | |
68 | ok ((1 << ($bits - 1)) == $cusp && | |
69 | do { use integer; 1 << ($bits - 1) } == -$cusp); | |
70 | ok (($cusp >> 1) == ($cusp / 2) && | |
71 | do { use integer; abs($cusp >> 1) } == ($cusp / 2)); | |
ddb9d9dc | 72 | |
9d116dd7 JH |
73 | $Aaz = chr(ord("A") & ord("z")); |
74 | $Aoz = chr(ord("A") | ord("z")); | |
75 | $Axz = chr(ord("A") ^ ord("z")); | |
76 | ||
ddb9d9dc | 77 | # short strings |
add36b05 NC |
78 | is (("AAAAA" & "zzzzz"), ($Aaz x 5)); |
79 | is (("AAAAA" | "zzzzz"), ($Aoz x 5)); | |
80 | is (("AAAAA" ^ "zzzzz"), ($Axz x 5)); | |
ddb9d9dc | 81 | |
82 | # long strings | |
83 | $foo = "A" x 150; | |
84 | $bar = "z" x 75; | |
9d116dd7 JH |
85 | $zap = "A" x 75; |
86 | # & truncates | |
add36b05 | 87 | is (($foo & $bar), ($Aaz x 75 )); |
9d116dd7 | 88 | # | does not truncate |
add36b05 | 89 | is (($foo | $bar), ($Aoz x 75 . $zap)); |
9d116dd7 | 90 | # ^ does not truncate |
add36b05 | 91 | is (($foo ^ $bar), ($Axz x 75 . $zap)); |
9d116dd7 | 92 | |
b35338b6 KW |
93 | # string constants. These tests expect the bit patterns of these strings in |
94 | # ASCII, so convert to that. | |
95 | sub _and($) { $_[0] & native_to_uni("+0") } | |
96 | sub _oar($) { $_[0] | native_to_uni("+0") } | |
97 | sub _xor($) { $_[0] ^ native_to_uni("+0") } | |
98 | is _and native_to_uni("waf"), native_to_uni('# '), 'str var & const str'; # [perl #20661] | |
99 | is _and native_to_uni("waf"), native_to_uni('# '), 'str var & const str again'; # [perl #20661] | |
100 | is _oar native_to_uni("yit"), native_to_uni('{yt'), 'str var | const str'; | |
101 | is _oar native_to_uni("yit"), native_to_uni('{yt'), 'str var | const str again'; | |
102 | is _xor native_to_uni("yit"), native_to_uni('RYt'), 'str var ^ const str'; | |
103 | is _xor native_to_uni("yit"), native_to_uni('RYt'), 'str var ^ const str again'; | |
104 | ||
105 | SKIP: { | |
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 | } | |
b20c4ee1 | 112 | |
5ee80e13 FC |
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; | |
117 | is $i, 255, '[perl #108480] $cow |= number'; | |
118 | $i=(keys %h)[0]; | |
119 | $i &= 105; | |
120 | is $i, 0, '[perl #108480] $cow &= number'; | |
121 | $i=(keys %h)[0]; | |
122 | $i ^= 105; | |
123 | is $i, 255, '[perl #108480] $cow ^= number'; | |
124 | ||
0c57e439 | 125 | # |
add36b05 NC |
126 | is ("ok \xFF\xFF\n" & "ok 19\n", "ok 19\n"); |
127 | is ("ok 20\n" | "ok \0\0\n", "ok 20\n"); | |
128 | is ("o\000 \0001\000" ^ "\000k\0002\000\n", "ok 21\n"); | |
0c57e439 GS |
129 | |
130 | # | |
add36b05 NC |
131 | is ("ok \x{FF}\x{FF}\n" & "ok 22\n", "ok 22\n"); |
132 | is ("ok 23\n" | "ok \x{0}\x{0}\n", "ok 23\n"); | |
133 | is ("o\x{0} \x{0}4\x{0}" ^ "\x{0}k\x{0}2\x{0}\n", "ok 24\n"); | |
0c57e439 | 134 | |
299b089d | 135 | # More variations on 19 and 22. |
add36b05 NC |
136 | is ("ok \xFF\x{FF}\n" & "ok 41\n", "ok 41\n"); |
137 | is ("ok \x{FF}\xFF\n" & "ok 42\n", "ok 42\n"); | |
66a74c25 JO |
138 | |
139 | # Tests to see if you really can do casts negative floats to unsigned properly | |
140 | $neg1 = -1.0; | |
add36b05 | 141 | ok (~ $neg1 == 0); |
66a74c25 | 142 | $neg7 = -7.0; |
add36b05 | 143 | ok (~ $neg7 == 6); |
891f9566 | 144 | |
891f9566 YST |
145 | |
146 | # double magic tests | |
147 | ||
148 | sub TIESCALAR { bless { value => $_[1], orig => $_[1] } } | |
149 | sub STORE { $_[0]{store}++; $_[0]{value} = $_[1] } | |
150 | sub FETCH { $_[0]{fetch}++; $_[0]{value} } | |
151 | sub stores { tied($_[0])->{value} = tied($_[0])->{orig}; | |
152 | delete(tied($_[0])->{store}) || 0 } | |
153 | sub fetches { delete(tied($_[0])->{fetch}) || 0 } | |
154 | ||
155 | # numeric double magic tests | |
156 | ||
157 | tie $x, "main", 1; | |
158 | tie $y, "main", 3; | |
159 | ||
160 | is(($x | $y), 3); | |
161 | is(fetches($x), 1); | |
162 | is(fetches($y), 1); | |
163 | is(stores($x), 0); | |
164 | is(stores($y), 0); | |
165 | ||
166 | is(($x & $y), 1); | |
167 | is(fetches($x), 1); | |
168 | is(fetches($y), 1); | |
169 | is(stores($x), 0); | |
170 | is(stores($y), 0); | |
171 | ||
172 | is(($x ^ $y), 2); | |
173 | is(fetches($x), 1); | |
174 | is(fetches($y), 1); | |
175 | is(stores($x), 0); | |
176 | is(stores($y), 0); | |
177 | ||
178 | is(($x |= $y), 3); | |
179 | is(fetches($x), 2); | |
180 | is(fetches($y), 1); | |
181 | is(stores($x), 1); | |
182 | is(stores($y), 0); | |
183 | ||
184 | is(($x &= $y), 1); | |
185 | is(fetches($x), 2); | |
186 | is(fetches($y), 1); | |
187 | is(stores($x), 1); | |
188 | is(stores($y), 0); | |
189 | ||
190 | is(($x ^= $y), 2); | |
191 | is(fetches($x), 2); | |
192 | is(fetches($y), 1); | |
193 | is(stores($x), 1); | |
194 | is(stores($y), 0); | |
195 | ||
196 | is(~~$y, 3); | |
197 | is(fetches($y), 1); | |
198 | is(stores($y), 0); | |
199 | ||
200 | { use integer; | |
201 | ||
202 | is(($x | $y), 3); | |
203 | is(fetches($x), 1); | |
204 | is(fetches($y), 1); | |
205 | is(stores($x), 0); | |
206 | is(stores($y), 0); | |
207 | ||
208 | is(($x & $y), 1); | |
209 | is(fetches($x), 1); | |
210 | is(fetches($y), 1); | |
211 | is(stores($x), 0); | |
212 | is(stores($y), 0); | |
213 | ||
214 | is(($x ^ $y), 2); | |
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), 3); | |
221 | is(fetches($x), 2); | |
222 | is(fetches($y), 1); | |
223 | is(stores($x), 1); | |
224 | is(stores($y), 0); | |
225 | ||
226 | is(($x &= $y), 1); | |
227 | is(fetches($x), 2); | |
228 | is(fetches($y), 1); | |
229 | is(stores($x), 1); | |
230 | is(stores($y), 0); | |
231 | ||
232 | is(($x ^= $y), 2); | |
233 | is(fetches($x), 2); | |
234 | is(fetches($y), 1); | |
235 | is(stores($x), 1); | |
236 | is(stores($y), 0); | |
237 | ||
238 | is(~$y, -4); | |
239 | is(fetches($y), 1); | |
240 | is(stores($y), 0); | |
241 | ||
242 | } # end of use integer; | |
243 | ||
244 | # stringwise double magic tests | |
245 | ||
246 | tie $x, "main", "a"; | |
247 | tie $y, "main", "c"; | |
248 | ||
249 | is(($x | $y), ("a" | "c")); | |
250 | is(fetches($x), 1); | |
251 | is(fetches($y), 1); | |
252 | is(stores($x), 0); | |
253 | is(stores($y), 0); | |
254 | ||
255 | is(($x & $y), ("a" & "c")); | |
256 | is(fetches($x), 1); | |
257 | is(fetches($y), 1); | |
258 | is(stores($x), 0); | |
259 | is(stores($y), 0); | |
260 | ||
261 | is(($x ^ $y), ("a" ^ "c")); | |
262 | is(fetches($x), 1); | |
263 | is(fetches($y), 1); | |
264 | is(stores($x), 0); | |
265 | is(stores($y), 0); | |
266 | ||
267 | is(($x |= $y), ("a" | "c")); | |
268 | is(fetches($x), 2); | |
269 | is(fetches($y), 1); | |
270 | is(stores($x), 1); | |
271 | is(stores($y), 0); | |
272 | ||
273 | is(($x &= $y), ("a" & "c")); | |
274 | is(fetches($x), 2); | |
275 | is(fetches($y), 1); | |
276 | is(stores($x), 1); | |
277 | is(stores($y), 0); | |
278 | ||
279 | is(($x ^= $y), ("a" ^ "c")); | |
280 | is(fetches($x), 2); | |
281 | is(fetches($y), 1); | |
282 | is(stores($x), 1); | |
283 | is(stores($y), 0); | |
284 | ||
285 | is(~~$y, "c"); | |
286 | is(fetches($y), 1); | |
287 | is(stores($y), 0); | |
d0a21e00 | 288 | |
ce400795 TC |
289 | my $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); | |
293 | is($g, (ord("a") & 0x01), "check vec value"); | |
294 | is(fetches($x), 1, "fetches for vec read"); | |
295 | is(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 | |
299 | vec($x, 0, 1) = 0; | |
300 | # one fetch in vec() another when the LV is assigned to | |
301 | is(fetches($x), 2, "fetches for vec write"); | |
302 | is(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 | ||
d0a21e00 GA |
318 | $a = "\0\x{100}"; chop($a); |
319 | ok(utf8::is_utf8($a)); # make sure UTF8 flag is still there | |
320 | $a = ~$a; | |
321 | is($a, "\xFF", "~ works with utf-8"); | |
55951dd7 | 322 | ok(! utf8::is_utf8($a), " and turns off the UTF-8 flag"); |
80ff368f | 323 | |
b08562c6 KW |
324 | $a = "\0\x{100}"; chop($a); |
325 | undef $b; | |
326 | $b = $a | "\xFF"; | |
327 | ok(utf8::is_utf8($b), "Verify UTF-8 | non-UTF-8 retains UTF-8 flag"); | |
328 | undef $b; | |
329 | $b = "\xFF" | $a; | |
330 | ok(utf8::is_utf8($b), "Verify non-UTF-8 | UTF-8 retains UTF-8 flag"); | |
331 | undef $b; | |
332 | $b = $a & "\xFF"; | |
333 | ok(utf8::is_utf8($b), "Verify UTF-8 & non-UTF-8 retains UTF-8 flag"); | |
334 | undef $b; | |
335 | $b = "\xFF" & $a; | |
336 | ok(utf8::is_utf8($b), "Verify non-UTF-8 & UTF-8 retains UTF-8 flag"); | |
337 | undef $b; | |
338 | $b = $a ^ "\xFF"; | |
339 | ok(utf8::is_utf8($b), "Verify UTF-8 ^ non-UTF-8 retains UTF-8 flag"); | |
340 | undef $b; | |
341 | $b = "\xFF" ^ $a; | |
342 | ok(utf8::is_utf8($b), "Verify non-UTF-8 ^ UTF-8 retains UTF-8 flag"); | |
343 | ||
55951dd7 | 344 | |
80ff368f | 345 | # [rt.perl.org 33003] |
784fea9c NC |
346 | # This would cause a segfault without malloc wrap |
347 | SKIP: { | |
348 | skip "No malloc wrap checks" unless $Config::Config{usemallocwrap}; | |
aaa63dae | 349 | like( runperl(prog => 'eval q($#a>>=1); print 1'), qr/^1\n?/ ); |
784fea9c | 350 | } |
1a787b95 TS |
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 | ||
7e99522f KW |
358 | $b = "bb\x{FF}"; |
359 | utf8::upgrade($b); | |
1a787b95 TS |
360 | $b &= "b"; |
361 | ok($b =~ /b+$/, 'Unicode "b" is NUL-terminated'); | |
362 | } | |
794a0d33 | 363 | |
b6e8d7fe FC |
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'; | |
b35338b6 KW |
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 | } | |
b6e8d7fe FC |
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 | } | |
401d2aaa FC |
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 | } | |
b6e8d7fe | 443 | |
8c8eee82 BM |
444 | # ref tests |
445 | ||
446 | my %res; | |
447 | ||
7e99522f KW |
448 | for my $str ("x", "\x{B6}") { |
449 | utf8::upgrade($str) if $str !~ /x/; | |
8c8eee82 BM |
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 | ||
462 | sub PVBM () { "X" } | |
51f0b9cd | 463 | 1 if index "foo", PVBM; |
8c8eee82 BM |
464 | |
465 | my $warn = 0; | |
466 | local $^W = 1; | |
467 | local $SIG{__WARN__} = sub { $warn++ }; | |
468 | ||
469 | sub is_first { | |
470 | my ($got, $orig, $op, $str, $name) = @_; | |
471 | is(substr($got, 0, 1), $res{"$orig$op$str"}, $name); | |
472 | } | |
473 | ||
474 | for ( | |
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 | ||
7e99522f | 489 | for (["x", "string"], ["\x{B6}", "utf8"]) { |
8c8eee82 | 490 | my ($str, $desc) = @$_; |
7e99522f | 491 | utf8::upgrade($str) if $desc =~ /utf8/; |
8c8eee82 BM |
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 | ||
bccb768e FC |
528 | delete $SIG{__WARN__}; |
529 | ||
8c8eee82 BM |
530 | my $strval; |
531 | ||
532 | { | |
533 | package Bar; | |
534 | use overload q/""/ => sub { $strval }; | |
535 | ||
536 | package Baz; | |
537 | use overload q/|/ => sub { "y" }; | |
538 | } | |
539 | ||
51f0b9cd | 540 | ok(!eval { 1 if bless([], "Bar") | "x"; 1 },"string overload can't use |"); |
8c8eee82 BM |
541 | like($@, qr/no method found/, "correct error"); |
542 | is(eval { bless([], "Baz") | "x" }, "y", "| overload works"); | |
543 | ||
544 | my $obj = bless [], "Bar"; | |
545 | $strval = "x"; | |
546 | eval { $obj |= "Q" }; | |
547 | $strval = "z"; | |
548 | is("$obj", "z", "|= doesn't break string overload"); | |
1e6bda93 FC |
549 | |
550 | # [perl #29070] | |
b35338b6 KW |
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")); | |
1e6bda93 | 554 | is $^A, "123", '~v0 clears vstring magic on retval'; |
b3498293 JH |
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"; | |
2183d14b | 586 | no warnings "overflow"; # prevent compile-time warning for ivsize=4 |
b69687e7 JH |
587 | is(-1 << 1, 0xFFFF_FFFF_FFFF_FFFE, |
588 | "neg UV (sic) left shift = 0xFF..E"); | |
589 | is(-1 >> 1, 0x7FFF_FFFF_FFFF_FFFF, | |
a3815e44 | 590 | "neg UV (sic) right shift = 0x7F..F"); |
b3498293 JH |
591 | } elsif ($w == 32) { |
592 | no warnings "portable"; | |
b69687e7 | 593 | is(-1 << 1, 0xFFFF_FFFE, "neg left shift == 0xFF..E"); |
a3815e44 | 594 | is(-1 >> 1, 0x7FFF_FFFF, "neg right shift == 0x7F..F"); |
b3498293 JH |
595 | } |
596 | ||
597 | { | |
598 | # 'use integer' means use IVs instead of UVs. | |
599 | use integer; | |
600 | ||
b69687e7 JH |
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"); | |
b3498293 | 604 | |
b69687e7 JH |
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"); | |
b3498293 | 611 | |
b69687e7 JH |
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"); | |
b3498293 JH |
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 | } | |
b43665ff FC |
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. | |
633 | for (["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 | } | |
638 | is $byte, "\0", "utf8 &. appends null byte"; | |
dc529e65 TC |
639 | |
640 | # only visible under sanitize | |
641 | fresh_perl_is('$x = "UUUUUUUV"; $y = "xxxxxxx"; $x |= $y; print $x', | |
a37fb5d5 KW |
642 | ( $::IS_EBCDIC) ? 'XXXXXXXV' : '}}}}}}}V', |
643 | {}, "[perl #129995] access to freed memory"); | |
5d09ee1c A |
644 | |
645 | ||
646 | # | |
647 | # Using code points above 0xFF is fatal | |
648 | # | |
649 | foreach 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 | } | |
b50535da | 667 | |
ba52ce15 | 668 | { |
c8b94fe0 JK |
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; | |
ba52ce15 KW |
694 | } |
695 | } | |
45f235c1 TC |
696 | |
697 | { | |
698 | # perl #17844 - only visible with valgrind/ASAN | |
699 | fresh_perl_is(<<'EOS', | |
700 | formline X000n^\\0,\\0^\\0for\0,0..10 | |
701 | EOS | |
702 | '', | |
703 | {}, "[perl #17844] access beyond end of block"); | |
704 | } |