Thread-Semaphore: Update to 2.13

Added down_timed method.

Author: Reini Urban

MANIFEST

@@ -3781,6 +3781,7 @@ dist/Thread-Semaphore/t/02_errs.t		Thread::Semaphore tests
 dist/Thread-Semaphore/t/03_nothreads.t		Thread::Semaphore tests
 dist/Thread-Semaphore/t/04_nonblocking.t	Thread::Semaphore tests
 dist/Thread-Semaphore/t/05_force.t	Thread::Semaphore tests
+dist/Thread-Semaphore/t/06_timed.t
 dist/threads/hints/hpux.pl	Hint file for HPUX
 dist/threads/hints/linux.pl	Hint file for Linux
 dist/threads/lib/threads.pm		ithreads

Porting/Maintainers.pl

@@ -1393,7 +1393,7 @@ package Maintainers;
     },
 
     'Thread::Semaphore' => {
-        'DISTRIBUTION' => 'JDHEDDEN/Thread-Semaphore-2.12.tar.gz',
+        'DISTRIBUTION' => 'JDHEDDEN/Thread-Semaphore-2.13.tar.gz',
         'FILES'        => q[dist/Thread-Semaphore],
         'EXCLUDED'     => [
             qw( examples/semaphore.pl

dist/Module-CoreList/lib/Module/CoreList.pm

@@ -13365,6 +13365,7 @@ for my $version ( sort { version_sort($a, $b) } keys %released ) {
             'ExtUtils::Command::MM' => '8.04_04',
             'Storable'              => '3.01c',
             'Term::ReadKey'         => '2.37_01',
+            'Thread::Semaphore'     => '2.13',
             'Cpanel::JSON::XS'      => '3.0218',
             'CPAN::Meta'            => '2.150010c',
             'CPAN::Meta::Converter' => '2.150010',

dist/Thread-Semaphore/lib/Thread/Semaphore.pm

@@ -3,7 +3,7 @@ package Thread::Semaphore;
 use strict;
 use warnings;
 
-our $VERSION = '2.12';
+our $VERSION = '2.13';
 $VERSION = eval $VERSION;
 
 use threads::shared;
@@ -64,6 +64,22 @@ sub down_force {
     $$sema -= $dec;
 }
 
+# Decrement a semaphore's count with timeout
+#  (timeout in seconds; decrement amount defaults to 1)
+sub down_timed {
+    my $sema = shift;
+    my $timeout = $validate_arg->(shift);
+    my $dec = @_ ? $validate_arg->(shift) : 1;
+
+    lock($$sema);
+    my $abs = time() + $timeout;
+    until ($$sema >= $dec) {
+        return if !cond_timedwait($$sema, $abs);
+    }
+    $$sema -= $dec;
+    return 1;
+}
+
 # Increment a semaphore's count (increment amount defaults to 1)
 sub up {
     my $sema = shift;
@@ -102,7 +118,7 @@ Thread::Semaphore - Thread-safe semaphores
 
 =head1 VERSION
 
-This document describes Thread::Semaphore version 2.12
+This document describes Thread::Semaphore version 2.13
 
 =head1 SYNOPSIS
 
@@ -190,6 +206,23 @@ number (which must be an integer >= 1), or by one if no number is specified.
 This method does not block, and may cause the semaphore's count to drop
 below zero.
 
+=item ->down_timed(TIMEOUT)
+
+=item ->down_timed(TIMEOUT, NUMBER)
+
+The C<down_timed> method attempts to decrease the semaphore's count by 1
+or by the specified number within the specified timeout period given in
+seconds (which must be an integer >= 0).
+
+If the semaphore's count would drop below zero, this method will block
+until either the semaphore's count is greater than or equal to the
+amount you're C<down>ing the semaphore's count by, or until the timeout is
+reached.
+
+If the timeout is reached, this method will return I<false>, and the
+semaphore's count remains unchanged.  Otherwise, the semaphore's count is
+decremented and this method returns I<true>.
+
 =item ->up()
 
 =item ->up(NUMBER)
@@ -218,11 +251,16 @@ environment.
 
 =head1 SEE ALSO
 
-Thread::Semaphore Discussion Forum on CPAN:
-L<http://www.cpanforum.com/dist/Thread-Semaphore>
+Thread::Semaphore on MetaCPAN:
+L<https://metacpan.org/release/Thread-Semaphore>
+
+Code repository for CPAN distribution:
+L<https://github.com/Dual-Life/Thread-Semaphore>
 
 L<threads>, L<threads::shared>
 
+Sample code in the I<examples> directory of this distribution on CPAN.
+
 =head1 MAINTAINER
 
 Jerry D. Hedden, S<E<lt>jdhedden AT cpan DOT orgE<gt>>

dist/Thread-Semaphore/t/01_basic.t

@@ -35,7 +35,6 @@ my @threads;
 push @threads, threads->create(sub {
     $st->down();
     is($token++, 1, 'Thread 1 got semaphore');
-    $st->up();
     $sm->up();
 
     $st->down(4);
@@ -46,7 +45,6 @@ push @threads, threads->create(sub {
 push @threads, threads->create(sub {
     $st->down(2);
     is($token++, 3, 'Thread 2 got semaphore');
-    $st->up();
     $sm->up();
 
     $st->down(4);
@@ -68,11 +66,11 @@ $st->up(9);
 
 $sm->down(2);
 $st->down();
-ok(1, 'Main done');
-threads::yield();
 
 $_->join for @threads;
 
+ok(1, 'Main done');
+
 exit(0);
 
 # EOF

dist/Thread-Semaphore/t/03_nothreads.t

@@ -1,7 +1,7 @@
 use strict;
 use warnings;
 
-use Test::More 'tests' => 6;
+use Test::More 'tests' => 7;
 
 use Thread::Semaphore;
 
@@ -15,6 +15,7 @@ $s->down();
 is($$s, 1, 'Non-threaded semaphore');
 ok(! $s->down_nb(2), 'Non-threaded semaphore');
 ok($s->down_nb(), 'Non-threaded semaphore');
+ok(! $s->down_timed(1), 'Non-threaded semaphore');
 
 exit(0);
 

dist/Thread-Semaphore/t/05_force.t

@@ -51,11 +51,10 @@ $st->up();
 $sm->down();
 is($token, 4, 'Main re-got semaphore');
 
-ok(1, 'Main done');
-threads::yield();
-
 $thread->join;
 
+ok(1, 'Main done');
+
 exit(0);
 
 # EOF

dist/Thread-Semaphore/t/06_timed.t

@@ -0,0 +1,76 @@
+use strict;
+use warnings;
+
+BEGIN {
+    use Config;
+    if (! $Config{'useithreads'}) {
+        print("1..0 # SKIP Perl not compiled with 'useithreads'\n");
+        exit(0);
+    }
+}
+
+use threads;
+use threads::shared;
+use Thread::Semaphore;
+
+if ($] == 5.008) {
+    require 't/test.pl';   # Test::More work-alike for Perl 5.8.0
+} else {
+    require Test::More;
+}
+Test::More->import();
+plan('tests' => 10);
+
+### Basic usage with multiple threads ###
+
+my $sm = Thread::Semaphore->new();
+my $st = Thread::Semaphore->new(0);
+ok($sm, 'New Semaphore');
+ok($st, 'New Semaphore');
+
+my $token :shared = 0;
+
+my @threads;
+
+push @threads, threads->create(sub {
+    $st->down_timed(3);
+    is($token++, 1, 'Thread 1 got semaphore');
+    $sm->up();
+
+    $st->down_timed(3, 4);
+    is($token, 5, 'Thread 1 done');
+    $sm->up();
+});
+
+push @threads, threads->create(sub {
+    $st->down_timed(3, 2);
+    is($token++, 3, 'Thread 2 got semaphore');
+    $sm->up();
+
+    # Force timeout by asking for more than will ever show up
+    ok(! $st->down_timed(1, 10), 'Thread 2 timed out');
+    $sm->up();
+});
+
+$sm->down();
+is($token++, 0, 'Main has semaphore');
+$st->up();
+
+$sm->down();
+is($token++, 2, 'Main got semaphore');
+$st->up(2);
+
+$sm->down();
+is($token++, 4, 'Main re-got semaphore');
+$st->up(5);
+
+$sm->down(2);
+$st->down();
+
+$_->join for @threads;
+
+ok(1, 'Main done');
+
+exit(0);
+
+# EOF

pod/perlcdelta.pod

@@ -445,6 +445,10 @@ See L<https://metacpan.org/changes/distribution/Sys-Syslog>
 Kept our smoker logic in F<t/syslog.t>, for slow darwin systems,
 the suse patch and disabled the lexical filehandle patch.
 
+=item Thread-Semaphore  2.13
+
+Added C<down_timed> method.
+
 =back
 
 =head1 Documentation

t/porting/customized.dat

@@ -62,7 +62,7 @@ File::Path cpan/File-Path/t/Path_win32.t 94b9276557ce7f80b91f6fd9bfa7a0cd9bf9683
 File::Spec dist/PathTools/t/rel2abs_vs_symlink.t abbf1a890a1b6fefebc0c8a9e2849694ade89fa9
 IO::Socket::IP cpan/IO-Socket-IP/lib/IO/Socket/IP.pm fb1175286262913bec59482b84a3587ec48339ea
 JSON::PP cpan/JSON-PP/lib/JSON/PP.pm ea210ef037088b8ff77db8a0c149e09032a4beab
-Module::CoreList dist/Module-CoreList/lib/Module/CoreList.pm 943a8048cd3f5f01899850c0e4c46559245918aa
+Module::CoreList dist/Module-CoreList/lib/Module/CoreList.pm f27b15d4b275a468ffa4c0867ac6a759b7e54d12
 Module::CoreList dist/Module-CoreList/lib/Module/CoreList/Utils.pm c968b0977900360ef0cf739ee9f9c6be6ce91afc
 Module::Metadata cpan/Module-Metadata/t/lib/GeneratePackage.pm 502ffbe2609947430e6aa1a3df8064b3fef3e086
 Net::Domain cpan/libnet/lib/Net/Cmd.pm 70a007c38833667ad47ea8059c37c1b7d1c77b6c