1use warnings;
2use strict;
3
4use Carp;
5use Data::Dumper;
6use IPC::Shareable;
7use IPC::Shareable::SharedMem;
8use Test::More;
9use Test::SharedFork;
10
11sub shm_cleaned {
12    # --- shmread should barf if the segment has really been cleaned
13    my $id = shift;
14    my $data = '';
15
16    eval { shmread($id, $data, 0, 6) or die "$!" };
17
18    if ($@ && ($@ =~ /Invalid/ || $@ =~ /removed/)) {
19        return 1;
20    }
21
22    return 0;
23}
24
25# create not sent in
26{
27    my $ret = eval { my $s = tie(my $sv, 'IPC::Shareable', 'child_sv', { destroy => 0 }); 1; };
28    is $ret, undef, "We croak if a key is specified, create is not called and no segment exists";
29    like $@, qr/ERROR: Could not acquire/, "...and error message is sane";
30}
31
32# remove() (default IPC_PRIVATE)
33{
34    my $s = tie my $sv, 'IPC::Shareable', { destroy => 0 };
35    $sv = 'foobar';
36    is $sv, 'foobar', "Default (IPC_PRIVATE) SV set and value is 'foobar'";
37
38    my $id = $s->seg->id;
39
40    my $global = $s->global_register;
41    my $process = $s->process_register;
42
43    is keys %$global, 1, "Global register has one entry ok";
44    is keys %$process, 1, "Process register has one entry ok";
45
46    is exists $global->{$id}, 1, "ID $id exists in global register";
47    is exists $global->{$id}, 1, "ID $id exists in process register";
48
49    $s->remove;
50
51    is shm_cleaned($id), 1, "Default (IPC_PRIVATE) seg id $id removed after remove() ok";
52
53    is keys %$global, 0, "Global register cleaned after remove()";
54    is keys %$process, 0, "Process register cleaned after remove()";
55}
56
57# remove()
58{
59    my $s = tie my $sv, 'IPC::Shareable', 'test', { create => 1, destroy => 0 };
60    $sv = 'foobar';
61    is $sv, 'foobar', "SV set and value is 'foobar'";
62
63    my $id = $s->seg->id;
64
65    my $global = $s->global_register;
66    my $process = $s->process_register;
67
68    is keys %$global, 1, "Global register has one entry ok";
69    is keys %$process, 1, "Process register has one entry ok";
70
71    is exists $global->{$id}, 1, "ID $id exists in global register";
72    is exists $global->{$id}, 1, "ID $id exists in process register";
73
74    $s->remove;
75
76    is shm_cleaned($id), 1, "seg id $id removed after remove() ok";
77
78    is keys %$global, 0, "Global register cleaned after remove()";
79    is keys %$process, 0, "Process register cleaned after remove()";
80}
81
82# clean_up()
83{
84    my $s = tie my $sv, 'IPC::Shareable', 'test', { create => 1, destroy => 0 };
85    $sv = 'foobar';
86    is $sv, 'foobar', "SV set and value is 'foobar'";
87
88    my $id = $s->seg->id;
89
90    my $global = $s->global_register;
91    my $process = $s->process_register;
92
93    is keys %$global, 1, "Global register has one entry ok";
94    is keys %$process, 1, "Process register has one entry ok";
95
96    is exists $global->{$id}, 1, "ID $id exists in global register";
97    is exists $global->{$id}, 1, "ID $id exists in process register";
98
99    $s->clean_up;
100
101    is shm_cleaned($id), 1, "seg id $id removed after clean_up() ok";
102
103    is keys %$global, 0, "Global register cleaned after clean_up()";
104    is keys %$process, 0, "Process register cleaned after clean_up()";
105}
106
107# clean_up_all()
108{
109    my $s = tie my $sv, 'IPC::Shareable', 'test', { create => 1, destroy => 0 };
110    $sv = 'foobar';
111    is $sv, 'foobar', "SV set and value is 'foobar'";
112
113    my $id = $s->seg->id;
114
115    my $global = $s->global_register;
116    my $process = $s->process_register;
117
118    is keys %$global, 1, "Global register has one entry ok";
119    is keys %$process, 1, "Process register has one entry ok";
120
121    is exists $global->{$id}, 1, "ID $id exists in global register";
122    is exists $global->{$id}, 1, "ID $id exists in process register";
123
124    $s->clean_up_all;
125
126    is shm_cleaned($id), 1, "seg id $id removed after clean_up_all() ok";
127
128    is keys %$global, 0, "Global register cleaned after clean_up_all()";
129    is keys %$process, 0, "Process register cleaned after clean_up_all()";
130}
131
132my ($z, $y, $x, $w);
133
134# parent/child
135{
136    my $awake = 0;
137    local $SIG{ALRM} = sub { $awake = 1 };
138
139    my $pid = fork;
140    defined $pid or die "Cannot fork : $!";
141
142    if ($pid == 0) {
143        # child
144
145        sleep unless $awake;
146
147        my $s = tie(my $sv, 'IPC::Shareable', 'kids', { destroy => 0 });
148        $sv = 'baz';
149
150        is $sv, 'baz', "SV initialized and set to 'baz' ok";
151
152        IPC::Shareable->clean_up;
153
154        my $data = '';
155        my $id = $s->seg->id;
156
157        shmread($id, $data, 0, length('IPC::Shareable'));
158        is $data, 'IPC::Shareable', "Shared memory alive ok in child";
159
160        $s->clean_up;
161
162        is shm_cleaned($id), 0, "after clean_up(), all is well ok in child, we don't clean up what isn't ours";
163
164        shmread($id, $data, 0, length('IPC::Shareable'));
165        is $data, 'IPC::Shareable', "SV doesn't get wiped if in a different proc w/clean_up()";
166
167        exit;
168    }
169    else {
170        # parent
171
172        my $s = tie(my $sv, 'IPC::Shareable', 'kids', { create => 1, destroy => 0 });
173
174        kill ALRM => $pid;
175        my $id = $s->seg->id;
176        waitpid($pid, 0);
177
178        is shm_cleaned($id), 0, "ID $id was not cleaned up in the child";
179
180        is keys %{ $s->global_register }, 1, "Global register set before clean_up_all()";
181        is keys %{ $s->process_register }, 1, "Process register set before clean_up_all()";
182
183        IPC::Shareable->clean_up_all;
184
185        is keys %{ $s->global_register }, 0, "Global register cleaned with clean_up_all()";
186        is keys %{ $s->process_register }, 0, "Process register cleaned with clean_up_all()";
187    }
188}
189
190done_testing();
191