From: Jerry D. Hedden Date: Thu, 17 May 2007 12:21:46 +0000 (-0400) Subject: threads 1.62 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=18b9e6f5b84f2d3457be2e55295072eec926f1d7;p=p5sagit%2Fp5-mst-13.2.git threads 1.62 From: "Jerry D. Hedden" Message-ID: <1ff86f510705170921g77d87898ye2c081fc0df53a9e@mail.gmail.com> p4raw-id: //depot/perl@31238 --- diff --git a/ext/threads/Changes b/ext/threads/Changes index 1b3f7fa..86c4138 100755 --- a/ext/threads/Changes +++ b/ext/threads/Changes @@ -1,5 +1,10 @@ Revision history for Perl extension threads. +1.62 Thu May 17 16:10:49 2007 + - Fixed :all import option + - Fixed problems in test suite + - Subversion repository on Google + 1.61 Wed Mar 21 16:09:15 EDT 2007 - Fix 'list/array' context - both keywords are supported - Upgraded ppport.h to Devel::PPPort 3.11 diff --git a/ext/threads/README b/ext/threads/README index ac67652..b247d99 100755 --- a/ext/threads/README +++ b/ext/threads/README @@ -1,4 +1,4 @@ -threads version 1.61 +threads version 1.62 ==================== This module exposes interpreter threads to the Perl level. diff --git a/ext/threads/t/exit.t b/ext/threads/t/exit.t index 689473b..ac147d6 100644 --- a/ext/threads/t/exit.t +++ b/ext/threads/t/exit.t @@ -56,7 +56,7 @@ my $rc = $thr->join(); ok(! defined($rc), 'Exited: threads->exit()'); -run_perl(prog => 'use threads 1.61;' . +run_perl(prog => 'use threads 1.62;' . 'threads->exit(86);' . 'exit(99);', nolib => ($ENV{PERL_CORE}) ? 0 : 1, @@ -104,7 +104,7 @@ $rc = $thr->join(); ok(! defined($rc), 'Exited: $thr->set_thread_exit_only'); -run_perl(prog => 'use threads 1.61 qw(exit thread_only);' . +run_perl(prog => 'use threads 1.62 qw(exit thread_only);' . 'threads->create(sub { exit(99); })->join();' . 'exit(86);', nolib => ($ENV{PERL_CORE}) ? 0 : 1, @@ -112,7 +112,7 @@ run_perl(prog => 'use threads 1.61 qw(exit thread_only);' . is($?>>8, 86, "'use threads 'exit' => 'thread_only'"); -my $out = run_perl(prog => 'use threads 1.61;' . +my $out = run_perl(prog => 'use threads 1.62;' . 'threads->create(sub {' . ' exit(99);' . '});' . @@ -125,7 +125,7 @@ is($?>>8, 99, "exit(status) in thread"); like($out, '1 finished and unjoined', "exit(status) in thread"); -$out = run_perl(prog => 'use threads 1.61 qw(exit thread_only);' . +$out = run_perl(prog => 'use threads 1.62 qw(exit thread_only);' . 'threads->create(sub {' . ' threads->set_thread_exit_only(0);' . ' exit(99);' . @@ -139,7 +139,7 @@ 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.61;' . +run_perl(prog => 'use threads 1.62;' . 'threads->create(sub {' . ' $SIG{__WARN__} = sub { exit(99); };' . ' die();' . diff --git a/ext/threads/t/free.t b/ext/threads/t/free.t index 44ef1cb..5e4d3b8 100644 --- a/ext/threads/t/free.t +++ b/ext/threads/t/free.t @@ -27,37 +27,37 @@ BEGIN { exit(0); } + require Thread::Queue; + $| = 1; print("1..29\n"); ### Number of tests that will be run ### -}; - -my $TEST; -BEGIN { - share($TEST); - $TEST = 1; } -ok(1, 'Loaded'); -sub ok { - my ($ok, $name) = @_; +my $q = Thread::Queue->new(); +my $TEST = 1; - 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]); +sub ok +{ + $q->enqueue(@_); + + while ($q->pending()) { + my $ok = $q->dequeue(); + my $name = $q->dequeue(); + my $id = $TEST++; + + if ($ok) { + print("ok $id - $name\n"); + } else { + print("not ok $id - $name\n"); + printf("# Failed test at line %d\n", (caller)[2]); + } } - - return ($ok); } ### Start of Testing ### +ok(1, 'Loaded'); # Tests freeing the Perl interperter for each thread # See http://www.nntp.perl.org/group/perl.perl5.porters/110772 for details @@ -65,8 +65,10 @@ sub ok { my ($COUNT, $STARTED) :shared; sub threading_1 { + my $q = shift; + my $tid = threads->tid(); - ok($tid, "Thread $tid started"); + $q->enqueue($tid, "Thread $tid started"); my $id; { @@ -76,7 +78,7 @@ sub threading_1 { } if ($STARTED < 5) { sleep(1); - threads->create('threading_1')->detach(); + threads->create('threading_1', $q)->detach(); } if ($id == 1) { @@ -94,13 +96,13 @@ sub threading_1 { lock($COUNT); $COUNT++; cond_signal($COUNT); - ok($tid, "Thread $tid done"); + $q->enqueue($tid, "Thread $tid done"); } { $STARTED = 0; $COUNT = 0; - threads->create('threading_1')->detach(); + threads->create('threading_1', $q)->detach(); { my $cnt = 0; while ($cnt < 5) { @@ -120,15 +122,17 @@ ok($COUNT == 5, "Done - $COUNT threads"); sub threading_2 { + my $q = shift; + my $tid = threads->tid(); - ok($tid, "Thread $tid started"); + $q->enqueue($tid, "Thread $tid started"); { lock($STARTED); $STARTED++; } if ($STARTED < 5) { - threads->create('threading_2')->detach(); + threads->create('threading_2', $q)->detach(); } threads->yield(); @@ -136,13 +140,13 @@ sub threading_2 { $COUNT++; cond_signal($COUNT); - ok($tid, "Thread $tid done"); + $q->enqueue($tid, "Thread $tid done"); } { $STARTED = 0; $COUNT = 0; - threads->create('threading_2')->detach(); + threads->create('threading_2', $q)->detach(); threads->create(sub { threads->create(sub { })->join(); })->join(); @@ -164,13 +168,17 @@ ok(1, 'Join'); sub threading_3 { + my $q = shift; + my $tid = threads->tid(); - ok($tid, "Thread $tid started"); + $q->enqueue($tid, "Thread $tid started"); { threads->create(sub { + my $q = shift; + my $tid = threads->tid(); - ok($tid, "Thread $tid started"); + $q->enqueue($tid, "Thread $tid started"); sleep(1); @@ -178,21 +186,21 @@ sub threading_3 { $COUNT++; cond_signal($COUNT); - ok($tid, "Thread $tid done"); - })->detach(); + $q->enqueue($tid, "Thread $tid done"); + }, $q)->detach(); } lock($COUNT); $COUNT++; cond_signal($COUNT); - ok($tid, "Thread $tid done"); + $q->enqueue($tid, "Thread $tid done"); } { $COUNT = 0; threads->create(sub { - threads->create('threading_3')->detach(); + threads->create('threading_3', $q)->detach(); { lock($COUNT); while ($COUNT < 2) { diff --git a/ext/threads/t/free2.t b/ext/threads/t/free2.t index cdab3eb..48e5c00 100644 --- a/ext/threads/t/free2.t +++ b/ext/threads/t/free2.t @@ -32,37 +32,38 @@ BEGIN { exit(0); } + require Thread::Queue; + $| = 1; print("1..78\n"); ### Number of tests that will be run ### -}; - -my $TEST; -BEGIN { - share($TEST); - $TEST = 1; } -ok(1, 'Loaded'); -sub ok { - my ($ok, $name) = @_; +my $q = Thread::Queue->new(); +my $TEST = 1; - lock($TEST); - my $id = $TEST++; +sub ok +{ + $q->enqueue(@_) if @_; - # 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]); - } + while ($q->pending()) { + my $ok = $q->dequeue(); + my $name = $q->dequeue(); + my $id = $TEST++; - return ($ok); + if ($ok) { + print("ok $id - $name\n"); + } else { + print("not ok $id - $name\n"); + printf("# Failed test at line %d\n", (caller)[2]); + } + } } + ### Start of Testing ### +ok(1, 'Loaded'); # Tests freeing the Perl interperter for each thread # See http://www.nntp.perl.org/group/perl.perl5.porters/110772 for details @@ -73,9 +74,11 @@ my %READY; share(%READY); # Init a thread -sub th_start { +sub th_start +{ + my $q = shift; my $tid = threads->tid(); - ok($tid, "Thread $tid started"); + $q->enqueue($tid, "Thread $tid started"); threads->yield(); @@ -86,10 +89,10 @@ sub th_start { # Create next thread if ($tid < 17) { my $next = 'th' . ($tid+1); - my $th = threads->create($next); + my $th = threads->create($next, $q); } else { # Last thread signals first - th_signal(1); + th_signal($q, 1); } # Wait until signalled by another thread @@ -98,28 +101,31 @@ sub th_start { } $other = delete($READY{$tid}); } - ok($tid, "Thread $tid received signal from $other"); + $q->enqueue($tid, "Thread $tid received signal from $other"); threads->yield(); } # Thread terminating -sub th_done { +sub th_done +{ + my $q = shift; my $tid = threads->tid(); lock($COUNT); $COUNT++; cond_signal($COUNT); - ok($tid, "Thread $tid done"); + $q->enqueue($tid, "Thread $tid done"); } # Signal another thread to go sub th_signal { + my $q = shift; my $other = shift; my $tid = threads->tid(); - ok($tid, "Thread $tid signalling $other"); + $q->enqueue($tid, "Thread $tid signalling $other"); lock(%READY); $READY{$other} = $tid; @@ -128,155 +134,189 @@ sub th_signal ##### -sub th1 { - th_start(); +sub th1 +{ + my $q = shift; + th_start($q); threads->detach(); - th_signal(2); - th_signal(6); - th_signal(10); - th_signal(14); + th_signal($q, 2); + th_signal($q, 6); + th_signal($q, 10); + th_signal($q, 14); - th_done(); + th_done($q); } -sub th2 { - th_start(); +sub th2 +{ + my $q = shift; + th_start($q); threads->detach(); - th_signal(4); - th_done(); + th_signal($q, 4); + th_done($q); } -sub th6 { - th_start(); +sub th6 +{ + my $q = shift; + th_start($q); threads->detach(); - th_signal(8); - th_done(); + th_signal($q, 8); + th_done($q); } -sub th10 { - th_start(); +sub th10 +{ + my $q = shift; + th_start($q); threads->detach(); - th_signal(12); - th_done(); + th_signal($q, 12); + th_done($q); } -sub th14 { - th_start(); +sub th14 +{ + my $q = shift; + th_start($q); threads->detach(); - th_signal(16); - th_done(); + th_signal($q, 16); + th_done($q); } -sub th4 { - th_start(); +sub th4 +{ + my $q = shift; + th_start($q); threads->detach(); - th_signal(3); - th_done(); + th_signal($q, 3); + th_done($q); } -sub th8 { - th_start(); +sub th8 +{ + my $q = shift; + th_start($q); threads->detach(); - th_signal(7); - th_done(); + th_signal($q, 7); + th_done($q); } -sub th12 { - th_start(); +sub th12 +{ + my $q = shift; + th_start($q); threads->detach(); - th_signal(13); - th_done(); + th_signal($q, 13); + th_done($q); } -sub th16 { - th_start(); +sub th16 +{ + my $q = shift; + th_start($q); threads->detach(); - th_signal(17); - th_done(); + th_signal($q, 17); + th_done($q); } -sub th3 { +sub th3 +{ + my $q = shift; my $tid = threads->tid(); my $other = 5; - th_start(); + th_start($q); threads->detach(); - th_signal($other); + th_signal($q, $other); sleep(1); - ok(1, "Thread $tid getting return from thread $other"); + $q->enqueue(1, "Thread $tid getting return from thread $other"); my $ret = threads->object($other)->join(); - ok($ret == $other, "Thread $tid saw that thread $other returned $ret"); - th_done(); + $q->enqueue($ret == $other, "Thread $tid saw that thread $other returned $ret"); + th_done($q); } -sub th5 { - th_start(); - th_done(); +sub th5 +{ + my $q = shift; + th_start($q); + th_done($q); return (threads->tid()); } -sub th7 { +sub th7 +{ + my $q = shift; my $tid = threads->tid(); my $other = 9; - th_start(); + th_start($q); threads->detach(); - th_signal($other); - ok(1, "Thread $tid getting return from thread $other"); + th_signal($q, $other); + $q->enqueue(1, "Thread $tid getting return from thread $other"); my $ret = threads->object($other)->join(); - ok($ret == $other, "Thread $tid saw that thread $other returned $ret"); - th_done(); + $q->enqueue($ret == $other, "Thread $tid saw that thread $other returned $ret"); + th_done($q); } -sub th9 { - th_start(); +sub th9 +{ + my $q = shift; + th_start($q); sleep(1); - th_done(); + th_done($q); return (threads->tid()); } -sub th13 { +sub th13 +{ + my $q = shift; my $tid = threads->tid(); my $other = 11; - th_start(); + th_start($q); threads->detach(); - th_signal($other); + th_signal($q, $other); sleep(1); - ok(1, "Thread $tid getting return from thread $other"); + $q->enqueue(1, "Thread $tid getting return from thread $other"); my $ret = threads->object($other)->join(); - ok($ret == $other, "Thread $tid saw that thread $other returned $ret"); - th_done(); + $q->enqueue($ret == $other, "Thread $tid saw that thread $other returned $ret"); + th_done($q); } -sub th11 { - th_start(); - th_done(); +sub th11 +{ + my $q = shift; + th_start($q); + th_done($q); return (threads->tid()); } -sub th17 { +sub th17 +{ + my $q = shift; my $tid = threads->tid(); my $other = 15; - th_start(); + th_start($q); threads->detach(); - th_signal($other); - ok(1, "Thread $tid getting return from thread $other"); + th_signal($q, $other); + $q->enqueue(1, "Thread $tid getting return from thread $other"); my $ret = threads->object($other)->join(); - ok($ret == $other, "Thread $tid saw that thread $other returned $ret"); - th_done(); + $q->enqueue($ret == $other, "Thread $tid saw that thread $other returned $ret"); + th_done($q); } -sub th15 { - th_start(); +sub th15 +{ + my $q = shift; + th_start($q); sleep(1); - th_done(); + th_done($q); return (threads->tid()); } @@ -284,11 +324,12 @@ sub th15 { TEST_STARTS_HERE: { $COUNT = 0; - threads->create('th1'); + threads->create('th1', $q); { lock($COUNT); while ($COUNT < 17) { cond_wait($COUNT); + ok(); # Prints out any intermediate results } } sleep(1); diff --git a/ext/threads/t/kill.t b/ext/threads/t/kill.t index 3874db1..a361ee3 100644 --- a/ext/threads/t/kill.t +++ b/ext/threads/t/kill.t @@ -35,63 +35,39 @@ BEGIN { print("1..0 # Skip: Not using safe signals\n"); exit(0); } -} - -{ - package Thread::Semaphore; - use threads::shared; - sub new { - my $class = shift; - my $val : shared = @_ ? shift : 1; - bless \$val, $class; - } + require Thread::Queue; + require Thread::Semaphore; - sub down { - my $s = shift; - lock($$s); - my $inc = @_ ? shift : 1; - cond_wait $$s until $$s >= $inc; - $$s -= $inc; - } - - sub up { - my $s = shift; - lock($$s); - my $inc = @_ ? shift : 1; - ($$s += $inc) > 0 and cond_broadcast $$s; - } -} - -BEGIN { $| = 1; - print("1..19\n"); ### Number of tests that will be run ### + print("1..18\n"); ### Number of tests that will be run ### }; -my $TEST = 1; -share($TEST); - -ok(1, 'Loaded'); - -sub ok { - my ($ok, $name) = @_; - lock($TEST); - my $id = $TEST++; +my $q = Thread::Queue->new(); +my $TEST = 1; - # 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]); +sub ok +{ + $q->enqueue(@_); + + while ($q->pending()) { + my $ok = $q->dequeue(); + my $name = $q->dequeue(); + my $id = $TEST++; + + if ($ok) { + print("ok $id - $name\n"); + } else { + print("not ok $id - $name\n"); + printf("# Failed test at line %d\n", (caller)[2]); + } } - - return ($ok); } ### Start of Testing ### +ok(1, 'Loaded'); ### Thread cancel ### @@ -99,44 +75,33 @@ sub ok { my @errs :shared; $SIG{__WARN__} = sub { push(@errs, @_); }; - sub thr_func { + my $q = shift; + # Thread 'cancellation' signal handler $SIG{'KILL'} = sub { - ok(1, 'Thread received signal'); + $q->enqueue(1, 'Thread received signal'); die("Thread killed\n"); }; # Thread sleeps until signalled - ok(1, 'Thread sleeping'); - { - local $SIG{'INT'} = sub {}; - sleep(5); - } + $q->enqueue(1, 'Thread sleeping'); + sleep(1) for (1..10); # Should not go past here - ok(0, 'Thread terminated normally'); + $q->enqueue(0, 'Thread terminated normally'); return ('ERROR'); } - # Create thread -my $thr = threads->create('thr_func'); +my $thr = threads->create('thr_func', $q); ok($thr && $thr->tid() == 2, 'Created thread'); threads->yield(); sleep(1); # Signal thread -ok($thr->kill('KILL'), 'Signalled thread'); +ok($thr->kill('KILL') == $thr, 'Signalled thread'); threads->yield(); -# Interrupt thread's sleep call -{ - # We can't be sure whether the signal itself will get delivered to this - # thread or the sleeping thread - local $SIG{'INT'} = sub {}; - ok(kill('INT', $$) || $^O eq 'MSWin32', q/Interrupt thread's sleep call/); -} - # Cleanup my $rc = $thr->join(); ok(! $rc, 'No thread return value'); @@ -149,21 +114,23 @@ ok(@errs && $errs[0] =~ /Thread killed/, 'Thread termination warning'); sub thr_func2 { + my $q = shift; + my $sema = shift; - ok($sema, 'Thread received semaphore'); + $q->enqueue($sema, 'Thread received semaphore'); # Set up the signal handler for suspension/resumption $SIG{'STOP'} = sub { - ok(1, 'Thread suspending'); + $q->enqueue(1, 'Thread suspending'); $sema->down(); - ok(1, 'Thread resuming'); + $q->enqueue(1, 'Thread resuming'); $sema->up(); }; # Set up the signal handler for graceful termination my $term = 0; $SIG{'TERM'} = sub { - ok(1, 'Thread caught termination signal'); + $q->enqueue(1, 'Thread caught termination signal'); $term = 1; }; @@ -172,7 +139,7 @@ sub thr_func2 sleep(1); } - ok(1, 'Thread done'); + $q->enqueue(1, 'Thread done'); return ('OKAY'); } @@ -182,14 +149,14 @@ my $sema = Thread::Semaphore->new(); ok($sema, 'Semaphore created'); # Create a thread and send it the semaphore -$thr = threads->create('thr_func2', $sema); +$thr = threads->create('thr_func2', $q, $sema); ok($thr && $thr->tid() == 3, 'Created thread'); threads->yield(); sleep(1); # Suspend the thread $sema->down(); -ok($thr->kill('STOP'), 'Suspended thread'); +ok($thr->kill('STOP') == $thr, 'Suspended thread'); threads->yield(); sleep(1); @@ -206,6 +173,6 @@ ok($thr->kill('TERM') == $thr, 'Signalled thread to terminate'); $rc = $thr->join(); ok($rc eq 'OKAY', 'Thread return value'); -ok($thr->kill('TERM'), 'Ignore signal to terminated thread'); +ok($thr->kill('TERM') == $thr, 'Ignore signal to terminated thread'); # EOF diff --git a/ext/threads/t/thread.t b/ext/threads/t/thread.t index aed1d49..6c00578 100644 --- a/ext/threads/t/thread.t +++ b/ext/threads/t/thread.t @@ -171,7 +171,7 @@ package main; # bugid #24165 -run_perl(prog => 'use threads 1.61;' . +run_perl(prog => 'use threads 1.62;' . 'sub a{threads->create(shift)} $t = a sub{};' . '$t->tid; $t->join; $t->tid', nolib => ($ENV{PERL_CORE}) ? 0 : 1, diff --git a/ext/threads/threads.pm b/ext/threads/threads.pm index 2c9ee4d..2f63636 100755 --- a/ext/threads/threads.pm +++ b/ext/threads/threads.pm @@ -5,7 +5,7 @@ use 5.008; use strict; use warnings; -our $VERSION = '1.61'; +our $VERSION = '1.62'; my $XS_VERSION = $VERSION; $VERSION = eval $VERSION; @@ -62,7 +62,7 @@ sub import } elsif ($sym =~ /^str/i) { import overload ('""' => \&tid); - } elsif ($sym =~ /^(?:all|yield)$/) { + } elsif ($sym =~ /^(?::all|yield)$/) { push(@EXPORT, qw(yield)); } else { @@ -138,7 +138,7 @@ threads - Perl interpreter-based threads =head1 VERSION -This document describes threads version 1.61 +This document describes threads version 1.62 =head1 SYNOPSIS @@ -959,7 +959,10 @@ L Discussion Forum on CPAN: L Annotated POD for L: -L +L + +Source repository: +L L, L diff --git a/ext/threads/threads.xs b/ext/threads/threads.xs index aa93767..f43b428 100755 --- a/ext/threads/threads.xs +++ b/ext/threads/threads.xs @@ -848,7 +848,7 @@ ithread_create(...) CODE: if ((items >= 2) && SvROK(ST(1)) && SvTYPE(SvRV(ST(1)))==SVt_PVHV) { if (--items < 2) { - Perl_croak(aTHX_ "Usage: threads->create(\\%specs, function, ...)"); + Perl_croak(aTHX_ "Usage: threads->create(\\%%specs, function, ...)"); } specs = (HV*)SvRV(ST(1)); idx = 1;