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