X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FNet%2FPing.pm;h=5f2545fccab69590a3579fdd80e6c77e65bcac5a;hb=3226bbec67a495e52de65a4d7ece19d720e5f94d;hp=a2846fe902101b6ba7293c6968f139cc1f8c7fae;hpb=4d69506c2d1d71db8d32dc38aa9aa6beb5cd8d07;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/Net/Ping.pm b/lib/Net/Ping.pm index a2846fe..5f2545f 100644 --- a/lib/Net/Ping.pm +++ b/lib/Net/Ping.pm @@ -1,20 +1,13 @@ 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; +# $Id: Ping.pm,v 1.5 2001/11/19 09:44:18 rob Exp $ + +require 5.002; require Exporter; use strict; -our(@ISA, @EXPORT, $VERSION, $def_timeout, $def_proto, $max_datasize); +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 ); @@ -22,7 +15,7 @@ use Carp; @ISA = qw(Exporter); @EXPORT = qw(pingecho); -$VERSION = 2.02; +$VERSION = 2.06; # Constants @@ -105,7 +98,7 @@ sub new } elsif ($self->{"proto"} eq "icmp") { - croak("icmp ping requires root privilege") if ($> and $^O ne 'VMS'); + 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 @@ -128,7 +121,7 @@ sub new # 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 +# perform the specific ping method based on the protocol. Return the # result of the ping. sub ping @@ -269,13 +262,13 @@ sub checksum ); $len_msg = length($msg); - $num_short = int($len_msg / 2); + $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)) << 8) if $len_msg % 2; + $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 } @@ -299,20 +292,21 @@ sub ping_tcp 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); + eval { + die $! unless connect($self->{"fh"}, $saddr); $ret = 1; -EOM + }; alarm(0); + $ret = 1 if $@ =~ /connection refused/i; $self->{"fh"}->close(); return($ret); } @@ -369,24 +363,23 @@ sub ping_udp 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; - } - } + $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. @@ -406,6 +399,8 @@ __END__ Net::Ping - check a remote host for reachability +$Id: Ping.pm,v 1.5 2001/11/19 09:44:18 rob Exp $ + =head1 SYNOPSIS use Net::Ping; @@ -425,6 +420,8 @@ Net::Ping - check a remote host for reachability $p->close(); $p = Net::Ping->new("tcp", 2); + # Try connecting to the www port instead of the echo port + $p->{port_num} = getservbyname("http", "tcp"); while ($stop_time > time()) { print "$host not reachable ", scalar(localtime()), "\n" @@ -443,11 +440,7 @@ 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. - +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 @@ -460,11 +453,6 @@ 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 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 @@ -556,4 +544,26 @@ 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. +=head1 AUTHOR(S) + + Original pingecho(): + Andreas Karrer (karrer@bernina.ethz.ch) + Paul Marquess (pmarquess@bfsec.bt.co.uk) + + Net::Ping base code: + Russell Mosemann (mose@ns.ccsn.edu) + + Compatibility porting so ping_tcp() + can work with most remote systems: + Rob Brown (rob@roobik.com) + +=head1 COPYRIGHT + +Copyright (c) 2001 Rob Brown. All rights reserved. + +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. + =cut