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     # ECONNREFUSED is 10061 on MSWin32. If we pass it as child error through $?,
 569     # we'll get (10061 & 255) = 77, so we cannot check it in the parent process.
 570     return ($ret = connect($self->{"fh"}, $saddr) || ($! == ECONNREFUSED && !$self->{"econnrefused"}));
 571   };
 572   my $do_connect_nb = sub {
 573     # Set O_NONBLOCK property on filehandle
 574     $self->socket_blocking_mode($self->{"fh"}, 0);
 575
 576     # start the connection attempt
 577     if (!connect($self->{"fh"}, $saddr)) {
 578       if ($! == ECONNREFUSED) {
 579         $ret = 1 unless $self->{"econnrefused"};
 580       } elsif ($! != EINPROGRESS && ($^O ne 'MSWin32' || $! != EWOULDBLOCK)) {
 581         # EINPROGRESS is the expected error code after a connect()
 582         # on a non-blocking socket.  But if the kernel immediately
 583         # determined that this connect() will never work,
 584         # Simply respond with "unreachable" status.
 585         # (This can occur on some platforms with errno
 586         # EHOSTUNREACH or ENETUNREACH.)
 587         return 0;
 588       } else {
 589         # Got the expected EINPROGRESS.
 590         # Just wait for connection completion...
 591         my ($wbits, $wout, $wexc);
 592         $wout = $wexc = $wbits = "";
 593         vec($wbits, $self->{"fh"}->fileno, 1) = 1;
 594
 595         my $nfound = mselect(undef,
 596                             ($wout = $wbits),
 597                             ($^O eq 'MSWin32' ? ($wexc = $wbits) : undef),
 598                             $timeout);
 599         warn("select: $!") unless defined $nfound;
 600
 601         if ($nfound && vec($wout, $self->{"fh"}->fileno, 1)) {
 602           # the socket is ready for writing so the connection
 603           # attempt completed. test whether the connection
 604           # attempt was successful or not
 605
 606           if (getpeername($self->{"fh"})) {
 607             # Connection established to remote host
 608             $ret = 1;
 609           } else {
 610             # TCP ACK will never come from this host
 611             # because there was an error connecting.
 612
 613             # This should set $! to the correct error.
 614             my $char;
 615             sysread($self->{"fh"},$char,1);
 616             $! = ECONNREFUSED if ($! == EAGAIN && $^O =~ /cygwin/i);
 617
 618             $ret = 1 if (!$self->{"econnrefused"}
 619                          && $! == ECONNREFUSED);
 620           }
 621         } else {
 622           # the connection attempt timed out (or there were connect
 623           # errors on Windows)
 624           if ($^O =~ 'MSWin32') {
 625               # If the connect will fail on a non-blocking socket,
 626               # winsock reports ECONNREFUSED as an exception, and we
 627               # need to fetch the socket-level error code via getsockopt()
 628               # instead of using the thread-level error code that is in $!.
 629               if ($nfound && vec($wexc, $self->{"fh"}->fileno, 1)) {
 630                   $! = unpack("i", getsockopt($self->{"fh"}, SOL_SOCKET,
 631                                               SO_ERROR));
 632               }
 633           }
 634         }
 635       }
 636     } else {
 637       # Connection established to remote host
 638       $ret = 1;
 639     }
 640
 641     # Unset O_NONBLOCK property on filehandle
 642     $self->socket_blocking_mode($self->{"fh"}, 1);
 643     $self->{"ip"} = $ip;
 644     return $ret;
 645   };
 646
 647   if ($syn_forking) {
 648     # Buggy Winsock API doesn't allow nonblocking connect.
 649     # Hence, if our OS is Windows, we need to create a separate
 650     # process to do the blocking connect attempt.
 651     # XXX Above comments are not true at least for Win2K, where
 652     # nonblocking connect works.
 653
 654     $| = 1; # Clear buffer prior to fork to prevent duplicate flushing.
 655     $self->{'tcp_chld'} = fork;
 656     if (!$self->{'tcp_chld'}) {
 657       if (!defined $self->{'tcp_chld'}) {
 658         # Fork did not work
 659         warn "Fork error: $!";
 660         return 0;
 661       }
 662       &{ $do_socket }();
 663
 664       # Try a slow blocking connect() call
 665       # and report the status to the parent.
 666       if ( &{ $do_connect }() ) {
 667         $self->{"fh"}->close();
 668         # No error
 669         exit 0;
 670       } else {
 671         # Pass the error status to the parent
 672         # Make sure that $! <= 255
 673         exit($! <= 255 ? $! : 255);
 674       }
 675     }
 676
 677     &{ $do_socket }();
 678
 679     my $patience = &time() + $timeout;
 680
 681     my ($child, $child_errno);
 682     $? = 0; $child_errno = 0;
 683     # Wait up to the timeout
 684     # And clean off the zombie
 685     do {
 686       $child = waitpid($self->{'tcp_chld'}, &WNOHANG());
 687       $child_errno = $? >> 8;
 688       select(undef, undef, undef, 0.1);
 689     } while &time() < $patience && $child != $self->{'tcp_chld'};
 690
 691     if ($child == $self->{'tcp_chld'}) {
 692       if ($self->{"proto"} eq "stream") {
 693         # We need the socket connected here, in parent
 694         # Should be safe to connect because the child finished
 695         # within the timeout
 696         &{ $do_connect }();
 697       }
 698       # $ret cannot be set by the child process
 699       $ret = !$child_errno;
 700     } else {
 701       # Time must have run out.
 702       # Put that choking client out of its misery
 703       kill "KILL", $self->{'tcp_chld'};
 704       # Clean off the zombie
 705       waitpid($self->{'tcp_chld'}, 0);
 706       $ret = 0;
 707     }
 708     delete $self->{'tcp_chld'};
 709     $! = $child_errno;
 710   } else {
 711     # Otherwise don't waste the resources to fork
 712
 713     &{ $do_socket }();
 714
 715     &{ $do_connect_nb }();
 716   }
 717
 718   return $ret;
 719 }
 720
 721 sub DESTROY {
 722   my $self = shift;
 723   if ($self->{'proto'} eq 'tcp' &&
 724       $self->{'tcp_chld'}) {
 725     # Put that choking client out of its misery
 726     kill "KILL", $self->{'tcp_chld'};
 727     # Clean off the zombie
 728     waitpid($self->{'tcp_chld'}, 0);
 729   }
 730 }
 731
 732 # This writes the given string to the socket and then reads it
 733 # back.  It returns 1 on success, 0 on failure.
 734 sub tcp_echo
 735 {
 736   my $self = shift;
 737   my $timeout = shift;
 738   my $pingstring = shift;
 739
 740   my $ret = undef;
 741   my $time = &time();
 742   my $wrstr = $pingstring;
 743   my $rdstr = "";
 744
 745   eval <<'EOM';
 746     do {
 747       my $rin = "";
 748       vec($rin, $self->{"fh"}->fileno(), 1) = 1;
 749
 750       my $rout = undef;
 751       if($wrstr) {
 752         $rout = "";
 753         vec($rout, $self->{"fh"}->fileno(), 1) = 1;
 754       }
 755
 756       if(mselect($rin, $rout, undef, ($time + $timeout) - &time())) {
 757
 758         if($rout && vec($rout,$self->{"fh"}->fileno(),1)) {
 759           my $num = syswrite($self->{"fh"}, $wrstr, length $wrstr);
 760           if($num) {
 761             # If it was a partial write, update and try again.
 762             $wrstr = substr($wrstr,$num);
 763           } else {
 764             # There was an error.
 765             $ret = 0;
 766           }
 767         }
 768
 769         if(vec($rin,$self->{"fh"}->fileno(),1)) {
 770           my $reply;
 771           if(sysread($self->{"fh"},$reply,length($pingstring)-length($rdstr))) {
 772             $rdstr .= $reply;
 773             $ret = 1 if $rdstr eq $pingstring;
 774           } else {
 775             # There was an error.
 776             $ret = 0;
 777           }
 778         }
 779
 780       }
 781     } until &time() > ($time + $timeout) || defined($ret);
 782 EOM
 783
 784   return $ret;
 785 }
 786
 787
 788
 789
 790 # Description: Perform a stream ping.  If the tcp connection isn't
 791 # already open, it opens it.  It then sends some data and waits for
 792 # a reply.  It leaves the stream open on exit.
 793
 794 sub ping_stream
 795 {
 796   my ($self,
 797       $ip,                # Packed IP number of the host
 798       $timeout            # Seconds after which ping times out
 799       ) = @_;
 800
 801   # Open the stream if it's not already open
 802   if(!defined $self->{"fh"}->fileno()) {
 803     $self->tcp_connect($ip, $timeout) or return 0;
 804   }
 805
 806   croak "tried to switch servers while stream pinging"
 807     if $self->{"ip"} ne $ip;
 808
 809   return $self->tcp_echo($timeout, $pingstring);
 810 }
 811
 812 # Description: opens the stream.  You would do this if you want to
 813 # separate the overhead of opening the stream from the first ping.
 814
 815 sub open
 816 {
 817   my ($self,
 818       $host,              # Host or IP address
 819       $timeout            # Seconds after which open times out
 820       ) = @_;
 821
 822   my ($ip);               # Packed IP number of the host
 823   $ip = inet_aton($host);
 824   $timeout = $self->{"timeout"} unless $timeout;
 825
 826   if($self->{"proto"} eq "stream") {
 827     if(defined($self->{"fh"}->fileno())) {
 828       croak("socket is already open");
 829     } else {
 830       $self->tcp_connect($ip, $timeout);
 831     }
 832   }
 833 }
 834
 835
 836 # Description:  Perform a udp echo ping.  Construct a message of
 837 # at least the one-byte sequence number and any additional data bytes.
 838 # Send the message out and wait for a message to come back.  If we
 839 # get a message, make sure all of its parts match.  If they do, we are
 840 # done.  Otherwise go back and wait for the message until we run out
 841 # of time.  Return the result of our efforts.
 842
 843 use constant UDP_FLAGS => 0; # Nothing special on send or recv
 844 sub ping_udp
 845 {
 846   my ($self,
 847       $ip,                # Packed IP number of the host
 848       $timeout            # Seconds after which ping times out
 849       ) = @_;
 850
 851   my ($saddr,             # sockaddr_in with port and ip
 852       $ret,               # The return value
 853       $msg,               # Message to be echoed
 854       $finish_time,       # Time ping should be finished
 855       $flush,             # Whether socket needs to be disconnected
 856       $connect,           # Whether socket needs to be connected
 857       $done,              # Set to 1 when we are done pinging
 858       $rbits,             # Read bits, filehandles for reading
 859       $nfound,            # Number of ready filehandles found
 860       $from_saddr,        # sockaddr_in of sender
 861       $from_msg,          # Characters echoed by $host
 862       $from_port,         # Port message was echoed from
 863       $from_ip            # Packed IP number of sender
 864       );
 865
 866   $saddr = sockaddr_in($self->{"port_num"}, $ip);
 867   $self->{"seq"} = ($self->{"seq"} + 1) % 256;    # Increment sequence
 868   $msg = chr($self->{"seq"}) . $self->{"data"};   # Add data if any
 869
 870   if ($self->{"connected"}) {
 871     if ($self->{"connected"} ne $saddr) {
 872       # Still connected to wrong destination.
 873       # Need to flush out the old one.
 874       $flush = 1;
 875     }
 876   } else {
 877     # Not connected yet.
 878     # Need to connect() before send()
 879     $connect = 1;
 880   }
 881
 882   # Have to connect() and send() instead of sendto()
 883   # in order to pick up on the ECONNREFUSED setting
 884   # from recv() or double send() errno as utilized in
 885   # the concept by rdw @ perlmonks.  See:
 886   # http://perlmonks.thepen.com/42898.html
 887   if ($flush) {
 888     # Need to socket() again to flush the descriptor
 889     # This will disconnect from the old saddr.
 890     socket($self->{"fh"}, PF_INET, SOCK_DGRAM,
 891            $self->{"proto_num"});
 892   }
 893   # Connect the socket if it isn't already connected
 894   # to the right destination.
 895   if ($flush || $connect) {
 896     connect($self->{"fh"}, $saddr);               # Tie destination to socket
 897     $self->{"connected"} = $saddr;
 898   }
 899   send($self->{"fh"}, $msg, UDP_FLAGS);           # Send it
 900
 901   $rbits = "";
 902   vec($rbits, $self->{"fh"}->fileno(), 1) = 1;
 903   $ret = 0;                   # Default to unreachable
 904   $done = 0;
 905   my $retrans = 0.01;
 906   my $factor = $self->{"retrans"};
 907   $finish_time = &time() + $timeout;       # Ping needs to be done by then
 908   while (!$done && $timeout > 0)
 909   {
 910     if ($factor > 1)
 911     {
 912       $timeout = $retrans if $timeout > $retrans;
 913       $retrans*= $factor; # Exponential backoff
 914     }
 915     $nfound  = mselect((my $rout=$rbits), undef, undef, $timeout); # Wait for response
 916     my $why = $!;
 917     $timeout = $finish_time - &time();   # Get remaining time
 918
 919     if (!defined($nfound))  # Hmm, a strange error
 920     {
 921       $ret = undef;
 922       $done = 1;
 923     }
 924     elsif ($nfound)         # A packet is waiting
 925     {
 926       $from_msg = "";
 927       $from_saddr = recv($self->{"fh"}, $from_msg, 1500, UDP_FLAGS);
 928       if (!$from_saddr) {
 929         # For example an unreachable host will make recv() fail.
 930         if (!$self->{"econnrefused"} &&
 931             ($! == ECONNREFUSED ||
 932              $! == ECONNRESET)) {
 933           # "Connection refused" means reachable
 934           # Good, continue
 935           $ret = 1;
 936         }
 937         $done = 1;
 938       } else {
 939         ($from_port, $from_ip) = sockaddr_in($from_saddr);
 940         if (!$source_verify ||
 941             (($from_ip eq $ip) &&        # Does the packet check out?
 942              ($from_port == $self->{"port_num"}) &&
 943              ($from_msg eq $msg)))
 944         {
 945           $ret = 1;       # It's a winner
 946           $done = 1;
 947         }
 948       }
 949     }
 950     elsif ($timeout <= 0)              # Oops, timed out
 951     {
 952       $done = 1;
 953     }
 954     else
 955     {
 956       # Send another in case the last one dropped
 957       if (send($self->{"fh"}, $msg, UDP_FLAGS)) {
 958         # Another send worked?  The previous udp packet
 959         # must have gotten lost or is still in transit.
 960         # Hopefully this new packet will arrive safely.
 961       } else {
 962         if (!$self->{"econnrefused"} &&
 963             $! == ECONNREFUSED) {
 964           # "Connection refused" means reachable
 965           # Good, continue
 966           $ret = 1;
 967         }
 968         $done = 1;
 969       }
 970     }
 971   }
 972   return $ret;
 973 }
 974
 975 # Description: Send a TCP SYN packet to host specified.
 976 sub ping_syn
 977 {
 978   my $self = shift;
 979   my $host = shift;
 980   my $ip = shift;
 981   my $start_time = shift;
 982   my $stop_time = shift;
 983
 984   if ($syn_forking) {
 985     return $self->ping_syn_fork($host, $ip, $start_time, $stop_time);
 986   }
 987
 988   my $fh = FileHandle->new();
 989   my $saddr = sockaddr_in($self->{"port_num"}, $ip);
 990
 991   # Create TCP socket
 992   if (!socket ($fh, PF_INET, SOCK_STREAM, $self->{"proto_num"})) {
 993     croak("tcp socket error - $!");
 994   }
 995
 996   if (defined $self->{"local_addr"} &&
 997       !CORE::bind($fh, sockaddr_in(0, $self->{"local_addr"}))) {
 998     croak("tcp bind error - $!");
 999   }
1000
1001   if ($self->{'device'}) {
1002     setsockopt($fh, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'}))
1003       or croak("error binding to device $self->{'device'} $!");
1004   }
1005
1006   # Set O_NONBLOCK property on filehandle
1007   $self->socket_blocking_mode($fh, 0);
1008
1009   # Attempt the non-blocking connect
1010   # by just sending the TCP SYN packet
1011   if (connect($fh, $saddr)) {
1012     # Non-blocking, yet still connected?
1013     # Must have connected very quickly,
1014     # or else it wasn't very non-blocking.
1015     #warn "WARNING: Nonblocking connect connected anyway? ($^O)";
1016   } else {
1017     # Error occurred connecting.
1018     if ($! == EINPROGRESS || ($^O eq 'MSWin32' && $! == EWOULDBLOCK)) {
1019       # The connection is just still in progress.
1020       # This is the expected condition.
1021     } else {
1022       # Just save the error and continue on.
1023       # The ack() can check the status later.
1024       $self->{"bad"}->{$host} = $!;
1025     }
1026   }
1027
1028   my $entry = [ $host, $ip, $fh, $start_time, $stop_time ];
1029   $self->{"syn"}->{$fh->fileno} = $entry;
1030   if ($self->{"stop_time"} < $stop_time) {
1031     $self->{"stop_time"} = $stop_time;
1032   }
1033   vec($self->{"wbits"}, $fh->fileno, 1) = 1;
1034
1035   return 1;
1036 }
1037
1038 sub ping_syn_fork {
1039   my ($self, $host, $ip, $start_time, $stop_time) = @_;
1040
1041   # Buggy Winsock API doesn't allow nonblocking connect.
1042   # Hence, if our OS is Windows, we need to create a separate
1043   # process to do the blocking connect attempt.
1044   my $pid = fork();
1045   if (defined $pid) {
1046     if ($pid) {
1047       # Parent process
1048       my $entry = [ $host, $ip, $pid, $start_time, $stop_time ];
1049       $self->{"syn"}->{$pid} = $entry;
1050       if ($self->{"stop_time"} < $stop_time) {
1051         $self->{"stop_time"} = $stop_time;
1052       }
1053     } else {
1054       # Child process
1055       my $saddr = sockaddr_in($self->{"port_num"}, $ip);
1056
1057       # Create TCP socket
1058       if (!socket ($self->{"fh"}, PF_INET, SOCK_STREAM, $self->{"proto_num"})) {
1059         croak("tcp socket error - $!");
1060       }
1061
1062       if (defined $self->{"local_addr"} &&
1063           !CORE::bind($self->{"fh"}, sockaddr_in(0, $self->{"local_addr"}))) {
1064         croak("tcp bind error - $!");
1065       }
1066
1067       if ($self->{'device'}) {
1068         setsockopt($self->{"fh"}, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'}))
1069           or croak("error binding to device $self->{'device'} $!");
1070       }
1071
1072       $!=0;
1073       # Try to connect (could take a long time)
1074       connect($self->{"fh"}, $saddr);
1075       # Notify parent of connect error status
1076       my $err = $!+0;
1077       my $wrstr = "$$ $err";
1078       # Force to 16 chars including \n
1079       $wrstr .= " "x(15 - length $wrstr). "\n";
1080       syswrite($self->{"fork_wr"}, $wrstr, length $wrstr);
1081       exit;
1082     }
1083   } else {
1084     # fork() failed?
1085     die "fork: $!";
1086   }
1087   return 1;
1088 }
1089
1090 # Description: Wait for TCP ACK from host specified
1091 # from ping_syn above.  If no host is specified, wait
1092 # for TCP ACK from any of the hosts in the SYN queue.
1093 sub ack
1094 {
1095   my $self = shift;
1096
1097   if ($self->{"proto"} eq "syn") {
1098     if ($syn_forking) {
1099       my @answer = $self->ack_unfork(shift);
1100       return wantarray ? @answer : $answer[0];
1101     }
1102     my $wbits = "";
1103     my $stop_time = 0;
1104     if (my $host = shift) {
1105       # Host passed as arg
1106       if (exists $self->{"bad"}->{$host}) {
1107         if (!$self->{"econnrefused"} &&
1108             $self->{"bad"}->{ $host } &&
1109             (($! = ECONNREFUSED)>0) &&
1110             $self->{"bad"}->{ $host } eq "$!") {
1111           # "Connection refused" means reachable
1112           # Good, continue
1113         } else {
1114           # ECONNREFUSED means no good
1115           return ();
1116         }
1117       }
1118       my $host_fd = undef;
1119       foreach my $fd (keys %{ $self->{"syn"} }) {
1120         my $entry = $self->{"syn"}->{$fd};
1121         if ($entry->[0] eq $host) {
1122           $host_fd = $fd;
1123           $stop_time = $entry->[4]
1124             || croak("Corrupted SYN entry for [$host]");
1125           last;
1126         }
1127       }
1128       croak("ack called on [$host] without calling ping first!")
1129         unless defined $host_fd;
1130       vec($wbits, $host_fd, 1) = 1;
1131     } else {
1132       # No $host passed so scan all hosts
1133       # Use the latest stop_time
1134       $stop_time = $self->{"stop_time"};
1135       # Use all the bits
1136       $wbits = $self->{"wbits"};
1137     }
1138
1139     while ($wbits !~ /^\0*\z/) {
1140       my $timeout = $stop_time - &time();
1141       # Force a minimum of 10 ms timeout.
1142       $timeout = 0.01 if $timeout <= 0.01;
1143
1144       my $winner_fd = undef;
1145       my $wout = $wbits;
1146       my $fd = 0;
1147       # Do "bad" fds from $wbits first
1148       while ($wout !~ /^\0*\z/) {
1149         if (vec($wout, $fd, 1)) {
1150           # Wipe it from future scanning.
1151           vec($wout, $fd, 1) = 0;
1152           if (my $entry = $self->{"syn"}->{$fd}) {
1153             if ($self->{"bad"}->{ $entry->[0] }) {
1154               $winner_fd = $fd;
1155               last;
1156             }
1157           }
1158         }
1159         $fd++;
1160       }
1161
1162       if (defined($winner_fd) or my $nfound = mselect(undef, ($wout=$wbits), undef, $timeout)) {
1163         if (defined $winner_fd) {
1164           $fd = $winner_fd;
1165         } else {
1166           # Done waiting for one of the ACKs
1167           $fd = 0;
1168           # Determine which one
1169           while ($wout !~ /^\0*\z/ &&
1170                  !vec($wout, $fd, 1)) {
1171             $fd++;
1172           }
1173         }
1174         if (my $entry = $self->{"syn"}->{$fd}) {
1175           # Wipe it from future scanning.
1176           delete $self->{"syn"}->{$fd};
1177           vec($self->{"wbits"}, $fd, 1) = 0;
1178           vec($wbits, $fd, 1) = 0;
1179           if (!$self->{"econnrefused"} &&
1180               $self->{"bad"}->{ $entry->[0] } &&
1181               (($! = ECONNREFUSED)>0) &&
1182               $self->{"bad"}->{ $entry->[0] } eq "$!") {
1183             # "Connection refused" means reachable
1184             # Good, continue
1185           } elsif (getpeername($entry->[2])) {
1186             # Connection established to remote host
1187             # Good, continue
1188           } else {
1189             # TCP ACK will never come from this host
1190             # because there was an error connecting.
1191
1192             # This should set $! to the correct error.
1193             my $char;
1194             sysread($entry->[2],$char,1);
1195             # Store the excuse why the connection failed.
1196             $self->{"bad"}->{$entry->[0]} = $!;
1197             if (!$self->{"econnrefused"} &&
1198                 (($! == ECONNREFUSED) ||
1199                  ($! == EAGAIN && $^O =~ /cygwin/i))) {
1200               # "Connection refused" means reachable
1201               # Good, continue
1202             } else {
1203               # No good, try the next socket...
1204               next;
1205             }
1206           }
1207           # Everything passed okay, return the answer
1208           return wantarray ?
1209             ($entry->[0], &time() - $entry->[3], inet_ntoa($entry->[1]))
1210             : $entry->[0];
1211         } else {
1212           warn "Corrupted SYN entry: unknown fd [$fd] ready!";
1213           vec($wbits, $fd, 1) = 0;
1214           vec($self->{"wbits"}, $fd, 1) = 0;
1215         }
1216       } elsif (defined $nfound) {
1217         # Timed out waiting for ACK
1218         foreach my $fd (keys %{ $self->{"syn"} }) {
1219           if (vec($wbits, $fd, 1)) {
1220             my $entry = $self->{"syn"}->{$fd};
1221             $self->{"bad"}->{$entry->[0]} = "Timed out";
1222             vec($wbits, $fd, 1) = 0;
1223             vec($self->{"wbits"}, $fd, 1) = 0;
1224             delete $self->{"syn"}->{$fd};
1225           }
1226         }
1227       } else {
1228         # Weird error occurred with select()
1229         warn("select: $!");
1230         $self->{"syn"} = {};
1231         $wbits = "";
1232       }
1233     }
1234   }
1235   return ();
1236 }
1237
1238 sub ack_unfork {
1239   my ($self,$host) = @_;
1240   my $stop_time = $self->{"stop_time"};
1241   if ($host) {
1242     # Host passed as arg
1243     if (my $entry = $self->{"good"}->{$host}) {
1244       delete $self->{"good"}->{$host};
1245       return ($entry->[0], &time() - $entry->[3], inet_ntoa($entry->[1]));
1246     }
1247   }
1248
1249   my $rbits = "";
1250   my $timeout;
1251
1252   if (keys %{ $self->{"syn"} }) {
1253     # Scan all hosts that are left
1254     vec($rbits, fileno($self->{"fork_rd"}), 1) = 1;
1255     $timeout = $stop_time - &time();
1256     # Force a minimum of 10 ms timeout.
1257     $timeout = 0.01 if $timeout < 0.01;
1258   } else {
1259     # No hosts left to wait for
1260     $timeout = 0;
1261   }
1262
1263   if ($timeout > 0) {
1264     my $nfound;
1265     while ( keys %{ $self->{"syn"} } and
1266            $nfound = mselect((my $rout=$rbits), undef, undef, $timeout)) {
1267       # Done waiting for one of the ACKs
1268       if (!sysread($self->{"fork_rd"}, $_, 16)) {
1269         # Socket closed, which means all children are done.
1270         return ();
1271       }
1272       my ($pid, $how) = split;
1273       if ($pid) {
1274         # Flush the zombie
1275         waitpid($pid, 0);
1276         if (my $entry = $self->{"syn"}->{$pid}) {
1277           # Connection attempt to remote host is done
1278           delete $self->{"syn"}->{$pid};
1279           if (!$how || # If there was no error connecting
1280               (!$self->{"econnrefused"} &&
1281                $how == ECONNREFUSED)) {  # "Connection refused" means reachable
1282             if ($host && $entry->[0] ne $host) {
1283               # A good connection, but not the host we need.
1284               # Move it from the "syn" hash to the "good" hash.
1285               $self->{"good"}->{$entry->[0]} = $entry;
1286               # And wait for the next winner
1287               next;
1288             }
1289             return ($entry->[0], &time() - $entry->[3], inet_ntoa($entry->[1]));
1290           }
1291         } else {
1292           # Should never happen
1293           die "Unknown ping from pid [$pid]";
1294         }
1295       } else {
1296         die "Empty response from status socket?";
1297       }
1298     }
1299     if (defined $nfound) {
1300       # Timed out waiting for ACK status
1301     } else {
1302       # Weird error occurred with select()
1303       warn("select: $!");
1304     }
1305   }
1306   if (my @synners = keys %{ $self->{"syn"} }) {
1307     # Kill all the synners
1308     kill 9, @synners;
1309     foreach my $pid (@synners) {
1310       # Wait for the deaths to finish
1311       # Then flush off the zombie
1312       waitpid($pid, 0);
1313     }
1314   }
1315   $self->{"syn"} = {};
1316   return ();
1317 }
1318
1319 # Description:  Tell why the ack() failed
1320 sub nack {
1321   my $self = shift;
1322   my $host = shift || croak('Usage> nack($failed_ack_host)');
1323   return $self->{"bad"}->{$host} || undef;
1324 }
1325
1326 # Description:  Close the connection.
1327
1328 sub close
1329 {
1330   my ($self) = @_;
1331
1332   if ($self->{"proto"} eq "syn") {
1333     delete $self->{"syn"};
1334   } elsif ($self->{"proto"} eq "tcp") {
1335     # The connection will already be closed
1336   } else {
1337     $self->{"fh"}->close();
1338   }
1339 }
1340
1341
1342 1;
1343 __END__
1344
1345 =head1 NAME
1346
1347 Net::Ping - check a remote host for reachability
1348
1349 =head1 SYNOPSIS
1350
1351     use Net::Ping;
1352
1353     $p = Net::Ping->new();
1354     print "$host is alive.\n" if $p->ping($host);
1355     $p->close();
1356
1357     $p = Net::Ping->new("icmp");
1358     $p->bind($my_addr); # Specify source interface of pings
1359     foreach $host (@host_array)
1360     {
1361         print "$host is ";
1362         print "NOT " unless $p->ping($host, 2);
1363         print "reachable.\n";
1364         sleep(1);
1365     }
1366     $p->close();
1367
1368     $p = Net::Ping->new("tcp", 2);
1369     # Try connecting to the www port instead of the echo port
1370     $p->{port_num} = getservbyname("http", "tcp");
1371     while ($stop_time > time())
1372     {
1373         print "$host not reachable ", scalar(localtime()), "\n"
1374             unless $p->ping($host);
1375         sleep(300);
1376     }
1377     undef($p);
1378
1379     # Like tcp protocol, but with many hosts
1380     $p = Net::Ping->new("syn");
1381     $p->{port_num} = getservbyname("http", "tcp");
1382     foreach $host (@host_array) {
1383       $p->ping($host);
1384     }
1385     while (($host,$rtt,$ip) = $p->ack) {
1386       print "HOST: $host [$ip] ACKed in $rtt seconds.\n";
1387     }
1388
1389     # High precision syntax (requires Time::HiRes)
1390     $p = Net::Ping->new();
1391     $p->hires();
1392     ($ret, $duration, $ip) = $p->ping($host, 5.5);
1393     printf("$host [ip: $ip] is alive (packet return time: %.2f ms)\n", 1000 * $duration)
1394       if $ret;
1395     $p->close();
1396
1397     # For backward compatibility
1398     print "$host is alive.\n" if pingecho($host);
1399
1400 =head1 DESCRIPTION
1401
1402 This module contains methods to test the reachability of remote
1403 hosts on a network.  A ping object is first created with optional
1404 parameters, a variable number of hosts may be pinged multiple
1405 times and then the connection is closed.
1406
1407 You may choose one of six different protocols to use for the
1408 ping. The "tcp" protocol is the default. Note that a live remote host
1409 may still fail to be pingable by one or more of these protocols. For
1410 example, www.microsoft.com is generally alive but not "icmp" pingable.
1411
1412 With the "tcp" protocol the ping() method attempts to establish a
1413 connection to the remote host's echo port.  If the connection is
1414 successfully established, the remote host is considered reachable.  No
1415 data is actually echoed.  This protocol does not require any special
1416 privileges but has higher overhead than the "udp" and "icmp" protocols.
1417
1418 Specifying the "udp" protocol causes the ping() method to send a udp
1419 packet to the remote host's echo port.  If the echoed packet is
1420 received from the remote host and the received packet contains the
1421 same data as the packet that was sent, the remote host is considered
1422 reachable.  This protocol does not require any special privileges.
1423 It should be borne in mind that, for a udp ping, a host
1424 will be reported as unreachable if it is not running the
1425 appropriate echo service.  For Unix-like systems see L<inetd(8)>
1426 for more information.
1427
1428 If the "icmp" protocol is specified, the ping() method sends an icmp
1429 echo message to the remote host, which is what the UNIX ping program
1430 does.  If the echoed message is received from the remote host and
1431 the echoed information is correct, the remote host is considered
1432 reachable.  Specifying the "icmp" protocol requires that the program
1433 be run as root or that the program be setuid to root.
1434
1435 If the "external" protocol is specified, the ping() method attempts to
1436 use the C<Net::Ping::External> module to ping the remote host.
1437 C<Net::Ping::External> interfaces with your system's default C<ping>
1438 utility to perform the ping, and generally produces relatively
1439 accurate results. If C<Net::Ping::External> if not installed on your
1440 system, specifying the "external" protocol will result in an error.
1441
1442 If the "syn" protocol is specified, the ping() method will only
1443 send a TCP SYN packet to the remote host then immediately return.
1444 If the syn packet was sent successfully, it will return a true value,
1445 otherwise it will return false.  NOTE: Unlike the other protocols,
1446 the return value does NOT determine if the remote host is alive or
1447 not since the full TCP three-way handshake may not have completed
1448 yet.  The remote host is only considered reachable if it receives
1449 a TCP ACK within the timeout specifed.  To begin waiting for the
1450 ACK packets, use the ack() method as explained below.  Use the
1451 "syn" protocol instead the "tcp" protocol to determine reachability
1452 of multiple destinations simultaneously by sending parallel TCP
1453 SYN packets.  It will not block while testing each remote host.
1454 demo/fping is provided in this distribution to demonstrate the
1455 "syn" protocol as an example.
1456 This protocol does not require any special privileges.
1457
1458 =head2 Functions
1459
1460 =over 4
1461
1462 =item Net::Ping->new([$proto [, $def_timeout [, $bytes [, $device ]]]]);
1463
1464 Create a new ping object.  All of the parameters are optional.  $proto
1465 specifies the protocol to use when doing a ping.  The current choices
1466 are "tcp", "udp", "icmp", "stream", "syn", or "external".
1467 The default is "tcp".
1468
1469 If a default timeout ($def_timeout) in seconds is provided, it is used
1470 when a timeout is not given to the ping() method (below).  The timeout
1471 must be greater than 0 and the default, if not specified, is 5 seconds.
1472
1473 If the number of data bytes ($bytes) is given, that many data bytes
1474 are included in the ping packet sent to the remote host. The number of
1475 data bytes is ignored if the protocol is "tcp".  The minimum (and
1476 default) number of data bytes is 1 if the protocol is "udp" and 0
1477 otherwise.  The maximum number of data bytes that can be specified is
1478 1024.
1479
1480 If $device is given, this device is used to bind the source endpoint
1481 before sending the ping packet.  I beleive this only works with
1482 superuser privileges and with udp and icmp protocols at this time.
1483
1484 =item $p->ping($host [, $timeout]);
1485
1486 Ping the remote host and wait for a response.  $host can be either the
1487 hostname or the IP number of the remote host.  The optional timeout
1488 must be greater than 0 seconds and defaults to whatever was specified
1489 when the ping object was created.  Returns a success flag.  If the
1490 hostname cannot be found or there is a problem with the IP number, the
1491 success flag returned will be undef.  Otherwise, the success flag will
1492 be 1 if the host is reachable and 0 if it is not.  For most practical
1493 purposes, undef and 0 and can be treated as the same case.  In array
1494 context, the elapsed time as well as the string form of the ip the
1495 host resolved to are also returned.  The elapsed time value will
1496 be a float, as retuned by the Time::HiRes::time() function, if hires()
1497 has been previously called, otherwise it is returned as an integer.
1498
1499 =item $p->source_verify( { 0 | 1 } );
1500
1501 Allows source endpoint verification to be enabled or disabled.
1502 This is useful for those remote destinations with multiples
1503 interfaces where the response may not originate from the same
1504 endpoint that the original destination endpoint was sent to.
1505 This only affects udp and icmp protocol pings.
1506
1507 This is enabled by default.
1508
1509 =item $p->service_check( { 0 | 1 } );
1510
1511 Set whether or not the connect behavior should enforce
1512 remote service availability as well as reachability.  Normally,
1513 if the remote server reported ECONNREFUSED, it must have been
1514 reachable because of the status packet that it reported.
1515 With this option enabled, the full three-way tcp handshake
1516 must have been established successfully before it will
1517 claim it is reachable.  NOTE:  It still does nothing more
1518 than connect and disconnect.  It does not speak any protocol
1519 (i.e., HTTP or FTP) to ensure the remote server is sane in
1520 any way.  The remote server CPU could be grinding to a halt
1521 and unresponsive to any clients connecting, but if the kernel
1522 throws the ACK packet, it is considered alive anyway.  To
1523 really determine if the server is responding well would be
1524 application specific and is beyond the scope of Net::Ping.
1525 For udp protocol, enabling this option demands that the
1526 remote server replies with the same udp data that it was sent
1527 as defined by the udp echo service.
1528
1529 This affects the "udp", "tcp", and "syn" protocols.
1530
1531 This is disabled by default.
1532
1533 =item $p->tcp_service_check( { 0 | 1 } );
1534
1535 Depricated method, but does the same as service_check() method.
1536
1537 =item $p->hires( { 0 | 1 } );
1538
1539 Causes this module to use Time::HiRes module, allowing milliseconds
1540 to be returned by subsequent calls to ping().
1541
1542 This is disabled by default.
1543
1544 =item $p->bind($local_addr);
1545
1546 Sets the source address from which pings will be sent.  This must be
1547 the address of one of the interfaces on the local host.  $local_addr
1548 may be specified as a hostname or as a text IP address such as
1549 "192.168.1.1".
1550
1551 If the protocol is set to "tcp", this method may be called any
1552 number of times, and each call to the ping() method (below) will use
1553 the most recent $local_addr.  If the protocol is "icmp" or "udp",
1554 then bind() must be called at most once per object, and (if it is
1555 called at all) must be called before the first call to ping() for that
1556 object.
1557
1558 =item $p->open($host);
1559
1560 When you are using the "stream" protocol, this call pre-opens the
1561 tcp socket.  It's only necessary to do this if you want to
1562 provide a different timeout when creating the connection, or
1563 remove the overhead of establishing the connection from the
1564 first ping.  If you don't call C<open()>, the connection is
1565 automatically opened the first time C<ping()> is called.
1566 This call simply does nothing if you are using any protocol other
1567 than stream.
1568
1569 =item $p->ack( [ $host ] );
1570
1571 When using the "syn" protocol, use this method to determine
1572 the reachability of the remote host.  This method is meant
1573 to be called up to as many times as ping() was called.  Each
1574 call returns the host (as passed to ping()) that came back
1575 with the TCP ACK.  The order in which the hosts are returned
1576 may not necessarily be the same order in which they were
1577 SYN queued using the ping() method.  If the timeout is
1578 reached before the TCP ACK is received, or if the remote
1579 host is not listening on the port attempted, then the TCP
1580 connection will not be established and ack() will return
1581 undef.  In list context, the host, the ack time, and the
1582 dotted ip string will be returned instead of just the host.
1583 If the optional $host argument is specified, the return
1584 value will be partaining to that host only.
1585 This call simply does nothing if you are using any protocol
1586 other than syn.
1587
1588 =item $p->nack( $failed_ack_host );
1589
1590 The reason that host $failed_ack_host did not receive a
1591 valid ACK.  Useful to find out why when ack( $fail_ack_host )
1592 returns a false value.
1593
1594 =item $p->close();
1595
1596 Close the network connection for this ping object.  The network
1597 connection is also closed by "undef $p".  The network connection is
1598 automatically closed if the ping object goes out of scope (e.g. $p is
1599 local to a subroutine and you leave the subroutine).
1600
1601 =item pingecho($host [, $timeout]);
1602
1603 To provide backward compatibility with the previous version of
1604 Net::Ping, a pingecho() subroutine is available with the same
1605 functionality as before.  pingecho() uses the tcp protocol.  The
1606 return values and parameters are the same as described for the ping()
1607 method.  This subroutine is obsolete and may be removed in a future
1608 version of Net::Ping.
1609
1610 =back
1611
1612 =head1 NOTES
1613
1614 There will be less network overhead (and some efficiency in your
1615 program) if you specify either the udp or the icmp protocol.  The tcp
1616 protocol will generate 2.5 times or more traffic for each ping than
1617 either udp or icmp.  If many hosts are pinged frequently, you may wish
1618 to implement a small wait (e.g. 25ms or more) between each ping to
1619 avoid flooding your network with packets.
1620
1621 The icmp protocol requires that the program be run as root or that it
1622 be setuid to root.  The other protocols do not require special
1623 privileges, but not all network devices implement tcp or udp echo.
1624
1625 Local hosts should normally respond to pings within milliseconds.
1626 However, on a very congested network it may take up to 3 seconds or
1627 longer to receive an echo packet from the remote host.  If the timeout
1628 is set too low under these conditions, it will appear that the remote
1629 host is not reachable (which is almost the truth).
1630
1631 Reachability doesn't necessarily mean that the remote host is actually
1632 functioning beyond its ability to echo packets.  tcp is slightly better
1633 at indicating the health of a system than icmp because it uses more
1634 of the networking stack to respond.
1635
1636 Because of a lack of anything better, this module uses its own
1637 routines to pack and unpack ICMP packets.  It would be better for a
1638 separate module to be written which understands all of the different
1639 kinds of ICMP packets.
1640
1641 =head1 INSTALL
1642
1643 The latest source tree is available via cvs:
1644
1645   cvs -z3 -q -d :pserver:anonymous@cvs.roobik.com.:/usr/local/cvsroot/freeware checkout Net-Ping
1646   cd Net-Ping
1647
1648 The tarball can be created as follows:
1649
1650   perl Makefile.PL ; make ; make dist
1651
1652 The latest Net::Ping release can be found at CPAN:
1653
1654   $CPAN/modules/by-module/Net/
1655
1656 1) Extract the tarball
1657
1658   gtar -zxvf Net-Ping-xxxx.tar.gz
1659   cd Net-Ping-xxxx
1660
1661 2) Build:
1662
1663   make realclean
1664   perl Makefile.PL
1665   make
1666   make test
1667
1668 3) Install
1669
1670   make install
1671
1672 Or install it RPM Style:
1673
1674   rpm -ta SOURCES/Net-Ping-xxxx.tar.gz
1675
1676   rpm -ih RPMS/noarch/perl-Net-Ping-xxxx.rpm
1677
1678 =head1 BUGS
1679
1680 For a list of known issues, visit:
1681
1682 https://rt.cpan.org/NoAuth/Bugs.html?Dist=Net-Ping
1683
1684 To report a new bug, visit:
1685
1686 https://rt.cpan.org/NoAuth/ReportBug.html?Queue=Net-Ping
1687
1688 =head1 AUTHORS
1689
1690   Current maintainer:
1691     bbb@cpan.org (Rob Brown)
1692
1693   External protocol:
1694     colinm@cpan.org (Colin McMillen)
1695
1696   Stream protocol:
1697     bronson@trestle.com (Scott Bronson)
1698
1699   Original pingecho():
1700     karrer@bernina.ethz.ch (Andreas Karrer)
1701     pmarquess@bfsec.bt.co.uk (Paul Marquess)
1702
1703   Original Net::Ping author:
1704     mose@ns.ccsn.edu (Russell Mosemann)
1705
1706 =head1 COPYRIGHT
1707
1708 Copyright (c) 2002-2003, Rob Brown.  All rights reserved.
1709
1710 Copyright (c) 2001, Colin McMillen.  All rights reserved.
1711
1712 This program is free software; you may redistribute it and/or
1713 modify it under the same terms as Perl itself.
1714
1715 $Id: Ping.pm,v 1.81 2003/04/18 04:16:03 rob Exp $
1716
1717 =cut