Test that goto-to-uplevel does not mess up returned values

[perl/modules/Scope-Upper.git] / t / 61-uplevel-args.t

diff --git a/t/61-uplevel-args.t b/t/61-uplevel-args.t
index d4ee2edde3bd5829735a1a844776689e2071d2cf..59a9071fe0e5370d6671680781959ce2a664de5c 100644 (file)
--- 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 + 2 + 6;
+use Test::More tests => 9 + 4 * 7 + 3 + ((5 * 4 * 4) * 3 + 1) + 2 + 6;
 
 use Scope::Upper qw<uplevel HERE>;
 
@@ -11,37 +11,38 @@ use Scope::Upper qw<uplevel HERE>;
 
 sub {
  uplevel { pass 'no @_: callback' };
- is_deeply \@_, [ 'dummy' ], 'no @_: @_ outside';
+ is "@_", 'dummy', 'no @_: @_ outside';
 }->('dummy');
 
 sub {
- uplevel { is_deeply \@_, [ ], "no arguments, no context" }
+ uplevel { is "@_", '', "no arguments, no context" }
 }->('dummy');
 
 sub {
- uplevel { is_deeply \@_, [ ], "no arguments, with context" } HERE
+ uplevel { is "@_", '', "no arguments, with context" } HERE
 }->('dummy');
 
 sub {
- uplevel { is_deeply \@_, [ 1 ], "one const argument" } 1, HERE
+ uplevel { is "@_", '1', "one const argument" } 1, HERE
 }->('dummy');
 
 my $x = 2;
 sub {
- uplevel { is_deeply \@_, [ 2 ], "one lexical argument" } $x, HERE
+ uplevel { is "@_", '2', "one lexical argument" } $x, HERE
 }->('dummy');
 
 our $y = 3;
 sub {
- uplevel { is_deeply \@_, [ 3 ], "one global argument" } $y, HERE
+ uplevel { is "@_", '3', "one global argument" } $y, HERE
 }->('dummy');
 
 sub {
- uplevel { is_deeply \@_, [ 4, 5 ], "two const arguments" } 4, 5, HERE
+ uplevel { is "@_", '4 5', "two const arguments" } 4, 5, HERE
 }->('dummy');
 
 sub {
- uplevel { is_deeply \@_, [ 1 .. 10 ], "ten const arguments" } 1 .. 10, HERE
+ uplevel { is "@_", '1 2 3 4 5 6 7 8 9 10', "ten const arguments" }
+         1 .. 10 => HERE;
 }->('dummy');
 
 # Reification of @_
@@ -144,6 +145,94 @@ sub {
  is $s, 'xyz', 'aliasing, two layers 2';
 }->('dummy');
 
+# goto
+
+SKIP: {
+ if ("$]" < 5.008) {
+  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";
+  skip "goto to an uplevel'd stack frame does not work on perl 5\.6"
+                                                   => ((5 * 4 * 4) * 3 + 1) - 1;
+ }
+
+ my @args = (
+  [ [ ],          [ 'm' ]      ],
+  [ [ 'a' ],      [ ]          ],
+  [ [ 'b' ],      [ 'n' ]      ],
+  [ [ 'c' ],      [ 'o', 'p' ] ],
+  [ [ 'd', 'e' ], [ 'q' ]      ],
+ );
+
+ for my $args (@args) {
+  my ($out, $in) = @$args;
+
+  my @out  = @$out;
+  my @in   = @$in;
+
+  for my $reify_out (0, 1) {
+   for my $reify_in (0, 1) {
+    my $desc;
+
+    my $base_test = sub {
+     if ($reify_in) {
+      is_deeply \@_, $in, "$desc: \@_ inside";
+     } else {
+      is "@_", "@in", "$desc: \@_ inside";
+     }
+    };
+
+    my $goto_test         = sub { goto $base_test };
+    my $uplevel_test      = sub { &uplevel($base_test, @_, HERE) };
+    my $goto_uplevel_test = sub { &uplevel($goto_test, @_, HERE) };
+
+    my @tests = (
+     [ 'goto'                    => sub { goto $base_test }         ],
+     [ 'goto in goto'            => sub { goto $goto_test }         ],
+     [ 'uplevel in goto'         => sub { goto $uplevel_test }      ],
+     [ 'goto in uplevel in goto' => sub { goto $goto_uplevel_test } ],
+    );
+
+    for my $test (@tests) {
+     ($desc, my $cb) = @$test;
+     $desc .= ' (' . @out . ' out, ' . @in . ' in';
+     $desc .= ', reify out' if $reify_out;
+     $desc .= ', reify in'  if $reify_in;
+     $desc .= ')';
+
+     local $@;
+     eval {
+      sub {
+       &uplevel($cb, @in, HERE);
+       if ($reify_out) {
+        is_deeply \@_, $out, "$desc: \@_ outside";
+       } else {
+        is "@_", "@out", "$desc: \@_ outside";
+       }
+      }->(@out);
+     };
+     is $@, '', "$desc: no error";
+    }
+   }
+  }
+ }
+
+ sub {
+  my $s  = 'caesar';
+  my $cb = sub {
+   $_[0] = 'brutus';
+  };
+  sub {
+   uplevel {
+    goto $cb;
+   } $_[0], HERE;
+  }->($s);
+  is $s, 'brutus', 'aliasing and goto';
+ }->('dummy');
+}
+
 # Magic
 
 {