X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=t%2F60-uplevel-target.t;h=87444ba701299b695bd5c26f26096a04ccf5eafb;hb=76f7748a793b1d04798c743cc70b46a1bf657300;hp=246af7b351913f70ac67a1fb4a74cdc1e5b1ca1f;hpb=c85df5478ff2d9380ee42b0e5a70461d063745d6;p=perl%2Fmodules%2FScope-Upper.git

diff --git a/t/60-uplevel-target.t b/t/60-uplevel-target.t
index 246af7b..87444ba 100644
--- a/t/60-uplevel-target.t
+++ b/t/60-uplevel-target.t
@@ -3,7 +3,8 @@
 use strict;
 use warnings;
 
-use Test::More tests => (1 * 3 + 2 * 4 + 3 * 5) * 2 + 7 + 5 + 6 + 5 + 6;
+use Test::More
+             tests => (1 * 3 + 2 * 4 + 3 * 5) * 2 + 7 + 7 + (5 + 6 + 5 + 6 + 5);
 
 use Scope::Upper qw<uplevel HERE UP TOP>;
 
@@ -120,6 +121,39 @@ sub four {
  like $@, qr/^Can't uplevel to an eval frame/, "$desc: dies";
 }
 
+# XS
+
+{
+ my $desc = 'uplevel to XS 1';
+ local $@;
+ eval {
+  sub {
+   my $cxt = HERE;
+   pass "$desc: before";
+   &uplevel(\&HERE => $cxt);
+   is HERE, $cxt, "$desc: after";
+  }->();
+ };
+ is $@, '', "$desc: no error";
+}
+
+{
+ my $desc = 'uplevel to XS 1';
+ local $@;
+ eval {
+  sub {
+   my $up = HERE;
+   sub {
+    is UP, $up, "$desc: before";
+    &uplevel(\&HERE => $up);
+    isnt HERE, $up, "$desc: after 1";
+   }->();
+   is HERE, $up, "$desc: after 2";
+  }->();
+ };
+ is $@, '', "$desc: no error";
+}
+
 # Target destruction
 
 {
@@ -226,7 +260,9 @@ sub four {
   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 = 'code destruction';
@@ -237,6 +273,7 @@ sub four {
     ++$lexical;
     is $destroyed, 0, "$desc: not yet 1";
    };
+   $code = bless $code, 'Scope::Upper::TestCodeDestruction';
 
    eval {
     sub {
@@ -251,6 +288,34 @@ sub four {
    is $destroyed, 0,  "$desc: not yet 3";
   };
 
-  is $destroyed, 0,  "$desc: code is destroyed";
+  is $destroyed, 1, "$desc: code is destroyed";
+ }
+
+ SKIP: {
+  skip 'This fails even with a plain subroutine call on 5.8.x' => 5
+                                                                if "$]" < 5.009;
+  local $@;
+  local $destroyed = 0;
+  my $desc = 'code destruction and goto';
+
+  {
+   my $lexical = 0;
+   my $cb = sub {
+    ++$lexical;
+    is $destroyed, 0, "$desc: not yet 1";
+   };
+   $cb = bless $cb, 'Scope::Upper::TestCodeDestruction';
+
+   eval {
+    sub {
+     &uplevel(sub { goto $cb } => HERE);
+     is $destroyed, 0, "$desc: not yet 2";
+    }->();
+   };
+   is $@,         '', "$desc: no error";
+   is $destroyed, 0,  "$desc: not yet 3";
+  }
+
+  is $destroyed, 1, "$desc: code is destroyed";
  }
 }