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
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
|
use strict;
use warnings;
use Test::More;
use Test::Warnings;
use ZMQ::FFI qw(ZMQ_REQ);
#
# Test that we guard against trying to clean up context/sockets
# created in a parent process in forked children
#
my $parent_c = ZMQ::FFI->new();
my $parent_s = $parent_c->socket(ZMQ_REQ);
my $parent_s_closed;
my $parent_c_destroyed;
my ($major, $minor) = $parent_c->version;
if ($major == 2) {
no warnings qw/redefine once/;
local *ZMQ::FFI::ZMQ2::Socket::zmq_close = sub {
$parent_s_closed = 1;
};
local *ZMQ::FFI::ZMQ2::Context::zmq_term = sub {
$parent_c_destroyed = 1;
};
use warnings;
pid_test();
}
elsif ($major == 3) {
no warnings qw/redefine once/;
local *ZMQ::FFI::ZMQ3::Socket::zmq_close = sub {
$parent_s_closed = 1;
};
local *ZMQ::FFI::ZMQ3::Context::zmq_ctx_destroy = sub {
$parent_c_destroyed = 1;
};
use warnings;
pid_test();
}
else {
if ($major == 4 and $minor == 0) {
no warnings qw/redefine once/;
local *ZMQ::FFI::ZMQ4::Socket::zmq_close = sub {
$parent_s_closed = 1;
};
local *ZMQ::FFI::ZMQ4::Context::zmq_ctx_term = sub {
$parent_c_destroyed = 1;
};
use warnings;
pid_test();
}
else {
no warnings qw/redefine once/;
local *ZMQ::FFI::ZMQ4_1::Socket::zmq_close = sub {
$parent_s_closed = 1;
};
local *ZMQ::FFI::ZMQ4_1::Context::zmq_ctx_term = sub {
$parent_c_destroyed = 1;
};
use warnings;
pid_test();
}
}
sub pid_test {
my $child_pid = open(FROM_CHILDTEST, '-|') // die "fork failed $!";
if ($child_pid) {
# parent process, do test assertions here
my $result;
read(FROM_CHILDTEST, $result, 128);
waitpid $child_pid, 0;
is $result, 'ok',
'child process skipped parent ctx/socket cleanup';
ok $parent_c->_pid == $$, "parent context pid _should_ match parent pid";
ok $parent_s->_pid == $$, "parent socket pid _should_ match parent pid";
# explicitly undef ctx/socket created in parent to trigger DEMOLISH/
# cleanup logic.. then verify that close/destroy _was_ called
# for ctx/socket created in parent
undef $parent_s;
undef $parent_c;
ok $parent_s_closed, "parent socket closed in parent";
ok $parent_c_destroyed, "parent context destroyed in parent";
}
else {
# check test expectataions and print 'ok' if successful
if ( $parent_c->_pid == $$ ) {
print "parent context pid _should not_ match child pid"; exit;
}
if ( $parent_s->_pid == $$ ) {
print "parent socket pid _should not_ match child pid"; exit;
}
# explicitly undef ctx/socket cloned from parent to trigger DEMOLISH/
# cleanup logic.. then verify that close/destroy _was not_ called
# for ctx/socket created in parent
undef $parent_s;
undef $parent_c;
if ( $parent_s_closed ) {
print "parent socket closed in child!"; exit;
}
if ( $parent_c_destroyed) {
print "parent context destroyed in child!"; exit;
}
print 'ok';
exit;
}
}
done_testing;
|
