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.010_001) {
  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;