t/lib/autovivification/TestCases.pm

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