[PATCH-revised] Upgrade to Thread-Semaphore 2.11

  Added new methods ->down_nb() and ->down_force() at the suggestion of
  Rick Garlick.

  Refactored methods to skip argument validation when no argument is supplied.

Signed-off-by: Chris 'BinGOs' Williams <chris@bingosnet.co.uk>

diff --git a/MANIFEST b/MANIFEST
index 197d359..a5ab58d 100644 (file)
--- 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 (executable)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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);