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