Thread-Semaphore v2.11

Changes

@@ -1,5 +1,11 @@
 Revision history for Perl extension Thread::Semaphore.
 
+2.11 Thu Jun 11 02:14:41 2010
+	- Added ->down_nb() and ->down_force()
+	- Skip argument validation when no argument
+	- Install in 'site' for Perl >= 5.011
+	- Test file changes for core
+
 2.09 Thu Jun 12 13:40:19 2008
 	- End all tests with exit(0) and fix SKIPs
 

MANIFEST

@@ -7,6 +7,8 @@ t/00_load.t
 t/01_basic.t
 t/02_errs.t
 t/03_nothreads.t
+t/04_nonblocking.t
+t/05_force.t
 t/99_pod.t
 t/test.pl
 examples/semaphore.pl

Makefile.PL

@@ -18,7 +18,7 @@ WriteMakefile(
         'Scalar::Util'    => 1.10,
         'Test::More'      => 0.50,
     },
-    'INSTALLDIRS'   => 'perl',
+    'INSTALLDIRS'   => (($] < 5.011) ? 'perl' : 'site'),
 
     ((ExtUtils::MakeMaker->VERSION() lt '6.25') ?
         ('PL_FILES' => { })            : ()),

README

@@ -1,4 +1,4 @@
-Thread::Semaphore version 2.09
+Thread::Semaphore version 2.11
 ==============================
 
 Thread-safe Semaphores

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/>

t/01_basic.t

@@ -2,10 +2,6 @@ use strict;
 use warnings;
 
 BEGIN {
-    if ($ENV{'PERL_CORE'}){
-        chdir('t');
-        unshift(@INC, '../lib');
-    }
     use Config;
     if (! $Config{'useithreads'}) {
         print("1..0 # SKIP Perl not compiled with 'useithreads'\n");

t/02_errs.t

@@ -1,18 +1,11 @@
 use strict;
 use warnings;
 
-BEGIN {
-    if ($ENV{'PERL_CORE'}){
-        chdir('t');
-        unshift(@INC, '../lib');
-    }
-}
-
 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, $@);
@@ -24,23 +17,20 @@ 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); };
 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);
 

t/03_nothreads.t

@@ -1,14 +1,7 @@
 use strict;
 use warnings;
 
-BEGIN {
-    if ($ENV{'PERL_CORE'}){
-        chdir('t');
-        unshift(@INC, '../lib');
-    }
-}
-
-use Test::More 'tests' => 4;
+use Test::More 'tests' => 6;
 
 use Thread::Semaphore;
 
@@ -20,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);
 

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