Implement uplevel()

[perl/modules/Scope-Upper.git] / t / 64-uplevel-caller.t

diff --git a/t/64-uplevel-caller.t b/t/64-uplevel-caller.t
new file mode 100644 (file)
index 0000000..50a44d7
--- /dev/null
+++ b/t/64-uplevel-caller.t
@@ -0,0 +1,151 @@
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => ((3 * 4) / 2) * 2 * 2 + 8;
+
+use Scope::Upper qw<uplevel HERE CALLER>;
+
+sub callstack {
+ my ($check_args) = @_;
+ my $i = 1;
+ my @stack;
+ while (1) {
+  my @c = $check_args ? do { package DB; caller($i++) }
+                      : caller($i++);
+  last unless @c;
+  if ($check_args) {
+   my $args = $c[4] ? [ @DB::args ] : undef;
+   push @c, $args;
+  }
+  push @stack, \@c;
+ }
+ return \@stack;
+}
+
+my @stacks;
+
+sub three {
+ my ($depth, $code) = @_;
+ $stacks[0] = callstack(1);
+ &uplevel($code, 'three', CALLER($depth));
+}
+
+my $two = sub {
+ $stacks[1] = callstack(1);
+ three(@_, 'two');
+};
+
+sub one {
+ $stacks[2] = callstack(1);
+ $two->(@_, 'one');
+}
+
+sub tester_sub { callstack(1) }
+
+my $tester_anon = sub { callstack(1) };
+
+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) {
+   my $desc = "callstack at depth $depth/$height";
+   $desc .= $anon ? ' (anonymous callback)' : ' (named callback)';
+
+   local $@;
+   my $result = eval { $base->($depth, $code, 'zero') };
+   is        $@,    '',                "$desc: no error";
+   is_deeply $result, $stacks[$depth], "$desc: correct call stack";
+  }
+ }
+}
+
+sub four {
+ my $cb = shift;
+ &uplevel($cb, 1, HERE);
+}
+
+{
+ my $desc = "recalling in the coderef passed to uplevel (anonymous)";
+ my $cb;
+ $cb = sub { $_[0] ? $cb->(0) : callstack(0) };
+ local $@;
+ my ($expected, $got) = eval { $cb->(1), four($cb) };
+ is $@, '', "$desc: no error";
+ $expected->[1]->[3] = 'main::four';
+ is_deeply $got, $expected, "$desc: correct call stack";
+}
+
+sub test_named_recall { $_[0] ? test_named_recall(0) : callstack(0) }
+
+{
+ my $desc = "recalling in the coderef passed to uplevel (named)";
+ local $@;
+ my ($expected, $got) = eval { test_named_recall(1),four(\&test_named_recall) };
+ is $@, '', "$desc: no error";
+ $expected->[1]->[3] = 'main::four';
+ is_deeply $got, $expected, "$desc: correct call stack";
+}
+
+my $mixed_recall_1;
+sub test_mixed_recall_1 {
+ if ($_[0]) {
+  $mixed_recall_1->(0)
+ } else {
+  callstack(0)
+ }
+}
+$mixed_recall_1 = \&test_mixed_recall_1;
+
+{
+ my $desc = "recalling in the coderef passed to uplevel (mixed 1)";
+ local $@;
+ my ($expected, $got) = eval { test_mixed_recall_1(1), four($mixed_recall_1) };
+ is $@, '', "$desc: no error";
+ $expected->[1]->[3] = 'main::four';
+ is_deeply $got, $expected, "$desc: correct call stack";
+}
+
+my $mixed_recall_2_bis = do {
+ my $mixed_recall_2;
+
+ {
+  my $fake1;
+
+  eval q{
+   my $fake2;
+
+   {
+    my $fake3;
+
+    sub test_mixed_recall_2 {
+     $fake1++;
+     $fake2++;
+     $fake3++;
+     if ($_[0]) {
+      $mixed_recall_2->(0)
+     } else {
+      callstack(0)
+     }
+    }
+   }
+  };
+ }
+
+ $mixed_recall_2 = \&test_mixed_recall_2;
+};
+
+{
+ my $desc = "recalling in the coderef passed to uplevel (mixed 2)";
+ local $@;
+ my ($expected, $got) = eval { test_mixed_recall_2(1), four($mixed_recall_2_bis) };
+ is $@, '', "$desc: no error";
+ $expected->[1]->[3] = 'main::four';
+ is_deeply $got, $expected, "$desc: correct call stack";
+}