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