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 @blocks = map [ map "$_\n", @$_ ], @blocks;
  29
  30 sub _block {
  31  my ($height, $level, $i) = @_;
  32  my $j = $height - $i;
  33  $j = 0 if $j > $#blocks or $j < 0;
  34  return [ map "$_\n", @{$blocks[$j]} ];
  35 }
  36
  37 sub gen {
  38  my ($height, $level, $i, $x) = @_;
  39  push @_, $i = 0 if @_ == 2;
  40  return $call->(@_) if $height < $i;
  41  my @res;
  42  my @blks = $allblocks ? @blocks : _block(@_);
  43  my $up   = gen($height, $level, $i + 1, $x);
  44  for my $base (@$up) {
  45   for my $blk (@blks) {
  46    push @res, $blk->[0] . $base . $test->(@_) . $testlocal->(@_) . $blk->[1];
  47   }
  48  }
  49  $_[3] = $i + 1;
  50  $up = gen($height, $level, $i + 1, $i + 1);
  51  for my $base (@$up) {
  52   for my $blk (@blks) {
  53    push @res, $blk->[0] .
  54                $local->(@_) . $base . $test->(@_) . $testlocal->(@_)
  55               . $blk->[1];
  56   }
  57  }
  58  return \@res;
  59 }
  60
  61 1;