--- /dev/null
+#!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";
+ }
+ }
+ }->();
+}
projects / perl / modules / Scope-Upper.git / blobdiff