]> git.vpit.fr Git - perl/modules/Scope-Upper.git/blob - t/85-stress-yield.t
Document that we can no longer die from uplevel in the debugger
[perl/modules/Scope-Upper.git] / 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 }