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
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
|
package Scope::Upper::TestGenerator;
use strict;
use warnings;
our ($call, $test, $allblocks);
our $local_var = '$x';
our $local_decl = sub {
my $x = $_[3];
return "local $local_var = $x;\n";
};
our $local_cond = sub {
my $x = $_[3];
return defined $x ? "($local_var eq $x)" : "(!defined($local_var))";
};
our $local_test = sub {
my ($height, $level, $i, $x) = @_;
my $cond = $local_cond->(@_);
return "ok($cond, 'local h=$height, l=$level, i=$i');\n";
};
my @blocks = (
[ '{', '}' ],
[ 'sub {', '}->();' ],
[ 'do {', '};' ],
[ 'eval {', '};' ],
[ 'for (1) {', '}' ],
[ 'eval q[', '];' ],
);
push @blocks, [ 'given (1) {', '}' ] if "$]" >= 5.010_001 and "$]" < 5.037_010;
my %exports = (
verbose_is => \&verbose_is,
);
sub import {
if ("$]" >= 5.017_011) {
require warnings;
warnings->unimport('experimental::smartmatch');
}
if ("$]" >= 5.010_001) {
require feature;
feature->import('switch');
}
my $pkg = caller;
while (my ($name, $code) = each %exports) {
no strict 'refs';
*{$pkg.'::'.$name} = $code;
}
}
@blocks = map [ map "$_\n", @$_ ], @blocks;
sub verbose_is ($$;$) {
my ($a, $b, $desc) = @_;
if (defined $::testcase
and (defined $b) ? (not defined $a or $a ne $b) : defined $a) {
Test::Leaner::diag(<<DIAG);
=== This testcase failed ===
$::testcase
==== vvvvv Errors vvvvvv ===
DIAG
undef $::testcase;
}
Test::Leaner::is($a, $b, $desc);
}
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) = @_;
if (@_ == 2) {
$i = 0;
push @_, $i;
}
return $call->(@_) if $height < $i;
my @res;
my @blks = $allblocks ? @blocks : _block(@_);
my $up = gen($height, $level, $i + 1, $x);
my $t = $test->(@_);
my $loct = $local_test->(@_);
for my $base (@$up) {
for my $blk (@blks) {
push @res, join '', $blk->[0], $base, $t, $loct, $blk->[1];
}
}
$_[3] = $x = $i + 1;
$up = gen($height, $level, $i + 1, $x);
$t = $test->(@_);
my $locd = $local_decl->(@_);
$loct = $local_test->(@_);
for my $base (@$up) {
for my $blk (@blks) {
push @res, join '', $blk->[0], $locd, $base, $t, $loct, $blk->[1];
}
}
return \@res;
}
1;
|
