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