ext/threads/t/kill.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 BEGIN {
  22     local $SIG{'HUP'} = sub {};
  23     my $thr = threads->create(sub {});
  24     eval { $thr->kill('HUP') };
  25     $thr->join();
  26     if ($@ && $@ =~ /safe signals/) {
  27         print("1..0 # Skip: Not using safe signals\n");
  28         exit(0);
  29     }
  30 }
  31
  32 {
  33     package Thread::Semaphore;
  34     use threads::shared;
  35
  36     sub new {
  37         my $class = shift;
  38         my $val : shared = @_ ? shift : 1;
  39         bless \$val, $class;
  40     }
  41
  42     sub down {
  43         my $s = shift;
  44         lock($$s);
  45         my $inc = @_ ? shift : 1;
  46         cond_wait $$s until $$s >= $inc;
  47         $$s -= $inc;
  48     }
  49
  50     sub up {
  51         my $s = shift;
  52         lock($$s);
  53         my $inc = @_ ? shift : 1;
  54         ($$s += $inc) > 0 and cond_broadcast $$s;
  55     }
  56 }
  57
  58 BEGIN {
  59     $| = 1;
  60     print("1..18\n");   ### Number of tests that will be run ###
  61 };
  62
  63 my $TEST = 1;
  64 share($TEST);
  65
  66 ok(1, 'Loaded');
  67
  68 sub ok {
  69     my ($ok, $name) = @_;
  70
  71     lock($TEST);
  72     my $id = $TEST++;
  73
  74     # You have to do it this way or VMS will get confused.
  75     if ($ok) {
  76         print("ok $id - $name\n");
  77     } else {
  78         print("not ok $id - $name\n");
  79         printf("# Failed test at line %d\n", (caller)[2]);
  80     }
  81
  82     return ($ok);
  83 }
  84
  85
  86 ### Start of Testing ###
  87
  88 ### Thread cancel ###
  89
  90 # Set up to capture warning when thread terminates
  91 my @errs :shared;
  92 $SIG{__WARN__} = sub { push(@errs, @_); };
  93
  94
  95 sub thr_func {
  96     # Thread 'cancellation' signal handler
  97     $SIG{'KILL'} = sub {
  98         ok(1, 'Thread received signal');
  99         die("Thread killed\n");
 100     };
 101
 102     # Thread sleeps until signalled
 103     ok(1, 'Thread sleeping');
 104     {
 105         local $SIG{'INT'} = sub {};
 106         sleep(5);
 107     }
 108     # Should not go past here
 109     ok(0, 'Thread terminated normally');
 110     return ('ERROR');
 111 }
 112
 113
 114 # Create thread
 115 my $thr = threads->create('thr_func');
 116 ok($thr && $thr->tid() == 2, 'Created thread');
 117 threads->yield();
 118 sleep(1);
 119
 120 # Signal thread
 121 ok($thr->kill('KILL'), 'Signalled thread');
 122 threads->yield();
 123
 124 # Interrupt thread's sleep call
 125 {
 126     # We can't be sure whether the signal itself will get delivered to this
 127     # thread or the sleeping thread
 128     local $SIG{'INT'} = sub {};
 129     ok(kill('INT', $$) || $^O eq 'MSWin32', q/Interrupt thread's sleep call/);
 130 }
 131
 132 # Cleanup
 133 my $rc = $thr->join();
 134 ok(! $rc, 'No thread return value');
 135
 136 # Check for thread termination message
 137 ok(@errs && $errs[0] =~ /Thread killed/, 'Thread termination warning');
 138
 139
 140 ### Thread suspend/resume ###
 141
 142 sub thr_func2
 143 {
 144     my $sema = shift;
 145     ok($sema, 'Thread received semaphore');
 146
 147     # Set up the signal handler for suspension/resumption
 148     $SIG{'STOP'} = sub {
 149         ok(1, 'Thread suspending');
 150         $sema->down();
 151         ok(1, 'Thread resuming');
 152         $sema->up();
 153     };
 154
 155     # Set up the signal handler for graceful termination
 156     my $term = 0;
 157     $SIG{'TERM'} = sub {
 158         ok(1, 'Thread caught termination signal');
 159         $term = 1;
 160     };
 161
 162     # Do work until signalled to terminate
 163     while (! $term) {
 164         sleep(1);
 165     }
 166
 167     ok(1, 'Thread done');
 168     return ('OKAY');
 169 }
 170
 171
 172 # Create a semaphore for use in suspending the thread
 173 my $sema = Thread::Semaphore->new();
 174 ok($sema, 'Semaphore created');
 175
 176 # Create a thread and send it the semaphore
 177 $thr = threads->create('thr_func2', $sema);
 178 ok($thr && $thr->tid() == 3, 'Created thread');
 179 threads->yield();
 180 sleep(1);
 181
 182 # Suspend the thread
 183 $sema->down();
 184 ok($thr->kill('STOP'), 'Suspended thread');
 185
 186 threads->yield();
 187 sleep(1);
 188
 189 # Allow the thread to continue
 190 $sema->up();
 191
 192 threads->yield();
 193 sleep(1);
 194
 195 # Terminate the thread
 196 ok($thr->kill('TERM'), 'Signalled thread to terminate');
 197
 198 $rc = $thr->join();
 199 ok($rc eq 'OKAY', 'Thread return value');
 200
 201 # EOF