t/05_thread_clone.t

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