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'; |
add36b05 | 10 | require "./test.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) | |
5ee80e13 | 18 | plan tests => 174 + (10*13*2) + 5; |
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 | |
b20c4ee1 FC |
66 | # string constants |
67 | sub _and($) { $_[0] & "+0" } | |
68 | sub _oar($) { $_[0] | "+0" } | |
69 | sub _xor($) { $_[0] ^ "+0" } | |
70 | is _and "waf", '# ', 'str var & const str'; # These three | |
71 | is _and 0, '0', 'num var & const str'; # are from | |
72 | is _and "waf", '# ', 'str var & const str again'; # [perl #20661] | |
73 | is _oar "yit", '{yt', 'str var | const str'; | |
74 | is _oar 0, '0', 'num var | const str'; | |
75 | is _oar "yit", '{yt', 'str var | const str again'; | |
76 | is _xor "yit", 'RYt', 'str var ^ const str'; | |
77 | is _xor 0, '0', 'num var ^ const str'; | |
78 | is _xor "yit", 'RYt', 'str var ^ const str again'; | |
79 | ||
5ee80e13 FC |
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; | |
84 | is $i, 255, '[perl #108480] $cow |= number'; | |
85 | $i=(keys %h)[0]; | |
86 | $i &= 105; | |
87 | is $i, 0, '[perl #108480] $cow &= number'; | |
88 | $i=(keys %h)[0]; | |
89 | $i ^= 105; | |
90 | is $i, 255, '[perl #108480] $cow ^= number'; | |
91 | ||
0c57e439 | 92 | # |
add36b05 NC |
93 | is ("ok \xFF\xFF\n" & "ok 19\n", "ok 19\n"); |
94 | is ("ok 20\n" | "ok \0\0\n", "ok 20\n"); | |
95 | is ("o\000 \0001\000" ^ "\000k\0002\000\n", "ok 21\n"); | |
0c57e439 GS |
96 | |
97 | # | |
add36b05 NC |
98 | is ("ok \x{FF}\x{FF}\n" & "ok 22\n", "ok 22\n"); |
99 | is ("ok 23\n" | "ok \x{0}\x{0}\n", "ok 23\n"); | |
100 | is ("o\x{0} \x{0}4\x{0}" ^ "\x{0}k\x{0}2\x{0}\n", "ok 24\n"); | |
0c57e439 GS |
101 | |
102 | # | |
add36b05 NC |
103 | is (sprintf("%vd", v4095 & v801), 801); |
104 | is (sprintf("%vd", v4095 | v801), 4095); | |
105 | is (sprintf("%vd", v4095 ^ v801), 3294); | |
0c57e439 GS |
106 | |
107 | # | |
add36b05 NC |
108 | is (sprintf("%vd", v4095.801.4095 & v801.4095), '801.801'); |
109 | is (sprintf("%vd", v4095.801.4095 | v801.4095), '4095.4095.4095'); | |
110 | is (sprintf("%vd", v801.4095 ^ v4095.801.4095), '3294.3294.4095'); | |
2a4ebaa6 | 111 | # |
add36b05 NC |
112 | is (sprintf("%vd", v120.300 & v200.400), '72.256'); |
113 | is (sprintf("%vd", v120.300 | v200.400), '248.444'); | |
114 | is (sprintf("%vd", v120.300 ^ v200.400), '176.188'); | |
2a4ebaa6 JH |
115 | # |
116 | my $a = v120.300; | |
117 | my $b = v200.400; | |
118 | $a ^= $b; | |
add36b05 | 119 | is (sprintf("%vd", $a), '176.188'); |
2a4ebaa6 JH |
120 | my $a = v120.300; |
121 | my $b = v200.400; | |
122 | $a |= $b; | |
add36b05 | 123 | is (sprintf("%vd", $a), '248.444'); |
3da1940a | 124 | |
1d68d6cd SC |
125 | # |
126 | # UTF8 ~ behaviour | |
3da1940a JH |
127 | # |
128 | ||
210db7fc PP |
129 | my $Is_EBCDIC = (ord('A') == 193) ? 1 : 0; |
130 | ||
3da1940a JH |
131 | my @not36; |
132 | ||
f0da931d | 133 | for (0x100...0xFFF) { |
1d68d6cd | 134 | $a = ~(chr $_); |
210db7fc PP |
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 | } | |
3da1940a | 143 | } |
add36b05 | 144 | is (join (', ', @not36), ''); |
1d68d6cd | 145 | |
3da1940a JH |
146 | my @not37; |
147 | ||
1d68d6cd SC |
148 | for my $i (0xEEE...0xF00) { |
149 | for my $j (0x0..0x120) { | |
150 | $a = ~(chr ($i) . chr $j); | |
210db7fc PP |
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 | } | |
1d68d6cd SC |
162 | } |
163 | } | |
add36b05 NC |
164 | is (join (', ', @not37), ''); |
165 | ||
166 | SKIP: { | |
167 | skip "EBCDIC" if $Is_EBCDIC; | |
168 | is (~chr(~0), "\0"); | |
3da1940a | 169 | } |
f0da931d | 170 | |
a1ca4561 YST |
171 | |
172 | my @not39; | |
173 | ||
174 | for 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 | } | |
add36b05 | 180 | is (join (', ', @not39), ''); |
a1ca4561 YST |
181 | |
182 | my @not40; | |
183 | ||
184 | for 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 | } | |
add36b05 NC |
190 | is (join (', ', @not40), ''); |
191 | ||
299b089d JH |
192 | |
193 | # More variations on 19 and 22. | |
add36b05 NC |
194 | is ("ok \xFF\x{FF}\n" & "ok 41\n", "ok 41\n"); |
195 | is ("ok \x{FF}\xFF\n" & "ok 42\n", "ok 42\n"); | |
66a74c25 JO |
196 | |
197 | # Tests to see if you really can do casts negative floats to unsigned properly | |
198 | $neg1 = -1.0; | |
add36b05 | 199 | ok (~ $neg1 == 0); |
66a74c25 | 200 | $neg7 = -7.0; |
add36b05 | 201 | ok (~ $neg7 == 6); |
891f9566 | 202 | |
891f9566 YST |
203 | |
204 | # double magic tests | |
205 | ||
206 | sub TIESCALAR { bless { value => $_[1], orig => $_[1] } } | |
207 | sub STORE { $_[0]{store}++; $_[0]{value} = $_[1] } | |
208 | sub FETCH { $_[0]{fetch}++; $_[0]{value} } | |
209 | sub stores { tied($_[0])->{value} = tied($_[0])->{orig}; | |
210 | delete(tied($_[0])->{store}) || 0 } | |
211 | sub fetches { delete(tied($_[0])->{fetch}) || 0 } | |
212 | ||
213 | # numeric double magic tests | |
214 | ||
215 | tie $x, "main", 1; | |
216 | tie $y, "main", 3; | |
217 | ||
218 | is(($x | $y), 3); | |
219 | is(fetches($x), 1); | |
220 | is(fetches($y), 1); | |
221 | is(stores($x), 0); | |
222 | is(stores($y), 0); | |
223 | ||
224 | is(($x & $y), 1); | |
225 | is(fetches($x), 1); | |
226 | is(fetches($y), 1); | |
227 | is(stores($x), 0); | |
228 | is(stores($y), 0); | |
229 | ||
230 | is(($x ^ $y), 2); | |
231 | is(fetches($x), 1); | |
232 | is(fetches($y), 1); | |
233 | is(stores($x), 0); | |
234 | is(stores($y), 0); | |
235 | ||
236 | is(($x |= $y), 3); | |
237 | is(fetches($x), 2); | |
238 | is(fetches($y), 1); | |
239 | is(stores($x), 1); | |
240 | is(stores($y), 0); | |
241 | ||
242 | is(($x &= $y), 1); | |
243 | is(fetches($x), 2); | |
244 | is(fetches($y), 1); | |
245 | is(stores($x), 1); | |
246 | is(stores($y), 0); | |
247 | ||
248 | is(($x ^= $y), 2); | |
249 | is(fetches($x), 2); | |
250 | is(fetches($y), 1); | |
251 | is(stores($x), 1); | |
252 | is(stores($y), 0); | |
253 | ||
254 | is(~~$y, 3); | |
255 | is(fetches($y), 1); | |
256 | is(stores($y), 0); | |
257 | ||
258 | { use integer; | |
259 | ||
260 | is(($x | $y), 3); | |
261 | is(fetches($x), 1); | |
262 | is(fetches($y), 1); | |
263 | is(stores($x), 0); | |
264 | is(stores($y), 0); | |
265 | ||
266 | is(($x & $y), 1); | |
267 | is(fetches($x), 1); | |
268 | is(fetches($y), 1); | |
269 | is(stores($x), 0); | |
270 | is(stores($y), 0); | |
271 | ||
272 | is(($x ^ $y), 2); | |
273 | is(fetches($x), 1); | |
274 | is(fetches($y), 1); | |
275 | is(stores($x), 0); | |
276 | is(stores($y), 0); | |
277 | ||
278 | is(($x |= $y), 3); | |
279 | is(fetches($x), 2); | |
280 | is(fetches($y), 1); | |
281 | is(stores($x), 1); | |
282 | is(stores($y), 0); | |
283 | ||
284 | is(($x &= $y), 1); | |
285 | is(fetches($x), 2); | |
286 | is(fetches($y), 1); | |
287 | is(stores($x), 1); | |
288 | is(stores($y), 0); | |
289 | ||
290 | is(($x ^= $y), 2); | |
291 | is(fetches($x), 2); | |
292 | is(fetches($y), 1); | |
293 | is(stores($x), 1); | |
294 | is(stores($y), 0); | |
295 | ||
296 | is(~$y, -4); | |
297 | is(fetches($y), 1); | |
298 | is(stores($y), 0); | |
299 | ||
300 | } # end of use integer; | |
301 | ||
302 | # stringwise double magic tests | |
303 | ||
304 | tie $x, "main", "a"; | |
305 | tie $y, "main", "c"; | |
306 | ||
307 | is(($x | $y), ("a" | "c")); | |
308 | is(fetches($x), 1); | |
309 | is(fetches($y), 1); | |
310 | is(stores($x), 0); | |
311 | is(stores($y), 0); | |
312 | ||
313 | is(($x & $y), ("a" & "c")); | |
314 | is(fetches($x), 1); | |
315 | is(fetches($y), 1); | |
316 | is(stores($x), 0); | |
317 | is(stores($y), 0); | |
318 | ||
319 | is(($x ^ $y), ("a" ^ "c")); | |
320 | is(fetches($x), 1); | |
321 | is(fetches($y), 1); | |
322 | is(stores($x), 0); | |
323 | is(stores($y), 0); | |
324 | ||
325 | is(($x |= $y), ("a" | "c")); | |
326 | is(fetches($x), 2); | |
327 | is(fetches($y), 1); | |
328 | is(stores($x), 1); | |
329 | is(stores($y), 0); | |
330 | ||
331 | is(($x &= $y), ("a" & "c")); | |
332 | is(fetches($x), 2); | |
333 | is(fetches($y), 1); | |
334 | is(stores($x), 1); | |
335 | is(stores($y), 0); | |
336 | ||
337 | is(($x ^= $y), ("a" ^ "c")); | |
338 | is(fetches($x), 2); | |
339 | is(fetches($y), 1); | |
340 | is(stores($x), 1); | |
341 | is(stores($y), 0); | |
342 | ||
343 | is(~~$y, "c"); | |
344 | is(fetches($y), 1); | |
345 | is(stores($y), 0); | |
d0a21e00 GA |
346 | |
347 | $a = "\0\x{100}"; chop($a); | |
348 | ok(utf8::is_utf8($a)); # make sure UTF8 flag is still there | |
349 | $a = ~$a; | |
350 | is($a, "\xFF", "~ works with utf-8"); | |
80ff368f RGS |
351 | |
352 | # [rt.perl.org 33003] | |
784fea9c NC |
353 | # This would cause a segfault without malloc wrap |
354 | SKIP: { | |
355 | skip "No malloc wrap checks" unless $Config::Config{usemallocwrap}; | |
356 | like( runperl(prog => 'eval q($#a>>=1); print 1'), "^1\n?" ); | |
357 | } | |
1a787b95 TS |
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 | } | |
794a0d33 JH |
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 | ||
74d49cd0 TS |
441 | # update to pp_complement() via Coverity |
442 | SKIP: { | |
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); | |
4b8811a5 DM |
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"); | |
74d49cd0 | 466 | } |
8c8eee82 BM |
467 | |
468 | # ref tests | |
469 | ||
470 | my %res; | |
471 | ||
472 | for 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 | ||
485 | sub PVBM () { "X" } | |
44250bdc | 486 | index "foo", PVBM; |
8c8eee82 BM |
487 | |
488 | my $warn = 0; | |
489 | local $^W = 1; | |
490 | local $SIG{__WARN__} = sub { $warn++ }; | |
491 | ||
492 | sub is_first { | |
493 | my ($got, $orig, $op, $str, $name) = @_; | |
494 | is(substr($got, 0, 1), $res{"$orig$op$str"}, $name); | |
495 | } | |
496 | ||
497 | for ( | |
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 | ||
550 | my $strval; | |
551 | ||
552 | { | |
553 | package Bar; | |
554 | use overload q/""/ => sub { $strval }; | |
555 | ||
556 | package Baz; | |
557 | use overload q/|/ => sub { "y" }; | |
558 | } | |
559 | ||
560 | ok(!eval { bless([], "Bar") | "x"; 1 }, "string overload can't use |"); | |
561 | like($@, qr/no method found/, "correct error"); | |
562 | is(eval { bless([], "Baz") | "x" }, "y", "| overload works"); | |
563 | ||
564 | my $obj = bless [], "Bar"; | |
565 | $strval = "x"; | |
566 | eval { $obj |= "Q" }; | |
567 | $strval = "z"; | |
568 | is("$obj", "z", "|= doesn't break string overload"); | |
1e6bda93 FC |
569 | |
570 | # [perl #29070] | |
571 | $^A .= new version ~$_ for "\xce", v205, "\xcc"; | |
572 | is $^A, "123", '~v0 clears vstring magic on retval'; |