t/86-stress-uplevel.t

   1 #!perl -T
   2
   3 use strict;
   4 use warnings;
   5
   6 use lib 't/lib';
   7 use Test::Leaner;
   8
   9 use Scope::Upper qw<uplevel HERE UP SUB CALLER>;
  10
  11 my $n = 1_000;
  12
  13 plan tests => 3 + $n * (6 + 3);
  14
  15 my $period1 = 100;
  16 my $period2 = 10;
  17 my $shift   = 10;
  18 my $amp     = 10;
  19
  20 sub PI () { CORE::atan2(0, -1) }
  21
  22 sub depth {
  23  my $depth = 0;
  24  while (1) {
  25   my @c = caller($depth);
  26   last unless @c;
  27   ++$depth;
  28  }
  29  return $depth - 1;
  30 }
  31
  32 sub cap {
  33  my ($depth, $top) = @_;
  34
  35  $depth <= 0 ? 1
  36              : $depth >= $top ? $top - 1
  37                               : $depth;
  38 }
  39
  40 sub base_depth {
  41  cap($shift + int($amp * sin(2 * PI * $_[0] / $period1)), 2 * $shift + 1);
  42 }
  43
  44 sub uplevel_depth {
  45  my ($base_depth, $i) = @_;
  46
  47  my $h = int($base_depth / 2);
  48
  49  cap($h + int($h * sin(2 * PI * $i / $period2)), $base_depth);
  50 }
  51
  52 sub rec_basic {
  53  my ($base_depth, $uplevel_depth, $desc, $i) = @_;
  54  if ($i < $base_depth) {
  55   $i, rec_basic($base_depth, $uplevel_depth, $desc, $i + 1);
  56  } else {
  57   is depth(), $base_depth+1, "$desc: depth before uplevel";
  58   my $ret = uplevel {
  59    is depth(), $base_depth+1-$uplevel_depth, "$desc: depth inside uplevel";
  60    is "@_", "$base_depth $uplevel_depth",  "$desc: arguments";
  61    -$uplevel_depth;
  62   } @_[0, 1], CALLER($uplevel_depth);
  63   is depth(), $base_depth+1, "$desc: depth after uplevel";
  64   $ret;
  65  }
  66 }
  67
  68 sub rec_die {
  69  my ($base_depth, $uplevel_depth, $desc, $i) = @_;
  70  if ($i < $base_depth) {
  71   local $@;
  72   my $ret;
  73   if ($i % 2) {
  74    $ret = eval q<
  75     rec_die($base_depth, $uplevel_depth, $desc, $i + 1)
  76    >
  77   } else {
  78    $ret = eval {
  79     rec_die($base_depth, $uplevel_depth, $desc, $i + 1)
  80    }
  81   }
  82   return $@ ? $@
  83             : $ret ? $ret
  84                    : undef;
  85  } else {
  86   my $cxt = SUB;
  87   {
  88    my $n = $uplevel_depth;
  89    while ($n) {
  90     $cxt = SUB UP $cxt;
  91     $n--;
  92    }
  93   }
  94   my $ret = uplevel {
  95    is HERE, $cxt, "$desc: context inside uplevel";
  96    die "XXX @_";
  97   } @_[0, 1], $cxt;
  98   $ret;
  99  }
 100 }
 101
 102 my $die_line = __LINE__-6;
 103
 104 is depth(),                           0, 'check top depth';
 105 is sub { depth() }->(),               1, 'check subroutine call depth';
 106 is do { local $@; eval { depth() } }, 1, 'check eval block depth';
 107
 108 for my $i (1 .. $n) {
 109  my $base_depth    = base_depth($i);
 110  my $uplevel_depth = uplevel_depth($base_depth, $i);
 111
 112  {
 113   my $desc = "basic $base_depth $uplevel_depth";
 114
 115   my @ret = rec_basic($base_depth, $uplevel_depth, $desc, 0);
 116   is depth(), 0, "$desc: depth outside";
 117   is_deeply \@ret, [ 0 .. $base_depth-1, -$uplevel_depth ],
 118                                                        "$desc: returned values";
 119  }
 120
 121  {
 122   ++$base_depth;
 123   my $desc = "die $base_depth $uplevel_depth";
 124
 125   my $err = rec_die($base_depth, $uplevel_depth, $desc, 0);
 126   is depth(), 0, "$desc: depth outside";
 127   like $err, qr/^XXX $base_depth $uplevel_depth at \Q$0\E line $die_line/,
 128                                                          "$desc: correct error";
 129  }
 130 }