#!perl -T
use strict;
use warnings;
use lib 't/lib';
use Test::Leaner 'no_plan';
use Scope::Upper qw<yield HERE SCOPE>;
# @_[0 .. $#_] also ought to work, but it sometimes evaluates to nonsense in
# scalar context on perl 5.8.5 and below.
sub list { wantarray ? @_ : $_[$#_] }
my @blocks = (
[
'do {',
'}'
],
[
'(list map {', # map in scalar context yields the number of elements
'} 1)'
],
[
'sub {
my $next = shift;',
'}->($next, @_)'
],
[
'eval {',
'}'
],
);
my @contexts = (
[ '', '; ()', 'v' ],
[ 'scalar(', ')', 's' ],
[ 'list(', ')', 'l' ],
);
sub linearize { join ', ', map { defined($_) ? $_ : '(undef)' } @_ }
our @stack;
our @pre;
# Don't put closures in empty pads on 5.6.
my $dummy;
my $capture_outer_pad = "$]" < 5.008 ? "++\$dummy;" : '';
my @test_frames;
for my $block (@blocks) {
for my $context (@contexts) {
my $source = <<"FRAME";
sub {
my \$next = shift; $capture_outer_pad
$block->[0]
unshift \@stack, HERE;
$context->[0]
(\@{shift \@pre}, \$next->[0]->(\@_))
$context->[1]
$block->[1]
}
FRAME
my $code;
{
local $@;
$code = do {
no warnings 'void';
eval $source;
};
my $err = $@;
chomp $err;
die "$err. Source was :\n$source\n" if $@;
}
push @test_frames, [ $code, $source, $context->[2] ];
}
}
my @targets = (
[ sub {
my $depth = pop;
unshift @stack, HERE;
yield(@_ => $stack[$depth]);
}, 'target context from HERE' ],
[ sub {
my $depth = pop;
yield(@_ => SCOPE($depth == 0 ? 0 : (2 * ($depth - 1) + 1)));
}, 'target context from SCOPE' ],
);
my $seed = 0;
for my $args ([ ], [ 'A' ], [ qw<B C> ]) {
my @args = @$args;
for my $frame0 (@test_frames) {
for my $frame1 (@test_frames) {
for my $frame2 (@test_frames) {
my $max_depth = 3;
$seed += 5; # Coprime with $max_depth
my @prepend;
for (1 .. $max_depth) {
++$seed;
my $i = $seed + $_;
my $l = $seed % $max_depth - 1;
push @prepend, [ $i .. ($i + $l) ];
}
my $prepend_str = join ' ', map { '[' . join(' ', @$_) . ']' } @prepend;
for my $depth (0 .. $max_depth) {
my $exp = do {
my @cxts = map $_->[2], $frame0, $frame1, $frame2;
my @exp = @args;
for (my $i = $depth + 1; $i <= $max_depth; ++$i) {
my $c = $cxts[$max_depth - $i];
if ($c eq 'v') {
@exp = ();
} elsif ($c eq 's') {
@exp = @exp ? $exp[-1] : undef;
} else {
unshift @exp, @{$prepend[$max_depth - $i]};
}
}
linearize @exp;
};
for my $target (@targets) {
local @stack;
local @pre = @prepend;
my @res = $frame0->[0]->($frame1, $frame2, $target, @args, $depth);
my $got = linearize @res;
if ($got ne $exp) {
diag <<DIAG;
=== This testcase failed ===
$frame0->[1]
$frame1->[1]
$frame2->[1]
$target->[1]
==== vvvvv Errors vvvvvv ===
DIAG
}
is $got, $exp, "yield to depth $depth with args [@args] and prepending $prepend_str";
}
}
}
}
}
}