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