line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package IPC::ShareLite; |
2
|
|
|
|
|
|
|
|
3
|
4
|
|
|
4
|
|
46832
|
use strict; |
|
4
|
|
|
|
|
8
|
|
|
4
|
|
|
|
|
142
|
|
4
|
4
|
|
|
4
|
|
20
|
use warnings; |
|
4
|
|
|
|
|
10
|
|
|
4
|
|
|
|
|
125
|
|
5
|
4
|
|
|
4
|
|
22
|
use Carp; |
|
4
|
|
|
|
|
44
|
|
|
4
|
|
|
|
|
442
|
|
6
|
|
|
|
|
|
|
|
7
|
|
|
|
|
|
|
=head1 NAME |
8
|
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
IPC::ShareLite - Lightweight interface to shared memory |
10
|
|
|
|
|
|
|
|
11
|
|
|
|
|
|
|
=head1 VERSION |
12
|
|
|
|
|
|
|
|
13
|
|
|
|
|
|
|
This document describes IPC::ShareLite version 0.17 |
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
=cut |
16
|
|
|
|
|
|
|
|
17
|
4
|
|
|
|
|
441
|
use vars qw( |
18
|
|
|
|
|
|
|
$VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $AUTOLOAD |
19
|
4
|
|
|
4
|
|
20
|
); |
|
4
|
|
|
|
|
9
|
|
20
|
|
|
|
|
|
|
|
21
|
4
|
|
|
|
|
20
|
use subs qw( |
22
|
|
|
|
|
|
|
IPC_CREAT IPC_EXCL IPC_RMID IPC_STAT IPC_PRIVATE GETVAL SETVAL GETALL |
23
|
|
|
|
|
|
|
SEM_UNDO LOCK_EX LOCK_SH LOCK_UN LOCK_NB |
24
|
4
|
|
|
4
|
|
3855
|
); |
|
4
|
|
|
|
|
109
|
|
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
require Exporter; |
27
|
|
|
|
|
|
|
require DynaLoader; |
28
|
|
|
|
|
|
|
require AutoLoader; |
29
|
|
|
|
|
|
|
|
30
|
|
|
|
|
|
|
@ISA = qw( Exporter DynaLoader ); |
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
@EXPORT = qw( ); |
33
|
|
|
|
|
|
|
|
34
|
|
|
|
|
|
|
@EXPORT_OK = qw( |
35
|
|
|
|
|
|
|
IPC_CREAT IPC_EXCL IPC_RMID IPC_STATE IPC_PRIVATE GETVAL SETVAL GETALL |
36
|
|
|
|
|
|
|
SEM_UNDO LOCK_EX LOCK_SH LOCK_UN LOCK_NB |
37
|
|
|
|
|
|
|
); |
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
%EXPORT_TAGS = ( |
40
|
|
|
|
|
|
|
all => [ |
41
|
|
|
|
|
|
|
qw( |
42
|
|
|
|
|
|
|
IPC_CREAT IPC_EXCL IPC_RMID IPC_PRIVATE LOCK_EX LOCK_SH LOCK_UN |
43
|
|
|
|
|
|
|
LOCK_NB |
44
|
|
|
|
|
|
|
) |
45
|
|
|
|
|
|
|
], |
46
|
|
|
|
|
|
|
lock => [qw( LOCK_EX LOCK_SH LOCK_UN LOCK_NB )], |
47
|
|
|
|
|
|
|
flock => [qw( LOCK_EX LOCK_SH LOCK_UN LOCK_NB )], |
48
|
|
|
|
|
|
|
); |
49
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
Exporter::export_ok_tags( 'all', 'lock', 'flock' ); |
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
$VERSION = '0.17'; |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
=head1 SYNOPSIS |
55
|
|
|
|
|
|
|
|
56
|
|
|
|
|
|
|
use IPC::ShareLite; |
57
|
|
|
|
|
|
|
|
58
|
|
|
|
|
|
|
my $share = IPC::ShareLite->new( |
59
|
|
|
|
|
|
|
-key => 1971, |
60
|
|
|
|
|
|
|
-create => 'yes', |
61
|
|
|
|
|
|
|
-destroy => 'no' |
62
|
|
|
|
|
|
|
) or die $!; |
63
|
|
|
|
|
|
|
|
64
|
|
|
|
|
|
|
$share->store( "This is stored in shared memory" ); |
65
|
|
|
|
|
|
|
my $str = $share->fetch; |
66
|
|
|
|
|
|
|
|
67
|
|
|
|
|
|
|
=head1 DESCRIPTION |
68
|
|
|
|
|
|
|
|
69
|
|
|
|
|
|
|
IPC::ShareLite provides a simple interface to shared memory, allowing |
70
|
|
|
|
|
|
|
data to be efficiently communicated between processes. Your operating |
71
|
|
|
|
|
|
|
system must support SysV IPC (shared memory and semaphores) in order to |
72
|
|
|
|
|
|
|
use this module. |
73
|
|
|
|
|
|
|
|
74
|
|
|
|
|
|
|
IPC::ShareLite provides an abstraction of the shared memory and |
75
|
|
|
|
|
|
|
semaphore facilities of SysV IPC, allowing the storage of arbitrarily |
76
|
|
|
|
|
|
|
large data; the module automatically acquires and removes shared memory |
77
|
|
|
|
|
|
|
segments as needed. Storage and retrieval of data is atomic, and locking |
78
|
|
|
|
|
|
|
functions are provided for higher-level synchronization. |
79
|
|
|
|
|
|
|
|
80
|
|
|
|
|
|
|
In many respects, this module is similar to IPC::Shareable. However, |
81
|
|
|
|
|
|
|
IPC::ShareLite does not provide a tied interface, does not |
82
|
|
|
|
|
|
|
(automatically) allow the storage of variables, and is written in C |
83
|
|
|
|
|
|
|
for additional speed. |
84
|
|
|
|
|
|
|
|
85
|
|
|
|
|
|
|
Construct an IPC::ShareLite object by calling its constructor: |
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
my $share = IPC::ShareLite->new( |
88
|
|
|
|
|
|
|
-key => 1971, |
89
|
|
|
|
|
|
|
-create => 'yes', |
90
|
|
|
|
|
|
|
-destroy => 'no' |
91
|
|
|
|
|
|
|
) or die $!; |
92
|
|
|
|
|
|
|
|
93
|
|
|
|
|
|
|
Once an instance has been created, data can be written to shared memory |
94
|
|
|
|
|
|
|
by calling the store() method: |
95
|
|
|
|
|
|
|
|
96
|
|
|
|
|
|
|
$share->store("This is going in shared memory"); |
97
|
|
|
|
|
|
|
|
98
|
|
|
|
|
|
|
Retrieve the data by calling the fetch() method: |
99
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
my $str = $share->fetch(); |
101
|
|
|
|
|
|
|
|
102
|
|
|
|
|
|
|
The store() and fetch() methods are atomic; any processes attempting |
103
|
|
|
|
|
|
|
to read or write to the memory are blocked until these calls finish. |
104
|
|
|
|
|
|
|
However, in certain situations, you'll want to perform multiple |
105
|
|
|
|
|
|
|
operations atomically. Advisory locking methods are available for |
106
|
|
|
|
|
|
|
this purpose. |
107
|
|
|
|
|
|
|
|
108
|
|
|
|
|
|
|
An exclusive lock is obtained by calling the lock() method: |
109
|
|
|
|
|
|
|
|
110
|
|
|
|
|
|
|
$share->lock(); |
111
|
|
|
|
|
|
|
|
112
|
|
|
|
|
|
|
Happily, the lock() method also accepts all of the flags recognized |
113
|
|
|
|
|
|
|
by the flock() system call. So, for example, you can obtain a |
114
|
|
|
|
|
|
|
shared lock like this: |
115
|
|
|
|
|
|
|
|
116
|
|
|
|
|
|
|
$share->lock( LOCK_SH ); |
117
|
|
|
|
|
|
|
|
118
|
|
|
|
|
|
|
Or, you can make either type of lock non-blocking: |
119
|
|
|
|
|
|
|
|
120
|
|
|
|
|
|
|
$share->lock( LOCK_EX|LOCK_NB ); |
121
|
|
|
|
|
|
|
|
122
|
|
|
|
|
|
|
Release the lock by calling the unlock() method: |
123
|
|
|
|
|
|
|
|
124
|
|
|
|
|
|
|
$share->unlock; |
125
|
|
|
|
|
|
|
|
126
|
|
|
|
|
|
|
=head1 METHODS |
127
|
|
|
|
|
|
|
|
128
|
|
|
|
|
|
|
=head2 C<< new($key, $create, $destroy, $exclusive, $mode, $flags, $size) >> |
129
|
|
|
|
|
|
|
|
130
|
|
|
|
|
|
|
This is the constructor for IPC::ShareLite. It accepts both |
131
|
|
|
|
|
|
|
the positional and named parameter calling styles. |
132
|
|
|
|
|
|
|
|
133
|
|
|
|
|
|
|
C<$key> is an integer value used to associate data between processes. |
134
|
|
|
|
|
|
|
All processes wishing to communicate should use the same $key value. |
135
|
|
|
|
|
|
|
$key may also be specified as a four character string, in which case |
136
|
|
|
|
|
|
|
it will be converted to an integer value automatically. If $key |
137
|
|
|
|
|
|
|
is undefined, the shared memory will not be accessible from other |
138
|
|
|
|
|
|
|
processes. |
139
|
|
|
|
|
|
|
|
140
|
|
|
|
|
|
|
C<$create> specifies whether the shared memory segment should be |
141
|
|
|
|
|
|
|
created if it does not already exist. Acceptable values are |
142
|
|
|
|
|
|
|
1, 'yes', 0, or 'no'. |
143
|
|
|
|
|
|
|
|
144
|
|
|
|
|
|
|
C<$destroy> indicates whether the shared memory segments and semaphores |
145
|
|
|
|
|
|
|
should be removed from the system once the object is destroyed. |
146
|
|
|
|
|
|
|
Acceptable values are 1, 'yes', 0, or 'no'. |
147
|
|
|
|
|
|
|
|
148
|
|
|
|
|
|
|
If C<$exclusive> is true, instantiation will fail if the shared memory |
149
|
|
|
|
|
|
|
segment already exists. Acceptable values are 1, 'yes', 0, or 'no'. |
150
|
|
|
|
|
|
|
|
151
|
|
|
|
|
|
|
C<$mode> specifies the permissions for the shared memory and semaphores. |
152
|
|
|
|
|
|
|
The default value is 0666. |
153
|
|
|
|
|
|
|
|
154
|
|
|
|
|
|
|
C<$flags> specifies the exact shared memory and semaphore flags to |
155
|
|
|
|
|
|
|
use. The constants IPC_CREAT, IPC_EXCL, and IPC_PRIVATE are available |
156
|
|
|
|
|
|
|
for import. |
157
|
|
|
|
|
|
|
|
158
|
|
|
|
|
|
|
C<$size> specifies the shared memory segment size, in bytes. The default |
159
|
|
|
|
|
|
|
size is 65,536 bytes, which is fairly portable. Linux, as an example, |
160
|
|
|
|
|
|
|
supports segment sizes of 4 megabytes. |
161
|
|
|
|
|
|
|
|
162
|
|
|
|
|
|
|
The constructor croaks on error. |
163
|
|
|
|
|
|
|
|
164
|
|
|
|
|
|
|
=cut |
165
|
|
|
|
|
|
|
|
166
|
|
|
|
|
|
|
sub new { |
167
|
4
|
|
|
4
|
1
|
1602
|
my $class = shift; |
168
|
4
|
|
33
|
|
|
32
|
my $self = bless {}, ref $class || $class; |
169
|
|
|
|
|
|
|
|
170
|
4
|
|
|
|
|
24
|
my $args = $class->_rearrange_args( |
171
|
|
|
|
|
|
|
[ |
172
|
|
|
|
|
|
|
qw( key create destroy exclusive mode |
173
|
|
|
|
|
|
|
flags size glue ) |
174
|
|
|
|
|
|
|
], |
175
|
|
|
|
|
|
|
\@_ |
176
|
|
|
|
|
|
|
); |
177
|
|
|
|
|
|
|
|
178
|
4
|
|
|
|
|
15
|
$self->_initialize( $args ); |
179
|
|
|
|
|
|
|
|
180
|
2
|
|
|
|
|
1390
|
return $self; |
181
|
|
|
|
|
|
|
} |
182
|
|
|
|
|
|
|
|
183
|
|
|
|
|
|
|
sub _8bit_clean { |
184
|
2
|
|
|
2
|
|
5
|
my ( $self, $str ) = @_; |
185
|
8
|
|
|
|
|
402
|
croak "$str is not 8-bit clean" |
186
|
2
|
50
|
|
|
|
11
|
if grep { $_ > 255 } map ord, split //, $str; |
187
|
|
|
|
|
|
|
} |
188
|
|
|
|
|
|
|
|
189
|
|
|
|
|
|
|
sub _initialize { |
190
|
4
|
|
|
4
|
|
8
|
my $self = shift; |
191
|
4
|
|
|
|
|
7
|
my $args = shift; |
192
|
|
|
|
|
|
|
|
193
|
4
|
|
|
|
|
8
|
for ( qw( create exclusive destroy ) ) { |
194
|
12
|
100
|
100
|
|
|
143
|
$args->{$_} = 0 |
195
|
|
|
|
|
|
|
if defined $args->{$_} and lc $args->{$_} eq 'no'; |
196
|
|
|
|
|
|
|
} |
197
|
|
|
|
|
|
|
|
198
|
|
|
|
|
|
|
# Allow glue as a synonym for key |
199
|
4
|
|
33
|
|
|
39
|
$self->{key} = $args->{key} || $args->{glue} || IPC_PRIVATE; |
200
|
|
|
|
|
|
|
|
201
|
|
|
|
|
|
|
# Allow a four character string as the key |
202
|
4
|
100
|
|
|
|
42
|
unless ( $self->{key} =~ /^\d+$/ ) { |
203
|
2
|
50
|
|
|
|
8
|
croak "Key must be a number or four character string" |
204
|
|
|
|
|
|
|
if length $self->{key} > 4; |
205
|
2
|
|
|
|
|
6
|
$self->_8bit_clean( $self->{key} ); |
206
|
0
|
|
|
|
|
0
|
$self->{key} = unpack( 'i', pack( 'A4', $self->{key} ) ); |
207
|
|
|
|
|
|
|
} |
208
|
|
|
|
|
|
|
|
209
|
2
|
50
|
|
|
|
16
|
$self->{create} = ( $args->{create} ? IPC_CREAT : 0 ); |
210
|
|
|
|
|
|
|
|
211
|
2
|
50
|
|
|
|
8
|
$self->{exclusive} = ( |
212
|
|
|
|
|
|
|
$args->{exclusive} |
213
|
|
|
|
|
|
|
? IPC_EXCL | IPC_CREAT |
214
|
|
|
|
|
|
|
: 0 |
215
|
|
|
|
|
|
|
); |
216
|
|
|
|
|
|
|
|
217
|
2
|
50
|
|
|
|
6
|
$self->{destroy} = ( $args->{destroy} ? 1 : 0 ); |
218
|
|
|
|
|
|
|
|
219
|
2
|
|
50
|
|
|
12
|
$self->{flags} = $args->{flags} || 0; |
220
|
2
|
50
|
50
|
|
|
46
|
$self->{mode} = $args->{mode} || 0666 unless $args->{flags}; |
221
|
2
|
|
50
|
|
|
10
|
$self->{size} = $args->{size} || 0; |
222
|
|
|
|
|
|
|
|
223
|
2
|
|
|
|
|
6
|
$self->{flags} = $self->{flags} | $self->{exclusive} | $self->{create} |
224
|
|
|
|
|
|
|
| $self->{mode}; |
225
|
|
|
|
|
|
|
|
226
|
2
|
50
|
|
|
|
172
|
$self->{share} |
227
|
|
|
|
|
|
|
= new_share( $self->{key}, $self->{size}, $self->{flags} ) |
228
|
|
|
|
|
|
|
or croak "Failed to create share"; |
229
|
|
|
|
|
|
|
|
230
|
2
|
|
|
|
|
4
|
return 1; |
231
|
|
|
|
|
|
|
} |
232
|
|
|
|
|
|
|
|
233
|
|
|
|
|
|
|
sub _rearrange_args { |
234
|
4
|
|
|
4
|
|
10
|
my ( $self, $names, $params ) = @_; |
235
|
4
|
|
|
|
|
7
|
my ( %hash, %names ); |
236
|
|
|
|
|
|
|
|
237
|
4
|
50
|
|
|
|
13
|
return \%hash unless ( @$params ); |
238
|
|
|
|
|
|
|
|
239
|
4
|
50
|
|
|
|
29
|
unless ( $params->[0] =~ /^-/ ) { |
240
|
0
|
0
|
|
|
|
0
|
croak "unexpected number of parameters" |
241
|
|
|
|
|
|
|
unless ( @$names == @$params ); |
242
|
0
|
|
|
|
|
0
|
$hash{@$names} = @$params; |
243
|
0
|
|
|
|
|
0
|
return \%hash; |
244
|
|
|
|
|
|
|
} |
245
|
|
|
|
|
|
|
|
246
|
4
|
|
|
|
|
10
|
%names = map { $_ => 1 } @$names; |
|
32
|
|
|
|
|
64
|
|
247
|
|
|
|
|
|
|
|
248
|
4
|
|
|
|
|
19
|
while ( @$params ) { |
249
|
14
|
|
|
|
|
32
|
my $param = lc substr( shift @$params, 1 ); |
250
|
14
|
50
|
|
|
|
32
|
exists $names{$param} or croak "unexpected parameter '-$param'"; |
251
|
14
|
|
|
|
|
41
|
$hash{$param} = shift @$params; |
252
|
|
|
|
|
|
|
} |
253
|
|
|
|
|
|
|
|
254
|
4
|
|
|
|
|
16
|
return \%hash; |
255
|
|
|
|
|
|
|
} |
256
|
|
|
|
|
|
|
|
257
|
|
|
|
|
|
|
=head2 C<< store( $scalar ) >> |
258
|
|
|
|
|
|
|
|
259
|
|
|
|
|
|
|
This method stores C<$scalar> into shared memory. C<$scalar> may be |
260
|
|
|
|
|
|
|
arbitrarily long. Shared memory segments are acquired and |
261
|
|
|
|
|
|
|
released automatically as the data length changes. |
262
|
|
|
|
|
|
|
The only limits on the amount of data are the system-wide |
263
|
|
|
|
|
|
|
limits on shared memory pages (SHMALL) and segments (SHMMNI) |
264
|
|
|
|
|
|
|
as compiled into the kernel. |
265
|
|
|
|
|
|
|
|
266
|
|
|
|
|
|
|
The method raises an exception on error. |
267
|
|
|
|
|
|
|
|
268
|
|
|
|
|
|
|
Note that unlike L, this module does not automatically |
269
|
|
|
|
|
|
|
allow references to be stored. Serializing all data is expensive, and is |
270
|
|
|
|
|
|
|
not always necessary. If you need to store a reference, you should employ |
271
|
|
|
|
|
|
|
the L module yourself. For example: |
272
|
|
|
|
|
|
|
|
273
|
|
|
|
|
|
|
use Storable qw( freeze thaw ); |
274
|
|
|
|
|
|
|
... |
275
|
|
|
|
|
|
|
$hash = { red => 1, white => 1, blue => 1 }; |
276
|
|
|
|
|
|
|
$share->store( freeze( $hash ) ); |
277
|
|
|
|
|
|
|
... |
278
|
|
|
|
|
|
|
$hash = thaw( $share->fetch ); |
279
|
|
|
|
|
|
|
|
280
|
|
|
|
|
|
|
=cut |
281
|
|
|
|
|
|
|
|
282
|
|
|
|
|
|
|
sub store { |
283
|
2006
|
|
|
2006
|
1
|
8906
|
my $self = shift; |
284
|
|
|
|
|
|
|
|
285
|
2006
|
50
|
|
|
|
10979
|
if ( write_share( $self->{share}, $_[0], length $_[0] ) < 0 ) { |
286
|
0
|
|
|
|
|
0
|
croak "IPC::ShareLite store() error: $!"; |
287
|
|
|
|
|
|
|
} |
288
|
2006
|
|
|
|
|
4067
|
return 1; |
289
|
|
|
|
|
|
|
} |
290
|
|
|
|
|
|
|
|
291
|
|
|
|
|
|
|
=head2 C<< fetch >> |
292
|
|
|
|
|
|
|
|
293
|
|
|
|
|
|
|
This method returns the data that was previously stored in |
294
|
|
|
|
|
|
|
shared memory. The empty string is returned if no data was |
295
|
|
|
|
|
|
|
previously stored. |
296
|
|
|
|
|
|
|
|
297
|
|
|
|
|
|
|
The method raises an exception on error. |
298
|
|
|
|
|
|
|
|
299
|
|
|
|
|
|
|
=cut |
300
|
|
|
|
|
|
|
|
301
|
|
|
|
|
|
|
sub fetch { |
302
|
2005
|
|
|
2005
|
1
|
294286
|
my $self = shift; |
303
|
|
|
|
|
|
|
|
304
|
2005
|
|
|
|
|
8966
|
my $str = read_share( $self->{share} ); |
305
|
2005
|
50
|
|
|
|
5902
|
defined $str or croak "IPC::ShareLite fetch() error: $!"; |
306
|
2005
|
|
|
|
|
6332
|
return $str; |
307
|
|
|
|
|
|
|
} |
308
|
|
|
|
|
|
|
|
309
|
|
|
|
|
|
|
=head2 C<< lock( $type ) >> |
310
|
|
|
|
|
|
|
|
311
|
|
|
|
|
|
|
Obtains a lock on the shared memory. $type specifies the type |
312
|
|
|
|
|
|
|
of lock to acquire. If $type is not specified, an exclusive |
313
|
|
|
|
|
|
|
read/write lock is obtained. Acceptable values for $type are |
314
|
|
|
|
|
|
|
the same as for the flock() system call. The method returns |
315
|
|
|
|
|
|
|
true on success, and undef on error. For non-blocking calls |
316
|
|
|
|
|
|
|
(see below), the method returns 0 if it would have blocked. |
317
|
|
|
|
|
|
|
|
318
|
|
|
|
|
|
|
Obtain an exclusive lock like this: |
319
|
|
|
|
|
|
|
|
320
|
|
|
|
|
|
|
$share->lock( LOCK_EX ); # same as default |
321
|
|
|
|
|
|
|
|
322
|
|
|
|
|
|
|
Only one process can hold an exclusive lock on the shared memory at |
323
|
|
|
|
|
|
|
a given time. |
324
|
|
|
|
|
|
|
|
325
|
|
|
|
|
|
|
Obtain a shared lock this this: |
326
|
|
|
|
|
|
|
|
327
|
|
|
|
|
|
|
$share->lock( LOCK_SH ); |
328
|
|
|
|
|
|
|
|
329
|
|
|
|
|
|
|
Multiple processes can hold a shared lock at a given time. If a process |
330
|
|
|
|
|
|
|
attempts to obtain an exclusive lock while one or more processes hold |
331
|
|
|
|
|
|
|
shared locks, it will be blocked until they have all finished. |
332
|
|
|
|
|
|
|
|
333
|
|
|
|
|
|
|
Either of the locks may be specified as non-blocking: |
334
|
|
|
|
|
|
|
|
335
|
|
|
|
|
|
|
$share->lock( LOCK_EX|LOCK_NB ); |
336
|
|
|
|
|
|
|
$share->lock( LOCK_SH|LOCK_NB ); |
337
|
|
|
|
|
|
|
|
338
|
|
|
|
|
|
|
A non-blocking lock request will return 0 if it would have had to |
339
|
|
|
|
|
|
|
wait to obtain the lock. |
340
|
|
|
|
|
|
|
|
341
|
|
|
|
|
|
|
Note that these locks are advisory (just like flock), meaning that |
342
|
|
|
|
|
|
|
all cooperating processes must coordinate their accesses to shared memory |
343
|
|
|
|
|
|
|
using these calls in order for locking to work. See the flock() call for |
344
|
|
|
|
|
|
|
details. |
345
|
|
|
|
|
|
|
|
346
|
|
|
|
|
|
|
Locks are inherited through forks, which means that two processes actually |
347
|
|
|
|
|
|
|
can possess an exclusive lock at the same time. Don't do that. |
348
|
|
|
|
|
|
|
|
349
|
|
|
|
|
|
|
The constants LOCK_EX, LOCK_SH, LOCK_NB, and LOCK_UN are available |
350
|
|
|
|
|
|
|
for import: |
351
|
|
|
|
|
|
|
|
352
|
|
|
|
|
|
|
use IPC::ShareLite qw( :lock ); |
353
|
|
|
|
|
|
|
|
354
|
|
|
|
|
|
|
Or, just use the flock constants available in the Fcntl module. |
355
|
|
|
|
|
|
|
|
356
|
|
|
|
|
|
|
=cut |
357
|
|
|
|
|
|
|
|
358
|
|
|
|
|
|
|
sub lock { |
359
|
2000
|
|
|
2000
|
1
|
3393
|
my $self = shift; |
360
|
|
|
|
|
|
|
|
361
|
2000
|
|
|
|
|
286821
|
my $response = sharelite_lock( $self->{share}, shift() ); |
362
|
2000
|
50
|
|
|
|
6187
|
return undef if ( $response == -1 ); |
363
|
2000
|
50
|
|
|
|
4501
|
return 0 if ( $response == 1 ); # operation failed due to LOCK_NB |
364
|
2000
|
|
|
|
|
10229
|
return 1; |
365
|
|
|
|
|
|
|
} |
366
|
|
|
|
|
|
|
|
367
|
|
|
|
|
|
|
=head2 C<< unlock >> |
368
|
|
|
|
|
|
|
|
369
|
|
|
|
|
|
|
Releases any locks. This is actually equivalent to: |
370
|
|
|
|
|
|
|
|
371
|
|
|
|
|
|
|
$share->lock( LOCK_UN ); |
372
|
|
|
|
|
|
|
|
373
|
|
|
|
|
|
|
The method returns true on success and undef on error. |
374
|
|
|
|
|
|
|
|
375
|
|
|
|
|
|
|
=cut |
376
|
|
|
|
|
|
|
|
377
|
|
|
|
|
|
|
sub unlock { |
378
|
2000
|
|
|
2000
|
1
|
7616
|
my $self = shift; |
379
|
|
|
|
|
|
|
|
380
|
2000
|
50
|
|
|
|
43097
|
return undef if ( sharelite_unlock( $self->{share} ) < 0 ); |
381
|
2000
|
|
|
|
|
5381
|
return 1; |
382
|
|
|
|
|
|
|
} |
383
|
|
|
|
|
|
|
|
384
|
|
|
|
|
|
|
# DEPRECATED -- Use lock() and unlock() instead. |
385
|
0
|
|
|
0
|
0
|
0
|
sub shlock { shift->lock( @_ ) } |
386
|
0
|
|
|
0
|
0
|
0
|
sub shunlock { shift->unlock( @_ ) } |
387
|
|
|
|
|
|
|
|
388
|
|
|
|
|
|
|
=head2 C<< version >> |
389
|
|
|
|
|
|
|
|
390
|
|
|
|
|
|
|
Each share has a version number that incrementents monotonically for |
391
|
|
|
|
|
|
|
each write to the share. When the share is initally created its version |
392
|
|
|
|
|
|
|
number will be 1. |
393
|
|
|
|
|
|
|
|
394
|
|
|
|
|
|
|
my $num_writes = $share->version; |
395
|
|
|
|
|
|
|
|
396
|
|
|
|
|
|
|
=cut |
397
|
|
|
|
|
|
|
|
398
|
9
|
|
|
9
|
1
|
63
|
sub version { sharelite_version( shift->{share} ) } |
399
|
|
|
|
|
|
|
|
400
|
|
|
|
|
|
|
=head2 C<< key >> |
401
|
|
|
|
|
|
|
|
402
|
|
|
|
|
|
|
Get a share's key. |
403
|
|
|
|
|
|
|
|
404
|
|
|
|
|
|
|
my $key = $share->key; |
405
|
|
|
|
|
|
|
|
406
|
|
|
|
|
|
|
=cut |
407
|
|
|
|
|
|
|
|
408
|
0
|
|
|
0
|
1
|
0
|
sub key { shift->{key} } |
409
|
|
|
|
|
|
|
|
410
|
|
|
|
|
|
|
=head2 C<< create >> |
411
|
|
|
|
|
|
|
|
412
|
|
|
|
|
|
|
Get a share's create flag. |
413
|
|
|
|
|
|
|
|
414
|
|
|
|
|
|
|
=cut |
415
|
|
|
|
|
|
|
|
416
|
0
|
|
|
0
|
1
|
0
|
sub create { shift->{create} } |
417
|
|
|
|
|
|
|
|
418
|
|
|
|
|
|
|
=head2 C<< exclusive >> |
419
|
|
|
|
|
|
|
|
420
|
|
|
|
|
|
|
Get a share's exclusive flag. |
421
|
|
|
|
|
|
|
|
422
|
|
|
|
|
|
|
=cut |
423
|
|
|
|
|
|
|
|
424
|
0
|
|
|
0
|
1
|
0
|
sub exclusive { shift->{exclusive} } |
425
|
|
|
|
|
|
|
|
426
|
|
|
|
|
|
|
=head2 C<< flags >> |
427
|
|
|
|
|
|
|
|
428
|
|
|
|
|
|
|
Get a share's flag. |
429
|
|
|
|
|
|
|
|
430
|
|
|
|
|
|
|
=cut |
431
|
|
|
|
|
|
|
|
432
|
0
|
|
|
0
|
1
|
0
|
sub flags { shift->{flags} } |
433
|
|
|
|
|
|
|
|
434
|
|
|
|
|
|
|
=head2 C<< mode >> |
435
|
|
|
|
|
|
|
|
436
|
|
|
|
|
|
|
Get a share's mode. |
437
|
|
|
|
|
|
|
|
438
|
|
|
|
|
|
|
=cut |
439
|
|
|
|
|
|
|
|
440
|
0
|
|
|
0
|
1
|
0
|
sub mode { shift->{mode} } |
441
|
|
|
|
|
|
|
|
442
|
|
|
|
|
|
|
=head2 C<< size >> |
443
|
|
|
|
|
|
|
|
444
|
|
|
|
|
|
|
Get a share's segment size. |
445
|
|
|
|
|
|
|
|
446
|
|
|
|
|
|
|
=cut |
447
|
|
|
|
|
|
|
|
448
|
0
|
|
|
0
|
1
|
0
|
sub size { shift->{size} } |
449
|
|
|
|
|
|
|
|
450
|
|
|
|
|
|
|
=head2 C<< num_segments >> |
451
|
|
|
|
|
|
|
|
452
|
|
|
|
|
|
|
Get the number of segments in a share. The memory usage of a share can |
453
|
|
|
|
|
|
|
be approximated like this: |
454
|
|
|
|
|
|
|
|
455
|
|
|
|
|
|
|
my $usage = $share->size * $share->num_segments; |
456
|
|
|
|
|
|
|
|
457
|
|
|
|
|
|
|
C<$usage> will be the memory usage rounded up to the next segment |
458
|
|
|
|
|
|
|
boundary. |
459
|
|
|
|
|
|
|
|
460
|
|
|
|
|
|
|
=cut |
461
|
|
|
|
|
|
|
|
462
|
|
|
|
|
|
|
sub num_segments { |
463
|
2
|
|
|
2
|
1
|
6
|
my $self = shift; |
464
|
|
|
|
|
|
|
|
465
|
2
|
|
|
|
|
234
|
my $count = sharelite_num_segments( $self->{share} ); |
466
|
2
|
50
|
|
|
|
18
|
return undef if $count < 0; |
467
|
2
|
|
|
|
|
8
|
return $count; |
468
|
|
|
|
|
|
|
} |
469
|
|
|
|
|
|
|
|
470
|
|
|
|
|
|
|
=head2 C<< destroy >> |
471
|
|
|
|
|
|
|
|
472
|
|
|
|
|
|
|
Get or set the share's destroy flag. |
473
|
|
|
|
|
|
|
|
474
|
|
|
|
|
|
|
=cut |
475
|
|
|
|
|
|
|
|
476
|
|
|
|
|
|
|
sub destroy { |
477
|
1
|
|
|
1
|
1
|
226
|
my $self = shift; |
478
|
1
|
50
|
|
|
|
18
|
$self->{destroy} = shift if @_; |
479
|
1
|
|
|
|
|
33
|
return $self->{destroy}; |
480
|
|
|
|
|
|
|
} |
481
|
|
|
|
|
|
|
|
482
|
|
|
|
|
|
|
sub DESTROY { |
483
|
4
|
|
|
4
|
|
86
|
my $self = shift; |
484
|
|
|
|
|
|
|
|
485
|
4
|
100
|
|
|
|
1392
|
destroy_share( $self->{share}, $self->{destroy} ) |
486
|
|
|
|
|
|
|
if $self->{share}; |
487
|
|
|
|
|
|
|
} |
488
|
|
|
|
|
|
|
|
489
|
|
|
|
|
|
|
sub AUTOLOAD { |
490
|
|
|
|
|
|
|
# This AUTOLOAD is used to 'autoload' constants from the constant() |
491
|
|
|
|
|
|
|
# XS function. If a constant is not found then control is passed |
492
|
|
|
|
|
|
|
# to the AUTOLOAD in AutoLoader. |
493
|
|
|
|
|
|
|
|
494
|
4
|
|
|
4
|
|
7
|
my $constname; |
495
|
4
|
|
|
|
|
139
|
( $constname = $AUTOLOAD ) =~ s/.*:://; |
496
|
4
|
50
|
|
|
|
78
|
my $val = constant( $constname, @_ ? $_[0] : 0 ); |
497
|
4
|
50
|
|
|
|
76
|
if ( $! != 0 ) { |
498
|
0
|
0
|
|
|
|
0
|
if ( $! =~ /Invalid/ ) { |
499
|
0
|
|
|
|
|
0
|
$AutoLoader::AUTOLOAD = $AUTOLOAD; |
500
|
0
|
|
|
|
|
0
|
goto &AutoLoader::AUTOLOAD; |
501
|
|
|
|
|
|
|
} |
502
|
|
|
|
|
|
|
else { |
503
|
0
|
|
|
|
|
0
|
croak "Your vendor has not defined ShareLite macro $constname"; |
504
|
|
|
|
|
|
|
} |
505
|
|
|
|
|
|
|
} |
506
|
4
|
|
|
2
|
|
776
|
eval "sub $AUTOLOAD { $val }"; |
|
2
|
|
|
2000
|
|
8
|
|
|
2000
|
|
|
|
|
101190
|
|
507
|
4
|
|
|
|
|
516
|
goto &$AUTOLOAD; |
508
|
|
|
|
|
|
|
} |
509
|
|
|
|
|
|
|
|
510
|
|
|
|
|
|
|
bootstrap IPC::ShareLite $VERSION; |
511
|
|
|
|
|
|
|
|
512
|
|
|
|
|
|
|
1; |
513
|
|
|
|
|
|
|
|
514
|
|
|
|
|
|
|
__END__ |