[ Index ]

PHP Cross Reference of Unnamed Project

title

Body

[close]

/se3-unattended/var/se3/unattended/install/linuxaux/opt/perl/lib/5.10.0/Net/ -> Ping.pm (source)

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


Generated: Tue Mar 17 22:47:18 2015 Cross-referenced by PHPXref 0.7.1