line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# You may distribute under the terms of either the GNU General Public License |
2
|
|
|
|
|
|
|
# or the Artistic License (the same terms as Perl itself) |
3
|
|
|
|
|
|
|
# |
4
|
|
|
|
|
|
|
# (C) Paul Evans, 2016-2020 -- leonerd@leonerd.org.uk |
5
|
|
|
|
|
|
|
|
6
|
|
|
|
|
|
|
package Future::Mutex; |
7
|
|
|
|
|
|
|
|
8
|
1
|
|
|
1
|
|
459
|
use v5.10; |
|
1
|
|
|
|
|
4
|
|
9
|
1
|
|
|
1
|
|
5
|
use strict; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
19
|
|
10
|
1
|
|
|
1
|
|
5
|
use warnings; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
37
|
|
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
our $VERSION = '0.49'; |
13
|
|
|
|
|
|
|
|
14
|
1
|
|
|
1
|
|
5
|
use Future; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
326
|
|
15
|
|
|
|
|
|
|
|
16
|
|
|
|
|
|
|
=head1 NAME |
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
C - mutual exclusion lock around code that returns Ls |
19
|
|
|
|
|
|
|
|
20
|
|
|
|
|
|
|
=head1 SYNOPSIS |
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
use Future::Mutex; |
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
my $mutex = Future::Mutex->new; |
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
sub do_atomically |
27
|
|
|
|
|
|
|
{ |
28
|
|
|
|
|
|
|
return $mutex->enter( sub { |
29
|
|
|
|
|
|
|
... |
30
|
|
|
|
|
|
|
return $f; |
31
|
|
|
|
|
|
|
}); |
32
|
|
|
|
|
|
|
} |
33
|
|
|
|
|
|
|
|
34
|
|
|
|
|
|
|
=head1 DESCRIPTION |
35
|
|
|
|
|
|
|
|
36
|
|
|
|
|
|
|
Most L-using code expects to run with some level of concurrency, using |
37
|
|
|
|
|
|
|
future instances to represent still-pending operations that will complete at |
38
|
|
|
|
|
|
|
some later time. There are occasions however, when this concurrency needs to |
39
|
|
|
|
|
|
|
be restricted - some operations that, once started, must not be interrupted |
40
|
|
|
|
|
|
|
until they are complete. Subsequent requests to perform the same operation |
41
|
|
|
|
|
|
|
while one is still outstanding must therefore be queued to wait until the |
42
|
|
|
|
|
|
|
first is finished. These situations call for a mutual-exclusion lock, or |
43
|
|
|
|
|
|
|
"mutex". |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
A C instance provides one basic operation, which will execute a |
46
|
|
|
|
|
|
|
given block of code which returns a future, and itself returns a future to |
47
|
|
|
|
|
|
|
represent that. The mutex can be in one of two states; either unlocked or |
48
|
|
|
|
|
|
|
locked. While it is unlocked, requests to execute code are handled |
49
|
|
|
|
|
|
|
immediately. Once a block of code is invoked, the mutex is now considered to |
50
|
|
|
|
|
|
|
be locked, causing any subsequent requests to invoke code to be queued behind |
51
|
|
|
|
|
|
|
the first one, until it completes. Once the initial code indicates completion |
52
|
|
|
|
|
|
|
(by its returned future providing a result or failing), the next queued code |
53
|
|
|
|
|
|
|
is invoked. |
54
|
|
|
|
|
|
|
|
55
|
|
|
|
|
|
|
An instance may also be a counting mutex if initialised with a count greater |
56
|
|
|
|
|
|
|
than one. In this case, it can keep multiple blocks outstanding up to that |
57
|
|
|
|
|
|
|
limit, with subsequent requests queued as before. This allows it to act as a |
58
|
|
|
|
|
|
|
concurrency-bounding limit around some operation that can run concurrently, |
59
|
|
|
|
|
|
|
but an application wishes to apply overall limits to stop it growing too much, |
60
|
|
|
|
|
|
|
such as communications with external services or executing other programs. |
61
|
|
|
|
|
|
|
|
62
|
|
|
|
|
|
|
=cut |
63
|
|
|
|
|
|
|
|
64
|
|
|
|
|
|
|
=head1 CONSTRUCTOR |
65
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
=cut |
67
|
|
|
|
|
|
|
|
68
|
|
|
|
|
|
|
=head2 new |
69
|
|
|
|
|
|
|
|
70
|
|
|
|
|
|
|
$mutex = Future::Mutex->new( count => $n ) |
71
|
|
|
|
|
|
|
|
72
|
|
|
|
|
|
|
Returns a new C instance. It is initially unlocked. |
73
|
|
|
|
|
|
|
|
74
|
|
|
|
|
|
|
Takes the following named arguments: |
75
|
|
|
|
|
|
|
|
76
|
|
|
|
|
|
|
=over 8 |
77
|
|
|
|
|
|
|
|
78
|
|
|
|
|
|
|
=item count => INT |
79
|
|
|
|
|
|
|
|
80
|
|
|
|
|
|
|
Optional number to limit outstanding concurrency. Will default to 1 if not |
81
|
|
|
|
|
|
|
supplied. |
82
|
|
|
|
|
|
|
|
83
|
|
|
|
|
|
|
=back |
84
|
|
|
|
|
|
|
|
85
|
|
|
|
|
|
|
=cut |
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
sub new |
88
|
|
|
|
|
|
|
{ |
89
|
10
|
|
|
10
|
1
|
3514
|
my $class = shift; |
90
|
10
|
|
|
|
|
22
|
my %params = @_; |
91
|
|
|
|
|
|
|
|
92
|
|
|
|
|
|
|
return bless { |
93
|
10
|
|
100
|
|
|
70
|
avail => $params{count} // 1, |
94
|
|
|
|
|
|
|
waitf => undef, |
95
|
|
|
|
|
|
|
queue => [], |
96
|
|
|
|
|
|
|
}, $class; |
97
|
|
|
|
|
|
|
} |
98
|
|
|
|
|
|
|
|
99
|
|
|
|
|
|
|
=head1 METHODS |
100
|
|
|
|
|
|
|
|
101
|
|
|
|
|
|
|
=cut |
102
|
|
|
|
|
|
|
|
103
|
|
|
|
|
|
|
=head2 enter |
104
|
|
|
|
|
|
|
|
105
|
|
|
|
|
|
|
$f = $mutex->enter( \&code ) |
106
|
|
|
|
|
|
|
|
107
|
|
|
|
|
|
|
Returns a new C that represents the eventual result of calling the |
108
|
|
|
|
|
|
|
code. If the mutex is currently unlocked, the code will be invoked |
109
|
|
|
|
|
|
|
immediately. If it is currently locked, the code will be queued waiting for |
110
|
|
|
|
|
|
|
the next time it becomes unlocked. |
111
|
|
|
|
|
|
|
|
112
|
|
|
|
|
|
|
The code is invoked with no arguments, and is expected to return a C. |
113
|
|
|
|
|
|
|
The eventual result of that future determines the result of the future that |
114
|
|
|
|
|
|
|
C returned. |
115
|
|
|
|
|
|
|
|
116
|
|
|
|
|
|
|
=cut |
117
|
|
|
|
|
|
|
|
118
|
|
|
|
|
|
|
sub enter |
119
|
|
|
|
|
|
|
{ |
120
|
17
|
|
|
17
|
1
|
92
|
my $self = shift; |
121
|
17
|
|
|
|
|
25
|
my ( $code ) = @_; |
122
|
|
|
|
|
|
|
|
123
|
17
|
|
|
|
|
21
|
my $down_f; |
124
|
17
|
100
|
|
|
|
35
|
if( $self->{avail} ) { |
125
|
11
|
|
|
|
|
13
|
$self->{avail}--; |
126
|
11
|
|
|
|
|
39
|
$down_f = Future->done; |
127
|
|
|
|
|
|
|
} |
128
|
|
|
|
|
|
|
else { |
129
|
6
|
50
|
|
|
|
13
|
die "ARGH Need to clone an existing future\n" unless defined $self->{waitf}; |
130
|
6
|
|
|
|
|
7
|
push @{ $self->{queue} }, $down_f = $self->{waitf}->new; |
|
6
|
|
|
|
|
17
|
|
131
|
|
|
|
|
|
|
} |
132
|
|
|
|
|
|
|
|
133
|
|
|
|
|
|
|
my $up = sub { |
134
|
17
|
100
|
|
17
|
|
25
|
if( my $next_f = shift @{ $self->{queue} } ) { |
|
17
|
|
|
|
|
41
|
|
135
|
6
|
|
|
|
|
17
|
$next_f->done; |
136
|
|
|
|
|
|
|
} |
137
|
|
|
|
|
|
|
else { |
138
|
11
|
|
|
|
|
18
|
$self->{avail}++; |
139
|
11
|
|
|
|
|
38
|
undef $self->{waitf}; |
140
|
|
|
|
|
|
|
} |
141
|
17
|
|
|
|
|
56
|
}; |
142
|
|
|
|
|
|
|
|
143
|
17
|
|
|
|
|
48
|
my $retf = $down_f->then( $code )->on_ready( $up ); |
144
|
17
|
100
|
|
|
|
40
|
$self->{waitf} or $self->{waitf} = $retf; |
145
|
17
|
|
|
|
|
101
|
return $retf; |
146
|
|
|
|
|
|
|
} |
147
|
|
|
|
|
|
|
|
148
|
|
|
|
|
|
|
=head2 available |
149
|
|
|
|
|
|
|
|
150
|
|
|
|
|
|
|
$avail = $mutex->available |
151
|
|
|
|
|
|
|
|
152
|
|
|
|
|
|
|
Returns true if the mutex is currently unlocked, or false if it is locked. |
153
|
|
|
|
|
|
|
|
154
|
|
|
|
|
|
|
=cut |
155
|
|
|
|
|
|
|
|
156
|
|
|
|
|
|
|
sub available |
157
|
|
|
|
|
|
|
{ |
158
|
12
|
|
|
12
|
1
|
888
|
my $self = shift; |
159
|
12
|
|
|
|
|
55
|
return $self->{avail}; |
160
|
|
|
|
|
|
|
} |
161
|
|
|
|
|
|
|
|
162
|
|
|
|
|
|
|
=head1 AUTHOR |
163
|
|
|
|
|
|
|
|
164
|
|
|
|
|
|
|
Paul Evans |
165
|
|
|
|
|
|
|
|
166
|
|
|
|
|
|
|
=cut |
167
|
|
|
|
|
|
|
|
168
|
|
|
|
|
|
|
0x55AA; |