X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=t%2F61-uplevel-args.t;h=8a81c21cc17864206acd6e8613982d3e1c7d15b7;hb=eef3f2764e7018e3eaf2f1d11f249b510d023a2d;hp=f6955adfbf821339eb798ef3ee8b3c9ffdfd67b9;hpb=44b173f9220cfdd1afd01ae4baf414f885d2f0b2;p=perl%2Fmodules%2FScope-Upper.git

diff --git a/t/61-uplevel-args.t b/t/61-uplevel-args.t
index f6955ad..8a81c21 100644
--- a/t/61-uplevel-args.t
+++ b/t/61-uplevel-args.t
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 9 + 4 * 7 + 3 + ((5 * 4 * 4) * 3 + 1) + 3 + 2 + 6;
+use Test::More tests => 9 + 4 * 7 + 3 + ((5 * 4 * 4) * 3 + 1) + 5 + 3 + 2 + 6;
 
 use Scope::Upper qw<uplevel HERE UP>;
 
@@ -149,11 +149,11 @@ sub {
 
 SKIP: {
  if ("$]" < 5.008) {
-  my $cb = sub { fail "should not be executed" };
+  my $cb = sub { fail 'should not be executed' };
   local $@;
   eval { sub { uplevel { goto $cb } HERE }->() };
-  like $@, qr/^Can't goto to an uplevel'd stack frame on perl 5\.6/,
-           "goto croaks";
+  like $@, qr/^uplevel\(\) can't execute code that calls goto before perl 5\.8/,
+           'goto croaks';
   skip "goto to an uplevel'd stack frame does not work on perl 5\.6"
                                                    => ((5 * 4 * 4) * 3 + 1) - 1;
  }
@@ -233,6 +233,39 @@ SKIP: {
  }->('dummy');
 }
 
+# goto XS
+
+SKIP: {
+ skip "goto to an uplevel'd stack frame does not work on perl 5\.6" => 5
+                                                                if "$]" < 5.008;
+
+ my $desc = 'uplevel() calling goto &uplevel';
+ local $@;
+ eval {
+  sub {
+   my $outer_cxt = HERE;
+   sub {
+    my $inner_cxt = HERE;
+    sub {
+     uplevel {
+      is HERE, $inner_cxt, "$desc: context inside first uplevel";
+      is "@_", '1 2 3',    "$desc: arguments inisde first uplevel";
+      unshift @_, 0;
+      push    @_, 4;
+      unshift @_, sub {
+       is HERE, $outer_cxt,  "$desc: context inside second uplevel";
+       is "@_", '0 1 2 3 4', "$desc: arguments inisde second uplevel";
+      };
+      push @_, UP;
+      goto \&uplevel;
+     } 1 .. 3 => UP;
+    }->();
+   }->();
+  }->();
+ };
+ is $@, '', "$desc: no error";
+}
+
 # uplevel() to uplevel()
 
 {