t/lib/autovivification/TestCases.pm

   1 package autovivification::TestCases;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::Leaner;
   7
   8 sub import {
   9  no strict 'refs';
  10  *{caller().'::testcase_ok'} = \&testcase_ok;
  11 }
  12
  13 sub in_strict { (caller 0)[8] & (eval { strict::bits(@_) } || 0) };
  14
  15 sub do_nothing { }
  16
  17 sub set_arg { $_[0] = 1 }
  18
  19 sub generate {
  20  my ($var, $init, $code, $exp, $use, $opts, $global) = @_;
  21  my $decl = $global ? "our $var; local $var;" : "my $var;";
  22  my $test = $var =~ /^[@%]/ ? "\\$var" : $var;
  23  my $desc = join('; ', map { my $x = $_; $x=~ s,;\s*$,,; $x }
  24                                    grep /\S/, $decl, $init, $code) . " <$opts>";
  25  return <<TESTCASE, $desc;
  26 $decl
  27 $init
  28 my \$strict = autovivification::TestCases::in_strict('refs');
  29 my \@exp = ($exp);
  30 my \$res = eval {
  31  local \$SIG{__WARN__} = sub { die join '', 'warn:', \@_ };
  32  $use
  33  $code
  34 };
  35 if (ref \$exp[0]) {
  36  like \$@, \$exp[0], \$desc . ' [exception]';
  37 } else {
  38  is   \$@, \$exp[0], \$desc . ' [exception]';
  39 }
  40 is_deeply \$res, \$exp[1], \$desc . ' [return]';
  41 is_deeply $test, \$exp[2], \$desc . ' [variable]';
  42 TESTCASE
  43 }
  44
  45 sub testcase_ok {
  46  local $_  = shift;
  47  my $sigil = shift;
  48
  49  my @chunks = split /#+/, "$_ ";
  50  s/^\s+//, s/\s+$// for @chunks;
  51  my ($init, $code, $exp, $opts) = @chunks;
  52
  53  (my $var = $init) =~ s/[^\$@%\w].*//;
  54  $init = $var eq $init ? '' : "$init;";
  55  my $use;
  56  if ($opts) {
  57   for (split ' ', $opts) {
  58    my $no = 1;
  59    $no = 0 if s/^([-+])// and $1 eq '-';
  60    $use .= ($no ? 'no' : 'use') . " autovivification '$_';"
  61   }
  62  } elsif (defined $opts) {
  63   $opts = 'empty';
  64   $use  = 'no autovivification;';
  65  } else {
  66   $opts = 'default';
  67   $use  = '';
  68  }
  69
  70  my @base = ([ $var, $init, $code, $exp, $use ]);
  71  if ($var =~ /\$/) {
  72   my ($name) = $var =~ /^\$(.*)/;
  73
  74   my @oldderef = @{$base[0]};
  75   $oldderef[2] =~ s/\Q$var\E\->/\$$var/g;
  76   push @base, \@oldderef;
  77
  78   my @nonref = @{$base[0]};
  79   $nonref[0] = $sigil . $name;
  80   for ($nonref[1], $nonref[2]) {
  81    s/\@\Q$var\E([\[\{])/\@$name$1/g;
  82    s/\Q$sigil$var\E/$nonref[0]/g;
  83    s/\Q$var\E\->/$var/g;
  84   }
  85   my $simple      = $nonref[2] !~ /->/;
  86   my $plain_deref = $nonref[2] =~ /\Q$nonref[0]\E/;
  87   my $empty  = { '@' => '[ ]', '%' => '{ }' }->{$sigil};
  88   if (($simple
  89        and (   $nonref[3] =~ m!qr/\^Reference vivification forbidden.*?/!
  90             or $nonref[3] =~ m!qr/\^Can't vivify reference.*?/!))
  91   or ($plain_deref
  92        and $nonref[3] =~ m!qr/\^Can't use an undefined value as a.*?/!)) {
  93    $nonref[1] = '';
  94    $nonref[2] = 1;
  95    $nonref[3] = "'', 1, $empty";
  96   }
  97   $nonref[3] =~ s/,\s*undef\s*$/, $empty/;
  98   push @base, \@nonref;
  99  }
 100
 101  my @testcases = map {
 102   my ($var, $init, $code, $exp, $use) = @$_;
 103   [ $var, $init,               $code, $exp, $use, $opts, 0 ],
 104   [ $var, "use strict; $init", $code, $exp, $use, $opts, 1 ],
 105   [ $var, "no strict;  $init", $code, $exp, $use, $opts, 1 ],
 106  } @base;
 107
 108  for (@testcases) {
 109   my ($testcase, $desc) = generate(@$_);
 110   my @N = (0 .. 9);
 111   eval $testcase;
 112   diag "== This testcase failed to compile ==\n$testcase\n## Reason: $@" if $@;
 113  }
 114 }
 115
 116 1;