]> git.vpit.fr Git - perl/modules/Scope-Upper.git/blob - t/64-uplevel-caller.t
Rename some variables and struct members around su_uplevel()
[perl/modules/Scope-Upper.git] / t / 64-uplevel-caller.t
1 #!perl -T
2
3 use strict;
4 use warnings;
5
6 use Test::More tests => ((3 * 4) / 2) * 2 * 2 + 8;
7
8 use Scope::Upper qw<uplevel HERE CALLER>;
9
10 sub callstack {
11  my ($check_args) = @_;
12  my $i = 1;
13  my @stack;
14  while (1) {
15   my @c = $check_args ? do { package DB; caller($i++) }
16                       : caller($i++);
17   last unless @c;
18   if ($check_args) {
19    my $args = $c[4] ? [ @DB::args ] : undef;
20    push @c, $args;
21   }
22   push @stack, \@c;
23  }
24  return \@stack;
25 }
26
27 my @stacks;
28
29 sub three {
30  my ($depth, $code) = @_;
31  $stacks[0] = callstack(1);
32  &uplevel($code, 'three', CALLER($depth));
33 }
34
35 my $two = sub {
36  $stacks[1] = callstack(1);
37  three(@_, 'two');
38 };
39
40 sub one {
41  $stacks[2] = callstack(1);
42  $two->(@_, 'one');
43 }
44
45 sub tester_sub { callstack(1) }
46
47 my $tester_anon = sub { callstack(1) };
48
49 my @subs = (\&three, $two, \&one);
50
51 for my $height (0 .. 2) {
52  my $base = $subs[$height];
53
54  for my $anon (0, 1) {
55   my $code = $anon ? $tester_anon : \&tester_sub;
56
57   for my $depth (0 .. $height) {
58    my $desc = "callstack at depth $depth/$height";
59    $desc .= $anon ? ' (anonymous callback)' : ' (named callback)';
60
61    local $@;
62    my $result = eval { $base->($depth, $code, 'zero') };
63    is        $@,    '',                "$desc: no error";
64    is_deeply $result, $stacks[$depth], "$desc: correct call stack";
65   }
66  }
67 }
68
69 sub four {
70  my $cb = shift;
71  &uplevel($cb, 1, HERE);
72 }
73
74 {
75  my $desc = "recalling in the coderef passed to uplevel (anonymous)";
76  my $cb;
77  $cb = sub { $_[0] ? $cb->(0) : callstack(0) };
78  local $@;
79  my ($expected, $got) = eval { $cb->(1), four($cb) };
80  is $@, '', "$desc: no error";
81  $expected->[1]->[3] = 'main::four';
82  is_deeply $got, $expected, "$desc: correct call stack";
83 }
84
85 sub test_named_recall { $_[0] ? test_named_recall(0) : callstack(0) }
86
87 {
88  my $desc = "recalling in the coderef passed to uplevel (named)";
89  local $@;
90  my ($expected, $got) = eval { test_named_recall(1),four(\&test_named_recall) };
91  is $@, '', "$desc: no error";
92  $expected->[1]->[3] = 'main::four';
93  is_deeply $got, $expected, "$desc: correct call stack";
94 }
95
96 my $mixed_recall_1;
97 sub test_mixed_recall_1 {
98  if ($_[0]) {
99   $mixed_recall_1->(0)
100  } else {
101   callstack(0)
102  }
103 }
104 $mixed_recall_1 = \&test_mixed_recall_1;
105
106 {
107  my $desc = "recalling in the coderef passed to uplevel (mixed 1)";
108  local $@;
109  my ($expected, $got) = eval { test_mixed_recall_1(1), four($mixed_recall_1) };
110  is $@, '', "$desc: no error";
111  $expected->[1]->[3] = 'main::four';
112  is_deeply $got, $expected, "$desc: correct call stack";
113 }
114
115 my $mixed_recall_2_bis = do {
116  my $mixed_recall_2;
117
118  {
119   my $fake1;
120
121   eval q{
122    my $fake2;
123
124    {
125     my $fake3;
126
127     sub test_mixed_recall_2 {
128      $fake1++;
129      $fake2++;
130      $fake3++;
131      if ($_[0]) {
132       $mixed_recall_2->(0)
133      } else {
134       callstack(0)
135      }
136     }
137    }
138   };
139  }
140
141  $mixed_recall_2 = \&test_mixed_recall_2;
142 };
143
144 {
145  my $desc = "recalling in the coderef passed to uplevel (mixed 2)";
146  local $@;
147  my ($expected, $got) = eval { test_mixed_recall_2(1), four($mixed_recall_2_bis) };
148  is $@, '', "$desc: no error";
149  $expected->[1]->[3] = 'main::four';
150  is_deeply $got, $expected, "$desc: correct call stack";
151 }