1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
|
use strict;
use warnings;
use Test::More tests => 14;
use File::Spec;
my $log_file = $ENV{IPC_SHARELITE_LOG}
= File::Spec->catfile( 't', "sl-$$.log" );
use_ok 'IPC::ShareLite', qw( LOCK_EX LOCK_SH LOCK_UN LOCK_NB );
######################### End of black magic.
# If a semaphore or shared memory segment already uses this
# key, all tests will fail
my $KEY = 192;
# Test object construction
ok my $share = IPC::ShareLite->new(
-key => $KEY,
-create => 'yes',
-destroy => 'yes',
-size => 100
),
'new';
isa_ok $share, 'IPC::ShareLite';
is $share->version, 1, 'version';
# Store value
ok $share->store( 'maurice' ), 'store';
is $share->version, 2, 'version inc';
# Retrieve value
is $share->fetch, 'maurice', 'fetch';
# Fragmented store
ok $share->store( "X" x 200 ), 'frag store';
is $share->version, 3, 'version inc';
# Check number of segments
is $share->num_segments, 3, 'num_segments';
# Fragmented fetch
is $share->fetch, ( 'X' x 200 ), 'frag fetch';
$share->store( 0 );
is $share->version, 4, 'version inc';
my $pid = fork;
defined $pid or die $!;
if ( $pid == 0 ) {
$share->destroy( 0 );
for ( 1 .. 1000 ) {
$share->lock( LOCK_EX() ) or die $!;
my $val = $share->fetch;
$share->store( ++$val ) or die $!;
$share->unlock or die $!;
}
exit;
}
else {
for ( 1 .. 1000 ) {
$share->lock( LOCK_EX() ) or die $!;
my $val = $share->fetch;
$share->store( ++$val ) or die $!;
$share->unlock or die $!;
}
wait;
}
is $share->fetch, 2000, 'lock';
is $share->version, 2004, 'version inc';
if ( -f $log_file ) {
if ( -s $log_file ) {
open my $lh, '<', $log_file or die "Can't read $log_file ($!)\n";
while ( <$lh> ) {
chomp;
diag $_;
}
}
unlink $log_file;
}
|
