t/85-stress-unwind.t

   1 #!perl -T
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More 'no_plan';
   7
   8 use Scope::Upper qw/unwind/;
   9
  10 our ($call, @args, $args);
  11
  12 $call = sub {
  13  my ($height, $level, $i) = @_;
  14  return [ [ "unwind(\@args => $level)\n", '' ] ];
  15 };
  16
  17 sub list { @_ }
  18
  19 my @blocks = (
  20  [ 'sub {',     '}->()' ],
  21  [ 'eval {',    '}' ],
  22 );
  23
  24 my @contexts = (
  25  [ '',        '; ()' ],
  26  [ 'scalar(', ')' ],
  27  [ 'list(',   ')' ],
  28 );
  29
  30 @blocks   = map [ map "$_\n", @$_ ], @blocks;
  31 @contexts = map [ map "$_\n", @$_ ], @contexts;
  32
  33 sub gen {
  34  my ($height, $level, $i) = @_;
  35  push @_, $i = 0 if @_ == 2;
  36  my @res;
  37  my $up = $i == $height + 1 ? $call->(@_) : gen($height, $level, $i + 1);
  38  if ($i + $level == $height + 1) {
  39   for (@$up) {
  40    $_->[1] = "return($args)\n";
  41   }
  42  }
  43  for my $base (@$up) {
  44   my ($code, $exp) = @$base;
  45   for my $blk (@blocks) {
  46    for my $cx (@contexts) {
  47     push @res, [
  48      $blk->[0] . $cx->[0] . $code . $cx->[1] . $blk->[1],
  49      $blk->[0] . $cx->[0] . $exp .  $cx->[1] . $blk->[1],
  50     ];
  51     my $list = join ', ', map { int rand 10 } 0 .. rand 3;
  52     push @res, [
  53      $blk->[0] . $cx->[0] . "($list, " . $code . ')' . $cx->[1] . $blk->[1],
  54      $blk->[0] . $cx->[0] . "($list, " . $exp .  ')' . $cx->[1] . $blk->[1],
  55     ];
  56    }
  57   }
  58  }
  59  return \@res;
  60 }
  61
  62 sub runtests {
  63  my $tests = gen @_;
  64  for (@$tests) {
  65   no warnings 'void';
  66   my @res = eval $_->[0];
  67   my @exp = eval $_->[1] unless $@;
  68   if ($@ || !is_deeply \@res, \@exp) {
  69    diag "=== vvv Test vvv ===";
  70    diag $_->[0];
  71    diag "------- Got --------";
  72    diag join(', ', map { defined($_) ? $_ : '(undef)' } @res);
  73    diag "----- Expected -----";
  74    diag join(', ', map { defined($_) ? $_ : '(undef)' } @exp);
  75    diag "=== ^^^^^^^^^^^^ ===";
  76   }
  77  }
  78 }
  79
  80 for ([ ], [ 'A' ], [ qw/B C/ ]) {
  81  @args = @$_;
  82  $args = '(' . join(', ', map "'$_'", @args) . ')';
  83  runtests 0, 0;
  84  runtests 0, 1;
  85  runtests 1, 0;
  86  runtests 1, 1;
  87 }