1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
|
#!perl -T
use strict;
use warnings;
use Test::More tests => 3 + 7 * 2 + 8;
use Scope::Upper qw<uplevel HERE UP>;
sub depth {
my $depth = 0;
while (1) {
my @c = caller($depth);
last unless @c;
++$depth;
}
return $depth - 1;
}
is depth(), 0, 'check top depth';
is sub { depth() }->(), 1, 'check subroutine call depth';
is do { local $@; eval { depth() } }, 1, 'check eval block depth';
{
my $desc = 'uplevel in uplevel : lower frame';
local $@;
my @ret = eval {
1, sub {
is depth(), 2, "$desc: correct depth 1";
2, uplevel(sub {
is depth(), 2, "$desc: correct depth 2";
3, sub {
is depth(), 3, "$desc: correct depth 3";
4, uplevel(sub {
is depth(), 3, "$desc: correct depth 4";
return 5, @_;
}, 6, @_, HERE);
}->(7, @_);
}, 8, @_, HERE);
}->(9);
};
is $@, '', "$desc: no error";
is depth(), 0, "$desc: correct depth outside";
is_deeply \@ret, [ 1 .. 9 ], "$desc: correct return value"
}
{
my $desc = 'uplevel in uplevel : same frame';
local $@;
my @ret = eval {
11, sub {
is depth(), 2, "$desc: correct depth 1";
12, uplevel(sub {
is depth(), 2, "$desc: correct depth 2";
13, sub {
is depth(), 3, "$desc: correct depth 3";
14, uplevel(sub {
is depth(), 2, "$desc: correct depth 4";
return 15, @_;
}, 16, @_, UP);
}->(17, @_);
}, 18, @_, HERE);
}->(19);
};
is $@, '', "$desc: no error";
is depth(), 0, "$desc: correct depth outside";
is_deeply \@ret, [ 11 .. 19 ], "$desc: correct return value"
}
{
my $desc = 'uplevel in uplevel : higher frame';
local $@;
my @ret = eval {
20, sub {
is depth(), 2, "$desc: correct depth 1";
21, sub {
is depth(), 3, "$desc: correct depth 2";
22, uplevel(sub {
is depth(), 3, "$desc: correct depth 3";
23, sub {
is depth(), 4, "$desc: correct depth 4";
24, uplevel(sub {
is depth(), 2, "$desc: correct depth 5";
return 25, @_;
}, 26, @_, UP UP);
}->(27, @_);
}, 28, @_, HERE);
}->(29, @_);
}->('2A');
};
is $@, '', "$desc: no error";
is depth(), 0, "$desc: correct depth outside";
is_deeply \@ret, [ 20 .. 29, '2A' ], "$desc: correct return value"
}
|
