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