t/64-uplevel-caller.t

   1 #!perl -T
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More tests => ((3 * 4) / 2) * 2 * 2 + 8;
   7
   8 use Scope::Upper qw<uplevel HERE CALLER>;
   9
  10 sub callstack {
  11  my ($check_args) = @_;
  12  my $i = 1;
  13  my @stack;
  14  while (1) {
  15   my @c = $check_args ? do { package DB; caller($i++) }
  16                       : caller($i++);
  17   last unless @c;
  18   if ($check_args) {
  19    my $args = $c[4] ? [ @DB::args ] : undef;
  20    push @c, $args;
  21   }
  22   push @stack, \@c;
  23  }
  24  return \@stack;
  25 }
  26
  27 my @stacks;
  28
  29 sub three {
  30  my ($depth, $code) = @_;
  31  $stacks[0] = callstack(1);
  32  &uplevel($code, 'three', CALLER($depth));
  33 }
  34
  35 my $two = sub {
  36  $stacks[1] = callstack(1);
  37  three(@_, 'two');
  38 };
  39
  40 sub one {
  41  $stacks[2] = callstack(1);
  42  $two->(@_, 'one');
  43 }
  44
  45 sub tester_sub { callstack(1) }
  46
  47 my $tester_anon = sub { callstack(1) };
  48
  49 my @subs = (\&three, $two, \&one);
  50
  51 for my $height (0 .. 2) {
  52  my $base = $subs[$height];
  53
  54  for my $anon (0, 1) {
  55   my $code = $anon ? $tester_anon : \&tester_sub;
  56
  57   for my $depth (0 .. $height) {
  58    my $desc = "callstack at depth $depth/$height";
  59    $desc .= $anon ? ' (anonymous callback)' : ' (named callback)';
  60
  61    local $@;
  62    my $result = eval { $base->($depth, $code, 'zero') };
  63    is        $@,    '',                "$desc: no error";
  64    is_deeply $result, $stacks[$depth], "$desc: correct call stack";
  65   }
  66  }
  67 }
  68
  69 sub four {
  70  my $cb = shift;
  71  &uplevel($cb, 1, HERE);
  72 }
  73
  74 {
  75  my $desc = "recalling in the coderef passed to uplevel (anonymous)";
  76  my $cb;
  77  $cb = sub { $_[0] ? $cb->(0) : callstack(0) };
  78  local $@;
  79  my ($expected, $got) = eval { $cb->(1), four($cb) };
  80  is $@, '', "$desc: no error";
  81  $expected->[1]->[3] = 'main::four';
  82  is_deeply $got, $expected, "$desc: correct call stack";
  83 }
  84
  85 sub test_named_recall { $_[0] ? test_named_recall(0) : callstack(0) }
  86
  87 {
  88  my $desc = "recalling in the coderef passed to uplevel (named)";
  89  local $@;
  90  my ($expected, $got) = eval { test_named_recall(1),four(\&test_named_recall) };
  91  is $@, '', "$desc: no error";
  92  $expected->[1]->[3] = 'main::four';
  93  is_deeply $got, $expected, "$desc: correct call stack";
  94 }
  95
  96 my $mixed_recall_1;
  97 sub test_mixed_recall_1 {
  98  if ($_[0]) {
  99   $mixed_recall_1->(0)
 100  } else {
 101   callstack(0)
 102  }
 103 }
 104 $mixed_recall_1 = \&test_mixed_recall_1;
 105
 106 {
 107  my $desc = "recalling in the coderef passed to uplevel (mixed 1)";
 108  local $@;
 109  my ($expected, $got) = eval { test_mixed_recall_1(1), four($mixed_recall_1) };
 110  is $@, '', "$desc: no error";
 111  $expected->[1]->[3] = 'main::four';
 112  is_deeply $got, $expected, "$desc: correct call stack";
 113 }
 114
 115 my $mixed_recall_2_bis = do {
 116  my $mixed_recall_2;
 117
 118  {
 119   my $fake1;
 120
 121   eval q{
 122    my $fake2;
 123
 124    {
 125     my $fake3;
 126
 127     sub test_mixed_recall_2 {
 128      $fake1++;
 129      $fake2++;
 130      $fake3++;
 131      if ($_[0]) {
 132       $mixed_recall_2->(0)
 133      } else {
 134       callstack(0)
 135      }
 136     }
 137    }
 138   };
 139  }
 140
 141  $mixed_recall_2 = \&test_mixed_recall_2;
 142 };
 143
 144 {
 145  my $desc = "recalling in the coderef passed to uplevel (mixed 2)";
 146  local $@;
 147  my ($expected, $got) = eval { test_mixed_recall_2(1), four($mixed_recall_2_bis) };
 148  is $@, '', "$desc: no error";
 149  $expected->[1]->[3] = 'main::four';
 150  is_deeply $got, $expected, "$desc: correct call stack";
 151 }