ext/threads/t/exit.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     $| = 1;
  31     print("1..226\n");   ### Number of tests that will be run ###
  32 };
  33
  34 my $TEST;
  35 BEGIN {
  36     share($TEST);
  37     $TEST = 1;
  38 }
  39
  40 ok(1, 'Loaded');
  41
  42 sub ok {
  43     my ($ok, $name) = @_;
  44     if (! defined($name)) {
  45         # Bug in test
  46         $name = $ok;
  47         $ok = 0;
  48     }
  49     chomp($name);
  50
  51     lock($TEST);
  52     my $id = $TEST++;
  53
  54     # You have to do it this way or VMS will get confused.
  55     if ($ok) {
  56         print("ok $id - $name\n");
  57     } else {
  58         print("not ok $id - $name\n");
  59         printf("# Failed test at line %d\n", (caller)[2]);
  60         print(STDERR "# FAIL: $name\n") if (! exists($ENV{'PERL_CORE'}));
  61     }
  62
  63     return ($ok);
  64 }
  65
  66
  67 ### Start of Testing ###
  68
  69 $SIG{'__WARN__'} = sub {
  70     my $msg = shift;
  71     ok(0, "WARN in main: $msg");
  72 };
  73 $SIG{'__DIE__'} = sub {
  74     my $msg = shift;
  75     ok(0, "DIE in main: $msg");
  76 };
  77
  78
  79 sub nasty
  80 {
  81     my ($term, $warn, $die) = @_;
  82     my $tid = threads->tid();
  83
  84     $SIG{'__WARN__'} = sub {
  85         my $msg = $_[0];
  86         ok($msg =~ /Thread \d+ terminated abnormally/, "WARN: $msg");
  87         if ($warn eq 'return') {
  88             return ('# __WARN__ returned');
  89         } elsif ($warn eq 'die') {
  90             die('# __WARN__ dying');
  91         } elsif ($warn eq 'exit') {
  92             CORE::exit(20);
  93         } else {
  94             threads->exit(21);
  95         }
  96     };
  97
  98     $SIG{'__DIE__'} = sub {
  99         my $msg = $_[0];
 100         ok(1, "DIE: $msg");
 101         if ($die eq 'return') {
 102             return ('# __DIE__ returned');
 103         } elsif ($die eq 'die') {
 104             die('# __DIE__ dying');
 105         } elsif ($die eq 'exit') {
 106             CORE::exit(30);
 107         } else {
 108             threads->exit(31);
 109         }
 110     };
 111
 112     ok(1, "Thread $tid");
 113     if ($term eq 'return') {
 114         return ('# Thread returned');
 115     } elsif ($term eq 'die') {
 116         die('# Thread dying');
 117     } elsif ($term eq 'exit') {
 118         CORE::exit(10);
 119     } else {
 120         threads->exit(11);
 121     }
 122 }
 123
 124
 125 my @exit_types = qw(return die exit threads->exit);
 126
 127 # Test (non-trivial) combinations of termination methods
 128 #   WRT the thread and its handlers
 129 foreach my $die (@exit_types) {
 130     foreach my $wrn (@exit_types) {
 131         foreach my $thr (@exit_types) {
 132             # Things are well behaved if the thread just returns
 133             next if ($thr eq 'return');
 134
 135             # Skip combos with the die handler
 136             #   if neither the thread nor the warn handler dies
 137             next if ($thr ne 'die' && $wrn ne 'die' && $die ne 'return');
 138
 139             # Must send STDERR to file to filter out 'un-capturable' output
 140             my $rc;
 141             eval {
 142                 local *STDERR;
 143                 if (! open(STDERR, '>tmp.stderr')) {
 144                     die('Failed to create "tmp.stderr"');
 145                 }
 146
 147                 $rc = threads->create('nasty', $thr, $wrn, $die)->join();
 148
 149                 close(STDERR);
 150             };
 151
 152             # Filter out 'un-capturable' output
 153             if (open(IN, 'tmp.stderr')) {
 154                 while (my $line = <IN>) {
 155                     if ($line !~ /^#/) {
 156                         print(STDERR $line);
 157                     }
 158                 }
 159                 close(IN);
 160             } else {
 161                 ok(0, "Failed to open 'tmp.stderr': $!");
 162             }
 163             unlink('tmp.stderr');
 164
 165             ok(! $@, ($@) ? "Thread problem: $@" : "Thread ran okay");
 166             ok(! defined($rc), "Thread returned 'undef'");
 167         }
 168     }
 169 }
 170
 171
 172 # Again with:
 173 no warnings 'threads';
 174
 175 sub less_nasty
 176 {
 177     my ($term, $warn, $die) = @_;
 178     my $tid = threads->tid();
 179
 180     $SIG{'__WARN__'} = sub {
 181         my $msg = $_[0];
 182         ok(0, "WARN: $msg");
 183         if ($warn eq 'return') {
 184             return ('# __WARN__ returned');
 185         } elsif ($warn eq 'die') {
 186             die('# __WARN__ dying');
 187         } elsif ($warn eq 'exit') {
 188             CORE::exit(20);
 189         } else {
 190             threads->exit(21);
 191         }
 192     };
 193
 194     $SIG{'__DIE__'} = sub {
 195         my $msg = $_[0];
 196         ok(1, "DIE: $msg");
 197         if ($die eq 'return') {
 198             return ('# __DIE__ returned');
 199         } elsif ($die eq 'die') {
 200             die('# __DIE__ dying');
 201         } elsif ($die eq 'exit') {
 202             CORE::exit(30);
 203         } else {
 204             threads->exit(31);
 205         }
 206     };
 207
 208     ok(1, "Thread $tid");
 209     if ($term eq 'return') {
 210         return ('# Thread returned');
 211     } elsif ($term eq 'die') {
 212         die('# Thread dying');
 213     } elsif ($term eq 'exit') {
 214         CORE::exit(10);
 215     } else {
 216         threads->exit(11);
 217     }
 218 }
 219
 220 foreach my $die (@exit_types) {
 221     foreach my $wrn (@exit_types) {
 222         foreach my $thr (@exit_types) {
 223             # Things are well behaved if the thread just returns
 224             next if ($thr eq 'return');
 225
 226             # Skip combos with the die handler
 227             #   if neither the thread nor the warn handler dies
 228             next if ($thr ne 'die' && $wrn ne 'die' && $die ne 'return');
 229
 230             my $rc;
 231             eval { $rc = threads->create('less_nasty', $thr, $wrn, $die)->join() };
 232             ok(! $@, ($@) ? "Thread problem: $@" : "Thread ran okay");
 233             ok(! defined($rc), "Thread returned 'undef'");
 234         }
 235     }
 236 }
 237
 238
 239 # Check termination warning concerning running threads
 240 $SIG{'__WARN__'} = sub {
 241     my $msg = shift;
 242     ok($msg =~ /1 running and unjoined/,  '1 running and unjoined');
 243     ok($msg =~ /2 finished and unjoined/, '2 finished and unjoined');
 244     ok($msg =~ /3 running and detached/,  '3 finished and detached');
 245 };
 246
 247 threads->create(sub { sleep(100); });
 248 threads->create(sub {});
 249 threads->create(sub {});
 250 threads->create(sub { sleep(100); })->detach();
 251 threads->create(sub { sleep(100); })->detach();
 252 threads->create(sub { sleep(100); })->detach();
 253 threads->yield();
 254 sleep(1);
 255
 256 # EOF