ext/threads/t/basic.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     unless ($Config{'useithreads'}) {
  11         print "1..0 # Skip: no useithreads\n";
  12         exit 0;
  13     }
  14 }
  15
  16 use ExtUtils::testlib;
  17
  18 BEGIN { $| = 1; print "1..32\n" };
  19 use threads;
  20
  21
  22
  23 if ($threads::VERSION && ! exists($ENV{'PERL_CORE'})) {
  24     print(STDERR "# Testing threads $threads::VERSION\n");
  25 }
  26
  27 ok(1, 1, 'Loaded');
  28
  29 ### Start of Testing ###
  30
  31
  32
  33 sub ok {
  34     my ($id, $ok, $name) = @_;
  35
  36     # You have to do it this way or VMS will get confused.
  37     print $ok ? "ok $id - $name\n" : "not ok $id - $name\n";
  38
  39     printf "# Failed test at line %d\n", (caller)[2] unless $ok;
  40
  41     return $ok;
  42 }
  43
  44
  45 sub test1 {
  46         ok(2,'bar' eq $_[0],"Test that argument passing works");
  47 }
  48 threads->create('test1','bar')->join();
  49
  50 sub test2 {
  51         ok(3,'bar' eq $_[0]->[0]->{foo},"Test that passing arguments as references work");
  52 }
  53
  54 threads->create(\&test2,[{foo => 'bar'}])->join();
  55
  56
  57 #test execuion of normal sub
  58 sub test3 { ok(4,shift() == 1,"Test a normal sub") }
  59 threads->create(\&test3,1)->join();
  60
  61
  62 #check Config
  63 ok(5, 1 == $threads::threads,"Check that threads::threads is true");
  64
  65 #test trying to detach thread
  66
  67 sub test4 { ok(6,1,"Detach test") }
  68
  69 my $thread1 = threads->create('test4');
  70
  71 $thread1->detach();
  72 threads->yield; # help out non-preemptive thread implementations
  73 sleep 2;
  74 ok(7,1,"Detach test");
  75
  76
  77
  78 sub test5 {
  79         threads->create('test6')->join();
  80         ok(9,1,"Nested thread test");
  81 }
  82
  83 sub test6 {
  84         ok(8,1,"Nested thread test");
  85 }
  86
  87 threads->create('test5')->join();
  88
  89 sub test7 {
  90         my $self = threads->self();
  91         ok(10, $self->tid == 7, "Wanted 7, got ".$self->tid);
  92         ok(11, threads->tid() == 7, "Wanted 7, got ".threads->tid());
  93 }
  94
  95 threads->create('test7')->join;
  96
  97 sub test8 {
  98         my $self = threads->self();
  99         ok(12, $self->tid == 8, "Wanted 8, got ".$self->tid);
 100         ok(13, threads->tid() == 8, "Wanted 8, got ".threads->tid());
 101 }
 102
 103 threads->create('test8')->join;
 104
 105
 106 #check support for threads->self() in main thread
 107 ok(14, 0 == threads->self->tid(),"Check so that tid for threads work for main thread");
 108 ok(15, 0 == threads->tid(),"Check so that tid for threads work for main thread");
 109
 110 {
 111         no warnings;
 112     local *CLONE = sub { ok(16, threads->tid() == 9, "Tid should be correct in the clone")};
 113     threads->create(sub { ok(17, threads->tid() == 9, "And tid be 9 here too") })->join();
 114 }
 115
 116 {
 117
 118     sub Foo::DESTROY {
 119         ok(19, threads->tid() == 10, "In destroy it should be correct too" )
 120         }
 121     my $foo;
 122     threads->create(sub { ok(18, threads->tid() == 10, "And tid be 10 here");
 123                           $foo = bless {}, 'Foo';
 124                           return undef;
 125                       })->join();
 126
 127 }
 128
 129
 130 my $thr1 = threads->create(sub {});
 131 my $thr2 = threads->create(sub {});
 132 my $thr3 = threads->object($thr1->tid());
 133
 134 # Make sure both overloaded '==' and '!=' are working correctly
 135 ok(20,   $thr1 != $thr2,  'Treads not equal');
 136 ok(21, !($thr1 == $thr2), 'Treads not equal');
 137 ok(22,   $thr1 == $thr3,  'Threads equal');
 138 ok(23, !($thr1 != $thr3), 'Threads equal');
 139
 140 ok(24, $thr1->_handle(), 'Handle method');
 141 ok(25, $thr2->_handle(), 'Handle method');
 142
 143 ok(26, threads->object($thr1->tid())->tid() == 11, 'Object method');
 144 ok(27, threads->object($thr2->tid())->tid() == 12, 'Object method');
 145
 146 $thr1->join();
 147 $thr2->join();
 148
 149 my $sub = sub { ok(28, shift() == 1, "Test code ref"); };
 150 threads->create($sub, 1)->join();
 151
 152 my $thrx = threads->object(99);
 153 ok(29, ! defined($thrx), 'No object');
 154 $thrx = threads->object();
 155 ok(30, ! defined($thrx), 'No object');
 156 $thrx = threads->object(undef);
 157 ok(31, ! defined($thrx), 'No object');
 158 $thrx = threads->object(0);
 159 ok(32, ! defined($thrx), 'No object');
 160
 161 # EOF