t/05_thread_clone.t

   1 use strict;
   2 use warnings;
   3
   4 use Config;
   5 BEGIN {
   6   unless ($Config{useithreads}) {
   7     print "1..0 # SKIP your perl does not support ithreads\n";
   8     exit 0;
   9   }
  10 }
  11
  12 BEGIN {
  13   unless (eval { require threads }) {
  14     print "1..0 # SKIP threads.pm not installed\n";
  15     exit 0;
  16   }
  17 }
  18
  19 BEGIN {
  20   package Test::Scope::Guard;
  21   sub new { my ($class, $code) = @_; bless [$code], $class; }
  22   sub DESTROY { my $self = shift; $self->[0]->() }
  23 }
  24 BEGIN {
  25   package Test::Thread::Clone;
  26   my @code;
  27   sub new { my ($class, $code) = @_; push @code, $code; bless [$code], $class; }
  28   sub CLONE { $_->() for @code }
  29 }
  30
  31 use threads;
  32 use threads::shared;
  33
  34 print "1..4\n";
  35
  36 our $had_error :shared;
  37 END { $? = $had_error||0 }
  38
  39 sub ok ($$) {
  40   $had_error++, print "not " if !$_[0];
  41   print "ok";
  42   print " - $_[1]" if defined $_[1];
  43   print "\n";
  44 }
  45
  46 # load it before spawning a thread, that's the whole point
  47 use Devel::GlobalDestruction::XS;
  48
  49 our $cloner = Test::Thread::Clone->new(sub {
  50     ok( ! Devel::GlobalDestruction::XS::in_global_destruction(), "CLONE is not GD" );
  51     my $guard = Test::Scope::Guard->new(sub {
  52         ok( ! Devel::GlobalDestruction::XS::in_global_destruction(), "DESTROY during CLONE is not GD");
  53     });
  54 });
  55 our $global = Test::Scope::Guard->new(sub {
  56     ok( Devel::GlobalDestruction::XS::in_global_destruction(), "Final cleanup object destruction properly in GD in " . (threads->tid ? 'thread' : 'main program') );
  57 });
  58
  59 sub do_test {
  60   # just die so we don't need to deal with testcount skew
  61   unless ( ($_[0]||'') eq 'arg' ) {
  62     $had_error++;
  63     die "Argument passing failed!";
  64   }
  65   # nothing really to do in here
  66   1;
  67 }
  68
  69 threads->create('do_test', 'arg')->join
  70   or $had_error++;