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