t/69-uplevel-threads.t

   1 #!perl -T
   2
   3 use strict;
   4 use warnings;
   5
   6 use lib 't/lib';
   7 use Scope::Upper::TestThreads;
   8
   9 use Test::Leaner;
  10
  11 use Scope::Upper qw<uplevel UP>;
  12
  13 sub depth {
  14  my $depth = 0;
  15  while (1) {
  16   my @c = caller($depth);
  17   last unless @c;
  18   ++$depth;
  19  }
  20  return $depth - 1;
  21 }
  22
  23 is depth(),                           0, 'check top depth';
  24 is sub { depth() }->(),               1, 'check subroutine call depth';
  25 is do { local $@; eval { depth() } }, 1, 'check eval block depth';
  26
  27 our $z;
  28
  29 sub cb {
  30  my $d   = splice @_, 1, 1;
  31  my $p   = shift;
  32  my $tid = pop;
  33  is depth(), $d - 1, "$p: correct depth inside";
  34  $tid, @_, $tid + 2
  35 }
  36
  37 sub up1 {
  38  my $tid  = threads->tid();
  39  local $z = $tid;
  40  my $p    = "[$tid] up1";
  41
  42  usleep rand(1e6);
  43
  44  my @res = (
  45   -2,
  46   sub {
  47    my @dummy = (
  48     -1,
  49     sub {
  50      my $d = depth();
  51      my @ret = &uplevel(\&cb => ($p, $d, $tid + 1, $tid) => UP);
  52      is depth(), $d, "$p: correct depth after uplevel";
  53      @ret;
  54     }->(),
  55     1
  56    );
  57   }->(),
  58   2
  59  );
  60
  61  is_deeply \@res, [ -2, -1, $tid .. $tid + 2, 1, 2 ], "$p: returns correctly";
  62 }
  63
  64 my @threads = map spawn(\&up1), 1 .. 30;
  65
  66 $_->join for @threads;
  67
  68 done_testing(3 + scalar(@threads) * 3);