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