home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / lib / Net / Ping.pm < prev    next >
Text File  |  2000-03-03  |  21KB  |  550 lines

  1. package Net::Ping;
  2.  
  3. # Author:   mose@ccsn.edu (Russell Mosemann)
  4. #
  5. # Authors of the original pingecho():
  6. #           karrer@bernina.ethz.ch (Andreas Karrer)
  7. #           Paul.Marquess@btinternet.com (Paul Marquess)
  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.  
  13. use 5.005_64;
  14. require Exporter;
  15.  
  16. use strict;
  17. our(@ISA, @EXPORT, $VERSION, $def_timeout, $def_proto, $max_datasize);
  18. use FileHandle;
  19. use Socket qw( SOCK_DGRAM SOCK_STREAM SOCK_RAW PF_INET
  20.                inet_aton sockaddr_in );
  21. use Carp;
  22.  
  23. @ISA = qw(Exporter);
  24. @EXPORT = qw(pingecho);
  25. $VERSION = 2.02;
  26.  
  27. # Constants
  28.  
  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
  32.  
  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.
  37.  
  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
  44.  
  45.     $p = Net::Ping->new("tcp", $timeout);
  46.     $p->ping($host);        # Going out of scope closes the connection
  47. }
  48.  
  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.     {
  108.         croak("icmp ping requires root privilege") if ($> and $^O ne 'VMS');
  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. }
  128.  
  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.     }
  163.     else
  164.     {
  165.         croak("Unknown protocol \"$self->{proto}\" in ping()");
  166.     }
  167.     return($ret);
  168. }
  169.  
  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;
  218.     $ret = 0;
  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);
  272.     $num_short = $len_msg / 2;
  273.     $chk = 0;
  274.     foreach $short (unpack("S$num_short", $msg))
  275.     {
  276.         $chk += $short;
  277.     }                                           # Add the odd byte in
  278.     $chk += unpack("C", substr($msg, $len_msg - 1, 1)) if $len_msg % 2;
  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
  311.     eval <<'EOM' ;
  312.         return unless connect($self->{"fh"}, $saddr);
  313.         $ret = 1;
  314. EOM
  315.     alarm(0);
  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 = "";
  372.             $from_saddr = recv($self->{"fh"}, $from_msg, 1500, $flags);
  373.             ($from_port, $from_ip) = sockaddr_in($from_saddr);
  374.             if (($from_ip eq $ip) &&        # Does the packet check out?
  375.                 ($from_port == $self->{"port_num"}) &&
  376.                 ($from_msg eq $msg))
  377.             {
  378.                 $ret = 1;       # It's a winner
  379.                 $done = 1;
  380.             }
  381.         }
  382.         else                    # Oops, timed out
  383.         {
  384.             $done = 1;
  385.         }
  386.     }
  387.     return($ret);
  388. }   
  389.  
  390. # Description:  Close the connection unless we are using the tcp
  391. # protocol, since it will already be closed.
  392.  
  393. sub close
  394. {
  395.     my ($self) = @_;
  396.  
  397.     $self->{"fh"}->close() unless $self->{"proto"} eq "tcp";
  398. }
  399.  
  400.  
  401. 1;
  402. __END__
  403.  
  404. =head1 NAME
  405.  
  406. Net::Ping - check a remote host for reachability
  407.  
  408. =head1 SYNOPSIS
  409.  
  410.     use Net::Ping;
  411.  
  412.     $p = Net::Ping->new();
  413.     print "$host is alive.\n" if $p->ping($host);
  414.     $p->close();
  415.  
  416.     $p = Net::Ping->new("icmp");
  417.     foreach $host (@host_array)
  418.     {
  419.         print "$host is ";
  420.         print "NOT " unless $p->ping($host, 2);
  421.         print "reachable.\n";
  422.         sleep(1);
  423.     }
  424.     $p->close();
  425.  
  426.     $p = Net::Ping->new("tcp", 2);
  427.     while ($stop_time > time())
  428.     {
  429.         print "$host not reachable ", scalar(localtime()), "\n"
  430.             unless $p->ping($host);
  431.         sleep(300);
  432.     }
  433.     undef($p);
  434.  
  435.     # For backward compatibility
  436.     print "$host is alive.\n" if pingecho($host);
  437.  
  438. =head1 DESCRIPTION
  439.  
  440. This module contains methods to test the reachability of remote
  441. hosts on a network.  A ping object is first created with optional
  442. parameters, a variable number of hosts may be pinged multiple
  443. times and then the connection is closed.
  444.  
  445. You may choose one of three different protocols to use for the ping.
  446. With the "tcp" protocol the ping() method attempts to establish a
  447. connection to the remote host's echo port.  If the connection is
  448. successfully established, the remote host is considered reachable.  No
  449. data is actually echoed.  This protocol does not require any special
  450. privileges but has higher overhead than the other two protocols.
  451.  
  452. Specifying the "udp" protocol causes the ping() method to send a udp
  453. packet to the remote host's echo port.  If the echoed packet is
  454. received from the remote host and the received packet contains the
  455. same data as the packet that was sent, the remote host is considered
  456. reachable.  This protocol does not require any special privileges.
  457.  
  458. If the "icmp" protocol is specified, the ping() method sends an icmp
  459. echo message to the remote host, which is what the UNIX ping program
  460. does.  If the echoed message is received from the remote host and
  461. the echoed information is correct, the remote host is considered
  462. reachable.  Specifying the "icmp" protocol requires that the program
  463. be run as root or that the program be setuid to root.
  464.  
  465. =head2 Functions
  466.  
  467. =over 4
  468.  
  469. =item Net::Ping->new([$proto [, $def_timeout [, $bytes]]]);
  470.  
  471. Create a new ping object.  All of the parameters are optional.  $proto
  472. specifies the protocol to use when doing a ping.  The current choices
  473. are "tcp", "udp" or "icmp".  The default is "udp".
  474.  
  475. If a default timeout ($def_timeout) in seconds is provided, it is used
  476. when a timeout is not given to the ping() method (below).  The timeout
  477. must be greater than 0 and the default, if not specified, is 5 seconds.
  478.  
  479. If the number of data bytes ($bytes) is given, that many data bytes
  480. are included in the ping packet sent to the remote host. The number of
  481. data bytes is ignored if the protocol is "tcp".  The minimum (and
  482. default) number of data bytes is 1 if the protocol is "udp" and 0
  483. otherwise.  The maximum number of data bytes that can be specified is
  484. 1024.
  485.  
  486. =item $p->ping($host [, $timeout]);
  487.  
  488. Ping the remote host and wait for a response.  $host can be either the
  489. hostname or the IP number of the remote host.  The optional timeout
  490. must be greater than 0 seconds and defaults to whatever was specified
  491. when the ping object was created.  If the hostname cannot be found or
  492. there is a problem with the IP number, undef is returned.  Otherwise,
  493. 1 is returned if the host is reachable and 0 if it is not.  For all
  494. practical purposes, undef and 0 and can be treated as the same case.
  495.  
  496. =item $p->close();
  497.  
  498. Close the network connection for this ping object.  The network
  499. connection is also closed by "undef $p".  The network connection is
  500. automatically closed if the ping object goes out of scope (e.g. $p is
  501. local to a subroutine and you leave the subroutine).
  502.  
  503. =item pingecho($host [, $timeout]);
  504.  
  505. To provide backward compatibility with the previous version of
  506. Net::Ping, a pingecho() subroutine is available with the same
  507. functionality as before.  pingecho() uses the tcp protocol.  The
  508. return values and parameters are the same as described for the ping()
  509. method.  This subroutine is obsolete and may be removed in a future
  510. version of Net::Ping.
  511.  
  512. =back
  513.  
  514. =head1 WARNING
  515.  
  516. pingecho() or a ping object with the tcp protocol use alarm() to
  517. implement the timeout.  So, don't use alarm() in your program while
  518. you are using pingecho() or a ping object with the tcp protocol.  The
  519. udp and icmp protocols do not use alarm() to implement the timeout.
  520.  
  521. =head1 NOTES
  522.  
  523. There will be less network overhead (and some efficiency in your
  524. program) if you specify either the udp or the icmp protocol.  The tcp
  525. protocol will generate 2.5 times or more traffic for each ping than
  526. either udp or icmp.  If many hosts are pinged frequently, you may wish
  527. to implement a small wait (e.g. 25ms or more) between each ping to
  528. avoid flooding your network with packets.
  529.  
  530. The icmp protocol requires that the program be run as root or that it
  531. be setuid to root.  The tcp and udp protocols do not require special
  532. privileges, but not all network devices implement the echo protocol
  533. for tcp or udp.
  534.  
  535. Local hosts should normally respond to pings within milliseconds.
  536. However, on a very congested network it may take up to 3 seconds or
  537. longer to receive an echo packet from the remote host.  If the timeout
  538. is set too low under these conditions, it will appear that the remote
  539. host is not reachable (which is almost the truth).
  540.  
  541. Reachability doesn't necessarily mean that the remote host is actually
  542. functioning beyond its ability to echo packets.
  543.  
  544. Because of a lack of anything better, this module uses its own
  545. routines to pack and unpack ICMP packets.  It would be better for a
  546. separate module to be written which understands all of the different
  547. kinds of ICMP packets.
  548.  
  549. =cut
  550.