This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
More general fix for bug [perl #37915]
[perl5.git] / lib / Net / Ping.pm
CommitLineData
a0d0e21e
LW
1package Net::Ping;
2
b124990b 3require 5.002;
a0d0e21e
LW
4require Exporter;
5
a3b93737 6use strict;
b124990b 7use vars qw(@ISA @EXPORT $VERSION
9539e94f
JH
8 $def_timeout $def_proto $def_factor
9 $max_datasize $pingstring $hires $source_verify $syn_forking);
f569508e 10use Fcntl qw( F_GETFL F_SETFL O_NONBLOCK );
eb194dd9 11use Socket qw( SOCK_DGRAM SOCK_STREAM SOCK_RAW PF_INET SOL_SOCKET SO_ERROR
e82f584b 12 inet_aton inet_ntoa sockaddr_in );
eb194dd9 13use POSIX qw( ENOTCONN ECONNREFUSED ECONNRESET EINPROGRESS EWOULDBLOCK EAGAIN WNOHANG );
f569508e 14use FileHandle;
a3b93737 15use Carp;
a79c1648 16
a0d0e21e 17@ISA = qw(Exporter);
a3b93737 18@EXPORT = qw(pingecho);
2708b1f4 19$VERSION = "2.31_03";
03550e9d
JH
20
21sub SOL_IP { 0; };
22sub IP_TOS { 1; };
a0d0e21e 23
a3b93737 24# Constants
a0d0e21e 25
a3b93737 26$def_timeout = 5; # Default timeout to wait for a reply
a5a165b1 27$def_proto = "tcp"; # Default protocol to use for pinging
9539e94f 28$def_factor = 1.2; # Default exponential backoff rate.
a3b93737 29$max_datasize = 1024; # Maximum data bytes in a packet
b124990b
JH
30# The data we exchange with the server for the stream protocol
31$pingstring = "pingschwingping!\n";
5d20095f 32$source_verify = 1; # Default is to verify source endpoint
f569508e 33$syn_forking = 0;
a0d0e21e 34
ef73e1db
JH
35if ($^O =~ /Win32/i) {
36 # Hack to avoid this Win32 spewage:
37 # Your vendor has not defined POSIX macro ECONNREFUSED
38 *ECONNREFUSED = sub {10061;}; # "Unknown Error" Special Win32 Response?
eb194dd9
GS
39 *ENOTCONN = sub {10057;};
40 *ECONNRESET = sub {10054;};
41 *EINPROGRESS = sub {10036;};
42 *EWOULDBLOCK = sub {10035;};
43# $syn_forking = 1; # XXX possibly useful in < Win2K ?
ef73e1db
JH
44};
45
f569508e
HS
46# h2ph "asm/socket.h"
47# require "asm/socket.ph";
48sub SO_BINDTODEVICE {25;}
49
a3b93737
RM
50# Description: The pingecho() subroutine is provided for backward
51# compatibility with the original Net::Ping. It accepts a host
52# name/IP and an optional timeout in seconds. Create a tcp ping
53# object and try pinging the host. The result of the ping is returned.
a0d0e21e 54
a3b93737
RM
55sub pingecho
56{
e82f584b
JH
57 my ($host, # Name or IP number of host to ping
58 $timeout # Optional timeout in seconds
59 ) = @_;
60 my ($p); # A ping object
a0d0e21e 61
e82f584b
JH
62 $p = Net::Ping->new("tcp", $timeout);
63 $p->ping($host); # Going out of scope closes the connection
a3b93737 64}
a0d0e21e 65
a3b93737
RM
66# Description: The new() method creates a new ping object. Optional
67# parameters may be specified for the protocol to use, the timeout in
68# seconds and the size in bytes of additional data which should be
69# included in the packet.
70# After the optional parameters are checked, the data is constructed
71# and a socket is opened if appropriate. The object is returned.
72
73sub new
74{
e82f584b
JH
75 my ($this,
76 $proto, # Optional protocol to use for pinging
77 $timeout, # Optional timeout in seconds
f569508e
HS
78 $data_size, # Optional additional bytes of data
79 $device, # Optional device to use
03550e9d 80 $tos, # Optional ToS to set
e82f584b
JH
81 ) = @_;
82 my $class = ref($this) || $this;
83 my $self = {};
84 my ($cnt, # Count through data bytes
85 $min_datasize # Minimum data bytes required
86 );
87
88 bless($self, $class);
89
90 $proto = $def_proto unless $proto; # Determine the protocol
f569508e
HS
91 croak('Protocol for ping must be "icmp", "udp", "tcp", "syn", "stream", or "external"')
92 unless $proto =~ m/^(icmp|udp|tcp|syn|stream|external)$/;
e82f584b
JH
93 $self->{"proto"} = $proto;
94
95 $timeout = $def_timeout unless $timeout; # Determine the timeout
96 croak("Default timeout for ping must be greater than 0 seconds")
97 if $timeout <= 0;
98 $self->{"timeout"} = $timeout;
99
f569508e
HS
100 $self->{"device"} = $device;
101
03550e9d
JH
102 $self->{"tos"} = $tos;
103
e82f584b
JH
104 $min_datasize = ($proto eq "udp") ? 1 : 0; # Determine data size
105 $data_size = $min_datasize unless defined($data_size) && $proto ne "tcp";
106 croak("Data for ping must be from $min_datasize to $max_datasize bytes")
107 if ($data_size < $min_datasize) || ($data_size > $max_datasize);
108 $data_size-- if $self->{"proto"} eq "udp"; # We provide the first byte
109 $self->{"data_size"} = $data_size;
110
111 $self->{"data"} = ""; # Construct data bytes
112 for ($cnt = 0; $cnt < $self->{"data_size"}; $cnt++)
113 {
114 $self->{"data"} .= chr($cnt % 256);
115 }
116
117 $self->{"local_addr"} = undef; # Don't bind by default
9539e94f 118 $self->{"retrans"} = $def_factor; # Default exponential backoff rate
c94ff782 119 $self->{"econnrefused"} = undef; # Default Connection refused behavior
f569508e 120
e82f584b
JH
121 $self->{"seq"} = 0; # For counting packets
122 if ($self->{"proto"} eq "udp") # Open a socket
123 {
124 $self->{"proto_num"} = (getprotobyname('udp'))[2] ||
125 croak("Can't udp protocol by name");
126 $self->{"port_num"} = (getservbyname('echo', 'udp'))[2] ||
127 croak("Can't get udp echo port by name");
128 $self->{"fh"} = FileHandle->new();
129 socket($self->{"fh"}, PF_INET, SOCK_DGRAM,
130 $self->{"proto_num"}) ||
131 croak("udp socket error - $!");
f569508e
HS
132 if ($self->{'device'}) {
133 setsockopt($self->{"fh"}, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'}))
134 or croak "error binding to device $self->{'device'} $!";
135 }
03550e9d
JH
136 if ($self->{'tos'}) {
137 setsockopt($self->{"fh"}, SOL_IP, IP_TOS(), pack("I*", $self->{'tos'}))
138 or croak "error configuring tos to $self->{'tos'} $!";
139 }
e82f584b
JH
140 }
141 elsif ($self->{"proto"} eq "icmp")
142 {
f569508e 143 croak("icmp ping requires root privilege") if ($> and $^O ne 'VMS' and $^O ne 'cygwin');
e82f584b
JH
144 $self->{"proto_num"} = (getprotobyname('icmp'))[2] ||
145 croak("Can't get icmp protocol by name");
146 $self->{"pid"} = $$ & 0xffff; # Save lower 16 bits of pid
147 $self->{"fh"} = FileHandle->new();
148 socket($self->{"fh"}, PF_INET, SOCK_RAW, $self->{"proto_num"}) ||
149 croak("icmp socket error - $!");
f569508e
HS
150 if ($self->{'device'}) {
151 setsockopt($self->{"fh"}, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'}))
152 or croak "error binding to device $self->{'device'} $!";
153 }
03550e9d
JH
154 if ($self->{'tos'}) {
155 setsockopt($self->{"fh"}, SOL_IP, IP_TOS(), pack("I*", $self->{'tos'}))
156 or croak "error configuring tos to $self->{'tos'} $!";
157 }
e82f584b
JH
158 }
159 elsif ($self->{"proto"} eq "tcp" || $self->{"proto"} eq "stream")
160 {
161 $self->{"proto_num"} = (getprotobyname('tcp'))[2] ||
162 croak("Can't get tcp protocol by name");
163 $self->{"port_num"} = (getservbyname('echo', 'tcp'))[2] ||
164 croak("Can't get tcp echo port by name");
165 $self->{"fh"} = FileHandle->new();
166 }
f569508e
HS
167 elsif ($self->{"proto"} eq "syn")
168 {
169 $self->{"proto_num"} = (getprotobyname('tcp'))[2] ||
170 croak("Can't get tcp protocol by name");
171 $self->{"port_num"} = (getservbyname('echo', 'tcp'))[2] ||
172 croak("Can't get tcp echo port by name");
173 if ($syn_forking) {
174 $self->{"fork_rd"} = FileHandle->new();
175 $self->{"fork_wr"} = FileHandle->new();
176 pipe($self->{"fork_rd"}, $self->{"fork_wr"});
177 $self->{"fh"} = FileHandle->new();
69c74a9c
HS
178 $self->{"good"} = {};
179 $self->{"bad"} = {};
f569508e
HS
180 } else {
181 $self->{"wbits"} = "";
182 $self->{"bad"} = {};
183 }
184 $self->{"syn"} = {};
185 $self->{"stop_time"} = 0;
186 }
187 elsif ($self->{"proto"} eq "external")
188 {
189 # No preliminary work needs to be done.
190 }
e82f584b
JH
191
192 return($self);
a3b93737 193}
a0d0e21e 194
49afa5f6
JH
195# Description: Set the local IP address from which pings will be sent.
196# For ICMP and UDP pings, this calls bind() on the already-opened socket;
197# for TCP pings, just saves the address to be used when the socket is
198# opened. Returns non-zero if successful; croaks on error.
199sub bind
200{
e82f584b
JH
201 my ($self,
202 $local_addr # Name or IP number of local interface
203 ) = @_;
204 my ($ip # Packed IP number of $local_addr
205 );
206
207 croak("Usage: \$p->bind(\$local_addr)") unless @_ == 2;
208 croak("already bound") if defined($self->{"local_addr"}) &&
209 ($self->{"proto"} eq "udp" || $self->{"proto"} eq "icmp");
210
211 $ip = inet_aton($local_addr);
212 croak("nonexistent local address $local_addr") unless defined($ip);
213 $self->{"local_addr"} = $ip; # Only used if proto is tcp
214
215 if ($self->{"proto"} eq "udp" || $self->{"proto"} eq "icmp")
216 {
217 CORE::bind($self->{"fh"}, sockaddr_in(0, $ip)) ||
218 croak("$self->{'proto'} bind error - $!");
219 }
03550e9d 220 elsif (($self->{"proto"} ne "tcp") && ($self->{"proto"} ne "syn"))
e82f584b
JH
221 {
222 croak("Unknown protocol \"$self->{proto}\" in bind()");
223 }
224
225 return 1;
226}
49afa5f6 227
eb194dd9
GS
228# Description: A select() wrapper that compensates for platform
229# peculiarities.
230sub mselect
231{
232 if ($_[3] > 0 and $^O eq 'MSWin32') {
233 # On windows, select() doesn't process the message loop,
234 # but sleep() will, allowing alarm() to interrupt the latter.
235 # So we chop up the timeout into smaller pieces and interleave
236 # select() and sleep() calls.
237 my $t = $_[3];
238 my $gran = 0.5; # polling granularity in seconds
239 my @args = @_;
240 while (1) {
241 $gran = $t if $gran > $t;
242 my $nfound = select($_[0], $_[1], $_[2], $gran);
95d3daf0 243 undef $nfound if $nfound == -1;
eb194dd9
GS
244 $t -= $gran;
245 return $nfound if $nfound or !defined($nfound) or $t <= 0;
246
247 sleep(0);
248 ($_[0], $_[1], $_[2]) = @args;
249 }
250 }
251 else {
95d3daf0
RGS
252 my $nfound = select($_[0], $_[1], $_[2], $_[3]);
253 undef $nfound if $nfound == -1;
254 return $nfound;
eb194dd9
GS
255 }
256}
49afa5f6 257
3c4b39be 258# Description: Allow UDP source endpoint comparison to be
15d96390
JH
259# skipped for those remote interfaces that do
260# not response from the same endpoint.
261
262sub source_verify
263{
264 my $self = shift;
5d20095f
JH
265 $source_verify = 1 unless defined
266 ($source_verify = ((defined $self) && (ref $self)) ? shift() : $self);
15d96390
JH
267}
268
c94ff782
JH
269# Description: Set whether or not the connect
270# behavior should enforce remote service
271# availability as well as reachability.
f569508e 272
c94ff782 273sub service_check
f569508e
HS
274{
275 my $self = shift;
c94ff782
JH
276 $self->{"econnrefused"} = 1 unless defined
277 ($self->{"econnrefused"} = shift());
278}
279
280sub tcp_service_check
281{
282 service_check(@_);
f569508e
HS
283}
284
9539e94f
JH
285# Description: Set exponential backoff for retransmission.
286# Should be > 1 to retain exponential properties.
287# If set to 0, retransmissions are disabled.
288
289sub retrans
290{
291 my $self = shift;
292 $self->{"retrans"} = shift;
293}
294
e82f584b
JH
295# Description: allows the module to use milliseconds as returned by
296# the Time::HiRes module
49afa5f6 297
e82f584b
JH
298$hires = 0;
299sub hires
300{
301 my $self = shift;
302 $hires = 1 unless defined
303 ($hires = ((defined $self) && (ref $self)) ? shift() : $self);
304 require Time::HiRes if $hires;
49afa5f6
JH
305}
306
e82f584b
JH
307sub time
308{
309 return $hires ? Time::HiRes::time() : CORE::time();
310}
49afa5f6 311
9c36735d
JH
312# Description: Sets or clears the O_NONBLOCK flag on a file handle.
313sub socket_blocking_mode
314{
315 my ($self,
316 $fh, # the file handle whose flags are to be modified
317 $block) = @_; # if true then set the blocking
318 # mode (clear O_NONBLOCK), otherwise
319 # set the non-blocking mode (set O_NONBLOCK)
320
321 my $flags;
d135e082
CB
322 if ($^O eq 'MSWin32' || $^O eq 'VMS') {
323 # FIONBIO enables non-blocking sockets on windows and vms.
324 # FIONBIO is (0x80000000|(4<<16)|(ord('f')<<8)|126), as per winsock.h, ioctl.h
eb194dd9
GS
325 my $f = 0x8004667e;
326 my $v = pack("L", $block ? 0 : 1);
327 ioctl($fh, $f, $v) or croak("ioctl failed: $!");
328 return;
329 }
9c36735d
JH
330 if ($flags = fcntl($fh, F_GETFL, 0)) {
331 $flags = $block ? ($flags & ~O_NONBLOCK) : ($flags | O_NONBLOCK);
332 if (!fcntl($fh, F_SETFL, $flags)) {
333 croak("fcntl F_SETFL: $!");
334 }
335 } else {
336 croak("fcntl F_GETFL: $!");
337 }
338}
339
a3b93737
RM
340# Description: Ping a host name or IP number with an optional timeout.
341# First lookup the host, and return undef if it is not found. Otherwise
b124990b 342# perform the specific ping method based on the protocol. Return the
a3b93737
RM
343# result of the ping.
344
345sub ping
346{
e82f584b
JH
347 my ($self,
348 $host, # Name or IP number of host to ping
349 $timeout, # Seconds after which ping times out
350 ) = @_;
351 my ($ip, # Packed IP number of $host
352 $ret, # The return value
353 $ping_time, # When ping began
354 );
355
356 croak("Usage: \$p->ping(\$host [, \$timeout])") unless @_ == 2 || @_ == 3;
357 $timeout = $self->{"timeout"} unless $timeout;
358 croak("Timeout must be greater than 0 seconds") if $timeout <= 0;
359
360 $ip = inet_aton($host);
c94ff782 361 return () unless defined($ip); # Does host exist?
e82f584b
JH
362
363 # Dispatch to the appropriate routine.
364 $ping_time = &time();
365 if ($self->{"proto"} eq "external") {
366 $ret = $self->ping_external($ip, $timeout);
367 }
368 elsif ($self->{"proto"} eq "udp") {
369 $ret = $self->ping_udp($ip, $timeout);
370 }
371 elsif ($self->{"proto"} eq "icmp") {
372 $ret = $self->ping_icmp($ip, $timeout);
373 }
374 elsif ($self->{"proto"} eq "tcp") {
375 $ret = $self->ping_tcp($ip, $timeout);
376 }
377 elsif ($self->{"proto"} eq "stream") {
378 $ret = $self->ping_stream($ip, $timeout);
f569508e
HS
379 }
380 elsif ($self->{"proto"} eq "syn") {
381 $ret = $self->ping_syn($host, $ip, $ping_time, $ping_time+$timeout);
e82f584b 382 } else {
787ecdfa 383 croak("Unknown protocol \"$self->{proto}\" in ping()");
e82f584b
JH
384 }
385
386 return wantarray ? ($ret, &time() - $ping_time, inet_ntoa($ip)) : $ret;
787ecdfa
JH
387}
388
389# Uses Net::Ping::External to do an external ping.
390sub ping_external {
391 my ($self,
392 $ip, # Packed IP number of the host
393 $timeout # Seconds after which ping times out
394 ) = @_;
395
b124990b
JH
396 eval { require Net::Ping::External; }
397 or croak('Protocol "external" not supported on your system: Net::Ping::External not found');
787ecdfa 398 return Net::Ping::External::ping(ip => $ip, timeout => $timeout);
a3b93737 399}
a0d0e21e 400
46b9c7d8
GA
401use constant ICMP_ECHOREPLY => 0; # ICMP packet types
402use constant ICMP_UNREACHABLE => 3; # ICMP packet types
403use constant ICMP_ECHO => 8;
404use constant ICMP_STRUCT => "C2 n3 A"; # Structure of a minimal ICMP packet
405use constant SUBCODE => 0; # No ICMP subcode for ECHO and ECHOREPLY
406use constant ICMP_FLAGS => 0; # No special flags for send or recv
407use constant ICMP_PORT => 0; # No port with ICMP
49afa5f6 408
a3b93737
RM
409sub ping_icmp
410{
e82f584b
JH
411 my ($self,
412 $ip, # Packed IP number of the host
413 $timeout # Seconds after which ping times out
414 ) = @_;
415
416 my ($saddr, # sockaddr_in with port and ip
417 $checksum, # Checksum of ICMP packet
418 $msg, # ICMP packet to send
419 $len_msg, # Length of $msg
420 $rbits, # Read bits, filehandles for reading
421 $nfound, # Number of ready filehandles found
422 $finish_time, # Time ping should be finished
423 $done, # set to 1 when we are done
424 $ret, # Return value
425 $recv_msg, # Received message including IP header
426 $from_saddr, # sockaddr_in of sender
427 $from_port, # Port packet was sent from
428 $from_ip, # Packed IP of sender
429 $from_type, # ICMP type
430 $from_subcode, # ICMP subcode
431 $from_chk, # ICMP packet checksum
432 $from_pid, # ICMP packet id
433 $from_seq, # ICMP packet sequence
434 $from_msg # ICMP message
435 );
436
437 $self->{"seq"} = ($self->{"seq"} + 1) % 65536; # Increment sequence
438 $checksum = 0; # No checksum for starters
439 $msg = pack(ICMP_STRUCT . $self->{"data_size"}, ICMP_ECHO, SUBCODE,
440 $checksum, $self->{"pid"}, $self->{"seq"}, $self->{"data"});
441 $checksum = Net::Ping->checksum($msg);
442 $msg = pack(ICMP_STRUCT . $self->{"data_size"}, ICMP_ECHO, SUBCODE,
443 $checksum, $self->{"pid"}, $self->{"seq"}, $self->{"data"});
444 $len_msg = length($msg);
445 $saddr = sockaddr_in(ICMP_PORT, $ip);
9c36735d
JH
446 $self->{"from_ip"} = undef;
447 $self->{"from_type"} = undef;
448 $self->{"from_subcode"} = undef;
e82f584b
JH
449 send($self->{"fh"}, $msg, ICMP_FLAGS, $saddr); # Send the message
450
451 $rbits = "";
452 vec($rbits, $self->{"fh"}->fileno(), 1) = 1;
453 $ret = 0;
454 $done = 0;
455 $finish_time = &time() + $timeout; # Must be done by this time
456 while (!$done && $timeout > 0) # Keep trying if we have time
457 {
eb194dd9 458 $nfound = mselect((my $rout=$rbits), undef, undef, $timeout); # Wait for packet
e82f584b 459 $timeout = $finish_time - &time(); # Get remaining time
95d3daf0 460 if (!defined($nfound)) # Hmm, a strange error
a3b93737 461 {
e82f584b
JH
462 $ret = undef;
463 $done = 1;
464 }
465 elsif ($nfound) # Got a packet from somewhere
466 {
467 $recv_msg = "";
9539e94f
JH
468 $from_pid = -1;
469 $from_seq = -1;
e82f584b
JH
470 $from_saddr = recv($self->{"fh"}, $recv_msg, 1500, ICMP_FLAGS);
471 ($from_port, $from_ip) = sockaddr_in($from_saddr);
9c36735d 472 ($from_type, $from_subcode) = unpack("C2", substr($recv_msg, 20, 2));
9539e94f
JH
473 if ($from_type == ICMP_ECHOREPLY) {
474 ($from_pid, $from_seq) = unpack("n3", substr($recv_msg, 24, 4))
475 if length $recv_msg >= 28;
9c36735d 476 } else {
9539e94f
JH
477 ($from_pid, $from_seq) = unpack("n3", substr($recv_msg, 52, 4))
478 if length $recv_msg >= 56;
9c36735d
JH
479 }
480 $self->{"from_ip"} = $from_ip;
481 $self->{"from_type"} = $from_type;
482 $self->{"from_subcode"} = $from_subcode;
483 if (($from_pid == $self->{"pid"}) && # Does the packet check out?
484 ($from_seq == $self->{"seq"})) {
46b9c7d8 485 if ($from_type == ICMP_ECHOREPLY) {
9c36735d 486 $ret = 1;
46b9c7d8
GA
487 $done = 1;
488 } elsif ($from_type == ICMP_UNREACHABLE) {
489 $done = 1;
9c36735d 490 }
e82f584b 491 }
9c36735d 492 } else { # Oops, timed out
e82f584b
JH
493 $done = 1;
494 }
495 }
496 return $ret;
a3b93737
RM
497}
498
9c36735d
JH
499sub icmp_result {
500 my ($self) = @_;
501 my $ip = $self->{"from_ip"} || "";
502 $ip = "\0\0\0\0" unless 4 == length $ip;
503 return (inet_ntoa($ip),($self->{"from_type"} || 0), ($self->{"from_subcode"} || 0));
504}
505
a3b93737
RM
506# Description: Do a checksum on the message. Basically sum all of
507# the short words and fold the high order bits into the low order bits.
508
509sub checksum
510{
e82f584b
JH
511 my ($class,
512 $msg # The message to checksum
513 ) = @_;
514 my ($len_msg, # Length of the message
515 $num_short, # The number of short words in the message
516 $short, # One short word
517 $chk # The checksum
518 );
519
520 $len_msg = length($msg);
521 $num_short = int($len_msg / 2);
522 $chk = 0;
9c36735d 523 foreach $short (unpack("n$num_short", $msg))
e82f584b
JH
524 {
525 $chk += $short;
526 } # Add the odd byte in
527 $chk += (unpack("C", substr($msg, $len_msg - 1, 1)) << 8) if $len_msg % 2;
528 $chk = ($chk >> 16) + ($chk & 0xffff); # Fold high into low
529 return(~(($chk >> 16) + $chk) & 0xffff); # Again and complement
a3b93737
RM
530}
531
787ecdfa 532
b124990b
JH
533# Description: Perform a tcp echo ping. Since a tcp connection is
534# host specific, we have to open and close each connection here. We
535# can't just leave a socket open. Because of the robust nature of
536# tcp, it will take a while before it gives up trying to establish a
537# connection. Therefore, we use select() on a non-blocking socket to
538# check against our timeout. No data bytes are actually
539# sent since the successful establishment of a connection is proof
540# enough of the reachability of the remote host. Also, tcp is
541# expensive and doesn't need our help to add to the overhead.
542
543sub ping_tcp
787ecdfa 544{
e82f584b
JH
545 my ($self,
546 $ip, # Packed IP number of the host
547 $timeout # Seconds after which ping times out
548 ) = @_;
549 my ($ret # The return value
550 );
551
9c36735d 552 $! = 0;
e82f584b 553 $ret = $self -> tcp_connect( $ip, $timeout);
c94ff782 554 if (!$self->{"econnrefused"} &&
f569508e
HS
555 $! == ECONNREFUSED) {
556 $ret = 1; # "Connection refused" means reachable
557 }
e82f584b
JH
558 $self->{"fh"}->close();
559 return $ret;
787ecdfa
JH
560}
561
b124990b 562sub tcp_connect
787ecdfa 563{
e82f584b
JH
564 my ($self,
565 $ip, # Packed IP number of the host
566 $timeout # Seconds after which connect times out
567 ) = @_;
568 my ($saddr); # Packed IP and Port
b124990b 569
e82f584b 570 $saddr = sockaddr_in($self->{"port_num"}, $ip);
b124990b 571
e82f584b 572 my $ret = 0; # Default to unreachable
b124990b 573
e82f584b
JH
574 my $do_socket = sub {
575 socket($self->{"fh"}, PF_INET, SOCK_STREAM, $self->{"proto_num"}) ||
576 croak("tcp socket error - $!");
577 if (defined $self->{"local_addr"} &&
578 !CORE::bind($self->{"fh"}, sockaddr_in(0, $self->{"local_addr"}))) {
579 croak("tcp bind error - $!");
580 }
f569508e
HS
581 if ($self->{'device'}) {
582 setsockopt($self->{"fh"}, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'}))
583 or croak("error binding to device $self->{'device'} $!");
584 }
03550e9d
JH
585 if ($self->{'tos'}) {
586 setsockopt($self->{"fh"}, SOL_IP, IP_TOS(), pack("I*", $self->{'tos'}))
587 or croak "error configuring tos to $self->{'tos'} $!";
588 }
e82f584b
JH
589 };
590 my $do_connect = sub {
9c36735d 591 $self->{"ip"} = $ip;
6dbac12b
GS
592 # ECONNREFUSED is 10061 on MSWin32. If we pass it as child error through $?,
593 # we'll get (10061 & 255) = 77, so we cannot check it in the parent process.
594 return ($ret = connect($self->{"fh"}, $saddr) || ($! == ECONNREFUSED && !$self->{"econnrefused"}));
e82f584b 595 };
9c36735d
JH
596 my $do_connect_nb = sub {
597 # Set O_NONBLOCK property on filehandle
598 $self->socket_blocking_mode($self->{"fh"}, 0);
599
600 # start the connection attempt
601 if (!connect($self->{"fh"}, $saddr)) {
602 if ($! == ECONNREFUSED) {
c94ff782 603 $ret = 1 unless $self->{"econnrefused"};
eb194dd9 604 } elsif ($! != EINPROGRESS && ($^O ne 'MSWin32' || $! != EWOULDBLOCK)) {
9c36735d 605 # EINPROGRESS is the expected error code after a connect()
c94ff782
JH
606 # on a non-blocking socket. But if the kernel immediately
607 # determined that this connect() will never work,
608 # Simply respond with "unreachable" status.
609 # (This can occur on some platforms with errno
610 # EHOSTUNREACH or ENETUNREACH.)
611 return 0;
612 } else {
613 # Got the expected EINPROGRESS.
614 # Just wait for connection completion...
eb194dd9
GS
615 my ($wbits, $wout, $wexc);
616 $wout = $wexc = $wbits = "";
9c36735d
JH
617 vec($wbits, $self->{"fh"}->fileno, 1) = 1;
618
eb194dd9
GS
619 my $nfound = mselect(undef,
620 ($wout = $wbits),
621 ($^O eq 'MSWin32' ? ($wexc = $wbits) : undef),
622 $timeout);
9c36735d
JH
623 warn("select: $!") unless defined $nfound;
624
625 if ($nfound && vec($wout, $self->{"fh"}->fileno, 1)) {
626 # the socket is ready for writing so the connection
627 # attempt completed. test whether the connection
628 # attempt was successful or not
629
630 if (getpeername($self->{"fh"})) {
631 # Connection established to remote host
632 $ret = 1;
633 } else {
634 # TCP ACK will never come from this host
635 # because there was an error connecting.
e82f584b 636
9c36735d
JH
637 # This should set $! to the correct error.
638 my $char;
639 sysread($self->{"fh"},$char,1);
640 $! = ECONNREFUSED if ($! == EAGAIN && $^O =~ /cygwin/i);
e82f584b 641
c94ff782 642 $ret = 1 if (!$self->{"econnrefused"}
9c36735d
JH
643 && $! == ECONNREFUSED);
644 }
645 } else {
eb194dd9
GS
646 # the connection attempt timed out (or there were connect
647 # errors on Windows)
648 if ($^O =~ 'MSWin32') {
649 # If the connect will fail on a non-blocking socket,
650 # winsock reports ECONNREFUSED as an exception, and we
651 # need to fetch the socket-level error code via getsockopt()
652 # instead of using the thread-level error code that is in $!.
653 if ($nfound && vec($wexc, $self->{"fh"}->fileno, 1)) {
654 $! = unpack("i", getsockopt($self->{"fh"}, SOL_SOCKET,
655 SO_ERROR));
656 }
657 }
9c36735d
JH
658 }
659 }
660 } else {
661 # Connection established to remote host
662 $ret = 1;
663 }
664
665 # Unset O_NONBLOCK property on filehandle
666 $self->socket_blocking_mode($self->{"fh"}, 1);
667 $self->{"ip"} = $ip;
668 return $ret;
669 };
670
671 if ($syn_forking) {
672 # Buggy Winsock API doesn't allow nonblocking connect.
e82f584b
JH
673 # Hence, if our OS is Windows, we need to create a separate
674 # process to do the blocking connect attempt.
eb194dd9
GS
675 # XXX Above comments are not true at least for Win2K, where
676 # nonblocking connect works.
e82f584b
JH
677
678 $| = 1; # Clear buffer prior to fork to prevent duplicate flushing.
9c36735d
JH
679 $self->{'tcp_chld'} = fork;
680 if (!$self->{'tcp_chld'}) {
681 if (!defined $self->{'tcp_chld'}) {
e82f584b 682 # Fork did not work
9c36735d 683 warn "Fork error: $!";
e82f584b 684 return 0;
b124990b 685 }
b124990b
JH
686 &{ $do_socket }();
687
e82f584b 688 # Try a slow blocking connect() call
9c36735d 689 # and report the status to the parent.
e82f584b
JH
690 if ( &{ $do_connect }() ) {
691 $self->{"fh"}->close();
692 # No error
693 exit 0;
b124990b 694 } else {
e82f584b 695 # Pass the error status to the parent
6dbac12b
GS
696 # Make sure that $! <= 255
697 exit($! <= 255 ? $! : 255);
b124990b 698 }
e82f584b 699 }
b124990b 700
e82f584b
JH
701 &{ $do_socket }();
702
703 my $patience = &time() + $timeout;
704
9c36735d
JH
705 my ($child, $child_errno);
706 $? = 0; $child_errno = 0;
e82f584b
JH
707 # Wait up to the timeout
708 # And clean off the zombie
709 do {
9c36735d
JH
710 $child = waitpid($self->{'tcp_chld'}, &WNOHANG());
711 $child_errno = $? >> 8;
e82f584b 712 select(undef, undef, undef, 0.1);
9c36735d
JH
713 } while &time() < $patience && $child != $self->{'tcp_chld'};
714
715 if ($child == $self->{'tcp_chld'}) {
716 if ($self->{"proto"} eq "stream") {
717 # We need the socket connected here, in parent
718 # Should be safe to connect because the child finished
719 # within the timeout
720 &{ $do_connect }();
721 }
6dbac12b
GS
722 # $ret cannot be set by the child process
723 $ret = !$child_errno;
e82f584b
JH
724 } else {
725 # Time must have run out.
e82f584b 726 # Put that choking client out of its misery
9c36735d 727 kill "KILL", $self->{'tcp_chld'};
e82f584b 728 # Clean off the zombie
9c36735d 729 waitpid($self->{'tcp_chld'}, 0);
e82f584b 730 $ret = 0;
b124990b 731 }
9c36735d
JH
732 delete $self->{'tcp_chld'};
733 $! = $child_errno;
734 } else {
e82f584b
JH
735 # Otherwise don't waste the resources to fork
736
737 &{ $do_socket }();
738
9c36735d 739 &{ $do_connect_nb }();
e82f584b 740 }
787ecdfa 741
e82f584b 742 return $ret;
787ecdfa
JH
743}
744
9c36735d
JH
745sub DESTROY {
746 my $self = shift;
747 if ($self->{'proto'} eq 'tcp' &&
748 $self->{'tcp_chld'}) {
749 # Put that choking client out of its misery
750 kill "KILL", $self->{'tcp_chld'};
751 # Clean off the zombie
752 waitpid($self->{'tcp_chld'}, 0);
753 }
754}
755
787ecdfa
JH
756# This writes the given string to the socket and then reads it
757# back. It returns 1 on success, 0 on failure.
758sub tcp_echo
759{
e82f584b
JH
760 my $self = shift;
761 my $timeout = shift;
762 my $pingstring = shift;
763
764 my $ret = undef;
765 my $time = &time();
766 my $wrstr = $pingstring;
767 my $rdstr = "";
768
769 eval <<'EOM';
770 do {
771 my $rin = "";
772 vec($rin, $self->{"fh"}->fileno(), 1) = 1;
773
774 my $rout = undef;
775 if($wrstr) {
776 $rout = "";
777 vec($rout, $self->{"fh"}->fileno(), 1) = 1;
778 }
779
eb194dd9 780 if(mselect($rin, $rout, undef, ($time + $timeout) - &time())) {
e82f584b
JH
781
782 if($rout && vec($rout,$self->{"fh"}->fileno(),1)) {
9c36735d 783 my $num = syswrite($self->{"fh"}, $wrstr, length $wrstr);
e82f584b
JH
784 if($num) {
785 # If it was a partial write, update and try again.
786 $wrstr = substr($wrstr,$num);
787 } else {
788 # There was an error.
789 $ret = 0;
790 }
791 }
792
793 if(vec($rin,$self->{"fh"}->fileno(),1)) {
794 my $reply;
795 if(sysread($self->{"fh"},$reply,length($pingstring)-length($rdstr))) {
796 $rdstr .= $reply;
797 $ret = 1 if $rdstr eq $pingstring;
798 } else {
799 # There was an error.
800 $ret = 0;
801 }
802 }
803
804 }
805 } until &time() > ($time + $timeout) || defined($ret);
787ecdfa
JH
806EOM
807
e82f584b 808 return $ret;
787ecdfa
JH
809}
810
787ecdfa 811
787ecdfa 812
787ecdfa
JH
813
814# Description: Perform a stream ping. If the tcp connection isn't
815# already open, it opens it. It then sends some data and waits for
816# a reply. It leaves the stream open on exit.
817
818sub ping_stream
819{
e82f584b
JH
820 my ($self,
821 $ip, # Packed IP number of the host
822 $timeout # Seconds after which ping times out
823 ) = @_;
072620d9 824
e82f584b
JH
825 # Open the stream if it's not already open
826 if(!defined $self->{"fh"}->fileno()) {
827 $self->tcp_connect($ip, $timeout) or return 0;
828 }
787ecdfa 829
e82f584b
JH
830 croak "tried to switch servers while stream pinging"
831 if $self->{"ip"} ne $ip;
832
833 return $self->tcp_echo($timeout, $pingstring);
787ecdfa
JH
834}
835
836# Description: opens the stream. You would do this if you want to
837# separate the overhead of opening the stream from the first ping.
838
839sub open
840{
e82f584b
JH
841 my ($self,
842 $host, # Host or IP address
843 $timeout # Seconds after which open times out
844 ) = @_;
845
846 my ($ip); # Packed IP number of the host
847 $ip = inet_aton($host);
848 $timeout = $self->{"timeout"} unless $timeout;
849
850 if($self->{"proto"} eq "stream") {
851 if(defined($self->{"fh"}->fileno())) {
852 croak("socket is already open");
853 } else {
854 $self->tcp_connect($ip, $timeout);
b124990b 855 }
e82f584b 856 }
072620d9
SB
857}
858
b124990b 859
a3b93737
RM
860# Description: Perform a udp echo ping. Construct a message of
861# at least the one-byte sequence number and any additional data bytes.
862# Send the message out and wait for a message to come back. If we
863# get a message, make sure all of its parts match. If they do, we are
864# done. Otherwise go back and wait for the message until we run out
865# of time. Return the result of our efforts.
866
49afa5f6 867use constant UDP_FLAGS => 0; # Nothing special on send or recv
a3b93737
RM
868sub ping_udp
869{
e82f584b
JH
870 my ($self,
871 $ip, # Packed IP number of the host
872 $timeout # Seconds after which ping times out
873 ) = @_;
874
875 my ($saddr, # sockaddr_in with port and ip
876 $ret, # The return value
877 $msg, # Message to be echoed
878 $finish_time, # Time ping should be finished
9539e94f
JH
879 $flush, # Whether socket needs to be disconnected
880 $connect, # Whether socket needs to be connected
e82f584b
JH
881 $done, # Set to 1 when we are done pinging
882 $rbits, # Read bits, filehandles for reading
883 $nfound, # Number of ready filehandles found
884 $from_saddr, # sockaddr_in of sender
885 $from_msg, # Characters echoed by $host
886 $from_port, # Port message was echoed from
887 $from_ip # Packed IP number of sender
888 );
889
890 $saddr = sockaddr_in($self->{"port_num"}, $ip);
891 $self->{"seq"} = ($self->{"seq"} + 1) % 256; # Increment sequence
892 $msg = chr($self->{"seq"}) . $self->{"data"}; # Add data if any
9539e94f
JH
893
894 if ($self->{"connected"}) {
895 if ($self->{"connected"} ne $saddr) {
896 # Still connected to wrong destination.
897 # Need to flush out the old one.
898 $flush = 1;
899 }
900 } else {
901 # Not connected yet.
902 # Need to connect() before send()
903 $connect = 1;
904 }
905
c94ff782
JH
906 # Have to connect() and send() instead of sendto()
907 # in order to pick up on the ECONNREFUSED setting
908 # from recv() or double send() errno as utilized in
909 # the concept by rdw @ perlmonks. See:
910 # http://perlmonks.thepen.com/42898.html
9539e94f
JH
911 if ($flush) {
912 # Need to socket() again to flush the descriptor
913 # This will disconnect from the old saddr.
914 socket($self->{"fh"}, PF_INET, SOCK_DGRAM,
915 $self->{"proto_num"});
916 }
917 # Connect the socket if it isn't already connected
918 # to the right destination.
919 if ($flush || $connect) {
920 connect($self->{"fh"}, $saddr); # Tie destination to socket
921 $self->{"connected"} = $saddr;
922 }
c94ff782 923 send($self->{"fh"}, $msg, UDP_FLAGS); # Send it
e82f584b
JH
924
925 $rbits = "";
926 vec($rbits, $self->{"fh"}->fileno(), 1) = 1;
927 $ret = 0; # Default to unreachable
928 $done = 0;
c94ff782 929 my $retrans = 0.01;
9539e94f 930 my $factor = $self->{"retrans"};
e82f584b
JH
931 $finish_time = &time() + $timeout; # Ping needs to be done by then
932 while (!$done && $timeout > 0)
933 {
9539e94f
JH
934 if ($factor > 1)
935 {
936 $timeout = $retrans if $timeout > $retrans;
937 $retrans*= $factor; # Exponential backoff
938 }
eb194dd9 939 $nfound = mselect((my $rout=$rbits), undef, undef, $timeout); # Wait for response
c94ff782 940 my $why = $!;
e82f584b
JH
941 $timeout = $finish_time - &time(); # Get remaining time
942
943 if (!defined($nfound)) # Hmm, a strange error
a3b93737 944 {
e82f584b
JH
945 $ret = undef;
946 $done = 1;
a3b93737 947 }
e82f584b
JH
948 elsif ($nfound) # A packet is waiting
949 {
950 $from_msg = "";
c94ff782
JH
951 $from_saddr = recv($self->{"fh"}, $from_msg, 1500, UDP_FLAGS);
952 if (!$from_saddr) {
953 # For example an unreachable host will make recv() fail.
954 if (!$self->{"econnrefused"} &&
9539e94f
JH
955 ($! == ECONNREFUSED ||
956 $! == ECONNRESET)) {
c94ff782
JH
957 # "Connection refused" means reachable
958 # Good, continue
959 $ret = 1;
960 }
e82f584b 961 $done = 1;
c94ff782
JH
962 } else {
963 ($from_port, $from_ip) = sockaddr_in($from_saddr);
964 if (!$source_verify ||
965 (($from_ip eq $ip) && # Does the packet check out?
966 ($from_port == $self->{"port_num"}) &&
967 ($from_msg eq $msg)))
968 {
969 $ret = 1; # It's a winner
970 $done = 1;
971 }
e82f584b
JH
972 }
973 }
c94ff782 974 elsif ($timeout <= 0) # Oops, timed out
e82f584b
JH
975 {
976 $done = 1;
977 }
c94ff782
JH
978 else
979 {
980 # Send another in case the last one dropped
981 if (send($self->{"fh"}, $msg, UDP_FLAGS)) {
982 # Another send worked? The previous udp packet
983 # must have gotten lost or is still in transit.
984 # Hopefully this new packet will arrive safely.
985 } else {
986 if (!$self->{"econnrefused"} &&
987 $! == ECONNREFUSED) {
988 # "Connection refused" means reachable
989 # Good, continue
990 $ret = 1;
991 }
992 $done = 1;
993 }
994 }
e82f584b 995 }
a5a165b1 996 return $ret;
b124990b 997}
a0d0e21e 998
f569508e
HS
999# Description: Send a TCP SYN packet to host specified.
1000sub ping_syn
1001{
1002 my $self = shift;
1003 my $host = shift;
1004 my $ip = shift;
1005 my $start_time = shift;
1006 my $stop_time = shift;
1007
1008 if ($syn_forking) {
1009 return $self->ping_syn_fork($host, $ip, $start_time, $stop_time);
1010 }
1011
1012 my $fh = FileHandle->new();
1013 my $saddr = sockaddr_in($self->{"port_num"}, $ip);
1014
1015 # Create TCP socket
1016 if (!socket ($fh, PF_INET, SOCK_STREAM, $self->{"proto_num"})) {
1017 croak("tcp socket error - $!");
1018 }
1019
1020 if (defined $self->{"local_addr"} &&
1021 !CORE::bind($fh, sockaddr_in(0, $self->{"local_addr"}))) {
1022 croak("tcp bind error - $!");
1023 }
1024
1025 if ($self->{'device'}) {
1026 setsockopt($fh, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'}))
1027 or croak("error binding to device $self->{'device'} $!");
1028 }
03550e9d
JH
1029 if ($self->{'tos'}) {
1030 setsockopt($fh, SOL_IP, IP_TOS(), pack("I*", $self->{'tos'}))
1031 or croak "error configuring tos to $self->{'tos'} $!";
1032 }
f569508e 1033 # Set O_NONBLOCK property on filehandle
9c36735d 1034 $self->socket_blocking_mode($fh, 0);
f569508e
HS
1035
1036 # Attempt the non-blocking connect
1037 # by just sending the TCP SYN packet
1038 if (connect($fh, $saddr)) {
1039 # Non-blocking, yet still connected?
69c74a9c
HS
1040 # Must have connected very quickly,
1041 # or else it wasn't very non-blocking.
1042 #warn "WARNING: Nonblocking connect connected anyway? ($^O)";
1043 } else {
f569508e 1044 # Error occurred connecting.
eb194dd9 1045 if ($! == EINPROGRESS || ($^O eq 'MSWin32' && $! == EWOULDBLOCK)) {
69c74a9c
HS
1046 # The connection is just still in progress.
1047 # This is the expected condition.
1048 } else {
1049 # Just save the error and continue on.
1050 # The ack() can check the status later.
f569508e 1051 $self->{"bad"}->{$host} = $!;
f569508e
HS
1052 }
1053 }
1054
1055 my $entry = [ $host, $ip, $fh, $start_time, $stop_time ];
1056 $self->{"syn"}->{$fh->fileno} = $entry;
1057 if ($self->{"stop_time"} < $stop_time) {
1058 $self->{"stop_time"} = $stop_time;
1059 }
1060 vec($self->{"wbits"}, $fh->fileno, 1) = 1;
1061
1062 return 1;
1063}
1064
1065sub ping_syn_fork {
1066 my ($self, $host, $ip, $start_time, $stop_time) = @_;
1067
1068 # Buggy Winsock API doesn't allow nonblocking connect.
1069 # Hence, if our OS is Windows, we need to create a separate
1070 # process to do the blocking connect attempt.
1071 my $pid = fork();
1072 if (defined $pid) {
1073 if ($pid) {
1074 # Parent process
1075 my $entry = [ $host, $ip, $pid, $start_time, $stop_time ];
1076 $self->{"syn"}->{$pid} = $entry;
1077 if ($self->{"stop_time"} < $stop_time) {
1078 $self->{"stop_time"} = $stop_time;
1079 }
1080 } else {
1081 # Child process
1082 my $saddr = sockaddr_in($self->{"port_num"}, $ip);
1083
1084 # Create TCP socket
1085 if (!socket ($self->{"fh"}, PF_INET, SOCK_STREAM, $self->{"proto_num"})) {
1086 croak("tcp socket error - $!");
1087 }
1088
1089 if (defined $self->{"local_addr"} &&
1090 !CORE::bind($self->{"fh"}, sockaddr_in(0, $self->{"local_addr"}))) {
1091 croak("tcp bind error - $!");
1092 }
1093
1094 if ($self->{'device'}) {
1095 setsockopt($self->{"fh"}, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'}))
1096 or croak("error binding to device $self->{'device'} $!");
1097 }
03550e9d
JH
1098 if ($self->{'tos'}) {
1099 setsockopt($self->{"fh"}, SOL_IP, IP_TOS(), pack("I*", $self->{'tos'}))
1100 or croak "error configuring tos to $self->{'tos'} $!";
1101 }
f569508e
HS
1102
1103 $!=0;
1104 # Try to connect (could take a long time)
1105 connect($self->{"fh"}, $saddr);
1106 # Notify parent of connect error status
1107 my $err = $!+0;
1108 my $wrstr = "$$ $err";
9c36735d
JH
1109 # Force to 16 chars including \n
1110 $wrstr .= " "x(15 - length $wrstr). "\n";
1111 syswrite($self->{"fork_wr"}, $wrstr, length $wrstr);
f569508e
HS
1112 exit;
1113 }
1114 } else {
1115 # fork() failed?
1116 die "fork: $!";
1117 }
1118 return 1;
1119}
1120
1121# Description: Wait for TCP ACK from host specified
1122# from ping_syn above. If no host is specified, wait
1123# for TCP ACK from any of the hosts in the SYN queue.
1124sub ack
1125{
1126 my $self = shift;
1127
1128 if ($self->{"proto"} eq "syn") {
1129 if ($syn_forking) {
1130 my @answer = $self->ack_unfork(shift);
1131 return wantarray ? @answer : $answer[0];
1132 }
1133 my $wbits = "";
1134 my $stop_time = 0;
1135 if (my $host = shift) {
1136 # Host passed as arg
1137 if (exists $self->{"bad"}->{$host}) {
c94ff782 1138 if (!$self->{"econnrefused"} &&
69c74a9c
HS
1139 $self->{"bad"}->{ $host } &&
1140 (($! = ECONNREFUSED)>0) &&
1141 $self->{"bad"}->{ $host } eq "$!") {
1142 # "Connection refused" means reachable
1143 # Good, continue
1144 } else {
1145 # ECONNREFUSED means no good
1146 return ();
1147 }
f569508e
HS
1148 }
1149 my $host_fd = undef;
1150 foreach my $fd (keys %{ $self->{"syn"} }) {
1151 my $entry = $self->{"syn"}->{$fd};
1152 if ($entry->[0] eq $host) {
1153 $host_fd = $fd;
1154 $stop_time = $entry->[4]
1155 || croak("Corrupted SYN entry for [$host]");
1156 last;
1157 }
1158 }
1159 croak("ack called on [$host] without calling ping first!")
1160 unless defined $host_fd;
1161 vec($wbits, $host_fd, 1) = 1;
1162 } else {
1163 # No $host passed so scan all hosts
1164 # Use the latest stop_time
1165 $stop_time = $self->{"stop_time"};
1166 # Use all the bits
1167 $wbits = $self->{"wbits"};
1168 }
1169
9c36735d 1170 while ($wbits !~ /^\0*\z/) {
f569508e
HS
1171 my $timeout = $stop_time - &time();
1172 # Force a minimum of 10 ms timeout.
69c74a9c
HS
1173 $timeout = 0.01 if $timeout <= 0.01;
1174
1175 my $winner_fd = undef;
1176 my $wout = $wbits;
1177 my $fd = 0;
1178 # Do "bad" fds from $wbits first
9c36735d 1179 while ($wout !~ /^\0*\z/) {
69c74a9c
HS
1180 if (vec($wout, $fd, 1)) {
1181 # Wipe it from future scanning.
1182 vec($wout, $fd, 1) = 0;
1183 if (my $entry = $self->{"syn"}->{$fd}) {
1184 if ($self->{"bad"}->{ $entry->[0] }) {
1185 $winner_fd = $fd;
1186 last;
1187 }
1188 }
1189 }
1190 $fd++;
1191 }
1192
eb194dd9 1193 if (defined($winner_fd) or my $nfound = mselect(undef, ($wout=$wbits), undef, $timeout)) {
69c74a9c
HS
1194 if (defined $winner_fd) {
1195 $fd = $winner_fd;
1196 } else {
1197 # Done waiting for one of the ACKs
1198 $fd = 0;
1199 # Determine which one
9c36735d 1200 while ($wout !~ /^\0*\z/ &&
69c74a9c
HS
1201 !vec($wout, $fd, 1)) {
1202 $fd++;
1203 }
f569508e
HS
1204 }
1205 if (my $entry = $self->{"syn"}->{$fd}) {
69c74a9c
HS
1206 # Wipe it from future scanning.
1207 delete $self->{"syn"}->{$fd};
1208 vec($self->{"wbits"}, $fd, 1) = 0;
1209 vec($wbits, $fd, 1) = 0;
c94ff782 1210 if (!$self->{"econnrefused"} &&
69c74a9c
HS
1211 $self->{"bad"}->{ $entry->[0] } &&
1212 (($! = ECONNREFUSED)>0) &&
1213 $self->{"bad"}->{ $entry->[0] } eq "$!") {
1214 # "Connection refused" means reachable
1215 # Good, continue
1216 } elsif (getpeername($entry->[2])) {
f569508e 1217 # Connection established to remote host
69c74a9c 1218 # Good, continue
f569508e
HS
1219 } else {
1220 # TCP ACK will never come from this host
1221 # because there was an error connecting.
1222
f569508e
HS
1223 # This should set $! to the correct error.
1224 my $char;
9c36735d 1225 sysread($entry->[2],$char,1);
f569508e
HS
1226 # Store the excuse why the connection failed.
1227 $self->{"bad"}->{$entry->[0]} = $!;
c94ff782 1228 if (!$self->{"econnrefused"} &&
69c74a9c
HS
1229 (($! == ECONNREFUSED) ||
1230 ($! == EAGAIN && $^O =~ /cygwin/i))) {
f569508e 1231 # "Connection refused" means reachable
69c74a9c
HS
1232 # Good, continue
1233 } else {
1234 # No good, try the next socket...
1235 next;
f569508e 1236 }
f569508e 1237 }
69c74a9c
HS
1238 # Everything passed okay, return the answer
1239 return wantarray ?
1240 ($entry->[0], &time() - $entry->[3], inet_ntoa($entry->[1]))
1241 : $entry->[0];
f569508e
HS
1242 } else {
1243 warn "Corrupted SYN entry: unknown fd [$fd] ready!";
1244 vec($wbits, $fd, 1) = 0;
1245 vec($self->{"wbits"}, $fd, 1) = 0;
1246 }
1247 } elsif (defined $nfound) {
1248 # Timed out waiting for ACK
1249 foreach my $fd (keys %{ $self->{"syn"} }) {
1250 if (vec($wbits, $fd, 1)) {
1251 my $entry = $self->{"syn"}->{$fd};
1252 $self->{"bad"}->{$entry->[0]} = "Timed out";
1253 vec($wbits, $fd, 1) = 0;
1254 vec($self->{"wbits"}, $fd, 1) = 0;
1255 delete $self->{"syn"}->{$fd};
1256 }
1257 }
1258 } else {
1259 # Weird error occurred with select()
1260 warn("select: $!");
1261 $self->{"syn"} = {};
1262 $wbits = "";
1263 }
1264 }
1265 }
1266 return ();
1267}
1268
1269sub ack_unfork {
69c74a9c 1270 my ($self,$host) = @_;
f569508e 1271 my $stop_time = $self->{"stop_time"};
69c74a9c 1272 if ($host) {
f569508e 1273 # Host passed as arg
69c74a9c
HS
1274 if (my $entry = $self->{"good"}->{$host}) {
1275 delete $self->{"good"}->{$host};
1276 return ($entry->[0], &time() - $entry->[3], inet_ntoa($entry->[1]));
1277 }
f569508e
HS
1278 }
1279
1280 my $rbits = "";
1281 my $timeout;
69c74a9c 1282
f569508e
HS
1283 if (keys %{ $self->{"syn"} }) {
1284 # Scan all hosts that are left
1285 vec($rbits, fileno($self->{"fork_rd"}), 1) = 1;
1286 $timeout = $stop_time - &time();
69c74a9c
HS
1287 # Force a minimum of 10 ms timeout.
1288 $timeout = 0.01 if $timeout < 0.01;
f569508e
HS
1289 } else {
1290 # No hosts left to wait for
1291 $timeout = 0;
1292 }
1293
1294 if ($timeout > 0) {
69c74a9c
HS
1295 my $nfound;
1296 while ( keys %{ $self->{"syn"} } and
eb194dd9 1297 $nfound = mselect((my $rout=$rbits), undef, undef, $timeout)) {
f569508e 1298 # Done waiting for one of the ACKs
9c36735d 1299 if (!sysread($self->{"fork_rd"}, $_, 16)) {
f569508e
HS
1300 # Socket closed, which means all children are done.
1301 return ();
1302 }
1303 my ($pid, $how) = split;
1304 if ($pid) {
1305 # Flush the zombie
1306 waitpid($pid, 0);
1307 if (my $entry = $self->{"syn"}->{$pid}) {
1308 # Connection attempt to remote host is done
1309 delete $self->{"syn"}->{$pid};
1310 if (!$how || # If there was no error connecting
c94ff782 1311 (!$self->{"econnrefused"} &&
f569508e 1312 $how == ECONNREFUSED)) { # "Connection refused" means reachable
69c74a9c
HS
1313 if ($host && $entry->[0] ne $host) {
1314 # A good connection, but not the host we need.
1315 # Move it from the "syn" hash to the "good" hash.
1316 $self->{"good"}->{$entry->[0]} = $entry;
1317 # And wait for the next winner
1318 next;
1319 }
f569508e
HS
1320 return ($entry->[0], &time() - $entry->[3], inet_ntoa($entry->[1]));
1321 }
1322 } else {
1323 # Should never happen
1324 die "Unknown ping from pid [$pid]";
1325 }
1326 } else {
1327 die "Empty response from status socket?";
1328 }
69c74a9c
HS
1329 }
1330 if (defined $nfound) {
f569508e
HS
1331 # Timed out waiting for ACK status
1332 } else {
1333 # Weird error occurred with select()
1334 warn("select: $!");
1335 }
1336 }
1337 if (my @synners = keys %{ $self->{"syn"} }) {
1338 # Kill all the synners
1339 kill 9, @synners;
1340 foreach my $pid (@synners) {
1341 # Wait for the deaths to finish
1342 # Then flush off the zombie
1343 waitpid($pid, 0);
1344 }
1345 }
1346 $self->{"syn"} = {};
1347 return ();
1348}
1349
1350# Description: Tell why the ack() failed
1351sub nack {
1352 my $self = shift;
1353 my $host = shift || croak('Usage> nack($failed_ack_host)');
1354 return $self->{"bad"}->{$host} || undef;
1355}
1356
1357# Description: Close the connection.
a3b93737
RM
1358
1359sub close
1360{
e82f584b 1361 my ($self) = @_;
a3b93737 1362
f569508e
HS
1363 if ($self->{"proto"} eq "syn") {
1364 delete $self->{"syn"};
1365 } elsif ($self->{"proto"} eq "tcp") {
1366 # The connection will already be closed
1367 } else {
1368 $self->{"fh"}->close();
1369 }
a3b93737
RM
1370}
1371
1372
a0d0e21e 13731;
8e07c86e
AD
1374__END__
1375
8e07c86e
AD
1376=head1 NAME
1377
a3b93737 1378Net::Ping - check a remote host for reachability
8e07c86e
AD
1379
1380=head1 SYNOPSIS
1381
1382 use Net::Ping;
8e07c86e 1383
a3b93737
RM
1384 $p = Net::Ping->new();
1385 print "$host is alive.\n" if $p->ping($host);
1386 $p->close();
1387
1388 $p = Net::Ping->new("icmp");
49afa5f6 1389 $p->bind($my_addr); # Specify source interface of pings
a3b93737
RM
1390 foreach $host (@host_array)
1391 {
1392 print "$host is ";
1393 print "NOT " unless $p->ping($host, 2);
1394 print "reachable.\n";
1395 sleep(1);
1396 }
1397 $p->close();
b124990b 1398
a3b93737 1399 $p = Net::Ping->new("tcp", 2);
b124990b
JH
1400 # Try connecting to the www port instead of the echo port
1401 $p->{port_num} = getservbyname("http", "tcp");
a3b93737
RM
1402 while ($stop_time > time())
1403 {
1404 print "$host not reachable ", scalar(localtime()), "\n"
1405 unless $p->ping($host);
1406 sleep(300);
1407 }
1408 undef($p);
b124990b 1409
f569508e
HS
1410 # Like tcp protocol, but with many hosts
1411 $p = Net::Ping->new("syn");
1412 $p->{port_num} = getservbyname("http", "tcp");
1413 foreach $host (@host_array) {
1414 $p->ping($host);
1415 }
1416 while (($host,$rtt,$ip) = $p->ack) {
1417 print "HOST: $host [$ip] ACKed in $rtt seconds.\n";
1418 }
1419
e82f584b
JH
1420 # High precision syntax (requires Time::HiRes)
1421 $p = Net::Ping->new();
1422 $p->hires();
1423 ($ret, $duration, $ip) = $p->ping($host, 5.5);
1424 printf("$host [ip: $ip] is alive (packet return time: %.2f ms)\n", 1000 * $duration)
1425 if $ret;
1426 $p->close();
1427
a3b93737
RM
1428 # For backward compatibility
1429 print "$host is alive.\n" if pingecho($host);
8e07c86e 1430
a3b93737 1431=head1 DESCRIPTION
8e07c86e 1432
a3b93737
RM
1433This module contains methods to test the reachability of remote
1434hosts on a network. A ping object is first created with optional
1435parameters, a variable number of hosts may be pinged multiple
1436times and then the connection is closed.
1437
f569508e
HS
1438You may choose one of six different protocols to use for the
1439ping. The "tcp" protocol is the default. Note that a live remote host
b124990b 1440may still fail to be pingable by one or more of these protocols. For
f569508e 1441example, www.microsoft.com is generally alive but not "icmp" pingable.
787ecdfa 1442
b124990b
JH
1443With the "tcp" protocol the ping() method attempts to establish a
1444connection to the remote host's echo port. If the connection is
1445successfully established, the remote host is considered reachable. No
1446data is actually echoed. This protocol does not require any special
9c36735d 1447privileges but has higher overhead than the "udp" and "icmp" protocols.
072620d9 1448
b124990b 1449Specifying the "udp" protocol causes the ping() method to send a udp
a3b93737
RM
1450packet to the remote host's echo port. If the echoed packet is
1451received from the remote host and the received packet contains the
1452same data as the packet that was sent, the remote host is considered
1453reachable. This protocol does not require any special privileges.
b124990b 1454It should be borne in mind that, for a udp ping, a host
787ecdfa 1455will be reported as unreachable if it is not running the
b124990b
JH
1456appropriate echo service. For Unix-like systems see L<inetd(8)>
1457for more information.
787ecdfa 1458
b124990b
JH
1459If the "icmp" protocol is specified, the ping() method sends an icmp
1460echo message to the remote host, which is what the UNIX ping program
1461does. If the echoed message is received from the remote host and
1462the echoed information is correct, the remote host is considered
1463reachable. Specifying the "icmp" protocol requires that the program
1464be run as root or that the program be setuid to root.
787ecdfa 1465
b124990b
JH
1466If the "external" protocol is specified, the ping() method attempts to
1467use the C<Net::Ping::External> module to ping the remote host.
1468C<Net::Ping::External> interfaces with your system's default C<ping>
1469utility to perform the ping, and generally produces relatively
787ecdfa
JH
1470accurate results. If C<Net::Ping::External> if not installed on your
1471system, specifying the "external" protocol will result in an error.
edc5bd88 1472
f569508e
HS
1473If the "syn" protocol is specified, the ping() method will only
1474send a TCP SYN packet to the remote host then immediately return.
1475If the syn packet was sent successfully, it will return a true value,
1476otherwise it will return false. NOTE: Unlike the other protocols,
1477the return value does NOT determine if the remote host is alive or
1478not since the full TCP three-way handshake may not have completed
1479yet. The remote host is only considered reachable if it receives
3c4b39be 1480a TCP ACK within the timeout specified. To begin waiting for the
f569508e
HS
1481ACK packets, use the ack() method as explained below. Use the
1482"syn" protocol instead the "tcp" protocol to determine reachability
1483of multiple destinations simultaneously by sending parallel TCP
1484SYN packets. It will not block while testing each remote host.
1485demo/fping is provided in this distribution to demonstrate the
1486"syn" protocol as an example.
1487This protocol does not require any special privileges.
1488
a3b93737
RM
1489=head2 Functions
1490
1491=over 4
1492
03550e9d 1493=item Net::Ping->new([$proto [, $def_timeout [, $bytes [, $device [, $tos ]]]]]);
a3b93737
RM
1494
1495Create a new ping object. All of the parameters are optional. $proto
1496specifies the protocol to use when doing a ping. The current choices
f569508e
HS
1497are "tcp", "udp", "icmp", "stream", "syn", or "external".
1498The default is "tcp".
a3b93737
RM
1499
1500If a default timeout ($def_timeout) in seconds is provided, it is used
1501when a timeout is not given to the ping() method (below). The timeout
1502must be greater than 0 and the default, if not specified, is 5 seconds.
1503
1504If the number of data bytes ($bytes) is given, that many data bytes
1505are included in the ping packet sent to the remote host. The number of
1506data bytes is ignored if the protocol is "tcp". The minimum (and
1507default) number of data bytes is 1 if the protocol is "udp" and 0
1508otherwise. The maximum number of data bytes that can be specified is
15091024.
1510
f569508e 1511If $device is given, this device is used to bind the source endpoint
3c4b39be 1512before sending the ping packet. I believe this only works with
f569508e
HS
1513superuser privileges and with udp and icmp protocols at this time.
1514
3c4b39be 1515If $tos is given, this ToS is configured into the socket.
03550e9d 1516
5d20095f
JH
1517=item $p->ping($host [, $timeout]);
1518
1519Ping the remote host and wait for a response. $host can be either the
1520hostname or the IP number of the remote host. The optional timeout
1521must be greater than 0 seconds and defaults to whatever was specified
1522when the ping object was created. Returns a success flag. If the
1523hostname cannot be found or there is a problem with the IP number, the
1524success flag returned will be undef. Otherwise, the success flag will
1525be 1 if the host is reachable and 0 if it is not. For most practical
1526purposes, undef and 0 and can be treated as the same case. In array
f569508e
HS
1527context, the elapsed time as well as the string form of the ip the
1528host resolved to are also returned. The elapsed time value will
5d20095f
JH
1529be a float, as retuned by the Time::HiRes::time() function, if hires()
1530has been previously called, otherwise it is returned as an integer.
1531
15d96390
JH
1532=item $p->source_verify( { 0 | 1 } );
1533
1534Allows source endpoint verification to be enabled or disabled.
1535This is useful for those remote destinations with multiples
1536interfaces where the response may not originate from the same
1537endpoint that the original destination endpoint was sent to.
5d20095f 1538This only affects udp and icmp protocol pings.
15d96390
JH
1539
1540This is enabled by default.
1541
c94ff782 1542=item $p->service_check( { 0 | 1 } );
f569508e 1543
c94ff782 1544Set whether or not the connect behavior should enforce
f569508e
HS
1545remote service availability as well as reachability. Normally,
1546if the remote server reported ECONNREFUSED, it must have been
1547reachable because of the status packet that it reported.
1548With this option enabled, the full three-way tcp handshake
1549must have been established successfully before it will
1550claim it is reachable. NOTE: It still does nothing more
1551than connect and disconnect. It does not speak any protocol
1552(i.e., HTTP or FTP) to ensure the remote server is sane in
1553any way. The remote server CPU could be grinding to a halt
1554and unresponsive to any clients connecting, but if the kernel
1555throws the ACK packet, it is considered alive anyway. To
1556really determine if the server is responding well would be
1557application specific and is beyond the scope of Net::Ping.
c94ff782
JH
1558For udp protocol, enabling this option demands that the
1559remote server replies with the same udp data that it was sent
1560as defined by the udp echo service.
f569508e 1561
c94ff782 1562This affects the "udp", "tcp", and "syn" protocols.
f569508e
HS
1563
1564This is disabled by default.
1565
c94ff782
JH
1566=item $p->tcp_service_check( { 0 | 1 } );
1567
3c4b39be 1568Deprecated method, but does the same as service_check() method.
c94ff782 1569
e82f584b
JH
1570=item $p->hires( { 0 | 1 } );
1571
1572Causes this module to use Time::HiRes module, allowing milliseconds
1573to be returned by subsequent calls to ping().
1574
15d96390
JH
1575This is disabled by default.
1576
49afa5f6
JH
1577=item $p->bind($local_addr);
1578
1579Sets the source address from which pings will be sent. This must be
1580the address of one of the interfaces on the local host. $local_addr
1581may be specified as a hostname or as a text IP address such as
1582"192.168.1.1".
1583
1584If the protocol is set to "tcp", this method may be called any
1585number of times, and each call to the ping() method (below) will use
1586the most recent $local_addr. If the protocol is "icmp" or "udp",
1587then bind() must be called at most once per object, and (if it is
1588called at all) must be called before the first call to ping() for that
1589object.
1590
b124990b
JH
1591=item $p->open($host);
1592
f569508e 1593When you are using the "stream" protocol, this call pre-opens the
b124990b
JH
1594tcp socket. It's only necessary to do this if you want to
1595provide a different timeout when creating the connection, or
1596remove the overhead of establishing the connection from the
1597first ping. If you don't call C<open()>, the connection is
1598automatically opened the first time C<ping()> is called.
787ecdfa
JH
1599This call simply does nothing if you are using any protocol other
1600than stream.
1601
f569508e
HS
1602=item $p->ack( [ $host ] );
1603
1604When using the "syn" protocol, use this method to determine
1605the reachability of the remote host. This method is meant
1606to be called up to as many times as ping() was called. Each
1607call returns the host (as passed to ping()) that came back
1608with the TCP ACK. The order in which the hosts are returned
1609may not necessarily be the same order in which they were
1610SYN queued using the ping() method. If the timeout is
1611reached before the TCP ACK is received, or if the remote
1612host is not listening on the port attempted, then the TCP
1613connection will not be established and ack() will return
1614undef. In list context, the host, the ack time, and the
1615dotted ip string will be returned instead of just the host.
1616If the optional $host argument is specified, the return
3c4b39be 1617value will be pertaining to that host only.
f569508e
HS
1618This call simply does nothing if you are using any protocol
1619other than syn.
1620
1621=item $p->nack( $failed_ack_host );
1622
1623The reason that host $failed_ack_host did not receive a
1624valid ACK. Useful to find out why when ack( $fail_ack_host )
1625returns a false value.
1626
a3b93737
RM
1627=item $p->close();
1628
1629Close the network connection for this ping object. The network
1630connection is also closed by "undef $p". The network connection is
1631automatically closed if the ping object goes out of scope (e.g. $p is
1632local to a subroutine and you leave the subroutine).
1633
1634=item pingecho($host [, $timeout]);
1635
1636To provide backward compatibility with the previous version of
1637Net::Ping, a pingecho() subroutine is available with the same
1638functionality as before. pingecho() uses the tcp protocol. The
1639return values and parameters are the same as described for the ping()
1640method. This subroutine is obsolete and may be removed in a future
1641version of Net::Ping.
8e07c86e 1642
a3b93737 1643=back
8e07c86e 1644
a3b93737 1645=head1 NOTES
8e07c86e 1646
a3b93737
RM
1647There will be less network overhead (and some efficiency in your
1648program) if you specify either the udp or the icmp protocol. The tcp
1649protocol will generate 2.5 times or more traffic for each ping than
1650either udp or icmp. If many hosts are pinged frequently, you may wish
1651to implement a small wait (e.g. 25ms or more) between each ping to
1652avoid flooding your network with packets.
8e07c86e 1653
a3b93737 1654The icmp protocol requires that the program be run as root or that it
787ecdfa
JH
1655be setuid to root. The other protocols do not require special
1656privileges, but not all network devices implement tcp or udp echo.
8e07c86e 1657
a3b93737
RM
1658Local hosts should normally respond to pings within milliseconds.
1659However, on a very congested network it may take up to 3 seconds or
1660longer to receive an echo packet from the remote host. If the timeout
1661is set too low under these conditions, it will appear that the remote
1662host is not reachable (which is almost the truth).
8e07c86e 1663
a3b93737 1664Reachability doesn't necessarily mean that the remote host is actually
787ecdfa
JH
1665functioning beyond its ability to echo packets. tcp is slightly better
1666at indicating the health of a system than icmp because it uses more
1667of the networking stack to respond.
8e07c86e 1668
a3b93737
RM
1669Because of a lack of anything better, this module uses its own
1670routines to pack and unpack ICMP packets. It would be better for a
1671separate module to be written which understands all of the different
1672kinds of ICMP packets.
8e07c86e 1673
5d20095f
JH
1674=head1 INSTALL
1675
1676The latest source tree is available via cvs:
1677
f569508e 1678 cvs -z3 -q -d :pserver:anonymous@cvs.roobik.com.:/usr/local/cvsroot/freeware checkout Net-Ping
5d20095f
JH
1679 cd Net-Ping
1680
1681The tarball can be created as follows:
1682
1683 perl Makefile.PL ; make ; make dist
1684
1685The latest Net::Ping release can be found at CPAN:
1686
1687 $CPAN/modules/by-module/Net/
1688
16891) Extract the tarball
1690
1691 gtar -zxvf Net-Ping-xxxx.tar.gz
1692 cd Net-Ping-xxxx
1693
16942) Build:
1695
1696 make realclean
1697 perl Makefile.PL
1698 make
1699 make test
1700
17013) Install
1702
1703 make install
1704
1705Or install it RPM Style:
1706
1707 rpm -ta SOURCES/Net-Ping-xxxx.tar.gz
1708
1709 rpm -ih RPMS/noarch/perl-Net-Ping-xxxx.rpm
1710
c94ff782
JH
1711=head1 BUGS
1712
1713For a list of known issues, visit:
1714
1715https://rt.cpan.org/NoAuth/Bugs.html?Dist=Net-Ping
1716
1717To report a new bug, visit:
1718
1719https://rt.cpan.org/NoAuth/ReportBug.html?Queue=Net-Ping
1720
49afa5f6 1721=head1 AUTHORS
b124990b 1722
e82f584b 1723 Current maintainer:
49afa5f6 1724 bbb@cpan.org (Rob Brown)
b124990b 1725
e82f584b
JH
1726 External protocol:
1727 colinm@cpan.org (Colin McMillen)
1728
b124990b
JH
1729 Stream protocol:
1730 bronson@trestle.com (Scott Bronson)
1731
1732 Original pingecho():
1733 karrer@bernina.ethz.ch (Andreas Karrer)
1734 pmarquess@bfsec.bt.co.uk (Paul Marquess)
1735
1736 Original Net::Ping author:
1737 mose@ns.ccsn.edu (Russell Mosemann)
1738
b124990b
JH
1739=head1 COPYRIGHT
1740
9c36735d 1741Copyright (c) 2002-2003, Rob Brown. All rights reserved.
49afa5f6 1742
e82f584b 1743Copyright (c) 2001, Colin McMillen. All rights reserved.
b124990b
JH
1744
1745This program is free software; you may redistribute it and/or
1746modify it under the same terms as Perl itself.
1747
03550e9d 1748$Id: Ping.pm,v 1.86 2003/06/27 21:31:07 rob Exp $
c94ff782 1749
a3b93737 1750=cut