6 use Test::More tests => ((3 * 4) / 2) * 2 * 2 + 8;
8 use Scope::Upper qw<uplevel HERE CALLER>;
11 my ($check_args) = @_;
15 my @c = $check_args ? do { package DB; caller($i++) }
19 my $args = $c[4] ? [ @DB::args ] : undef;
30 my ($depth, $code) = @_;
31 $stacks[0] = callstack(1);
32 &uplevel($code, 'three', CALLER($depth));
36 $stacks[1] = callstack(1);
41 $stacks[2] = callstack(1);
45 sub tester_sub { callstack(1) }
47 my $tester_anon = sub { callstack(1) };
49 my @subs = (\&three, $two, \&one);
51 for my $height (0 .. 2) {
52 my $base = $subs[$height];
55 my $code = $anon ? $tester_anon : \&tester_sub;
57 for my $depth (0 .. $height) {
58 my $desc = "callstack at depth $depth/$height";
59 $desc .= $anon ? ' (anonymous callback)' : ' (named callback)';
62 my $result = eval { $base->($depth, $code, 'zero') };
63 is $@, '', "$desc: no error";
64 is_deeply $result, $stacks[$depth], "$desc: correct call stack";
71 &uplevel($cb, 1, HERE);
75 my $desc = "recalling in the coderef passed to uplevel (anonymous)";
77 $cb = sub { $_[0] ? $cb->(0) : callstack(0) };
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";
85 sub test_named_recall { $_[0] ? test_named_recall(0) : callstack(0) }
88 my $desc = "recalling in the coderef passed to uplevel (named)";
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";
97 sub test_mixed_recall_1 {
104 $mixed_recall_1 = \&test_mixed_recall_1;
107 my $desc = "recalling in the coderef passed to uplevel (mixed 1)";
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";
115 my $mixed_recall_2_bis = do {
127 sub test_mixed_recall_2 {
141 $mixed_recall_2 = \&test_mixed_recall_2;
145 my $desc = "recalling in the coderef passed to uplevel (mixed 2)";
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";