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