]> git.vpit.fr Git - perl/modules/Scope-Upper.git/blob - t/lib/Scope/Upper/TestGenerator.pm
Update the bug tracker URL in META after the rt.perl.org upgrade
[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, $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 push @blocks, [ 'given (1) {', '}' ] if "$]" >= 5.010_001;
36
37 my %exports = (
38  verbose_is => \&verbose_is,
39 );
40
41 sub import {
42  if ("$]" >= 5.010_001) {
43   require feature;
44   feature->import('switch');
45  }
46
47  my $pkg = caller;
48  while (my ($name, $code) = each %exports) {
49   no strict 'refs';
50   *{$pkg.'::'.$name} = $code;
51  }
52 }
53
54 @blocks = map [ map "$_\n", @$_ ], @blocks;
55
56 sub verbose_is ($$;$) {
57  my ($a, $b, $desc) = @_;
58
59  if (defined $::testcase
60       and (defined $b) ? (not defined $a or $a ne $b) : defined $a) {
61   Test::Leaner::diag(<<DIAG);
62 === This testcase failed ===
63 $::testcase
64 ==== vvvvv Errors vvvvvv ===
65 DIAG
66   undef $::testcase;
67  }
68
69  Test::Leaner::is($a, $b, $desc);
70 }
71
72 sub _block {
73  my ($height, $level, $i) = @_;
74  my $j = $height - $i;
75  $j = 0 if $j > $#blocks or $j < 0;
76  return [ map "$_\n", @{$blocks[$j]} ];
77 }
78
79 sub gen {
80  my ($height, $level, $i, $x) = @_;
81
82  if (@_ == 2) {
83   $i = 0;
84   push @_, $i;
85  }
86
87  return $call->(@_) if $height < $i;
88
89  my @res;
90  my @blks = $allblocks ? @blocks : _block(@_);
91
92  my $up   = gen($height, $level, $i + 1, $x);
93  my $t    = $test->(@_);
94  my $loct = $local_test->(@_);
95  for my $base (@$up) {
96   for my $blk (@blks) {
97    push @res, join '', $blk->[0], $base, $t, $loct, $blk->[1];
98   }
99  }
100
101  $_[3]    = $x = $i + 1;
102  $up      = gen($height, $level, $i + 1, $x);
103  $t       = $test->(@_);
104  my $locd = $local_decl->(@_);
105  $loct    = $local_test->(@_);
106  for my $base (@$up) {
107   for my $blk (@blks) {
108    push @res, join '', $blk->[0], $locd, $base, $t, $loct, $blk->[1];
109   }
110  }
111
112  return \@res;
113 }
114
115 1;