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   if ($ENV{DEVEL_GLOBALDESTRUCTION_PP_TEST}) {
  21     no strict 'refs';
  22     no warnings 'redefine';
  23
  24     for my $f (qw(DynaLoader::bootstrap XSLoader::load)) {
  25       my ($mod) = $f =~ /^ (.+) \:\: [^:]+ $/x;
  26       eval "require $mod" or die $@;
  27
  28       my $orig = \&$f;
  29       *$f = sub {
  30         die 'no XS' if ($_[0]||'') eq 'Devel::GlobalDestruction';
  31         goto $orig;
  32       };
  33     }
  34   }
  35 }
  36
  37 BEGIN {
  38   package Test::Scope::Guard;
  39   sub new { my ($class, $code) = @_; bless [$code], $class; }
  40   sub DESTROY { my $self = shift; $self->[0]->() }
  41 }
  42 BEGIN {
  43   package Test::Thread::Clone;
  44   my @code;
  45   sub new { my ($class, $code) = @_; push @code, $code; bless [$code], $class; }
  46   sub CLONE { $_->() for @code }
  47 }
  48
  49 use threads;
  50 use threads::shared;
  51
  52 print "1..4\n";
  53
  54 our $had_error :shared;
  55 END { $? = $had_error||0 }
  56
  57 sub ok ($$) {
  58   $had_error++, print "not " if !$_[0];
  59   print "ok";
  60   print " - $_[1]" if defined $_[1];
  61   print "\n";
  62 }
  63
  64 # load it before spawning a thread, that's the whole point
  65 use Devel::GlobalDestruction;
  66
  67 our $cloner = Test::Thread::Clone->new(sub {
  68     ok( ! in_global_destruction(), "CLONE is not GD" );
  69     my $guard = Test::Scope::Guard->new(sub {
  70         ok( ! in_global_destruction(), "DESTROY during CLONE is not GD");
  71     });
  72 });
  73 our $global = Test::Scope::Guard->new(sub {
  74     ok( in_global_destruction(), "Final cleanup object destruction properly in GD in " . (threads->tid ? 'thread' : 'main program') );
  75 });
  76
  77 sub do_test {
  78   # just die so we don't need to deal with testcount skew
  79   unless ( ($_[0]||'') eq 'arg' ) {
  80     $had_error++;
  81     die "Argument passing failed!";
  82   }
  83   # nothing really to do in here
  84   1;
  85 }
  86
  87 threads->create('do_test', 'arg')->join
  88   or $had_error++;