7 use Test::Leaner 'no_plan';
9 use Scope::Upper qw<unwind UP HERE>;
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.
18 # perl 5.6.x is really bad at closures, hence make it compile a function call
20 *_get_args = sub { @args };
21 $args_code = '_get_args()';
27 my ($height, $level, $i) = @_;
28 $level = $level ? 'UP ' x $level : 'HERE';
29 return [ [ "unwind($args_code => $level)\n", [ \@args ] ] ];
32 # @_[0 .. $#_] also ought to work, but it sometimes evaluates to nonsense in
33 # scalar context on perl 5.8.5 and below.
35 sub list { wantarray ? @_ : $_[$#_] }
44 [ 'scalar(', ')', 's' ],
45 [ 'list(', ')', 'l' ],
48 for my $block (@blocks) {
49 $_ .= "\n" for @$block[0, 1];
51 for my $cxt (@contexts) {
52 $_ .= "\n" for @$cxt[0, 1];
56 my ($cxt, $active, $exp, @items) = @_;
57 return $exp unless $active;
60 } elsif ($cxt eq 's') {
61 return [ $cxt, @$exp ];
63 return [ @items, @$exp ];
71 my ($height, $level, $i) = @_;
72 push @_, $i = 0 if @_ == 2;
74 my $up = $i == $height + 1 ? $call->(@_) : gen($height, $level, $i + 1);
75 my $active = $i <= ($height - $level);
77 my ($code, $exp) = @$base;
78 for my $blk (@blocks) {
79 for my $cx (@contexts) {
81 $blk->[0] . $cx->[0] . $code . $cx->[1] . $blk->[1],
82 contextify($cx->[2], $active, $exp),
84 my @items = map $integer++, 0 .. ($items++ % 3);
85 my $list = join ', ', @items;
87 $blk->[0] . $cx->[0] . "($list, $code)" . $cx->[1] . $blk->[1],
88 contextify($cx->[2], $active, $exp, @items),
96 sub linearize { join ', ', map { defined($_) ? $_ : '(undef)' } @_ }
101 for my $s (reverse @spec) {
104 } elsif ($s =~ /^[0-9]+$/) {
106 } elsif ($s eq 's') {
107 @acc = (@acc ? $acc[-1] : undef);
112 return linearize @acc;
115 my @arg_lists = ([ ], [ 'A' ], [ qw<B C> ]);
117 for my $height (0 .. 1) {
118 for my $level (0 .. 1) {
120 my $tests = gen $height, $level;
122 my ($code, $exp_spec) = @$_;
124 my $desc = "stress unwind $height $level $i";
127 eval "sub { $code }";
130 fail "$desc : test did not compile" for 1 .. @arg_lists;
134 my $res = linearize $cb->();
135 my $exp = expect $exp_spec;
138 === This testcase failed ===
140 ==== vvvvv Errors vvvvvv ===
143 is $res, $exp, "$desc [@args]";