line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# License and documentation are after __END__. |
2
|
|
|
|
|
|
|
# vim: ts=2 sw=2 expandtab |
3
|
|
|
|
|
|
|
|
4
|
|
|
|
|
|
|
package POE::Component::Client::Ping; |
5
|
|
|
|
|
|
|
|
6
|
6
|
|
|
6
|
|
660869
|
use warnings; |
|
6
|
|
|
|
|
47
|
|
|
6
|
|
|
|
|
257
|
|
7
|
6
|
|
|
6
|
|
37
|
use strict; |
|
6
|
|
|
|
|
15
|
|
|
6
|
|
|
|
|
127
|
|
8
|
|
|
|
|
|
|
|
9
|
6
|
|
|
6
|
|
29
|
use Exporter; |
|
6
|
|
|
|
|
14
|
|
|
6
|
|
|
|
|
271
|
|
10
|
6
|
|
|
6
|
|
37
|
use vars qw(@ISA @EXPORT_OK %EXPORT_TAGS); |
|
6
|
|
|
|
|
12
|
|
|
6
|
|
|
|
|
639
|
|
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
@ISA = qw(Exporter); |
13
|
|
|
|
|
|
|
@EXPORT_OK = qw( |
14
|
|
|
|
|
|
|
REQ_ADDRESS REQ_TIMEOUT REQ_TIME REQ_USER_ARGS |
15
|
|
|
|
|
|
|
RES_ADDRESS RES_ROUNDTRIP RES_TIME RES_TTL |
16
|
|
|
|
|
|
|
); |
17
|
|
|
|
|
|
|
%EXPORT_TAGS = ( |
18
|
|
|
|
|
|
|
const => [ |
19
|
|
|
|
|
|
|
qw( |
20
|
|
|
|
|
|
|
REQ_ADDRESS REQ_TIMEOUT REQ_TIME REQ_USER_ARGS |
21
|
|
|
|
|
|
|
RES_ADDRESS RES_ROUNDTRIP RES_TIME RES_TTL |
22
|
|
|
|
|
|
|
) |
23
|
|
|
|
|
|
|
] |
24
|
|
|
|
|
|
|
); |
25
|
|
|
|
|
|
|
|
26
|
6
|
|
|
6
|
|
44
|
use vars qw($VERSION $PKTSIZE); |
|
6
|
|
|
|
|
14
|
|
|
6
|
|
|
|
|
525
|
|
27
|
|
|
|
|
|
|
$VERSION = '1.177'; |
28
|
|
|
|
|
|
|
$PKTSIZE = $^O eq 'linux' ? 3_000 : 100; |
29
|
|
|
|
|
|
|
|
30
|
6
|
|
|
6
|
|
43
|
use Carp qw(croak); |
|
6
|
|
|
|
|
16
|
|
|
6
|
|
|
|
|
356
|
|
31
|
6
|
|
|
6
|
|
40
|
use Symbol qw(gensym); |
|
6
|
|
|
|
|
14
|
|
|
6
|
|
|
|
|
277
|
|
32
|
6
|
|
|
6
|
|
34
|
use Socket; |
|
6
|
|
|
|
|
13
|
|
|
6
|
|
|
|
|
3650
|
|
33
|
6
|
|
|
6
|
|
49
|
use Time::HiRes qw(time); |
|
6
|
|
|
|
|
13
|
|
|
6
|
|
|
|
|
54
|
|
34
|
|
|
|
|
|
|
|
35
|
6
|
|
|
6
|
|
1283
|
use POE::Session; |
|
6
|
|
|
|
|
22
|
|
|
6
|
|
|
|
|
40
|
|
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
sub DEBUG () { 0 } # Enable more information. |
38
|
|
|
|
|
|
|
sub DEBUG_SOCKET () { 0 } # Watch the socket open and close. |
39
|
|
|
|
|
|
|
sub DEBUG_PBS () { 0 } # Watch ping_by_seq management. |
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
# ping_by_seq structure offsets. |
42
|
|
|
|
|
|
|
|
43
|
|
|
|
|
|
|
sub PBS_POSTBACK () { 0 }; |
44
|
|
|
|
|
|
|
sub PBS_SESSION () { 1 }; |
45
|
|
|
|
|
|
|
sub PBS_ADDRESS () { 2 }; |
46
|
|
|
|
|
|
|
sub PBS_REQUEST_TIME () { 3 }; |
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
# request_packet offsets |
49
|
|
|
|
|
|
|
sub REQ_ADDRESS () { 0 }; |
50
|
|
|
|
|
|
|
sub REQ_TIMEOUT () { 1 }; |
51
|
|
|
|
|
|
|
sub REQ_TIME () { 2 }; |
52
|
|
|
|
|
|
|
sub REQ_USER_ARGS () { 3 }; |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
# response_packet offsets |
55
|
|
|
|
|
|
|
sub RES_ADDRESS () { 0 }; |
56
|
|
|
|
|
|
|
sub RES_ROUNDTRIP () { 1 }; |
57
|
|
|
|
|
|
|
sub RES_TIME () { 2 }; |
58
|
|
|
|
|
|
|
sub RES_TTL () { 3 }; |
59
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
# ICMP echo constants. Types, structures, and fields. Cribbed |
61
|
|
|
|
|
|
|
# mercilessly from Net::Ping. |
62
|
|
|
|
|
|
|
|
63
|
|
|
|
|
|
|
sub ICMP_ECHOREPLY () { 0 } |
64
|
|
|
|
|
|
|
sub ICMP_ECHO () { 8 } |
65
|
|
|
|
|
|
|
sub ICMP_STRUCT () { 'C2 S3 A' } |
66
|
|
|
|
|
|
|
sub ICMP_SUBCODE () { 0 } |
67
|
|
|
|
|
|
|
sub ICMP_FLAGS () { 0 } |
68
|
|
|
|
|
|
|
sub ICMP_PORT () { 0 } |
69
|
|
|
|
|
|
|
|
70
|
|
|
|
|
|
|
# "Static" variables which will be shared across multiple instances. |
71
|
|
|
|
|
|
|
|
72
|
|
|
|
|
|
|
my $master_seq = 0; |
73
|
|
|
|
|
|
|
|
74
|
|
|
|
|
|
|
# Spawn a new PoCo::Client::Ping session. This basically is a |
75
|
|
|
|
|
|
|
# constructor, but it isn't named "new" because it doesn't create a |
76
|
|
|
|
|
|
|
# usable object. Instead, it spawns the object off as a session. |
77
|
|
|
|
|
|
|
# Randal Schwartz gave me heck about calling spawny things "new", so I |
78
|
|
|
|
|
|
|
# blame him for this naming convention. |
79
|
|
|
|
|
|
|
|
80
|
|
|
|
|
|
|
sub spawn { |
81
|
5
|
|
|
5
|
0
|
539
|
my $type = shift; |
82
|
|
|
|
|
|
|
|
83
|
5
|
50
|
|
|
|
31
|
croak "$type requires an even number of parameters" if @_ % 2; |
84
|
5
|
|
|
|
|
29
|
my %params = @_; |
85
|
|
|
|
|
|
|
|
86
|
5
|
|
|
|
|
16
|
my $socket = delete $params{Socket}; |
87
|
5
|
50
|
66
|
|
|
31
|
croak "$type requires root privilege" unless ( |
88
|
|
|
|
|
|
|
defined $socket or can_open_socket() |
89
|
|
|
|
|
|
|
); |
90
|
|
|
|
|
|
|
|
91
|
5
|
|
|
|
|
22
|
my $alias = delete $params{Alias}; |
92
|
5
|
100
|
66
|
|
|
50
|
$alias = "pinger" unless defined $alias and length $alias; |
93
|
|
|
|
|
|
|
|
94
|
5
|
|
|
|
|
12
|
my $timeout = delete $params{Timeout}; |
95
|
5
|
100
|
66
|
|
|
28
|
$timeout = 1 unless defined $timeout and $timeout >= 0; |
96
|
|
|
|
|
|
|
|
97
|
5
|
|
|
|
|
14
|
my $onereply = delete $params{OneReply}; |
98
|
5
|
|
100
|
|
|
23
|
my $parallelism = delete $params{Parallelism} || -1; |
99
|
5
|
|
|
|
|
13
|
my $rcvbuf = delete $params{BufferSize}; |
100
|
5
|
|
|
|
|
12
|
my $always_decode = delete $params{AlwaysDecodeAddress}; |
101
|
5
|
|
|
|
|
12
|
my $retry = delete $params{Retry}; |
102
|
5
|
|
|
|
|
11
|
my $payload = delete $params{Payload}; |
103
|
|
|
|
|
|
|
|
104
|
|
|
|
|
|
|
# 56 data bytes :) |
105
|
5
|
50
|
|
|
|
21
|
$payload = 'Use POE!' x 7 unless defined $payload; |
106
|
|
|
|
|
|
|
|
107
|
5
|
50
|
|
|
|
22
|
croak( |
108
|
|
|
|
|
|
|
"$type doesn't know these parameters: ", join(', ', sort keys %params) |
109
|
|
|
|
|
|
|
) if scalar keys %params; |
110
|
|
|
|
|
|
|
|
111
|
5
|
|
100
|
|
|
161
|
POE::Session->create( |
|
|
|
100
|
|
|
|
|
112
|
|
|
|
|
|
|
inline_states => { |
113
|
|
|
|
|
|
|
_start => \&poco_ping_start, |
114
|
|
|
|
|
|
|
ping => \&poco_ping_ping, |
115
|
|
|
|
|
|
|
clear => \&poco_ping_clear, |
116
|
|
|
|
|
|
|
got_pong => \&poco_ping_pong, |
117
|
|
|
|
|
|
|
_default => \&poco_ping_default, |
118
|
|
|
|
|
|
|
}, |
119
|
|
|
|
|
|
|
heap => { |
120
|
|
|
|
|
|
|
alias => $alias, |
121
|
|
|
|
|
|
|
always_decode => $always_decode, |
122
|
|
|
|
|
|
|
data => $payload, |
123
|
|
|
|
|
|
|
data_size => length($payload), |
124
|
|
|
|
|
|
|
keep_socket => (defined $socket) || 0, |
125
|
|
|
|
|
|
|
onereply => $onereply, |
126
|
|
|
|
|
|
|
rcvbuf => $rcvbuf, |
127
|
|
|
|
|
|
|
retry => $retry || 0, |
128
|
|
|
|
|
|
|
socket_handle => $socket, |
129
|
|
|
|
|
|
|
timeout => $timeout, |
130
|
|
|
|
|
|
|
|
131
|
|
|
|
|
|
|
# Active query tracking. |
132
|
|
|
|
|
|
|
ping_by_seq => { }, # keyed on sequence number |
133
|
|
|
|
|
|
|
addr_to_seq => { }, # keyed on request address, then sender |
134
|
|
|
|
|
|
|
|
135
|
|
|
|
|
|
|
# Queue to manage throttling. |
136
|
|
|
|
|
|
|
parallelism => $parallelism, # how many pings can we send at once |
137
|
|
|
|
|
|
|
queue => [ ], # ordered list of throttled pings |
138
|
|
|
|
|
|
|
pending => { }, # data for the sequence ids of queued pings |
139
|
|
|
|
|
|
|
outstanding => 0, # How many pings are we awaiting replies for |
140
|
|
|
|
|
|
|
}, |
141
|
|
|
|
|
|
|
); |
142
|
|
|
|
|
|
|
|
143
|
5
|
|
|
|
|
1290
|
undef; |
144
|
|
|
|
|
|
|
} |
145
|
|
|
|
|
|
|
|
146
|
|
|
|
|
|
|
|
147
|
|
|
|
|
|
|
# Start the pinger session. |
148
|
|
|
|
|
|
|
|
149
|
|
|
|
|
|
|
sub poco_ping_start { |
150
|
5
|
|
|
5
|
0
|
1630
|
$_[KERNEL]->alias_set( $_[HEAP]->{alias} ); |
151
|
|
|
|
|
|
|
} |
152
|
|
|
|
|
|
|
|
153
|
|
|
|
|
|
|
|
154
|
|
|
|
|
|
|
# (NOT A POE EVENT HANDLER) |
155
|
|
|
|
|
|
|
# Test whether this process can open raw sockets. |
156
|
|
|
|
|
|
|
sub can_open_socket { |
157
|
9
|
|
|
9
|
0
|
574
|
my $socket = eval { _create_handle() }; |
|
9
|
|
|
|
|
29
|
|
158
|
9
|
50
|
33
|
|
|
138
|
return 0 if $@ or not $socket; |
159
|
9
|
|
|
|
|
251
|
return 1; |
160
|
|
|
|
|
|
|
} |
161
|
|
|
|
|
|
|
|
162
|
|
|
|
|
|
|
|
163
|
|
|
|
|
|
|
# (NOT A POE EVENT HANDLER) |
164
|
|
|
|
|
|
|
# Create a raw socket to send ICMP packets down. |
165
|
|
|
|
|
|
|
# (optionally) mess with the size of the buffers on the socket. |
166
|
|
|
|
|
|
|
|
167
|
|
|
|
|
|
|
sub _create_handle { |
168
|
13
|
|
|
13
|
|
25
|
DEBUG_SOCKET and warn "opening a raw socket for icmp"; |
169
|
|
|
|
|
|
|
|
170
|
13
|
|
|
|
|
22
|
my $protocol = Socket::IPPROTO_ICMP; |
171
|
|
|
|
|
|
|
|
172
|
13
|
|
|
|
|
53
|
my $socket = gensym(); |
173
|
13
|
50
|
|
|
|
832
|
socket($socket, PF_INET, SOCK_RAW, $protocol) |
174
|
|
|
|
|
|
|
or die "can't create icmp socket: $!"; |
175
|
|
|
|
|
|
|
|
176
|
13
|
|
|
|
|
64
|
return $socket; |
177
|
|
|
|
|
|
|
} |
178
|
|
|
|
|
|
|
|
179
|
|
|
|
|
|
|
### NOT A POE EVENT HANDLER |
180
|
|
|
|
|
|
|
|
181
|
|
|
|
|
|
|
sub _setup_handle { |
182
|
9
|
|
|
9
|
|
29
|
my ($kernel, $heap) = @_; |
183
|
|
|
|
|
|
|
|
184
|
9
|
100
|
|
|
|
39
|
if ($heap->{rcvbuf}) { |
185
|
5
|
50
|
|
|
|
137
|
unless ( |
186
|
|
|
|
|
|
|
setsockopt( |
187
|
|
|
|
|
|
|
$heap->{socket_handle}, SOL_SOCKET, |
188
|
|
|
|
|
|
|
SO_RCVBUF, pack("I", $heap->{rcvbuf}) |
189
|
|
|
|
|
|
|
) |
190
|
|
|
|
|
|
|
) { |
191
|
0
|
|
|
|
|
0
|
warn("setsockopt rcvbuf size ($heap->{rcvbuf}) failed: $!"); |
192
|
|
|
|
|
|
|
} |
193
|
|
|
|
|
|
|
} |
194
|
|
|
|
|
|
|
|
195
|
9
|
100
|
66
|
|
|
127
|
if ($heap->{parallelism} && $heap->{parallelism} == -1) { |
196
|
3
|
|
|
|
|
52
|
my $rcvbuf = getsockopt($heap->{socket_handle}, SOL_SOCKET, SO_RCVBUF); |
197
|
3
|
50
|
|
|
|
14
|
if ($rcvbuf) { |
198
|
3
|
|
|
|
|
27
|
my $size = unpack("I", $rcvbuf); |
199
|
3
|
|
|
|
|
23
|
my $max_parallel = int($size / $PKTSIZE); |
200
|
3
|
50
|
|
|
|
14
|
if ($max_parallel > 8) { |
|
|
0
|
|
|
|
|
|
201
|
3
|
|
|
|
|
8
|
$max_parallel -= 8; |
202
|
|
|
|
|
|
|
} |
203
|
|
|
|
|
|
|
elsif ($max_parallel < 1) { |
204
|
0
|
|
|
|
|
0
|
$max_parallel = 1; |
205
|
|
|
|
|
|
|
} |
206
|
3
|
|
|
|
|
10
|
$heap->{parallelism} = $max_parallel; |
207
|
|
|
|
|
|
|
} |
208
|
|
|
|
|
|
|
} |
209
|
|
|
|
|
|
|
|
210
|
9
|
|
|
|
|
71
|
$kernel->select_read($heap->{socket_handle}, 'got_pong'); |
211
|
|
|
|
|
|
|
} |
212
|
|
|
|
|
|
|
|
213
|
|
|
|
|
|
|
# Request a ping. This code borrows heavily from Net::Ping. |
214
|
|
|
|
|
|
|
|
215
|
|
|
|
|
|
|
sub poco_ping_ping { |
216
|
|
|
|
|
|
|
my ( |
217
|
51
|
|
|
51
|
0
|
15449
|
$kernel, $heap, $sender, |
218
|
|
|
|
|
|
|
$event, $address, $timeout, $tries_left |
219
|
|
|
|
|
|
|
) = @_[ |
220
|
|
|
|
|
|
|
KERNEL, HEAP, SENDER, |
221
|
|
|
|
|
|
|
ARG0, ARG1, ARG2, ARG3 |
222
|
|
|
|
|
|
|
]; |
223
|
|
|
|
|
|
|
|
224
|
51
|
|
66
|
|
|
264
|
$tries_left ||= $heap->{retry}; |
225
|
|
|
|
|
|
|
|
226
|
51
|
|
|
|
|
77
|
DEBUG and warn "ping requested for $address ($tries_left try/tries left)\n"; |
227
|
|
|
|
|
|
|
|
228
|
51
|
|
|
|
|
136
|
_do_ping($kernel, $heap, $sender, $event, $address, $timeout, $tries_left); |
229
|
|
|
|
|
|
|
} |
230
|
|
|
|
|
|
|
|
231
|
|
|
|
|
|
|
|
232
|
|
|
|
|
|
|
sub _do_ping { |
233
|
55
|
|
|
55
|
|
138
|
my ($kernel, $heap, $sender, $event, $address, $timeout, $tries_left) = @_; |
234
|
|
|
|
|
|
|
|
235
|
|
|
|
|
|
|
# No current pings. Open a socket, or setup the existing one. |
236
|
55
|
100
|
|
|
|
96
|
unless (scalar(keys %{$heap->{ping_by_seq}})) { |
|
55
|
|
|
|
|
181
|
|
237
|
9
|
100
|
|
|
|
35
|
unless (defined $heap->{socket_handle}) { |
238
|
4
|
|
|
|
|
14
|
$heap->{socket_handle} = _create_handle(); |
239
|
|
|
|
|
|
|
} |
240
|
9
|
|
|
|
|
40
|
_setup_handle($kernel, $heap); |
241
|
|
|
|
|
|
|
} |
242
|
|
|
|
|
|
|
|
243
|
|
|
|
|
|
|
# Get the timeout, or default to the one set for the component. |
244
|
55
|
100
|
66
|
|
|
1284
|
$timeout = $heap->{timeout} unless defined $timeout and $timeout > 0; |
245
|
55
|
50
|
|
|
|
139
|
$tries_left = $heap->{retry} unless defined $tries_left; |
246
|
|
|
|
|
|
|
|
247
|
|
|
|
|
|
|
# Find an unused sequence number. |
248
|
55
|
|
|
|
|
88
|
while (1) { |
249
|
55
|
|
|
|
|
105
|
$master_seq = ($master_seq + 1) & 0xFFFF; |
250
|
55
|
50
|
|
|
|
158
|
last unless exists $heap->{ping_by_seq}->{$master_seq}; |
251
|
|
|
|
|
|
|
} |
252
|
|
|
|
|
|
|
|
253
|
55
|
|
|
|
|
114
|
my $checksum = 0; |
254
|
|
|
|
|
|
|
|
255
|
|
|
|
|
|
|
# Build the message without a checksum. |
256
|
|
|
|
|
|
|
my $msg = pack( |
257
|
|
|
|
|
|
|
ICMP_STRUCT . $heap->{data_size}, |
258
|
|
|
|
|
|
|
ICMP_ECHO, ICMP_SUBCODE, |
259
|
|
|
|
|
|
|
$checksum, ($$ & 0xFFFF), $master_seq, $heap->{data} |
260
|
55
|
|
|
|
|
360
|
); |
261
|
|
|
|
|
|
|
|
262
|
|
|
|
|
|
|
### Begin checksum calculation section. |
263
|
|
|
|
|
|
|
|
264
|
|
|
|
|
|
|
# Sum up short integers in the packet. |
265
|
55
|
|
|
|
|
159
|
my $shorts = int(length($msg) / 2); |
266
|
55
|
|
|
|
|
285
|
foreach my $short (unpack "S$shorts", $msg) { |
267
|
1760
|
|
|
|
|
2442
|
$checksum += $short; |
268
|
|
|
|
|
|
|
} |
269
|
|
|
|
|
|
|
|
270
|
|
|
|
|
|
|
# If there's an odd byte, add that in as well. |
271
|
55
|
50
|
|
|
|
190
|
$checksum += ord(substr($msg, -1)) if length($msg) % 2; |
272
|
|
|
|
|
|
|
|
273
|
|
|
|
|
|
|
# Fold the high short into the low one twice, and then complement. |
274
|
55
|
|
|
|
|
105
|
$checksum = ($checksum >> 16) + ($checksum & 0xFFFF); |
275
|
55
|
|
|
|
|
109
|
$checksum = ~( ($checksum >> 16) + $checksum) & 0xFFFF; |
276
|
|
|
|
|
|
|
|
277
|
|
|
|
|
|
|
### Cease checksum calculation section. |
278
|
|
|
|
|
|
|
|
279
|
|
|
|
|
|
|
# Rebuild the message with the checksum this time. |
280
|
|
|
|
|
|
|
$msg = pack( |
281
|
|
|
|
|
|
|
ICMP_STRUCT . $heap->{data_size}, |
282
|
|
|
|
|
|
|
ICMP_ECHO, ICMP_SUBCODE, $checksum, ($$ & 0xFFFF), $master_seq, |
283
|
|
|
|
|
|
|
$heap->{data} |
284
|
55
|
|
|
|
|
192
|
); |
285
|
|
|
|
|
|
|
|
286
|
|
|
|
|
|
|
# Record information about the ping request. |
287
|
|
|
|
|
|
|
|
288
|
55
|
|
|
|
|
100
|
my ($event_name, @user_args); |
289
|
55
|
100
|
|
|
|
180
|
if (ref($event) eq "ARRAY") { |
290
|
1
|
|
|
|
|
4
|
($event_name, @user_args) = @$event; |
291
|
|
|
|
|
|
|
} |
292
|
|
|
|
|
|
|
else { |
293
|
54
|
|
|
|
|
93
|
$event_name = $event; |
294
|
|
|
|
|
|
|
} |
295
|
|
|
|
|
|
|
|
296
|
|
|
|
|
|
|
# Build an address to send the ping at. |
297
|
|
|
|
|
|
|
# TODO - This blocks, so resolve them first. |
298
|
|
|
|
|
|
|
# TODO - This assumes four-octet addresses are IPv4. |
299
|
|
|
|
|
|
|
|
300
|
55
|
|
|
|
|
100
|
my $usable_address = $address; |
301
|
55
|
50
|
33
|
|
|
218
|
if ($heap->{always_decode} || length($address) != 4) { |
302
|
55
|
|
|
|
|
25862
|
$usable_address = inet_aton($address); |
303
|
|
|
|
|
|
|
} |
304
|
|
|
|
|
|
|
|
305
|
|
|
|
|
|
|
# Return failure if an address was not resolvable. This simulates |
306
|
|
|
|
|
|
|
# the postback behavior. |
307
|
|
|
|
|
|
|
|
308
|
55
|
50
|
|
|
|
149
|
unless (defined $usable_address) { |
309
|
0
|
|
|
|
|
0
|
$kernel->post( |
310
|
|
|
|
|
|
|
$sender, $event_name, |
311
|
|
|
|
|
|
|
[ |
312
|
|
|
|
|
|
|
$address, # REQ_ADDRESS |
313
|
|
|
|
|
|
|
$timeout, # REQ_TIMEOUT |
314
|
|
|
|
|
|
|
time(), # REQ_TIME |
315
|
|
|
|
|
|
|
@user_args, # REQ_USER_ARGS |
316
|
|
|
|
|
|
|
], |
317
|
|
|
|
|
|
|
[ |
318
|
|
|
|
|
|
|
undef, # RES_ADDRESS |
319
|
|
|
|
|
|
|
undef, # RES_ROUNDTRIP |
320
|
|
|
|
|
|
|
time(), # RES_TIME |
321
|
|
|
|
|
|
|
undef, # RES_TTL |
322
|
|
|
|
|
|
|
], |
323
|
|
|
|
|
|
|
); |
324
|
0
|
|
|
|
|
0
|
_check_for_close($kernel, $heap); |
325
|
0
|
|
|
|
|
0
|
return; |
326
|
|
|
|
|
|
|
} |
327
|
|
|
|
|
|
|
|
328
|
55
|
|
|
|
|
179
|
my $socket_address = pack_sockaddr_in(ICMP_PORT, $usable_address); |
329
|
|
|
|
|
|
|
|
330
|
55
|
|
|
|
|
105
|
push(@{$heap->{queue}}, $master_seq); |
|
55
|
|
|
|
|
152
|
|
331
|
55
|
|
|
|
|
200
|
$heap->{pending}->{$master_seq} = [ |
332
|
|
|
|
|
|
|
$msg, # PEND_MSG |
333
|
|
|
|
|
|
|
$socket_address, # PEND_ADDR |
334
|
|
|
|
|
|
|
$sender, # PEND_SENDER |
335
|
|
|
|
|
|
|
$event, # PEND_EVENT |
336
|
|
|
|
|
|
|
$address, # PEND_ADDR ??? |
337
|
|
|
|
|
|
|
$timeout, # PEND_TIMEOUT |
338
|
|
|
|
|
|
|
]; |
339
|
|
|
|
|
|
|
|
340
|
55
|
100
|
100
|
|
|
167
|
if ($tries_left and $tries_left > 1) { |
341
|
4
|
|
|
|
|
14
|
$heap->{retrydata}->{$master_seq} = [ |
342
|
|
|
|
|
|
|
$sender, # RD_SENDER |
343
|
|
|
|
|
|
|
$event, # RD_EVENT |
344
|
|
|
|
|
|
|
$address, # RD_ADDRESS |
345
|
|
|
|
|
|
|
$timeout, # RD_TIMEOUT |
346
|
|
|
|
|
|
|
$tries_left, # RD_RETRY |
347
|
|
|
|
|
|
|
]; |
348
|
|
|
|
|
|
|
} |
349
|
|
|
|
|
|
|
|
350
|
55
|
|
|
|
|
133
|
_send_next_packet($kernel, $heap); |
351
|
|
|
|
|
|
|
} |
352
|
|
|
|
|
|
|
|
353
|
|
|
|
|
|
|
|
354
|
|
|
|
|
|
|
sub _send_next_packet { |
355
|
102
|
|
|
102
|
|
261
|
my ($kernel, $heap) = @_; |
356
|
102
|
100
|
|
|
|
151
|
return unless (scalar @{$heap->{queue}}); |
|
102
|
|
|
|
|
281
|
|
357
|
|
|
|
|
|
|
|
358
|
55
|
50
|
33
|
|
|
235
|
if ($heap->{parallelism} && $heap->{outstanding} >= $heap->{parallelism}) { |
359
|
|
|
|
|
|
|
# We want to throttle back since we're still waiting for pings |
360
|
|
|
|
|
|
|
# so, let's just leave this till later |
361
|
|
|
|
|
|
|
DEBUG and warn( |
362
|
|
|
|
|
|
|
"throttled since there are $heap->{outstanding} pings outstanding. " . |
363
|
0
|
|
|
|
|
0
|
"queue size=" . (scalar @{$heap->{queue}}) . "\n" |
364
|
|
|
|
|
|
|
); |
365
|
0
|
|
|
|
|
0
|
return; |
366
|
|
|
|
|
|
|
} |
367
|
|
|
|
|
|
|
|
368
|
55
|
|
|
|
|
89
|
my $seq = shift(@{$heap->{queue}}); |
|
55
|
|
|
|
|
125
|
|
369
|
|
|
|
|
|
|
|
370
|
|
|
|
|
|
|
# May have been cleared by caller |
371
|
55
|
50
|
|
|
|
137
|
return unless (exists $heap->{pending}->{$seq}); |
372
|
|
|
|
|
|
|
|
373
|
55
|
|
|
|
|
125
|
my $ping_info = delete $heap->{pending}->{$seq}; |
374
|
|
|
|
|
|
|
my ( |
375
|
55
|
|
|
|
|
132
|
$msg, # PEND_MSG |
376
|
|
|
|
|
|
|
$socket_address, # PEND_ADDR |
377
|
|
|
|
|
|
|
$sender, # PEND_SENDER |
378
|
|
|
|
|
|
|
$event, # PEND_EVENT |
379
|
|
|
|
|
|
|
$address, # PEND_ADDR ??? |
380
|
|
|
|
|
|
|
$timeout, # PEND_TIMEOUT |
381
|
|
|
|
|
|
|
) = @$ping_info; |
382
|
|
|
|
|
|
|
|
383
|
|
|
|
|
|
|
# Send the packet. If send() fails, then we bail with an error. |
384
|
55
|
|
|
|
|
111
|
my @user_args = (); |
385
|
55
|
100
|
|
|
|
155
|
($event, @user_args) = @$event if ref($event) eq "ARRAY"; |
386
|
|
|
|
|
|
|
|
387
|
55
|
|
|
|
|
78
|
DEBUG and warn "sending packet sequence number $seq\n"; |
388
|
55
|
50
|
|
|
|
3991
|
unless (send($heap->{socket_handle}, $msg, ICMP_FLAGS, $socket_address)) { |
389
|
0
|
|
|
|
|
0
|
$kernel->post( |
390
|
|
|
|
|
|
|
$sender, $event, |
391
|
|
|
|
|
|
|
[ $address, # REQ_ADDRESS |
392
|
|
|
|
|
|
|
$timeout, # REQ_TIMEOUT |
393
|
|
|
|
|
|
|
time(), # REQ_TIME |
394
|
|
|
|
|
|
|
@user_args, # REQ_USER_ARGS |
395
|
|
|
|
|
|
|
], |
396
|
|
|
|
|
|
|
[ undef, # RES_ADDRESS |
397
|
|
|
|
|
|
|
undef, # RES_ROUNDTRIP |
398
|
|
|
|
|
|
|
time(), # RES_TIME |
399
|
|
|
|
|
|
|
undef, # RES_TTL |
400
|
|
|
|
|
|
|
], |
401
|
|
|
|
|
|
|
); |
402
|
0
|
|
|
|
|
0
|
_check_for_close($kernel, $heap); |
403
|
0
|
|
|
|
|
0
|
return; |
404
|
|
|
|
|
|
|
} |
405
|
|
|
|
|
|
|
|
406
|
|
|
|
|
|
|
# Record the message's length. This is constant, but we do it here |
407
|
|
|
|
|
|
|
# anyway. It's also used to flag when we start requesting replies. |
408
|
55
|
|
|
|
|
282
|
$heap->{message_length} = length($msg); |
409
|
55
|
|
|
|
|
106
|
$heap->{outstanding}++; |
410
|
|
|
|
|
|
|
|
411
|
|
|
|
|
|
|
# Set a timeout based on the sequence number. |
412
|
55
|
|
|
|
|
300
|
$kernel->delay( $seq => $timeout ); |
413
|
|
|
|
|
|
|
|
414
|
55
|
|
|
|
|
11451
|
DEBUG_PBS and warn "recording ping_by_seq($seq)"; |
415
|
55
|
|
|
|
|
239
|
$heap->{ping_by_seq}->{$seq} = [ |
416
|
|
|
|
|
|
|
# PBS_POSTBACK |
417
|
|
|
|
|
|
|
$sender->postback( |
418
|
|
|
|
|
|
|
$event, |
419
|
|
|
|
|
|
|
$address, # REQ_ADDRESS |
420
|
|
|
|
|
|
|
$timeout, # REQ_TIMEOUT |
421
|
|
|
|
|
|
|
time(), # REQ_TIME |
422
|
|
|
|
|
|
|
@user_args, # REQ_USER_ARGS |
423
|
|
|
|
|
|
|
), |
424
|
|
|
|
|
|
|
"$sender", # PBS_SESSION (stringified to weaken reference) |
425
|
|
|
|
|
|
|
$address, # PBS_ADDRESS |
426
|
|
|
|
|
|
|
time() # PBS_REQUEST_TIME |
427
|
|
|
|
|
|
|
]; |
428
|
|
|
|
|
|
|
|
429
|
|
|
|
|
|
|
# Duplicate pings? Forcibly time out the previous one. |
430
|
55
|
100
|
|
|
|
4358
|
if (exists $heap->{addr_to_seq}->{$sender}->{$address}) { |
431
|
4
|
|
|
|
|
8
|
DEBUG and warn "Duplicate ping. Canceling $address"; |
432
|
|
|
|
|
|
|
|
433
|
4
|
|
|
|
|
17
|
my $now = time(); |
434
|
4
|
|
|
|
|
12
|
my $ping_info = _end_ping_by_requester_and_address( |
435
|
|
|
|
|
|
|
$kernel, $heap, $sender, $address |
436
|
|
|
|
|
|
|
); |
437
|
|
|
|
|
|
|
|
438
|
4
|
|
|
|
|
12
|
$ping_info->[PBS_POSTBACK]->( undef, undef, $now, undef ); |
439
|
|
|
|
|
|
|
} |
440
|
|
|
|
|
|
|
|
441
|
55
|
|
|
|
|
1007
|
$heap->{addr_to_seq}->{$sender}->{$address} = $seq; |
442
|
|
|
|
|
|
|
} |
443
|
|
|
|
|
|
|
|
444
|
|
|
|
|
|
|
# Clear a ping postback by address. The sender+address pair are a |
445
|
|
|
|
|
|
|
# unique ID into the pinger's data. |
446
|
|
|
|
|
|
|
|
447
|
|
|
|
|
|
|
sub poco_ping_clear { |
448
|
0
|
|
|
0
|
0
|
0
|
my ($kernel, $heap, $sender, $address) = @_[KERNEL, HEAP, SENDER, ARG0]; |
449
|
|
|
|
|
|
|
|
450
|
|
|
|
|
|
|
# Is the sender still waiting for anything? |
451
|
0
|
0
|
|
|
|
0
|
return unless exists $heap->{addr_to_seq}->{$sender}; |
452
|
|
|
|
|
|
|
|
453
|
|
|
|
|
|
|
# Try to clear a single ping if an address was specified. |
454
|
0
|
0
|
|
|
|
0
|
if (defined $address) { |
455
|
0
|
|
|
|
|
0
|
_end_ping_by_requester_and_address($kernel, $heap, $sender, $address); |
456
|
|
|
|
|
|
|
} |
457
|
|
|
|
|
|
|
|
458
|
|
|
|
|
|
|
# No address was specified. Clear all the pings for this session. |
459
|
|
|
|
|
|
|
else { |
460
|
0
|
|
|
|
|
0
|
_end_pings_by_requester($kernel, $heap, $sender); |
461
|
|
|
|
|
|
|
} |
462
|
|
|
|
|
|
|
|
463
|
0
|
|
|
|
|
0
|
_check_for_close($kernel, $heap); |
464
|
|
|
|
|
|
|
} |
465
|
|
|
|
|
|
|
|
466
|
|
|
|
|
|
|
# (NOT A POE EVENT HANDLER) |
467
|
|
|
|
|
|
|
# Check to see if no more pings are waiting. Close the socket if so. |
468
|
|
|
|
|
|
|
|
469
|
|
|
|
|
|
|
sub _check_for_close { |
470
|
47
|
|
|
47
|
|
116
|
my ($kernel, $heap) = @_; |
471
|
|
|
|
|
|
|
|
472
|
47
|
50
|
|
|
|
182
|
return unless exists $heap->{socket_handle}; |
473
|
|
|
|
|
|
|
|
474
|
47
|
100
|
|
|
|
76
|
return if scalar keys %{$heap->{ping_by_seq}}; |
|
47
|
|
|
|
|
239
|
|
475
|
|
|
|
|
|
|
|
476
|
5
|
|
|
|
|
13
|
DEBUG_SOCKET and warn "stopping raw socket watcher"; |
477
|
5
|
|
|
|
|
49
|
$kernel->select_read( $heap->{socket_handle} ); |
478
|
|
|
|
|
|
|
|
479
|
5
|
100
|
|
|
|
1001
|
return if $heap->{keep_socket}; |
480
|
|
|
|
|
|
|
|
481
|
4
|
|
|
|
|
10
|
DEBUG_SOCKET and warn "closing raw socket"; |
482
|
4
|
|
|
|
|
130
|
delete $heap->{socket_handle}; |
483
|
|
|
|
|
|
|
} |
484
|
|
|
|
|
|
|
|
485
|
|
|
|
|
|
|
# (NOT A POE EVENT HANDLER) |
486
|
|
|
|
|
|
|
# Clean up after we're done with a ping. |
487
|
|
|
|
|
|
|
# Remove it from all tracking hashes. |
488
|
|
|
|
|
|
|
# Determine if the socket should be unthrottled or shut down. |
489
|
|
|
|
|
|
|
|
490
|
|
|
|
|
|
|
sub _end_ping_by_sequence { |
491
|
51
|
|
|
51
|
|
142
|
my ($kernel, $heap, $seq) = @_; |
492
|
|
|
|
|
|
|
|
493
|
|
|
|
|
|
|
# Delete the ping information. Cache a copy for other cleanup. |
494
|
51
|
|
|
|
|
111
|
DEBUG_PBS and warn "removing ping by sequence ($seq)"; |
495
|
51
|
|
|
|
|
137
|
my $ping_info = delete $heap->{ping_by_seq}->{$seq}; |
496
|
51
|
50
|
|
|
|
124
|
return unless $ping_info; |
497
|
|
|
|
|
|
|
|
498
|
|
|
|
|
|
|
# Stop its associated timeout. |
499
|
51
|
|
|
|
|
180
|
$kernel->delay($seq); |
500
|
|
|
|
|
|
|
|
501
|
|
|
|
|
|
|
# Stop mapping the session+address to this sequence number. |
502
|
51
|
|
|
|
|
8087
|
my $pbs_session = $ping_info->[PBS_SESSION]; |
503
|
51
|
|
|
|
|
209
|
delete $heap->{addr_to_seq}->{$pbs_session}->{$ping_info->[PBS_ADDRESS]}; |
504
|
|
|
|
|
|
|
|
505
|
|
|
|
|
|
|
# Stop tracking the session if that was its last address. |
506
|
|
|
|
|
|
|
delete $heap->{addr_to_seq}->{$pbs_session} unless ( |
507
|
51
|
100
|
|
|
|
142
|
scalar(keys %{$heap->{addr_to_seq}->{$pbs_session}}) |
|
51
|
|
|
|
|
245
|
|
508
|
|
|
|
|
|
|
); |
509
|
|
|
|
|
|
|
|
510
|
51
|
|
|
|
|
121
|
$heap->{outstanding}--; |
511
|
|
|
|
|
|
|
|
512
|
51
|
|
|
|
|
180
|
return $ping_info; |
513
|
|
|
|
|
|
|
} |
514
|
|
|
|
|
|
|
|
515
|
|
|
|
|
|
|
|
516
|
|
|
|
|
|
|
sub _end_ping_by_requester_and_address { |
517
|
4
|
|
|
4
|
|
10
|
my ($kernel, $heap, $sender, $address) = @_; |
518
|
|
|
|
|
|
|
|
519
|
4
|
50
|
|
|
|
13
|
return unless exists $heap->{addr_to_seq}->{$sender}; |
520
|
4
|
|
|
|
|
7
|
my $addr_to_seq_rec = $heap->{addr_to_seq}->{$sender}; |
521
|
|
|
|
|
|
|
|
522
|
4
|
|
|
|
|
11
|
my $seq = delete $addr_to_seq_rec->{$address}; |
523
|
4
|
50
|
|
|
|
9
|
unless ($seq) { |
524
|
|
|
|
|
|
|
# TODO - Why? |
525
|
0
|
|
|
|
|
0
|
delete $heap->{pending}->{$sender}->{$address}; |
526
|
0
|
|
|
|
|
0
|
return; |
527
|
|
|
|
|
|
|
} |
528
|
|
|
|
|
|
|
|
529
|
|
|
|
|
|
|
# Stop tracking the sender if that was the last address. |
530
|
|
|
|
|
|
|
delete $heap->{addr_to_seq}->{$sender} unless scalar( |
531
|
4
|
50
|
|
|
|
7
|
keys %{$heap->{addr_to_seq}->{$sender}} |
|
4
|
|
|
|
|
19
|
|
532
|
|
|
|
|
|
|
); |
533
|
|
|
|
|
|
|
|
534
|
|
|
|
|
|
|
# Discard the postback for the discarded sequence number. |
535
|
4
|
|
|
|
|
8
|
DEBUG_PBS and warn "removing ping_by_seq($seq)"; |
536
|
4
|
|
|
|
|
8
|
my $ping_info = delete $heap->{ping_by_seq}->{$seq}; |
537
|
4
|
|
|
|
|
13
|
$kernel->delay($seq); |
538
|
|
|
|
|
|
|
|
539
|
4
|
|
|
|
|
407
|
$heap->{outstanding}--; |
540
|
|
|
|
|
|
|
|
541
|
4
|
|
|
|
|
12
|
return $ping_info; |
542
|
|
|
|
|
|
|
} |
543
|
|
|
|
|
|
|
|
544
|
|
|
|
|
|
|
|
545
|
|
|
|
|
|
|
sub _end_pings_by_requester { |
546
|
0
|
|
|
0
|
|
0
|
my ($kernel, $heap, $sender) = @_; |
547
|
|
|
|
|
|
|
|
548
|
0
|
0
|
|
|
|
0
|
return unless exists $heap->{addr_to_seq}->{$sender}; |
549
|
0
|
|
|
|
|
0
|
my $addr_to_seq_rec = delete $heap->{addr_to_seq}->{$sender}; |
550
|
|
|
|
|
|
|
|
551
|
|
|
|
|
|
|
# Discard cross references. |
552
|
|
|
|
|
|
|
|
553
|
0
|
|
|
|
|
0
|
foreach my $seq (values %$addr_to_seq_rec) { |
554
|
0
|
|
|
|
|
0
|
DEBUG_PBS and warn "removing ping_by_seq($seq)"; |
555
|
0
|
|
|
|
|
0
|
delete $heap->{ping_by_seq}->{$seq}; |
556
|
0
|
|
|
|
|
0
|
$kernel->delay($seq); |
557
|
|
|
|
|
|
|
|
558
|
0
|
|
|
|
|
0
|
$heap->{outstanding}--; |
559
|
|
|
|
|
|
|
} |
560
|
|
|
|
|
|
|
|
561
|
0
|
|
|
|
|
0
|
return; |
562
|
|
|
|
|
|
|
} |
563
|
|
|
|
|
|
|
|
564
|
|
|
|
|
|
|
|
565
|
|
|
|
|
|
|
|
566
|
|
|
|
|
|
|
# Something has arrived. Try to match it against something being |
567
|
|
|
|
|
|
|
# waited for. |
568
|
|
|
|
|
|
|
|
569
|
|
|
|
|
|
|
sub poco_ping_pong { |
570
|
29
|
|
|
29
|
0
|
112331
|
my ($kernel, $heap, $socket) = @_[KERNEL, HEAP, ARG0]; |
571
|
|
|
|
|
|
|
|
572
|
|
|
|
|
|
|
# Record the receive time for possible use later. |
573
|
29
|
|
|
|
|
84
|
my $now = time(); |
574
|
|
|
|
|
|
|
|
575
|
|
|
|
|
|
|
# Receive a message on the ICMP port. |
576
|
29
|
|
|
|
|
72
|
my $recv_message = ''; |
577
|
29
|
|
|
|
|
416
|
my $from_saddr = recv($socket, $recv_message, 1500, ICMP_FLAGS); |
578
|
29
|
50
|
|
|
|
125
|
return unless $from_saddr; |
579
|
|
|
|
|
|
|
|
580
|
|
|
|
|
|
|
# We haven't yet sent a message, so don't bother with whatever we've |
581
|
|
|
|
|
|
|
# received. |
582
|
29
|
50
|
|
|
|
92
|
return unless defined $heap->{message_length}; |
583
|
|
|
|
|
|
|
|
584
|
|
|
|
|
|
|
# Unpack the packet's sender address. |
585
|
29
|
|
|
|
|
160
|
my ($from_port, $from_ip) = unpack_sockaddr_in($from_saddr); |
586
|
|
|
|
|
|
|
|
587
|
|
|
|
|
|
|
# Get the response packet's time to live. |
588
|
29
|
|
|
|
|
118
|
my ($ihl, $from_ttl) = unpack('C1@7C1', $recv_message); |
589
|
29
|
|
|
|
|
61
|
$ihl &= 0x0F; |
590
|
|
|
|
|
|
|
|
591
|
|
|
|
|
|
|
# Unpack the packet itself. |
592
|
|
|
|
|
|
|
my ( |
593
|
|
|
|
|
|
|
$from_type, $from_subcode, |
594
|
|
|
|
|
|
|
$from_checksum, $from_pid, $from_seq, $from_message |
595
|
|
|
|
|
|
|
) = unpack( |
596
|
29
|
|
|
|
|
177
|
'@'.$ihl*4 . ICMP_STRUCT.$heap->{data_size}, $recv_message |
597
|
|
|
|
|
|
|
); |
598
|
|
|
|
|
|
|
|
599
|
29
|
|
|
|
|
79
|
DEBUG and do { |
600
|
|
|
|
|
|
|
warn ",----- packet from ", inet_ntoa($from_ip), ", port $from_port\n"; |
601
|
|
|
|
|
|
|
warn "| type = $from_type / subtype = $from_subcode\n"; |
602
|
|
|
|
|
|
|
warn "| checksum = $from_checksum, pid = $from_pid, seq = $from_seq\n"; |
603
|
|
|
|
|
|
|
warn "| message: ", unpack("H*", $from_message), "\n"; |
604
|
|
|
|
|
|
|
warn "`------------------------------------------------------------\n"; |
605
|
|
|
|
|
|
|
}; |
606
|
|
|
|
|
|
|
|
607
|
|
|
|
|
|
|
# Not an ICMP echo reply. Move along. |
608
|
29
|
100
|
|
|
|
144
|
return unless $from_type == ICMP_ECHOREPLY; |
609
|
|
|
|
|
|
|
|
610
|
15
|
|
|
|
|
40
|
DEBUG and warn "it's an ICMP echo reply"; |
611
|
|
|
|
|
|
|
|
612
|
|
|
|
|
|
|
# Not from this process. Move along. |
613
|
15
|
50
|
|
|
|
81
|
return unless $from_pid == ($$ & 0xFFFF); |
614
|
|
|
|
|
|
|
|
615
|
15
|
|
|
|
|
29
|
DEBUG and warn "it's from the current process"; |
616
|
|
|
|
|
|
|
|
617
|
|
|
|
|
|
|
# Not waiting for a response with that sequence number. Move along. |
618
|
15
|
100
|
|
|
|
61
|
return unless exists $heap->{ping_by_seq}->{$from_seq}; |
619
|
|
|
|
|
|
|
|
620
|
11
|
|
|
|
|
22
|
DEBUG and warn "it's one we're waiting for ($from_seq)"; |
621
|
|
|
|
|
|
|
|
622
|
|
|
|
|
|
|
# This is the response we're looking for. Calculate the round trip |
623
|
|
|
|
|
|
|
# time, and map it to a postback. |
624
|
11
|
|
|
|
|
39
|
my $trip_time = $now - $heap->{ping_by_seq}->{$from_seq}->[PBS_REQUEST_TIME]; |
625
|
11
|
|
|
|
|
140
|
$heap->{ping_by_seq}->{$from_seq}->[PBS_POSTBACK]->( |
626
|
|
|
|
|
|
|
inet_ntoa($from_ip), $trip_time, $now, $from_ttl |
627
|
|
|
|
|
|
|
); |
628
|
|
|
|
|
|
|
|
629
|
|
|
|
|
|
|
# It's a single-reply ping. Clean up after it. |
630
|
11
|
100
|
|
|
|
1762
|
if ($heap->{onereply}) { |
631
|
2
|
|
|
|
|
19
|
_end_ping_by_sequence($kernel, $heap, $from_seq); |
632
|
2
|
|
|
|
|
224
|
_send_next_packet($kernel, $heap); |
633
|
2
|
|
|
|
|
10
|
_check_for_close($kernel, $heap); |
634
|
|
|
|
|
|
|
} |
635
|
|
|
|
|
|
|
} |
636
|
|
|
|
|
|
|
|
637
|
|
|
|
|
|
|
# Default's used to catch ping timeouts, which are named after the |
638
|
|
|
|
|
|
|
# packed socket addresses being pinged. We always send the timeout so |
639
|
|
|
|
|
|
|
# the other session knows that a ping period has ended. |
640
|
|
|
|
|
|
|
|
641
|
|
|
|
|
|
|
sub poco_ping_default { |
642
|
54
|
|
|
54
|
0
|
15004150
|
my ($kernel, $heap, $seq) = @_[KERNEL, HEAP, ARG0]; |
643
|
|
|
|
|
|
|
|
644
|
|
|
|
|
|
|
# Record the receive time for possible use later. |
645
|
54
|
|
|
|
|
156
|
my $now = time(); |
646
|
|
|
|
|
|
|
|
647
|
|
|
|
|
|
|
# Are we waiting for this sequence number? We should be! |
648
|
54
|
100
|
|
|
|
242
|
unless (exists $heap->{ping_by_seq}->{$seq}) { |
649
|
5
|
|
|
|
|
11
|
warn "this shouldn't technically be displayed ($seq)" if ( |
650
|
|
|
|
|
|
|
DEBUG and $seq =~ /^\d+$/ |
651
|
|
|
|
|
|
|
); |
652
|
5
|
|
|
|
|
24
|
return; |
653
|
|
|
|
|
|
|
} |
654
|
|
|
|
|
|
|
|
655
|
49
|
|
|
|
|
129
|
my $ping_info = _end_ping_by_sequence($kernel, $heap, $seq); |
656
|
|
|
|
|
|
|
|
657
|
49
|
|
|
|
|
99
|
my $retryinfo = delete $heap->{retrydata}->{$seq}; |
658
|
49
|
100
|
|
|
|
144
|
if ($retryinfo) { |
659
|
4
|
|
|
|
|
11
|
my ($sender, $event, $address, $timeout, $remaining) = @{$retryinfo}; |
|
4
|
|
|
|
|
15
|
|
660
|
4
|
|
|
|
|
7
|
DEBUG and warn("retrying ping for $address (", $remaining - 1, ")\n"); |
661
|
4
|
|
|
|
|
28
|
_do_ping( |
662
|
|
|
|
|
|
|
$kernel, $heap, $sender, $event, $address, $timeout, |
663
|
|
|
|
|
|
|
$remaining - 1 |
664
|
|
|
|
|
|
|
); |
665
|
4
|
|
|
|
|
38
|
return; |
666
|
|
|
|
|
|
|
} |
667
|
|
|
|
|
|
|
|
668
|
|
|
|
|
|
|
# Post a timer tick back to the session. This marks the end of |
669
|
|
|
|
|
|
|
# the request/response transaction. |
670
|
45
|
|
|
|
|
154
|
$ping_info->[PBS_POSTBACK]->( undef, undef, $now, undef ); |
671
|
45
|
|
|
|
|
5585
|
_send_next_packet($kernel, $heap); |
672
|
45
|
|
|
|
|
124
|
_check_for_close($kernel, $heap); |
673
|
|
|
|
|
|
|
|
674
|
45
|
|
|
|
|
184
|
return; |
675
|
|
|
|
|
|
|
} |
676
|
|
|
|
|
|
|
|
677
|
|
|
|
|
|
|
1; |
678
|
|
|
|
|
|
|
|
679
|
|
|
|
|
|
|
__END__ |