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 HERE SCOPE>;
  10
  11 # @_[0 .. $#_] also ought to work, but it sometimes evaluates to nonsense in
  12 # scalar context on perl 5.8.5 and below.
  13
  14 sub list { wantarray ? @_ : $_[$#_] }
  15
  16 my @blocks = (
  17  [
  18    'sub {
  19      my $next = shift;',
  20    '}->($next, @_)'
  21  ],
  22  [
  23    'eval {',
  24    '}'
  25  ],
  26 );
  27
  28 my @contexts = (
  29  [ '',        '; ()', 'v' ],
  30  [ 'scalar(', ')',    's' ],
  31  [ 'list(',   ')',    'l' ],
  32 );
  33
  34 sub linearize { join ', ', map { defined($_) ? $_ : '(undef)' } @_ }
  35
  36 our @stack;
  37 our @pre;
  38
  39 # Don't put closures in empty pads on 5.6.
  40
  41 my $dummy;
  42 my $capture_outer_pad = "$]" < 5.008 ? "++\$dummy;" : '';
  43
  44 my @test_frames;
  45
  46 for my $block (@blocks) {
  47  for my $context (@contexts) {
  48   my $source = <<"FRAME";
  49    sub {
  50     my \$next = shift; $capture_outer_pad
  51     $block->[0]
  52      unshift \@stack, HERE;
  53      $context->[0]
  54       (\@{shift \@pre}, \$next->[0]->(\@_))
  55      $context->[1]
  56     $block->[1]
  57    }
  58 FRAME
  59   my $code;
  60   {
  61    local $@;
  62    $code = do {
  63     no warnings 'void';
  64     eval $source;
  65    };
  66    my $err = $@;
  67    chomp $err;
  68    die "$err. Source was :\n$source\n" if $@;
  69   }
  70   push @test_frames, [ $code, $source, $context->[2] ];
  71  }
  72 }
  73
  74 my @targets = (
  75  [ sub {
  76   my $depth = pop;
  77   unshift @stack, HERE;
  78   unwind(@_ => $stack[$depth]);
  79  }, 'target context from HERE' ],
  80  [ sub {
  81   my $depth = pop;
  82   unwind(@_ => SCOPE($depth == 0 ? 0 : (2 * ($depth - 1) + 1)));
  83  }, 'target context from SCOPE' ],
  84 );
  85
  86 my $seed = 0;
  87
  88 for my $args ([ ], [ 'A' ], [ qw<B C> ]) {
  89  my @args = @$args;
  90  for my $frame0 (@test_frames) {
  91   for my $frame1 (@test_frames) {
  92    for my $frame2 (@test_frames) {
  93     my $max_depth = 3;
  94     $seed += 5; # Coprime with $max_depth
  95     my @prepend;
  96     for (1 .. $max_depth) {
  97      ++$seed;
  98      my $i = $seed + $_;
  99      my $l = $seed % $max_depth - 1;
 100      push @prepend, [ $i .. ($i + $l) ];
 101     }
 102     my $prepend_str = join ' ', map { '[' . join(' ', @$_) . ']' } @prepend;
 103     for my $depth (0 .. $max_depth) {
 104      my $exp = do {
 105       my @cxts = map $_->[2], $frame0, $frame1, $frame2;
 106       my @exp  = @args;
 107       for (my $i = $depth + 1; $i <= $max_depth; ++$i) {
 108        my $c = $cxts[$max_depth - $i];
 109        if ($c eq 'v') {
 110         @exp = ();
 111        } elsif ($c eq 's') {
 112         @exp = @exp ? $exp[-1] : undef;
 113        } else {
 114         unshift @exp, @{$prepend[$max_depth - $i]};
 115        }
 116       }
 117       linearize @exp;
 118      };
 119      for my $target (@targets) {
 120       local @stack;
 121       local @pre = @prepend;
 122       my @res = $frame0->[0]->($frame1, $frame2, $target, @args, $depth);
 123       my $got = linearize @res;
 124       if ($got ne $exp) {
 125        diag <<DIAG;
 126 === This testcase failed ===
 127 $frame0->[1]
 128 $frame1->[1]
 129 $frame2->[1]
 130 $target->[1]
 131 ==== vvvvv Errors vvvvvv ===
 132 DIAG
 133       }
 134       is $got, $exp, "unwind to depth $depth with args [@args] and prepending $prepend_str";
 135      }
 136     }
 137    }
 138   }
 139  }
 140 }