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
  20 BEGIN {
  21     eval {
  22         require threads::shared;
  23         import threads::shared;
  24     };
  25     if ($@ || ! $threads::shared::threads_shared) {
  26         print("1..0 # Skip: threads::shared not available\n");
  27         exit(0);
  28     }
  29
  30     $| = 1;
  31     print("1..5\n");   ### Number of tests that will be run ###
  32 };
  33
  34 my $TEST = 1;
  35 share($TEST);
  36
  37 ok(1, 'Loaded');
  38
  39 sub ok {
  40     my ($ok, $name) = @_;
  41
  42     lock($TEST);
  43     my $id = $TEST++;
  44
  45     # You have to do it this way or VMS will get confused.
  46     if ($ok) {
  47         print("ok $id - $name\n");
  48     } else {
  49         print("not ok $id - $name\n");
  50         printf("# Failed test at line %d\n", (caller)[2]);
  51     }
  52
  53     return ($ok);
  54 }
  55
  56
  57 ### Start of Testing ###
  58
  59 $SIG{'__WARN__'} = sub { ok(0, "Warning: $_[0]"); };
  60
  61 sub foo { }
  62 sub baz { 42 }
  63
  64 my $bthr;
  65 BEGIN {
  66     $SIG{'__WARN__'} = sub { ok(0, "BEGIN: $_[0]"); };
  67
  68     threads->create('foo')->join();
  69     threads->create(\&foo)->join();
  70     threads->create(sub {})->join();
  71
  72     threads->create('foo')->detach();
  73     threads->create(\&foo)->detach();
  74     threads->create(sub {})->detach();
  75
  76     $bthr = threads->create('baz');
  77 }
  78
  79 my $mthr;
  80 MAIN: {
  81     threads->create('foo')->join();
  82     threads->create(\&foo)->join();
  83     threads->create(sub {})->join();
  84
  85     threads->create('foo')->detach();
  86     threads->create(\&foo)->detach();
  87     threads->create(sub {})->detach();
  88
  89     $mthr = threads->create('baz');
  90 }
  91
  92 ok($mthr, 'Main thread');
  93 ok($bthr, 'BEGIN thread');
  94
  95 ok($mthr->join() == 42, 'Main join');
  96 ok($bthr->join() == 42, 'BEGIN join');
  97
  98 # make sure a still-running detached thread doesn't give a warning on exit
  99
 100 # *** add new tests above this one
 101 threads->create(sub { 1 while 1 })->detach();
 102 # *** add new tests above this one