ext/threads/t/blocks.t

   1 use strict;
   2 use warnings;
   3
   4 BEGIN {
   5     if ($ENV{'PERL_CORE'}){
   6         chdir 't';
   7         unshift @INC, '../lib';
   8     }
   9     use Config;
  10     if (! $Config{'useithreads'}) {
  11         print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
  12         exit(0);
  13     }
  14 }
  15
  16 use ExtUtils::testlib;
  17
  18 use threads;
  19 use threads::shared;
  20
  21 my $TEST;
  22 BEGIN {
  23     $| = 1;
  24     print("1..5\n");   ### Number of tests that will be run ###
  25
  26     share($TEST);
  27     $TEST = 1;
  28 };
  29
  30 ok(1, 'Loaded');
  31
  32 sub ok {
  33     my ($ok, $name) = @_;
  34
  35     lock($TEST);
  36     my $id = $TEST++;
  37
  38     # You have to do it this way or VMS will get confused.
  39     if ($ok) {
  40         print("ok $id - $name\n");
  41     } else {
  42         print("not ok $id - $name\n");
  43         printf("# Failed test at line %d\n", (caller)[2]);
  44     }
  45
  46     return ($ok);
  47 }
  48
  49
  50 ### Start of Testing ###
  51
  52 $SIG{'__WARN__'} = sub { ok(0, "Warning: $_[0]"); };
  53
  54 sub foo { }
  55 sub baz { 42 }
  56
  57 my $bthr;
  58 BEGIN {
  59     $SIG{'__WARN__'} = sub { ok(0, "BEGIN: $_[0]"); };
  60
  61     threads->create('foo')->join();
  62     threads->create(\&foo)->join();
  63     threads->create(sub {})->join();
  64
  65     threads->create('foo')->detach();
  66     threads->create(\&foo)->detach();
  67     threads->create(sub {})->detach();
  68
  69     $bthr = threads->create('baz');
  70 }
  71
  72 my $mthr;
  73 MAIN: {
  74     threads->create('foo')->join();
  75     threads->create(\&foo)->join();
  76     threads->create(sub {})->join();
  77
  78     threads->create('foo')->detach();
  79     threads->create(\&foo)->detach();
  80     threads->create(sub {})->detach();
  81
  82     $mthr = threads->create('baz');
  83 }
  84
  85 ok($mthr, 'Main thread');
  86 ok($bthr, 'BEGIN thread');
  87
  88 ok($mthr->join() == 42, 'Main join');
  89 ok($bthr->join() == 42, 'BEGIN join');
  90
  91 # EOF