t/20-recurse.t

   1 #!perl -T
   2
   3 use strict;
   4 use warnings;
   5
   6 use Config qw/%Config/;
   7
   8 BEGIN {
   9  if (!$Config{useithreads}) {
  10   require Test::More;
  11   Test::More->import;
  12   plan(skip_all => 'This perl wasn\'t built to support threads');
  13  }
  14 }
  15
  16 use threads;
  17 use threads::shared;
  18
  19 my ($num, $depth);
  20 BEGIN {
  21  $num   = 3;
  22  $depth = 2;
  23 }
  24
  25 use Test::More tests => (($num ** ($depth + 1) - 1) / ($num - 1) - 1 ) * (2 + 2) + 1;
  26
  27 BEGIN {
  28  defined and diag "Using threads $_"         for $threads::VERSION;
  29  defined and diag "Using threads::shared $_" for $threads::shared::VERSION;
  30 }
  31
  32 use Thread::Cleanup;
  33
  34 diag 'This will leak some scalars';
  35
  36 our $x = -1;
  37
  38 my %ran    : shared;
  39 my %nums   : shared;
  40 my %called : shared;
  41
  42 my @tids;
  43
  44 sub spawn {
  45  my ($num, $depth) = @_;
  46  @tids = ();
  47  return unless $depth > 0;
  48  map {
  49   local $x = $_;
  50   my $thr = threads->create(\&cb, $_, $depth);
  51   push @tids, $thr->tid;
  52   $thr;
  53  } 1 .. $num;
  54 }
  55
  56 sub check {
  57  lock %ran;
  58  lock %called;
  59  for (@tids) {
  60   is $ran{$_},    1, "thread $_ was run once";
  61   is $called{$_}, 1, "thread $_ destructor was called once";
  62  }
  63 }
  64
  65 sub cb {
  66  my ($y, $depth) = @_;
  67
  68  my $tid = threads->tid;
  69  {
  70   lock %ran;
  71   $ran{$tid}++;
  72  }
  73
  74  {
  75   lock %nums;
  76   $nums{$tid} = $y;
  77  }
  78  is $x, $y, "\$x in thread $tid";
  79  local $x = -$tid;
  80
  81  $_->join for spawn $num, $depth - 1;
  82
  83  check;
  84 }
  85
  86 Thread::Cleanup::register {
  87  my $tid = threads->tid;
  88  {
  89   lock %called;
  90   $called{$tid}++;
  91  }
  92
  93  my $num = do {
  94   lock %nums;
  95   $nums{$tid};
  96  };
  97
  98  is $x, $num, "\$x in destructor of thread $tid";
  99  local $x = $tid;
 100 };
 101
 102 $_->join for spawn $num, $depth;
 103
 104 check;
 105
 106 is $x, -1, '$x in the main thread';
 107