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 source {
  14  my ($var, $init, $code, $exp, $use, $global) = @_;
  15  my $decl = $global ? "our $var; local $var;" : "my $var;";
  16  my $test = $var =~ /^[@%]/ ? "\\$var" : $var;
  17  return <<TESTCASE;
  18 my \@exp = ($exp);
  19 $decl
  20 $init
  21 my \$res = eval {
  22  local \$SIG{__WARN__} = sub { die join '', 'warn:', \@_ };
  23  $use
  24  $code
  25 };
  26 if (ref \$exp[0]) {
  27  like \$@, \$exp[0], \$desc . ' [exception]';
  28 } else {
  29  is   \$@, \$exp[0], \$desc . ' [exception]';
  30 }
  31 is_deeply \$res, \$exp[1], \$desc . ' [return]';
  32 is_deeply $test, \$exp[2], \$desc . ' [variable]';
  33 TESTCASE
  34 }
  35
  36 sub testcase_ok {
  37  local $_  = shift;
  38  my $sigil = shift;
  39  my @chunks = split /#+/, "$_ ";
  40  s/^\s+//, s/\s+$// for @chunks;
  41  my ($init, $code, $exp, $opts) = @chunks;
  42  (my $var = $init) =~ s/[^\$@%\w].*//;
  43  $init = $var eq $init ? '' : "$init;";
  44  my $use;
  45  if ($opts) {
  46   for (split ' ', $opts) {
  47    my $no = 1;
  48    $no = 0 if s/^([-+])// and $1 eq '-';
  49    $use .= ($no ? 'no' : 'use') . " autovivification '$_';"
  50   }
  51  } elsif (defined $opts) {
  52   $opts = 'empty';
  53   $use  = 'no autovivification;';
  54  } else {
  55   $opts = 'default';
  56   $use  = '';
  57  }
  58  my @testcases = (
  59   [ $var, $init,               $code, $exp, $use, 0 ],
  60   [ $var, "use strict; $init", $code, $exp, $use, 1 ],
  61   [ $var, "no strict;  $init", $code, $exp, $use, 1 ],
  62  );
  63  my @extra;
  64  for (@testcases) {
  65   my $var = $_->[0];
  66   if ($var =~ /\$/) {
  67    my @new = @$_;
  68    $new[0] =~ s/^$/$sigil/;
  69    $new[1] =~ s/$var\->/$var/g;
  70    $new[2] =~ s/$var\->/$var/g;
  71    push @extra, \@new;
  72   }
  73  }
  74  push @testcases, @extra;
  75  for (@testcases) {
  76   my $testcase = source(@$_);
  77   my ($var, $init, $code) = @$_;
  78   my $desc = do { (my $x = "$var | $init") =~ s,;\s+$,,; $x } . " | $code | $opts";
  79   eval $testcase;
  80   diag "== This testcase failed to compile ==\n$testcase\n## Reason: $@" if $@;
  81  }
  82 }
  83
  84 1;