From: Jarkko Hietaniemi Date: Tue, 2 Apr 2002 18:35:27 +0000 (+0000) Subject: Upgrade to Net::Ping 2.14. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=e82f584b1535e9978a30a104c8240f49d07f89bd;p=p5sagit%2Fp5-mst-13.2.git Upgrade to Net::Ping 2.14. p4raw-id: //depot/perl@15687 --- diff --git a/MANIFEST b/MANIFEST index 355c5ed..8598a84 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1225,6 +1225,7 @@ lib/Net/Ping/t/120_udp_inst.t Ping Net::Ping lib/Net/Ping/t/130_tcp_inst.t Ping Net::Ping lib/Net/Ping/t/140_stream_inst.t Ping Net::Ping lib/Net/Ping/t/200_ping_tcp.t Ping Net::Ping +lib/Net/Ping/t/250_ping_hires.t Ping Net::Ping lib/Net/Ping/t/300_ping_stream.t Ping Net::Ping lib/Net/POP3.pm libnet lib/Net/protoent.pm By-name interface to Perl's builtin getproto* diff --git a/lib/Net/Ping.pm b/lib/Net/Ping.pm index e81c997..874f1c5 100644 --- a/lib/Net/Ping.pm +++ b/lib/Net/Ping.pm @@ -1,22 +1,22 @@ package Net::Ping; -# $Id: Ping.pm,v 1.17 2002/02/18 01:25:11 rob Exp $ +# $Id: Ping.pm,v 1.27 2002/04/02 02:01:21 rob Exp $ require 5.002; require Exporter; use strict; use vars qw(@ISA @EXPORT $VERSION - $def_timeout $def_proto $max_datasize $pingstring); + $def_timeout $def_proto $max_datasize $pingstring $hires); use FileHandle; use Socket qw( SOCK_DGRAM SOCK_STREAM SOCK_RAW PF_INET - inet_aton sockaddr_in ); + inet_aton inet_ntoa sockaddr_in ); use Carp; use Errno qw(ECONNREFUSED); @ISA = qw(Exporter); @EXPORT = qw(pingecho); -$VERSION = "2.12"; +$VERSION = "2.14"; # Constants @@ -33,13 +33,13 @@ $pingstring = "pingschwingping!\n"; sub pingecho { - my ($host, # Name or IP number of host to ping - $timeout # Optional timeout in seconds - ) = @_; - my ($p); # A ping object + 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 + $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 @@ -51,76 +51,76 @@ sub pingecho 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 "icmp", "udp", "tcp", "stream", or "external"') - unless $proto =~ m/^(icmp|udp|tcp|stream|external)$/; - $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->{"local_addr"} = undef; # Don't bind by default - - $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" || $self->{"proto"} eq "stream") - { - $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); + 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 "icmp", "udp", "tcp", "stream", or "external"') + unless $proto =~ m/^(icmp|udp|tcp|stream|external)$/; + $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->{"local_addr"} = undef; # Don't bind by default + + $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" || $self->{"proto"} eq "stream") + { + $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: Set the local IP address from which pings will be sent. @@ -129,33 +129,50 @@ sub new # opened. Returns non-zero if successful; croaks on error. sub bind { - my ($self, - $local_addr # Name or IP number of local interface - ) = @_; - my ($ip # Packed IP number of $local_addr - ); - - croak("Usage: \$p->bind(\$local_addr)") unless @_ == 2; - croak("already bound") if defined($self->{"local_addr"}) && - ($self->{"proto"} eq "udp" || $self->{"proto"} eq "icmp"); + my ($self, + $local_addr # Name or IP number of local interface + ) = @_; + my ($ip # Packed IP number of $local_addr + ); + + croak("Usage: \$p->bind(\$local_addr)") unless @_ == 2; + croak("already bound") if defined($self->{"local_addr"}) && + ($self->{"proto"} eq "udp" || $self->{"proto"} eq "icmp"); + + $ip = inet_aton($local_addr); + croak("nonexistent local address $local_addr") unless defined($ip); + $self->{"local_addr"} = $ip; # Only used if proto is tcp + + if ($self->{"proto"} eq "udp" || $self->{"proto"} eq "icmp") + { + CORE::bind($self->{"fh"}, sockaddr_in(0, $ip)) || + croak("$self->{'proto'} bind error - $!"); + } + elsif ($self->{"proto"} ne "tcp") + { + croak("Unknown protocol \"$self->{proto}\" in bind()"); + } + + return 1; +} - $ip = inet_aton($local_addr); - croak("nonexistent local address $local_addr") unless defined($ip); - $self->{"local_addr"} = $ip; # Only used if proto is tcp - if ($self->{"proto"} eq "udp" || $self->{"proto"} eq "icmp") - { - CORE::bind($self->{"fh"}, sockaddr_in(0, $ip)) || - croak("$self->{'proto'} bind error - $!"); - } - elsif ($self->{"proto"} ne "tcp") - { - croak("Unknown protocol \"$self->{proto}\" in bind()"); - } +# Description: allows the module to use milliseconds as returned by +# the Time::HiRes module - return 1; +$hires = 0; +sub hires +{ + my $self = shift; + $hires = 1 unless defined + ($hires = ((defined $self) && (ref $self)) ? shift() : $self); + require Time::HiRes if $hires; } +sub time +{ + return $hires ? Time::HiRes::time() : CORE::time(); +} # 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 @@ -164,29 +181,43 @@ sub bind 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? - - # Dispatch to the appropriate routine. - return $self->ping_external($ip, $timeout) if $self->{"proto"} eq "external"; - return $self->ping_udp($ip, $timeout) if $self->{"proto"} eq "udp"; - return $self->ping_icmp($ip, $timeout) if $self->{"proto"} eq "icmp"; - return $self->ping_tcp($ip, $timeout) if $self->{"proto"} eq "tcp"; - return $self->ping_stream($ip, $timeout) if $self->{"proto"} eq "stream"; - + 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 + $ping_time, # When ping began + ); + + 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? + + # Dispatch to the appropriate routine. + $ping_time = &time(); + if ($self->{"proto"} eq "external") { + $ret = $self->ping_external($ip, $timeout); + } + elsif ($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); + } + elsif ($self->{"proto"} eq "stream") { + $ret = $self->ping_stream($ip, $timeout); + } else { croak("Unknown protocol \"$self->{proto}\" in ping()"); + } + + return wantarray ? ($ret, &time() - $ping_time, inet_ntoa($ip)) : $ret; } # Uses Net::Ping::External to do an external ping. @@ -210,82 +241,82 @@ use constant ICMP_PORT => 0; # No port with ICMP sub ping_icmp { - my ($self, - $ip, # Packed IP number of the host - $timeout # Seconds after which ping times out - ) = @_; - - 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(ICMP_PORT, $ip); - send($self->{"fh"}, $msg, ICMP_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 + my ($self, + $ip, # Packed IP number of the host + $timeout # Seconds after which ping times out + ) = @_; + + 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(ICMP_PORT, $ip); + send($self->{"fh"}, $msg, ICMP_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 { - $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, ICMP_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; - } + $ret = undef; + $done = 1; + } + elsif ($nfound) # Got a packet from somewhere + { + $recv_msg = ""; + $from_saddr = recv($self->{"fh"}, $recv_msg, 1500, ICMP_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; + } } - return($ret) + else # Oops, timed out + { + $done = 1; + } + } + return $ret; } # Description: Do a checksum on the message. Basically sum all of @@ -293,25 +324,25 @@ sub ping_icmp 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 + 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 } @@ -327,175 +358,175 @@ sub checksum sub ping_tcp { - my ($self, - $ip, # Packed IP number of the host - $timeout # Seconds after which ping times out - ) = @_; - my ($ret # The return value - ); - - $@ = ""; $! = 0; - $ret = $self -> tcp_connect( $ip, $timeout); - $ret = 1 if $! == ECONNREFUSED # Connection refused - || $@ =~ /Unknown Error/i; # Special Win32 response? - $self->{"fh"}->close(); - return($ret); + my ($self, + $ip, # Packed IP number of the host + $timeout # Seconds after which ping times out + ) = @_; + my ($ret # The return value + ); + + $@ = ""; $! = 0; + $ret = $self -> tcp_connect( $ip, $timeout); + $ret = 1 if $! == ECONNREFUSED # Connection refused + || $@ =~ /Unknown Error/i; # Special Win32 response? + $self->{"fh"}->close(); + return $ret; } sub tcp_connect { - my ($self, - $ip, # Packed IP number of the host - $timeout # Seconds after which connect times out - ) = @_; - my ($saddr); # Packed IP and Port - - $saddr = sockaddr_in($self->{"port_num"}, $ip); - - my $ret = 0; # Default to unreachable - - my $do_socket = sub { - socket($self->{"fh"}, PF_INET, SOCK_STREAM, $self->{"proto_num"}) || - croak("tcp socket error - $!"); - if (defined $self->{"local_addr"} && - !CORE::bind($self->{"fh"}, sockaddr_in(0, $self->{"local_addr"}))) { - croak("tcp bind error - $!"); - } - }; - my $do_connect = sub { - eval { - die $! unless connect($self->{"fh"}, $saddr); - $self->{"ip"} = $ip; - $ret = 1; - }; - $ret; - }; + my ($self, + $ip, # Packed IP number of the host + $timeout # Seconds after which connect times out + ) = @_; + my ($saddr); # Packed IP and Port - if ($^O =~ /Win32/i) { + $saddr = sockaddr_in($self->{"port_num"}, $ip); - # Buggy Winsock API doesn't allow us to use alarm() calls. - # Hence, if our OS is Windows, we need to create a separate - # process to do the blocking connect attempt. + my $ret = 0; # Default to unreachable - $| = 1; # Clear buffer prior to fork to prevent duplicate flushing. - my $pid = fork; - if (!$pid) { - if (!defined $pid) { - # Fork did not work - warn "Win32 Fork error: $!"; - return 0; - } - &{ $do_socket }(); - - # Try a slow blocking connect() call - # and report the status to the pipe. - if ( &{ $do_connect }() ) { - $self->{"fh"}->close(); - # No error - exit 0; - } else { - # Pass the error status to the parent - exit $!; - } + my $do_socket = sub { + socket($self->{"fh"}, PF_INET, SOCK_STREAM, $self->{"proto_num"}) || + croak("tcp socket error - $!"); + if (defined $self->{"local_addr"} && + !CORE::bind($self->{"fh"}, sockaddr_in(0, $self->{"local_addr"}))) { + croak("tcp bind error - $!"); + } + }; + my $do_connect = sub { + eval { + die $! unless connect($self->{"fh"}, $saddr); + $self->{"ip"} = $ip; + $ret = 1; + }; + $ret; + }; + + if ($^O =~ /Win32/i) { + + # Buggy Winsock API doesn't allow us to use alarm() calls. + # Hence, if our OS is Windows, we need to create a separate + # process to do the blocking connect attempt. + + $| = 1; # Clear buffer prior to fork to prevent duplicate flushing. + my $pid = fork; + if (!$pid) { + if (!defined $pid) { + # Fork did not work + warn "Win32 Fork error: $!"; + return 0; } - &{ $do_socket }(); - my $patience = time + $timeout; - - require POSIX; - my ($child); - $? = 0; - # Wait up to the timeout - # And clean off the zombie - do { - $child = waitpid($pid, &POSIX::WNOHANG); - $! = $? >> 8; - $@ = $!; - select(undef, undef, undef, 0.1); - } while time < $patience && $child != $pid; - - if ($child == $pid) { - # Since she finished within the timeout, - # it is probably safe for me to try it too - &{ $do_connect }(); + # Try a slow blocking connect() call + # and report the status to the pipe. + if ( &{ $do_connect }() ) { + $self->{"fh"}->close(); + # No error + exit 0; } else { - # Time must have run out. - $@ = "Timed out!"; - # Put that choking client out of its misery - kill "KILL", $pid; - # Clean off the zombie - waitpid($pid, 0); - $ret = 0; + # Pass the error status to the parent + exit $!; } - } else { # Win32 - # Otherwise don't waste the resources to fork - - &{ $do_socket }(); - - $SIG{'ALRM'} = sub { die "Timed out!"; }; - alarm($timeout); # Interrupt connect() if we have to + } + &{ $do_socket }(); + + my $patience = &time() + $timeout; + + require POSIX; + my ($child); + $? = 0; + # Wait up to the timeout + # And clean off the zombie + do { + $child = waitpid($pid, &POSIX::WNOHANG); + $! = $? >> 8; + $@ = $!; + select(undef, undef, undef, 0.1); + } while &time() < $patience && $child != $pid; + + if ($child == $pid) { + # Since she finished within the timeout, + # it is probably safe for me to try it too &{ $do_connect }(); - alarm(0); + } else { + # Time must have run out. + $@ = "Timed out!"; + # Put that choking client out of its misery + kill "KILL", $pid; + # Clean off the zombie + waitpid($pid, 0); + $ret = 0; } + } else { # Win32 + # Otherwise don't waste the resources to fork + + &{ $do_socket }(); + + $SIG{'ALRM'} = sub { die "Timed out!"; }; + alarm($timeout); # Interrupt connect() if we have to + + &{ $do_connect }(); + alarm(0); + } - return $ret; + return $ret; } # This writes the given string to the socket and then reads it # back. It returns 1 on success, 0 on failure. sub tcp_echo { - my $self = shift; - my $timeout = shift; - my $pingstring = shift; - - my $ret = undef; - my $time = time; - my $wrstr = $pingstring; - my $rdstr = ""; - - eval <<'EOM'; - do { - my $rin = ""; - vec($rin, $self->{"fh"}->fileno(), 1) = 1; - - my $rout = undef; - if($wrstr) { - $rout = ""; - vec($rout, $self->{"fh"}->fileno(), 1) = 1; - } - - if(select($rin, $rout, undef, ($time + $timeout) - time())) { - - if($rout && vec($rout,$self->{"fh"}->fileno(),1)) { - my $num = syswrite($self->{"fh"}, $wrstr); - if($num) { - # If it was a partial write, update and try again. - $wrstr = substr($wrstr,$num); - } else { - # There was an error. - $ret = 0; - } - } - - if(vec($rin,$self->{"fh"}->fileno(),1)) { - my $reply; - if(sysread($self->{"fh"},$reply,length($pingstring)-length($rdstr))) { - $rdstr .= $reply; - $ret = 1 if $rdstr eq $pingstring; - } else { - # There was an error. - $ret = 0; - } - } - - } - } until time() > ($time + $timeout) || defined($ret); + my $self = shift; + my $timeout = shift; + my $pingstring = shift; + + my $ret = undef; + my $time = &time(); + my $wrstr = $pingstring; + my $rdstr = ""; + + eval <<'EOM'; + do { + my $rin = ""; + vec($rin, $self->{"fh"}->fileno(), 1) = 1; + + my $rout = undef; + if($wrstr) { + $rout = ""; + vec($rout, $self->{"fh"}->fileno(), 1) = 1; + } + + if(select($rin, $rout, undef, ($time + $timeout) - &time())) { + + if($rout && vec($rout,$self->{"fh"}->fileno(),1)) { + my $num = syswrite($self->{"fh"}, $wrstr); + if($num) { + # If it was a partial write, update and try again. + $wrstr = substr($wrstr,$num); + } else { + # There was an error. + $ret = 0; + } + } + + if(vec($rin,$self->{"fh"}->fileno(),1)) { + my $reply; + if(sysread($self->{"fh"},$reply,length($pingstring)-length($rdstr))) { + $rdstr .= $reply; + $ret = 1 if $rdstr eq $pingstring; + } else { + # There was an error. + $ret = 0; + } + } + + } + } until &time() > ($time + $timeout) || defined($ret); EOM - return $ret; + return $ret; } @@ -507,20 +538,20 @@ EOM sub ping_stream { - my ($self, - $ip, # Packed IP number of the host - $timeout # Seconds after which ping times out - ) = @_; - - # Open the stream if it's not already open - if(!defined $self->{"fh"}->fileno()) { - $self->tcp_connect($ip, $timeout) or return 0; - } + my ($self, + $ip, # Packed IP number of the host + $timeout # Seconds after which ping times out + ) = @_; - croak "tried to switch servers while stream pinging" - if $self->{"ip"} ne $ip; + # Open the stream if it's not already open + if(!defined $self->{"fh"}->fileno()) { + $self->tcp_connect($ip, $timeout) or return 0; + } - return $self->tcp_echo($timeout, $pingstring); + croak "tried to switch servers while stream pinging" + if $self->{"ip"} ne $ip; + + return $self->tcp_echo($timeout, $pingstring); } # Description: opens the stream. You would do this if you want to @@ -528,22 +559,22 @@ sub ping_stream sub open { - my ($self, - $host, # Host or IP address - $timeout # Seconds after which open times out - ) = @_; - - my ($ip); # Packed IP number of the host - $ip = inet_aton($host); - $timeout = $self->{"timeout"} unless $timeout; - - if($self->{"proto"} eq "stream") { - if(defined($self->{"fh"}->fileno())) { - croak("socket is already open"); - } else { - $self->tcp_connect($ip, $timeout); - } + my ($self, + $host, # Host or IP address + $timeout # Seconds after which open times out + ) = @_; + + my ($ip); # Packed IP number of the host + $ip = inet_aton($host); + $timeout = $self->{"timeout"} unless $timeout; + + if($self->{"proto"} eq "stream") { + if(defined($self->{"fh"}->fileno())) { + croak("socket is already open"); + } else { + $self->tcp_connect($ip, $timeout); } + } } @@ -558,64 +589,67 @@ use constant UDP_FLAGS => 0; # Nothing special on send or recv sub ping_udp { - 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 - $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, UDP_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) + 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 + $msg, # Message to be echoed + $finish_time, # Time ping should be finished + $ping_time, # Time ping took to complete + $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, UDP_FLAGS, $saddr); # Send it + + $rbits = ""; + vec($rbits, $self->{"fh"}->fileno(), 1) = 1; + $ret = 0; # Default to unreachable + $done = 0; + $ping_time = $timeout; + $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 { - $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, UDP_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; - } + $ret = undef; + $done = 1; } - return($ret); + elsif ($nfound) # A packet is waiting + { + $from_msg = ""; + $from_saddr = recv($self->{"fh"}, $from_msg, 1500, UDP_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; + } + } + $ping_time -= $timeout; + return wantarray ? ($ret, $ping_time) : $ret; } # Description: Close the connection unless we are using the tcp @@ -623,9 +657,9 @@ sub ping_udp sub close { - my ($self) = @_; + my ($self) = @_; - $self->{"fh"}->close() unless $self->{"proto"} eq "tcp"; + $self->{"fh"}->close() unless $self->{"proto"} eq "tcp"; } @@ -636,7 +670,7 @@ __END__ Net::Ping - check a remote host for reachability -$Id: Ping.pm,v 1.17 2002/02/18 01:25:11 rob Exp $ +$Id: Ping.pm,v 1.27 2002/04/02 02:01:21 rob Exp $ =head1 SYNOPSIS @@ -668,6 +702,14 @@ $Id: Ping.pm,v 1.17 2002/02/18 01:25:11 rob Exp $ } undef($p); + # High precision syntax (requires Time::HiRes) + $p = Net::Ping->new(); + $p->hires(); + ($ret, $duration, $ip) = $p->ping($host, 5.5); + printf("$host [ip: $ip] is alive (packet return time: %.2f ms)\n", 1000 * $duration) + if $ret; + $p->close(); + # For backward compatibility print "$host is alive.\n" if pingecho($host); @@ -734,6 +776,11 @@ 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->hires( { 0 | 1 } ); + +Causes this module to use Time::HiRes module, allowing milliseconds +to be returned by subsequent calls to ping(). + =item $p->bind($local_addr); Sets the source address from which pings will be sent. This must be @@ -753,21 +800,14 @@ object. 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->open($host); - -When you are using the stream protocol, this call pre-opens the -tcp socket. It's only necessary to do this if you want to -provide a different timeout when creating the connection, or -remove the overhead of establishing the connection from the -first ping. If you don't call C, the connection is -automatically opened the first time C is called. -This call simply does nothing if you are using any protocol other -than stream. +when the ping object was created. Returns a success flag. If the +hostname cannot be found or there is a problem with the IP number, the +success flag returned will be undef. Otherwise, the success flag will +be 1 if the host is reachable and 0 if it is not. For most practical +purposes, undef and 0 and can be treated as the same case. In array +context, the elapsed time is also returned. The elapsed time value will +be a float, as retuned by the Time::HiRes::time() function, if hires() +has been previously called, otherwise it is returned as an integer. =item $p->open($host); @@ -836,10 +876,12 @@ kinds of ICMP packets. =head1 AUTHORS - Current maintainers: - colinm@cpan.org (Colin McMillen) + Current maintainer: bbb@cpan.org (Rob Brown) + External protocol: + colinm@cpan.org (Colin McMillen) + Stream protocol: bronson@trestle.com (Scott Bronson) @@ -852,9 +894,9 @@ kinds of ICMP packets. =head1 COPYRIGHT -Copyright (c) 2001, Colin McMillen. All rights reserved. +Copyright (c) 2002, Rob Brown. All rights reserved. -Copyright (c) 2001, Rob Brown. All rights reserved. +Copyright (c) 2001, Colin McMillen. All rights reserved. This program is free software; you may redistribute it and/or modify it under the same terms as Perl itself. diff --git a/lib/Net/Ping/CHANGES b/lib/Net/Ping/CHANGES index 172692d..4fb091a 100644 --- a/lib/Net/Ping/CHANGES +++ b/lib/Net/Ping/CHANGES @@ -1,6 +1,17 @@ CHANGES ------- +2.14 Apr 01 14:00 2002 + - Added reverse lookup feature. + e@arix.com (Erick Calder) + +2.13 Apr 01 14:00 2002 + - Added ping time measuring feature. + e@arix.com (Erick Calder) + - Optionally allow for high resolution + precision for timeouts and measuring + using the Time::HiRes module (Erick). + 2.12 Feb 17 19:00 2002 - More general error determination for better cross platform consistency and diff --git a/lib/Net/Ping/README b/lib/Net/Ping/README index 5e7d055..68a3631 100644 --- a/lib/Net/Ping/README +++ b/lib/Net/Ping/README @@ -1,7 +1,7 @@ NAME Net::Ping - check a remote host for reachability - $Id: Ping.pm,v 1.17 2002/02/18 01:25:11 rob Exp $ + $Id: Ping.pm,v 1.27 2002/04/02 02:01:21 rob Exp $ SYNOPSIS use Net::Ping; @@ -32,6 +32,14 @@ SYNOPSIS } undef($p); + # High precision syntax (requires Time::HiRes) + $p = Net::Ping->new(); + $p->hires(); + ($ret, $duration, $ip) = $p->ping($host, 5.5); + printf("$host [ip: $ip] is alive (packet return time: %.2f ms)\n", 1000 * $duration) + if $ret; + $p->close(); + # For backward compatibility print "$host is alive.\n" if pingecho($host); @@ -94,6 +102,10 @@ DESCRIPTION otherwise. The maximum number of data bytes that can be specified is 1024. + $p->hires( { 0 | 1 } ); + Causes this module to use Time::HiRes module, allowing milliseconds + to be returned by subsequent calls to ping(). + $p->bind($local_addr); Sets the source address from which pings will be sent. This must be the address of one of the interfaces on the local host. $local_addr @@ -111,20 +123,15 @@ DESCRIPTION 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. - - $p->open($host); - When you are using the stream protocol, this call pre-opens the tcp - socket. It's only necessary to do this if you want to provide a - different timeout when creating the connection, or remove the - overhead of establishing the connection from the first ping. If you - don't call `open()', the connection is automatically opened the - first time `ping()' is called. This call simply does nothing if you - are using any protocol other than stream. + specified when the ping object was created. Returns a success flag. + If the hostname cannot be found or there is a problem with the IP + number, the success flag returned will be undef. Otherwise, the + success flag will be 1 if the host is reachable and 0 if it is not. + For most practical purposes, undef and 0 and can be treated as the + same case. In array context, the elapsed time is also returned. The + elapsed time value will be a float, as retuned by the + Time::HiRes::time() function, if hires() has been previously called, + otherwise it is returned as an integer. $p->open($host); When you are using the stream protocol, this call pre-opens the tcp @@ -184,10 +191,12 @@ NOTES ICMP packets. AUTHORS - Current maintainers: - colinm@cpan.org (Colin McMillen) + Current maintainer: bbb@cpan.org (Rob Brown) + External protocol: + colinm@cpan.org (Colin McMillen) + Stream protocol: bronson@trestle.com (Scott Bronson) @@ -199,9 +208,9 @@ AUTHORS mose@ns.ccsn.edu (Russell Mosemann) COPYRIGHT - Copyright (c) 2001, Colin McMillen. All rights reserved. + Copyright (c) 2002, Rob Brown. All rights reserved. - Copyright (c) 2001, Rob Brown. All rights reserved. + Copyright (c) 2001, Colin McMillen. All rights reserved. This program is free software; you may redistribute it and/or modify it under the same terms as Perl itself. diff --git a/lib/Net/Ping/t/130_tcp_inst.t b/lib/Net/Ping/t/130_tcp_inst.t index 00be5af..e2efb8c 100644 --- a/lib/Net/Ping/t/130_tcp_inst.t +++ b/lib/Net/Ping/t/130_tcp_inst.t @@ -5,7 +5,7 @@ BEGIN { print "1..0 \# Skip: no Socket\n"; exit; } - unless (getservbyname('echo', 'udp')) { + unless (getservbyname('echo', 'tcp')) { print "1..0 \# Skip: no echo port\n"; exit; } diff --git a/lib/Net/Ping/t/140_stream_inst.t b/lib/Net/Ping/t/140_stream_inst.t index 626b2e1..4492332 100644 --- a/lib/Net/Ping/t/140_stream_inst.t +++ b/lib/Net/Ping/t/140_stream_inst.t @@ -5,7 +5,7 @@ BEGIN { print "1..0 \# Skip: no Socket\n"; exit; } - unless (getservbyname('echo', 'udp')) { + unless (getservbyname('echo', 'tcp')) { print "1..0 \# Skip: no echo port\n"; exit; } diff --git a/lib/Net/Ping/t/250_ping_hires.t b/lib/Net/Ping/t/250_ping_hires.t new file mode 100644 index 0000000..52dae1b --- /dev/null +++ b/lib/Net/Ping/t/250_ping_hires.t @@ -0,0 +1,61 @@ +# Test to make sure hires feature works. + +BEGIN { + if ($ENV{PERL_CORE}) { + unless ($ENV{PERL_TEST_Net_Ping}) { + print "1..0 # Skip: network dependent test\n"; + exit; + } + chdir 't' if -d 't'; + @INC = qw(../lib); + } + unless (eval "require Socket") { + print "1..0 \# Skip: no Socket\n"; + exit; + } + unless (eval "require Time::HiRes") { + print "1..0 \# Skip: no Time::HiRes\n"; + exit; + } + unless (getservbyname('echo', 'tcp')) { + print "1..0 \# Skip: no echo port\n"; + exit; + } +} + +use Test; +use Net::Ping; +plan tests => 8; + +# Everything loaded fine +ok 1; + +my $p = new Net::Ping "tcp"; + +# new() worked? +ok !!$p; + +# Default is to not use Time::HiRes +ok !$Net::Ping::hires; + +# Enable hires +$p -> hires(); +ok $Net::Ping::hires; + +# Make sure disable works +$p -> hires(0); +ok !$Net::Ping::hires; + +# Enable again +$p -> hires(1); +ok $Net::Ping::hires; + +# Test on the default port +my ($ret, $duration) = $p -> ping("localhost"); + +# localhost should always be reachable, right? +ok $ret; + +# It is extremely likely that the duration contains a decimal +# point if Time::HiRes is functioning properly. +ok $duration =~ /\./;