]> git.vpit.fr Git - perl/modules/Scope-Upper.git/blob - t/lib/Scope/Upper/TestGenerator.pm
This is 0.07
[perl/modules/Scope-Upper.git] / t / lib / Scope / Upper / TestGenerator.pm
1 package Scope::Upper::TestGenerator;
2
3 use strict;
4 use warnings;
5
6 our ($call, $test, $local, $testlocal, $allblocks);
7
8 $local = sub {
9  my $x = $_[3];
10  return "local \$x = $x;\n";
11 };
12
13 $testlocal = sub {
14  my ($height, $level, $i, $x) = @_;
15  my $j = defined $x ? $x : 'undef';
16  return "is(\$x, $j, 'x h=$height, l=$level, i=$i');\n";
17 };
18
19 my @blocks = (
20  [ '{',         '}' ],
21  [ 'sub {',     '}->();' ],
22  [ 'do {',      '};' ],
23  [ 'eval {',    '};' ],
24  [ 'for (1) {', '}' ],
25  [ 'eval q[',   '];' ],
26 );
27
28 @blocks = map [ map "$_\n", @$_ ], @blocks;
29
30 sub _block {
31  my ($height, $level, $i) = @_;
32  my $j = $height - $i;
33  $j = 0 if $j > $#blocks or $j < 0;
34  return [ map "$_\n", @{$blocks[$j]} ];
35 }
36
37 sub gen {
38  my ($height, $level, $i, $x) = @_;
39  push @_, $i = 0 if @_ == 2;
40  return $call->(@_) if $height < $i;
41  my @res;
42  my @blks = $allblocks ? @blocks : _block(@_);
43  my $up   = gen($height, $level, $i + 1, $x);
44  for my $base (@$up) {
45   for my $blk (@blks) {
46    push @res, $blk->[0] . $base . $test->(@_) . $testlocal->(@_) . $blk->[1];
47   }
48  }
49  $_[3] = $i + 1;
50  $up = gen($height, $level, $i + 1, $i + 1);
51  for my $base (@$up) {
52   for my $blk (@blks) {
53    push @res, $blk->[0] .
54                $local->(@_) . $base . $test->(@_) . $testlocal->(@_)
55               . $blk->[1];
56   }
57  }
58  return \@res;
59 }
60
61 1;