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