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    $new[1] =~ s/$var\->/$var/g;
  73    $new[2] =~ s/$var\->/$var/g;
  74    push @extra, \@new;
  75   }
  76  }
  77  push @testcases, @extra;
  78  for (@testcases) {
  79   my $testcase = source(@$_);
  80   my ($var, $init, $code) = @$_;
  81   my $desc = do { (my $x = "$var | $init") =~ s,;\s+$,,; $x } . " | $code | $opts";
  82   eval $testcase;
  83   diag "== This testcase failed to compile ==\n$testcase\n## Reason: $@" if $@;
  84  }
  85 }
  86
  87 1;