[PATCH-revised] Upgrade to Thread-Semaphore 2.11

From fae4a2d97dbec5b5407fef6570fb91c246d5d428 Mon Sep 17 00:00:00 2001
From: Jerry D. Hedden <[email protected]>
Date: Thu, 10 Jun 2010 22:13:25 -0400
Subject: [PATCH] Upgrade to Thread::Semaphore 2.11

---
 MANIFEST                                      |    2 +
 Porting/Maintainers.pl                        |    2 +-
 dist/Thread-Semaphore/lib/Thread/Semaphore.pm |  133 +++++++++++++++++++------
 dist/Thread-Semaphore/t/02_errs.t             |   17 ++--
 dist/Thread-Semaphore/t/03_nothreads.t        |    4 +-
 dist/Thread-Semaphore/t/04_nonblocking.t      |   62 ++++++++++++
 dist/Thread-Semaphore/t/05_force.t            |   59 +++++++++++
 7 files changed, 236 insertions(+), 43 deletions(-)
 create mode 100644 dist/Thread-Semaphore/t/04_nonblocking.t
 create mode 100644 dist/Thread-Semaphore/t/05_force.t

diff --git a/MANIFEST b/MANIFEST
index 197d359..a5ab58d 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -2831,6 +2831,8 @@ dist/Thread-Semaphore/lib/Thread/Semaphore.pm	Thread-safe semaphores
 dist/Thread-Semaphore/t/01_basic.t		Thread::Semaphore tests
 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/threads/hints/hpux.pl	Hint file for HPUX
 dist/threads/hints/linux.pl	Hint file for Linux
 dist/threads/Makefile.PL	ithreads
diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl
index 49e6525..2c39cf6 100755
--- a/Porting/Maintainers.pl
+++ b/Porting/Maintainers.pl
@@ -1406,7 +1406,7 @@ use File::Glob qw(:case);
     'Thread::Semaphore' =>
 	{
 	'MAINTAINER'	=> 'jdhedden',
-	'DISTRIBUTION'	=> 'JDHEDDEN/Thread-Semaphore-2.09.tar.gz',
+	'DISTRIBUTION'	=> 'JDHEDDEN/Thread-Semaphore-2.11.tar.gz',
 	'FILES'		=> q[dist/Thread-Semaphore],
 	'EXCLUDED'	=> [ qw(examples/semaphore.pl
 				t/00_load.t
diff --git a/dist/Thread-Semaphore/lib/Thread/Semaphore.pm b/dist/Thread-Semaphore/lib/Thread/Semaphore.pm
index 67cb30e..8ce2429 100644
--- a/dist/Thread-Semaphore/lib/Thread/Semaphore.pm
+++ b/dist/Thread-Semaphore/lib/Thread/Semaphore.pm
@@ -3,60 +3,96 @@ package Thread::Semaphore;
 use strict;
 use warnings;
 
-our $VERSION = '2.09';
+our $VERSION = '2.11';
+$VERSION = eval $VERSION;
 
 use threads::shared;
 use Scalar::Util 1.10 qw(looks_like_number);
 
+# Predeclarations for internal functions
+my ($validate_arg);
+
 # Create a new semaphore optionally with specified count (count defaults to 1)
 sub new {
     my $class = shift;
-    my $val :shared = @_ ? shift : 1;
-    if (!defined($val) ||
-        ! looks_like_number($val) ||
-        (int($val) != $val))
-    {
-        require Carp;
-        $val = 'undef' if (! defined($val));
-        Carp::croak("Semaphore initializer is not an integer: $val");
+
+    my $val :shared = 1;
+    if (@_) {
+        $val = shift;
+        if (! defined($val) ||
+            ! looks_like_number($val) ||
+            (int($val) != $val))
+        {
+            require Carp;
+            $val = 'undef' if (! defined($val));
+            Carp::croak("Semaphore initializer is not an integer: $val");
+        }
     }
+
     return bless(\$val, $class);
 }
 
 # Decrement a semaphore's count (decrement amount defaults to 1)
 sub down {
     my $sema = shift;
+    my $dec = @_ ? $validate_arg->(shift) : 1;
+
     lock($$sema);
-    my $dec = @_ ? shift : 1;
-    if (! defined($dec) ||
-        ! looks_like_number($dec) ||
-        (int($dec) != $dec) ||
-        ($dec < 1))
-    {
-        require Carp;
-        $dec = 'undef' if (! defined($dec));
-        Carp::croak("Semaphore decrement is not a positive integer: $dec");
-    }
     cond_wait($$sema) until ($$sema >= $dec);
     $$sema -= $dec;
 }
 
+# Decrement a semaphore's count only if count >= decrement value
+#  (decrement amount defaults to 1)
+sub down_nb {
+    my $sema = shift;
+    my $dec = @_ ? $validate_arg->(shift) : 1;
+
+    lock($$sema);
+    my $ok = ($$sema >= $dec);
+    $$sema -= $dec if $ok;
+    return $ok;
+}
+
+# Decrement a semaphore's count even if the count goes below 0
+#  (decrement amount defaults to 1)
+sub down_force {
+    my $sema = shift;
+    my $dec = @_ ? $validate_arg->(shift) : 1;
+
+    lock($$sema);
+    $$sema -= $dec;
+}
+
 # Increment a semaphore's count (increment amount defaults to 1)
 sub up {
     my $sema = shift;
+    my $inc = @_ ? $validate_arg->(shift) : 1;
+
     lock($$sema);
-    my $inc = @_ ? shift : 1;
-    if (! defined($inc) ||
-        ! looks_like_number($inc) ||
-        (int($inc) != $inc) ||
-        ($inc < 1))
+    ($$sema += $inc) > 0 and cond_broadcast($$sema);
+}
+
+### Internal Functions ###
+
+# Validate method argument
+$validate_arg = sub {
+    my $arg = shift;
+
+    if (! defined($arg) ||
+        ! looks_like_number($arg) ||
+        (int($arg) != $arg) ||
+        ($arg < 1))
     {
         require Carp;
-        $inc = 'undef' if (! defined($inc));
-        Carp::croak("Semaphore increment is not a positive integer: $inc");
+        my ($method) = (caller(1))[3];
+        $method =~ s/Thread::Semaphore:://;
+        $arg = 'undef' if (! defined($arg));
+        Carp::croak("Argument to semaphore method '$method' is not a positive integer: $arg");
     }
-    ($$sema += $inc) > 0 and cond_broadcast($$sema);
-}
+
+    return $arg;
+};
 
 1;
 
@@ -66,7 +102,7 @@ Thread::Semaphore - Thread-safe semaphores
 
 =head1 VERSION
 
-This document describes Thread::Semaphore version 2.09
+This document describes Thread::Semaphore version 2.11
 
 =head1 SYNOPSIS
 
@@ -76,10 +112,24 @@ This document describes Thread::Semaphore version 2.09
     # The guarded section is here
     $s->up();     # Also known as the semaphore V operation.
 
-    # The default semaphore value is 1
+    # Decrement the semaphore only if it would immediately succeed.
+    if ($s->down_nb()) {
+        # The guarded section is here
+        $s->up();
+    }
+
+    # Forcefully decrement the semaphore even if its count goes below 0.
+    $s->down_force();
+
+    # The default value for semaphore operations is 1
     my $s = Thread::Semaphore-new($initial_value);
     $s->down($down_value);
     $s->up($up_value);
+    if ($s->down_nb($down_value)) {
+        ...
+        $s->up($up_value);
+    }
+    $s->down_force($down_value);
 
 =head1 DESCRIPTION
 
@@ -119,6 +169,27 @@ This is the semaphore "P operation" (the name derives from the Dutch
 word "pak", which means "capture" -- the semaphore operations were
 named by the late Dijkstra, who was Dutch).
 
+=item ->down_nb()
+
+=item ->down_nb(NUMBER)
+
+The C<down_nb> method attempts to decrease the semaphore's count by the
+specified number (which must be an integer >= 1), or by one if no number
+is specified.
+
+If the semaphore's count would drop below zero, 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 ->down_force()
+
+=item ->down_force(NUMBER)
+
+The C<down_force> method decreases the semaphore's count by the specified
+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 ->up()
 
 =item ->up(NUMBER)
@@ -151,7 +222,7 @@ Thread::Semaphore Discussion Forum on CPAN:
 L<http://www.cpanforum.com/dist/Thread-Semaphore>
 
 Annotated POD for Thread::Semaphore:
-L<http://annocpan.org/~JDHEDDEN/Thread-Semaphore-2.09/lib/Thread/Semaphore.pm>
+L<http://annocpan.org/~JDHEDDEN/Thread-Semaphore-2.11/lib/Thread/Semaphore.pm>
 
 Source repository:
 L<http://code.google.com/p/thread-semaphore/>
diff --git a/dist/Thread-Semaphore/t/02_errs.t b/dist/Thread-Semaphore/t/02_errs.t
index 45b0aa9..e336b94 100644
--- a/dist/Thread-Semaphore/t/02_errs.t
+++ b/dist/Thread-Semaphore/t/02_errs.t
@@ -3,9 +3,9 @@ use warnings;
 
 use Thread::Semaphore;
 
-use Test::More 'tests' => 12;
+use Test::More 'tests' => 9;
 
-my $err = qr/^Semaphore .* is not .* integer: /;
+my $err = qr/^Semaphore initializer is not an integer: /;
 
 eval { Thread::Semaphore->new(undef); };
 like($@, $err, $@);
@@ -17,8 +17,12 @@ like($@, $err, $@);
 my $s = Thread::Semaphore->new();
 ok($s, 'New semaphore');
 
+$err = qr/^Argument to semaphore method .* is not a positive integer: /;
+
 eval { $s->down(undef); };
 like($@, $err, $@);
+eval { $s->down(0); };
+like($@, $err, $@);
 eval { $s->down(-1); };
 like($@, $err, $@);
 eval { $s->down(1.5); };
@@ -26,14 +30,7 @@ like($@, $err, $@);
 eval { $s->down('foo'); };
 like($@, $err, $@);
 
-eval { $s->up(undef); };
-like($@, $err, $@);
-eval { $s->up(-1); };
-like($@, $err, $@);
-eval { $s->up(1.5); };
-like($@, $err, $@);
-eval { $s->up('foo'); };
-like($@, $err, $@);
+# No need to test ->up(), etc. as the arg validation code is common to them all
 
 exit(0);
 
diff --git a/dist/Thread-Semaphore/t/03_nothreads.t b/dist/Thread-Semaphore/t/03_nothreads.t
index f0454be..b8b2f0f 100644
--- a/dist/Thread-Semaphore/t/03_nothreads.t
+++ b/dist/Thread-Semaphore/t/03_nothreads.t
@@ -1,7 +1,7 @@
 use strict;
 use warnings;
 
-use Test::More 'tests' => 4;
+use Test::More 'tests' => 6;
 
 use Thread::Semaphore;
 
@@ -13,6 +13,8 @@ $s->up(2);
 is($$s, 2, 'Non-threaded semaphore');
 $s->down();
 is($$s, 1, 'Non-threaded semaphore');
+ok(! $s->down_nb(2), 'Non-threaded semaphore');
+ok($s->down_nb(), 'Non-threaded semaphore');
 
 exit(0);
 
diff --git a/dist/Thread-Semaphore/t/04_nonblocking.t b/dist/Thread-Semaphore/t/04_nonblocking.t
new file mode 100644
index 0000000..9c06969
--- /dev/null
+++ b/dist/Thread-Semaphore/t/04_nonblocking.t
@@ -0,0 +1,62 @@
+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' => 13);
+
+### Basic usage with multiple threads ###
+
+my $sm = Thread::Semaphore->new(0);
+my $st = Thread::Semaphore->new(0);
+ok($sm, 'New Semaphore');
+ok($st, 'New Semaphore');
+
+my $token :shared = 0;
+
+threads->create(sub {
+    ok(! $st->down_nb(), 'Semaphore unavailable to thread');
+    $sm->up();
+
+    $st->down(2);
+    ok(! $st->down_nb(5), 'Semaphore unavailable to thread');
+    ok($st->down_nb(2), 'Thread 1 got semaphore');
+    ok(! $st->down_nb(2), 'Semaphore unavailable to thread');
+    ok($st->down_nb(1), 'Thread 1 got semaphore');
+    ok(! $st->down_nb(), 'Semaphore unavailable to thread');
+    is($token++, 1, 'Thread done');
+    $sm->up();
+})->detach();
+
+$sm->down(1);
+is($token++, 0, 'Main has semaphore');
+$st->up();
+
+ok(! $sm->down_nb(), 'Semaphore unavailable to main');
+$st->up(4);
+
+$sm->down();
+is($token++, 2, 'Main got semaphore');
+
+ok(1, 'Main done');
+threads::yield();
+
+exit(0);
+
+# EOF
diff --git a/dist/Thread-Semaphore/t/05_force.t b/dist/Thread-Semaphore/t/05_force.t
new file mode 100644
index 0000000..c1ed70b
--- /dev/null
+++ b/dist/Thread-Semaphore/t/05_force.t
@@ -0,0 +1,59 @@
+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' => 8);
+
+### Basic usage with multiple threads ###
+
+my $sm = Thread::Semaphore->new(0);
+my $st = Thread::Semaphore->new(0);
+ok($sm, 'New Semaphore');
+ok($st, 'New Semaphore');
+
+my $token :shared = 0;
+
+threads->create(sub {
+    $st->down_force(2);
+    is($token++, 0, 'Thread got semaphore');
+    $sm->up();
+
+    $st->down();
+    is($token++, 3, 'Thread done');
+    $sm->up();
+})->detach();
+
+$sm->down();
+is($token++, 1, 'Main has semaphore');
+$st->up(2);
+threads::yield();
+
+is($token++, 2, 'Main still has semaphore');
+$st->up();
+
+$sm->down();
+is($token, 4, 'Main re-got semaphore');
+
+ok(1, 'Main done');
+threads::yield();
+
+exit(0);
+
+# EOF
-- 
1.6.1.2