]> git.vpit.fr Git - perl/modules/Scope-Upper.git/blob - t/69-uplevel-threads.t
Require Module::ExtractUse 0.24 for the Kwalitee test
[perl/modules/Scope-Upper.git] / 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);