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
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
|
#!perl -T
use strict;
use warnings;
use Test::More tests => 2 * 32 + 2 * 21;
use Scope::Upper qw<uplevel uid validate_uid UP>;
for my $run (1, 2) {
sub {
my $above_uid = uid;
my $there = "in the sub above the target (run $run)";
my $uplevel_uid = sub {
my $target_uid = uid;
my $there = "in the target sub (run $run)";
my $uplevel_uid = sub {
my $between_uid = uid;
my $there = "in the sub between the target and the source (run $run)";
my $uplevel_uid = sub {
my $source_uid = uid;
my $there = "in the source sub (run $run)";
my $uplevel_uid = uplevel {
my $uplevel_uid = uid;
my $there = "in the uplevel callback (run $run)";
my $invalid = 'temporarily invalid';
ok validate_uid($uplevel_uid), "\$uplevel_uid is valid $there";
ok !validate_uid($source_uid), "\$source_uid is $invalid $there";
ok !validate_uid($between_uid), "\$between_uid is $invalid $there";
ok !validate_uid($target_uid), "\$target_uid is $invalid $there";
ok validate_uid($above_uid), "\$above_uid is valid $there";
isnt $uplevel_uid, $source_uid, "\$uplevel_uid != \$source_uid $there";
isnt $uplevel_uid, $between_uid, "\$uplevel_uid != \$between_uid $there";
isnt $uplevel_uid, $target_uid, "\$uplevel_uid != \$target_uid $there";
isnt $uplevel_uid, $above_uid, "\$uplevel_uid != \$above_uid $there";
{
my $here = uid;
isnt $here, $source_uid, "\$here != \$source_uid in block $there";
isnt $here, $between_uid, "\$here != \$between_uid in block $there";
isnt $here, $target_uid, "\$here != \$target_uid in block $there";
isnt $here, $above_uid, "\$here != \$above_uid in block $there";
}
is uid(UP), $above_uid, "uid(UP) == \$above_uid $there";
return $uplevel_uid;
} UP UP;
ok !validate_uid($uplevel_uid), "\$uplevel_uid is no longer valid $there";
ok validate_uid($source_uid), "\$source_uid is valid again $there";
ok validate_uid($between_uid), "\$between_uid is valid again $there";
ok validate_uid($target_uid), "\$target_uid is valid again $there";
ok validate_uid($above_uid), "\$above_uid is still valid $there";
return $uplevel_uid;
}->();
ok !validate_uid($uplevel_uid), "\$uplevel_uid is no longer valid $there";
ok validate_uid($between_uid), "\$between_uid is valid again $there";
ok validate_uid($target_uid), "\$target_uid is valid again $there";
ok validate_uid($above_uid), "\$above_uid is still valid $there";
return $uplevel_uid;
}->();
ok !validate_uid($uplevel_uid), "\$uplevel_uid is no longer valid $there";
ok validate_uid($target_uid), "\$target_uid is valid again $there";
ok validate_uid($above_uid), "\$above_uid is still valid $there";
return $uplevel_uid;
}->();
ok !validate_uid($uplevel_uid), "\$uplevel_uid is no longer valid $there";
ok validate_uid($above_uid), "\$above_uid is still valid $there";
sub {
my $here = uid;
my $there = "in a new sub at replacing the target";
ok !validate_uid($uplevel_uid), "\$uplevel_uid is no longer valid $there";
ok validate_uid($above_uid), "\$above_uid is still valid $there";
isnt $here, $uplevel_uid, "\$here != \$uplevel_uid $there";
is uid(UP), $above_uid, "uid(UP) == \$above_uid $there";
}->();
}->();
}
for my $run (1, 2) {
sub {
my $first_sub = uid;
my $there = "in the first sub (run $run)";
my $invalid = 'temporarily invalid';
uplevel {
my $first_uplevel = uid;
my $there = "in the first uplevel (run $run)";
ok !validate_uid($first_sub), "\$first_sub is $invalid $there";
ok validate_uid($first_uplevel), "\$first_uplevel is valid $there";
isnt $first_uplevel, $first_sub, "\$first_uplevel != \$first_sub $there";
isnt uid(UP), $first_sub, "uid(UP) != \$first_sub $there";
my ($second_sub, $second_uplevel) = sub {
my $second_sub = uid;
my $there = "in the second sub (run $run)";
my $second_uplevel = uplevel {
my $second_uplevel = uid;
my $there = "in the second uplevel (run $run)";
ok !validate_uid($first_sub), "\$first_sub is $invalid $there";
ok validate_uid($first_uplevel), "\$first_uplevel is valid $there";
ok !validate_uid($second_sub), "\$second_sub is $invalid $there";
ok validate_uid($second_uplevel), "\$second_uplevel is valid $there";
isnt $second_uplevel, $second_sub,
"\$second_uplevel != \$second_sub $there";
is uid(UP), $first_uplevel, "uid(UP) == \$first_uplevel $there";
return $second_uplevel;
};
return $second_sub, $second_uplevel;
}->();
ok validate_uid($first_uplevel), "\$first_uplevel is still valid $there";
ok !validate_uid($second_sub), "\$second_sub is no longer valid $there";
ok !validate_uid($second_uplevel),
"\$second_uplevel is no longer valid $there";
uplevel {
my $third_uplevel = uid;
my $there = "in the third uplevel (run $run)";
ok !validate_uid($first_uplevel), "\$first_uplevel is $invalid $there";
ok !validate_uid($second_sub), "\$second_sub is no longer valid $there";
ok !validate_uid($second_uplevel),
"\$second_uplevel is no longer valid $there";
ok validate_uid($third_uplevel), "\$third_uplevel is valid $there";
isnt $third_uplevel, $first_uplevel,
"\$third_uplevel != \$first_uplevel $there";
isnt $third_uplevel, $second_sub, "\$third_uplevel != \$second_sub $there";
isnt $third_uplevel, $second_uplevel,
"\$third_uplevel != \$second_uplevel $there";
isnt uid(UP), $first_sub, "uid(UP) != \$first_sub $there";
}
}
}->();
}
|
