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