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;

use Coro ();

$VERSION = 4.912;

=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->count

Returns the current semaphore count.

=cut

sub count {
   $_[0][0]
}

=item $sem->adjust ($diff)

Atomically adds the amount given to the current semaphore count. If the
count becomes positive, wakes up any waiters. Does not block if the count
becomes negative, however.

=cut

sub adjust {
   # basically a weird copy of up
   if (($_[0][0] += $_[1]) > 0) {
      (shift @{$_[0][1]})->ready if @{$_[0][1]};
   }
}

=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]}});
}

=back

=head1 AUTHOR

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

=cut

1

Revision:	1.78
Committed:	Thu Nov 13 17:32:01 2008 UTC (15 years, 6 months ago) by root
Branch:	MAIN
CVS Tags:	rel-4_912
Changes since 1.77:	+1 -1 lines
Log Message:	4.912
#	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.61	no warnings;
37	root	1.20
38	root	1.5	use Coro ();
39	root	1.1
40	root	1.78	$VERSION = 4.912;
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.55	=item $sem->count
56
57			Returns the current semaphore count.
58
59			=cut
60
61			sub count {
62			$_[0][0]
63			}
64
65	root	1.56	=item $sem->adjust ($diff)
66
67			Atomically adds the amount given to the current semaphore count. If the
68			count becomes positive, wakes up any waiters. Does not block if the count
69			becomes negative, however.
70
71			=cut
72
73			sub adjust {
74			# basically a weird copy of up
75			if (($_[0][0] += $_[1]) > 0) {
76			(shift @{$_[0][1]})->ready if @{$_[0][1]};
77			}
78			}
79
80	root	1.3	=item $sem->down
81
82			Decrement the counter, therefore "locking" the semaphore. This method
83			waits until the semaphore is available if the counter is zero.
84
85	root	1.57	=item $status = $sem->timed_down ($timeout)
86	root	1.24
87			Like C<down>, but returns false if semaphore couldn't be acquired within
88			$timeout seconds, otherwise true.
89
90	root	1.3	=cut
91
92	root	1.1	sub down {
93	root	1.17	while ($_[0][0] <= 0) {
94			push @{$_[0][1]}, $Coro::current;
95	root	1.54	&Coro::schedule;
96	root	1.1	}
97	root	1.17	--$_[0][0];
98	root	1.24	}
99
100			sub timed_down {
101			require Coro::Timer;
102	root	1.58	my $timeout = Coro::Timer::timeout ($_[1]);
103	root	1.24
104			while ($_[0][0] <= 0) {
105			push @{$_[0][1]}, $Coro::current;
106	root	1.54	&Coro::schedule;
107	root	1.26	if ($timeout) {
108	root	1.27	# ugly as hell. slow, too, btw!
109	root	1.26	for (0..$#{$_[0][1]}) {
110			if ($_[0][1][$_] == $Coro::current) {
111			splice @{$_[0][1]}, $_, 1;
112			return;
113			}
114			}
115			die;
116			}
117	root	1.24	}
118
119			--$_[0][0];
120			return 1;
121	root	1.1	}
122
123	root	1.3	=item $sem->up
124
125			Unlock the semaphore again.
126
127			=cut
128
129	root	1.1	sub up {
130	root	1.17	if (++$_[0][0] > 0) {
131			(shift @{$_[0][1]})->ready if @{$_[0][1]};
132	root	1.1	}
133			}
134	root	1.3
135			=item $sem->try
136
137			Try to C<down> the semaphore. Returns true when this was possible,
138			otherwise return false and leave the semaphore unchanged.
139
140			=cut
141	root	1.1
142			sub try {
143	root	1.17	if ($_[0][0] > 0) {
144			--$_[0][0];
145	root	1.1	return 1;
146			} else {
147			return 0;
148			}
149	root	1.12	}
150
151	root	1.15	=item $sem->waiters
152
153			In scalar context, returns the number of coroutines waiting for this
154			semaphore.
155
156			=cut
157
158			sub waiters {
159			@{$_[0][1]};
160			}
161
162	root	1.12	=item $guard = $sem->guard
163
164			This method calls C<down> and then creates a guard object. When the guard
165			object is destroyed it automatically calls C<up>.
166
167	root	1.57	=item $guard = $sem->timed_guard ($timeout)
168	root	1.25
169			Like C<guard>, but returns undef if semaphore couldn't be acquired within
170			$timeout seconds, otherwise the guard object.
171
172	root	1.12	=cut
173
174			sub guard {
175	root	1.16	&down;
176	root	1.13	# double indirection because bless works on the referenced
177			# object, not (only) on the reference itself.
178	root	1.26	bless \\$_[0], Coro::Semaphore::guard::;
179	root	1.25	}
180
181			sub timed_guard {
182			&timed_down
183	root	1.26	? bless \\$_[0], Coro::Semaphore::guard::
184	root	1.25	: ();
185	root	1.12	}
186
187	root	1.25	sub Coro::Semaphore::guard::DESTROY {
188	root	1.16	&up(${${$_[0]}});
189	root	1.1	}
190
191			=back
192
193			=head1 AUTHOR
194
195	root	1.44	Marc Lehmann <schmorp@schmorp.de>
196	root	1.42	http://home.schmorp.de/
197	root	1.1
198			=cut
199
200	root	1.51	1
201