lib/Net/Ping.pm

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