Refresh Net::Ping to 2.02

1 files changed, 507 insertions, 63 deletions

diff --git a/lib/Net/Ping.pm b/lib/Net/Ping.pm
index 3ba88d5751..91077ddad1 100644
--- a/lib/Net/Ping.pm
+++ b/lib/Net/Ping.pm
@@ -1,106 +1,550 @@
 package Net::Ping;
 
-# Authors: karrer@bernina.ethz.ch (Andreas Karrer)
-#          pmarquess@bfsec.bt.co.uk (Paul Marquess)
-
-require 5.002 ;
+# Author:   mose@ccsn.edu (Russell Mosemann)
+#
+# Authors of the original pingecho():
+#           karrer@bernina.ethz.ch (Andreas Karrer)
+#           pmarquess@bfsec.bt.co.uk (Paul Marquess)
+#
+# Copyright (c) 1996 Russell Mosemann.  All rights reserved.  This
+# program is free software; you may redistribute it and/or modify it
+# under the same terms as Perl itself.
+
+require 5.002;
 require Exporter;
 
-use strict ;
-use vars qw(@ISA @EXPORT $VERSION $tcp_proto $echo_port) ;
+use strict;
+use vars qw(@ISA @EXPORT $VERSION
+            $def_timeout $def_proto $max_datasize);
+use FileHandle;
+use Socket qw( SOCK_DGRAM SOCK_STREAM SOCK_RAW PF_INET
+               inet_aton sockaddr_in );
+use Carp;
 
 @ISA = qw(Exporter);
-@EXPORT = qw(ping pingecho);
-$VERSION = 1.01;
-
-use Socket 'PF_INET', 'AF_INET', 'SOCK_STREAM';
-use Carp ;
-
-$tcp_proto = (getprotobyname('tcp'))[2];
-$echo_port = (getservbyname('echo', 'tcp'))[2];
-
-sub ping {
-    croak "ping not implemented yet. Use pingecho()";
-}
+@EXPORT = qw(pingecho);
+$VERSION = 2.02;
 
+# Constants
 
-sub pingecho {
+$def_timeout = 5;           # Default timeout to wait for a reply
+$def_proto = "udp";         # Default protocol to use for pinging
+$max_datasize = 1024;       # Maximum data bytes in a packet
 
-    croak "usage: pingecho host [timeout]" 
-        unless @_ == 1 or @_ == 2 ;
+# 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
+# object and try pinging the host.  The result of the ping is returned.
 
-    my ($host, $timeout) = @_;
-    my ($saddr, $ip);
-    my ($ret) ;
-    local (*PINGSOCK);
+sub pingecho
+{
+    my ($host,              # Name or IP number of host to ping
+        $timeout            # Optional timeout in seconds
+        ) = @_;
+    my ($p);                # A ping object
 
-    # check if $host is alive by connecting to its echo port, within $timeout
-    # (default 5) seconds. returns 1 if OK, 0 if no answer, 0 if host not found
+    $p = Net::Ping->new("tcp", $timeout);
+    $p->ping($host);        # Going out of scope closes the connection
+}
 
-    $timeout = 5 unless $timeout;
+# Description:  The new() method creates a new ping object.  Optional
+# parameters may be specified for the protocol to use, the timeout in
+# seconds and the size in bytes of additional data which should be
+# included in the packet.
+#   After the optional parameters are checked, the data is constructed
+# and a socket is opened if appropriate.  The object is returned.
+
+sub new
+{
+    my ($this,
+        $proto,             # Optional protocol to use for pinging
+        $timeout,           # Optional timeout in seconds
+        $data_size          # Optional additional bytes of data
+        ) = @_;
+    my  $class = ref($this) || $this;
+    my  $self = {};
+    my ($cnt,               # Count through data bytes
+        $min_datasize       # Minimum data bytes required
+        );
+
+    bless($self, $class);
+
+    $proto = $def_proto unless $proto;          # Determine the protocol
+    croak("Protocol for ping must be \"tcp\", \"udp\" or \"icmp\"")
+        unless $proto =~ m/^(tcp|udp|icmp)$/;
+    $self->{"proto"} = $proto;
+
+    $timeout = $def_timeout unless $timeout;    # Determine the timeout
+    croak("Default timeout for ping must be greater than 0 seconds")
+        if $timeout <= 0;
+    $self->{"timeout"} = $timeout;
+
+    $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")
+        if ($data_size < $min_datasize) || ($data_size > $max_datasize);
+    $data_size-- if $self->{"proto"} eq "udp";  # We provide the first byte
+    $self->{"data_size"} = $data_size;
+
+    $self->{"data"} = "";                       # Construct data bytes
+    for ($cnt = 0; $cnt < $self->{"data_size"}; $cnt++)
+    {
+        $self->{"data"} .= chr($cnt % 256);
+    }
+
+    $self->{"seq"} = 0;                         # For counting packets
+    if ($self->{"proto"} eq "udp")              # Open a socket
+    {
+        $self->{"proto_num"} = (getprotobyname('udp'))[2] ||
+            croak("Can't udp protocol by name");
+        $self->{"port_num"} = (getservbyname('echo', 'udp'))[2] ||
+            croak("Can't get udp echo port by name");
+        $self->{"fh"} = FileHandle->new();
+        socket($self->{"fh"}, &PF_INET(), &SOCK_DGRAM(),
+               $self->{"proto_num"}) ||
+            croak("udp socket error - $!");
+    }
+    elsif ($self->{"proto"} eq "icmp")
+    {
+        croak("icmp ping requires root privilege") if $>;
+        $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 - $!");
+    }
+    elsif ($self->{"proto"} eq "tcp")           # Just a file handle for now
+    {
+        $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");
+        $self->{"fh"} = FileHandle->new();
+    }
+
+
+    return($self);
+}
 
-    if ($host =~ /^\s*((\d+\.){3}\d+)\s*$/)
-      { $ip = pack ('C4', split (/\./, $1)) }
+# Description: Ping a host name or IP number with an optional timeout.
+# First lookup the host, and return undef if it is not found.  Otherwise
+# perform the specific ping method based on the protocol.  Return the 
+# result of the ping.
+
+sub ping
+{
+    my ($self,
+        $host,              # Name or IP number of host to ping
+        $timeout            # Seconds after which ping times out
+        ) = @_;
+    my ($ip,                # Packed IP number of $host
+        $ret                # The return value
+        );
+
+    croak("Usage: \$p->ping(\$host [, \$timeout])") unless @_ == 2 || @_ == 3;
+    $timeout = $self->{"timeout"} unless $timeout;
+    croak("Timeout must be greater than 0 seconds") if $timeout <= 0;
+
+    $ip = inet_aton($host);
+    return(undef) unless defined($ip);      # Does host exist?
+
+    if ($self->{"proto"} eq "udp")
+    {
+        $ret = $self->ping_udp($ip, $timeout);
+    }
+    elsif ($self->{"proto"} eq "icmp")
+    {
+        $ret = $self->ping_icmp($ip, $timeout);
+    }
+    elsif ($self->{"proto"} eq "tcp")
+    {
+        $ret = $self->ping_tcp($ip, $timeout);
+    }
     else
-      { $ip = (gethostbyname($host))[4] }
-
-    return 0 unless $ip;		# "no such host"
+    {
+        croak("Unknown protocol \"$self->{proto}\" in ping()");
+    }
+    return($ret);
+}
 
-    $saddr = pack('S n a4 x8', AF_INET, $echo_port, $ip);
-    $SIG{'ALRM'} = sub { die } ;
-    alarm($timeout);
-    
+sub ping_icmp
+{
+    my ($self,
+        $ip,                # Packed IP number of the host
+        $timeout            # Seconds after which ping times out
+        ) = @_;
+
+    my $ICMP_ECHOREPLY = 0; # ICMP packet types
+    my $ICMP_ECHO = 8;
+    my $icmp_struct = "C2 S3 A";  # Structure of a minimal ICMP packet
+    my $subcode = 0;        # No ICMP subcode for ECHO and ECHOREPLY
+    my $flags = 0;          # No special flags when opening a socket
+    my $port = 0;           # No port with ICMP
+
+    my ($saddr,             # sockaddr_in with port and ip
+        $checksum,          # Checksum of ICMP packet
+        $msg,               # ICMP packet to send
+        $len_msg,           # Length of $msg
+        $rbits,             # Read bits, filehandles for reading
+        $nfound,            # Number of ready filehandles found
+        $finish_time,       # Time ping should be finished
+        $done,              # set to 1 when we are done
+        $ret,               # Return value
+        $recv_msg,          # Received message including IP header
+        $from_saddr,        # sockaddr_in of sender
+        $from_port,         # Port packet was sent from
+        $from_ip,           # Packed IP of sender
+        $from_type,         # ICMP type
+        $from_subcode,      # ICMP subcode
+        $from_chk,          # ICMP packet checksum
+        $from_pid,          # ICMP packet id
+        $from_seq,          # ICMP packet sequence
+        $from_msg           # ICMP message
+        );
+
+    $self->{"seq"} = ($self->{"seq"} + 1) % 65536; # Increment sequence
+    $checksum = 0;                          # No checksum for starters
+    $msg = pack($icmp_struct . $self->{"data_size"}, $ICMP_ECHO, $subcode,
+                $checksum, $self->{"pid"}, $self->{"seq"}, $self->{"data"});
+    $checksum = Net::Ping->checksum($msg);
+    $msg = pack($icmp_struct . $self->{"data_size"}, $ICMP_ECHO, $subcode,
+                $checksum, $self->{"pid"}, $self->{"seq"}, $self->{"data"});
+    $len_msg = length($msg);
+    $saddr = sockaddr_in($port, $ip);
+    send($self->{"fh"}, $msg, $flags, $saddr); # Send the message
+
+    $rbits = "";
+    vec($rbits, $self->{"fh"}->fileno(), 1) = 1;
     $ret = 0;
+    $done = 0;
+    $finish_time = time() + $timeout;       # Must be done by this time
+    while (!$done && $timeout > 0)          # Keep trying if we have time
+    {
+        $nfound = select($rbits, undef, undef, $timeout); # Wait for packet
+        $timeout = $finish_time - time();   # Get remaining time
+        if (!defined($nfound))              # Hmm, a strange error
+        {
+            $ret = undef;
+            $done = 1;
+        }
+        elsif ($nfound)                     # Got a packet from somewhere
+        {
+            $recv_msg = "";
+            $from_saddr = recv($self->{"fh"}, $recv_msg, 1500, $flags);
+            ($from_port, $from_ip) = sockaddr_in($from_saddr);
+            ($from_type, $from_subcode, $from_chk,
+             $from_pid, $from_seq, $from_msg) =
+                unpack($icmp_struct . $self->{"data_size"},
+                       substr($recv_msg, length($recv_msg) - $len_msg,
+                              $len_msg));
+            if (($from_type == $ICMP_ECHOREPLY) &&
+                ($from_ip eq $ip) &&
+                ($from_pid == $self->{"pid"}) && # Does the packet check out?
+                ($from_seq == $self->{"seq"}))
+            {
+                $ret = 1;                   # It's a winner
+                $done = 1;
+            }
+        }
+        else                                # Oops, timed out
+        {
+            $done = 1;
+        }
+    }
+    return($ret)
+}
+
+# Description:  Do a checksum on the message.  Basically sum all of
+# the short words and fold the high order bits into the low order bits.
+
+sub checksum
+{
+    my ($class,
+        $msg            # The message to checksum
+        ) = @_;
+    my ($len_msg,       # Length of the message
+        $num_short,     # The number of short words in the message
+        $short,         # One short word
+        $chk            # The checksum
+        );
+
+    $len_msg = length($msg);
+    $num_short = $len_msg / 2;
+    $chk = 0;
+    foreach $short (unpack("S$num_short", $msg))
+    {
+        $chk += $short;
+    }                                           # Add the odd byte in
+    $chk += unpack("C", substr($msg, $len_msg - 1, 1)) if $len_msg % 2;
+    $chk = ($chk >> 16) + ($chk & 0xffff);      # Fold high into low
+    return(~(($chk >> 16) + $chk) & 0xffff);    # Again and complement
+}
+
+# Description:  Perform a tcp echo ping.  Since a tcp connection is
+# host specific, we have to open and close each connection here.  We
+# can't just leave a socket open.  Because of the robust nature of
+# tcp, it will take a while before it gives up trying to establish a
+# connection.  Therefore, we have to set the alarm to break out of the
+# connection sooner if the timeout expires.  No data bytes are actually
+# sent since the successful establishment of a connection is proof
+# enough of the reachability of the remote host.  Also, tcp is
+# expensive and doesn't need our help to add to the overhead.
+
+sub ping_tcp
+{
+    my ($self,
+        $ip,                # Packed IP number of the host
+        $timeout            # Seconds after which ping times out
+        ) = @_;
+    my ($saddr,             # sockaddr_in with port and ip
+        $ret                # The return value
+        );
+                            
+    socket($self->{"fh"}, &PF_INET(), &SOCK_STREAM(), $self->{"proto_num"}) ||
+        croak("tcp socket error - $!");
+    $saddr = sockaddr_in($self->{"port_num"}, $ip);
+
+    $SIG{'ALRM'} = sub { die };
+    alarm($timeout);        # Interrupt connect() if we have to
+            
+    $ret = 0;               # Default to unreachable
     eval <<'EOM' ;
-    return unless socket(PINGSOCK, PF_INET, SOCK_STREAM, $tcp_proto) ;
-    return unless connect(PINGSOCK, $saddr) ;
-    $ret=1 ;
+        return unless connect($self->{"fh"}, $saddr);
+        $ret = 1;
 EOM
     alarm(0);
-    close(PINGSOCK);
-    $ret;
+    $self->{"fh"}->close();
+    return($ret);
+}
+
+# Description:  Perform a udp echo ping.  Construct a message of
+# at least the one-byte sequence number and any additional data bytes.
+# Send the message out and wait for a message to come back.  If we
+# get a message, make sure all of its parts match.  If they do, we are
+# done.  Otherwise go back and wait for the message until we run out
+# of time.  Return the result of our efforts.
+
+sub ping_udp
+{
+    my ($self,
+        $ip,                # Packed IP number of the host
+        $timeout            # Seconds after which ping times out
+        ) = @_;
+
+    my $flags = 0;          # Nothing special on open
+
+    my ($saddr,             # sockaddr_in with port and ip
+        $ret,               # The return value
+        $msg,               # Message to be echoed
+        $finish_time,       # Time ping should be finished
+        $done,              # Set to 1 when we are done pinging
+        $rbits,             # Read bits, filehandles for reading
+        $nfound,            # Number of ready filehandles found
+        $from_saddr,        # sockaddr_in of sender
+        $from_msg,          # Characters echoed by $host
+        $from_port,         # Port message was echoed from
+        $from_ip            # Packed IP number of sender
+        );
+
+    $saddr = sockaddr_in($self->{"port_num"}, $ip);
+    $self->{"seq"} = ($self->{"seq"} + 1) % 256;    # Increment sequence
+    $msg = chr($self->{"seq"}) . $self->{"data"};   # Add data if any
+    send($self->{"fh"}, $msg, $flags, $saddr);      # Send it
+
+    $rbits = "";
+    vec($rbits, $self->{"fh"}->fileno(), 1) = 1;
+    $ret = 0;                   # Default to unreachable
+    $done = 0;
+    $finish_time = time() + $timeout;       # Ping needs to be done by then
+    while (!$done && $timeout > 0)
+    {
+        $nfound = select($rbits, undef, undef, $timeout); # Wait for response
+        $timeout = $finish_time - time();   # Get remaining time
+
+        if (!defined($nfound))  # Hmm, a strange error
+        {
+            $ret = undef;
+            $done = 1;
+        }
+        elsif ($nfound)         # A packet is waiting
+        {
+            $from_msg = "";
+            $from_saddr = recv($self->{"fh"}, $from_msg, 1500, $flags);
+            ($from_port, $from_ip) = sockaddr_in($from_saddr);
+            if (($from_ip eq $ip) &&        # Does the packet check out?
+                ($from_port == $self->{"port_num"}) &&
+                ($from_msg eq $msg))
+            {
+                $ret = 1;       # It's a winner
+                $done = 1;
+            }
+        }
+        else                    # Oops, timed out
+        {
+            $done = 1;
+        }
+    }
+    return($ret);
 }   
 
+# Description:  Close the connection unless we are using the tcp
+# protocol, since it will already be closed.
+
+sub close
+{
+    my ($self) = @_;
+
+    $self->{"fh"}->close() unless $self->{"proto"} eq "tcp";
+}
+
+
 1;
 __END__
 
-=cut
-
 =head1 NAME
 
-Net::Ping, pingecho - check a host for upness
+Net::Ping - check a remote host for reachability
 
 =head1 SYNOPSIS
 
     use Net::Ping;
-    print "'jimmy' is alive and kicking\n" if pingecho('jimmy', 10) ;
-
-=head1 DESCRIPTION
 
-This module contains routines to test for the reachability of remote hosts.
-Currently the only routine implemented is pingecho(). 
+    $p = Net::Ping->new();
+    print "$host is alive.\n" if $p->ping($host);
+    $p->close();
+
+    $p = Net::Ping->new("icmp");
+    foreach $host (@host_array)
+    {
+        print "$host is ";
+        print "NOT " unless $p->ping($host, 2);
+        print "reachable.\n";
+        sleep(1);
+    }
+    $p->close();
+    
+    $p = Net::Ping->new("tcp", 2);
+    while ($stop_time > time())
+    {
+        print "$host not reachable ", scalar(localtime()), "\n"
+            unless $p->ping($host);
+        sleep(300);
+    }
+    undef($p);
+    
+    # For backward compatibility
+    print "$host is alive.\n" if pingecho($host);
 
-pingecho() uses a TCP echo (I<not> an ICMP one) to determine if the
-remote host is reachable. This is usually adequate to tell that a remote
-host is available to rsh(1), ftp(1), or telnet(1) onto.
+=head1 DESCRIPTION
 
-=head2 Parameters
+This module contains methods to test the reachability of remote
+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 three different protocols to use for the ping.
+With the "tcp" protocol the ping() method attempts to establish a
+connection to the remote host's echo port.  If the connection is
+successfully established, the remote host is considered reachable.  No
+data is actually echoed.  This protocol does not require any special
+privileges but has higher overhead than the other two protocols.
+
+Specifying the "udp" protocol causes the ping() method to send a udp
+packet to the remote host's echo port.  If the echoed packet is
+received from the remote host and the received packet contains the
+same data as the packet that was sent, the remote host is considered
+reachable.  This protocol does not require any special privileges.
+
+If the "icmp" protocol is specified, the ping() method sends an icmp
+echo message to the remote host, which is what the UNIX ping program
+does.  If the echoed message is received from the remote host and
+the echoed information is correct, the remote host is considered
+reachable.  Specifying the "icmp" protocol requires that the program
+be run as root or that the program be setuid to root.
+
+=head2 Functions
+
+=over 4
+
+=item Net::Ping->new([$proto [, $def_timeout [, $bytes]]]);
+
+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".
+
+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
+must be greater than 0 and the default, if not specified, is 5 seconds.
+
+If the number of data bytes ($bytes) is given, that many data bytes
+are included in the ping packet sent to the remote host. The number of
+data bytes is ignored if the protocol is "tcp".  The minimum (and
+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.
+
+=item $p->ping($host [, $timeout]);
+
+Ping the remote host and wait for a response.  $host can be either the
+hostname or the IP number of the remote host.  The optional timeout
+must be greater than 0 seconds and defaults to whatever was specified
+when the ping object was created.  If the hostname cannot be found or
+there is a problem with the IP number, undef is returned.  Otherwise,
+1 is returned if the host is reachable and 0 if it is not.  For all
+practical purposes, undef and 0 and can be treated as the same case.
+
+=item $p->close();
+
+Close the network connection for this ping object.  The network
+connection is also closed by "undef $p".  The network connection is
+automatically closed if the ping object goes out of scope (e.g. $p is
+local to a subroutine and you leave the subroutine).
+
+=item pingecho($host [, $timeout]);
+
+To provide backward compatibility with the previous version of
+Net::Ping, a pingecho() subroutine is available with the same
+functionality as before.  pingecho() uses the tcp protocol.  The
+return values and parameters are the same as described for the ping()
+method.  This subroutine is obsolete and may be removed in a future
+version of Net::Ping.
 
-=over 5
+=back
 
-=item hostname
+=head1 WARNING
 
-The remote host to check, specified either as a hostname or as an IP address.
+pingecho() or a ping object with the tcp protocol use alarm() to
+implement the timeout.  So, don't use alarm() in your program while
+you are using pingecho() or a ping object with the tcp protocol.  The
+udp and icmp protocols do not use alarm() to implement the timeout.
 
-=item timeout
+=head1 NOTES
 
-The timeout in seconds. If not specified it will default to 5 seconds.
+There will be less network overhead (and some efficiency in your
+program) if you specify either the udp or the icmp protocol.  The tcp
+protocol will generate 2.5 times or more traffic for each ping than
+either udp or icmp.  If many hosts are pinged frequently, you may wish
+to implement a small wait (e.g. 25ms or more) between each ping to
+avoid flooding your network with packets.
 
-=back
+The icmp protocol requires that the program be run as root or that it
+be setuid to root.  The tcp and udp protocols do not require special
+privileges, but not all network devices implement the echo protocol
+for tcp or udp.
 
-=head1 WARNING
+Local hosts should normally respond to pings within milliseconds.
+However, on a very congested network it may take up to 3 seconds or
+longer to receive an echo packet from the remote host.  If the timeout
+is set too low under these conditions, it will appear that the remote
+host is not reachable (which is almost the truth).
 
-pingecho() uses alarm to implement the timeout, so don't set another alarm
-while you are using it.
+Reachability doesn't necessarily mean that the remote host is actually
+functioning beyond its ability to echo packets.
 
+Because of a lack of anything better, this module uses its own
+routines to pack and unpack ICMP packets.  It would be better for a
+separate module to be written which understands all of the different
+kinds of ICMP packets.
 
+=cut