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 sub gen {
  55  my ($height, $level, $i) = @_;
  56  push @_, $i = 0 if @_ == 2;
  57  my @res;
  58  my $up = $i == $height + 1 ? $call->(@_) : gen($height, $level, $i + 1);
  59  my $active = $i <= ($height - $level);
  60  for my $base (@$up) {
  61   my ($code, $exp) = @$base;
  62   for my $blk (@blocks) {
  63    for my $cx (@contexts) {
  64     push @res, [
  65      $blk->[0] . $cx->[0] . $code . $cx->[1] . $blk->[1],
  66      contextify($cx->[2], $active, $exp),
  67     ];
  68     my @items = map { int rand 10 } 0 .. rand 3;
  69     my $list  = join ', ', @items;
  70     push @res, [
  71      $blk->[0] . $cx->[0] . "($list, $code)" . $cx->[1] . $blk->[1],
  72      contextify($cx->[2], $active, $exp, @items),
  73     ];
  74    }
  75   }
  76  }
  77  return \@res;
  78 }
  79
  80 sub linearize { join ', ', map { defined($_) ? $_ : '(undef)' } @_ }
  81
  82 sub expect {
  83  my @spec = @{$_[0]};
  84  my @acc;
  85  for my $s (reverse @spec) {
  86   if (ref $s) {
  87    unshift @acc, @$s;
  88   } elsif ($s =~ /^[0-9]+$/) {
  89    unshift @acc, $s;
  90   } elsif ($s eq 's') {
  91    @acc = (@acc ? $acc[-1] : undef);
  92   } else {
  93    return 'XXX';
  94   }
  95  }
  96  return linearize @acc;
  97 }
  98
  99 sub runtests {
 100  my ($height, $level) = @_;
 101  my $i;
 102  my $tests = gen @_;
 103  for (@$tests) {
 104   ++$i;
 105   no warnings 'void';
 106   my $res = linearize eval $_->[0];
 107   my $exp;
 108   if ($@) {
 109    $res = '*TEST DID NOT COMPILE*';
 110   } else {
 111    $exp = expect $_->[1];
 112   }
 113   if ($res ne $exp) {
 114    diag <<DIAG;
 115 === This testcase failed ===
 116 $_->[0];
 117 ==== vvvvv Errors vvvvvv ===
 118 DIAG
 119   }
 120   is $res, $exp, "stress unwind $height $level $i";
 121  }
 122 }
 123
 124 for ([ ], [ 'A' ], [ qw<B C> ]) {
 125  @args = @$_;
 126  runtests 0, 0;
 127  runtests 0, 1;
 128  runtests 1, 0;
 129  runtests 1, 1;
 130 }