]> git.vpit.fr Git - perl/modules/Scope-Upper.git/blob - t/69-uplevel-threads.t
775add33847963c257f367df82d5d04774ce84f5
[perl/modules/Scope-Upper.git] / 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;