lib/Thread/Semaphore.pm

   1 package Thread::Semaphore;
   2
   3 use strict;
   4
   5 our $VERSION = '1.00';
   6
   7 use Thread qw(cond_wait cond_broadcast);
   8
   9 BEGIN {
  10     use Config;
  11     if ($Config{useithreads}) {
  12         require 'threads/shared/semaphore.pm';
  13         for my $meth (qw(new up down)) {
  14             no strict 'refs';
  15             *{"Thread::Semaphore::$meth"} = \&{"threads::shared::semaphore::$meth"};
  16         }
  17     } elsif ($Config{use5005threads}) {
  18         for my $meth (qw(new up down)) {
  19             no strict 'refs';
  20             *{"Thread::Semaphore::$meth"} = \&{"Thread::Semaphore::${meth}_othread"};
  21         }
  22     } else {
  23         require Carp;
  24         Carp::croak("This Perl has neither ithreads nor 5005threads");
  25     }
  26 }
  27
  28
  29 =head1 NAME
  30
  31 Thread::Semaphore - thread-safe semaphores (for old code only)
  32
  33 =head1 CAVEAT
  34
  35 For new code the use of the C<Thread::Semaphore> module is discouraged and
  36 the direct use of the C<threads>, C<threads::shared> and
  37 C<threads::shared::semaphore> modules is encouraged instead.
  38
  39 For the whole story about the development of threads in Perl, and why you
  40 should B<not> be using this module unless you know what you're doing, see the
  41 CAVEAT of the C<Thread> module.
  42
  43 =head1 SYNOPSIS
  44
  45     use Thread::Semaphore;
  46     my $s = new Thread::Semaphore;
  47     $s->up;     # Also known as the semaphore V -operation.
  48     # The guarded section is here
  49     $s->down;   # Also known as the semaphore P -operation.
  50
  51     # The default semaphore value is 1.
  52     my $s = new Thread::Semaphore($initial_value);
  53     $s->up($up_value);
  54     $s->down($up_value);
  55
  56 =head1 DESCRIPTION
  57
  58 Semaphores provide a mechanism to regulate access to resources. Semaphores,
  59 unlike locks, aren't tied to particular scalars, and so may be used to
  60 control access to anything you care to use them for.
  61
  62 Semaphores don't limit their values to zero or one, so they can be used to
  63 control access to some resource that may have more than one of. (For
  64 example, filehandles) Increment and decrement amounts aren't fixed at one
  65 either, so threads can reserve or return multiple resources at once.
  66
  67 =head1 FUNCTIONS AND METHODS
  68
  69 =over 8
  70
  71 =item new
  72
  73 =item new NUMBER
  74
  75 C<new> creates a new semaphore, and initializes its count to the passed
  76 number. If no number is passed, the semaphore's count is set to one.
  77
  78 =item down
  79
  80 =item down NUMBER
  81
  82 The C<down> method decreases the semaphore's count by the specified number,
  83 or one if no number has been specified. If the semaphore's count would drop
  84 below zero, this method will block until such time that the semaphore's
  85 count is equal to or larger than the amount you're C<down>ing the
  86 semaphore's count by.
  87
  88 =item up
  89
  90 =item up NUMBER
  91
  92 The C<up> method increases the semaphore's count by the number specified,
  93 or one if no number's been specified. This will unblock any thread blocked
  94 trying to C<down> the semaphore if the C<up> raises the semaphore count
  95 above what the C<down>s are trying to decrement it by.
  96
  97 =back
  98
  99 =cut
 100
 101 sub new_othread {
 102     my $class = shift;
 103     my $val = @_ ? shift : 1;
 104     bless \$val, $class;
 105 }
 106
 107 sub down_othread : locked : method {
 108     my $s = shift;
 109     my $inc = @_ ? shift : 1;
 110     cond_wait $s until $$s >= $inc;
 111     $$s -= $inc;
 112 }
 113
 114 sub up_othread : locked : method {
 115     my $s = shift;
 116     my $inc = @_ ? shift : 1;
 117     ($$s += $inc) > 0 and cond_broadcast $s;
 118 }
 119
 120 1;