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     sleep(5);
  94     # Should not go past here
  95     ok(0, 'Thread terminated normally');
  96     return ('ERROR');
  97 }
  98
  99
 100 # Create thread
 101 my $thr = threads->create('thr_func');
 102 ok($thr && $thr->tid() == 1, 'Created thread');
 103 threads->yield();
 104 sleep(1);
 105
 106 # Signal thread
 107 ok($thr->kill('KILL'), 'Signalled thread');
 108 threads->yield();
 109
 110 # Interrupt thread's sleep call
 111 {
 112     local $SIG{'INT'} = sub {};
 113     ok(kill('INT', $$) || $^O eq 'MSWin32', q/Interrupt thread's sleep call/);
 114 }
 115
 116 # Cleanup
 117 my $rc = $thr->join();
 118 ok(! $rc, 'No thread return value');
 119
 120 # Check for thread termination message
 121 ok(@errs && $errs[0] =~ /Thread killed/, 'Thread termination warning');
 122
 123
 124 ### Thread suspend/resume ###
 125
 126 sub thr_func2
 127 {
 128     my $sema = shift;
 129     ok($sema, 'Thread received semaphore');
 130
 131     # Set up the signal handler for suspension/resumption
 132     $SIG{'STOP'} = sub {
 133         ok(1, 'Thread suspending');
 134         $sema->down();
 135         ok(1, 'Thread resuming');
 136         $sema->up();
 137     };
 138
 139     # Set up the signal handler for graceful termination
 140     my $term = 0;
 141     $SIG{'TERM'} = sub {
 142         ok(1, 'Thread caught termination signal');
 143         $term = 1;
 144     };
 145
 146     # Do work until signalled to terminate
 147     while (! $term) {
 148         sleep(1);
 149     }
 150
 151     ok(1, 'Thread done');
 152     return ('OKAY');
 153 }
 154
 155
 156 # Create a semaphore for use in suspending the thread
 157 my $sema = Thread::Semaphore->new();
 158 ok($sema, 'Semaphore created');
 159
 160 # Create a thread and send it the semaphore
 161 $thr = threads->create('thr_func2', $sema);
 162 ok($thr && $thr->tid() == 2, 'Created thread');
 163 threads->yield();
 164 sleep(1);
 165
 166 # Suspend the thread
 167 $sema->down();
 168 ok($thr->kill('STOP'), 'Suspended thread');
 169
 170 threads->yield();
 171 sleep(1);
 172
 173 # Allow the thread to continue
 174 $sema->up();
 175
 176 threads->yield();
 177 sleep(1);
 178
 179 # Terminate the thread
 180 ok($thr->kill('TERM'), 'Signalled thread to terminate');
 181
 182 $rc = $thr->join();
 183 ok($rc eq 'OKAY', 'Thread return value');
 184
 185 # EOF