This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[perl #29070] Add vstring set-magic
[perl5.git] / t / op / bop.t
1 #!./perl
2
3 #
4 # test the bit operators '&', '|', '^', '~', '<<', and '>>'
5 #
6
7 BEGIN {
8     chdir 't' if -d 't';
9     @INC = '../lib';
10     require "./test.pl";
11     require Config;
12 }
13
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)
18 plan tests => 171 + (10*13*2) + 5;
19
20 # numerics
21 ok ((0xdead & 0xbeef) == 0x9ead);
22 ok ((0xdead | 0xbeef) == 0xfeef);
23 ok ((0xdead ^ 0xbeef) == 0x6042);
24 ok ((~0xdead & 0xbeef) == 0x2042);
25
26 # shifts
27 ok ((257 << 7) == 32896);
28 ok ((33023 >> 7) == 257);
29
30 # signed vs. unsigned
31 ok ((~0 > 0 && do { use integer; ~0 } == -1));
32
33 my $bits = 0;
34 for (my $i = ~0; $i; $i >>= 1) { ++$bits; }
35 my $cusp = 1 << ($bits - 1);
36
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));
45
46 $Aaz = chr(ord("A") & ord("z"));
47 $Aoz = chr(ord("A") | ord("z"));
48 $Axz = chr(ord("A") ^ ord("z"));
49
50 # short strings
51 is (("AAAAA" & "zzzzz"), ($Aaz x 5));
52 is (("AAAAA" | "zzzzz"), ($Aoz x 5));
53 is (("AAAAA" ^ "zzzzz"), ($Axz x 5));
54
55 # long strings
56 $foo = "A" x 150;
57 $bar = "z" x 75;
58 $zap = "A" x 75;
59 # & truncates
60 is (($foo & $bar), ($Aaz x 75 ));
61 # | does not truncate
62 is (($foo | $bar), ($Aoz x 75 . $zap));
63 # ^ does not truncate
64 is (($foo ^ $bar), ($Axz x 75 . $zap));
65
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
80 #
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");
84
85 #
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");
89
90 #
91 is (sprintf("%vd", v4095 & v801), 801);
92 is (sprintf("%vd", v4095 | v801), 4095);
93 is (sprintf("%vd", v4095 ^ v801), 3294);
94
95 #
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');
99 #
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');
103 #
104 my $a = v120.300;
105 my $b = v200.400;
106 $a ^= $b;
107 is (sprintf("%vd", $a), '176.188');
108 my $a = v120.300;
109 my $b = v200.400;
110 $a |= $b;
111 is (sprintf("%vd", $a), '248.444');
112
113 #
114 # UTF8 ~ behaviour
115 #
116
117 my $Is_EBCDIC = (ord('A') == 193) ? 1 : 0;
118
119 my @not36;
120
121 for (0x100...0xFFF) {
122   $a = ~(chr $_);
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   }
131 }
132 is (join (', ', @not36), '');
133
134 my @not37;
135
136 for my $i (0xEEE...0xF00) {
137   for my $j (0x0..0x120) {
138     $a = ~(chr ($i) . chr $j);
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     }
150   }
151 }
152 is (join (', ', @not37), '');
153
154 SKIP: {
155   skip "EBCDIC" if $Is_EBCDIC;
156   is (~chr(~0), "\0");
157 }
158
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 }
168 is (join (', ', @not39), '');
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 }
178 is (join (', ', @not40), '');
179
180
181 # More variations on 19 and 22.
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");
184
185 # Tests to see if you really can do casts negative floats to unsigned properly
186 $neg1 = -1.0;
187 ok (~ $neg1 == 0);
188 $neg7 = -7.0;
189 ok (~ $neg7 == 6);
190
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);
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");
339
340 # [rt.perl.org 33003]
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 }
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 }
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
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);
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");
454 }
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" }
474 index "foo", PVBM;
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");
557
558 # [perl #29070]
559 $^A .= new version ~$_ for "\xce", v205, "\xcc";
560 is $^A, "123", '~v0 clears vstring magic on retval';