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