]> git.vpit.fr Git - perl/modules/Scope-Upper.git/blob - TestGenerator.pm
8415632cc349a3a6859d53572f2f0ba3fe7f9d27
[perl/modules/Scope-Upper.git] / 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 sub import {
36  if ("$]" >= 5.010_001) {
37   push @blocks, [ 'given (1) {', '}' ];
38   require feature;
39   feature->import('switch');
40  }
41 }
42
43 @blocks = map [ map "$_\n", @$_ ], @blocks;
44
45 sub _block {
46  my ($height, $level, $i) = @_;
47  my $j = $height - $i;
48  $j = 0 if $j > $#blocks or $j < 0;
49  return [ map "$_\n", @{$blocks[$j]} ];
50 }
51
52 sub gen {
53  my ($height, $level, $i, $x) = @_;
54
55  if (@_ == 2) {
56   $i = 0;
57   push @_, $i;
58  }
59
60  return $call->(@_) if $height < $i;
61
62  my @res;
63  my @blks = $allblocks ? @blocks : _block(@_);
64
65  my $up   = gen($height, $level, $i + 1, $x);
66  my $t    = $test->(@_);
67  my $loct = $local_test->(@_);
68  for my $base (@$up) {
69   for my $blk (@blks) {
70    push @res, join '', $blk->[0], $base, $t, $loct, $blk->[1];
71   }
72  }
73
74  $_[3]    = $x = $i + 1;
75  $up      = gen($height, $level, $i + 1, $x);
76  $t       = $test->(@_);
77  my $locd = $local_decl->(@_);
78  $loct    = $local_test->(@_);
79  for my $base (@$up) {
80   for my $blk (@blks) {
81    push @res, join '', $blk->[0], $locd, $base, $t, $loct, $blk->[1];
82   }
83  }
84
85  return \@res;
86 }
87
88 1;