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