This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Update Net::Ping to upstream version 2.71
[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;
1a58b39a 7our $hires;
f569508e 8use Fcntl qw( F_GETFL F_SETFL O_NONBLOCK );
773d126d
CBW		 9use Socket qw( SOCK_DGRAM SOCK_STREAM SOCK_RAW AF_INET PF_INET IPPROTO_TCP
10 SOL_SOCKET SO_ERROR SO_BROADCAST
11 IPPROTO_IP IP_TOS IP_TTL
8c91ebab 12 inet_ntoa inet_aton getnameinfo sockaddr_in );
773d126d
CBW		 13use POSIX qw( ENOTCONN ECONNREFUSED ECONNRESET EINPROGRESS EWOULDBLOCK EAGAIN
14 WNOHANG );
f569508e 15use FileHandle;
a3b93737 16use Carp;
4e0aac35 17use Time::HiRes;
a79c1648 18
1a58b39a
N		 19our @ISA = qw(Exporter);
20our @EXPORT = qw(pingecho);
21our @EXPORT_OK = qw(wakeonlan);
2e598186 22our $VERSION = "2.71";
a0d0e21e 23
773d126d 24# Globals
a0d0e21e 25
1a58b39a
N		 26our $def_timeout = 5; # Default timeout to wait for a reply
27our $def_proto = "tcp"; # Default protocol to use for pinging
28our $def_factor = 1.2; # Default exponential backoff rate.
29our $def_family = AF_INET; # Default family.
2e598186 30our $max_datasize = 65535; # Maximum data bytes. recommended: 1472 (Ethernet MTU: 1500)
b124990b 31# The data we exchange with the server for the stream protocol
1a58b39a
N		 32our $pingstring = "pingschwingping!\n";
33our $source_verify = 1; # Default is to verify source endpoint
34our $syn_forking = 0;
a0d0e21e 35
773d126d
CBW		 36# Constants
37
8c91ebab 38my $AF_INET6 = eval { Socket::AF_INET6() } || 30;
773d126d 39my $AF_UNSPEC = eval { Socket::AF_UNSPEC() };
8c91ebab
SH		 40my $AI_NUMERICHOST = eval { Socket::AI_NUMERICHOST() } || 4;
41my $NI_NUMERICHOST = eval { Socket::NI_NUMERICHOST() } || 2;
42my $IPPROTO_IPV6 = eval { Socket::IPPROTO_IPV6() } || 41;
2e598186 43my $NIx_NOSERV = eval { Socket::NIx_NOSERV() } || 2;
773d126d
CBW		 44#my $IPV6_HOPLIMIT = eval { Socket::IPV6_HOPLIMIT() }; # ping6 -h 0-255
45my $qr_family = qr/^(?:(?:(:?ip)?v?(?:4|6))|${\AF_INET}|$AF_INET6)$/;
46my $qr_family4 = qr/^(?:(?:(:?ip)?v?4)|${\AF_INET})$/;
2e598186 47my $Socket_VERSION = eval { $Socket::VERSION };
773d126d 48
ef73e1db
JH		 49if ($^O =~ /Win32/i) {
50 # Hack to avoid this Win32 spewage:
51 # Your vendor has not defined POSIX macro ECONNREFUSED
5d6b07c5
NC		 52 my @pairs = (ECONNREFUSED => 10061, # "Unknown Error" Special Win32 Response?
53 ENOTCONN => 10057,
54 ECONNRESET => 10054,
55 EINPROGRESS => 10036,
56 EWOULDBLOCK => 10035,
57 );
58 while (my $name = shift @pairs) {
59 my $value = shift @pairs;
60 # When defined, these all are non-zero
61 unless (eval $name) {
62 no strict 'refs';
63 *{$name} = defined prototype \&{$name} ? sub () {$value} : sub {$value};
64 }
65 }
eb194dd9 66# $syn_forking = 1; # XXX possibly useful in < Win2K ?
ef73e1db
JH		 67};
68
a3b93737
RM		 69# Description: The pingecho() subroutine is provided for backward
70# compatibility with the original Net::Ping. It accepts a host
71# name/IP and an optional timeout in seconds. Create a tcp ping
72# object and try pinging the host. The result of the ping is returned.
a0d0e21e 73
a3b93737
RM		 74sub pingecho
75{
e82f584b
JH		 76 my ($host, # Name or IP number of host to ping
77 $timeout # Optional timeout in seconds
78 ) = @_;
79 my ($p); # A ping object
a0d0e21e 80
e82f584b
JH		 81 $p = Net::Ping->new("tcp", $timeout);
82 $p->ping($host); # Going out of scope closes the connection
a3b93737 83}
a0d0e21e 84
a3b93737
RM		 85# Description: The new() method creates a new ping object. Optional
86# parameters may be specified for the protocol to use, the timeout in
87# seconds and the size in bytes of additional data which should be
88# included in the packet.
89# After the optional parameters are checked, the data is constructed
90# and a socket is opened if appropriate. The object is returned.
91
92sub new
93{
e82f584b
JH		 94 my ($this,
95 $proto, # Optional protocol to use for pinging
96 $timeout, # Optional timeout in seconds
f569508e
HS		 97 $data_size, # Optional additional bytes of data
98 $device, # Optional device to use
03550e9d 99 $tos, # Optional ToS to set
1bd59f2c 100 $ttl, # Optional TTL to set
773d126d 101 $family, # Optional address family (AF_INET)
e82f584b
JH		 102 ) = @_;
103 my $class = ref($this) || $this;
104 my $self = {};
105 my ($cnt, # Count through data bytes
106 $min_datasize # Minimum data bytes required
107 );
108
109 bless($self, $class);
773d126d
CBW		 110 if (ref $proto eq 'HASH') { # support named args
111 for my $k (qw(proto timeout data_size device tos ttl family
112 gateway host port bind retrans pingstring source_verify
113 econnrefused dontfrag
114 IPV6_USE_MIN_MTU IPV6_RECVPATHMTU IPV6_HOPLIMIT))
115 {
116 if (exists $proto->{$k}) {
117 $self->{$k} = $proto->{$k};
118 # some are still globals
119 if ($k eq 'pingstring') { $pingstring = $proto->{$k} }
120 if ($k eq 'source_verify') { $source_verify = $proto->{$k} }
121 delete $proto->{$k};
122 }
123 }
124 if (%$proto) {
125 croak("Invalid named argument: ",join(" ",keys (%$proto)));
126 }
127 $proto = $self->{'proto'};
128 }
e82f584b
JH		 129
130 $proto = $def_proto unless $proto; # Determine the protocol
773d126d
CBW		 131 croak('Protocol for ping must be "icmp", "icmpv6", "udp", "tcp", "syn", "stream" or "external"')
132 unless $proto =~ m/^(icmp|icmpv6|udp|tcp|syn|stream|external)$/;
26e9d721 133 $self->{proto} = $proto;
e82f584b 134
2e598186 135 $timeout = $def_timeout unless defined $timeout; # Determine the timeout
e82f584b
JH		 136 croak("Default timeout for ping must be greater than 0 seconds")
137 if $timeout <= 0;
26e9d721 138 $self->{timeout} = $timeout;
e82f584b 139
26e9d721 140 $self->{device} = $device;
f569508e 141
26e9d721 142 $self->{tos} = $tos;
03550e9d 143
773d126d
CBW		 144 if ($self->{'host'}) {
145 my $host = $self->{'host'};
2e598186
N		 146 my $ip = _resolv($host) or
147 carp("could not resolve host $host");
773d126d
CBW		 148 $self->{host} = $ip;
149 $self->{family} = $ip->{family};
150 }
151
152 if ($self->{bind}) {
153 my $addr = $self->{bind};
154 my $ip = _resolv($addr)
2e598186 155 or carp("could not resolve local addr $addr");
773d126d
CBW		 156 $self->{local_addr} = $ip;
157 } else {
158 $self->{local_addr} = undef; # Don't bind by default
159 }
160
161 if ($self->{proto} eq 'icmp') {
1bd59f2c
SP		 162 croak('TTL must be from 0 to 255')
163 if ($ttl && ($ttl < 0 || $ttl > 255));
773d126d
CBW		 164 $self->{ttl} = $ttl;
165 }
166
167 if ($family) {
168 if ($family =~ $qr_family) {
169 if ($family =~ $qr_family4) {
26e9d721 170 $self->{family} = AF_INET;
773d126d 171 } else {
26e9d721 172 $self->{family} = $AF_INET6;
773d126d
CBW		 173 }
174 } else {
175 croak('Family must be "ipv4" or "ipv6"')
176 }
177 } else {
2e598186
N		 178 if ($self->{proto} eq 'icmpv6') {
179 $self->{family} = $AF_INET6;
180 } else {
181 $self->{family} = $def_family;
182 }
1bd59f2c
SP		 183 }
184
e82f584b
JH		 185 $min_datasize = ($proto eq "udp") ? 1 : 0; # Determine data size
186 $data_size = $min_datasize unless defined($data_size) && $proto ne "tcp";
2e598186 187 # allow for fragmented packets if data_size>1472 (MTU 1500)
e82f584b
JH		 188 croak("Data for ping must be from $min_datasize to $max_datasize bytes")
189 if ($data_size < $min_datasize) || ($data_size > $max_datasize);
26e9d721
SH		 190 $data_size-- if $self->{proto} eq "udp"; # We provide the first byte
191 $self->{data_size} = $data_size;
e82f584b 192
26e9d721
SH		 193 $self->{data} = ""; # Construct data bytes
194 for ($cnt = 0; $cnt < $self->{data_size}; $cnt++)
e82f584b 195 {
26e9d721 196 $self->{data} .= chr($cnt % 256);
e82f584b
JH		 197 }
198
773d126d 199 # Default exponential backoff rate
26e9d721 200 $self->{retrans} = $def_factor unless exists $self->{retrans};
773d126d 201 # Default Connection refused behavior
26e9d721 202 $self->{econnrefused} = undef unless exists $self->{econnrefused};
f569508e 203
26e9d721
SH		 204 $self->{seq} = 0; # For counting packets
205 if ($self->{proto} eq "udp") # Open a socket
e82f584b 206 {
26e9d721 207 $self->{proto_num} = eval { (getprotobyname('udp'))[2] } ||
e82f584b 208 croak("Can't udp protocol by name");
26e9d721 209 $self->{port_num} = $self->{port}
773d126d
CBW		 210 || (getservbyname('echo', 'udp'))[2]
211 || croak("Can't get udp echo port by name");
26e9d721
SH		 212 $self->{fh} = FileHandle->new();
213 socket($self->{fh}, PF_INET, SOCK_DGRAM,
214 $self->{proto_num}) ||
e82f584b 215 croak("udp socket error - $!");
773d126d 216 $self->_setopts();
e82f584b 217 }
26e9d721 218 elsif ($self->{proto} eq "icmp")
e82f584b 219 {
773d126d 220 croak("icmp ping requires root privilege") if !_isroot();
26e9d721 221 $self->{proto_num} = eval { (getprotobyname('icmp'))[2] } ||
e82f584b 222 croak("Can't get icmp protocol by name");
26e9d721
SH		 223 $self->{pid} = $$ & 0xffff; # Save lower 16 bits of pid
224 $self->{fh} = FileHandle->new();
225 socket($self->{fh}, PF_INET, SOCK_RAW, $self->{proto_num}) ||
e82f584b 226 croak("icmp socket error - $!");
773d126d
CBW		 227 $self->_setopts();
228 if ($self->{'ttl'}) {
26e9d721 229 setsockopt($self->{fh}, IPPROTO_IP, IP_TTL, pack("I*", $self->{'ttl'}))
773d126d
CBW		 230 or croak "error configuring ttl to $self->{'ttl'} $!";
231 }
232 }
26e9d721 233 elsif ($self->{proto} eq "icmpv6")
773d126d 234 {
2e598186 235 #croak("icmpv6 ping requires root privilege") if !_isroot();
773d126d 236 croak("Wrong family $self->{family} for icmpv6 protocol")
26e9d721
SH		 237 if $self->{family} and $self->{family} != $AF_INET6;
238 $self->{family} = $AF_INET6;
239 $self->{proto_num} = eval { (getprotobyname('ipv6-icmp'))[2] } ||
773d126d 240 croak("Can't get ipv6-icmp protocol by name"); # 58
26e9d721
SH		 241 $self->{pid} = $$ & 0xffff; # Save lower 16 bits of pid
242 $self->{fh} = FileHandle->new();
243 socket($self->{fh}, $AF_INET6, SOCK_RAW, $self->{proto_num}) ||
773d126d
CBW		 244 croak("icmp socket error - $!");
245 $self->_setopts();
246 if ($self->{'gateway'}) {
247 my $g = $self->{gateway};
248 my $ip = _resolv($g)
249 or croak("nonexistent gateway $g");
250 $self->{family} eq $AF_INET6
251 or croak("gateway requires the AF_INET6 family");
252 $ip->{family} eq $AF_INET6
253 or croak("gateway address needs to be IPv6");
254 my $IPV6_NEXTHOP = eval { Socket::IPV6_NEXTHOP() } || 48; # IPV6_3542NEXTHOP, or 21
26e9d721 255 setsockopt($self->{fh}, $IPPROTO_IPV6, $IPV6_NEXTHOP, _pack_sockaddr_in($ip))
773d126d
CBW		 256 or croak "error configuring gateway to $g NEXTHOP $!";
257 }
258 if (exists $self->{IPV6_USE_MIN_MTU}) {
259 my $IPV6_USE_MIN_MTU = eval { Socket::IPV6_USE_MIN_MTU() } || 42;
26e9d721 260 setsockopt($self->{fh}, $IPPROTO_IPV6, $IPV6_USE_MIN_MTU,
773d126d
CBW		 261 pack("I*", $self->{'IPV6_USE_MIN_MT'}))
262 or croak "error configuring IPV6_USE_MIN_MT} $!";
263 }
264 if (exists $self->{IPV6_RECVPATHMTU}) {
265 my $IPV6_RECVPATHMTU = eval { Socket::IPV6_RECVPATHMTU() } || 43;
26e9d721 266 setsockopt($self->{fh}, $IPPROTO_IPV6, $IPV6_RECVPATHMTU,
773d126d
CBW		 267 pack("I*", $self->{'RECVPATHMTU'}))
268 or croak "error configuring IPV6_RECVPATHMTU $!";
f569508e 269 }
03550e9d 270 if ($self->{'tos'}) {
773d126d 271 my $proto = $self->{family} == AF_INET ? IPPROTO_IP : $IPPROTO_IPV6;
26e9d721 272 setsockopt($self->{fh}, $proto, IP_TOS, pack("I*", $self->{'tos'}))
03550e9d
JH		 273 or croak "error configuring tos to $self->{'tos'} $!";
274 }
1bd59f2c 275 if ($self->{'ttl'}) {
773d126d 276 my $proto = $self->{family} == AF_INET ? IPPROTO_IP : $IPPROTO_IPV6;
26e9d721 277 setsockopt($self->{fh}, $proto, IP_TTL, pack("I*", $self->{'ttl'}))
1bd59f2c
SP		 278 or croak "error configuring ttl to $self->{'ttl'} $!";
279 }
e82f584b 280 }
26e9d721 281 elsif ($self->{proto} eq "tcp" || $self->{proto} eq "stream")
e82f584b 282 {
26e9d721 283 $self->{proto_num} = eval { (getprotobyname('tcp'))[2] } ||
e82f584b 284 croak("Can't get tcp protocol by name");
26e9d721 285 $self->{port_num} = $self->{port}
773d126d
CBW		 286 || (getservbyname('echo', 'tcp'))[2]
287 || croak("Can't get tcp echo port by name");
26e9d721 288 $self->{fh} = FileHandle->new();
e82f584b 289 }
26e9d721 290 elsif ($self->{proto} eq "syn")
f569508e 291 {
26e9d721 292 $self->{proto_num} = eval { (getprotobyname('tcp'))[2] } ||
f569508e 293 croak("Can't get tcp protocol by name");
26e9d721 294 $self->{port_num} = (getservbyname('echo', 'tcp'))[2] ||
f569508e
HS		 295 croak("Can't get tcp echo port by name");
296 if ($syn_forking) {
26e9d721
SH		 297 $self->{fork_rd} = FileHandle->new();
298 $self->{fork_wr} = FileHandle->new();
299 pipe($self->{fork_rd}, $self->{fork_wr});
300 $self->{fh} = FileHandle->new();
301 $self->{good} = {};
302 $self->{bad} = {};
f569508e 303 } else {
26e9d721
SH		 304 $self->{wbits} = "";
305 $self->{bad} = {};
f569508e 306 }
26e9d721
SH		 307 $self->{syn} = {};
308 $self->{stop_time} = 0;
f569508e 309 }
e82f584b
JH		 310
311 return($self);
a3b93737 312}
a0d0e21e 313
49afa5f6 314# Description: Set the local IP address from which pings will be sent.
773d126d
CBW		 315# For ICMP, UDP and TCP pings, just saves the address to be used when
316# the socket is opened. Returns non-zero if successful; croaks on error.
49afa5f6
JH		 317sub bind
318{
e82f584b
JH		 319 my ($self,
320 $local_addr # Name or IP number of local interface
321 ) = @_;
773d126d
CBW		 322 my ($ip, # Hash of addr (string), addr_in (packed), family
323 $h # resolved hash
e82f584b
JH		 324 );
325
326 croak("Usage: \$p->bind(\$local_addr)") unless @_ == 2;
26e9d721
SH		 327 croak("already bound") if defined($self->{local_addr}) &&
328 ($self->{proto} eq "udp" || $self->{proto} eq "icmp");
e82f584b 329
773d126d 330 $ip = $self->_resolv($local_addr);
2e598186 331 carp("nonexistent local address $local_addr") unless defined($ip);
26e9d721 332 $self->{local_addr} = $ip;
e82f584b 333
26e9d721
SH		 334 if (($self->{proto} ne "udp") &&
335 ($self->{proto} ne "icmp") &&
336 ($self->{proto} ne "tcp") &&
337 ($self->{proto} ne "syn"))
e82f584b
JH		 338 {
339 croak("Unknown protocol \"$self->{proto}\" in bind()");
340 }
341
342 return 1;
343}
49afa5f6 344
eb194dd9
GS		 345# Description: A select() wrapper that compensates for platform
346# peculiarities.
347sub mselect
348{
349 if ($_[3] > 0 and $^O eq 'MSWin32') {
350 # On windows, select() doesn't process the message loop,
351 # but sleep() will, allowing alarm() to interrupt the latter.
352 # So we chop up the timeout into smaller pieces and interleave
353 # select() and sleep() calls.
354 my $t = $_[3];
355 my $gran = 0.5; # polling granularity in seconds
356 my @args = @_;
357 while (1) {
358 $gran = $t if $gran > $t;
359 my $nfound = select($_[0], $_[1], $_[2], $gran);
95d3daf0 360 undef $nfound if $nfound == -1;
eb194dd9
GS		 361 $t -= $gran;
362 return $nfound if $nfound or !defined($nfound) or $t <= 0;
363
364 sleep(0);
365 ($_[0], $_[1], $_[2]) = @args;
366 }
367 }
368 else {
95d3daf0
RGS		 369 my $nfound = select($_[0], $_[1], $_[2], $_[3]);
370 undef $nfound if $nfound == -1;
371 return $nfound;
eb194dd9
GS		 372 }
373}
49afa5f6 374
3c4b39be 375# Description: Allow UDP source endpoint comparison to be
15d96390
JH		 376# skipped for those remote interfaces that do
377# not response from the same endpoint.
378
379sub source_verify
380{
381 my $self = shift;
5d20095f
JH		 382 $source_verify = 1 unless defined
383 ($source_verify = ((defined $self) && (ref $self)) ? shift() : $self);
15d96390
JH		 384}
385
c94ff782
JH		 386# Description: Set whether or not the connect
387# behavior should enforce remote service
388# availability as well as reachability.
f569508e 389
c94ff782 390sub service_check
f569508e
HS		 391{
392 my $self = shift;
26e9d721
SH		 393 $self->{econnrefused} = 1 unless defined
394 ($self->{econnrefused} = shift());
c94ff782
JH		 395}
396
397sub tcp_service_check
398{
399 service_check(@_);
f569508e
HS		 400}
401
9539e94f
JH		 402# Description: Set exponential backoff for retransmission.
403# Should be > 1 to retain exponential properties.
404# If set to 0, retransmissions are disabled.
405
406sub retrans
407{
408 my $self = shift;
26e9d721 409 $self->{retrans} = shift;
9539e94f
JH		 410}
411
773d126d
CBW		 412sub _IsAdminUser {
413 return unless $^O eq 'MSWin32' or $^O eq "cygwin";
414 return unless eval { require Win32 };
415 return unless defined &Win32::IsAdminUser;
416 return Win32::IsAdminUser();
417}
418
419sub _isroot {
420 if (($> and $^O ne 'VMS' and $^O ne 'cygwin')
421 or (($^O eq 'MSWin32' or $^O eq 'cygwin')
422 and !_IsAdminUser())
423 or ($^O eq 'VMS'
424 and (`write sys\$output f\$privilege("SYSPRV")` =~ m/FALSE/))) {
425 return 0;
426 }
427 else {
428 return 1;
429 }
430}
431
432# Description: Sets ipv6 reachability
433# REACHCONF was removed in RFC3542, ping6 -R supports it. requires root.
434
435sub IPV6_REACHCONF
436{
437 my $self = shift;
438 my $on = shift;
439 if ($on) {
440 my $reachconf = eval { Socket::IPV6_REACHCONF() };
441 if (!$reachconf) {
442 carp "IPV6_REACHCONF not supported on this platform";
443 return 0;
444 }
445 if (!_isroot()) {
446 carp "IPV6_REACHCONF requires root permissions";
447 return 0;
448 }
26e9d721 449 $self->{IPV6_REACHCONF} = 1;
773d126d
CBW		 450 }
451 else {
26e9d721 452 return $self->{IPV6_REACHCONF};
773d126d
CBW		 453 }
454}
455
456# Description: set it on or off.
457
458sub IPV6_USE_MIN_MTU
459{
460 my $self = shift;
461 my $on = shift;
462 if (defined $on) {
463 my $IPV6_USE_MIN_MTU = eval { Socket::IPV6_USE_MIN_MTU() } || 43;
464 #if (!$IPV6_USE_MIN_MTU) {
465 # carp "IPV6_USE_MIN_MTU not supported on this platform";
466 # return 0;
467 #}
26e9d721
SH		 468 $self->{IPV6_USE_MIN_MTU} = $on ? 1 : 0;
469 setsockopt($self->{fh}, $IPPROTO_IPV6, $IPV6_USE_MIN_MTU,
773d126d
CBW		 470 pack("I*", $self->{'IPV6_USE_MIN_MT'}))
471 or croak "error configuring IPV6_USE_MIN_MT} $!";
472 }
473 else {
26e9d721 474 return $self->{IPV6_USE_MIN_MTU};
773d126d
CBW		 475 }
476}
477
478# Description: notify an according MTU
479
480sub IPV6_RECVPATHMTU
481{
482 my $self = shift;
483 my $on = shift;
484 if ($on) {
485 my $IPV6_RECVPATHMTU = eval { Socket::IPV6_RECVPATHMTU() } || 43;
486 #if (!$RECVPATHMTU) {
487 # carp "IPV6_RECVPATHMTU not supported on this platform";
488 # return 0;
489 #}
26e9d721
SH		 490 $self->{IPV6_RECVPATHMTU} = 1;
491 setsockopt($self->{fh}, $IPPROTO_IPV6, $IPV6_RECVPATHMTU,
773d126d
CBW		 492 pack("I*", $self->{'IPV6_RECVPATHMTU'}))
493 or croak "error configuring IPV6_RECVPATHMTU} $!";
494 }
495 else {
26e9d721 496 return $self->{IPV6_RECVPATHMTU};
773d126d
CBW		 497 }
498}
499
e82f584b
JH		 500# Description: allows the module to use milliseconds as returned by
501# the Time::HiRes module
49afa5f6 502
4e0aac35 503$hires = 1;
e82f584b
JH		 504sub hires
505{
506 my $self = shift;
507 $hires = 1 unless defined
508 ($hires = ((defined $self) && (ref $self)) ? shift() : $self);
49afa5f6
JH		 509}
510
e82f584b
JH		 511sub time
512{
513 return $hires ? Time::HiRes::time() : CORE::time();
514}
49afa5f6 515
9c36735d
JH		 516# Description: Sets or clears the O_NONBLOCK flag on a file handle.
517sub socket_blocking_mode
518{
519 my ($self,
520 $fh, # the file handle whose flags are to be modified
521 $block) = @_; # if true then set the blocking
522 # mode (clear O_NONBLOCK), otherwise
523 # set the non-blocking mode (set O_NONBLOCK)
524
525 my $flags;
d135e082
CB		 526 if ($^O eq 'MSWin32' || $^O eq 'VMS') {
527 # FIONBIO enables non-blocking sockets on windows and vms.
528 # FIONBIO is (0x80000000|(4<<16)|(ord('f')<<8)|126), as per winsock.h, ioctl.h
eb194dd9
GS		 529 my $f = 0x8004667e;
530 my $v = pack("L", $block ? 0 : 1);
531 ioctl($fh, $f, $v) or croak("ioctl failed: $!");
532 return;
533 }
9c36735d
JH		 534 if ($flags = fcntl($fh, F_GETFL, 0)) {
535 $flags = $block ? ($flags & ~O_NONBLOCK) : ($flags | O_NONBLOCK);
536 if (!fcntl($fh, F_SETFL, $flags)) {
537 croak("fcntl F_SETFL: $!");
538 }
539 } else {
540 croak("fcntl F_GETFL: $!");
541 }
542}
543
a3b93737
RM		 544# Description: Ping a host name or IP number with an optional timeout.
545# First lookup the host, and return undef if it is not found. Otherwise
b124990b 546# perform the specific ping method based on the protocol. Return the
a3b93737
RM		 547# result of the ping.
548
549sub ping
550{
e82f584b
JH		 551 my ($self,
552 $host, # Name or IP number of host to ping
553 $timeout, # Seconds after which ping times out
773d126d 554 $family, # Address family
e82f584b 555 ) = @_;
773d126d 556 my ($ip, # Hash of addr (string), addr_in (packed), family
e82f584b
JH		 557 $ret, # The return value
558 $ping_time, # When ping began
559 );
560
773d126d
CBW		 561 $host = $self->{host} if !defined $host and $self->{host};
562 croak("Usage: \$p->ping([ \$host [, \$timeout [, \$family]]])") if @_ > 4 or !$host;
26e9d721 563 $timeout = $self->{timeout} unless $timeout;
e82f584b
JH		 564 croak("Timeout must be greater than 0 seconds") if $timeout <= 0;
565
773d126d
CBW		 566 if ($family) {
567 if ($family =~ $qr_family) {
568 if ($family =~ $qr_family4) {
26e9d721 569 $self->{family_local} = AF_INET;
773d126d 570 } else {
26e9d721 571 $self->{family_local} = $AF_INET6;
773d126d
CBW		 572 }
573 } else {
574 croak('Family must be "ipv4" or "ipv6"')
575 }
576 } else {
26e9d721 577 $self->{family_local} = $self->{family};
773d126d
CBW		 578 }
579
580 $ip = $self->_resolv($host);
c94ff782 581 return () unless defined($ip); # Does host exist?
e82f584b
JH		 582
583 # Dispatch to the appropriate routine.
584 $ping_time = &time();
26e9d721 585 if ($self->{proto} eq "external") {
e82f584b
JH		 586 $ret = $self->ping_external($ip, $timeout);
587 }
26e9d721 588 elsif ($self->{proto} eq "udp") {
e82f584b
JH		 589 $ret = $self->ping_udp($ip, $timeout);
590 }
26e9d721 591 elsif ($self->{proto} eq "icmp") {
e82f584b
JH		 592 $ret = $self->ping_icmp($ip, $timeout);
593 }
26e9d721 594 elsif ($self->{proto} eq "icmpv6") {
773d126d
CBW		 595 $ret = $self->ping_icmpv6($ip, $timeout);
596 }
26e9d721 597 elsif ($self->{proto} eq "tcp") {
e82f584b
JH		 598 $ret = $self->ping_tcp($ip, $timeout);
599 }
26e9d721 600 elsif ($self->{proto} eq "stream") {
e82f584b 601 $ret = $self->ping_stream($ip, $timeout);
f569508e 602 }
26e9d721 603 elsif ($self->{proto} eq "syn") {
f569508e 604 $ret = $self->ping_syn($host, $ip, $ping_time, $ping_time+$timeout);
e82f584b 605 } else {
787ecdfa 606 croak("Unknown protocol \"$self->{proto}\" in ping()");
e82f584b
JH		 607 }
608
4e0aac35 609 return wantarray ? ($ret, &time() - $ping_time, $self->ntop($ip)) : $ret;
787ecdfa
JH		 610}
611
612# Uses Net::Ping::External to do an external ping.
613sub ping_external {
614 my ($self,
773d126d
CBW		 615 $ip, # Hash of addr (string), addr_in (packed), family
616 $timeout, # Seconds after which ping times out
617 $family
787ecdfa
JH		 618 ) = @_;
619
773d126d
CBW		 620 $ip = $self->{host} if !defined $ip and $self->{host};
621 $timeout = $self->{timeout} if !defined $timeout and $self->{timeout};
26e9d721
SH		 622 my @addr = exists $ip->{addr_in}
623 ? ('ip' => $ip->{addr_in})
624 : ('host' => $ip->{host});
773d126d 625
8c91ebab
SH		 626 eval {
627 local @INC = @INC;
628 pop @INC if $INC[-1] eq '.';
629 require Net::Ping::External;
630 } or croak('Protocol "external" not supported on your system: Net::Ping::External not found');
26e9d721 631 return Net::Ping::External::ping(@addr, timeout => $timeout,
773d126d 632 family => $family);
a3b93737 633}
a0d0e21e 634
773d126d
CBW		 635# h2ph "asm/socket.h"
636# require "asm/socket.ph";
637use constant SO_BINDTODEVICE => 25;
46b9c7d8 638use constant ICMP_ECHOREPLY => 0; # ICMP packet types
773d126d 639use constant ICMPv6_ECHOREPLY => 129; # ICMP packet types
46b9c7d8 640use constant ICMP_UNREACHABLE => 3; # ICMP packet types
773d126d 641use constant ICMPv6_UNREACHABLE => 1; # ICMP packet types
46b9c7d8 642use constant ICMP_ECHO => 8;
773d126d 643use constant ICMPv6_ECHO => 128;
1bd59f2c
SP		 644use constant ICMP_TIME_EXCEEDED => 11; # ICMP packet types
645use constant ICMP_PARAMETER_PROBLEM => 12; # ICMP packet types
2e598186
N		 646use constant ICMP_TIMESTAMP => 13;
647use constant ICMP_TIMESTAMP_REPLY => 14;
46b9c7d8 648use constant ICMP_STRUCT => "C2 n3 A"; # Structure of a minimal ICMP packet
2e598186 649use constant ICMP_TIMESTAMP_STRUCT => "C2 n3 N3"; # Structure of a minimal timestamp ICMP packet
46b9c7d8
GA		 650use constant SUBCODE => 0; # No ICMP subcode for ECHO and ECHOREPLY
651use constant ICMP_FLAGS => 0; # No special flags for send or recv
652use constant ICMP_PORT => 0; # No port with ICMP
773d126d 653use constant IP_MTU_DISCOVER => 10; # linux only
49afa5f6 654
2e598186
N		 655sub message_type
656{
657 my ($self,
658 $type
659 ) = @_;
660
661 croak "Setting message type only supported on 'icmp' protocol"
662 unless $self->{proto} eq 'icmp';
663
664 return $self->{message_type} || 'echo'
665 unless defined($type);
666
667 croak "Supported icmp message type are limited to 'echo' and 'timestamp': '$type' not supported"
668 unless $type =~ /^echo|timestamp$/i;
669
670 $self->{message_type} = lc($type);
671}
672
a3b93737
RM		 673sub ping_icmp
674{
e82f584b 675 my ($self,
773d126d 676 $ip, # Hash of addr (string), addr_in (packed), family
e82f584b
JH		 677 $timeout # Seconds after which ping times out
678 ) = @_;
679
680 my ($saddr, # sockaddr_in with port and ip
681 $checksum, # Checksum of ICMP packet
682 $msg, # ICMP packet to send
683 $len_msg, # Length of $msg
684 $rbits, # Read bits, filehandles for reading
685 $nfound, # Number of ready filehandles found
686 $finish_time, # Time ping should be finished
687 $done, # set to 1 when we are done
688 $ret, # Return value
689 $recv_msg, # Received message including IP header
690 $from_saddr, # sockaddr_in of sender
691 $from_port, # Port packet was sent from
692 $from_ip, # Packed IP of sender
2e598186 693 $timestamp_msg, # ICMP timestamp message type
e82f584b
JH		 694 $from_type, # ICMP type
695 $from_subcode, # ICMP subcode
696 $from_chk, # ICMP packet checksum
697 $from_pid, # ICMP packet id
698 $from_seq, # ICMP packet sequence
699 $from_msg # ICMP message
700 );
701
773d126d
CBW		 702 $ip = $self->{host} if !defined $ip and $self->{host};
703 $timeout = $self->{timeout} if !defined $timeout and $self->{timeout};
2e598186 704 $timestamp_msg = $self->{message_type} && $self->{message_type} eq 'timestamp' ? 1 : 0;
773d126d 705
26e9d721 706 socket($self->{fh}, $ip->{family}, SOCK_RAW, $self->{proto_num}) ||
773d126d
CBW		 707 croak("icmp socket error - $!");
708
26e9d721
SH		 709 if (defined $self->{local_addr} &&
710 !CORE::bind($self->{fh}, _pack_sockaddr_in(0, $self->{local_addr}))) {
773d126d
CBW		 711 croak("icmp bind error - $!");
712 }
713 $self->_setopts();
714
26e9d721 715 $self->{seq} = ($self->{seq} + 1) % 65536; # Increment sequence
e82f584b 716 $checksum = 0; # No checksum for starters
26e9d721 717 if ($ip->{family} == AF_INET) {
2e598186
N		 718 if ($timestamp_msg) {
719 $msg = pack(ICMP_TIMESTAMP_STRUCT, ICMP_TIMESTAMP, SUBCODE,
720 $checksum, $self->{pid}, $self->{seq}, 0, 0, 0);
721 } else {
722 $msg = pack(ICMP_STRUCT . $self->{data_size}, ICMP_ECHO, SUBCODE,
723 $checksum, $self->{pid}, $self->{seq}, $self->{data});
724 }
773d126d
CBW		 725 } else {
726 # how to get SRC
2e598186 727 my $pseudo_header = pack('a16a16Nnn', $ip->{addr_in}, $ip->{addr_in}, 8+length($self->{data}), 0, 0x003a);
26e9d721
SH		 728 $msg = pack(ICMP_STRUCT . $self->{data_size}, ICMPv6_ECHO, SUBCODE,
729 $checksum, $self->{pid}, $self->{seq}, $self->{data});
773d126d
CBW		 730 $msg = $pseudo_header.$msg
731 }
e82f584b 732 $checksum = Net::Ping->checksum($msg);
26e9d721 733 if ($ip->{family} == AF_INET) {
2e598186
N		 734 if ($timestamp_msg) {
735 $msg = pack(ICMP_TIMESTAMP_STRUCT, ICMP_TIMESTAMP, SUBCODE,
736 $checksum, $self->{pid}, $self->{seq}, 0, 0, 0);
737 } else {
738 $msg = pack(ICMP_STRUCT . $self->{data_size}, ICMP_ECHO, SUBCODE,
739 $checksum, $self->{pid}, $self->{seq}, $self->{data});
740 }
773d126d 741 } else {
26e9d721
SH		 742 $msg = pack(ICMP_STRUCT . $self->{data_size}, ICMPv6_ECHO, SUBCODE,
743 $checksum, $self->{pid}, $self->{seq}, $self->{data});
773d126d 744 }
e82f584b 745 $len_msg = length($msg);
773d126d 746 $saddr = _pack_sockaddr_in(ICMP_PORT, $ip);
26e9d721
SH		 747 $self->{from_ip} = undef;
748 $self->{from_type} = undef;
749 $self->{from_subcode} = undef;
750 send($self->{fh}, $msg, ICMP_FLAGS, $saddr); # Send the message
e82f584b
JH		 751
752 $rbits = "";
26e9d721 753 vec($rbits, $self->{fh}->fileno(), 1) = 1;
e82f584b
JH		 754 $ret = 0;
755 $done = 0;
756 $finish_time = &time() + $timeout; # Must be done by this time
757 while (!$done && $timeout > 0) # Keep trying if we have time
758 {
eb194dd9 759 $nfound = mselect((my $rout=$rbits), undef, undef, $timeout); # Wait for packet
e82f584b 760 $timeout = $finish_time - &time(); # Get remaining time
95d3daf0 761 if (!defined($nfound)) # Hmm, a strange error
a3b93737 762 {
e82f584b
JH		 763 $ret = undef;
764 $done = 1;
765 }
766 elsif ($nfound) # Got a packet from somewhere
767 {
768 $recv_msg = "";
9539e94f
JH		 769 $from_pid = -1;
770 $from_seq = -1;
26e9d721
SH		 771 $from_saddr = recv($self->{fh}, $recv_msg, 1500, ICMP_FLAGS);
772 ($from_port, $from_ip) = _unpack_sockaddr_in($from_saddr, $ip->{family});
9c36735d 773 ($from_type, $from_subcode) = unpack("C2", substr($recv_msg, 20, 2));
2e598186 774 if ($from_type == ICMP_TIMESTAMP_REPLY) {
9539e94f
JH		 775 ($from_pid, $from_seq) = unpack("n3", substr($recv_msg, 24, 4))
776 if length $recv_msg >= 28;
2e598186
N		 777 } elsif ($from_type == ICMP_ECHOREPLY) {
778 #warn "ICMP_ECHOREPLY: ", $ip->{family}, " ",$recv_msg, ":", length($recv_msg);
779 ($from_pid, $from_seq) = unpack("n2", substr($recv_msg, 24, 4))
780 if ($ip->{family} == AF_INET && length $recv_msg == 28);
781 ($from_pid, $from_seq) = unpack("n2", substr($recv_msg, 4, 4))
782 if ($ip->{family} == $AF_INET6 && length $recv_msg == 8);
773d126d 783 } elsif ($from_type == ICMPv6_ECHOREPLY) {
2e598186
N		 784 #($from_pid, $from_seq) = unpack("n3", substr($recv_msg, 24, 4))
785 # if length $recv_msg >= 28;
786 #($from_pid, $from_seq) = unpack("n2", substr($recv_msg, 24, 4))
787 # if ($ip->{family} == AF_INET && length $recv_msg == 28);
788 #warn "ICMPv6_ECHOREPLY: ", $ip->{family}, " ",$recv_msg, ":", length($recv_msg);
789 ($from_pid, $from_seq) = unpack("n2", substr($recv_msg, 4, 4))
790 if ($ip->{family} == $AF_INET6 && length $recv_msg == 8);
791 #} elsif ($from_type == ICMPv6_NI_REPLY) {
792 # ($from_pid, $from_seq) = unpack("n2", substr($recv_msg, 4, 4))
793 # if ($ip->{family} == $AF_INET6 && length $recv_msg == 8);
9c36735d 794 } else {
2e598186
N		 795 #warn "ICMP: ", $from_type, " ",$ip->{family}, " ",$recv_msg, ":", length($recv_msg);
796 ($from_pid, $from_seq) = unpack("n2", substr($recv_msg, 52, 4))
9539e94f 797 if length $recv_msg >= 56;
9c36735d 798 }
26e9d721
SH		 799 $self->{from_ip} = $from_ip;
800 $self->{from_type} = $from_type;
801 $self->{from_subcode} = $from_subcode;
802 next if ($from_pid != $self->{pid});
803 next if ($from_seq != $self->{seq});
4e0aac35 804 if (! $source_verify || ($self->ntop($from_ip) eq $self->ntop($ip))) { # Does the packet check out?
2e598186
N		 805 if (!$timestamp_msg && (($from_type == ICMP_ECHOREPLY) || ($from_type == ICMPv6_ECHOREPLY))) {
806 $ret = 1;
807 $done = 1;
808 } elsif ($timestamp_msg && $from_type == ICMP_TIMESTAMP_REPLY) {
9c36735d 809 $ret = 1;
773d126d
CBW		 810 $done = 1;
811 } elsif (($from_type == ICMP_UNREACHABLE) || ($from_type == ICMPv6_UNREACHABLE)) {
46b9c7d8 812 $done = 1;
1bd59f2c
SP		 813 } elsif ($from_type == ICMP_TIME_EXCEEDED) {
814 $ret = 0;
815 $done = 1;
9c36735d 816 }
e82f584b 817 }
9c36735d 818 } else { # Oops, timed out
e82f584b
JH		 819 $done = 1;
820 }
821 }
822 return $ret;
a3b93737
RM		 823}
824
773d126d
CBW		 825sub ping_icmpv6
826{
827 shift->ping_icmp(@_);
828}
829
9c36735d
JH		 830sub icmp_result {
831 my ($self) = @_;
26e9d721 832 my $addr = $self->{from_ip} || "";
773d126d 833 $addr = "\0\0\0\0" unless 4 == length $addr;
26e9d721 834 return ($self->ntop($addr),($self->{from_type} || 0), ($self->{from_subcode} || 0));
9c36735d
JH		 835}
836
a3b93737
RM		 837# Description: Do a checksum on the message. Basically sum all of
838# the short words and fold the high order bits into the low order bits.
839
840sub checksum
841{
e82f584b
JH		 842 my ($class,
843 $msg # The message to checksum
844 ) = @_;
845 my ($len_msg, # Length of the message
846 $num_short, # The number of short words in the message
847 $short, # One short word
848 $chk # The checksum
849 );
850
851 $len_msg = length($msg);
852 $num_short = int($len_msg / 2);
853 $chk = 0;
9c36735d 854 foreach $short (unpack("n$num_short", $msg))
e82f584b
JH		 855 {
856 $chk += $short;
857 } # Add the odd byte in
858 $chk += (unpack("C", substr($msg, $len_msg - 1, 1)) << 8) if $len_msg % 2;
859 $chk = ($chk >> 16) + ($chk & 0xffff); # Fold high into low
860 return(~(($chk >> 16) + $chk) & 0xffff); # Again and complement
a3b93737
RM		 861}
862
787ecdfa 863
b124990b
JH		 864# Description: Perform a tcp echo ping. Since a tcp connection is
865# host specific, we have to open and close each connection here. We
866# can't just leave a socket open. Because of the robust nature of
867# tcp, it will take a while before it gives up trying to establish a
868# connection. Therefore, we use select() on a non-blocking socket to
869# check against our timeout. No data bytes are actually
870# sent since the successful establishment of a connection is proof
871# enough of the reachability of the remote host. Also, tcp is
872# expensive and doesn't need our help to add to the overhead.
873
874sub ping_tcp
787ecdfa 875{
e82f584b 876 my ($self,
773d126d 877 $ip, # Hash of addr (string), addr_in (packed), family
e82f584b
JH		 878 $timeout # Seconds after which ping times out
879 ) = @_;
880 my ($ret # The return value
881 );
882
773d126d
CBW		 883 $ip = $self->{host} if !defined $ip and $self->{host};
884 $timeout = $self->{timeout} if !defined $timeout and $self->{timeout};
885
9c36735d 886 $! = 0;
e82f584b 887 $ret = $self -> tcp_connect( $ip, $timeout);
26e9d721 888 if (!$self->{econnrefused} &&
f569508e
HS		 889 $! == ECONNREFUSED) {
890 $ret = 1; # "Connection refused" means reachable
891 }
26e9d721 892 $self->{fh}->close();
e82f584b 893 return $ret;
787ecdfa
JH		 894}
895
b124990b 896sub tcp_connect
787ecdfa 897{
e82f584b 898 my ($self,
773d126d 899 $ip, # Hash of addr (string), addr_in (packed), family
e82f584b
JH		 900 $timeout # Seconds after which connect times out
901 ) = @_;
902 my ($saddr); # Packed IP and Port
b124990b 903
773d126d
CBW		 904 $ip = $self->{host} if !defined $ip and $self->{host};
905 $timeout = $self->{timeout} if !defined $timeout and $self->{timeout};
906
26e9d721 907 $saddr = _pack_sockaddr_in($self->{port_num}, $ip);
b124990b 908
e82f584b 909 my $ret = 0; # Default to unreachable
b124990b 910
e82f584b 911 my $do_socket = sub {
26e9d721 912 socket($self->{fh}, $ip->{family}, SOCK_STREAM, $self->{proto_num}) ||
e82f584b 913 croak("tcp socket error - $!");
26e9d721
SH		 914 if (defined $self->{local_addr} &&
915 !CORE::bind($self->{fh}, _pack_sockaddr_in(0, $self->{local_addr}))) {
e82f584b
JH		 916 croak("tcp bind error - $!");
917 }
773d126d 918 $self->_setopts();
e82f584b
JH		 919 };
920 my $do_connect = sub {
26e9d721 921 $self->{ip} = $ip->{addr_in};
6dbac12b
GS		 922 # ECONNREFUSED is 10061 on MSWin32. If we pass it as child error through $?,
923 # we'll get (10061 & 255) = 77, so we cannot check it in the parent process.
26e9d721 924 return ($ret = connect($self->{fh}, $saddr) || ($! == ECONNREFUSED && !$self->{econnrefused}));
e82f584b 925 };
9c36735d
JH		 926 my $do_connect_nb = sub {
927 # Set O_NONBLOCK property on filehandle
26e9d721 928 $self->socket_blocking_mode($self->{fh}, 0);
9c36735d
JH		 929
930 # start the connection attempt
26e9d721 931 if (!connect($self->{fh}, $saddr)) {
9c36735d 932 if ($! == ECONNREFUSED) {
26e9d721 933 $ret = 1 unless $self->{econnrefused};
eb194dd9 934 } elsif ($! != EINPROGRESS && ($^O ne 'MSWin32' || $! != EWOULDBLOCK)) {
9c36735d 935 # EINPROGRESS is the expected error code after a connect()
c94ff782
JH		 936 # on a non-blocking socket. But if the kernel immediately
937 # determined that this connect() will never work,
938 # Simply respond with "unreachable" status.
939 # (This can occur on some platforms with errno
940 # EHOSTUNREACH or ENETUNREACH.)
941 return 0;
942 } else {
943 # Got the expected EINPROGRESS.
944 # Just wait for connection completion...
eb194dd9
GS		 945 my ($wbits, $wout, $wexc);
946 $wout = $wexc = $wbits = "";
26e9d721 947 vec($wbits, $self->{fh}->fileno, 1) = 1;
9c36735d 948
eb194dd9
GS		 949 my $nfound = mselect(undef,
950 ($wout = $wbits),
951 ($^O eq 'MSWin32' ? ($wexc = $wbits) : undef),
952 $timeout);
9c36735d
JH		 953 warn("select: $!") unless defined $nfound;
954
26e9d721 955 if ($nfound && vec($wout, $self->{fh}->fileno, 1)) {
9c36735d
JH		 956 # the socket is ready for writing so the connection
957 # attempt completed. test whether the connection
958 # attempt was successful or not
959
26e9d721 960 if (getpeername($self->{fh})) {
9c36735d
JH		 961 # Connection established to remote host
962 $ret = 1;
963 } else {
964 # TCP ACK will never come from this host
965 # because there was an error connecting.
e82f584b 966
9c36735d
JH		 967 # This should set $! to the correct error.
968 my $char;
26e9d721 969 sysread($self->{fh},$char,1);
9c36735d 970 $! = ECONNREFUSED if ($! == EAGAIN && $^O =~ /cygwin/i);
e82f584b 971
26e9d721 972 $ret = 1 if (!$self->{econnrefused}
9c36735d
JH		 973 && $! == ECONNREFUSED);
974 }
975 } else {
eb194dd9
GS		 976 # the connection attempt timed out (or there were connect
977 # errors on Windows)
978 if ($^O =~ 'MSWin32') {
979 # If the connect will fail on a non-blocking socket,
980 # winsock reports ECONNREFUSED as an exception, and we
981 # need to fetch the socket-level error code via getsockopt()
982 # instead of using the thread-level error code that is in $!.
26e9d721
SH		 983 if ($nfound && vec($wexc, $self->{fh}->fileno, 1)) {
984 $! = unpack("i", getsockopt($self->{fh}, SOL_SOCKET,
eb194dd9
GS		 985 SO_ERROR));
986 }
987 }
9c36735d
JH		 988 }
989 }
990 } else {
991 # Connection established to remote host
992 $ret = 1;
993 }
994
995 # Unset O_NONBLOCK property on filehandle
26e9d721
SH		 996 $self->socket_blocking_mode($self->{fh}, 1);
997 $self->{ip} = $ip->{addr_in};
9c36735d
JH		 998 return $ret;
999 };
1000
1001 if ($syn_forking) {
1002 # Buggy Winsock API doesn't allow nonblocking connect.
e82f584b
JH		 1003 # Hence, if our OS is Windows, we need to create a separate
1004 # process to do the blocking connect attempt.
eb194dd9
GS		 1005 # XXX Above comments are not true at least for Win2K, where
1006 # nonblocking connect works.
e82f584b
JH		 1007
1008 $| = 1; # Clear buffer prior to fork to prevent duplicate flushing.
9c36735d
JH		 1009 $self->{'tcp_chld'} = fork;
1010 if (!$self->{'tcp_chld'}) {
1011 if (!defined $self->{'tcp_chld'}) {
e82f584b 1012 # Fork did not work
9c36735d 1013 warn "Fork error: $!";
e82f584b 1014 return 0;
b124990b 1015 }
b124990b
JH		 1016 &{ $do_socket }();
1017
e82f584b 1018 # Try a slow blocking connect() call
9c36735d 1019 # and report the status to the parent.
e82f584b 1020 if ( &{ $do_connect }() ) {
26e9d721 1021 $self->{fh}->close();
e82f584b
JH		 1022 # No error
1023 exit 0;
b124990b 1024 } else {
e82f584b 1025 # Pass the error status to the parent
6dbac12b
GS		 1026 # Make sure that $! <= 255
1027 exit($! <= 255 ? $! : 255);
b124990b 1028 }
e82f584b 1029 }
b124990b 1030
e82f584b
JH		 1031 &{ $do_socket }();
1032
1033 my $patience = &time() + $timeout;
1034
9c36735d
JH		 1035 my ($child, $child_errno);
1036 $? = 0; $child_errno = 0;
e82f584b
JH		 1037 # Wait up to the timeout
1038 # And clean off the zombie
1039 do {
9c36735d
JH		 1040 $child = waitpid($self->{'tcp_chld'}, &WNOHANG());
1041 $child_errno = $? >> 8;
e82f584b 1042 select(undef, undef, undef, 0.1);
9c36735d
JH		 1043 } while &time() < $patience && $child != $self->{'tcp_chld'};
1044
1045 if ($child == $self->{'tcp_chld'}) {
26e9d721 1046 if ($self->{proto} eq "stream") {
9c36735d
JH		 1047 # We need the socket connected here, in parent
1048 # Should be safe to connect because the child finished
1049 # within the timeout
1050 &{ $do_connect }();
1051 }
6dbac12b
GS		 1052 # $ret cannot be set by the child process
1053 $ret = !$child_errno;
e82f584b
JH		 1054 } else {
1055 # Time must have run out.
e82f584b 1056 # Put that choking client out of its misery
9c36735d 1057 kill "KILL", $self->{'tcp_chld'};
e82f584b 1058 # Clean off the zombie
9c36735d 1059 waitpid($self->{'tcp_chld'}, 0);
e82f584b 1060 $ret = 0;
b124990b 1061 }
9c36735d
JH		 1062 delete $self->{'tcp_chld'};
1063 $! = $child_errno;
1064 } else {
e82f584b
JH		 1065 # Otherwise don't waste the resources to fork
1066
1067 &{ $do_socket }();
1068
9c36735d 1069 &{ $do_connect_nb }();
e82f584b 1070 }
787ecdfa 1071
e82f584b 1072 return $ret;
787ecdfa
JH		 1073}
1074
9c36735d
JH		 1075sub DESTROY {
1076 my $self = shift;
1077 if ($self->{'proto'} eq 'tcp' &&
1078 $self->{'tcp_chld'}) {
1079 # Put that choking client out of its misery
1080 kill "KILL", $self->{'tcp_chld'};
1081 # Clean off the zombie
1082 waitpid($self->{'tcp_chld'}, 0);
1083 }
1084}
1085
787ecdfa
JH		 1086# This writes the given string to the socket and then reads it
1087# back. It returns 1 on success, 0 on failure.
1088sub tcp_echo
1089{
773d126d
CBW		 1090 my ($self, $timeout, $pingstring) = @_;
1091
1092 $timeout = $self->{timeout} if !defined $timeout and $self->{timeout};
1093 $pingstring = $self->{pingstring} if !defined $pingstring and $self->{pingstring};
e82f584b
JH		 1094
1095 my $ret = undef;
1096 my $time = &time();
1097 my $wrstr = $pingstring;
1098 my $rdstr = "";
1099
1100 eval <<'EOM';
1101 do {
1102 my $rin = "";
26e9d721 1103 vec($rin, $self->{fh}->fileno(), 1) = 1;
e82f584b
JH		 1104
1105 my $rout = undef;
1106 if($wrstr) {
1107 $rout = "";
26e9d721 1108 vec($rout, $self->{fh}->fileno(), 1) = 1;
e82f584b
JH		 1109 }
1110
eb194dd9 1111 if(mselect($rin, $rout, undef, ($time + $timeout) - &time())) {
e82f584b 1112
26e9d721
SH		 1113 if($rout && vec($rout,$self->{fh}->fileno(),1)) {
1114 my $num = syswrite($self->{fh}, $wrstr, length $wrstr);
e82f584b
JH		 1115 if($num) {
1116 # If it was a partial write, update and try again.
1117 $wrstr = substr($wrstr,$num);
1118 } else {
1119 # There was an error.
1120 $ret = 0;
1121 }
1122 }
1123
26e9d721 1124 if(vec($rin,$self->{fh}->fileno(),1)) {
e82f584b 1125 my $reply;
26e9d721 1126 if(sysread($self->{fh},$reply,length($pingstring)-length($rdstr))) {
e82f584b
JH		 1127 $rdstr .= $reply;
1128 $ret = 1 if $rdstr eq $pingstring;
1129 } else {
1130 # There was an error.
1131 $ret = 0;
1132 }
1133 }
1134
1135 }
1136 } until &time() > ($time + $timeout) || defined($ret);
787ecdfa
JH		 1137EOM
1138
e82f584b 1139 return $ret;
787ecdfa
JH		 1140}
1141
787ecdfa
JH		 1142# Description: Perform a stream ping. If the tcp connection isn't
1143# already open, it opens it. It then sends some data and waits for
1144# a reply. It leaves the stream open on exit.
1145
1146sub ping_stream
1147{
e82f584b 1148 my ($self,
773d126d 1149 $ip, # Hash of addr (string), addr_in (packed), family
e82f584b
JH		 1150 $timeout # Seconds after which ping times out
1151 ) = @_;
072620d9 1152
e82f584b 1153 # Open the stream if it's not already open
26e9d721 1154 if(!defined $self->{fh}->fileno()) {
e82f584b
JH		 1155 $self->tcp_connect($ip, $timeout) or return 0;
1156 }
787ecdfa 1157
e82f584b 1158 croak "tried to switch servers while stream pinging"
26e9d721 1159 if $self->{ip} ne $ip->{addr_in};
e82f584b
JH		 1160
1161 return $self->tcp_echo($timeout, $pingstring);
787ecdfa
JH		 1162}
1163
1164# Description: opens the stream. You would do this if you want to
1165# separate the overhead of opening the stream from the first ping.
1166
1167sub open
1168{
e82f584b
JH		 1169 my ($self,
1170 $host, # Host or IP address
773d126d
CBW		 1171 $timeout, # Seconds after which open times out
1172 $family
e82f584b 1173 ) = @_;
773d126d
CBW		 1174 my $ip; # Hash of addr (string), addr_in (packed), family
1175 $host = $self->{host} unless defined $host;
1176
1177 if ($family) {
1178 if ($family =~ $qr_family) {
1179 if ($family =~ $qr_family4) {
26e9d721 1180 $self->{family_local} = AF_INET;
773d126d 1181 } else {
26e9d721 1182 $self->{family_local} = $AF_INET6;
773d126d
CBW		 1183 }
1184 } else {
1185 croak('Family must be "ipv4" or "ipv6"')
1186 }
1187 } else {
26e9d721 1188 $self->{family_local} = $self->{family};
773d126d 1189 }
e82f584b 1190
26e9d721 1191 $timeout = $self->{timeout} unless $timeout;
2e598186 1192 $ip = $self->_resolv($host);
e82f584b 1193
2e598186
N		 1194 if ($self->{proto} eq "stream") {
1195 if (defined($self->{fh}->fileno())) {
e82f584b
JH		 1196 croak("socket is already open");
1197 } else {
2e598186 1198 return () unless $ip;
e82f584b 1199 $self->tcp_connect($ip, $timeout);
b124990b 1200 }
e82f584b 1201 }
072620d9
SB		 1202}
1203
773d126d
CBW		 1204sub _dontfrag {
1205 my $self = shift;
1206 # bsd solaris
1207 my $IP_DONTFRAG = eval { Socket::IP_DONTFRAG() };
1208 if ($IP_DONTFRAG) {
1209 my $i = 1;
26e9d721 1210 setsockopt($self->{fh}, IPPROTO_IP, $IP_DONTFRAG, pack("I*", $i))
773d126d
CBW		 1211 or croak "error configuring IP_DONTFRAG $!";
1212 # Linux needs more: Path MTU Discovery as defined in RFC 1191
1213 # For non SOCK_STREAM sockets it is the user's responsibility to packetize
1214 # the data in MTU sized chunks and to do the retransmits if necessary.
1215 # The kernel will reject packets that are bigger than the known path
1216 # MTU if this flag is set (with EMSGSIZE).
1217 if ($^O eq 'linux') {
1218 my $i = 2; # IP_PMTUDISC_DO
26e9d721 1219 setsockopt($self->{fh}, IPPROTO_IP, IP_MTU_DISCOVER, pack("I*", $i))
773d126d
CBW		 1220 or croak "error configuring IP_MTU_DISCOVER $!";
1221 }
1222 }
1223}
1224
1225# SO_BINDTODEVICE + IP_TOS
1226sub _setopts {
1227 my $self = shift;
1228 if ($self->{'device'}) {
26e9d721 1229 setsockopt($self->{fh}, SOL_SOCKET, SO_BINDTODEVICE, pack("Z*", $self->{'device'}))
773d126d
CBW		 1230 or croak "error binding to device $self->{'device'} $!";
1231 }
1232 if ($self->{'tos'}) { # need to re-apply ToS (RT #6706)
26e9d721 1233 setsockopt($self->{fh}, IPPROTO_IP, IP_TOS, pack("I*", $self->{'tos'}))
773d126d
CBW		 1234 or croak "error applying tos to $self->{'tos'} $!";
1235 }
1236 if ($self->{'dontfrag'}) {
1237 $self->_dontfrag;
1238 }
1239}
1240
b124990b 1241
a3b93737
RM		 1242# Description: Perform a udp echo ping. Construct a message of
1243# at least the one-byte sequence number and any additional data bytes.
1244# Send the message out and wait for a message to come back. If we
1245# get a message, make sure all of its parts match. If they do, we are
1246# done. Otherwise go back and wait for the message until we run out
1247# of time. Return the result of our efforts.
1248
49afa5f6 1249use constant UDP_FLAGS => 0; # Nothing special on send or recv
a3b93737
RM		 1250sub ping_udp
1251{
e82f584b 1252 my ($self,
773d126d 1253 $ip, # Hash of addr (string), addr_in (packed), family
e82f584b
JH		 1254 $timeout # Seconds after which ping times out
1255 ) = @_;
1256
1257 my ($saddr, # sockaddr_in with port and ip
1258 $ret, # The return value
1259 $msg, # Message to be echoed
1260 $finish_time, # Time ping should be finished
9539e94f
JH		 1261 $flush, # Whether socket needs to be disconnected
1262 $connect, # Whether socket needs to be connected
e82f584b
JH		 1263 $done, # Set to 1 when we are done pinging
1264 $rbits, # Read bits, filehandles for reading
1265 $nfound, # Number of ready filehandles found
1266 $from_saddr, # sockaddr_in of sender
1267 $from_msg, # Characters echoed by $host
1268 $from_port, # Port message was echoed from
1269 $from_ip # Packed IP number of sender
1270 );
1271
26e9d721
SH		 1272 $saddr = _pack_sockaddr_in($self->{port_num}, $ip);
1273 $self->{seq} = ($self->{seq} + 1) % 256; # Increment sequence
1274 $msg = chr($self->{seq}) . $self->{data}; # Add data if any
9539e94f 1275
26e9d721
SH		 1276 socket($self->{fh}, $ip->{family}, SOCK_DGRAM,
1277 $self->{proto_num}) ||
773d126d
CBW		 1278 croak("udp socket error - $!");
1279
26e9d721
SH		 1280 if (defined $self->{local_addr} &&
1281 !CORE::bind($self->{fh}, _pack_sockaddr_in(0, $self->{local_addr}))) {
773d126d
CBW		 1282 croak("udp bind error - $!");
1283 }
1284
1285 $self->_setopts();
1286
26e9d721
SH		 1287 if ($self->{connected}) {
1288 if ($self->{connected} ne $saddr) {
9539e94f
JH		 1289 # Still connected to wrong destination.
1290 # Need to flush out the old one.
1291 $flush = 1;
1292 }
1293 } else {
1294 # Not connected yet.
1295 # Need to connect() before send()
1296 $connect = 1;
1297 }
1298
c94ff782
JH		 1299 # Have to connect() and send() instead of sendto()
1300 # in order to pick up on the ECONNREFUSED setting
1301 # from recv() or double send() errno as utilized in
1302 # the concept by rdw @ perlmonks. See:
1303 # http://perlmonks.thepen.com/42898.html
9539e94f
JH		 1304 if ($flush) {
1305 # Need to socket() again to flush the descriptor
1306 # This will disconnect from the old saddr.
26e9d721
SH		 1307 socket($self->{fh}, $ip->{family}, SOCK_DGRAM,
1308 $self->{proto_num});
773d126d 1309 $self->_setopts();
9539e94f
JH		 1310 }
1311 # Connect the socket if it isn't already connected
1312 # to the right destination.
1313 if ($flush || $connect) {
26e9d721
SH		 1314 connect($self->{fh}, $saddr); # Tie destination to socket
1315 $self->{connected} = $saddr;
9539e94f 1316 }
26e9d721 1317 send($self->{fh}, $msg, UDP_FLAGS); # Send it
e82f584b
JH		 1318
1319 $rbits = "";
26e9d721 1320 vec($rbits, $self->{fh}->fileno(), 1) = 1;
e82f584b
JH		 1321 $ret = 0; # Default to unreachable
1322 $done = 0;
c94ff782 1323 my $retrans = 0.01;
26e9d721 1324 my $factor = $self->{retrans};
e82f584b
JH		 1325 $finish_time = &time() + $timeout; # Ping needs to be done by then
1326 while (!$done && $timeout > 0)
1327 {
9539e94f
JH		 1328 if ($factor > 1)
1329 {
1330 $timeout = $retrans if $timeout > $retrans;
1331 $retrans*= $factor; # Exponential backoff
1332 }
eb194dd9 1333 $nfound = mselect((my $rout=$rbits), undef, undef, $timeout); # Wait for response
c94ff782 1334 my $why = $!;
e82f584b
JH		 1335 $timeout = $finish_time - &time(); # Get remaining time
1336
1337 if (!defined($nfound)) # Hmm, a strange error
a3b93737 1338 {
e82f584b
JH		 1339 $ret = undef;
1340 $done = 1;
a3b93737 1341 }
e82f584b
JH		 1342 elsif ($nfound) # A packet is waiting
1343 {
1344 $from_msg = "";
26e9d721 1345 $from_saddr = recv($self->{fh}, $from_msg, 1500, UDP_FLAGS);
c94ff782
JH		 1346 if (!$from_saddr) {
1347 # For example an unreachable host will make recv() fail.
26e9d721 1348 if (!$self->{econnrefused} &&
9539e94f
JH		 1349 ($! == ECONNREFUSED ||
1350 $! == ECONNRESET)) {
c94ff782
JH		 1351 # "Connection refused" means reachable
1352 # Good, continue
1353 $ret = 1;
1354 }
e82f584b 1355 $done = 1;
c94ff782 1356 } else {
26e9d721 1357 ($from_port, $from_ip) = _unpack_sockaddr_in($from_saddr, $ip->{family});
8c91ebab 1358 my $addr_in = ref($ip) eq "HASH" ? $ip->{addr_in} : $ip;
c94ff782 1359 if (!$source_verify ||
8c91ebab 1360 (($from_ip eq $addr_in) && # Does the packet check out?
26e9d721 1361 ($from_port == $self->{port_num}) &&
c94ff782
JH		 1362 ($from_msg eq $msg)))
1363 {
1364 $ret = 1; # It's a winner
1365 $done = 1;
1366 }
e82f584b
JH		 1367 }
1368 }
c94ff782 1369 elsif ($timeout <= 0) # Oops, timed out
e82f584b
JH		 1370 {
1371 $done = 1;
1372 }
c94ff782
JH		 1373 else
1374 {
1375 # Send another in case the last one dropped
26e9d721 1376 if (send($self->{fh}, $msg, UDP_FLAGS)) {
c94ff782
JH		 1377 # Another send worked? The previous udp packet
1378 # must have gotten lost or is still in transit.
1379 # Hopefully this new packet will arrive safely.
1380 } else {
26e9d721 1381 if (!$self->{econnrefused} &&
c94ff782
JH		 1382 $! == ECONNREFUSED) {
1383 # "Connection refused" means reachable
1384 # Good, continue
1385 $ret = 1;
1386 }
1387 $done = 1;
1388 }
1389 }
e82f584b 1390 }
a5a165b1 1391 return $ret;
b124990b 1392}
a0d0e21e 1393
f569508e
HS		 1394# Description: Send a TCP SYN packet to host specified.
1395sub ping_syn
1396{
1397 my $self = shift;
1398 my $host = shift;
1399 my $ip = shift;
1400 my $start_time = shift;
1401 my $stop_time = shift;
1402
1403 if ($syn_forking) {
1404 return $self->ping_syn_fork($host, $ip, $start_time, $stop_time);
1405 }
1406
1407 my $fh = FileHandle->new();
26e9d721 1408 my $saddr = _pack_sockaddr_in($self->{port_num}, $ip);
f569508e
HS		 1409
1410 # Create TCP socket
26e9d721 1411 if (!socket ($fh, $ip->{family}, SOCK_STREAM, $self->{proto_num})) {
f569508e
HS		 1412 croak("tcp socket error - $!");
1413 }
1414
26e9d721
SH		 1415 if (defined $self->{local_addr} &&
1416 !CORE::bind($fh, _pack_sockaddr_in(0, $self->{local_addr}))) {
f569508e
HS		 1417 croak("tcp bind error - $!");
1418 }
1419
773d126d 1420 $self->_setopts();
f569508e 1421 # Set O_NONBLOCK property on filehandle
9c36735d 1422 $self->socket_blocking_mode($fh, 0);
f569508e
HS		 1423
1424 # Attempt the non-blocking connect
1425 # by just sending the TCP SYN packet
1426 if (connect($fh, $saddr)) {
1427 # Non-blocking, yet still connected?
69c74a9c
HS		 1428 # Must have connected very quickly,
1429 # or else it wasn't very non-blocking.
1430 #warn "WARNING: Nonblocking connect connected anyway? ($^O)";
1431 } else {
f569508e 1432 # Error occurred connecting.
eb194dd9 1433 if ($! == EINPROGRESS || ($^O eq 'MSWin32' && $! == EWOULDBLOCK)) {
69c74a9c
HS		 1434 # The connection is just still in progress.
1435 # This is the expected condition.
1436 } else {
1437 # Just save the error and continue on.
1438 # The ack() can check the status later.
26e9d721 1439 $self->{bad}->{$host} = $!;
f569508e
HS		 1440 }
1441 }
1442
8c91ebab 1443 my $entry = [ $host, $ip, $fh, $start_time, $stop_time, $self->{port_num} ];
26e9d721
SH		 1444 $self->{syn}->{$fh->fileno} = $entry;
1445 if ($self->{stop_time} < $stop_time) {
1446 $self->{stop_time} = $stop_time;
f569508e 1447 }
26e9d721 1448 vec($self->{wbits}, $fh->fileno, 1) = 1;
f569508e
HS		 1449
1450 return 1;
1451}
1452
1453sub ping_syn_fork {
1454 my ($self, $host, $ip, $start_time, $stop_time) = @_;
1455
1456 # Buggy Winsock API doesn't allow nonblocking connect.
1457 # Hence, if our OS is Windows, we need to create a separate
1458 # process to do the blocking connect attempt.
1459 my $pid = fork();
1460 if (defined $pid) {
1461 if ($pid) {
1462 # Parent process
1463 my $entry = [ $host, $ip, $pid, $start_time, $stop_time ];
26e9d721
SH		 1464 $self->{syn}->{$pid} = $entry;
1465 if ($self->{stop_time} < $stop_time) {
1466 $self->{stop_time} = $stop_time;
f569508e
HS		 1467 }
1468 } else {
1469 # Child process
26e9d721 1470 my $saddr = _pack_sockaddr_in($self->{port_num}, $ip);
f569508e
HS		 1471
1472 # Create TCP socket
26e9d721 1473 if (!socket ($self->{fh}, $ip->{family}, SOCK_STREAM, $self->{proto_num})) {
f569508e
HS		 1474 croak("tcp socket error - $!");
1475 }
1476
26e9d721
SH		 1477 if (defined $self->{local_addr} &&
1478 !CORE::bind($self->{fh}, _pack_sockaddr_in(0, $self->{local_addr}))) {
f569508e
HS		 1479 croak("tcp bind error - $!");
1480 }
1481
773d126d 1482 $self->_setopts();
f569508e
HS		 1483
1484 $!=0;
1485 # Try to connect (could take a long time)
26e9d721 1486 connect($self->{fh}, $saddr);
f569508e
HS		 1487 # Notify parent of connect error status
1488 my $err = $!+0;
1489 my $wrstr = "$$ $err";
9c36735d
JH		 1490 # Force to 16 chars including \n
1491 $wrstr .= " "x(15 - length $wrstr). "\n";
26e9d721 1492 syswrite($self->{fork_wr}, $wrstr, length $wrstr);
f569508e
HS		 1493 exit;
1494 }
1495 } else {
1496 # fork() failed?
1497 die "fork: $!";
1498 }
1499 return 1;
1500}
1501
1502# Description: Wait for TCP ACK from host specified
1503# from ping_syn above. If no host is specified, wait
1504# for TCP ACK from any of the hosts in the SYN queue.
1505sub ack
1506{
1507 my $self = shift;
1508
26e9d721 1509 if ($self->{proto} eq "syn") {
f569508e
HS		 1510 if ($syn_forking) {
1511 my @answer = $self->ack_unfork(shift);
1512 return wantarray ? @answer : $answer[0];
1513 }
1514 my $wbits = "";
1515 my $stop_time = 0;
773d126d
CBW		 1516 if (my $host = shift or $self->{host}) {
1517 # Host passed as arg or as option to new
1518 $host = $self->{host} unless defined $host;
26e9d721
SH		 1519 if (exists $self->{bad}->{$host}) {
1520 if (!$self->{econnrefused} &&
1521 $self->{bad}->{ $host } &&
69c74a9c 1522 (($! = ECONNREFUSED)>0) &&
26e9d721 1523 $self->{bad}->{ $host } eq "$!") {
69c74a9c
HS		 1524 # "Connection refused" means reachable
1525 # Good, continue
1526 } else {
1527 # ECONNREFUSED means no good
1528 return ();
1529 }
f569508e
HS		 1530 }
1531 my $host_fd = undef;
26e9d721
SH		 1532 foreach my $fd (keys %{ $self->{syn} }) {
1533 my $entry = $self->{syn}->{$fd};
f569508e
HS		 1534 if ($entry->[0] eq $host) {
1535 $host_fd = $fd;
1536 $stop_time = $entry->[4]
1537 || croak("Corrupted SYN entry for [$host]");
1538 last;
1539 }
1540 }
1541 croak("ack called on [$host] without calling ping first!")
1542 unless defined $host_fd;
1543 vec($wbits, $host_fd, 1) = 1;
1544 } else {
1545 # No $host passed so scan all hosts
1546 # Use the latest stop_time
26e9d721 1547 $stop_time = $self->{stop_time};
f569508e 1548 # Use all the bits
26e9d721 1549 $wbits = $self->{wbits};
f569508e
HS		 1550 }
1551
9c36735d 1552 while ($wbits !~ /^\0*\z/) {
f569508e
HS		 1553 my $timeout = $stop_time - &time();
1554 # Force a minimum of 10 ms timeout.
69c74a9c
HS		 1555 $timeout = 0.01 if $timeout <= 0.01;
1556
1557 my $winner_fd = undef;
1558 my $wout = $wbits;
1559 my $fd = 0;
1560 # Do "bad" fds from $wbits first
9c36735d 1561 while ($wout !~ /^\0*\z/) {
69c74a9c
HS		 1562 if (vec($wout, $fd, 1)) {
1563 # Wipe it from future scanning.
1564 vec($wout, $fd, 1) = 0;
26e9d721
SH		 1565 if (my $entry = $self->{syn}->{$fd}) {
1566 if ($self->{bad}->{ $entry->[0] }) {
69c74a9c
HS		 1567 $winner_fd = $fd;
1568 last;
1569 }
1570 }
1571 }
1572 $fd++;
1573 }
1574
eb194dd9 1575 if (defined($winner_fd) or my $nfound = mselect(undef, ($wout=$wbits), undef, $timeout)) {
69c74a9c
HS		 1576 if (defined $winner_fd) {
1577 $fd = $winner_fd;
1578 } else {
1579 # Done waiting for one of the ACKs
1580 $fd = 0;
1581 # Determine which one
9c36735d 1582 while ($wout !~ /^\0*\z/ &&
69c74a9c
HS		 1583 !vec($wout, $fd, 1)) {
1584 $fd++;
1585 }
f569508e 1586 }
26e9d721 1587 if (my $entry = $self->{syn}->{$fd}) {
69c74a9c 1588 # Wipe it from future scanning.
26e9d721
SH		 1589 delete $self->{syn}->{$fd};
1590 vec($self->{wbits}, $fd, 1) = 0;
69c74a9c 1591 vec($wbits, $fd, 1) = 0;
26e9d721
SH		 1592 if (!$self->{econnrefused} &&
1593 $self->{bad}->{ $entry->[0] } &&
69c74a9c 1594 (($! = ECONNREFUSED)>0) &&
26e9d721 1595 $self->{bad}->{ $entry->[0] } eq "$!") {
69c74a9c
HS		 1596 # "Connection refused" means reachable
1597 # Good, continue
1598 } elsif (getpeername($entry->[2])) {
f569508e 1599 # Connection established to remote host
69c74a9c 1600 # Good, continue
f569508e
HS		 1601 } else {
1602 # TCP ACK will never come from this host
1603 # because there was an error connecting.
1604
f569508e
HS		 1605 # This should set $! to the correct error.
1606 my $char;
9c36735d 1607 sysread($entry->[2],$char,1);
f569508e 1608 # Store the excuse why the connection failed.
26e9d721
SH		 1609 $self->{bad}->{$entry->[0]} = $!;
1610 if (!$self->{econnrefused} &&
69c74a9c
HS		 1611 (($! == ECONNREFUSED) ||
1612 ($! == EAGAIN && $^O =~ /cygwin/i))) {
f569508e 1613 # "Connection refused" means reachable
69c74a9c
HS		 1614 # Good, continue
1615 } else {
1616 # No good, try the next socket...
1617 next;
f569508e 1618 }
f569508e 1619 }
69c74a9c
HS		 1620 # Everything passed okay, return the answer
1621 return wantarray ?
8c91ebab 1622 ($entry->[0], &time() - $entry->[3], $self->ntop($entry->[1]), $entry->[5])
69c74a9c 1623 : $entry->[0];
f569508e
HS		 1624 } else {
1625 warn "Corrupted SYN entry: unknown fd [$fd] ready!";
1626 vec($wbits, $fd, 1) = 0;
26e9d721 1627 vec($self->{wbits}, $fd, 1) = 0;
f569508e
HS		 1628 }
1629 } elsif (defined $nfound) {
1630 # Timed out waiting for ACK
26e9d721 1631 foreach my $fd (keys %{ $self->{syn} }) {
f569508e 1632 if (vec($wbits, $fd, 1)) {
26e9d721
SH		 1633 my $entry = $self->{syn}->{$fd};
1634 $self->{bad}->{$entry->[0]} = "Timed out";
f569508e 1635 vec($wbits, $fd, 1) = 0;
26e9d721
SH		 1636 vec($self->{wbits}, $fd, 1) = 0;
1637 delete $self->{syn}->{$fd};
f569508e
HS		 1638 }
1639 }
1640 } else {
1641 # Weird error occurred with select()
1642 warn("select: $!");
26e9d721 1643 $self->{syn} = {};
f569508e
HS		 1644 $wbits = "";
1645 }
1646 }
1647 }
1648 return ();
1649}
1650
1651sub ack_unfork {
69c74a9c 1652 my ($self,$host) = @_;
26e9d721 1653 my $stop_time = $self->{stop_time};
69c74a9c 1654 if ($host) {
f569508e 1655 # Host passed as arg
26e9d721
SH		 1656 if (my $entry = $self->{good}->{$host}) {
1657 delete $self->{good}->{$host};
4e0aac35 1658 return ($entry->[0], &time() - $entry->[3], $self->ntop($entry->[1]));
69c74a9c 1659 }
f569508e
HS		 1660 }
1661
1662 my $rbits = "";
1663 my $timeout;
69c74a9c 1664
26e9d721 1665 if (keys %{ $self->{syn} }) {
f569508e 1666 # Scan all hosts that are left
26e9d721 1667 vec($rbits, fileno($self->{fork_rd}), 1) = 1;
f569508e 1668 $timeout = $stop_time - &time();
69c74a9c
HS		 1669 # Force a minimum of 10 ms timeout.
1670 $timeout = 0.01 if $timeout < 0.01;
f569508e
HS		 1671 } else {
1672 # No hosts left to wait for
1673 $timeout = 0;
1674 }
1675
1676 if ($timeout > 0) {
69c74a9c 1677 my $nfound;
26e9d721 1678 while ( keys %{ $self->{syn} } and
eb194dd9 1679 $nfound = mselect((my $rout=$rbits), undef, undef, $timeout)) {
f569508e 1680 # Done waiting for one of the ACKs
26e9d721 1681 if (!sysread($self->{fork_rd}, $_, 16)) {
f569508e
HS		 1682 # Socket closed, which means all children are done.
1683 return ();
1684 }
1685 my ($pid, $how) = split;
1686 if ($pid) {
1687 # Flush the zombie
1688 waitpid($pid, 0);
26e9d721 1689 if (my $entry = $self->{syn}->{$pid}) {
f569508e 1690 # Connection attempt to remote host is done
26e9d721 1691 delete $self->{syn}->{$pid};
f569508e 1692 if (!$how || # If there was no error connecting
26e9d721 1693 (!$self->{econnrefused} &&
f569508e 1694 $how == ECONNREFUSED)) { # "Connection refused" means reachable
69c74a9c
HS		 1695 if ($host && $entry->[0] ne $host) {
1696 # A good connection, but not the host we need.
1697 # Move it from the "syn" hash to the "good" hash.
26e9d721 1698 $self->{good}->{$entry->[0]} = $entry;
69c74a9c
HS		 1699 # And wait for the next winner
1700 next;
1701 }
4e0aac35 1702 return ($entry->[0], &time() - $entry->[3], $self->ntop($entry->[1]));
f569508e
HS		 1703 }
1704 } else {
1705 # Should never happen
1706 die "Unknown ping from pid [$pid]";
1707 }
1708 } else {
1709 die "Empty response from status socket?";
1710 }
69c74a9c
HS		 1711 }
1712 if (defined $nfound) {
f569508e
HS		 1713 # Timed out waiting for ACK status
1714 } else {
1715 # Weird error occurred with select()
1716 warn("select: $!");
1717 }
1718 }
26e9d721 1719 if (my @synners = keys %{ $self->{syn} }) {
f569508e
HS		 1720 # Kill all the synners
1721 kill 9, @synners;
1722 foreach my $pid (@synners) {
1723 # Wait for the deaths to finish
1724 # Then flush off the zombie
1725 waitpid($pid, 0);
1726 }
1727 }
26e9d721 1728 $self->{syn} = {};
f569508e
HS		 1729 return ();
1730}
1731
1732# Description: Tell why the ack() failed
1733sub nack {
1734 my $self = shift;
1735 my $host = shift || croak('Usage> nack($failed_ack_host)');
26e9d721 1736 return $self->{bad}->{$host} || undef;
f569508e
HS		 1737}
1738
1739# Description: Close the connection.
a3b93737
RM		 1740
1741sub close
1742{
e82f584b 1743 my ($self) = @_;
a3b93737 1744
26e9d721
SH		 1745 if ($self->{proto} eq "syn") {
1746 delete $self->{syn};
1747 } elsif ($self->{proto} eq "tcp") {
f569508e 1748 # The connection will already be closed
26e9d721 1749 } elsif ($self->{proto} eq "external") {
ad0c015e 1750 # Nothing to close
f569508e 1751 } else {
26e9d721 1752 $self->{fh}->close();
f569508e 1753 }
a3b93737
RM		 1754}
1755
af96568d
RGS		 1756sub port_number {
1757 my $self = shift;
1758 if(@_) {
1759 $self->{port_num} = shift @_;
1760 $self->service_check(1);
1761 }
1762 return $self->{port_num};
1763}
1764
4e0aac35
MM		 1765sub ntop {
1766 my($self, $ip) = @_;
1767
1768 # Vista doesn't define a inet_ntop. It has InetNtop instead.
1769 # Not following ANSI... priceless. getnameinfo() is defined
1770 # for Windows 2000 and later, so that may be the choice.
1771
1772 # Any port will work, even undef, but this will work for now.
1773 # Socket warns when undef is passed in, but it still works.
1774 my $port = getservbyname('echo', 'udp');
773d126d 1775 my $sockaddr = _pack_sockaddr_in($port, $ip);
8c91ebab
SH		 1776 my ($error, $address) = getnameinfo($sockaddr, $NI_NUMERICHOST);
1777 croak $error if $error;
4e0aac35
MM		 1778 return $address;
1779}
a3b93737 1780
773d126d
CBW		 1781sub wakeonlan {
1782 my ($mac_addr, $host, $port) = @_;
1783
1784 # use the discard service if $port not passed in
1785 if (! defined $host) { $host = '255.255.255.255' }
1786 if (! defined $port || $port !~ /^\d+$/ ) { $port = 9 }
1787
1788 require IO::Socket::INET;
1789 my $sock = IO::Socket::INET->new(Proto=>'udp') || return undef;
1790
1791 my $ip_addr = inet_aton($host);
1792 my $sock_addr = sockaddr_in($port, $ip_addr);
1793 $mac_addr =~ s/://g;
1794 my $packet = pack('C6H*', 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, $mac_addr x 16);
1795
1796 setsockopt($sock, SOL_SOCKET, SO_BROADCAST, 1);
1797 send($sock, $packet, 0, $sock_addr);
1798 $sock->close;
1799
1800 return 1;
1801}
1802
1803########################################################
1804# DNS hostname resolution
1805# return:
1806# $h->{name} = host - as passed in
1807# $h->{host} = host - as passed in without :port
1808# $h->{port} = OPTIONAL - if :port, then value of port
1809# $h->{addr} = resolved numeric address
1810# $h->{addr_in} = aton/pton result
1811# $h->{family} = AF_INET/6
1812############################
1813sub _resolv {
1814 my ($self,
1815 $name,
1816 ) = @_;
1817
1818 my %h;
1819 $h{name} = $name;
26e9d721 1820 my $family = $self->{family};
773d126d 1821
26e9d721
SH		 1822 if (defined($self->{family_local})) {
1823 $family = $self->{family_local}
773d126d
CBW		 1824 }
1825
1826# START - host:port
1827 my $cnt = 0;
1828
1829 # Count ":"
1830 $cnt++ while ($name =~ m/:/g);
1831
1832 # 0 = hostname or IPv4 address
1833 if ($cnt == 0) {
1834 $h{host} = $name
1835 # 1 = IPv4 address with port
1836 } elsif ($cnt == 1) {
1837 ($h{host}, $h{port}) = split /:/, $name
1838 # >=2 = IPv6 address
1839 } elsif ($cnt >= 2) {
1840 #IPv6 with port - [2001::1]:port
1841 if ($name =~ /^\[.*\]:\d{1,5}$/) {
1842 ($h{host}, $h{port}) = split /:([^:]+)$/, $name # split after last :
1843 # IPv6 without port
1844 } else {
1845 $h{host} = $name
1846 }
1847 }
1848
1849 # Clean up host
1850 $h{host} =~ s/\[//g;
1851 $h{host} =~ s/\]//g;
1852 # Clean up port
1853 if (defined($h{port}) && (($h{port} !~ /^\d{1,5}$/) || ($h{port} < 1) || ($h{port} > 65535))) {
1854 croak("Invalid port `$h{port}' in `$name'");
2e598186 1855 return undef;
773d126d
CBW		 1856 }
1857# END - host:port
1858
1859 # address check
1860 # new way
2e598186 1861 if ($Socket_VERSION > 1.94) {
773d126d
CBW		 1862 my %hints = (
1863 family => $AF_UNSPEC,
1864 protocol => IPPROTO_TCP,
1865 flags => $AI_NUMERICHOST
1866 );
1867
1868 # numeric address, return
1869 my ($err, @getaddr) = Socket::getaddrinfo($h{host}, undef, \%hints);
1870 if (defined($getaddr[0])) {
1871 $h{addr} = $h{host};
1872 $h{family} = $getaddr[0]->{family};
1873 if ($h{family} == AF_INET) {
1874 (undef, $h{addr_in}, undef, undef) = Socket::unpack_sockaddr_in $getaddr[0]->{addr};
1875 } else {
1876 (undef, $h{addr_in}, undef, undef) = Socket::unpack_sockaddr_in6 $getaddr[0]->{addr};
1877 }
1878 return \%h
1879 }
1880 # old way
1881 } else {
1882 # numeric address, return
1883 my $ret = gethostbyname($h{host});
1884 if (defined($ret) && (_inet_ntoa($ret) eq $h{host})) {
1885 $h{addr} = $h{host};
1886 $h{addr_in} = $ret;
1887 $h{family} = AF_INET;
1888 return \%h
1889 }
1890 }
1891
1892 # resolve
1893 # new way
2e598186 1894 if ($Socket_VERSION >= 1.94) {
773d126d
CBW		 1895 my %hints = (
1896 family => $family,
1897 protocol => IPPROTO_TCP
1898 );
1899
1900 my ($err, @getaddr) = Socket::getaddrinfo($h{host}, undef, \%hints);
1901 if (defined($getaddr[0])) {
2e598186 1902 my ($err, $address) = Socket::getnameinfo($getaddr[0]->{addr}, $NI_NUMERICHOST, $NIx_NOSERV);
773d126d
CBW		 1903 if (defined($address)) {
1904 $h{addr} = $address;
1905 $h{addr} =~ s/\%(.)*$//; # remove %ifID if IPv6
1906 $h{family} = $getaddr[0]->{family};
1907 if ($h{family} == AF_INET) {
1908 (undef, $h{addr_in}, undef, undef) = Socket::unpack_sockaddr_in $getaddr[0]->{addr};
1909 } else {
1910 (undef, $h{addr_in}, undef, undef) = Socket::unpack_sockaddr_in6 $getaddr[0]->{addr};
1911 }
2e598186 1912 return \%h;
773d126d 1913 } else {
2e598186
N		 1914 carp("getnameinfo($getaddr[0]->{addr}) failed - $err");
1915 return undef;
773d126d
CBW		 1916 }
1917 } else {
2e598186 1918 warn(sprintf("getaddrinfo($h{host},,%s) failed - $err",
8c91ebab 1919 $family == AF_INET ? "AF_INET" : "AF_INET6"));
2e598186 1920 return undef;
773d126d
CBW		 1921 }
1922 # old way
1923 } else {
1924 if ($family == $AF_INET6) {
1925 croak("Socket >= 1.94 required for IPv6 - found Socket $Socket::VERSION");
2e598186 1926 return undef;
773d126d
CBW		 1927 }
1928
1929 my @gethost = gethostbyname($h{host});
1930 if (defined($gethost[4])) {
1931 $h{addr} = inet_ntoa($gethost[4]);
1932 $h{addr_in} = $gethost[4];
1933 $h{family} = AF_INET;
1934 return \%h
1935 } else {
2e598186
N		 1936 carp("gethostbyname($h{host}) failed - $^E");
1937 return undef;
773d126d
CBW		 1938 }
1939 }
2e598186 1940 return undef;
773d126d
CBW		 1941}
1942
1943sub _pack_sockaddr_in($$) {
1944 my ($port,
26e9d721 1945 $ip,
773d126d
CBW		 1946 ) = @_;
1947
26e9d721
SH		 1948 my $addr = ref($ip) eq "HASH" ? $ip->{addr_in} : $ip;
1949 if (length($addr) <= 4 ) {
1950 return Socket::pack_sockaddr_in($port, $addr);
773d126d 1951 } else {
26e9d721 1952 return Socket::pack_sockaddr_in6($port, $addr);
773d126d
CBW		 1953 }
1954}
1955
1956sub _unpack_sockaddr_in($;$) {
1957 my ($addr,
1958 $family,
1959 ) = @_;
1960
1961 my ($port, $host);
1962 if ($family == AF_INET || (!defined($family) and length($addr) <= 16 )) {
1963 ($port, $host) = Socket::unpack_sockaddr_in($addr);
1964 } else {
1965 ($port, $host) = Socket::unpack_sockaddr_in6($addr);
1966 }
1967 return $port, $host
1968}
1969
1970sub _inet_ntoa {
1971 my ($addr
1972 ) = @_;
1973
1974 my $ret;
2e598186 1975 if ($Socket_VERSION >= 1.94) {
773d126d
CBW		 1976 my ($err, $address) = Socket::getnameinfo($addr, $NI_NUMERICHOST);
1977 if (defined($address)) {
1978 $ret = $address;
1979 } else {
2e598186 1980 carp("getnameinfo($addr) failed - $err");
773d126d
CBW		 1981 }
1982 } else {
1983 $ret = inet_ntoa($addr)
1984 }
1985
1986 return $ret
1987}
1988
a0d0e21e 19891;
8e07c86e
AD		 1990__END__
1991
8e07c86e
AD		 1992=head1 NAME
1993
a3b93737 1994Net::Ping - check a remote host for reachability
8e07c86e
AD		 1995
1996=head1 SYNOPSIS
1997
1998 use Net::Ping;
8e07c86e 1999
a3b93737
RM		 2000 $p = Net::Ping->new();
2001 print "$host is alive.\n" if $p->ping($host);
2002 $p->close();
2003
2004 $p = Net::Ping->new("icmp");
49afa5f6 2005 $p->bind($my_addr); # Specify source interface of pings
a3b93737
RM		 2006 foreach $host (@host_array)
2007 {
2008 print "$host is ";
2009 print "NOT " unless $p->ping($host, 2);
2010 print "reachable.\n";
2011 sleep(1);
2012 }
2013 $p->close();
b124990b 2014
a3b93737 2015 $p = Net::Ping->new("tcp", 2);
b124990b 2016 # Try connecting to the www port instead of the echo port
1bd59f2c 2017 $p->port_number(scalar(getservbyname("http", "tcp")));
a3b93737
RM		 2018 while ($stop_time > time())
2019 {
2020 print "$host not reachable ", scalar(localtime()), "\n"
2021 unless $p->ping($host);
2022 sleep(300);
2023 }
2024 undef($p);
b124990b 2025
f569508e
HS		 2026 # Like tcp protocol, but with many hosts
2027 $p = Net::Ping->new("syn");
af96568d 2028 $p->port_number(getservbyname("http", "tcp"));
f569508e
HS		 2029 foreach $host (@host_array) {
2030 $p->ping($host);
2031 }
2032 while (($host,$rtt,$ip) = $p->ack) {
2033 print "HOST: $host [$ip] ACKed in $rtt seconds.\n";
2034 }
2035
e82f584b
JH		 2036 # High precision syntax (requires Time::HiRes)
2037 $p = Net::Ping->new();
2038 $p->hires();
2039 ($ret, $duration, $ip) = $p->ping($host, 5.5);
b08c27cd
FC		 2040 printf("$host [ip: $ip] is alive (packet return time: %.2f ms)\n",
2041 1000 * $duration)
e82f584b
JH		 2042 if $ret;
2043 $p->close();
2044
a3b93737
RM		 2045 # For backward compatibility
2046 print "$host is alive.\n" if pingecho($host);
8e07c86e 2047
a3b93737 2048=head1 DESCRIPTION
8e07c86e 2049
a3b93737
RM		 2050This module contains methods to test the reachability of remote
2051hosts on a network. A ping object is first created with optional
2052parameters, a variable number of hosts may be pinged multiple
2053times and then the connection is closed.
2054
f569508e
HS		 2055You may choose one of six different protocols to use for the
2056ping. The "tcp" protocol is the default. Note that a live remote host
b124990b 2057may still fail to be pingable by one or more of these protocols. For
f569508e 2058example, www.microsoft.com is generally alive but not "icmp" pingable.
787ecdfa 2059
b124990b
JH		 2060With the "tcp" protocol the ping() method attempts to establish a
2061connection to the remote host's echo port. If the connection is
2062successfully established, the remote host is considered reachable. No
2063data is actually echoed. This protocol does not require any special
9c36735d 2064privileges but has higher overhead than the "udp" and "icmp" protocols.
072620d9 2065
b124990b 2066Specifying the "udp" protocol causes the ping() method to send a udp
a3b93737
RM		 2067packet to the remote host's echo port. If the echoed packet is
2068received from the remote host and the received packet contains the
2069same data as the packet that was sent, the remote host is considered
2070reachable. This protocol does not require any special privileges.
b124990b 2071It should be borne in mind that, for a udp ping, a host
787ecdfa 2072will be reported as unreachable if it is not running the
b124990b
JH		 2073appropriate echo service. For Unix-like systems see L<inetd(8)>
2074for more information.
787ecdfa 2075
b124990b
JH		 2076If the "icmp" protocol is specified, the ping() method sends an icmp
2077echo message to the remote host, which is what the UNIX ping program
2078does. If the echoed message is received from the remote host and
2079the echoed information is correct, the remote host is considered
2080reachable. Specifying the "icmp" protocol requires that the program
2081be run as root or that the program be setuid to root.
787ecdfa 2082
b124990b
JH		 2083If the "external" protocol is specified, the ping() method attempts to
2084use the C<Net::Ping::External> module to ping the remote host.
2085C<Net::Ping::External> interfaces with your system's default C<ping>
2086utility to perform the ping, and generally produces relatively
787ecdfa
JH		 2087accurate results. If C<Net::Ping::External> if not installed on your
2088system, specifying the "external" protocol will result in an error.
edc5bd88 2089
2e598186 2090If the "syn" protocol is specified, the L</ping> method will only
f569508e
HS		 2091send a TCP SYN packet to the remote host then immediately return.
2092If the syn packet was sent successfully, it will return a true value,
2093otherwise it will return false. NOTE: Unlike the other protocols,
2094the return value does NOT determine if the remote host is alive or
2095not since the full TCP three-way handshake may not have completed
2096yet. The remote host is only considered reachable if it receives
3c4b39be 2097a TCP ACK within the timeout specified. To begin waiting for the
2e598186 2098ACK packets, use the L</ack> method as explained below. Use the
f569508e
HS		 2099"syn" protocol instead the "tcp" protocol to determine reachability
2100of multiple destinations simultaneously by sending parallel TCP
2101SYN packets. It will not block while testing each remote host.
f569508e
HS		 2102This protocol does not require any special privileges.
2103
a3b93737
RM		 2104=head2 Functions
2105
2106=over 4
2107
773d126d
CBW		 2108=item Net::Ping->new([proto, timeout, bytes, device, tos, ttl, family,
2109 host, port, bind, gateway, retrans, pingstring,
2110 source_verify econnrefused dontfrag
2111 IPV6_USE_MIN_MTU IPV6_RECVPATHMTU])
2e598186 2112X<new>
a3b93737 2113
773d126d
CBW		 2114Create a new ping object. All of the parameters are optional and can
2115be passed as hash ref. All options besides the first 7 must be passed
2116as hash ref.
a3b93737 2117
773d126d
CBW		 2118C<proto> specifies the protocol to use when doing a ping. The current
2119choices are "tcp", "udp", "icmp", "icmpv6", "stream", "syn", or
2120"external". The default is "tcp".
2121
2122If a C<timeout> in seconds is provided, it is used
a3b93737
RM		 2123when a timeout is not given to the ping() method (below). The timeout
2124must be greater than 0 and the default, if not specified, is 5 seconds.
2125
773d126d 2126If the number of data bytes (C<bytes>) is given, that many data bytes
a3b93737
RM		 2127are included in the ping packet sent to the remote host. The number of
2128data bytes is ignored if the protocol is "tcp". The minimum (and
2129default) number of data bytes is 1 if the protocol is "udp" and 0
2130otherwise. The maximum number of data bytes that can be specified is
2e598186
N		 213165535, but staying below the MTU (1472 bytes for ICMP) is recommended.
2132Many small devices cannot deal with fragmented ICMP packets.
a3b93737 2133
773d126d 2134If C<device> is given, this device is used to bind the source endpoint
3c4b39be 2135before sending the ping packet. I believe this only works with
f569508e
HS		 2136superuser privileges and with udp and icmp protocols at this time.
2137
773d126d
CBW		 2138If <tos> is given, this ToS is configured into the socket.
2139
2140For icmp, C<ttl> can be specified to set the TTL of the outgoing packet.
2141
2142Valid C<family> values for IPv4:
2143
2144 4, v4, ip4, ipv4, AF_INET (constant)
2145
2146Valid C<family> values for IPv6:
2147
2148 6, v6, ip6, ipv6, AF_INET6 (constant)
2149
2150The C<host> argument implicitly specifies the family if the family
2151argument is not given.
2152
2153The C<port> argument is only valid for a udp, tcp or stream ping, and will not
2154do what you think it does. ping returns true when we get a "Connection refused"!
2155The default is the echo port.
2156
2157The C<bind> argument specifies the local_addr to bind to.
2158By specifying a bind argument you don't need the bind method.
2159
2160The C<gateway> argument is only valid for IPv6, and requires a IPv6
2161address.
03550e9d 2162
773d126d
CBW		 2163The C<retrans> argument the exponential backoff rate, default 1.2.
2164It matches the $def_factor global.
1bd59f2c 2165
773d126d
CBW		 2166The C<dontfrag> argument sets the IP_DONTFRAG bit, but note that
2167IP_DONTFRAG is not yet defined by Socket, and not available on many
2168systems. Then it is ignored. On linux it also sets IP_MTU_DISCOVER to
2169IP_PMTUDISC_DO but need we don't chunk oversized packets. You need to
2170set $data_size manually.
2171
2172=item $p->ping($host [, $timeout [, $family]]);
2e598186 2173X<ping>
5d20095f
JH		 2174
2175Ping the remote host and wait for a response. $host can be either the
2176hostname or the IP number of the remote host. The optional timeout
2177must be greater than 0 seconds and defaults to whatever was specified
2178when the ping object was created. Returns a success flag. If the
2179hostname cannot be found or there is a problem with the IP number, the
2180success flag returned will be undef. Otherwise, the success flag will
2181be 1 if the host is reachable and 0 if it is not. For most practical
2182purposes, undef and 0 and can be treated as the same case. In array
f569508e
HS		 2183context, the elapsed time as well as the string form of the ip the
2184host resolved to are also returned. The elapsed time value will
c4a6f826 2185be a float, as returned by the Time::HiRes::time() function, if hires()
5d20095f
JH		 2186has been previously called, otherwise it is returned as an integer.
2187
15d96390 2188=item $p->source_verify( { 0 | 1 } );
2e598186 2189X<source_verify>
15d96390
JH		 2190
2191Allows source endpoint verification to be enabled or disabled.
2192This is useful for those remote destinations with multiples
2193interfaces where the response may not originate from the same
2194endpoint that the original destination endpoint was sent to.
5d20095f 2195This only affects udp and icmp protocol pings.
15d96390
JH		 2196
2197This is enabled by default.
2198
c94ff782 2199=item $p->service_check( { 0 | 1 } );
2e598186 2200X<service_check>
f569508e 2201
c94ff782 2202Set whether or not the connect behavior should enforce
f569508e
HS		 2203remote service availability as well as reachability. Normally,
2204if the remote server reported ECONNREFUSED, it must have been
2205reachable because of the status packet that it reported.
2206With this option enabled, the full three-way tcp handshake
2207must have been established successfully before it will
2208claim it is reachable. NOTE: It still does nothing more
2209than connect and disconnect. It does not speak any protocol
2210(i.e., HTTP or FTP) to ensure the remote server is sane in
2211any way. The remote server CPU could be grinding to a halt
2212and unresponsive to any clients connecting, but if the kernel
2213throws the ACK packet, it is considered alive anyway. To
2214really determine if the server is responding well would be
2215application specific and is beyond the scope of Net::Ping.
c94ff782
JH		 2216For udp protocol, enabling this option demands that the
2217remote server replies with the same udp data that it was sent
2218as defined by the udp echo service.
f569508e 2219
c94ff782 2220This affects the "udp", "tcp", and "syn" protocols.
f569508e
HS		 2221
2222This is disabled by default.
2223
c94ff782 2224=item $p->tcp_service_check( { 0 | 1 } );
2e598186 2225X<tcp_service_check>
c94ff782 2226
3c4b39be 2227Deprecated method, but does the same as service_check() method.
c94ff782 2228
e82f584b 2229=item $p->hires( { 0 | 1 } );
2e598186 2230X<hires>
e82f584b 2231
773d126d 2232With 1 causes this module to use Time::HiRes module, allowing milliseconds
e82f584b
JH		 2233to be returned by subsequent calls to ping().
2234
773d126d 2235=item $p->time
2e598186 2236X<time>
773d126d
CBW		 2237
2238The current time, hires or not.
2239
2240=item $p->socket_blocking_mode( $fh, $mode );
2e598186 2241X<socket_blocking_mode>
773d126d
CBW		 2242
2243Sets or clears the O_NONBLOCK flag on a file handle.
2244
2245=item $p->IPV6_USE_MIN_MTU
2e598186 2246X<IPV6_USE_MIN_MTU>
773d126d
CBW		 2247
2248With argument sets the option.
2249Without returns the option value.
2250
2251=item $p->IPV6_RECVPATHMTU
2e598186 2252X<IPV6_RECVPATHMTU>
773d126d
CBW		 2253
2254Notify an according IPv6 MTU.
2255
2256With argument sets the option.
2257Without returns the option value.
2258
2259=item $p->IPV6_HOPLIMIT
2e598186 2260X<IPV6_HOPLIMIT>
773d126d
CBW		 2261
2262With argument sets the option.
2263Without returns the option value.
2264
2265=item $p->IPV6_REACHCONF I<NYI>
2e598186 2266X<IPV6_REACHCONF>
773d126d
CBW		 2267
2268Sets ipv6 reachability
2269IPV6_REACHCONF was removed in RFC3542. ping6 -R supports it.
2270IPV6_REACHCONF requires root/admin permissions.
2271
2272With argument sets the option.
2273Without returns the option value.
2274
2275Not yet implemented.
15d96390 2276
49afa5f6 2277=item $p->bind($local_addr);
2e598186 2278X<bind>
49afa5f6
JH		 2279
2280Sets the source address from which pings will be sent. This must be
2281the address of one of the interfaces on the local host. $local_addr
2282may be specified as a hostname or as a text IP address such as
2283"192.168.1.1".
2284
2285If the protocol is set to "tcp", this method may be called any
2286number of times, and each call to the ping() method (below) will use
2287the most recent $local_addr. If the protocol is "icmp" or "udp",
2288then bind() must be called at most once per object, and (if it is
2289called at all) must be called before the first call to ping() for that
2290object.
2291
773d126d
CBW		 2292The bind() call can be omitted when specifying the C<bind> option to
2293new().
2294
2e598186
N		 2295=item $p->message_type([$ping_type]);
2296X<message_type>
2297
2298When you are using the "icmp" protocol, this call permit to change the
2299message type to 'echo' or 'timestamp' (only for IPv4, see RFC 792).
2300
2301Without argument, it returns the currently used icmp protocol message type.
2302By default, it returns 'echo'.
2303
b124990b 2304=item $p->open($host);
2e598186 2305X<open>
b124990b 2306
f569508e 2307When you are using the "stream" protocol, this call pre-opens the
b124990b
JH		 2308tcp socket. It's only necessary to do this if you want to
2309provide a different timeout when creating the connection, or
2310remove the overhead of establishing the connection from the
2311first ping. If you don't call C<open()>, the connection is
2312automatically opened the first time C<ping()> is called.
787ecdfa
JH		 2313This call simply does nothing if you are using any protocol other
2314than stream.
2315
773d126d
CBW		 2316The $host argument can be omitted when specifying the C<host> option to
2317new().
2318
f569508e 2319=item $p->ack( [ $host ] );
2e598186 2320X<ack>
f569508e
HS		 2321
2322When using the "syn" protocol, use this method to determine
2323the reachability of the remote host. This method is meant
2324to be called up to as many times as ping() was called. Each
2325call returns the host (as passed to ping()) that came back
2326with the TCP ACK. The order in which the hosts are returned
2327may not necessarily be the same order in which they were
2328SYN queued using the ping() method. If the timeout is
2329reached before the TCP ACK is received, or if the remote
2330host is not listening on the port attempted, then the TCP
2331connection will not be established and ack() will return
8c91ebab
SH		 2332undef. In list context, the host, the ack time, the dotted ip
2333string, and the port number will be returned instead of just the host.
2e598186 2334If the optional C<$host> argument is specified, the return
3c4b39be 2335value will be pertaining to that host only.
f569508e 2336This call simply does nothing if you are using any protocol
2e598186 2337other than "syn".
f569508e 2338
2e598186
N		 2339When L</new> had a host option, this host will be used.
2340Without C<$host> argument, all hosts are scanned.
773d126d 2341
f569508e 2342=item $p->nack( $failed_ack_host );
2e598186 2343X<nack>
f569508e 2344
2e598186
N		 2345The reason that C<host $failed_ack_host> did not receive a
2346valid ACK. Useful to find out why when C<ack($fail_ack_host)>
f569508e
HS		 2347returns a false value.
2348
773d126d 2349=item $p->ack_unfork($host)
2e598186 2350X<ack_unfork>
773d126d 2351
2e598186 2352The variant called by L</ack> with the "syn" protocol and C<$syn_forking>
773d126d
CBW		 2353enabled.
2354
2355=item $p->ping_icmp([$host, $timeout, $family])
2e598186 2356X<ping_icmp>
773d126d 2357
2e598186 2358The L</ping> method used with the icmp protocol.
773d126d
CBW		 2359
2360=item $p->ping_icmpv6([$host, $timeout, $family]) I<NYI>
2e598186 2361X<ping_icmpv6>
773d126d 2362
2e598186 2363The L</ping> method used with the icmpv6 protocol.
773d126d
CBW		 2364
2365=item $p->ping_stream([$host, $timeout, $family])
2e598186 2366X<ping_stream>
773d126d 2367
2e598186 2368The L</ping> method used with the stream protocol.
773d126d
CBW		 2369
2370Perform a stream ping. If the tcp connection isn't
2371already open, it opens it. It then sends some data and waits for
2372a reply. It leaves the stream open on exit.
2373
2374=item $p->ping_syn([$host, $ip, $start_time, $stop_time])
2e598186 2375X<ping_syn>
773d126d 2376
2e598186 2377The L</ping> method used with the syn protocol.
773d126d
CBW		 2378Sends a TCP SYN packet to host specified.
2379
2380=item $p->ping_syn_fork([$host, $timeout, $family])
2e598186 2381X<ping_syn_fork>
773d126d 2382
2e598186 2383The L</ping> method used with the forking syn protocol.
773d126d
CBW		 2384
2385=item $p->ping_tcp([$host, $timeout, $family])
2e598186 2386X<ping_tcp>
773d126d 2387
2e598186 2388The L</ping> method used with the tcp protocol.
773d126d
CBW		 2389
2390=item $p->ping_udp([$host, $timeout, $family])
2e598186 2391X<ping_udp>
773d126d 2392
2e598186 2393The L</ping> method used with the udp protocol.
773d126d
CBW		 2394
2395Perform a udp echo ping. Construct a message of
2396at least the one-byte sequence number and any additional data bytes.
2397Send the message out and wait for a message to come back. If we
2398get a message, make sure all of its parts match. If they do, we are
2399done. Otherwise go back and wait for the message until we run out
2400of time. Return the result of our efforts.
2401
2402=item $p->ping_external([$host, $timeout, $family])
2e598186 2403X<ping_external>
773d126d 2404
2e598186
N		 2405The L</ping> method used with the external protocol.
2406Uses L<Net::Ping::External> to do an external ping.
773d126d
CBW		 2407
2408=item $p->tcp_connect([$ip, $timeout])
2e598186 2409X<tcp_connect>
773d126d
CBW		 2410
2411Initiates a TCP connection, for a tcp ping.
2412
2413=item $p->tcp_echo([$ip, $timeout, $pingstring])
2e598186 2414X<tcp_echo>
773d126d
CBW		 2415
2416Performs a TCP echo.
2417It writes the given string to the socket and then reads it
2418back. It returns 1 on success, 0 on failure.
2419
a3b93737 2420=item $p->close();
2e598186 2421X<close>
a3b93737
RM		 2422
2423Close the network connection for this ping object. The network
2424connection is also closed by "undef $p". The network connection is
2425automatically closed if the ping object goes out of scope (e.g. $p is
2426local to a subroutine and you leave the subroutine).
2427
af96568d 2428=item $p->port_number([$port_number])
2e598186 2429X<port_number>
af96568d
RGS		 2430
2431When called with a port number, the port number used to ping is set to
2e598186 2432C<$port_number> rather than using the echo port. It also has the effect
af96568d
RGS		 2433of calling C<$p-E<gt>service_check(1)> causing a ping to return a successful
2434response only if that specific port is accessible. This function returns
2e598186 2435the value of the port that L</ping> will connect to.
af96568d 2436
773d126d 2437=item $p->mselect
2e598186 2438X<mselect>
773d126d 2439
2e598186 2440A C<select()> wrapper that compensates for platform
773d126d
CBW		 2441peculiarities.
2442
2443=item $p->ntop
2e598186 2444X<ntop>
773d126d 2445
2e598186 2446Platform abstraction over C<inet_ntop()>
773d126d
CBW		 2447
2448=item $p->checksum($msg)
2e598186 2449X<checksum>
773d126d
CBW		 2450
2451Do a checksum on the message. Basically sum all of
2452the short words and fold the high order bits into the low order bits.
2453
2454=item $p->icmp_result
2e598186 2455X<icmp_result>
773d126d
CBW		 2456
2457Returns a list of addr, type, subcode.
2458
a3b93737 2459=item pingecho($host [, $timeout]);
2e598186 2460X<pingecho>
a3b93737
RM		 2461
2462To provide backward compatibility with the previous version of
2e598186
N		 2463L<Net::Ping>, a C<pingecho()> subroutine is available with the same
2464functionality as before. C<pingecho()> uses the tcp protocol. The
2465return values and parameters are the same as described for the L</ping>
a3b93737 2466method. This subroutine is obsolete and may be removed in a future
2e598186 2467version of L<Net::Ping>.
8e07c86e 2468
773d126d 2469=item wakeonlan($mac, [$host, [$port]])
2e598186 2470X<wakeonlan>
773d126d
CBW		 2471
2472Emit the popular wake-on-lan magic udp packet to wake up a local
2473device. See also L<Net::Wake>, but this has the mac address as 1st arg.
2e598186 2474C<$host> should be the local gateway. Without it will broadcast.
773d126d
CBW		 2475
2476Default host: '255.255.255.255'
2477Default port: 9
2478
2479 perl -MNet::Ping=wakeonlan -e'wakeonlan "e0:69:95:35:68:d2"'
2480
a3b93737 2481=back
8e07c86e 2482
a3b93737 2483=head1 NOTES
8e07c86e 2484
a3b93737
RM		 2485There will be less network overhead (and some efficiency in your
2486program) if you specify either the udp or the icmp protocol. The tcp
2487protocol will generate 2.5 times or more traffic for each ping than
2488either udp or icmp. If many hosts are pinged frequently, you may wish
2489to implement a small wait (e.g. 25ms or more) between each ping to
2490avoid flooding your network with packets.
8e07c86e 2491
773d126d
CBW		 2492The icmp and icmpv6 protocols requires that the program be run as root
2493or that it be setuid to root. The other protocols do not require
2494special privileges, but not all network devices implement tcp or udp
2495echo.
8e07c86e 2496
a3b93737
RM		 2497Local hosts should normally respond to pings within milliseconds.
2498However, on a very congested network it may take up to 3 seconds or
2499longer to receive an echo packet from the remote host. If the timeout
2500is set too low under these conditions, it will appear that the remote
2501host is not reachable (which is almost the truth).
8e07c86e 2502
a3b93737 2503Reachability doesn't necessarily mean that the remote host is actually
787ecdfa
JH		 2504functioning beyond its ability to echo packets. tcp is slightly better
2505at indicating the health of a system than icmp because it uses more
2506of the networking stack to respond.
8e07c86e 2507
a3b93737
RM		 2508Because of a lack of anything better, this module uses its own
2509routines to pack and unpack ICMP packets. It would be better for a
2510separate module to be written which understands all of the different
2511kinds of ICMP packets.
8e07c86e 2512
5d20095f
JH		 2513=head1 INSTALL
2514
773d126d 2515The latest source tree is available via git:
5d20095f 2516
2e598186 2517 git clone https://github.com/rurban/Net-Ping.git
5d20095f
JH		 2518 cd Net-Ping
2519
2520The tarball can be created as follows:
2521
2522 perl Makefile.PL ; make ; make dist
2523
773d126d 2524The latest Net::Ping releases are included in cperl and perl5.
5d20095f 2525
773d126d 2526=head1 BUGS
5d20095f 2527
773d126d 2528For a list of known issues, visit:
5d20095f 2529
773d126d 2530L<https://rt.cpan.org/NoAuth/Bugs.html?Dist=Net-Ping>
2e598186
N		 2531and
2532L<https://github.com/rurban/Net-Ping/issues>
5d20095f 2533
773d126d 2534To report a new bug, visit:
5d20095f 2535
2e598186 2536L<https://github.com/rurban/Net-Ping/issues>
c94ff782 2537
49afa5f6 2538=head1 AUTHORS
b124990b 2539
773d126d
CBW		 2540 Current maintainers:
2541 perl11 (for cperl, with IPv6 support and more)
2542 p5p (for perl5)
2543
2544 Previous maintainers:
49afa5f6 2545 bbb@cpan.org (Rob Brown)
773d126d 2546 Steve Peters
b124990b 2547
e82f584b
JH		 2548 External protocol:
2549 colinm@cpan.org (Colin McMillen)
2550
b124990b
JH		 2551 Stream protocol:
2552 bronson@trestle.com (Scott Bronson)
2553
773d126d
CBW		 2554 Wake-on-lan:
2555 1999-2003 Clinton Wong
2556
b124990b
JH		 2557 Original pingecho():
2558 karrer@bernina.ethz.ch (Andreas Karrer)
2559 pmarquess@bfsec.bt.co.uk (Paul Marquess)
2560
2561 Original Net::Ping author:
2562 mose@ns.ccsn.edu (Russell Mosemann)
2563
b124990b
JH		 2564=head1 COPYRIGHT
2565
2e598186
N		 2566Copyright (c) 2017-2018, Reini Urban. All rights reserved.
2567
773d126d
CBW		 2568Copyright (c) 2016, cPanel Inc. All rights reserved.
2569
2570Copyright (c) 2012, Steve Peters. All rights reserved.
2571
9c36735d 2572Copyright (c) 2002-2003, Rob Brown. All rights reserved.
49afa5f6 2573
e82f584b 2574Copyright (c) 2001, Colin McMillen. All rights reserved.
b124990b
JH		 2575
2576This program is free software; you may redistribute it and/or
2577modify it under the same terms as Perl itself.
2578
a3b93737 2579=cut
Unnamed repository; edit this file 'description' to name the repository.