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