]> git.vpit.fr Git - perl/modules/Scope-Upper.git/blob - t/86-stress-uplevel.t
Fix goto &xsub in uplevel
[perl/modules/Scope-Upper.git] / t / 86-stress-uplevel.t
1 #!perl -T
2
3 use strict;
4 use warnings;
5
6 use lib 't/lib';
7 use Test::Leaner;
8
9 use Scope::Upper qw<uplevel HERE UP SUB CALLER>;
10
11 my $n = 1_000;
12
13 plan tests => 3 + $n * (6 + 3);
14
15 my $period1 = 100;
16 my $period2 = 10;
17 my $shift   = 10;
18 my $amp     = 10;
19
20 sub PI () { CORE::atan2(0, -1) }
21
22 sub depth {
23  my $depth = 0;
24  while (1) {
25   my @c = caller($depth);
26   last unless @c;
27   ++$depth;
28  }
29  return $depth - 1;
30 }
31
32 sub cap {
33  my ($depth, $top) = @_;
34
35  $depth <= 0 ? 1
36              : $depth >= $top ? $top - 1
37                               : $depth;
38 }
39
40 sub base_depth {
41  cap($shift + int($amp * sin(2 * PI * $_[0] / $period1)), 2 * $shift + 1);
42 }
43
44 sub uplevel_depth {
45  my ($base_depth, $i) = @_;
46
47  my $h = int($base_depth / 2);
48
49  cap($h + int($h * sin(2 * PI * $i / $period2)), $base_depth);
50 }
51
52 sub rec_basic {
53  my ($base_depth, $uplevel_depth, $desc, $i) = @_;
54  if ($i < $base_depth) {
55   $i, rec_basic($base_depth, $uplevel_depth, $desc, $i + 1);
56  } else {
57   is depth(), $base_depth+1, "$desc: depth before uplevel";
58   my $ret = uplevel {
59    is depth(), $base_depth+1-$uplevel_depth, "$desc: depth inside uplevel";
60    is "@_", "$base_depth $uplevel_depth",  "$desc: arguments";
61    -$uplevel_depth;
62   } @_[0, 1], CALLER($uplevel_depth);
63   is depth(), $base_depth+1, "$desc: depth after uplevel";
64   $ret;
65  }
66 }
67
68 sub rec_die {
69  my ($base_depth, $uplevel_depth, $desc, $i) = @_;
70  if ($i < $base_depth) {
71   local $@;
72   my $ret;
73   if ($i % 2) {
74    $ret = eval q<
75     rec_die($base_depth, $uplevel_depth, $desc, $i + 1)
76    >
77   } else {
78    $ret = eval {
79     rec_die($base_depth, $uplevel_depth, $desc, $i + 1)
80    }
81   }
82   return $@ ? $@
83             : $ret ? $ret
84                    : undef;
85  } else {
86   my $cxt = SUB;
87   {
88    my $n = $uplevel_depth;
89    while ($n) {
90     $cxt = SUB UP $cxt;
91     $n--;
92    }
93   }
94   my $ret = uplevel {
95    is HERE, $cxt, "$desc: context inside uplevel";
96    die "XXX @_";
97   } @_[0, 1], $cxt;
98   $ret;
99  }
100 }
101
102 my $die_line = __LINE__-6;
103
104 is depth(),                           0, 'check top depth';
105 is sub { depth() }->(),               1, 'check subroutine call depth';
106 is do { local $@; eval { depth() } }, 1, 'check eval block depth';
107
108 for my $i (1 .. $n) {
109  my $base_depth    = base_depth($i);
110  my $uplevel_depth = uplevel_depth($base_depth, $i);
111
112  {
113   my $desc = "basic $base_depth $uplevel_depth";
114
115   my @ret = rec_basic($base_depth, $uplevel_depth, $desc, 0);
116   is depth(), 0, "$desc: depth outside";
117   is_deeply \@ret, [ 0 .. $base_depth-1, -$uplevel_depth ],
118                                                        "$desc: returned values";
119  }
120
121  {
122   ++$base_depth;
123   my $desc = "die $base_depth $uplevel_depth";
124
125   my $err = rec_die($base_depth, $uplevel_depth, $desc, 0);
126   is depth(), 0, "$desc: depth outside";
127   like $err, qr/^XXX $base_depth $uplevel_depth at \Q$0\E line $die_line/,
128                                                          "$desc: correct error";
129  }
130 }