lib/Net/Ping.pm

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