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 (@lists, @max);
  58   for my $arg (@_) {
  59    next unless defined $arg;
  60    my $type = ref $arg;
  61    my $list;
  62    if ($type eq 'ARRAY') {
  63     $list = $arg;
  64    } elsif ($type eq '') {
  65     $list = [ 1 .. $arg ];
  66    } else {
  67     die "Invalid argument of type $type";
  68    }
  69    my $max = @$list;
  70    die "Empty list" unless $max;
  71    push @lists, $list;
  72    push @max,   $max;
  73   }
  74
  75   my $len = @_;
  76   bless {
  77    len   => $len,
  78    max   => \@max,
  79    lists => \@lists,
  80    idx   => [ (0) x $len ],
  81   }, $class;
  82  }
  83
  84  sub next {
  85   my $self = shift;
  86
  87   my ($len, $max, $idx) = @$self{qw<len max idx>};
  88
  89   my $i;
  90   ++$idx->[0];
  91   for ($i = 0; $i < $len; ++$i) {
  92    if ($idx->[$i] == $max->[$i]) {
  93     $idx->[$i] = 0;
  94     ++$idx->[$i + 1] unless $i == $len - 1;
  95    } else {
  96     last;
  97    }
  98   }
  99
 100   return $i < $len;
 101  }
 102
 103  sub items {
 104   my $self = shift;
 105
 106   my ($len, $lists, $idx) = @$self{qw<len lists idx>};
 107
 108   return map $lists->[$_]->[$idx->[$_]], 0 .. ($len - 1);
 109  }
 110 }
 111
 112 my $iterator = autovivification::TestIterator->new(
 113  \@prefixes, \@heads, (\@derefs) x $depth,
 114 );
 115 do {
 116  my ($prefix, @elems) = $iterator->items;
 117  my $code = $prefix->(join '', @elems);
 118  my $exp  = ($code =~ /^\s*exists/) ? !1
 119                                     : (($code =~ /=\s*$magic_val/) ? $magic_val
 120                                                                    : undef);
 121  reset_vars();
 122  my ($res, $err) = do {
 123   local $SIG{__WARN__} = sub { die @_ };
 124   local $@;
 125   my $r = eval <<" CODE";
 126   no autovivification;
 127   $code
 128  CODE
 129   ($r, $@)
 130  };
 131  is $err, '',   "$code: no exception";
 132  is $res, $exp, "$code: value";
 133 } while ($iterator->next);