t/op/vec.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     require './test.pl';
   6     set_up_inc('../lib');
   7 }
   8
   9 use warnings;
  10 use strict;
  11 use Config;
  12
  13 plan(tests => 78);
  14
  15 my $exception_134139 = "Use of strings with code points over 0xFF as arguments to vec is forbidden";
  16
  17 my $foo;
  18 is(vec($foo,0,1), 0);
  19 is(length($foo), undef);
  20 vec($foo,0,1) = 1;
  21 is(length($foo), 1);
  22 is(unpack('C',$foo), 1);
  23 is(vec($foo,0,1), 1);
  24
  25 is(vec($foo,20,1), 0);
  26 vec($foo,20,1) = 1;
  27 is(vec($foo,20,1), 1);
  28 is(length($foo), 3);
  29 is(vec($foo,1,8), 0);
  30 vec($foo,1,8) = 0xf1;
  31 is(vec($foo,1,8), 0xf1);
  32 is((unpack('C',substr($foo,1,1)) & 255), 0xf1);
  33 is(vec($foo,2,4), 1);;
  34 is(vec($foo,3,4), 15);
  35
  36 my $Vec;
  37 vec($Vec, 0, 32) = 0xbaddacab;
  38 is($Vec, "\xba\xdd\xac\xab");
  39 is(vec($Vec, 0, 32), 3135089835);
  40
  41 # ensure vec() handles numericalness correctly
  42 my ($bar, $baz);
  43 $foo = $bar = $baz = 0;
  44 vec($foo = 0,0,1) = 1;
  45 vec($bar = 0,1,1) = 1;
  46 $baz = $foo | $bar;
  47 ok($foo eq "1" && $foo == 1);
  48 ok($bar eq "2" && $bar == 2);
  49 ok("$foo $bar $baz" eq "1 2 3");
  50
  51 # error cases
  52
  53 my $x = eval { vec $foo, 0, 3 };
  54 like($@, qr/^Illegal number of bits in vec/);
  55 $@ = undef;
  56 $x = eval { vec $foo, 0, 0 };
  57 like($@, qr/^Illegal number of bits in vec/);
  58 $@ = undef;
  59 $x = eval { vec $foo, 0, -13 };
  60 like($@, qr/^Illegal number of bits in vec/);
  61 $@ = undef;
  62 $x = eval { vec($foo, -1, 4) = 2 };
  63 like($@, qr/^Negative offset to vec in lvalue context/);
  64 $@ = undef;
  65 ok(! vec('abcd', 7, 8));
  66
  67 # UTF8
  68 # N.B. currently curiously coded to circumvent bugs elswhere in UTF8 handling
  69
  70 $foo = "\x{100}" . "\xff\xfe";
  71 $x = substr $foo, 1;
  72 is(vec($x, 0, 8), 255);
  73 $@ = undef;
  74 {
  75     local $@;
  76     eval { my $foo = vec($foo, 1, 8) };
  77     like($@, qr/$exception_134139/,
  78         "Caught exception: code point over 0xFF used as argument to vec");
  79     $@ = undef;
  80     eval { vec($foo, 1, 8) = 13 };
  81     like($@, qr/$exception_134139/,
  82         "Caught exception: code point over 0xFF used as argument to vec");
  83 }
  84 $foo = "\x{100}" . "\xff\xfe";
  85 $x = substr $foo, 1;
  86 vec($x, 2, 4) = 7;
  87 is($x, "\xff\xf7");
  88
  89 # mixed magic
  90
  91 $foo = "\x61\x62\x63\x64\x65\x66";
  92 is(vec(substr($foo, 2, 2), 0, 16), 25444);
  93 vec(substr($foo, 1,3), 5, 4) = 3;
  94 is($foo, "\x61\x62\x63\x34\x65\x66");
  95
  96 # A variation of [perl #20933]
  97 {
  98     my $s = "";
  99     vec($s, 0, 1) = 0;
 100     vec($s, 1, 1) = 1;
 101     my @r;
 102     $r[$_] = \ vec $s, $_, 1 for (0, 1);
 103     ok(!(${ $r[0] } != 0 || ${ $r[1] } != 1));
 104 }
 105
 106
 107 my $destroyed;
 108 { package Class; DESTROY { ++$destroyed; } }
 109
 110 $destroyed = 0;
 111 {
 112     my $x = '';
 113     vec($x,0,1) = 0;
 114     $x = bless({}, 'Class');
 115 }
 116 is($destroyed, 1, 'Timely scalar destruction with lvalue vec');
 117
 118 use constant roref => \1;
 119 eval { for (roref) { vec($_,0,1) = 1 } };
 120 like($@, qr/^Modification of a read-only value attempted at /,
 121         'err msg when modifying read-only refs');
 122
 123
 124 {
 125     # downgradeable utf8 strings should be downgraded before accessing
 126     # the byte string.
 127     # See the p5p thread with Message-ID:
 128     # <CAMx+QJ6SAv05nmpnc7bmp0Wo+sjcx=ssxCcE-P_PZ8HDuCQd9A@mail.gmail.com>
 129
 130
 131     my $x = substr "\x{100}\xff\xfe", 1; # a utf8 string with all ords < 256
 132     my $v;
 133     $v = vec($x, 0, 8);
 134     is($v, 255, "downgraded utf8 try 1");
 135     $v = vec($x, 0, 8);
 136     is($v, 255, "downgraded utf8 try 2");
 137 }
 138
 139 # [perl #128260] assertion failure with \vec %h, \vec @h
 140 {
 141     my %h = 1..100;
 142     my @a = 1..100;
 143     is ${\vec %h, 0, 1}, vec(scalar %h, 0, 1), '\vec %h';
 144     is ${\vec @a, 0, 1}, vec(scalar @a, 0, 1), '\vec @a';
 145 }
 146
 147
 148 # [perl #130915] heap-buffer-overflow in Perl_do_vecget
 149
 150 {
 151     # ensure that out-of-STRLEN-range offsets are handled correctly. This
 152     # partially duplicates some tests above, but those cases are repeated
 153     # here for completeness.
 154     #
 155     # Note that all the 'Out of memory!' errors trapped eval {} are 'fake'
 156     # croaks generated by pp_vec() etc when they have detected something
 157     # that would have otherwise overflowed. The real 'Out of memory!'
 158     # error thrown by safesysrealloc() etc is not trappable. If it were
 159     # accidentally triggered in this test script, the script would exit at
 160     # that point.
 161
 162
 163     my $s = "abcdefghijklmnopqrstuvwxyz";
 164     my $x;
 165
 166     # offset is SvIOK_UV
 167
 168     $x = vec($s, ~0, 8);
 169     is($x, 0, "RT 130915: UV_MAX rval");
 170     eval { vec($s, ~0, 8) = 1 };
 171     like($@, qr/^Out of memory!/, "RT 130915: UV_MAX lval");
 172
 173     # offset is negative
 174
 175     $x = vec($s, -1, 8);
 176     is($x, 0, "RT 130915: -1 rval");
 177     eval { vec($s, -1, 8) = 1 };
 178     like($@, qr/^Negative offset to vec in lvalue context/,
 179                                             "RT 130915: -1 lval");
 180
 181     # offset positive but doesn't fit in a STRLEN
 182
 183     SKIP: {
 184         skip 'IV is no longer than size_t', 2
 185                     if $Config{ivsize} <= $Config{sizesize};
 186
 187         my $size_max = (1 << (8 *$Config{sizesize})) - 1;
 188         my $sm2 = $size_max * 2;
 189
 190         $x = vec($s, $sm2, 8);
 191         is($x, 0, "RT 130915: size_max*2 rval");
 192         eval { vec($s, $sm2, 8) = 1 };
 193         like($@, qr/^Out of memory!/, "RT 130915: size_max*2 lval");
 194     }
 195
 196     # (offset * num-bytes) could overflow
 197
 198     for my $power (1..3) {
 199         my $bytes = (1 << $power);
 200         my $biglog2 = $Config{sizesize} * 8 - $power;
 201         for my $i (0..1) {
 202             no warnings 'portable';
 203             my $offset = (1 << $biglog2) - $i;
 204             $x = vec($s, $offset, $bytes*8);
 205             is($x, 0, "large offset: bytes=$bytes biglog2=$biglog2 i=$i: rval");
 206             eval { vec($s, $offset, $bytes*8) = 1; };
 207             like($@, qr/^Out of memory!/,
 208                       "large offset: bytes=$bytes biglog2=$biglog2 i=$i: rval");
 209         }
 210     }
 211 }
 212
 213 # Test multi-byte gets partially beyond the end of the string.
 214 # It's supposed to pretend there is a stream of \0's following the string.
 215
 216 {
 217     my $s = "\x01\x02\x03\x04\x05\x06\x07";
 218     my $s0 = $s . ("\0" x 8);
 219
 220             no warnings 'portable';
 221     for my $bytes (1, 2, 4, 8) {
 222         for my $offset (0..$bytes) {
 223             if ($Config{ivsize} < $bytes) {
 224                 pass("skipping multi-byte bytes=$bytes offset=$offset");
 225                 next;
 226             }
 227             no warnings 'portable';
 228             is (vec($s,  8 - $offset, $bytes*8),
 229                 vec($s0, 8 - $offset, $bytes*8),
 230                 "multi-byte bytes=$bytes offset=$offset");
 231         }
 232     }
 233 }
 234
 235 # RT #131083 maybe-lvalue out of range should only croak if assigned to
 236
 237 {
 238     sub  RT131083 { if ($_[0]) { $_[1] = 1; } $_[1]; }
 239     my $s = "abc";
 240     my $off = -1;
 241     my $v = RT131083(0, vec($s, $off, 8));
 242     is($v, 0, "RT131083 rval -1");
 243     $v = eval { RT131083(1, vec($s, $off, 8)); };
 244     like($@, qr/Negative offset to vec in lvalue context/, "RT131083 lval -1");
 245
 246     $off = ~0;
 247     $v = RT131083(0, vec($s, $off, 8));
 248     is($v, 0, "RT131083 rval ~0");
 249     $v = eval { RT131083(1, vec($s, $off, 8)); };
 250     like($@, qr/Out of memory!/, "RT131083 lval ~0");
 251 }
 252
 253 {
 254     # Adapting test formerly in t/lib/warnings/doop
 255
 256     local $@;
 257     my $foo = "\x{100}" . "\xff\xfe";
 258     eval { my $bar = vec($foo, 1, 8) };
 259     like($@, qr/$exception_134139/,
 260         "RT 134139: Use of strings with code points over 0xFF as arguments to 'vec' is now forbidden");
 261 }