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);
  12
  13 $call = sub {
  14  my ($height, $level, $i) = @_;
  15  $level = $level ? 'UP ' x $level : 'HERE';
  16  return [ [ "unwind(\@args => $level)\n", [ \@args ] ] ];
  17 };
  18
  19 # @_[0 .. $#_] also ought to work, but it sometimes evaluates to nonsense in
  20 # scalar context on perl 5.8.5 and below.
  21
  22 sub list { wantarray ? @_ : $_[$#_] }
  23
  24 my @blocks = (
  25  [ 'sub {',     '}->()' ],
  26  [ 'eval {',    '}' ],
  27 );
  28
  29 my @contexts = (
  30  [ '',        '; ()', 'v' ],
  31  [ 'scalar(', ')',    's' ],
  32  [ 'list(',   ')',    'l' ],
  33 );
  34
  35 for my $block (@blocks) {
  36  $_ .= "\n" for @$block[0, 1];
  37 }
  38 for my $cxt (@contexts) {
  39  $_ .= "\n" for @$cxt[0, 1];
  40 }
  41
  42 sub contextify {
  43  my ($cxt, $active, $exp, @items) = @_;
  44  return $exp unless $active;
  45  if ($cxt eq 'v') {
  46   return [ ];
  47  } elsif ($cxt eq 's') {
  48   return [ $cxt, @$exp ];
  49  } else {
  50   return [ @items, @$exp ];
  51  }
  52 }
  53
  54 my $integer = 0;
  55 my $items   = 0;
  56
  57 sub gen {
  58  my ($height, $level, $i) = @_;
  59  push @_, $i = 0 if @_ == 2;
  60  my @res;
  61  my $up = $i == $height + 1 ? $call->(@_) : gen($height, $level, $i + 1);
  62  my $active = $i <= ($height - $level);
  63  for my $base (@$up) {
  64   my ($code, $exp) = @$base;
  65   for my $blk (@blocks) {
  66    for my $cx (@contexts) {
  67     push @res, [
  68      $blk->[0] . $cx->[0] . $code . $cx->[1] . $blk->[1],
  69      contextify($cx->[2], $active, $exp),
  70     ];
  71     my @items = map $integer++, 0 .. ($items++ % 3);
  72     my $list  = join ', ', @items;
  73     push @res, [
  74      $blk->[0] . $cx->[0] . "($list, $code)" . $cx->[1] . $blk->[1],
  75      contextify($cx->[2], $active, $exp, @items),
  76     ];
  77    }
  78   }
  79  }
  80  return \@res;
  81 }
  82
  83 sub linearize { join ', ', map { defined($_) ? $_ : '(undef)' } @_ }
  84
  85 sub expect {
  86  my @spec = @{$_[0]};
  87  my @acc;
  88  for my $s (reverse @spec) {
  89   if (ref $s) {
  90    unshift @acc, @$s;
  91   } elsif ($s =~ /^[0-9]+$/) {
  92    unshift @acc, $s;
  93   } elsif ($s eq 's') {
  94    @acc = (@acc ? $acc[-1] : undef);
  95   } else {
  96    return 'XXX';
  97   }
  98  }
  99  return linearize @acc;
 100 }
 101
 102 sub runtests {
 103  my ($height, $level) = @_;
 104  my $i;
 105  my $tests = gen @_;
 106  for (@$tests) {
 107   ++$i;
 108   no warnings 'void';
 109   my $res = linearize eval $_->[0];
 110   my $exp;
 111   if ($@) {
 112    $res = '*TEST DID NOT COMPILE*';
 113   } else {
 114    $exp = expect $_->[1];
 115   }
 116   if ($res ne $exp) {
 117    diag <<DIAG;
 118 === This testcase failed ===
 119 $_->[0];
 120 ==== vvvvv Errors vvvvvv ===
 121 DIAG
 122   }
 123   is $res, $exp, "stress unwind $height $level $i";
 124  }
 125 }
 126
 127 for ([ ], [ 'A' ], [ qw<B C> ]) {
 128  @args = @$_;
 129  runtests 0, 0;
 130  runtests 0, 1;
 131  runtests 1, 0;
 132  runtests 1, 1;
 133 }