t/69-uplevel-threads.t

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