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