[p5sagit/p5-mst-13.2.git] / lib / Net / Ping.pm

package Net::Ping;

# Author:   mose@ccsn.edu (Russell Mosemann)
#
# Authors of the original pingecho():
#           karrer@bernina.ethz.ch (Andreas Karrer)
#           Paul.Marquess@btinternet.com (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.

use 5.005_64;
require Exporter;

use strict;
our(@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(pingecho);
$VERSION = 2.02;

# Constants

$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

# 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.

sub pingecho
{
    my ($host,              # Name or IP number of host to ping
        $timeout            # Optional timeout in seconds
        ) = @_;
    my ($p);                # A ping object

    $p = Net::Ping->new("tcp", $timeout);
    $p->ping($host);        # Going out of scope closes the connection
}

# 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 ($> and $^O ne 'VMS');
        $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);
}

# 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
    {
        croak("Unknown protocol \"$self->{proto}\" in ping()");
    }
    return($ret);
}

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 = int($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)) << 8) 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 connect($self->{"fh"}, $saddr);
        $ret = 1;
EOM
    alarm(0);
    $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)
		or last; # For example an unreachable host will make recv() fail.
	    ($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__

=head1 NAME

Net::Ping - check a remote host for reachability

=head1 SYNOPSIS

    use Net::Ping;

    $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);

=head1 DESCRIPTION

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. The "udp" 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.

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.

It should be borne in mind that, for both tcp and udp ping, a host
will be reported as unreachable if it is not running the
appropriate echo service.  For Unix-like systems see L<inetd(8)> for
more information.

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.

=back

=head1 WARNING

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.

=head1 NOTES

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.

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.

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).

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
Commit	Line	Data
a0d0e21e	1	package Net::Ping;
a0d0e21e	2
a3b93737	3	# Author: mose@ccsn.edu (Russell Mosemann)
	4	#
	5	# Authors of the original pingecho():
	6	# karrer@bernina.ethz.ch (Andreas Karrer)
0536e0eb	7	# Paul.Marquess@btinternet.com (Paul Marquess)
a3b93737	8	#
	9	# Copyright (c) 1996 Russell Mosemann. All rights reserved. This
	10	# program is free software; you may redistribute it and/or modify it
	11	# under the same terms as Perl itself.
	12
17f410f9	13	use 5.005_64;
a0d0e21e	14	require Exporter;
a0d0e21e	15
a3b93737	16	use strict;
17f410f9	17	our(@ISA, @EXPORT, $VERSION, $def_timeout, $def_proto, $max_datasize);
a3b93737	18	use FileHandle;
	19	use Socket qw( SOCK_DGRAM SOCK_STREAM SOCK_RAW PF_INET
	20	inet_aton sockaddr_in );
	21	use Carp;
a79c1648	22
a0d0e21e	23	@ISA = qw(Exporter);
a3b93737	24	@EXPORT = qw(pingecho);
a3b93737	25	$VERSION = 2.02;
a0d0e21e	26
a3b93737	27	# Constants
a0d0e21e	28
a3b93737	29	$def_timeout = 5; # Default timeout to wait for a reply
	30	$def_proto = "udp"; # Default protocol to use for pinging
	31	$max_datasize = 1024; # Maximum data bytes in a packet
a0d0e21e	32
a3b93737	33	# Description: The pingecho() subroutine is provided for backward
	34	# compatibility with the original Net::Ping. It accepts a host
	35	# name/IP and an optional timeout in seconds. Create a tcp ping
	36	# object and try pinging the host. The result of the ping is returned.
a0d0e21e	37
a3b93737	38	sub pingecho
	39	{
	40	my ($host, # Name or IP number of host to ping
	41	$timeout # Optional timeout in seconds
	42	) = @_;
	43	my ($p); # A ping object
a0d0e21e	44
a3b93737	45	$p = Net::Ping->new("tcp", $timeout);
	46	$p->ping($host); # Going out of scope closes the connection
	47	}
a0d0e21e	48
a3b93737	49	# Description: The new() method creates a new ping object. Optional
	50	# parameters may be specified for the protocol to use, the timeout in
	51	# seconds and the size in bytes of additional data which should be
	52	# included in the packet.
	53	# After the optional parameters are checked, the data is constructed
	54	# and a socket is opened if appropriate. The object is returned.
	55
	56	sub new
	57	{
	58	my ($this,
	59	$proto, # Optional protocol to use for pinging
	60	$timeout, # Optional timeout in seconds
	61	$data_size # Optional additional bytes of data
	62	) = @_;
	63	my $class = ref($this) \|\| $this;
	64	my $self = {};
	65	my ($cnt, # Count through data bytes
	66	$min_datasize # Minimum data bytes required
	67	);
	68
	69	bless($self, $class);
	70
	71	$proto = $def_proto unless $proto; # Determine the protocol
	72	croak("Protocol for ping must be \"tcp\", \"udp\" or \"icmp\"")
	73	unless $proto =~ m/^(tcp\|udp\|icmp)$/;
	74	$self->{"proto"} = $proto;
	75
	76	$timeout = $def_timeout unless $timeout; # Determine the timeout
	77	croak("Default timeout for ping must be greater than 0 seconds")
	78	if $timeout <= 0;
	79	$self->{"timeout"} = $timeout;
	80
	81	$min_datasize = ($proto eq "udp") ? 1 : 0; # Determine data size
	82	$data_size = $min_datasize unless defined($data_size) && $proto ne "tcp";
	83	croak("Data for ping must be from $min_datasize to $max_datasize bytes")
	84	if ($data_size < $min_datasize) \|\| ($data_size > $max_datasize);
	85	$data_size-- if $self->{"proto"} eq "udp"; # We provide the first byte
	86	$self->{"data_size"} = $data_size;
	87
	88	$self->{"data"} = ""; # Construct data bytes
	89	for ($cnt = 0; $cnt < $self->{"data_size"}; $cnt++)
	90	{
	91	$self->{"data"} .= chr($cnt % 256);
	92	}
	93
	94	$self->{"seq"} = 0; # For counting packets
	95	if ($self->{"proto"} eq "udp") # Open a socket
	96	{
	97	$self->{"proto_num"} = (getprotobyname('udp'))[2] \|\|
	98	croak("Can't udp protocol by name");
	99	$self->{"port_num"} = (getservbyname('echo', 'udp'))[2] \|\|
	100	croak("Can't get udp echo port by name");
	101	$self->{"fh"} = FileHandle->new();
	102	socket($self->{"fh"}, &PF_INET(), &SOCK_DGRAM(),
	103	$self->{"proto_num"}) \|\|
	104	croak("udp socket error - $!");
	105	}
	106	elsif ($self->{"proto"} eq "icmp")
	107	{
17f28c40	108	croak("icmp ping requires root privilege") if ($> and $^O ne 'VMS');
a3b93737	109	$self->{"proto_num"} = (getprotobyname('icmp'))[2] \|\|
	110	croak("Can't get icmp protocol by name");
	111	$self->{"pid"} = $$ & 0xffff; # Save lower 16 bits of pid
	112	$self->{"fh"} = FileHandle->new();
	113	socket($self->{"fh"}, &PF_INET(), &SOCK_RAW(), $self->{"proto_num"}) \|\|
	114	croak("icmp socket error - $!");
	115	}
	116	elsif ($self->{"proto"} eq "tcp") # Just a file handle for now
	117	{
	118	$self->{"proto_num"} = (getprotobyname('tcp'))[2] \|\|
	119	croak("Can't get tcp protocol by name");
	120	$self->{"port_num"} = (getservbyname('echo', 'tcp'))[2] \|\|
	121	croak("Can't get tcp echo port by name");
	122	$self->{"fh"} = FileHandle->new();
	123	}
	124
	125
	126	return($self);
	127	}
a0d0e21e	128
a3b93737	129	# Description: Ping a host name or IP number with an optional timeout.
	130	# First lookup the host, and return undef if it is not found. Otherwise
	131	# perform the specific ping method based on the protocol. Return the
	132	# result of the ping.
	133
	134	sub ping
	135	{
	136	my ($self,
	137	$host, # Name or IP number of host to ping
	138	$timeout # Seconds after which ping times out
	139	) = @_;
	140	my ($ip, # Packed IP number of $host
	141	$ret # The return value
	142	);
	143
	144	croak("Usage: \$p->ping(\$host [, \$timeout])") unless @_ == 2 \|\| @_ == 3;
	145	$timeout = $self->{"timeout"} unless $timeout;
	146	croak("Timeout must be greater than 0 seconds") if $timeout <= 0;
	147
	148	$ip = inet_aton($host);
	149	return(undef) unless defined($ip); # Does host exist?
	150
	151	if ($self->{"proto"} eq "udp")
	152	{
	153	$ret = $self->ping_udp($ip, $timeout);
	154	}
	155	elsif ($self->{"proto"} eq "icmp")
	156	{
	157	$ret = $self->ping_icmp($ip, $timeout);
	158	}
	159	elsif ($self->{"proto"} eq "tcp")
	160	{
	161	$ret = $self->ping_tcp($ip, $timeout);
	162	}
a0d0e21e	163	else
a3b93737	164	{
	165	croak("Unknown protocol \"$self->{proto}\" in ping()");
	166	}
	167	return($ret);
	168	}
a0d0e21e	169
a3b93737	170	sub ping_icmp
	171	{
	172	my ($self,
	173	$ip, # Packed IP number of the host
	174	$timeout # Seconds after which ping times out
	175	) = @_;
	176
	177	my $ICMP_ECHOREPLY = 0; # ICMP packet types
	178	my $ICMP_ECHO = 8;
	179	my $icmp_struct = "C2 S3 A"; # Structure of a minimal ICMP packet
	180	my $subcode = 0; # No ICMP subcode for ECHO and ECHOREPLY
	181	my $flags = 0; # No special flags when opening a socket
	182	my $port = 0; # No port with ICMP
	183
	184	my ($saddr, # sockaddr_in with port and ip
	185	$checksum, # Checksum of ICMP packet
	186	$msg, # ICMP packet to send
	187	$len_msg, # Length of $msg
	188	$rbits, # Read bits, filehandles for reading
	189	$nfound, # Number of ready filehandles found
	190	$finish_time, # Time ping should be finished
	191	$done, # set to 1 when we are done
	192	$ret, # Return value
	193	$recv_msg, # Received message including IP header
	194	$from_saddr, # sockaddr_in of sender
	195	$from_port, # Port packet was sent from
	196	$from_ip, # Packed IP of sender
	197	$from_type, # ICMP type
	198	$from_subcode, # ICMP subcode
	199	$from_chk, # ICMP packet checksum
	200	$from_pid, # ICMP packet id
	201	$from_seq, # ICMP packet sequence
	202	$from_msg # ICMP message
	203	);
	204
	205	$self->{"seq"} = ($self->{"seq"} + 1) % 65536; # Increment sequence
	206	$checksum = 0; # No checksum for starters
	207	$msg = pack($icmp_struct . $self->{"data_size"}, $ICMP_ECHO, $subcode,
	208	$checksum, $self->{"pid"}, $self->{"seq"}, $self->{"data"});
	209	$checksum = Net::Ping->checksum($msg);
	210	$msg = pack($icmp_struct . $self->{"data_size"}, $ICMP_ECHO, $subcode,
	211	$checksum, $self->{"pid"}, $self->{"seq"}, $self->{"data"});
	212	$len_msg = length($msg);
	213	$saddr = sockaddr_in($port, $ip);
	214	send($self->{"fh"}, $msg, $flags, $saddr); # Send the message
	215
	216	$rbits = "";
	217	vec($rbits, $self->{"fh"}->fileno(), 1) = 1;
8e07c86e	218	$ret = 0;
a3b93737	219	$done = 0;
	220	$finish_time = time() + $timeout; # Must be done by this time
	221	while (!$done && $timeout > 0) # Keep trying if we have time
	222	{
	223	$nfound = select($rbits, undef, undef, $timeout); # Wait for packet
	224	$timeout = $finish_time - time(); # Get remaining time
	225	if (!defined($nfound)) # Hmm, a strange error
	226	{
	227	$ret = undef;
	228	$done = 1;
	229	}
	230	elsif ($nfound) # Got a packet from somewhere
	231	{
	232	$recv_msg = "";
	233	$from_saddr = recv($self->{"fh"}, $recv_msg, 1500, $flags);
	234	($from_port, $from_ip) = sockaddr_in($from_saddr);
	235	($from_type, $from_subcode, $from_chk,
	236	$from_pid, $from_seq, $from_msg) =
	237	unpack($icmp_struct . $self->{"data_size"},
	238	substr($recv_msg, length($recv_msg) - $len_msg,
	239	$len_msg));
	240	if (($from_type == $ICMP_ECHOREPLY) &&
	241	($from_ip eq $ip) &&
	242	($from_pid == $self->{"pid"}) && # Does the packet check out?
	243	($from_seq == $self->{"seq"}))
	244	{
	245	$ret = 1; # It's a winner
	246	$done = 1;
	247	}
	248	}
	249	else # Oops, timed out
	250	{
	251	$done = 1;
	252	}
	253	}
	254	return($ret)
	255	}
	256
	257	# Description: Do a checksum on the message. Basically sum all of
	258	# the short words and fold the high order bits into the low order bits.
	259
	260	sub checksum
	261	{
	262	my ($class,
	263	$msg # The message to checksum
	264	) = @_;
	265	my ($len_msg, # Length of the message
	266	$num_short, # The number of short words in the message
	267	$short, # One short word
	268	$chk # The checksum
	269	);
	270
	271	$len_msg = length($msg);
42fcf866	272	$num_short = int($len_msg / 2);
a3b93737	273	$chk = 0;
	274	foreach $short (unpack("S$num_short", $msg))
	275	{
	276	$chk += $short;
	277	} # Add the odd byte in
42fcf866	278	$chk += (unpack("C", substr($msg, $len_msg - 1, 1)) << 8) if $len_msg % 2;
a3b93737	279	$chk = ($chk >> 16) + ($chk & 0xffff); # Fold high into low
	280	return(~(($chk >> 16) + $chk) & 0xffff); # Again and complement
	281	}
	282
	283	# Description: Perform a tcp echo ping. Since a tcp connection is
	284	# host specific, we have to open and close each connection here. We
	285	# can't just leave a socket open. Because of the robust nature of
	286	# tcp, it will take a while before it gives up trying to establish a
	287	# connection. Therefore, we have to set the alarm to break out of the
	288	# connection sooner if the timeout expires. No data bytes are actually
	289	# sent since the successful establishment of a connection is proof
	290	# enough of the reachability of the remote host. Also, tcp is
	291	# expensive and doesn't need our help to add to the overhead.
	292
	293	sub ping_tcp
	294	{
	295	my ($self,
	296	$ip, # Packed IP number of the host
	297	$timeout # Seconds after which ping times out
	298	) = @_;
	299	my ($saddr, # sockaddr_in with port and ip
	300	$ret # The return value
	301	);
	302
	303	socket($self->{"fh"}, &PF_INET(), &SOCK_STREAM(), $self->{"proto_num"}) \|\|
	304	croak("tcp socket error - $!");
	305	$saddr = sockaddr_in($self->{"port_num"}, $ip);
	306
	307	$SIG{'ALRM'} = sub { die };
	308	alarm($timeout); # Interrupt connect() if we have to
	309
	310	$ret = 0; # Default to unreachable
8e07c86e	311	eval <<'EOM' ;
a3b93737	312	return unless connect($self->{"fh"}, $saddr);
a3b93737	313	$ret = 1;
a0d0e21e	314	EOM
a0d0e21e	315	alarm(0);
a3b93737	316	$self->{"fh"}->close();
	317	return($ret);
	318	}
	319
	320	# Description: Perform a udp echo ping. Construct a message of
	321	# at least the one-byte sequence number and any additional data bytes.
	322	# Send the message out and wait for a message to come back. If we
	323	# get a message, make sure all of its parts match. If they do, we are
	324	# done. Otherwise go back and wait for the message until we run out
	325	# of time. Return the result of our efforts.
	326
	327	sub ping_udp
	328	{
	329	my ($self,
	330	$ip, # Packed IP number of the host
	331	$timeout # Seconds after which ping times out
	332	) = @_;
	333
	334	my $flags = 0; # Nothing special on open
	335
	336	my ($saddr, # sockaddr_in with port and ip
	337	$ret, # The return value
	338	$msg, # Message to be echoed
	339	$finish_time, # Time ping should be finished
	340	$done, # Set to 1 when we are done pinging
	341	$rbits, # Read bits, filehandles for reading
	342	$nfound, # Number of ready filehandles found
	343	$from_saddr, # sockaddr_in of sender
	344	$from_msg, # Characters echoed by $host
	345	$from_port, # Port message was echoed from
	346	$from_ip # Packed IP number of sender
	347	);
	348
	349	$saddr = sockaddr_in($self->{"port_num"}, $ip);
	350	$self->{"seq"} = ($self->{"seq"} + 1) % 256; # Increment sequence
	351	$msg = chr($self->{"seq"}) . $self->{"data"}; # Add data if any
	352	send($self->{"fh"}, $msg, $flags, $saddr); # Send it
	353
	354	$rbits = "";
	355	vec($rbits, $self->{"fh"}->fileno(), 1) = 1;
	356	$ret = 0; # Default to unreachable
	357	$done = 0;
	358	$finish_time = time() + $timeout; # Ping needs to be done by then
	359	while (!$done && $timeout > 0)
	360	{
	361	$nfound = select($rbits, undef, undef, $timeout); # Wait for response
	362	$timeout = $finish_time - time(); # Get remaining time
	363
	364	if (!defined($nfound)) # Hmm, a strange error
	365	{
	366	$ret = undef;
	367	$done = 1;
	368	}
	369	elsif ($nfound) # A packet is waiting
	370	{
	371	$from_msg = "";
b4b1f609	372	$from_saddr = recv($self->{"fh"}, $from_msg, 1500, $flags)
	373	or last; # For example an unreachable host will make recv() fail.
	374	($from_port, $from_ip) = sockaddr_in($from_saddr);
	375	if (($from_ip eq $ip) && # Does the packet check out?
	376	($from_port == $self->{"port_num"}) &&
	377	($from_msg eq $msg))
	378	{
	379	$ret = 1; # It's a winner
	380	$done = 1;
	381	}
	382	}
a3b93737	383	else # Oops, timed out
	384	{
	385	$done = 1;
	386	}
	387	}
	388	return($ret);
a0d0e21e	389	}
a0d0e21e	390
a3b93737	391	# Description: Close the connection unless we are using the tcp
	392	# protocol, since it will already be closed.
	393
	394	sub close
	395	{
	396	my ($self) = @_;
	397
	398	$self->{"fh"}->close() unless $self->{"proto"} eq "tcp";
	399	}
	400
	401
a0d0e21e	402	1;
8e07c86e	403	__END__
8e07c86e	404
8e07c86e	405	=head1 NAME
8e07c86e	406
a3b93737	407	Net::Ping - check a remote host for reachability
8e07c86e	408
	409	=head1 SYNOPSIS
	410
	411	use Net::Ping;
8e07c86e	412
a3b93737	413	$p = Net::Ping->new();
	414	print "$host is alive.\n" if $p->ping($host);
	415	$p->close();
	416
	417	$p = Net::Ping->new("icmp");
	418	foreach $host (@host_array)
	419	{
	420	print "$host is ";
	421	print "NOT " unless $p->ping($host, 2);
	422	print "reachable.\n";
	423	sleep(1);
	424	}
	425	$p->close();
3cb6de81	426
a3b93737	427	$p = Net::Ping->new("tcp", 2);
	428	while ($stop_time > time())
	429	{
	430	print "$host not reachable ", scalar(localtime()), "\n"
	431	unless $p->ping($host);
	432	sleep(300);
	433	}
	434	undef($p);
3cb6de81	435
a3b93737	436	# For backward compatibility
a3b93737	437	print "$host is alive.\n" if pingecho($host);
8e07c86e	438
a3b93737	439	=head1 DESCRIPTION
8e07c86e	440
a3b93737	441	This module contains methods to test the reachability of remote
	442	hosts on a network. A ping object is first created with optional
	443	parameters, a variable number of hosts may be pinged multiple
	444	times and then the connection is closed.
	445
be3174d2	446	You may choose one of three different protocols to use for the
	447	ping. The "udp" protocol is the default. Note that a live remote host
	448	may still fail to be pingable by one or more of these protocols. For
	449	example, www.microsoft.com is generally alive but not pingable.
	450
a3b93737	451	With the "tcp" protocol the ping() method attempts to establish a
	452	connection to the remote host's echo port. If the connection is
	453	successfully established, the remote host is considered reachable. No
	454	data is actually echoed. This protocol does not require any special
	455	privileges but has higher overhead than the other two protocols.
	456
	457	Specifying the "udp" protocol causes the ping() method to send a udp
	458	packet to the remote host's echo port. If the echoed packet is
	459	received from the remote host and the received packet contains the
	460	same data as the packet that was sent, the remote host is considered
	461	reachable. This protocol does not require any special privileges.
	462
ba830936	463	It should be borne in mind that, for both tcp and udp ping, a host
4d69506c	464	will be reported as unreachable if it is not running the
ba830936	465	appropriate echo service. For Unix-like systems see L<inetd(8)> for
	466	more information.
	467
a3b93737	468	If the "icmp" protocol is specified, the ping() method sends an icmp
	469	echo message to the remote host, which is what the UNIX ping program
	470	does. If the echoed message is received from the remote host and
	471	the echoed information is correct, the remote host is considered
	472	reachable. Specifying the "icmp" protocol requires that the program
	473	be run as root or that the program be setuid to root.
	474
	475	=head2 Functions
	476
	477	=over 4
	478
	479	=item Net::Ping->new([$proto [, $def_timeout [, $bytes]]]);
	480
	481	Create a new ping object. All of the parameters are optional. $proto
	482	specifies the protocol to use when doing a ping. The current choices
	483	are "tcp", "udp" or "icmp". The default is "udp".
	484
	485	If a default timeout ($def_timeout) in seconds is provided, it is used
	486	when a timeout is not given to the ping() method (below). The timeout
	487	must be greater than 0 and the default, if not specified, is 5 seconds.
	488
	489	If the number of data bytes ($bytes) is given, that many data bytes
	490	are included in the ping packet sent to the remote host. The number of
	491	data bytes is ignored if the protocol is "tcp". The minimum (and
	492	default) number of data bytes is 1 if the protocol is "udp" and 0
	493	otherwise. The maximum number of data bytes that can be specified is
	494	1024.
	495
	496	=item $p->ping($host [, $timeout]);
	497
	498	Ping the remote host and wait for a response. $host can be either the
	499	hostname or the IP number of the remote host. The optional timeout
	500	must be greater than 0 seconds and defaults to whatever was specified
	501	when the ping object was created. If the hostname cannot be found or
	502	there is a problem with the IP number, undef is returned. Otherwise,
	503	1 is returned if the host is reachable and 0 if it is not. For all
	504	practical purposes, undef and 0 and can be treated as the same case.
	505
	506	=item $p->close();
	507
	508	Close the network connection for this ping object. The network
	509	connection is also closed by "undef $p". The network connection is
	510	automatically closed if the ping object goes out of scope (e.g. $p is
	511	local to a subroutine and you leave the subroutine).
	512
	513	=item pingecho($host [, $timeout]);
	514
	515	To provide backward compatibility with the previous version of
	516	Net::Ping, a pingecho() subroutine is available with the same
	517	functionality as before. pingecho() uses the tcp protocol. The
	518	return values and parameters are the same as described for the ping()
	519	method. This subroutine is obsolete and may be removed in a future
	520	version of Net::Ping.
8e07c86e	521
a3b93737	522	=back
8e07c86e	523
a3b93737	524	=head1 WARNING
8e07c86e	525
a3b93737	526	pingecho() or a ping object with the tcp protocol use alarm() to
	527	implement the timeout. So, don't use alarm() in your program while
	528	you are using pingecho() or a ping object with the tcp protocol. The
	529	udp and icmp protocols do not use alarm() to implement the timeout.
8e07c86e	530
a3b93737	531	=head1 NOTES
8e07c86e	532
a3b93737	533	There will be less network overhead (and some efficiency in your
	534	program) if you specify either the udp or the icmp protocol. The tcp
	535	protocol will generate 2.5 times or more traffic for each ping than
	536	either udp or icmp. If many hosts are pinged frequently, you may wish
	537	to implement a small wait (e.g. 25ms or more) between each ping to
	538	avoid flooding your network with packets.
8e07c86e	539
a3b93737	540	The icmp protocol requires that the program be run as root or that it
	541	be setuid to root. The tcp and udp protocols do not require special
	542	privileges, but not all network devices implement the echo protocol
	543	for tcp or udp.
8e07c86e	544
a3b93737	545	Local hosts should normally respond to pings within milliseconds.
	546	However, on a very congested network it may take up to 3 seconds or
	547	longer to receive an echo packet from the remote host. If the timeout
	548	is set too low under these conditions, it will appear that the remote
	549	host is not reachable (which is almost the truth).
8e07c86e	550
a3b93737	551	Reachability doesn't necessarily mean that the remote host is actually
a3b93737	552	functioning beyond its ability to echo packets.
8e07c86e	553
a3b93737	554	Because of a lack of anything better, this module uses its own
	555	routines to pack and unpack ICMP packets. It would be better for a
	556	separate module to be written which understands all of the different
	557	kinds of ICMP packets.
8e07c86e	558
a3b93737	559	=cut