Update to Net::Ping v2.23
Hugo van der Sanden [Sun, 20 Oct 2002 14:23:06 +0000 (14:23 +0000)]
p4raw-id: //depot/perl@18038

MANIFEST
lib/Net/Ping.pm
lib/Net/Ping/t/110_icmp_inst.t
lib/Net/Ping/t/150_syn_inst.t [new file with mode: 0644]
lib/Net/Ping/t/200_ping_tcp.t
lib/Net/Ping/t/400_ping_syn.t [new file with mode: 0644]
lib/Net/Ping/t/450_service.t [new file with mode: 0644]

index 7eee1be..0b90002 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -1331,14 +1331,18 @@ lib/Net/NNTP.pm                 libnet
 lib/Net/Ping.pm                        Hello, anybody home?
 lib/Net/Ping/Changes           Net::Ping
 lib/Net/Ping/README            Net::Ping
-lib/Net/Ping/t/100_load.t              Ping Net::Ping
-lib/Net/Ping/t/110_icmp_inst.t         Ping Net::Ping
-lib/Net/Ping/t/120_udp_inst.t          Ping Net::Ping
-lib/Net/Ping/t/130_tcp_inst.t          Ping Net::Ping
+lib/Net/Ping/t/100_load.t      Ping Net::Ping
+lib/Net/Ping/t/110_icmp_inst.t Ping Net::Ping
+lib/Net/Ping/t/120_udp_inst.t  Ping Net::Ping
+lib/Net/Ping/t/130_tcp_inst.t  Ping Net::Ping
 lib/Net/Ping/t/140_stream_inst.t       Ping Net::Ping
-lib/Net/Ping/t/200_ping_tcp.t          Ping Net::Ping
-lib/Net/Ping/t/250_ping_hires.t                Ping Net::Ping
+lib/Net/Ping/t/150_syn_inst.t  Ping Net::Ping
+lib/Net/Ping/t/200_ping_tcp.t  Ping Net::Ping
+lib/Net/Ping/t/250_ping_hires.t        Ping Net::Ping
 lib/Net/Ping/t/300_ping_stream.t       Ping Net::Ping
+lib/Net/Ping/t/300_ping_stream.t       Ping Net::Ping
+lib/Net/Ping/t/400_ping_syn.t  Ping Net::Ping
+lib/Net/Ping/t/450_service.t   Ping Net::Ping
 lib/Net/POP3.pm                        libnet
 lib/Net/protoent.pm            By-name interface to Perl's builtin getproto*
 lib/Net/protoent.t             See if Net::protoent works
index 815bb75..1192663 100644 (file)
@@ -1,22 +1,23 @@
 package Net::Ping;
 
-# $Id: Ping.pm,v 1.6 2002/06/19 15:23:48 rob Exp $
+# $Id: Ping.pm,v 1.33 2002/10/19 05:02:43 rob Exp $
 
 require 5.002;
 require Exporter;
 
 use strict;
 use vars qw(@ISA @EXPORT $VERSION
-            $def_timeout $def_proto $max_datasize $pingstring $hires $source_verify);
-use FileHandle;
-use Socket qw( SOCK_DGRAM SOCK_STREAM SOCK_RAW PF_INET
+            $def_timeout $def_proto $max_datasize $pingstring $hires $source_verify $syn_forking);
+use Fcntl qw( F_GETFL F_SETFL O_NONBLOCK );
+use Socket qw( SOCK_DGRAM SOCK_STREAM SOCK_RAW PF_INET SOL_SOCKET
                inet_aton inet_ntoa sockaddr_in );
+use POSIX qw( ECONNREFUSED EINPROGRESS WNOHANG );
+use FileHandle;
 use Carp;
-use POSIX qw(ECONNREFUSED);
 
 @ISA = qw(Exporter);
 @EXPORT = qw(pingecho);
-$VERSION = "2.20";
+$VERSION = "2.23";
 
 # Constants
 
@@ -26,13 +27,19 @@ $max_datasize = 1024;       # Maximum data bytes in a packet
 # The data we exchange with the server for the stream protocol
 $pingstring = "pingschwingping!\n";
 $source_verify = 1;         # Default is to verify source endpoint
+$syn_forking = 0;
 
 if ($^O =~ /Win32/i) {
   # Hack to avoid this Win32 spewage:
   # Your vendor has not defined POSIX macro ECONNREFUSED
   *ECONNREFUSED = sub {10061;}; # "Unknown Error" Special Win32 Response?
+  $syn_forking = 1;
 };
 
+# h2ph "asm/socket.h"
+# require "asm/socket.ph";
+sub SO_BINDTODEVICE {25;}
+
 # Description:  The pingecho() subroutine is provided for backward
 # compatibility with the original Net::Ping.  It accepts a host
 # name/IP and an optional timeout in seconds.  Create a tcp ping
@@ -61,7 +68,8 @@ sub new
   my ($this,
       $proto,             # Optional protocol to use for pinging
       $timeout,           # Optional timeout in seconds
-      $data_size          # Optional additional bytes of data
+      $data_size,         # Optional additional bytes of data
+      $device,            # Optional device to use
       ) = @_;
   my  $class = ref($this) || $this;
   my  $self = {};
@@ -72,8 +80,8 @@ sub new
   bless($self, $class);
 
   $proto = $def_proto unless $proto;          # Determine the protocol
-  croak('Protocol for ping must be "icmp", "udp", "tcp", "stream", or "external"')
-    unless $proto =~ m/^(icmp|udp|tcp|stream|external)$/;
+  croak('Protocol for ping must be "icmp", "udp", "tcp", "syn", "stream", or "external"')
+    unless $proto =~ m/^(icmp|udp|tcp|syn|stream|external)$/;
   $self->{"proto"} = $proto;
 
   $timeout = $def_timeout unless $timeout;    # Determine the timeout
@@ -81,6 +89,8 @@ sub new
     if $timeout <= 0;
   $self->{"timeout"} = $timeout;
 
+  $self->{"device"} = $device;
+
   $min_datasize = ($proto eq "udp") ? 1 : 0;  # Determine data size
   $data_size = $min_datasize unless defined($data_size) && $proto ne "tcp";
   croak("Data for ping must be from $min_datasize to $max_datasize bytes")
@@ -96,6 +106,8 @@ sub new
 
   $self->{"local_addr"} = undef;              # Don't bind by default
 
+  $self->{"tcp_econnrefused"} = undef;        # Default Connection refused behavior
+
   $self->{"seq"} = 0;                         # For counting packets
   if ($self->{"proto"} eq "udp")              # Open a socket
   {
@@ -107,16 +119,24 @@ sub new
     socket($self->{"fh"}, PF_INET, SOCK_DGRAM,
            $self->{"proto_num"}) ||
              croak("udp socket error - $!");
+    if ($self->{'device'}) {
+      setsockopt($self->{"fh"}, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'}))
+        or croak "error binding to device $self->{'device'} $!";
+    }
   }
   elsif ($self->{"proto"} eq "icmp")
   {
-    croak("icmp ping requires root privilege") if ($> and $^O ne 'VMS');
+    croak("icmp ping requires root privilege") if ($> and $^O ne 'VMS' and $^O ne 'cygwin');
     $self->{"proto_num"} = (getprotobyname('icmp'))[2] ||
       croak("Can't get icmp protocol by name");
     $self->{"pid"} = $$ & 0xffff;           # Save lower 16 bits of pid
     $self->{"fh"} = FileHandle->new();
     socket($self->{"fh"}, PF_INET, SOCK_RAW, $self->{"proto_num"}) ||
       croak("icmp socket error - $!");
+    if ($self->{'device'}) {
+      setsockopt($self->{"fh"}, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'}))
+        or croak "error binding to device $self->{'device'} $!";
+    }
   }
   elsif ($self->{"proto"} eq "tcp" || $self->{"proto"} eq "stream")
   {
@@ -126,6 +146,28 @@ sub new
       croak("Can't get tcp echo port by name");
     $self->{"fh"} = FileHandle->new();
   }
+  elsif ($self->{"proto"} eq "syn")
+  {
+    $self->{"proto_num"} = (getprotobyname('tcp'))[2] ||
+      croak("Can't get tcp protocol by name");
+    $self->{"port_num"} = (getservbyname('echo', 'tcp'))[2] ||
+      croak("Can't get tcp echo port by name");
+    if ($syn_forking) {
+      $self->{"fork_rd"} = FileHandle->new();
+      $self->{"fork_wr"} = FileHandle->new();
+      pipe($self->{"fork_rd"}, $self->{"fork_wr"});
+      $self->{"fh"} = FileHandle->new();
+    } else {
+      $self->{"wbits"} = "";
+      $self->{"bad"} = {};
+    }
+    $self->{"syn"} = {};
+    $self->{"stop_time"} = 0;
+  }
+  elsif ($self->{"proto"} eq "external")
+  {
+    # No preliminary work needs to be done.
+  }
 
   return($self);
 }
@@ -175,6 +217,17 @@ sub source_verify
     ($source_verify = ((defined $self) && (ref $self)) ? shift() : $self);
 }
 
+# Description: Set whether or not the tcp connect
+# behavior should enforce remote service availability
+# as well as reachability.
+
+sub tcp_service_check
+{
+  my $self = shift;
+  $self->{"tcp_econnrefused"} = 1 unless defined
+    ($self->{"tcp_econnrefused"} = shift());
+}
+
 # Description: allows the module to use milliseconds as returned by
 # the Time::HiRes module
 
@@ -231,6 +284,9 @@ sub ping
   }
   elsif ($self->{"proto"} eq "stream") {
     $ret = $self->ping_stream($ip, $timeout);
+  }
+  elsif ($self->{"proto"} eq "syn") {
+    $ret = $self->ping_syn($host, $ip, $ping_time, $ping_time+$timeout);
   } else {
     croak("Unknown protocol \"$self->{proto}\" in ping()");
   }
@@ -385,7 +441,10 @@ sub ping_tcp
 
   $@ = ""; $! = 0;
   $ret = $self -> tcp_connect( $ip, $timeout);
-  $ret = 1 if $! == ECONNREFUSED;  # Connection refused
+  if (!$self->{"tcp_econnrefused"} &&
+      $! == ECONNREFUSED) {
+    $ret = 1;  # "Connection refused" means reachable
+  }
   $self->{"fh"}->close();
   return $ret;
 }
@@ -409,6 +468,10 @@ sub tcp_connect
         !CORE::bind($self->{"fh"}, sockaddr_in(0, $self->{"local_addr"}))) {
       croak("tcp bind error - $!");
     }
+    if ($self->{'device'}) {
+      setsockopt($self->{"fh"}, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'}))
+        or croak("error binding to device $self->{'device'} $!");
+    }
   };
   my $do_connect = sub {
     eval {
@@ -451,13 +514,12 @@ sub tcp_connect
 
     my $patience = &time() + $timeout;
 
-    require POSIX;
     my ($child);
     $? = 0;
     # Wait up to the timeout
     # And clean off the zombie
     do {
-      $child = waitpid($pid, &POSIX::WNOHANG);
+      $child = waitpid($pid, &WNOHANG());
       $! = $? >> 8;
       $@ = $!;
       select(undef, undef, undef, 0.1);
@@ -481,11 +543,11 @@ sub tcp_connect
 
     &{ $do_socket }();
 
-    $SIG{'ALRM'} = sub { die "Timed out!"; };
-    alarm($timeout);        # Interrupt connect() if we have to
+    local $SIG{'ALRM'} = sub { die "Timed out!"; };
+    my $old = alarm($timeout);   # Interrupt connect() if we have to
 
     &{ $do_connect }();
-    alarm(0);
+    alarm($old);
   }
 
   return $ret;
@@ -667,14 +729,318 @@ sub ping_udp
   return $ret;
 }
 
-# Description:  Close the connection unless we are using the tcp
-# protocol, since it will already be closed.
+# Description: Send a TCP SYN packet to host specified.
+sub ping_syn
+{
+  my $self = shift;
+  my $host = shift;
+  my $ip = shift;
+  my $start_time = shift;
+  my $stop_time = shift;
+
+  if ($syn_forking) {
+    return $self->ping_syn_fork($host, $ip, $start_time, $stop_time);
+  }
+
+  my $fh = FileHandle->new();
+  my $saddr = sockaddr_in($self->{"port_num"}, $ip);
+
+  # Create TCP socket
+  if (!socket ($fh, PF_INET, SOCK_STREAM, $self->{"proto_num"})) {
+    croak("tcp socket error - $!");
+  }
+
+  if (defined $self->{"local_addr"} &&
+      !CORE::bind($fh, sockaddr_in(0, $self->{"local_addr"}))) {
+    croak("tcp bind error - $!");
+  }
+
+  if ($self->{'device'}) {
+    setsockopt($fh, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'}))
+      or croak("error binding to device $self->{'device'} $!");
+  }
+
+  # Set O_NONBLOCK property on filehandle
+  if (my $flags = fcntl($fh, F_GETFL, 0)) {
+    fcntl($fh, F_SETFL, $flags | O_NONBLOCK);
+  } else {
+    croak("fcntl F_GETFL: $!");
+  }
+
+  # Attempt the non-blocking connect
+  # by just sending the TCP SYN packet
+  if (connect($fh, $saddr)) {
+    # Non-blocking, yet still connected?
+    # Must have connected very quickly.
+    # Can this ever really happen?
+  }
+  else {
+    # Error occurred connecting.
+    # Hopefully the connection is just still in progress.
+    if ($! != EINPROGRESS) {
+      # If not, then it really is something bad.
+      $self->{"bad"}->{$host} = $!;
+      return undef;
+    }
+  }
+
+  my $entry = [ $host, $ip, $fh, $start_time, $stop_time ];
+  $self->{"syn"}->{$fh->fileno} = $entry;
+  if ($self->{"stop_time"} < $stop_time) {
+    $self->{"stop_time"} = $stop_time;
+  }
+  vec($self->{"wbits"}, $fh->fileno, 1) = 1;
+
+  return 1;
+}
+
+sub ping_syn_fork {
+  my ($self, $host, $ip, $start_time, $stop_time) = @_;
+
+  # Buggy Winsock API doesn't allow nonblocking connect.
+  # Hence, if our OS is Windows, we need to create a separate
+  # process to do the blocking connect attempt.
+  my $pid = fork();
+  if (defined $pid) {
+    if ($pid) {
+      # Parent process
+      my $entry = [ $host, $ip, $pid, $start_time, $stop_time ];
+      $self->{"syn"}->{$pid} = $entry;
+      if ($self->{"stop_time"} < $stop_time) {
+        $self->{"stop_time"} = $stop_time;
+      }
+    } else {
+      # Child process
+      my $saddr = sockaddr_in($self->{"port_num"}, $ip);
+
+      # Create TCP socket
+      if (!socket ($self->{"fh"}, PF_INET, SOCK_STREAM, $self->{"proto_num"})) {
+        croak("tcp socket error - $!");
+      }
+
+      if (defined $self->{"local_addr"} &&
+          !CORE::bind($self->{"fh"}, sockaddr_in(0, $self->{"local_addr"}))) {
+        croak("tcp bind error - $!");
+      }
+
+      if ($self->{'device'}) {
+        setsockopt($self->{"fh"}, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'}))
+          or croak("error binding to device $self->{'device'} $!");
+      }
+
+      $!=0;
+      # Try to connect (could take a long time)
+      connect($self->{"fh"}, $saddr);
+      # Notify parent of connect error status
+      my $err = $!+0;
+      my $wrstr = "$$ $err";
+      # Force to 10 chars including \n
+      $wrstr .= " "x(9 - length $wrstr). "\n";
+      syswrite($self->{"fork_wr"}, $wrstr);
+      exit;
+    }
+  } else {
+    # fork() failed?
+    die "fork: $!";
+  }
+  return 1;
+}
+
+# Description: Wait for TCP ACK from host specified
+# from ping_syn above.  If no host is specified, wait
+# for TCP ACK from any of the hosts in the SYN queue.
+sub ack
+{
+  my $self = shift;
+
+  if ($self->{"proto"} eq "syn") {
+    if ($syn_forking) {
+      my @answer = $self->ack_unfork(shift);
+      return wantarray ? @answer : $answer[0];
+    }
+    my $wbits = "";
+    my $stop_time = 0;
+    if (my $host = shift) {
+      # Host passed as arg
+      if (exists $self->{"bad"}->{$host}) {
+        return ();
+      }
+      my $host_fd = undef;
+      foreach my $fd (keys %{ $self->{"syn"} }) {
+        my $entry = $self->{"syn"}->{$fd};
+        if ($entry->[0] eq $host) {
+          $host_fd = $fd;
+          $stop_time = $entry->[4]
+            || croak("Corrupted SYN entry for [$host]");
+          last;
+        }
+      }
+      croak("ack called on [$host] without calling ping first!")
+        unless defined $host_fd;
+      vec($wbits, $host_fd, 1) = 1;
+    } else {
+      # No $host passed so scan all hosts
+      # Use the latest stop_time
+      $stop_time = $self->{"stop_time"};
+      # Use all the bits
+      $wbits = $self->{"wbits"};
+    }
+
+    while ($wbits !~ /^\0*$/) {
+      my $timeout = $stop_time - &time();
+      # Force a minimum of 10 ms timeout.
+      $timeout = 0.01 if $timeout <= .01;
+      if (my $nfound = select(undef, (my $wout=$wbits), undef, $timeout)) {
+        # Done waiting for one of the ACKs
+        my $fd = 0;
+        # Determine which one
+        while (length $wout &&
+               !vec($wout, $fd, 1)) {
+          $fd++;
+        }
+        if (my $entry = $self->{"syn"}->{$fd}) {
+          if (getpeername($entry->[2])) {
+            # Connection established to remote host
+            delete $self->{"syn"}->{$fd};
+            vec($self->{"wbits"}, $fd, 1) = 0;
+            return wantarray ?
+              ($entry->[0], &time() - $entry->[3], inet_ntoa($entry->[1]))
+              : $entry->[0];
+          } else {
+            # TCP ACK will never come from this host
+            # because there was an error connecting.
+
+            # Wipe it from future scanning.
+            delete $self->{"syn"}->{$fd};
+            vec($self->{"wbits"}, $fd, 1) = 0;
+            vec($wbits, $fd, 1) = 0;
+
+            # This should set $! to the correct error.
+            my $char;
+            read($entry->[2],$char,1);
+            # Store the excuse why the connection failed.
+            $self->{"bad"}->{$entry->[0]} = $!;
+            if (!$self->{"tcp_econnrefused"} &&
+                $! == ECONNREFUSED) {
+              # "Connection refused" means reachable
+              return wantarray ?
+                ($entry->[0], &time() - $entry->[3], inet_ntoa($entry->[1]))
+                : $entry->[0];
+            }
+            # Try another socket...
+          }
+        } else {
+          warn "Corrupted SYN entry: unknown fd [$fd] ready!";
+          vec($wbits, $fd, 1) = 0;
+          vec($self->{"wbits"}, $fd, 1) = 0;
+        }
+      } elsif (defined $nfound) {
+        # Timed out waiting for ACK
+        foreach my $fd (keys %{ $self->{"syn"} }) {
+          if (vec($wbits, $fd, 1)) {
+            my $entry = $self->{"syn"}->{$fd};
+            $self->{"bad"}->{$entry->[0]} = "Timed out";
+            vec($wbits, $fd, 1) = 0;
+            vec($self->{"wbits"}, $fd, 1) = 0;
+            delete $self->{"syn"}->{$fd};
+          }
+        }
+      } else {
+        # Weird error occurred with select()
+        warn("select: $!");
+        $self->{"syn"} = {};
+        $wbits = "";
+      }
+    }
+  }
+  return ();
+}
+
+sub ack_unfork {
+  my $self = shift;
+  my $stop_time = $self->{"stop_time"};
+  if (my $host = shift) {
+    # Host passed as arg
+    warn "Cannot specify host for ack on win32\n";
+  }
+
+  my $rbits = "";
+  my $timeout;
+  if (keys %{ $self->{"syn"} }) {
+    # Scan all hosts that are left
+    vec($rbits, fileno($self->{"fork_rd"}), 1) = 1;
+    $timeout = $stop_time - &time();
+  } else {
+    # No hosts left to wait for
+    $timeout = 0;
+  }
+
+  if ($timeout > 0) {
+    if (my $nfound = select((my $rout=$rbits), undef, undef, $timeout)) {
+      # Done waiting for one of the ACKs
+      if (!sysread($self->{"fork_rd"}, $_, 10)) {
+        # Socket closed, which means all children are done.
+        return ();
+      }
+      my ($pid, $how) = split;
+      if ($pid) {
+        # Flush the zombie
+        waitpid($pid, 0);
+        if (my $entry = $self->{"syn"}->{$pid}) {
+          # Connection attempt to remote host is done
+          delete $self->{"syn"}->{$pid};
+          if (!$how || # If there was no error connecting
+              (!$self->{"tcp_econnrefused"} &&
+               $how == ECONNREFUSED)) {  # "Connection refused" means reachable
+            return ($entry->[0], &time() - $entry->[3], inet_ntoa($entry->[1]));
+          }
+        } else {
+          # Should never happen
+          die "Unknown ping from pid [$pid]";
+        }
+      } else {
+        die "Empty response from status socket?";
+      }
+    } elsif (defined $nfound) {
+      # Timed out waiting for ACK status
+    } else {
+      # Weird error occurred with select()
+      warn("select: $!");
+    }
+  }
+  if (my @synners = keys %{ $self->{"syn"} }) {
+    # Kill all the synners
+    kill 9, @synners;
+    foreach my $pid (@synners) {
+      # Wait for the deaths to finish
+      # Then flush off the zombie
+      waitpid($pid, 0);
+    }
+  }
+  $self->{"syn"} = {};
+  return ();
+}
+
+# Description:  Tell why the ack() failed
+sub nack {
+  my $self = shift;
+  my $host = shift || croak('Usage> nack($failed_ack_host)');
+  return $self->{"bad"}->{$host} || undef;
+}
+
+# Description:  Close the connection.
 
 sub close
 {
   my ($self) = @_;
 
-  $self->{"fh"}->close() unless $self->{"proto"} eq "tcp";
+  if ($self->{"proto"} eq "syn") {
+    delete $self->{"syn"};
+  } elsif ($self->{"proto"} eq "tcp") {
+    # The connection will already be closed
+  } else {
+    $self->{"fh"}->close();
+  }
 }
 
 
@@ -685,7 +1051,7 @@ __END__
 
 Net::Ping - check a remote host for reachability
 
-$Id: Ping.pm,v 1.6 2002/06/19 15:23:48 rob Exp $
+$Id: Ping.pm,v 1.33 2002/10/19 05:02:43 rob Exp $
 
 =head1 SYNOPSIS
 
@@ -717,6 +1083,16 @@ $Id: Ping.pm,v 1.6 2002/06/19 15:23:48 rob Exp $
     }
     undef($p);
 
+    # Like tcp protocol, but with many hosts
+    $p = Net::Ping->new("syn");
+    $p->{port_num} = getservbyname("http", "tcp");
+    foreach $host (@host_array) {
+      $p->ping($host);
+    }
+    while (($host,$rtt,$ip) = $p->ack) {
+      print "HOST: $host [$ip] ACKed in $rtt seconds.\n";
+    }
+
     # High precision syntax (requires Time::HiRes)
     $p = Net::Ping->new();
     $p->hires();
@@ -735,10 +1111,10 @@ hosts on a network.  A ping object is first created with optional
 parameters, a variable number of hosts may be pinged multiple
 times and then the connection is closed.
 
-You may choose one of four different protocols to use for the
-ping. The "udp" protocol is the default. Note that a live remote host
+You may choose one of six different protocols to use for the
+ping. The "tcp" protocol is the default. Note that a live remote host
 may still fail to be pingable by one or more of these protocols. For
-example, www.microsoft.com is generally alive but not pingable.
+example, www.microsoft.com is generally alive but not "icmp" pingable.
 
 With the "tcp" protocol the ping() method attempts to establish a
 connection to the remote host's echo port.  If the connection is
@@ -770,15 +1146,32 @@ utility to perform the ping, and generally produces relatively
 accurate results. If C<Net::Ping::External> if not installed on your
 system, specifying the "external" protocol will result in an error.
 
+If the "syn" protocol is specified, the ping() method will only
+send a TCP SYN packet to the remote host then immediately return.
+If the syn packet was sent successfully, it will return a true value,
+otherwise it will return false.  NOTE: Unlike the other protocols,
+the return value does NOT determine if the remote host is alive or
+not since the full TCP three-way handshake may not have completed
+yet.  The remote host is only considered reachable if it receives
+a TCP ACK within the timeout specifed.  To begin waiting for the
+ACK packets, use the ack() method as explained below.  Use the
+"syn" protocol instead the "tcp" protocol to determine reachability
+of multiple destinations simultaneously by sending parallel TCP
+SYN packets.  It will not block while testing each remote host.
+demo/fping is provided in this distribution to demonstrate the
+"syn" protocol as an example.
+This protocol does not require any special privileges.
+
 =head2 Functions
 
 =over 4
 
-=item Net::Ping->new([$proto [, $def_timeout [, $bytes]]]);
+=item Net::Ping->new([$proto [, $def_timeout [, $bytes [, $device ]]]]);
 
 Create a new ping object.  All of the parameters are optional.  $proto
 specifies the protocol to use when doing a ping.  The current choices
-are "tcp", "udp" or "icmp".  The default is "udp".
+are "tcp", "udp", "icmp", "stream", "syn", or "external".
+The default is "tcp".
 
 If a default timeout ($def_timeout) in seconds is provided, it is used
 when a timeout is not given to the ping() method (below).  The timeout
@@ -791,6 +1184,10 @@ default) number of data bytes is 1 if the protocol is "udp" and 0
 otherwise.  The maximum number of data bytes that can be specified is
 1024.
 
+If $device is given, this device is used to bind the source endpoint
+before sending the ping packet.  I beleive this only works with
+superuser privileges and with udp and icmp protocols at this time.
+
 =item $p->ping($host [, $timeout]);
 
 Ping the remote host and wait for a response.  $host can be either the
@@ -801,7 +1198,8 @@ hostname cannot be found or there is a problem with the IP number, the
 success flag returned will be undef.  Otherwise, the success flag will
 be 1 if the host is reachable and 0 if it is not.  For most practical
 purposes, undef and 0 and can be treated as the same case.  In array
-context, the elapsed time is also returned.  The elapsed time value will
+context, the elapsed time as well as the string form of the ip the
+host resolved to are also returned.  The elapsed time value will
 be a float, as retuned by the Time::HiRes::time() function, if hires()
 has been previously called, otherwise it is returned as an integer.
 
@@ -815,6 +1213,27 @@ This only affects udp and icmp protocol pings.
 
 This is enabled by default.
 
+=item $p->tcp_service_check( { 0 | 1 } );
+
+Set whether or not the tcp connect behavior should enforce
+remote service availability as well as reachability.  Normally,
+if the remote server reported ECONNREFUSED, it must have been
+reachable because of the status packet that it reported.
+With this option enabled, the full three-way tcp handshake
+must have been established successfully before it will
+claim it is reachable.  NOTE:  It still does nothing more
+than connect and disconnect.  It does not speak any protocol
+(i.e., HTTP or FTP) to ensure the remote server is sane in
+any way.  The remote server CPU could be grinding to a halt
+and unresponsive to any clients connecting, but if the kernel
+throws the ACK packet, it is considered alive anyway.  To
+really determine if the server is responding well would be
+application specific and is beyond the scope of Net::Ping.
+
+This only affects "tcp" and "syn" protocols.
+
+This is disabled by default.
+
 =item $p->hires( { 0 | 1 } );
 
 Causes this module to use Time::HiRes module, allowing milliseconds
@@ -838,7 +1257,7 @@ object.
 
 =item $p->open($host);
 
-When you are using the stream protocol, this call pre-opens the
+When you are using the "stream" protocol, this call pre-opens the
 tcp socket.  It's only necessary to do this if you want to
 provide a different timeout when creating the connection, or
 remove the overhead of establishing the connection from the
@@ -847,6 +1266,31 @@ automatically opened the first time C<ping()> is called.
 This call simply does nothing if you are using any protocol other
 than stream.
 
+=item $p->ack( [ $host ] );
+
+When using the "syn" protocol, use this method to determine
+the reachability of the remote host.  This method is meant
+to be called up to as many times as ping() was called.  Each
+call returns the host (as passed to ping()) that came back
+with the TCP ACK.  The order in which the hosts are returned
+may not necessarily be the same order in which they were
+SYN queued using the ping() method.  If the timeout is
+reached before the TCP ACK is received, or if the remote
+host is not listening on the port attempted, then the TCP
+connection will not be established and ack() will return
+undef.  In list context, the host, the ack time, and the
+dotted ip string will be returned instead of just the host.
+If the optional $host argument is specified, the return
+value will be partaining to that host only.
+This call simply does nothing if you are using any protocol
+other than syn.
+
+=item $p->nack( $failed_ack_host );
+
+The reason that host $failed_ack_host did not receive a
+valid ACK.  Useful to find out why when ack( $fail_ack_host )
+returns a false value.
+
 =item $p->close();
 
 Close the network connection for this ping object.  The network
@@ -905,7 +1349,7 @@ kinds of ICMP packets.
 
 The latest source tree is available via cvs:
 
-  cvs -z3 -q -d :pserver:anonymous@cvs.roobik.com.:/usr/local/cvsroot/freeware co Net-Ping
+  cvs -z3 -q -d :pserver:anonymous@cvs.roobik.com.:/usr/local/cvsroot/freeware checkout Net-Ping
   cd Net-Ping
 
 The tarball can be created as follows:
index b0ee1b7..cdb7219 100644 (file)
@@ -15,7 +15,7 @@ plan tests => 2;
 # Everything loaded fine
 ok 1;
 
-if (($> and $^O ne 'VMS')
+if (($> and $^O ne 'VMS' and $^O ne 'cygwin')
     or ($^O eq 'MSWin32'
         and Win32::IsWinNT())
     or ($^O eq 'VMS'
diff --git a/lib/Net/Ping/t/150_syn_inst.t b/lib/Net/Ping/t/150_syn_inst.t
new file mode 100644 (file)
index 0000000..df85d46
--- /dev/null
@@ -0,0 +1,22 @@
+# Test to make sure object can be instantiated for syn protocol.
+
+BEGIN {
+  unless (eval "require Socket") {
+    print "1..0 \# Skip: no Socket\n";
+    exit;
+  }
+  unless (getservbyname('echo', 'tcp')) {
+    print "1..0 \# Skip: no echo port\n";
+    exit;
+  }
+}
+
+use Test;
+use Net::Ping;
+plan tests => 2;
+
+# Everything loaded fine
+ok 1;
+
+my $p = new Net::Ping "syn";
+ok !!$p;
index 591c251..2ac2236 100644 (file)
@@ -11,7 +11,7 @@ BEGIN {
     print "1..0 \# Skip: no Socket\n";
     exit;
   }
-  unless (getservbyname('echo', 'udp')) {
+  unless (getservbyname('echo', 'tcp')) {
     print "1..0 \# Skip: no echo port\n";
     exit;
   }
@@ -35,7 +35,7 @@ plan tests => 13;
 # Everything loaded fine
 ok 1;
 
-my $p = new Net::Ping "tcp";
+my $p = new Net::Ping "tcp",9;
 
 # new() worked?
 ok !!$p;
diff --git a/lib/Net/Ping/t/400_ping_syn.t b/lib/Net/Ping/t/400_ping_syn.t
new file mode 100644 (file)
index 0000000..3b84af7
--- /dev/null
@@ -0,0 +1,94 @@
+BEGIN {
+  if ($ENV{PERL_CORE}) {
+    unless ($ENV{PERL_TEST_Net_Ping}) {
+      print "1..0 # Skip: network dependent test\n";
+        exit;
+    }
+    chdir 't' if -d 't';
+    @INC = qw(../lib);
+  }
+  unless (eval "require Socket") {
+    print "1..0 \# Skip: no Socket\n";
+    exit;
+  }
+  unless (getservbyname('echo', 'tcp')) {
+    print "1..0 \# Skip: no echo port\n";
+    exit;
+  }
+  unless (getservbyname('http', 'tcp')) {
+    print "1..0 \# Skip: no http port\n";
+    exit;
+  }
+}
+
+# Remote network test using syn protocol.
+#
+# NOTE:
+#   Network connectivity will be required for all tests to pass.
+#   Firewalls may also cause some tests to fail, so test it
+#   on a clear network.  If you know you do not have a direct
+#   connection to remote networks, but you still want the tests
+#   to pass, use the following:
+#
+# $ PERL_CORE=1 make test
+
+# Try a few remote servers
+my $webs = {
+  # Hopefully this is never a routeable host
+  "172.29.249.249" => 0,
+
+  # Hopefully all these web servers are on
+  "www.geocities.com." => 1,
+  "www.freeservers.com." => 1,
+  "yahoo.com." => 1,
+  "www.yahoo.com." => 1,
+  "www.about.com." => 1,
+  "www.microsoft.com." => 1,
+};
+
+use strict;
+use Test;
+use Net::Ping;
+plan tests => ((keys %{ $webs }) * 2 + 3);
+
+# Everything loaded fine
+ok 1;
+
+my $p = new Net::Ping "syn", 10;
+
+# new() worked?
+ok !!$p;
+
+# Change to use the more common web port.
+# (Make sure getservbyname works in scalar context.)
+ok ($p -> {port_num} = getservbyname("http", "tcp"));
+
+foreach my $host (keys %{ $webs }) {
+  # ping() does dns resolution and
+  # only sends the SYN at this point
+  if ($p -> ping($host)) {
+    ok 1;
+  } else {
+    print STDERR "CANNOT RESOLVE $host\n";
+    ok 0;
+  }
+}
+
+while (my $host = $p->ack()) {
+  if ($webs->{$host}) {
+    ok 1;
+  } else {
+    print STDERR "SUPPOSED TO BE DOWN: http://$host/\n";
+    ok 0;
+  }
+  delete $webs->{$host};
+}
+
+foreach my $host (keys %{ $webs }) {
+  if ($webs->{$host}) {
+    print STDERR "DOWN: http://$host/\n";
+    ok 0;
+  } else {
+    ok 1;
+  }
+}
diff --git a/lib/Net/Ping/t/450_service.t b/lib/Net/Ping/t/450_service.t
new file mode 100644 (file)
index 0000000..7d19c76
--- /dev/null
@@ -0,0 +1,213 @@
+# Testing tcp_service_check method using tcp and syn protocols.
+
+BEGIN {
+  unless (eval "require IO::Socket") {
+    print "1..0 \# Skip: no IO::Socket\n";
+    exit;
+  }
+  unless (getservbyname('echo', 'tcp')) {
+    print "1..0 \# Skip: no echo port\n";
+    exit;
+  }
+}
+
+use strict;
+use Test;
+use Net::Ping;
+use IO::Socket;
+
+# I'm lazy so I'll just use IO::Socket
+# for the TCP Server stuff instead of doing
+# all that direct socket() junk manually.
+
+plan tests => 37;
+
+# Everything loaded fine
+ok 1;
+
+"0" =~ /(0)/; # IO::Socket::INET ephemeral buttwag hack
+
+# Start a tcp listen server on ephemeral port
+my $sock1 = new IO::Socket::INET
+  LocalAddr => "127.1.1.1",
+  Proto => "tcp",
+  Listen => 8,
+  Reuse => 1,
+  Type => SOCK_STREAM,
+  ;
+
+# Make sure it worked.
+ok !!$sock1;
+
+"0" =~ /(0)/; # IO::Socket::INET ephemeral buttwag hack
+
+# Start listening on another ephemeral port
+my $sock2 = new IO::Socket::INET
+  LocalAddr => "127.2.2.2",
+  Proto => "tcp",
+  Listen => 8,
+  Reuse => 1,
+  Type => SOCK_STREAM,
+  ;
+
+# Make sure it worked too.
+ok !!$sock2;
+
+my $port1 = $sock1->sockport;
+ok $port1;
+
+my $port2 = $sock2->sockport;
+ok $port2;
+
+# Make sure the sockets are listening on different ports.
+ok ($port1 != $port2);
+
+# This is how it should be:
+# 127.1.1.1:$port1 - service ON
+# 127.2.2.2:$port2 - service ON
+# 127.1.1.1:$port2 - service OFF
+# 127.2.2.2:$port1 - service OFF
+
+#####
+# First, we test using the "tcp" protocol.
+# (2 seconds should be long enough to connect to loopback.)
+my $p = new Net::Ping "tcp", 2;
+
+# new() worked?
+ok !!$p;
+
+# Disable service checking
+$p->tcp_service_check(0);
+
+# Try on the first port
+$p->{port_num} = $port1;
+
+# Make sure IP1 is reachable
+ok $p -> ping("127.1.1.1");
+
+# Make sure IP2 is reachable
+ok $p -> ping("127.2.2.2");
+
+# Try on the other port
+$p->{port_num} = $port2;
+
+# Make sure IP1 is reachable
+ok $p -> ping("127.1.1.1");
+
+# Make sure IP2 is reachable
+ok $p -> ping("127.2.2.2");
+
+
+# Enable service checking
+$p->tcp_service_check(1);
+
+# Try on the first port
+$p->{port_num} = $port1;
+
+# Make sure service on IP1 
+ok $p -> ping("127.1.1.1");
+
+# Make sure not service on IP2
+ok !$p -> ping("127.2.2.2");
+
+# Try on the other port
+$p->{port_num} = $port2;
+
+# Make sure not service on IP1
+ok !$p -> ping("127.1.1.1");
+
+# Make sure service on IP2
+ok $p -> ping("127.2.2.2");
+
+
+#####
+# Lastly, we test using the "syn" protocol.
+$p = new Net::Ping "syn", 2;
+
+# new() worked?
+ok !!$p;
+
+# Disable service checking
+$p->tcp_service_check(0);
+
+# Try on the first port
+$p->{port_num} = $port1;
+
+# Send SYN to both IPs
+ok $p -> ping("127.1.1.1");
+ok $p -> ping("127.2.2.2");
+
+# Both IPs should be reachable
+ok $p -> ack();
+ok $p -> ack();
+# No more sockets?
+ok !$p -> ack();
+
+###
+# Get a fresh object
+$p = new Net::Ping "syn", 2;
+
+# new() worked?
+ok !!$p;
+
+# Disable service checking
+$p->tcp_service_check(0);
+
+# Try on the other port
+$p->{port_num} = $port2;
+
+# Send SYN to both IPs
+ok $p -> ping("127.1.1.1");
+ok $p -> ping("127.2.2.2");
+
+# Both IPs should be reachable
+ok $p -> ack();
+ok $p -> ack();
+# No more sockets?
+ok !$p -> ack();
+
+
+###
+# Get a fresh object
+$p = new Net::Ping "syn", 2;
+
+# new() worked?
+ok !!$p;
+
+# Enable service checking
+$p->tcp_service_check(1);
+
+# Try on the first port
+$p->{port_num} = $port1;
+
+# Send SYN to both IPs
+ok $p -> ping("127.1.1.1");
+ok $p -> ping("127.2.2.2");
+
+# Only IP1 should have service
+ok "127.1.1.1",$p -> ack();
+# No more good sockets?
+ok !$p -> ack();
+
+
+###
+# Get a fresh object
+$p = new Net::Ping "syn", 2;
+
+# new() worked?
+ok !!$p;
+
+# Enable service checking
+$p->tcp_service_check(1);
+
+# Try on the other port
+$p->{port_num} = $port2;
+
+# Send SYN to both IPs
+ok $p -> ping("127.1.1.1");
+ok $p -> ping("127.2.2.2");
+
+# Only IP2 should have service
+ok "127.2.2.2",$p -> ack();
+# No more good sockets?
+ok !$p -> ack();