t/85-stress-unwind.t

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