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