]> git.vpit.fr Git - perl/modules/Scope-Upper.git/blob - t/lib/Scope/Upper/TestGenerator.pm
Test uplevel's behaviour regarding to match variables more thoroughly
[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 sub import {
29  if ("$]" >= 5.010001) {
30   push @blocks, [ 'given (1) {', '}' ];
31   require feature;
32   feature->import('switch');
33  }
34 }
35
36 @blocks = map [ map "$_\n", @$_ ], @blocks;
37
38 sub _block {
39  my ($height, $level, $i) = @_;
40  my $j = $height - $i;
41  $j = 0 if $j > $#blocks or $j < 0;
42  return [ map "$_\n", @{$blocks[$j]} ];
43 }
44
45 sub gen {
46  my ($height, $level, $i, $x) = @_;
47  push @_, $i = 0 if @_ == 2;
48  return $call->(@_) if $height < $i;
49  my @res;
50  my @blks = $allblocks ? @blocks : _block(@_);
51  my $up   = gen($height, $level, $i + 1, $x);
52  for my $base (@$up) {
53   for my $blk (@blks) {
54    push @res, $blk->[0] . $base . $test->(@_) . $testlocal->(@_) . $blk->[1];
55   }
56  }
57  $_[3] = $i + 1;
58  $up = gen($height, $level, $i + 1, $i + 1);
59  for my $base (@$up) {
60   for my $blk (@blks) {
61    push @res, $blk->[0] .
62                $local->(@_) . $base . $test->(@_) . $testlocal->(@_)
63               . $blk->[1];
64   }
65  }
66  return \@res;
67 }
68
69 1;