X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=ext%2Fthreads%2Ft%2Fexit.t;h=f91b35158bd61444fc220ee6c97379784e401ac5;hb=fea7688c419f77f70fbdf9124ff5cef2c8a4be23;hp=c0621c7078ec0e6fd5077bb233d757cf8b83673b;hpb=4dcb9e53db5ab3b8d2b2f8eaba341cb2c0c5d2b8;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/ext/threads/t/exit.t b/ext/threads/t/exit.t
index c0621c7..f91b351 100644
--- a/ext/threads/t/exit.t
+++ b/ext/threads/t/exit.t
@@ -11,6 +11,8 @@ BEGIN {
         print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
         exit(0);
     }
+
+    require($ENV{PERL_CORE} ? "./test.pl" : "./t/test.pl");
 }
 
 use ExtUtils::testlib;
@@ -28,42 +30,11 @@ BEGIN {
     }
 
     $| = 1;
-    print("1..226\n");   ### Number of tests that will be run ###
+    print("1..18\n");   ### Number of tests that will be run ###
 };
 
-my $TEST;
-BEGIN {
-    share($TEST);
-    $TEST = 1;
-}
-
 ok(1, 'Loaded');
 
-sub ok {
-    my ($ok, $name) = @_;
-    if (! defined($name)) {
-        # Bug in test
-        $name = $ok;
-        $ok = 0;
-    }
-    chomp($name);
-
-    lock($TEST);
-    my $id = $TEST++;
-
-    # You have to do it this way or VMS will get confused.
-    if ($ok) {
-        print("ok $id - $name\n");
-    } else {
-        print("not ok $id - $name\n");
-        printf("# Failed test at line %d\n", (caller)[2]);
-        print(STDERR "# FAIL: $name\n") if (! exists($ENV{'PERL_CORE'}));
-    }
-
-    return ($ok);
-}
-
-
 ### Start of Testing ###
 
 $SIG{'__WARN__'} = sub {
@@ -76,181 +47,114 @@ $SIG{'__DIE__'} = sub {
 };
 
 
-sub nasty
-{
-    my ($term, $warn, $die) = @_;
-    my $tid = threads->tid();
+my $thr = threads->create(sub {
+    threads->exit();
+    return (99);  # Not seen
+});
+ok($thr, 'Created: threads->exit()');
+my $rc = $thr->join();
+ok(! defined($rc), 'Exited: threads->exit()');
 
-    $SIG{'__WARN__'} = sub {
-        my $msg = $_[0];
-        ok($msg =~ /Thread \d+ terminated abnormally/, "WARN: $msg");
-        if ($warn eq 'return') {
-            return ('# __WARN__ returned');
-        } elsif ($warn eq 'die') {
-            die('# __WARN__ dying');
-        } elsif ($warn eq 'exit') {
-            CORE::exit(20);
-        } else {
-            threads->exit(21);
-        }
-    };
 
-    $SIG{'__DIE__'} = sub {
-        my $msg = $_[0];
-        ok(1, "DIE: $msg");
-        if ($die eq 'return') {
-            return ('# __DIE__ returned');
-        } elsif ($die eq 'die') {
-            die('# __DIE__ dying');
-        } elsif ($die eq 'exit') {
-            CORE::exit(30);
-        } else {
-            threads->exit(31);
-        }
-    };
+run_perl(prog => 'use threads 1.37;' .
+                 'threads->exit(86);' .
+                 'exit(99);',
+         nolib => ($ENV{PERL_CORE}) ? 0 : 1,
+         switches => ($ENV{PERL_CORE}) ? [] : [ '-Mblib' ]);
+is($?>>8, 86, 'thread->exit(status) in main');
 
-    ok(1, "Thread $tid");
-    if ($term eq 'return') {
-        return ('# Thread returned');
-    } elsif ($term eq 'die') {
-        die('# Thread dying');
-    } elsif ($term eq 'exit') {
-        CORE::exit(10);
-    } else {
-        threads->exit(11);
-    }
-}
 
+$thr = threads->create({'exit' => 'thread_only'}, sub {
+                                                    exit(1);
+                                                    return (99);  # Not seen
+                                                  });
+ok($thr, 'Created: thread_only');
+$rc = $thr->join();
+ok(! defined($rc), 'Exited: thread_only');
 
-my @exit_types = qw(return die exit threads->exit);
 
-# Test (non-trivial) combinations of termination methods
-#   WRT the thread and its handlers
-foreach my $die (@exit_types) {
-    foreach my $wrn (@exit_types) {
-        foreach my $thr (@exit_types) {
-            # Things are well behaved if the thread just returns
-            next if ($thr eq 'return');
+$thr = threads->create(sub {
+    threads->set_thread_exit_only(1);
+    exit(1);
+    return (99);  # Not seen
+});
+ok($thr, 'Created: threads->set_thread_exit_only');
+$rc = $thr->join();
+ok(! defined($rc), 'Exited: threads->set_thread_exit_only');
 
-            # Skip combos with the die handler
-            #   if neither the thread nor the warn handler dies
-            next if ($thr ne 'die' && $wrn ne 'die' && $die ne 'return');
 
-            # Must send STDERR to file to filter out 'un-capturable' output
-            my $rc;
-            eval {
-                local *STDERR;
-                if (! open(STDERR, '>tmp.stderr')) {
-                    die('Failed to create "tmp.stderr"');
-                }
-
-                $rc = threads->create('nasty', $thr, $wrn, $die)->join();
-
-                close(STDERR);
-            };
-
-            # Filter out 'un-capturable' output
-            if (open(IN, 'tmp.stderr')) {
-                while (my $line = <IN>) {
-                    if ($line !~ /^#/) {
-                        print(STDERR $line);
-                    }
-                }
-                close(IN);
-            } else {
-                ok(0, "Failed to open 'tmp.stderr': $!");
-            }
-            unlink('tmp.stderr');
-
-            ok(! $@, ($@) ? "Thread problem: $@" : "Thread ran okay");
-            ok(! defined($rc), "Thread returned 'undef'");
-        }
+my $WAIT :shared = 1;
+$thr = threads->create(sub {
+    lock($WAIT);
+    while ($WAIT) {
+        cond_wait($WAIT);
     }
-}
-
-
-# Again with:
-no warnings 'threads';
-
-sub less_nasty
+    exit(1);
+    return (99);  # Not seen
+});
+threads->yield();
+ok($thr, 'Created: $thr->set_thread_exit_only');
+$thr->set_thread_exit_only(1);
 {
-    my ($term, $warn, $die) = @_;
-    my $tid = threads->tid();
-
-    $SIG{'__WARN__'} = sub {
-        my $msg = $_[0];
-        ok(0, "WARN: $msg");
-        if ($warn eq 'return') {
-            return ('# __WARN__ returned');
-        } elsif ($warn eq 'die') {
-            die('# __WARN__ dying');
-        } elsif ($warn eq 'exit') {
-            CORE::exit(20);
-        } else {
-            threads->exit(21);
-        }
-    };
-
-    $SIG{'__DIE__'} = sub {
-        my $msg = $_[0];
-        ok(1, "DIE: $msg");
-        if ($die eq 'return') {
-            return ('# __DIE__ returned');
-        } elsif ($die eq 'die') {
-            die('# __DIE__ dying');
-        } elsif ($die eq 'exit') {
-            CORE::exit(30);
-        } else {
-            threads->exit(31);
-        }
-    };
-
-    ok(1, "Thread $tid");
-    if ($term eq 'return') {
-        return ('# Thread returned');
-    } elsif ($term eq 'die') {
-        die('# Thread dying');
-    } elsif ($term eq 'exit') {
-        CORE::exit(10);
-    } else {
-        threads->exit(11);
-    }
-}
-
-foreach my $die (@exit_types) {
-    foreach my $wrn (@exit_types) {
-        foreach my $thr (@exit_types) {
-            # Things are well behaved if the thread just returns
-            next if ($thr eq 'return');
-
-            # Skip combos with the die handler
-            #   if neither the thread nor the warn handler dies
-            next if ($thr ne 'die' && $wrn ne 'die' && $die ne 'return');
-
-            my $rc;
-            eval { $rc = threads->create('less_nasty', $thr, $wrn, $die)->join() };
-            ok(! $@, ($@) ? "Thread problem: $@" : "Thread ran okay");
-            ok(! defined($rc), "Thread returned 'undef'");
-        }
-    }
+    lock($WAIT);
+    $WAIT = 0;
+    cond_broadcast($WAIT);
 }
-
-
-# Check termination warning concerning running threads
-$SIG{'__WARN__'} = sub {
-    my $msg = shift;
-    ok($msg =~ /1 running and unjoined/,  '1 running and unjoined');
-    ok($msg =~ /2 finished and unjoined/, '2 finished and unjoined');
-    ok($msg =~ /3 running and detached/,  '3 finished and detached');
-};
-
-threads->create(sub { sleep(100); });
-threads->create(sub {});
-threads->create(sub {});
-threads->create(sub { sleep(100); })->detach();
-threads->create(sub { sleep(100); })->detach();
-threads->create(sub { sleep(100); })->detach();
-threads->yield();
-sleep(1);
+$rc = $thr->join();
+ok(! defined($rc), 'Exited: $thr->set_thread_exit_only');
+
+
+run_perl(prog => 'use threads 1.37 qw(exit thread_only);' .
+                 'threads->create(sub { exit(99); })->join();' .
+                 'exit(86);',
+         nolib => ($ENV{PERL_CORE}) ? 0 : 1,
+         switches => ($ENV{PERL_CORE}) ? [] : [ '-Mblib' ]);
+is($?>>8, 86, "'use threads 'exit' => 'thread_only'");
+
+
+my $out = run_perl(prog => 'use threads 1.37;' .
+                           'threads->create(sub {' .
+                           '    exit(99);' .
+                           '})->join();' .
+                           'exit(86);',
+                   nolib => ($ENV{PERL_CORE}) ? 0 : 1,
+                   switches => ($ENV{PERL_CORE}) ? [] : [ '-Mblib' ],
+                   stderr => 1);
+is($?>>8, 99, "exit(status) in thread");
+like($out, '1 finished and unjoined', "exit(status) in thread");
+
+
+$out = run_perl(prog => 'use threads 1.37 qw(exit thread_only);' .
+                        'threads->create(sub {' .
+                        '   threads->set_thread_exit_only(0);' .
+                        '   exit(99);' .
+                        '})->join();' .
+                        'exit(86);',
+                nolib => ($ENV{PERL_CORE}) ? 0 : 1,
+                switches => ($ENV{PERL_CORE}) ? [] : [ '-Mblib' ],
+                stderr => 1);
+is($?>>8, 99, "set_thread_exit_only(0)");
+like($out, '1 finished and unjoined', "set_thread_exit_only(0)");
+
+
+run_perl(prog => 'use threads 1.37;' .
+                 'threads->create(sub {' .
+                 '   $SIG{__WARN__} = sub { exit(99); };' .
+                 '   die();' .
+                 '})->join();' .
+                 'exit(86);',
+         nolib => ($ENV{PERL_CORE}) ? 0 : 1,
+         switches => ($ENV{PERL_CORE}) ? [] : [ '-Mblib' ]);
+is($?>>8, 99, "exit(status) in thread warn handler");
+
+
+$thr = threads->create(sub {
+    $SIG{__WARN__} = sub { threads->exit(); };
+    local $SIG{__DIE__} = 'DEFAULT';
+    die('Died');
+});
+ok($thr, 'Created: threads->exit() in thread warn handler');
+$rc = $thr->join();
+ok(! defined($rc), 'Exited: threads->exit() in thread warn handler');
 
 # EOF