t/44-multideref.t

   1 #!perl -T
   2
   3 use strict;
   4 use warnings;
   5
   6 use lib 't/lib';
   7 use Test::Leaner tests => 4 * 4 * (8 ** 3) * 2;
   8
   9 my $depth = 3;
  10
  11 my $magic_val = 123;
  12
  13 my @prefixes = (
  14  sub { $_[0]                },
  15  sub { "$_[0] = $magic_val" },
  16  sub { "exists $_[0]"       },
  17  sub { "delete $_[0]"       },
  18 );
  19
  20 my  (@vlex, %vlex, $vrlex);
  21 our (@vgbl, %vgbl, $vrgbl);
  22
  23 my @heads = (
  24  '$vlex',    # lexical array/hash
  25  '$vgbl',    # global array/hash
  26  '$vrlex->', # lexical array/hash reference
  27  '$vrgbl->', # global array/hash reference
  28 );
  29
  30 my  $lex;
  31 our $gbl;
  32
  33 my @derefs = (
  34  '[0]',      # array const (aelemfast)
  35  '[$lex]',   # array lexical
  36  '[$gbl]',   # array global
  37  '[$lex+1]', # array complex
  38  '{foo}',    # hash const
  39  '{$lex}',   # hash lexical
  40  '{$gbl}',   # hash global
  41  '{"x$lex"}' # hash complex
  42 );
  43
  44 sub reset_vars {
  45  (@vlex, %vlex, $vrlex) = ();
  46  (@vgbl, %vgbl, $vrgbl) = ();
  47  $lex = 1;
  48  $gbl = 2;
  49 }
  50
  51 {
  52  package autovivification::TestIterator;
  53
  54  sub new {
  55   my $class = shift;
  56
  57   my $len = @_;
  58   bless {
  59    len => $len,
  60    max => \@_,
  61    idx => [ (0) x $len ],
  62   }, $class;
  63  }
  64
  65  sub next {
  66   my $self = shift;
  67
  68   my ($len, $max, $idx) = @$self{qw<len max idx>};
  69
  70   my $i;
  71   ++$idx->[0];
  72   for ($i = 0; $i < $len; ++$i) {
  73    if ($idx->[$i] == $max->[$i]) {
  74     $idx->[$i] = 0;
  75     ++$idx->[$i + 1] unless $i == $len - 1;
  76    } else {
  77     last;
  78    }
  79   }
  80
  81   return $i < $len;
  82  }
  83
  84  sub pick {
  85   my $self = shift;
  86
  87   my ($len, $idx) = @$self{qw<len idx>};
  88
  89   return map $_[$_]->[$idx->[$_]], 0 .. ($len - 1);
  90  }
  91 }
  92
  93 my $iterator = autovivification::TestIterator->new(4, 4, (8) x $depth);
  94 do {
  95  my ($prefix, @elems)
  96                     = $iterator->pick(\@prefixes, \@heads, (\@derefs) x $depth);
  97  my $code = $prefix->(join '', @elems);
  98  my $exp  = ($code =~ /^\s*exists/) ? !1
  99                                     : (($code =~ /=\s*$magic_val/) ? $magic_val
 100                                                                    : undef);
 101  reset_vars();
 102  my ($res, $err) = do {
 103   local $SIG{__WARN__} = sub { die @_ };
 104   local $@;
 105   my $r = eval <<" CODE";
 106   no autovivification;
 107   $code
 108  CODE
 109   ($r, $@)
 110  };
 111  is $err, '',   "$code: no exception";
 112  is $res, $exp, "$code: value";
 113 } while ($iterator->next);