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