]> git.vpit.fr Git - perl/modules/Scope-Upper.git/blob - lib/Scope/Upper/TestGenerator.pm
This is 0.34
[perl/modules/Scope-Upper.git] / lib / Scope / Upper / TestGenerator.pm
1 package Scope::Upper::TestGenerator;
2
3 use strict;
4 use warnings;
5
6 our ($call, $test, $allblocks);
7
8 our $local_var = '$x';
9
10 our $local_decl = sub {
11  my $x = $_[3];
12  return "local $local_var = $x;\n";
13 };
14
15 our $local_cond = sub {
16  my $x = $_[3];
17  return defined $x ? "($local_var eq $x)" : "(!defined($local_var))";
18 };
19
20 our $local_test = sub {
21  my ($height, $level, $i, $x) = @_;
22  my $cond = $local_cond->(@_);
23  return "ok($cond, 'local h=$height, l=$level, i=$i');\n";
24 };
25
26 my @blocks = (
27  [ '{',         '}' ],
28  [ 'sub {',     '}->();' ],
29  [ 'do {',      '};' ],
30  [ 'eval {',    '};' ],
31  [ 'for (1) {', '}' ],
32  [ 'eval q[',   '];' ],
33 );
34
35 push @blocks, [ 'given (1) {', '}' ] if "$]" >= 5.010_001;
36
37 my %exports = (
38  verbose_is => \&verbose_is,
39 );
40
41 sub import {
42  if ("$]" >= 5.017_011) {
43   require warnings;
44   warnings->unimport('experimental::smartmatch');
45  }
46
47  if ("$]" >= 5.010_001) {
48   require feature;
49   feature->import('switch');
50  }
51
52  my $pkg = caller;
53  while (my ($name, $code) = each %exports) {
54   no strict 'refs';
55   *{$pkg.'::'.$name} = $code;
56  }
57 }
58
59 @blocks = map [ map "$_\n", @$_ ], @blocks;
60
61 sub verbose_is ($$;$) {
62  my ($a, $b, $desc) = @_;
63
64  if (defined $::testcase
65       and (defined $b) ? (not defined $a or $a ne $b) : defined $a) {
66   Test::Leaner::diag(<<DIAG);
67 === This testcase failed ===
68 $::testcase
69 ==== vvvvv Errors vvvvvv ===
70 DIAG
71   undef $::testcase;
72  }
73
74  Test::Leaner::is($a, $b, $desc);
75 }
76
77 sub _block {
78  my ($height, $level, $i) = @_;
79  my $j = $height - $i;
80  $j = 0 if $j > $#blocks or $j < 0;
81  return [ map "$_\n", @{$blocks[$j]} ];
82 }
83
84 sub gen {
85  my ($height, $level, $i, $x) = @_;
86
87  if (@_ == 2) {
88   $i = 0;
89   push @_, $i;
90  }
91
92  return $call->(@_) if $height < $i;
93
94  my @res;
95  my @blks = $allblocks ? @blocks : _block(@_);
96
97  my $up   = gen($height, $level, $i + 1, $x);
98  my $t    = $test->(@_);
99  my $loct = $local_test->(@_);
100  for my $base (@$up) {
101   for my $blk (@blks) {
102    push @res, join '', $blk->[0], $base, $t, $loct, $blk->[1];
103   }
104  }
105
106  $_[3]    = $x = $i + 1;
107  $up      = gen($height, $level, $i + 1, $x);
108  $t       = $test->(@_);
109  my $locd = $local_decl->(@_);
110  $loct    = $local_test->(@_);
111  for my $base (@$up) {
112   for my $blk (@blks) {
113    push @res, join '', $blk->[0], $locd, $base, $t, $loct, $blk->[1];
114   }
115  }
116
117  return \@res;
118 }
119
120 1;