#!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";
}
}
}->();
}