X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=t%2F60-uplevel-target.t;fp=t%2F60-uplevel-target.t;h=6b3a444742fe6a057e2930389e9a3790cc5d26e9;hb=1da764455f3f82a24aad0881beb01f5e4d3cf858;hp=0000000000000000000000000000000000000000;hpb=00eb4513e6dc65546222404eaa0e1c4910587c70;p=perl%2Fmodules%2FScope-Upper.git

diff --git a/t/60-uplevel-target.t b/t/60-uplevel-target.t
new file mode 100644
index 0000000..6b3a444
--- /dev/null
+++ b/t/60-uplevel-target.t
@@ -0,0 +1,228 @@
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => (1 * 3 + 2 * 4 + 3 * 5) * 2 + 7 + 5 + 6 + 5;
+
+use Scope::Upper qw<uplevel HERE UP TOP>;
+
+our ($desc, $target);
+
+my @cxt;
+
+sub three {
+ my ($depth, $code) = @_;
+ $cxt[0] = HERE;
+ $target = $cxt[$depth];
+ &uplevel($code => $target);
+ pass("$desc: reached end of three()");
+}
+
+my $two = sub {
+ $cxt[1] = HERE;
+ three(@_);
+ pass("$desc: reached end of \$two");
+};
+
+sub one {
+ $cxt[2] = HERE;
+ $two->(@_);
+ pass("$desc: reached end of one()");
+}
+
+sub tester_sub {
+ is(HERE, $target, "$desc: right context");
+}
+
+my $tester_anon = sub {
+ is(HERE, $target, "$desc: right context");
+};
+
+my @subs = (\&three, $two, \&one);
+
+for my $height (0 .. 2) {
+ my $base = $subs[$height];
+
+ for my $anon (0, 1) {
+  my $code = $anon ? $tester_anon : \&tester_sub;
+
+  for my $depth (0 .. $height) {
+   local $target;
+   local $desc = "uplevel at depth $depth/$height";
+   $desc .= $anon ? ' (anonymous callback)' : ' (named callback)';
+
+   local $@;
+   eval { $base->($depth, $code) };
+   is $@, '', "$desc: no error";
+  }
+ }
+}
+
+{
+ my $desc = 'uplevel called without a code reference';
+ local $@;
+ eval {
+  three(0, "wut");
+  fail "$desc: uplevel should have croaked";
+ };
+ like $@, qr/^First argument to uplevel must be a code reference/,"$desc: dies";
+}
+
+sub four {
+ my $desc = shift;
+ my $cxt  = HERE;
+ uplevel { is HERE, $cxt, "$desc: right context" };
+ pass "$desc: reached end of four()";
+}
+
+{
+ my $desc = 'uplevel called without a target';
+ local $@;
+ eval {
+  four($desc);
+ };
+ is $@, '', "$desc: no error";
+}
+
+{
+ my $desc = 'uplevel to top';
+ local $@;
+ eval {
+  uplevel sub { fail "$desc: uplevel body should not be executed" }, TOP;
+  fail "$desc: uplevel should have croaked";
+ };
+ like $@, qr/^Can't uplevel outside a subroutine/, "$desc: dies";
+}
+
+{
+ my $desc = 'uplevel to eval 1';
+ local $@;
+ eval {
+  uplevel sub { fail "$desc: uplevel body should not be executed" }, HERE;
+  fail "$desc: uplevel should have croaked";
+ };
+ like $@, qr/^Can't uplevel to an eval frame/, "$desc: dies";
+}
+
+{
+ my $desc = 'uplevel to eval 2';
+ local $@;
+ sub {
+  eval {
+   uplevel {
+    fail "$desc: uplevel body should not be executed"
+   };
+   fail "$desc: uplevel should have croaked";
+  };
+  return;
+ }->();
+ like $@, qr/^Can't uplevel to an eval frame/, "$desc: dies";
+}
+
+# Target destruction
+
+{
+ our $destroyed;
+ sub Scope::Upper::TestCodeDestruction::DESTROY { ++$destroyed }
+
+ {
+  local $@;
+  local $destroyed = 0;
+  my $desc = 'target destruction 1';
+
+  {
+   my $lexical;
+   my $target = sub {
+    my $code = shift;
+    ++$lexical;
+    $code->();
+   };
+   $target = bless $target, 'Scope::Upper::TestCodeDestruction';
+
+   eval {
+    $target->(
+     sub {
+      uplevel {
+       is $destroyed, 0, "$desc: not yet 1";
+      } UP;
+      is $destroyed, 0, "$desc: not yet 2";
+     },
+    );
+   };
+   is $@,         '', "$desc: no error";
+   is $destroyed, 0,  "$desc: not yet 3";
+  }
+
+  is $destroyed, 1, "$desc: target is detroyed";
+ }
+
+ SKIP: {
+  skip 'This fails even with a plain subroutine call on 5.8.x' => 6
+                                                                if "$]" < 5.009;
+  local $@;
+  local $destroyed = 0;
+  my $desc = 'target destruction 2';
+
+  {
+   my $lexical;
+   my $target = sub {
+    my $code = shift;
+    ++$lexical;
+    $code->();
+   };
+   $target = bless $target, 'Scope::Upper::TestCodeDestruction';
+
+   eval {
+    $target->(
+     sub {
+      uplevel {
+       $target->(sub {
+        is $destroyed, 0, "$desc: not yet 1";
+       });
+       is $destroyed, 0, "$desc: not yet 2";
+      } UP;
+      is $destroyed, 0, "$desc: not yet 3";
+     },
+    );
+   };
+   is $@,         '', "$desc: no error";
+   is $destroyed, 0,  "$desc: not yet 4";
+  }
+
+  is $destroyed, 1, "$desc: target is detroyed";
+ }
+
+ {
+  local $@;
+  local $destroyed = 0;
+  my $desc = 'target destruction 3';
+
+  {
+   my $lexical;
+   my $target = sub {
+    ++$lexical;
+    if (@_) {
+     my $code = shift;
+     $code->();
+    } else {
+     is $destroyed, 0, "$desc: not yet 1";
+    }
+   };
+   $target = bless $target, 'Scope::Upper::TestCodeDestruction';
+
+   eval {
+    $target->(
+     sub {
+      &uplevel($target => UP);
+      is $destroyed, 0, "$desc: not yet 2";
+     },
+    );
+   };
+   is $@,         '', "$desc: no error";
+   is $destroyed, 0,  "$desc: not yet 3";
+  }
+
+  is $destroyed, 1, "$desc: target is detroyed";
+ }
+}