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