Coro/Coro/SemaphoreSet.pm

=head1 NAME

Coro::SemaphoreSet - hash of 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;

no warnings qw(uninitialized);

use Coro ();

$VERSION = 0.52;

=item new [inital count]

Creates a new sempahore 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 $sem->down($id)

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

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

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

=cut

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

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

   my $sem = ($_[0][1]{$_[1]} ||= [$_[0][0]]);
   while ($sem->[0] <= 0) {
      push @{$sem->[1]}, $Coro::current;
      Coro::schedule;
      $timeout and return;
   }
   --$sem->[0];
   return 1;
}

=item $sem->up($id)

Unlock the semaphore again.

=cut

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

=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 {
   my $sem = ($_[0][1]{$_[1]} ||= [$_[0][0]]);
   if ($sem->[0] > 0) {
      --$sem->[0];
      return 1;
   } else {
      return 0;
   }
}

=item $sem->waiters($id)

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

=cut

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

=item $guard = $sem->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;
   # double indirection because bless works on the referenced
   # object, not (only) on the reference itself.
   bless [@_], Coro::SemaphoreSet::Guard::;
}

sub Coro::SemaphoreSet::Guard::DESTROY {
   &up(@{$_[0]});
}

1;

=back

=head1 AUTHOR

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

=cut

Revision:	1.8
Committed:	Tue Nov 27 02:51:03 2001 UTC (22 years, 7 months ago) by root
Branch:	MAIN
Changes since 1.7:	+19 -0 lines
Log Message:	* empty log message *
#	User	Rev	Content
1	root	1.1	=head1 NAME
2
3			Coro::SemaphoreSet - hash of semaphores.
4
5			=head1 SYNOPSIS
6
7			use Coro::SemaphoreSet;
8
9			$sig = new Coro::SemaphoreSet [initial value];
10
11			$sig->down("semaphoreid"); # wait for signal
12
13			# ... some other "thread"
14
15			$sig->up("semaphoreid");
16
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.5	no warnings qw(uninitialized);
34	root	1.4
35	root	1.1	use Coro ();
36
37	root	1.7	$VERSION = 0.52;
38	root	1.1
39			=item new [inital count]
40
41			Creates a new sempahore set with the given initial lock count for each
42			individual semaphore. See L<Coro::Semaphore>.
43
44			=cut
45
46			sub new {
47			bless [defined $_[1] ? $_[1] : 1], $_[0];
48			}
49
50			=item $sem->down($id)
51
52			Decrement the counter, therefore "locking" the named semaphore. This
53			method waits until the semaphore is available if the counter is zero.
54
55	root	1.8	=item $status = $sem->timed_down($id, $timeout)
56
57			Like C<down>, but returns false if semaphore couldn't be acquired within
58			$timeout seconds, otherwise true.
59
60	root	1.1	=cut
61
62			sub down {
63			my $sem = ($_[0][1]{$_[1]} \|\|= [$_[0][0]]);
64			while ($sem->[0] <= 0) {
65			push @{$sem->[1]}, $Coro::current;
66			Coro::schedule;
67			}
68			--$sem->[0];
69	root	1.8	}
70
71			sub timed_down {
72			require Coro::Timer;
73			my $timeout = Coro::Timer::timeout($_[2]);
74
75			my $sem = ($_[0][1]{$_[1]} \|\|= [$_[0][0]]);
76			while ($sem->[0] <= 0) {
77			push @{$sem->[1]}, $Coro::current;
78			Coro::schedule;
79			$timeout and return;
80			}
81			--$sem->[0];
82			return 1;
83	root	1.1	}
84
85			=item $sem->up($id)
86
87			Unlock the semaphore again.
88
89			=cut
90
91			sub up {
92			my $sem = $_[0][1]{$_[1]};
93			if (++$sem->[0] > 0) {
94			(shift @{$sem->[1]})->ready if @{$sem->[1]};
95			}
96			delete $_[0][1]{$_[1]} if $sem->[0] == $_[0][0];
97			}
98
99			=item $sem->try
100
101			Try to C<down> the semaphore. Returns true when this was possible,
102			otherwise return false and leave the semaphore unchanged.
103
104			=cut
105
106			sub try {
107			my $sem = ($_[0][1]{$_[1]} \|\|= [$_[0][0]]);
108			if ($sem->[0] > 0) {
109			--$sem->[0];
110			return 1;
111			} else {
112			return 0;
113			}
114			}
115
116			=item $sem->waiters($id)
117
118			In scalar context, returns the number of coroutines waiting for this
119			semaphore.
120
121			=cut
122
123			sub waiters {
124			@{$_[0][1]{$_[1]}};
125			}
126
127			=item $guard = $sem->guard($id)
128
129			This method calls C<down> and then creates a guard object. When the guard
130			object is destroyed it automatically calls C<up>.
131
132			=cut
133
134			sub guard {
135			&down;
136			# double indirection because bless works on the referenced
137			# object, not (only) on the reference itself.
138			bless [@_], Coro::SemaphoreSet::Guard::;
139			}
140
141			sub Coro::SemaphoreSet::Guard::DESTROY {
142			&up(@{$_[0]});
143			}
144
145			1;
146
147			=back
148
149			=head1 AUTHOR
150
151			Marc Lehmann <pcg@goof.com>
152			http://www.goof.com/pcg/marc/
153
154			=cut
155