t/op/multideref.t

   1 #!./perl
   2 #
   3 # test OP_MULTIDEREF.
   4 #
   5 # This optimising op is used when one or more array or hash aggregate
   6 # lookups / derefs are performed, and where each key/index is a simple
   7 # constant or scalar var; e.g.
   8 #
   9 #       $r->{foo}[0]{$k}[$i]
  10
  11
  12 BEGIN {
  13     chdir 't';
  14     require './test.pl';
  15     set_up_inc("../lib");
  16 }
  17
  18 use warnings;
  19 use strict;
  20
  21 plan 58;
  22
  23
  24 # check that strict refs hint is handled
  25
  26 {
  27     package strict_refs;
  28
  29     our %foo;
  30     my @a = ('foo');
  31     eval {
  32         $a[0]{k} = 7;
  33     };
  34     ::like($@, qr/Can't use string/, "strict refs");
  35     ::ok(!exists $foo{k}, "strict refs, not exist");
  36
  37     no strict 'refs';
  38
  39     $a[0]{k} = 13;
  40     ::is($foo{k}, 13, "no strict refs, exist");
  41 }
  42
  43 # check the basics of multilevel lookups
  44
  45 {
  46     package basic;
  47
  48     # build up the multi-level structure piecemeal to try and avoid
  49     # relying on what we're testing
  50
  51     my @a;
  52     my $r = \@a;
  53     my $rh = {};
  54     my $ra = [];
  55     my %h = qw(a 1 b 2 c 3 d 4 e 5 f 6);
  56     push @a, 66, 77, 'abc', $rh;
  57     %$rh = (foo => $ra, bar => 'BAR');
  58     push @$ra, 'def', \%h;
  59
  60     our ($i1, $i2,  $k1,  $k2)  = (3, 1, 'foo', 'c');
  61     my ($li1, $li2, $lk1, $lk2) = (3, 1, 'foo', 'c');
  62     my $z = 0;
  63
  64     # fetch
  65
  66     ::is($a[3]{foo}[1]{c}, 3,             'fetch: const indices');
  67     ::is($a[$i1]{$k1}[$i2]{$k2}, 3,       'fetch: pkg indices');
  68     ::is($r->[$i1]{$k1}[$i2]{$k2}, 3,     'fetch: deref pkg indices');
  69     ::is($a[$li1]{$lk1}[$li2]{$lk2}, 3,   'fetch: lexical indices');
  70     ::is($r->[$li1]{$lk1}[$li2]{$lk2}, 3, 'fetch: deref lexical indices');
  71     ::is(($r//0)->[$li1]{$lk1}[$li2+$z]{$lk2}, 3,
  72                             'fetch: general expression and index');
  73
  74
  75     # store
  76
  77     ::is($a[3]{foo}[1]{c} = 5, 5,             'store: const indices');
  78     ::is($a[3]{foo}[1]{c}, 5,                 'store: const indices 2');
  79     ::is($a[$i1]{$k1}[$i2]{$k2} = 7, 7,       'store: pkg indices');
  80     ::is($a[$i1]{$k1}[$i2]{$k2}, 7,           'store: pkg indices 2');
  81     ::is($r->[$i1]{$k1}[$i2]{$k2} = 9, 9,     'store: deref pkg indices');
  82     ::is($r->[$i1]{$k1}[$i2]{$k2}, 9,         'store: deref pkg indices 2');
  83     ::is($a[$li1]{$lk1}[$li2]{$lk2} = 11, 11, 'store: lexical indices');
  84     ::is($a[$li1]{$lk1}[$li2]{$lk2}, 11,      'store: lexical indices 2');
  85     ::is($r->[$li1]{$lk1}[$li2]{$lk2} = 13, 13, 'store: deref lexical indices');
  86     ::is($r->[$li1]{$lk1}[$li2]{$lk2}, 13,    'store: deref lexical indices 2');
  87     ::is(($r//0)->[$li1]{$lk1}[$li2+$z]{$lk2} = 15, 15,
  88                             'store: general expression and index');
  89     ::is(($r//0)->[$li1]{$lk1}[$li2+$z]{$lk2}, 15,
  90                             'store: general expression and index 2');
  91
  92
  93     # local
  94
  95     {
  96         ::is(local $a[3]{foo}[1]{c} = 19, 19,     'local const indices');
  97         ::is($a[3]{foo}[1]{c}, 19,                'local const indices 2');
  98     }
  99     ::is($a[3]{foo}[1]{c}, 15,          'local const indices 3');
 100     {
 101         ::is(local $a[$i1]{$k1}[$i2]{$k2} = 21, 21,     'local pkg indices');
 102         ::is($a[$i1]{$k1}[$i2]{$k2}, 21,          'local pkg indices 2');
 103     }
 104     ::is($a[$i1]{$k1}[$i2]{$k2}, 15,     'local pkg indices 3');
 105     {
 106         ::is(local $a[$li1]{$lk1}[$li2]{$lk2} = 23, 23, 'local lexical indices');
 107         ::is($a[$li1]{$lk1}[$li2]{$lk2}, 23,      'local lexical indices 2');
 108     }
 109     ::is($a[$li1]{$lk1}[$li2]{$lk2}, 15, 'local lexical indices 3');
 110     {
 111         ::is(local+($r//0)->[$li1]{$lk1}[$li2+$z]{$lk2} = 25, 25,
 112                                                             'local general');
 113         ::is(($r//0)->[$li1]{$lk1}[$li2+$z]{$lk2}, 25,      'local general 2');
 114     }
 115     ::is(($r//0)->[$li1]{$lk1}[$li2+$z]{$lk2}, 15, 'local general 3');
 116
 117
 118     # exists
 119
 120     ::ok(exists $a[3]{foo}[1]{c},           'exists: const indices');
 121     ::ok(exists $a[$i1]{$k1}[$i2]{$k2},     'exists: pkg indices');
 122     ::ok(exists $r->[$i1]{$k1}[$i2]{$k2},   'exists: deref pkg indices');
 123     ::ok(exists $a[$li1]{$lk1}[$li2]{$lk2}, 'exists: lexical indices');
 124     ::ok(exists $r->[$li1]{$lk1}[$li2]{$lk2}, 'exists: deref lexical indices');
 125     ::ok(exists +($r//0)->[$li1]{$lk1}[$li2+$z]{$lk2}, 'exists: general');
 126
 127     # delete
 128
 129     our $k3 = 'a';
 130     my $lk4 = 'b';
 131     ::is(delete $a[3]{foo}[1]{c}, 15,          'delete: const indices');
 132     ::is(delete $a[$i1]{$k1}[$i2]{$k3}, 1,     'delete: pkg indices');
 133     ::is(delete $r->[$i1]{$k1}[$i2]{d}, 4,     'delete: deref pkg indices');
 134     ::is(delete $a[$li1]{$lk1}[$li2]{$lk4}, 2, 'delete: lexical indices');
 135     ::is(delete $r->[$li1]{$lk1}[$li2]{e}, 5,  'delete: deref lexical indices');
 136     ::is(delete +($r//0)->[$li1]{$lk1}[$li2+$z]{f}, 6,  'delete: general');
 137
 138     # !exists
 139
 140     ::ok(!exists $a[3]{foo}[1]{c},            '!exists: const indices');
 141     ::ok(!exists $a[$i1]{$k1}[$i2]{$k3},      '!exists: pkg indices');
 142     ::ok(!exists $r->[$i1]{$k1}[$i2]{$k3},    '!exists: deref pkg indices');
 143     ::ok(!exists $a[$li1]{$lk1}[$li2]{$lk4},  '!exists: lexical indices');
 144     ::ok(!exists $r->[$li1]{$lk1}[$li2]{$lk4},'!exists: deref lexical indices');
 145     ::ok(!exists +($r//0)->[$li1]{$lk1}[$li2+$z]{$lk4},'!exists: general');
 146 }
 147
 148
 149 # weird "constant" keys
 150
 151 {
 152     use constant my_undef => undef;
 153     use constant my_ref   => [];
 154     no warnings 'uninitialized';
 155     my %h1;
 156     $h1{+my_undef} = 1;
 157     is(join(':', keys %h1), '', "+my_undef");
 158     my %h2;
 159     $h2{+my_ref} = 1;
 160     like(join(':', keys %h2), qr/x/, "+my_ref");
 161 }
 162
 163
 164
 165 {
 166     # test that multideref is marked OA_DANGEROUS, i.e. its one of the ops
 167     # that should set the OPpASSIGN_COMMON flag in list assignments
 168
 169     my $x = {};
 170     $x->{a} = [ 1 ];
 171     $x->{b} = [ 2 ];
 172     ($x->{a}, $x->{b}) = ($x->{b}, $x->{a});
 173     is($x->{a}[0], 2, "OA_DANGEROUS a");
 174     is($x->{b}[0], 1, "OA_DANGEROUS b");
 175 }
 176
 177 # defer
 178
 179
 180 sub defer {}
 181
 182 {
 183     my %h;
 184     $h{foo} = {};
 185     defer($h{foo}{bar});
 186     ok(!exists $h{foo}{bar}, "defer");
 187 }
 188
 189 # RT #123609
 190 # don't evaluate a const array index unless it's really a const array
 191 # index
 192
 193 {
 194     my $warn = '';
 195     local $SIG{__WARN__} = sub { $warn .= $_[0] };
 196     ok(
 197         eval q{
 198             my @a = (1);
 199             my $arg = 0;
 200             my $x = $a[ 'foo' eq $arg ? 1 : 0 ];
 201             1;
 202         },
 203         "#123609: eval"
 204     )
 205         or diag("eval gave: $@");
 206     is($warn, "", "#123609: warn");
 207 }