Thread-Semaphore v2.02

Changes

@@ -0,0 +1,12 @@
+Revision history for Perl extension Thread::Semaphore.
+
+2.02 Thu Feb 14 15:27:00 2008
+	- Argument validation
+	- Test suite
+
+2.01 Sep 02 06:40:00 2003
+	- Minor doc update
+
+2.00 Jul 12 16:32:00 2002
+	- Released as part of Perl 5.8.0
+

MANIFEST

@@ -0,0 +1,11 @@
+Changes
+MANIFEST
+Makefile.PL
+README
+lib/Thread/Semaphore.pm
+t/00_load.t
+t/01_basic.t
+t/02_errs.t
+t/99_pod.t
+examples/semaphore.pl
+META.yml                                 Module meta-data (added by MakeMaker)

Makefile.PL

@@ -0,0 +1,31 @@
+# Module makefile for Thread::Semaphore (using ExtUtils::MakeMaker)
+
+use Config;
+BEGIN {
+    if (! $Config{'useithreads'} || ($] < 5.008)) {
+        die("ERROR:  This Perl not built to support threads\n");
+    }
+}
+
+use ExtUtils::MakeMaker;
+
+# Construct make file
+WriteMakefile(
+    'NAME'          => 'Thread::Semaphore',
+    'AUTHOR'        => 'Jerry D. Hedden <jdhedden AT cpan DOT org>',
+    'VERSION_FROM'  => 'lib/Thread/Semaphore.pm',
+    'ABSTRACT_FROM' => 'lib/Thread/Semaphore.pm',
+    'PREREQ_PM'     => {
+        'threads'         => 0,
+        'threads::shared' => 0,
+        'Scalar::Util'    => 1.10,
+        'Test::More'      => 0.50,
+    },
+
+    ((ExtUtils::MakeMaker->VERSION() lt '6.25') ?
+        ('PL_FILES' => { })            : ()),
+    ((ExtUtils::MakeMaker->VERSION() gt '6.30') ?
+        ('LICENSE'  => 'perl')         : ()),
+);
+
+# EOF

README

@@ -0,0 +1,31 @@
+Thread::Semaphore version 2.02
+==============================
+
+Thread-safe Semaphores
+
+INSTALLATION
+
+To install this module type the following:
+
+   perl Makefile.PL
+   make
+   make test
+   make install
+
+DEPENDENCIES
+
+This module requires Perl 5.8.0 or later built with 'ithreads'.
+
+This module requires these other modules:
+
+    threads
+    threads::shared
+    Scalar::Util version 1.10 or later
+    Test::More 0.50 or later (for installation)
+
+COPYRIGHT AND LICENCE
+
+Maintained by Jerry D. Hedden <jdhedden AT cpan DOT org>
+Same licence as Perl.
+
+# EOF

examples/semaphore.pl

@@ -0,0 +1,35 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use threads;
+use Thread::Semaphore;
+
+MAIN:
+{
+    # Create semaphore with count of 0
+    my $s = Thread::Semaphore->new(0);
+
+    # Create detached thread
+    threads->create(sub {
+            # Thread is blocked until released by main
+            $s->down();
+
+            # Thread does work
+            # ...
+
+            # Tell main that thread is finished
+            $s->up();
+    })->detach();
+
+    # Release thread to do work
+    $s->up();
+
+    # Wait for thread to finish
+    $s->down();
+}
+
+exit(0);
+
+# EOF

lib/Thread/Semaphore.pm

@@ -0,0 +1,145 @@
+package Thread::Semaphore;
+
+use strict;
+use warnings;
+
+our $VERSION = '2.02';
+
+use threads::shared;
+use Scalar::Util 1.10 qw(looks_like_number);
+
+# 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
+
+=head1 SYNOPSIS
+
+    use Thread::Semaphore;
+    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.
+
+    # 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.  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 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 METHODS
+
+=over 8
+
+=item ->new()
+
+=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.
+
+=item ->down()
+
+=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.
+
+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(NUMBER)
+
+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
+
+=head1 SEE ALSO
+
+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.02/lib/Thread/Semaphore.pm>
+
+L<threads>, L<threads::shared>
+
+=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

t/00_load.t

@@ -0,0 +1,20 @@
+use strict;
+use warnings;
+
+BEGIN {
+    use Config;
+    if (! $Config{'useithreads'}) {
+        print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
+        exit(0);
+    }
+}
+
+use Test::More 'tests' => 1;
+
+use_ok('Thread::Semaphore');
+
+if (! exists($ENV{'PERL_CORE'})) {
+    diag('Testing Thread::Semaphore ' . $Thread::Semaphore::VERSION);
+}
+
+# EOF

t/01_basic.t

@@ -0,0 +1,69 @@
+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;
+
+use Test::More '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(3);
+    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(3);
+    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(7);
+
+$sm->down(2);
+$st->down();
+ok(1, 'Main done');
+
+# EOF