ext/threads/t/basic.t

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