dist/threads/t/exit.t

   1 use strict;
   2 use warnings;
   3
   4 BEGIN {
   5     require($ENV{PERL_CORE} ? '../../t/test.pl' : './t/test.pl');
   6
   7     use Config;
   8     if (! $Config{'useithreads'}) {
   9         skip_all(q/Perl not compiled with 'useithreads'/);
  10     }
  11 }
  12
  13 our $TODO;
  14
  15 use ExtUtils::testlib;
  16
  17 use threads;
  18
  19 BEGIN {
  20     if (! eval 'use threads::shared; 1') {
  21         skip_all('threads::shared not available');
  22     }
  23
  24     $| = 1;
  25     print("1..18\n");   ### Number of tests that will be run ###
  26 };
  27
  28 ok(1, 'Loaded');
  29
  30 ### Start of Testing ###
  31
  32 $SIG{'__WARN__'} = sub {
  33     my $msg = shift;
  34     ok(0, "WARN in main: $msg");
  35 };
  36 $SIG{'__DIE__'} = sub {
  37     my $msg = shift;
  38     ok(0, "DIE in main: $msg");
  39 };
  40
  41
  42 my $thr = threads->create(sub {
  43     threads->exit();
  44     return (99);  # Not seen
  45 });
  46 ok($thr, 'Created: threads->exit()');
  47 my $rc = $thr->join();
  48 ok(! defined($rc), 'Exited: threads->exit()');
  49
  50
  51 run_perl(prog => 'use threads 2.15;' .
  52                  'threads->exit(86);' .
  53                  'exit(99);',
  54          nolib => ($ENV{PERL_CORE}) ? 0 : 1,
  55          switches => ($ENV{PERL_CORE}) ? [] : [ '-Mblib' ]);
  56 {
  57     local $TODO = 'VMS exit semantics not like POSIX exit semantics' if $^O eq 'VMS';
  58     is($?>>8, 86, 'thread->exit(status) in main');
  59 }
  60
  61 $thr = threads->create({'exit' => 'thread_only'}, sub {
  62                                                     exit(1);
  63                                                     return (99);  # Not seen
  64                                                   });
  65 ok($thr, 'Created: thread_only');
  66 $rc = $thr->join();
  67 ok(! defined($rc), 'Exited: thread_only');
  68
  69
  70 $thr = threads->create(sub {
  71     threads->set_thread_exit_only(1);
  72     exit(1);
  73     return (99);  # Not seen
  74 });
  75 ok($thr, 'Created: threads->set_thread_exit_only');
  76 $rc = $thr->join();
  77 ok(! defined($rc), 'Exited: threads->set_thread_exit_only');
  78
  79
  80 my $WAIT :shared = 1;
  81 $thr = threads->create(sub {
  82     lock($WAIT);
  83     while ($WAIT) {
  84         cond_wait($WAIT);
  85     }
  86     exit(1);
  87     return (99);  # Not seen
  88 });
  89 threads->yield();
  90 ok($thr, 'Created: $thr->set_thread_exit_only');
  91 $thr->set_thread_exit_only(1);
  92 {
  93     lock($WAIT);
  94     $WAIT = 0;
  95     cond_broadcast($WAIT);
  96 }
  97 $rc = $thr->join();
  98 ok(! defined($rc), 'Exited: $thr->set_thread_exit_only');
  99
 100
 101 run_perl(prog => 'use threads 2.15 qw(exit thread_only);' .
 102                  'threads->create(sub { exit(99); })->join();' .
 103                  'exit(86);',
 104          nolib => ($ENV{PERL_CORE}) ? 0 : 1,
 105          switches => ($ENV{PERL_CORE}) ? [] : [ '-Mblib' ]);
 106 {
 107     local $TODO = 'VMS exit semantics not like POSIX exit semantics' if $^O eq 'VMS';
 108     is($?>>8, 86, "'use threads 'exit' => 'thread_only'");
 109 }
 110
 111 my $out = run_perl(prog => 'use threads 2.15;' .
 112                            'threads->create(sub {' .
 113                            '    exit(99);' .
 114                            '});' .
 115                            'sleep(1);' .
 116                            'exit(86);',
 117                    nolib => ($ENV{PERL_CORE}) ? 0 : 1,
 118                    switches => ($ENV{PERL_CORE}) ? [] : [ '-Mblib' ],
 119                    stderr => 1);
 120 {
 121     local $TODO = 'VMS exit semantics not like POSIX exit semantics' if $^O eq 'VMS';
 122     is($?>>8, 99, "exit(status) in thread");
 123 }
 124 like($out, qr/1 finished and unjoined/, "exit(status) in thread");
 125
 126
 127 $out = run_perl(prog => 'use threads 2.15 qw(exit thread_only);' .
 128                         'threads->create(sub {' .
 129                         '   threads->set_thread_exit_only(0);' .
 130                         '   exit(99);' .
 131                         '});' .
 132                         'sleep(1);' .
 133                         'exit(86);',
 134                 nolib => ($ENV{PERL_CORE}) ? 0 : 1,
 135                 switches => ($ENV{PERL_CORE}) ? [] : [ '-Mblib' ],
 136                 stderr => 1);
 137 {
 138     local $TODO = 'VMS exit semantics not like POSIX exit semantics' if $^O eq 'VMS';
 139     is($?>>8, 99, "set_thread_exit_only(0)");
 140 }
 141 like($out, qr/1 finished and unjoined/, "set_thread_exit_only(0)");
 142
 143
 144 run_perl(prog => 'use threads 2.15;' .
 145                  'threads->create(sub {' .
 146                  '   $SIG{__WARN__} = sub { exit(99); };' .
 147                  '   die();' .
 148                  '})->join();' .
 149                  'exit(86);',
 150          nolib => ($ENV{PERL_CORE}) ? 0 : 1,
 151          switches => ($ENV{PERL_CORE}) ? [] : [ '-Mblib' ]);
 152 {
 153     local $TODO = 'VMS exit semantics not like POSIX exit semantics' if $^O eq 'VMS';
 154     is($?>>8, 99, "exit(status) in thread warn handler");
 155 }
 156
 157 $thr = threads->create(sub {
 158     $SIG{__WARN__} = sub { threads->exit(); };
 159     local $SIG{__DIE__} = 'DEFAULT';
 160     die('Died');
 161 });
 162 ok($thr, 'Created: threads->exit() in thread warn handler');
 163 $rc = $thr->join();
 164 ok(! defined($rc), 'Exited: threads->exit() in thread warn handler');
 165
 166 exit(0);
 167
 168 # EOF