Coro/Coro/SemaphoreSet.pm

=head1 NAME

Coro::SemaphoreSet - efficient set of counting semaphores

=head1 SYNOPSIS

 use Coro::SemaphoreSet;

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

 $sig->down ("semaphoreid"); # wait for signal

 # ... some other "thread"

 $sig->up ("semaphoreid");

=head1 DESCRIPTION

This module implements sets of counting semaphores (see
L<Coro::Semaphore>). It is nothing more than a hash with normal semaphores
as members, but is more efficiently managed.

This is useful if you want to allow parallel tasks to run in parallel but
not on the same problem. Just use a SemaphoreSet and lock on the problem
identifier.

=over 4

=cut

package Coro::SemaphoreSet;

use strict qw(vars subs);
no warnings;

our $VERSION = 5.13;

use Coro::Semaphore ();

=item new [inital count]

Creates a new semaphore set with the given initial lock count for each
individual semaphore. See L<Coro::Semaphore>.

=cut

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

=item $semset->down ($id)

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

=cut

sub down {
   package Coro::Semaphore;
   down ($_[0][1]{$_[1]} ||= new undef, $_[0][0]);
}

#ub timed_down {
#  require Coro::Timer;
#  my $timeout = Coro::Timer::timeout ($_[2]);
#
#  while () {
#     my $sem = ($_[0][1]{$_[1]} ||= [$_[0][0]]);
#
#     if ($sem->[0] > 0) {
#        --$sem->[0];
#        return 1;
#     }
#
#     if ($timeout) {
#        # ugly as hell.
#        for (0..$#{$sem->[1]}) {
#           if ($sem->[1][$_] == $Coro::current) {
#              splice @{$sem->[1]}, $_, 1;
#              return 0;
#           }
#        }
#        die;
#     }
#
#     push @{$sem->[1]}, $Coro::current;
#     &Coro::schedule;
#  }
#

=item $semset->up ($id)

Unlock the semaphore again. If the semaphore then reaches the default
count for this set and has no waiters, the space allocated for it will be
freed.

=cut

sub up {
   my ($self, $id) = @_;

   package Coro::Semaphore;
   my $sem = $self->[1]{$id} ||= new undef, $self->[0];

   up $sem;

   delete $self->[1]{$id} if $self->[0] == count $sem and !waiters $sem;
}

=item $semset->try ($id)

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

=cut

sub try {
   package Coro::Semaphore;
   try ($_[0][1]{$_[1]} || return $_[0][0] > 0)
}

=item $semset->count ($id)

Return the current semaphore count for the specified semaphore.

=cut

sub count {
   package Coro::Semaphore;
   count ($_[0][1]{$_[1]} || return $_[0][0]);
}

=item $semset->wait ($id)

Same as Coro::Semaphore::wait on the specified semaphore.

=cut

sub wait {
   Coro::Semaphore::wait ($_[0][1]{$_[1]} || return $_[0][0] > 0);
}

=item $guard = $semset->guard ($id)

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

=cut

sub guard {
   &down;
   bless [@_], Coro::SemaphoreSet::guard::;
}

#ub timed_guard {
#  &timed_down
#     ? bless [$_[0], $_[1]], Coro::SemaphoreSet::guard::
#     : ();
#

sub Coro::SemaphoreSet::guard::DESTROY {
   up @{$_[0]};
}

=item $semaphore = $semset->sem ($id)

This SemaphoreSet version is based on Coro::Semaphore's. This function
creates (if necessary) the underlying Coro::Semaphore object and returns
it. You may legally call any Coro::Semaphore method on it, but note that
calling C<< $semset->up >> can invalidate the returned semaphore.

=cut

sub sem {
   package Coro::Semaphore;
   $_[0][1]{$_[1]} ||= new undef, $_[0][0]
}

1;

=back

=head1 AUTHOR

 Marc Lehmann <schmorp@schmorp.de>
 http://home.schmorp.de/

=cut

Revision:	1.73
Committed:	Sat Dec 13 22:08:13 2008 UTC (15 years, 5 months ago) by root
Branch:	MAIN
Changes since 1.72:	+26 -5 lines
Log Message:	* empty log message *
#	User	Rev	Content
1	root	1.1	=head1 NAME
2
3	root	1.70	Coro::SemaphoreSet - efficient set of counting semaphores
4	root	1.1
5			=head1 SYNOPSIS
6
7			use Coro::SemaphoreSet;
8
9			$sig = new Coro::SemaphoreSet [initial value];
10
11	root	1.73	$sig->down ("semaphoreid"); # wait for signal
12	root	1.1
13			# ... some other "thread"
14
15	root	1.73	$sig->up ("semaphoreid");
16	root	1.1
17			=head1 DESCRIPTION
18
19			This module implements sets of counting semaphores (see
20			L<Coro::Semaphore>). It is nothing more than a hash with normal semaphores
21			as members, but is more efficiently managed.
22
23			This is useful if you want to allow parallel tasks to run in parallel but
24			not on the same problem. Just use a SemaphoreSet and lock on the problem
25			identifier.
26
27			=over 4
28
29			=cut
30
31			package Coro::SemaphoreSet;
32
33	root	1.68	use strict qw(vars subs);
34	root	1.48	no warnings;
35	root	1.4
36	root	1.73	our $VERSION = 5.13;
37	root	1.1
38	root	1.68	use Coro::Semaphore ();
39	root	1.1
40			=item new [inital count]
41
42	root	1.36	Creates a new semaphore set with the given initial lock count for each
43	root	1.1	individual semaphore. See L<Coro::Semaphore>.
44
45			=cut
46
47			sub new {
48			bless [defined $_[1] ? $_[1] : 1], $_[0];
49			}
50
51	root	1.68	=item $semset->down ($id)
52	root	1.1
53			Decrement the counter, therefore "locking" the named semaphore. This
54			method waits until the semaphore is available if the counter is zero.
55
56			=cut
57
58			sub down {
59	root	1.68	package Coro::Semaphore;
60			down ($_[0][1]{$_[1]} \|\|= new undef, $_[0][0]);
61	root	1.1	}
62
63	root	1.68	#ub timed_down {
64			# require Coro::Timer;
65			# my $timeout = Coro::Timer::timeout ($_[2]);
66			#
67			# while () {
68			# my $sem = ($_[0][1]{$_[1]} \|\|= [$_[0][0]]);
69			#
70			# if ($sem->[0] > 0) {
71			# --$sem->[0];
72			# return 1;
73			# }
74			#
75			# if ($timeout) {
76			# # ugly as hell.
77			# for (0..$#{$sem->[1]}) {
78			# if ($sem->[1][$_] == $Coro::current) {
79			# splice @{$sem->[1]}, $_, 1;
80			# return 0;
81			# }
82			# }
83			# die;
84			# }
85			#
86			# push @{$sem->[1]}, $Coro::current;
87			# &Coro::schedule;
88			# }
89			#
90
91			=item $semset->up ($id)
92
93			Unlock the semaphore again. If the semaphore then reaches the default
94			count for this set and has no waiters, the space allocated for it will be
95			freed.
96	root	1.1
97			=cut
98
99			sub up {
100	root	1.68	my ($self, $id) = @_;
101
102			package Coro::Semaphore;
103			my $sem = $self->[1]{$id} \|\|= new undef, $self->[0];
104
105			up $sem;
106
107			delete $self->[1]{$id} if $self->[0] == count $sem and !waiters $sem;
108	root	1.1	}
109
110	root	1.73	=item $semset->try ($id)
111	root	1.1
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
117			sub try {
118	root	1.68	package Coro::Semaphore;
119	root	1.73	try ($_[0][1]{$_[1]} \|\| return $_[0][0] > 0)
120			}
121
122			=item $semset->count ($id)
123
124			Return the current semaphore count for the specified semaphore.
125
126			=cut
127
128			sub count {
129			package Coro::Semaphore;
130			count ($_[0][1]{$_[1]} \|\| return $_[0][0]);
131			}
132
133			=item $semset->wait ($id)
134
135			Same as Coro::Semaphore::wait on the specified semaphore.
136
137			=cut
138
139			sub wait {
140			Coro::Semaphore::wait ($_[0][1]{$_[1]} \|\| return $_[0][0] > 0);
141	root	1.1	}
142
143	root	1.68	=item $guard = $semset->guard ($id)
144	root	1.1
145			This method calls C<down> and then creates a guard object. When the guard
146			object is destroyed it automatically calls C<up>.
147
148			=cut
149
150			sub guard {
151			&down;
152	root	1.10	bless [@_], Coro::SemaphoreSet::guard::;
153	root	1.9	}
154
155	root	1.68	#ub timed_guard {
156			# &timed_down
157			# ? bless [$_[0], $_[1]], Coro::SemaphoreSet::guard::
158			# : ();
159			#
160
161			sub Coro::SemaphoreSet::guard::DESTROY {
162			up @{$_[0]};
163	root	1.1	}
164
165	root	1.68	=item $semaphore = $semset->sem ($id)
166
167			This SemaphoreSet version is based on Coro::Semaphore's. This function
168			creates (if necessary) the underlying Coro::Semaphore object and returns
169			it. You may legally call any Coro::Semaphore method on it, but note that
170			calling C<< $semset->up >> can invalidate the returned semaphore.
171
172			=cut
173
174			sub sem {
175			package Coro::Semaphore;
176			$_[0][1]{$_[1]} \|\|= new undef, $_[0][0]
177	root	1.1	}
178
179			1;
180
181			=back
182
183			=head1 AUTHOR
184
185	root	1.28	Marc Lehmann <schmorp@schmorp.de>
186	root	1.26	http://home.schmorp.de/
187	root	1.1
188			=cut
189