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