Thread::Semaphore 2.04

From: "Jerry D. Hedden" <jdhedden@cpan.org>
Message-ID: <1ff86f510802150812r3facd53cs1913dd82c3070ac0@mail.gmail.com>

p4raw-id: //depot/perl@33329

6 files changed, 239 insertions, 77 deletions

diff --git a/MANIFEST b/MANIFEST
index ef2505a2b9..d9705c86cd 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -2807,8 +2807,9 @@ lib/Text/Wrap.pm		Paragraph formatter
 lib/Thread.pm			Thread extensions frontend
 lib/Thread/Queue.pm		Threadsafe queue
 lib/Thread/Queue.t		See if threadsafe queue works
-lib/Thread/Semaphore.pm		Threadsafe semaphore
-lib/Thread/Semaphore.t		See if threadsafe semaphore works
+lib/Thread/Semaphore.pm		Thread-safe semaphores
+lib/Thread/Semaphore/t/01_basic.t	Thread::Semaphore tests
+lib/Thread/Semaphore/t/02_errs.t	Thread::Semaphore tests
 lib/Thread.t			Thread extensions frontend tests
 lib/Tie/Array.pm		Base class for tied arrays
 lib/Tie/Array/push.t		Test for Tie::Array
diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl
index 06053dc947..94dfafbefb 100644
--- a/Porting/Maintainers.pl
+++ b/Porting/Maintainers.pl
@@ -882,6 +882,13 @@ package Maintainers;
 		'CPAN'		=> 1,
 		},
 
+	'Thread::Semaphore' =>
+		{
+		'MAINTAINER'	=> 'jdhedden',
+		'FILES'		=> q[lib/Thread/Semaphore.pm lib/Thread/Semaphore],
+		'CPAN'		=> 1,
+		},
+
 	'threads' =>
 		{
 		'MAINTAINER'	=> 'jdhedden',
@@ -932,13 +939,6 @@ package Maintainers;
                 'CPAN'          => 1,
                 },
 
-        'Thread::Semaphore' =>
-                {
-                'MAINTAINER'    => 'jdhedden',
-                'FILES'         => q[lib/Thread/Semaphore.pm lib/Thread/Semaphore.t],
-                'CPAN'          => 1,
-                },
-
 	'Unicode::Collate' =>
 		{
 		'MAINTAINER'	=> 'sadahiro',
diff --git a/lib/Thread/Semaphore.pm b/lib/Thread/Semaphore.pm
index 1e188542de..d00da678a9 100644
--- a/lib/Thread/Semaphore.pm
+++ b/lib/Thread/Semaphore.pm
@@ -1,97 +1,149 @@
 package Thread::Semaphore;
 
+use strict;
+use warnings;
+
+our $VERSION = '2.04';
+
 use threads::shared;
+use Scalar::Util 1.10 qw(looks_like_number);
 
-our $VERSION = '2.01';
+# Create a new semaphore optionally with specified count (count defaults to 1)
+sub new {
+    my $class = shift;
+    my $val :shared = @_ ? shift : 1;
+    if (! 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;
+    lock($$sema);
+    my $dec = @_ ? shift : 1;
+    if (! 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;
+}
+
+# Increment a semaphore's count (increment amount defaults to 1)
+sub up {
+    my $sema = shift;
+    lock($$sema);
+    my $inc = @_ ? shift : 1;
+    if (! looks_like_number($inc) || (int($inc) != $inc) || ($inc < 1)) {
+        require Carp;
+        $inc = 'undef' if (! defined($inc));
+        Carp::croak("Semaphore increment is not a positive integer: $inc");
+    }
+    ($$sema += $inc) > 0 and cond_broadcast($$sema);
+}
+
+1;
 
 =head1 NAME
 
-Thread::Semaphore - thread-safe semaphores
+Thread::Semaphore - Thread-safe semaphores
+
+=head1 VERSION
+
+This document describes Thread::Semaphore version 2.04
 
 =head1 SYNOPSIS
 
     use Thread::Semaphore;
-    my $s = new Thread::Semaphore;
-    $s->down;	# Also known as the semaphore P operation.
+    my $s = Thread::Semaphore->new();
+    $s->down();   # Also known as the semaphore P operation.
     # The guarded section is here
-    $s->up;	# Also known as the semaphore V operation.
+    $s->up();     # Also known as the semaphore V operation.
 
-    # The default semaphore value is 1.
-    my $s = new Thread::Semaphore($initial_value);
+    # The default semaphore value is 1
+    my $s = Thread::Semaphore-new($initial_value);
     $s->down($down_value);
     $s->up($up_value);
 
 =head1 DESCRIPTION
 
-Semaphores provide a mechanism to regulate access to resources. Semaphores,
-unlike locks, aren't tied to particular scalars, and so may be used to
+Semaphores provide a mechanism to regulate access to resources.  Unlike
+locks, semaphores aren't tied to particular scalars, and so may be used to
 control access to anything you care to use them for.
 
-Semaphores don't limit their values to zero or one, so they can be used to
-control access to some resource that there may be more than one of. (For
-example, filehandles.) Increment and decrement amounts aren't fixed at one
-either, so threads can reserve or return multiple resources at once.
+Semaphores don't limit their values to zero and one, so they can be used to
+control access to some resource that there may be more than one of (e.g.,
+filehandles).  Increment and decrement amounts aren't fixed at one either,
+so threads can reserve or return multiple resources at once.
 
-=head1 FUNCTIONS AND METHODS
+=head1 METHODS
 
 =over 8
 
-=item new
+=item ->new()
+
+=item ->new(NUMBER)
 
-=item new NUMBER
+C<new> creates a new semaphore, and initializes its count to the specified
+number (which must be an integer).  If no number is specified, the
+semaphore's count defaults to 1.
 
-C<new> creates a new semaphore, and initializes its count to the passed
-number. If no number is passed, the semaphore's count is set to one.
+=item ->down()
 
-=item down
+=item ->down(NUMBER)
 
-=item down NUMBER
+The C<down> method decreases the semaphore's count by the specified number
+(which must be an integer >= 1), or by one if no number is specified.
 
-The C<down> method decreases the semaphore's count by the specified number,
-or by one if no number has been specified. If the semaphore's count would drop
-below zero, this method will block until such time that the semaphore's
-count is equal to or larger than the amount you're C<down>ing the
-semaphore's count by.
+If the semaphore's count would drop below zero, this method will block
+until such time as the semaphore's count is greater than or equal to the
+amount you're C<down>ing the semaphore's count by.
 
 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 up
+=item ->up()
 
-=item up NUMBER
+=item ->up(NUMBER)
 
-The C<up> method increases the semaphore's count by the number specified,
-or by one if no number has been specified. This will unblock any thread blocked
-trying to C<down> the semaphore if the C<up> raises the semaphore count
-above the amount that the C<down>s are trying to decrement it by.
+The C<up> method increases the semaphore's count by the number specified
+(which must be an integer >= 1), or by one if no number is specified.
+
+This will unblock any thread that is blocked trying to C<down> the
+semaphore if the C<up> raises the semaphore's count above the amount that
+the C<down> is trying to decrement it by.  For example, if three threads
+are blocked trying to C<down> a semaphore by one, and another thread C<up>s
+the semaphore by two, then two of the blocked threads (which two is
+indeterminate) will become unblocked.
 
 This is the semaphore "V operation" (the name derives from the Dutch
 word "vrij", which means "release").
 
 =back
 
-=cut
+=head1 SEE ALSO
 
-sub new {
-    my $class = shift;
-    my $val : shared = @_ ? shift : 1;
-    bless \$val, $class;
-}
+Thread::Semaphore Discussion Forum on CPAN:
+L<http://www.cpanforum.com/dist/Thread-Semaphore>
 
-sub down {
-    my $s = shift;
-    lock($$s);
-    my $inc = @_ ? shift : 1;
-    cond_wait $$s until $$s >= $inc;
-    $$s -= $inc;
-}
+Annotated POD for Thread::Semaphore:
+L<http://annocpan.org/~JDHEDDEN/Thread-Semaphore-2.04/lib/Thread/Semaphore.pm>
 
-sub up {
-    my $s = shift;
-    lock($$s);
-    my $inc = @_ ? shift : 1;
-    ($$s += $inc) > 0 and cond_broadcast $$s;
-}
+L<threads>, L<threads::shared>
 
-1;
+=head1 MAINTAINER
+
+Jerry D. Hedden, S<E<lt>jdhedden AT cpan DOT orgE<gt>>
+
+=head1 LICENSE
+
+This program is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
diff --git a/lib/Thread/Semaphore.t b/lib/Thread/Semaphore.t
deleted file mode 100644
index 14687e0b22..0000000000
--- a/lib/Thread/Semaphore.t
+++ /dev/null
@@ -1,17 +0,0 @@
-use warnings;
-
-BEGIN {
-    chdir 't' if -d 't';
-    push @INC ,'../lib';
-    require Config; import Config;
-    unless ($Config{'useithreads'}) {
-        print "1..0 # Skip: no ithreads\n";
-        exit 0;
-    }
-}
-
-print "1..1\n";
-use threads;
-use Thread::Semaphore;
-print "ok 1\n";
-
diff --git a/lib/Thread/Semaphore/t/01_basic.t b/lib/Thread/Semaphore/t/01_basic.t
new file mode 100644
index 0000000000..618fe4b61d
--- /dev/null
+++ b/lib/Thread/Semaphore/t/01_basic.t
@@ -0,0 +1,76 @@
+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");
+        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;
+
+threads->create(sub {
+    $st->down();
+    is($token++, 1, 'Thread 1 got semaphore');
+    $st->up();
+    $sm->up();
+
+    $st->down(4);
+    is($token, 5, 'Thread 1 done');
+    $sm->up();
+})->detach();
+
+threads->create(sub {
+    $st->down(2);
+    is($token++, 3, 'Thread 2 got semaphore');
+    $st->up();
+    $sm->up();
+
+    $st->down(4);
+    is($token, 5, 'Thread 2 done');
+    $sm->up();
+})->detach();
+
+$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(9);
+
+$sm->down(2);
+$st->down();
+ok(1, 'Main done');
+threads::yield();
+
+# EOF
diff --git a/lib/Thread/Semaphore/t/02_errs.t b/lib/Thread/Semaphore/t/02_errs.t
new file mode 100644
index 0000000000..a0129d20d1
--- /dev/null
+++ b/lib/Thread/Semaphore/t/02_errs.t
@@ -0,0 +1,50 @@
+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");
+        exit(0);
+    }
+}
+
+use Thread::Semaphore;
+
+use Test::More 'tests' => 12;
+
+my $err = qr/^Semaphore .* is not .* integer: /;
+
+eval { Thread::Semaphore->new(undef); };
+like($@, $err, $@);
+eval { Thread::Semaphore->new(0.5); };
+like($@, $err, $@);
+eval { Thread::Semaphore->new('foo'); };
+like($@, $err, $@);
+
+my $s = Thread::Semaphore->new();
+ok($s, 'New semaphore');
+
+eval { $s->down(undef); };
+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, $@);
+
+# EOF