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 UP HERE/;
   9
  10 our ($call, @args, $args);
  11
  12 $call = sub {
  13  my ($height, $level, $i) = @_;
  14  $level = $level ? 'UP ' x $level : 'HERE';
  15  return [ [ "unwind(\@args => $level)\n", '' ] ];
  16 };
  17
  18 sub list { @_ }
  19
  20 my @blocks = (
  21  [ 'sub {',     '}->()' ],
  22  [ 'eval {',    '}' ],
  23 );
  24
  25 my @contexts = (
  26  [ '',        '; ()' ],
  27  [ 'scalar(', ')' ],
  28  [ 'list(',   ')' ],
  29 );
  30
  31 @blocks   = map [ map "$_\n", @$_ ], @blocks;
  32 @contexts = map [ map "$_\n", @$_ ], @contexts;
  33
  34 sub gen {
  35  my ($height, $level, $i) = @_;
  36  push @_, $i = 0 if @_ == 2;
  37  my @res;
  38  my $up = $i == $height + 1 ? $call->(@_) : gen($height, $level, $i + 1);
  39  if ($i + $level == $height + 1) {
  40   for (@$up) {
  41    $_->[1] = "return($args)\n";
  42   }
  43  }
  44  for my $base (@$up) {
  45   my ($code, $exp) = @$base;
  46   for my $blk (@blocks) {
  47    for my $cx (@contexts) {
  48     push @res, [
  49      $blk->[0] . $cx->[0] . $code . $cx->[1] . $blk->[1],
  50      $blk->[0] . $cx->[0] . $exp .  $cx->[1] . $blk->[1],
  51     ];
  52     my $list = join ', ', map { int rand 10 } 0 .. rand 3;
  53     push @res, [
  54      $blk->[0] . $cx->[0] . "($list, " . $code . ')' . $cx->[1] . $blk->[1],
  55      $blk->[0] . $cx->[0] . "($list, " . $exp .  ')' . $cx->[1] . $blk->[1],
  56     ];
  57    }
  58   }
  59  }
  60  return \@res;
  61 }
  62
  63 sub linearize { join ', ', map { defined($_) ? $_ : '(undef)' } @_ }
  64
  65 sub runtests {
  66  my ($height, $level) = @_;
  67  my $i;
  68  my $tests = gen @_;
  69  for (@$tests) {
  70   ++$i;
  71   no warnings 'void';
  72   my $res = linearize eval $_->[0];
  73   $res = '*TEST DID NOT COMPILE*' if $@;
  74   my $exp;
  75   unless ($@) {
  76    $exp = linearize eval $_->[1];
  77    $exp = '*REFERENCE DID NOT COMPILE*' if $@;
  78   }
  79   if ($@ || $res ne $exp) {
  80    diag <<DIAG;
  81 === This testcase failed ===
  82 $_->[0];
  83 ==== vvvvv Errors vvvvvv ===
  84 DIAG
  85   }
  86   is $res, $exp, "stress unwind $height $level $i";
  87  }
  88 }
  89
  90 for ([ ], [ 'A' ], [ qw/B C/ ]) {
  91  @args = @$_;
  92  $args = '(' . join(', ', map "'$_'", @args) . ')';
  93  runtests 0, 0;
  94  runtests 0, 1;
  95  runtests 1, 0;
  96  runtests 1, 1;
  97 }