Coro/Coro/Semaphore.pm

=head1 NAME

Coro::Semaphore - non-binary semaphores

=head1 SYNOPSIS

 use Coro::Semaphore;

 $sig = new Coro::Semaphore [initial value];

 $sig->down; # wait for signal

 # ... some other "thread"

 $sig->up;

=head1 DESCRIPTION

This module implements counting semaphores. You can initialize a mutex
with any level of parallel users, that is, you can intialize a sempahore
that can be C<down>ed more than once until it blocks. There is no owner
associated with semaphores, so one coroutine can C<down> it while another
can C<up> it.

Counting semaphores are typically used to coordinate access to
resources, with the semaphore count initialized to the number of free
resources. Coroutines then increment the count when resources are added
and decrement the count when resources are removed.

=over 4

=cut

package Coro::Semaphore;

no warnings qw(uninitialized);

use Coro ();

$VERSION = 0.532;

=item new [inital count]

Creates a new sempahore object with the given initial lock count. The
default lock count is 1, which means it is unlocked by default. Zero (or
negative values) are also allowed, in which case the semaphore is locked
by default.

=cut

sub new {
   bless [defined $_[1] ? $_[1] : 1], $_[0];
}

=item $sem->down

Decrement the counter, therefore "locking" the semaphore. This method
waits until the semaphore is available if the counter is zero.

=item $status = $sem->timed_down($timeout)

Like C<down>, but returns false if semaphore couldn't be acquired within
$timeout seconds, otherwise true.

=cut

sub down {
   while ($_[0][0] <= 0) {
      push @{$_[0][1]}, $Coro::current;
      Coro::schedule;
   }
   --$_[0][0];
}

sub timed_down {
   require Coro::Timer;
   my $timeout = Coro::Timer::timeout($_[1]);

   while ($_[0][0] <= 0) {
      push @{$_[0][1]}, $Coro::current;
      Coro::schedule;
      if ($timeout) {
         # ugly as hell. slow, too, btw!
         for (0..$#{$_[0][1]}) {
            if ($_[0][1][$_] == $Coro::current) {
               splice @{$_[0][1]}, $_, 1;
               return;
            }
         }
         die;
      }
   }

   --$_[0][0];
   return 1;
}

=item $sem->up

Unlock the semaphore again.

=cut

sub up {
   if (++$_[0][0] > 0) {
      (shift @{$_[0][1]})->ready if @{$_[0][1]};
   }
}

=item $sem->try

Try to C<down> the semaphore. Returns true when this was possible,
otherwise return false and leave the semaphore unchanged.

=cut

sub try {
   if ($_[0][0] > 0) {
      --$_[0][0];
      return 1;
   } else {
      return 0;
   }
}

=item $sem->waiters

In scalar context, returns the number of coroutines waiting for this
semaphore.

=cut

sub waiters {
   @{$_[0][1]};
}

=item $guard = $sem->guard

This method calls C<down> and then creates a guard object. When the guard
object is destroyed it automatically calls C<up>.

=item $guard = $sem->timed_guard($timeout)

Like C<guard>, but returns undef if semaphore couldn't be acquired within
$timeout seconds, otherwise the guard object.

=cut

sub guard {
   &down;
   # double indirection because bless works on the referenced
   # object, not (only) on the reference itself.
   bless \\$_[0], Coro::Semaphore::guard::;
}

sub timed_guard {
   &timed_down
      ? bless \\$_[0], Coro::Semaphore::guard::
      : ();
}

sub Coro::Semaphore::guard::DESTROY {
   &up(${${$_[0]}});
}

1;

=back

=head1 AUTHOR

 Marc Lehmann <pcg@goof.com>
 http://www.goof.com/pcg/marc/

=cut

Revision:	1.29
Committed:	Sat Feb 9 18:53:03 2002 UTC (22 years, 3 months ago) by root
Branch:	MAIN
Changes since 1.28:	+1 -1 lines
Log Message:	* empty log message *
#	User	Rev	Content
1	root	1.1	=head1 NAME
2
3			Coro::Semaphore - non-binary semaphores
4
5			=head1 SYNOPSIS
6
7			use Coro::Semaphore;
8
9	root	1.3	$sig = new Coro::Semaphore [initial value];
10	root	1.1
11			$sig->down; # wait for signal
12
13			# ... some other "thread"
14
15			$sig->up;
16
17			=head1 DESCRIPTION
18
19	root	1.16	This module implements counting semaphores. You can initialize a mutex
20	root	1.11	with any level of parallel users, that is, you can intialize a sempahore
21			that can be C<down>ed more than once until it blocks. There is no owner
22			associated with semaphores, so one coroutine can C<down> it while another
23			can C<up> it.
24
25			Counting semaphores are typically used to coordinate access to
26			resources, with the semaphore count initialized to the number of free
27			resources. Coroutines then increment the count when resources are added
28			and decrement the count when resources are removed.
29
30	root	1.1	=over 4
31
32			=cut
33
34			package Coro::Semaphore;
35
36	root	1.21	no warnings qw(uninitialized);
37	root	1.20
38	root	1.5	use Coro ();
39	root	1.1
40	root	1.29	$VERSION = 0.532;
41	root	1.1
42	root	1.16	=item new [inital count]
43	root	1.3
44			Creates a new sempahore object with the given initial lock count. The
45	root	1.11	default lock count is 1, which means it is unlocked by default. Zero (or
46			negative values) are also allowed, in which case the semaphore is locked
47			by default.
48	root	1.3
49			=cut
50
51	root	1.1	sub new {
52	root	1.2	bless [defined $_[1] ? $_[1] : 1], $_[0];
53	root	1.1	}
54
55	root	1.3	=item $sem->down
56
57			Decrement the counter, therefore "locking" the semaphore. This method
58			waits until the semaphore is available if the counter is zero.
59
60	root	1.24	=item $status = $sem->timed_down($timeout)
61
62			Like C<down>, but returns false if semaphore couldn't be acquired within
63			$timeout seconds, otherwise true.
64
65	root	1.3	=cut
66
67	root	1.1	sub down {
68	root	1.17	while ($_[0][0] <= 0) {
69			push @{$_[0][1]}, $Coro::current;
70	root	1.5	Coro::schedule;
71	root	1.1	}
72	root	1.17	--$_[0][0];
73	root	1.24	}
74
75			sub timed_down {
76			require Coro::Timer;
77			my $timeout = Coro::Timer::timeout($_[1]);
78
79			while ($_[0][0] <= 0) {
80			push @{$_[0][1]}, $Coro::current;
81			Coro::schedule;
82	root	1.26	if ($timeout) {
83	root	1.27	# ugly as hell. slow, too, btw!
84	root	1.26	for (0..$#{$_[0][1]}) {
85			if ($_[0][1][$_] == $Coro::current) {
86			splice @{$_[0][1]}, $_, 1;
87			return;
88			}
89			}
90			die;
91			}
92	root	1.24	}
93
94			--$_[0][0];
95			return 1;
96	root	1.1	}
97
98	root	1.3	=item $sem->up
99
100			Unlock the semaphore again.
101
102			=cut
103
104	root	1.1	sub up {
105	root	1.17	if (++$_[0][0] > 0) {
106			(shift @{$_[0][1]})->ready if @{$_[0][1]};
107	root	1.1	}
108			}
109	root	1.3
110			=item $sem->try
111
112			Try to C<down> the semaphore. Returns true when this was possible,
113			otherwise return false and leave the semaphore unchanged.
114
115			=cut
116	root	1.1
117			sub try {
118	root	1.17	if ($_[0][0] > 0) {
119			--$_[0][0];
120	root	1.1	return 1;
121			} else {
122			return 0;
123			}
124	root	1.12	}
125
126	root	1.15	=item $sem->waiters
127
128			In scalar context, returns the number of coroutines waiting for this
129			semaphore.
130
131			=cut
132
133			sub waiters {
134			@{$_[0][1]};
135			}
136
137	root	1.12	=item $guard = $sem->guard
138
139			This method calls C<down> and then creates a guard object. When the guard
140			object is destroyed it automatically calls C<up>.
141
142	root	1.25	=item $guard = $sem->timed_guard($timeout)
143
144			Like C<guard>, but returns undef if semaphore couldn't be acquired within
145			$timeout seconds, otherwise the guard object.
146
147	root	1.12	=cut
148
149			sub guard {
150	root	1.16	&down;
151	root	1.13	# double indirection because bless works on the referenced
152			# object, not (only) on the reference itself.
153	root	1.26	bless \\$_[0], Coro::Semaphore::guard::;
154	root	1.25	}
155
156			sub timed_guard {
157			&timed_down
158	root	1.26	? bless \\$_[0], Coro::Semaphore::guard::
159	root	1.25	: ();
160	root	1.12	}
161
162	root	1.25	sub Coro::Semaphore::guard::DESTROY {
163	root	1.16	&up(${${$_[0]}});
164	root	1.1	}
165
166			1;
167
168			=back
169
170			=head1 AUTHOR
171
172			Marc Lehmann <pcg@goof.com>
173			http://www.goof.com/pcg/marc/
174
175			=cut
176