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;

use Coro ();

$VERSION = 5.0;

=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 $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 {
#   Coro::Semaphore::down ($_[0][1]{$_[1]} ||= Coro::Semaphore::new undef, $_[0][0]);
   while () {
      my $sem = ($_[0][1]{$_[1]} ||= [$_[0][0]]);
 
      if ($sem->[0] > 0) {
         --$sem->[0];
         return 1;
      }
 
      push @{$sem->[1]}, $Coro::current;
      &Coro::schedule;
   }
}

sub 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 $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] && !@{$sem->[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 {
   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 {
   my $sem = $_[0][1]{$_[1]}
      or return;
   @{ $_[0][1]{$_[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>.

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

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

=cut

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

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

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

1;

=back

=head1 AUTHOR

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

=cut

Revision:	1.67
Committed:	Mon Nov 17 08:25:06 2008 UTC (15 years, 6 months ago) by root
Branch:	MAIN
Changes since 1.66:	+5 -4 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.48	no warnings;
34	root	1.4
35	root	1.1	use Coro ();
36
37	root	1.66	$VERSION = 5.0;
38	root	1.1
39			=item new [inital count]
40
41	root	1.36	Creates a new semaphore set with the given initial lock count for each
42	root	1.1	individual semaphore. See L<Coro::Semaphore>.
43
44			=cut
45
46			sub new {
47			bless [defined $_[1] ? $_[1] : 1], $_[0];
48			}
49
50	root	1.31	=item $sem->down ($id)
51	root	1.1
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.31	=item $status = $sem->timed_down ($id, $timeout)
56	root	1.8
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	root	1.67	# Coro::Semaphore::down ($_[0][1]{$_[1]} \|\|= Coro::Semaphore::new undef, $_[0][0]);
64	root	1.29	while () {
65			my $sem = ($_[0][1]{$_[1]} \|\|= [$_[0][0]]);
66	root	1.67
67	root	1.30	if ($sem->[0] > 0) {
68			--$sem->[0];
69	root	1.31	return 1;
70	root	1.30	}
71	root	1.67
72	root	1.1	push @{$sem->[1]}, $Coro::current;
73	root	1.45	&Coro::schedule;
74	root	1.1	}
75	root	1.8	}
76
77			sub timed_down {
78			require Coro::Timer;
79	root	1.31	my $timeout = Coro::Timer::timeout ($_[2]);
80
81			while () {
82			my $sem = ($_[0][1]{$_[1]} \|\|= [$_[0][0]]);
83
84			if ($sem->[0] > 0) {
85			--$sem->[0];
86			return 1;
87			}
88	root	1.8
89	root	1.10	if ($timeout) {
90	root	1.11	# ugly as hell.
91			for (0..$#{$sem->[1]}) {
92			if ($sem->[1][$_] == $Coro::current) {
93			splice @{$sem->[1]}, $_, 1;
94	root	1.31	return 0;
95	root	1.10	}
96			}
97			die;
98			}
99	root	1.31
100			push @{$sem->[1]}, $Coro::current;
101	root	1.45	&Coro::schedule;
102	root	1.8	}
103	root	1.1	}
104
105	root	1.31	=item $sem->up ($id)
106	root	1.1
107			Unlock the semaphore again.
108
109			=cut
110
111			sub up {
112			my $sem = $_[0][1]{$_[1]};
113	root	1.67
114	root	1.1	if (++$sem->[0] > 0) {
115			(shift @{$sem->[1]})->ready if @{$sem->[1]};
116			}
117	root	1.67
118	root	1.35	delete $_[0][1]{$_[1]} if $sem->[0] == $_[0][0] && !@{$sem->[1] \|\| []};
119	root	1.1	}
120
121			=item $sem->try
122
123			Try to C<down> the semaphore. Returns true when this was possible,
124			otherwise return false and leave the semaphore unchanged.
125
126			=cut
127
128			sub try {
129			my $sem = ($_[0][1]{$_[1]} \|\|= [$_[0][0]]);
130			if ($sem->[0] > 0) {
131			--$sem->[0];
132			return 1;
133			} else {
134			return 0;
135			}
136			}
137
138	root	1.31	=item $sem->waiters ($id)
139	root	1.1
140			In scalar context, returns the number of coroutines waiting for this
141			semaphore.
142
143			=cut
144
145			sub waiters {
146	root	1.33	my $sem = $_[0][1]{$_[1]}
147	root	1.32	or return;
148	root	1.33	@{ $_[0][1]{$_[1]}[1] \|\| []}
149	root	1.1	}
150
151	root	1.31	=item $guard = $sem->guard ($id)
152	root	1.1
153			This method calls C<down> and then creates a guard object. When the guard
154			object is destroyed it automatically calls C<up>.
155
156	root	1.31	=item $guard = $sem->timed_guard ($id, $timeout)
157	root	1.9
158			Like C<guard>, but returns undef if semaphore couldn't be acquired within
159			$timeout seconds, otherwise the guard object.
160
161	root	1.1	=cut
162
163			sub guard {
164			&down;
165	root	1.10	bless [@_], Coro::SemaphoreSet::guard::;
166	root	1.9	}
167
168	root	1.15	sub timed_guard {
169	root	1.9	&timed_down
170	root	1.10	? bless [$_[0], $_[1]], Coro::SemaphoreSet::guard::
171	root	1.9	: ();
172	root	1.1	}
173
174	root	1.9	sub Coro::SemaphoreSet::guard::DESTROY {
175	root	1.1	&up(@{$_[0]});
176			}
177
178			1;
179
180			=back
181
182			=head1 AUTHOR
183
184	root	1.28	Marc Lehmann <schmorp@schmorp.de>
185	root	1.26	http://home.schmorp.de/
186	root	1.1
187			=cut
188