package Net::Ping;
-# $Id: Ping.pm,v 1.33 2002/10/19 05:02:43 rob Exp $
-
require 5.002;
require Exporter;
use strict;
use vars qw(@ISA @EXPORT $VERSION
- $def_timeout $def_proto $max_datasize $pingstring $hires $source_verify $syn_forking);
+ $def_timeout $def_proto $def_factor
+ $max_datasize $pingstring $hires $source_verify $syn_forking);
use Fcntl qw( F_GETFL F_SETFL O_NONBLOCK );
-use Socket qw( SOCK_DGRAM SOCK_STREAM SOCK_RAW PF_INET SOL_SOCKET
+use Socket qw( SOCK_DGRAM SOCK_STREAM SOCK_RAW PF_INET SOL_SOCKET SO_ERROR
inet_aton inet_ntoa sockaddr_in );
-use POSIX qw( ECONNREFUSED EINPROGRESS WNOHANG );
+use POSIX qw( ENOTCONN ECONNREFUSED ECONNRESET EINPROGRESS EWOULDBLOCK EAGAIN WNOHANG );
use FileHandle;
use Carp;
@ISA = qw(Exporter);
@EXPORT = qw(pingecho);
-$VERSION = "2.23";
+$VERSION = "2.31_04";
+
+sub SOL_IP { 0; };
+sub IP_TOS { 1; };
# Constants
$def_timeout = 5; # Default timeout to wait for a reply
$def_proto = "tcp"; # Default protocol to use for pinging
+$def_factor = 1.2; # Default exponential backoff rate.
$max_datasize = 1024; # Maximum data bytes in a packet
# The data we exchange with the server for the stream protocol
$pingstring = "pingschwingping!\n";
if ($^O =~ /Win32/i) {
# Hack to avoid this Win32 spewage:
# Your vendor has not defined POSIX macro ECONNREFUSED
- *ECONNREFUSED = sub {10061;}; # "Unknown Error" Special Win32 Response?
- $syn_forking = 1;
+ *ECONNREFUSED = sub() {10061;}; # "Unknown Error" Special Win32 Response?
+ *ENOTCONN = sub() {10057;};
+ *ECONNRESET = sub() {10054;};
+ *EINPROGRESS = sub() {10036;};
+ *EWOULDBLOCK = sub() {10035;};
+# $syn_forking = 1; # XXX possibly useful in < Win2K ?
};
# h2ph "asm/socket.h"
$timeout, # Optional timeout in seconds
$data_size, # Optional additional bytes of data
$device, # Optional device to use
+ $tos, # Optional ToS to set
) = @_;
my $class = ref($this) || $this;
my $self = {};
$self->{"device"} = $device;
+ $self->{"tos"} = $tos;
+
$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")
}
$self->{"local_addr"} = undef; # Don't bind by default
-
- $self->{"tcp_econnrefused"} = undef; # Default Connection refused behavior
+ $self->{"retrans"} = $def_factor; # Default exponential backoff rate
+ $self->{"econnrefused"} = undef; # Default Connection refused behavior
$self->{"seq"} = 0; # For counting packets
if ($self->{"proto"} eq "udp") # Open a socket
setsockopt($self->{"fh"}, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'}))
or croak "error binding to device $self->{'device'} $!";
}
+ if ($self->{'tos'}) {
+ setsockopt($self->{"fh"}, SOL_IP, IP_TOS(), pack("I*", $self->{'tos'}))
+ or croak "error configuring tos to $self->{'tos'} $!";
+ }
}
elsif ($self->{"proto"} eq "icmp")
{
setsockopt($self->{"fh"}, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'}))
or croak "error binding to device $self->{'device'} $!";
}
+ if ($self->{'tos'}) {
+ setsockopt($self->{"fh"}, SOL_IP, IP_TOS(), pack("I*", $self->{'tos'}))
+ or croak "error configuring tos to $self->{'tos'} $!";
+ }
}
elsif ($self->{"proto"} eq "tcp" || $self->{"proto"} eq "stream")
{
$self->{"fork_wr"} = FileHandle->new();
pipe($self->{"fork_rd"}, $self->{"fork_wr"});
$self->{"fh"} = FileHandle->new();
+ $self->{"good"} = {};
+ $self->{"bad"} = {};
} else {
$self->{"wbits"} = "";
$self->{"bad"} = {};
CORE::bind($self->{"fh"}, sockaddr_in(0, $ip)) ||
croak("$self->{'proto'} bind error - $!");
}
- elsif ($self->{"proto"} ne "tcp")
+ elsif (($self->{"proto"} ne "tcp") && ($self->{"proto"} ne "syn"))
{
croak("Unknown protocol \"$self->{proto}\" in bind()");
}
return 1;
}
+# Description: A select() wrapper that compensates for platform
+# peculiarities.
+sub mselect
+{
+ if ($_[3] > 0 and $^O eq 'MSWin32') {
+ # On windows, select() doesn't process the message loop,
+ # but sleep() will, allowing alarm() to interrupt the latter.
+ # So we chop up the timeout into smaller pieces and interleave
+ # select() and sleep() calls.
+ my $t = $_[3];
+ my $gran = 0.5; # polling granularity in seconds
+ my @args = @_;
+ while (1) {
+ $gran = $t if $gran > $t;
+ my $nfound = select($_[0], $_[1], $_[2], $gran);
+ undef $nfound if $nfound == -1;
+ $t -= $gran;
+ return $nfound if $nfound or !defined($nfound) or $t <= 0;
+
+ sleep(0);
+ ($_[0], $_[1], $_[2]) = @args;
+ }
+ }
+ else {
+ my $nfound = select($_[0], $_[1], $_[2], $_[3]);
+ undef $nfound if $nfound == -1;
+ return $nfound;
+ }
+}
-# Description: Allow UDP source endpoint comparision to be
+# Description: Allow UDP source endpoint comparison to be
# skipped for those remote interfaces that do
# not response from the same endpoint.
($source_verify = ((defined $self) && (ref $self)) ? shift() : $self);
}
-# Description: Set whether or not the tcp connect
-# behavior should enforce remote service availability
-# as well as reachability.
+# Description: Set whether or not the connect
+# behavior should enforce remote service
+# availability as well as reachability.
+
+sub service_check
+{
+ my $self = shift;
+ $self->{"econnrefused"} = 1 unless defined
+ ($self->{"econnrefused"} = shift());
+}
sub tcp_service_check
{
+ service_check(@_);
+}
+
+# Description: Set exponential backoff for retransmission.
+# Should be > 1 to retain exponential properties.
+# If set to 0, retransmissions are disabled.
+
+sub retrans
+{
my $self = shift;
- $self->{"tcp_econnrefused"} = 1 unless defined
- ($self->{"tcp_econnrefused"} = shift());
+ $self->{"retrans"} = shift;
}
# Description: allows the module to use milliseconds as returned by
return $hires ? Time::HiRes::time() : CORE::time();
}
+# Description: Sets or clears the O_NONBLOCK flag on a file handle.
+sub socket_blocking_mode
+{
+ my ($self,
+ $fh, # the file handle whose flags are to be modified
+ $block) = @_; # if true then set the blocking
+ # mode (clear O_NONBLOCK), otherwise
+ # set the non-blocking mode (set O_NONBLOCK)
+
+ my $flags;
+ if ($^O eq 'MSWin32' || $^O eq 'VMS') {
+ # FIONBIO enables non-blocking sockets on windows and vms.
+ # FIONBIO is (0x80000000|(4<<16)|(ord('f')<<8)|126), as per winsock.h, ioctl.h
+ my $f = 0x8004667e;
+ my $v = pack("L", $block ? 0 : 1);
+ ioctl($fh, $f, $v) or croak("ioctl failed: $!");
+ return;
+ }
+ if ($flags = fcntl($fh, F_GETFL, 0)) {
+ $flags = $block ? ($flags & ~O_NONBLOCK) : ($flags | O_NONBLOCK);
+ if (!fcntl($fh, F_SETFL, $flags)) {
+ croak("fcntl F_SETFL: $!");
+ }
+ } else {
+ croak("fcntl F_GETFL: $!");
+ }
+}
+
# 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
croak("Timeout must be greater than 0 seconds") if $timeout <= 0;
$ip = inet_aton($host);
- return(undef) unless defined($ip); # Does host exist?
+ return () unless defined($ip); # Does host exist?
# Dispatch to the appropriate routine.
$ping_time = &time();
return Net::Ping::External::ping(ip => $ip, timeout => $timeout);
}
-use constant ICMP_ECHOREPLY => 0; # ICMP packet types
-use constant ICMP_ECHO => 8;
-use constant ICMP_STRUCT => "C2 S3 A"; # Structure of a minimal ICMP packet
-use constant SUBCODE => 0; # No ICMP subcode for ECHO and ECHOREPLY
-use constant ICMP_FLAGS => 0; # No special flags for send or recv
-use constant ICMP_PORT => 0; # No port with ICMP
+use constant ICMP_ECHOREPLY => 0; # ICMP packet types
+use constant ICMP_UNREACHABLE => 3; # ICMP packet types
+use constant ICMP_ECHO => 8;
+use constant ICMP_STRUCT => "C2 n3 A"; # Structure of a minimal ICMP packet
+use constant SUBCODE => 0; # No ICMP subcode for ECHO and ECHOREPLY
+use constant ICMP_FLAGS => 0; # No special flags for send or recv
+use constant ICMP_PORT => 0; # No port with ICMP
sub ping_icmp
{
$checksum, $self->{"pid"}, $self->{"seq"}, $self->{"data"});
$len_msg = length($msg);
$saddr = sockaddr_in(ICMP_PORT, $ip);
+ $self->{"from_ip"} = undef;
+ $self->{"from_type"} = undef;
+ $self->{"from_subcode"} = undef;
send($self->{"fh"}, $msg, ICMP_FLAGS, $saddr); # Send the message
$rbits = "";
$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
+ $nfound = mselect((my $rout=$rbits), undef, undef, $timeout); # Wait for packet
$timeout = $finish_time - &time(); # Get remaining time
if (!defined($nfound)) # Hmm, a strange error
{
elsif ($nfound) # Got a packet from somewhere
{
$recv_msg = "";
+ $from_pid = -1;
+ $from_seq = -1;
$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) &&
- (!$source_verify || $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;
+ ($from_type, $from_subcode) = unpack("C2", substr($recv_msg, 20, 2));
+ if ($from_type == ICMP_ECHOREPLY) {
+ ($from_pid, $from_seq) = unpack("n3", substr($recv_msg, 24, 4))
+ if length $recv_msg >= 28;
+ } else {
+ ($from_pid, $from_seq) = unpack("n3", substr($recv_msg, 52, 4))
+ if length $recv_msg >= 56;
}
- }
- else # Oops, timed out
- {
+ $self->{"from_ip"} = $from_ip;
+ $self->{"from_type"} = $from_type;
+ $self->{"from_subcode"} = $from_subcode;
+ if (($from_pid == $self->{"pid"}) && # Does the packet check out?
+ ($from_seq == $self->{"seq"})) {
+ if ($from_type == ICMP_ECHOREPLY) {
+ $ret = 1;
+ $done = 1;
+ } elsif ($from_type == ICMP_UNREACHABLE) {
+ $done = 1;
+ }
+ }
+ } else { # Oops, timed out
$done = 1;
}
}
return $ret;
}
+sub icmp_result {
+ my ($self) = @_;
+ my $ip = $self->{"from_ip"} || "";
+ $ip = "\0\0\0\0" unless 4 == length $ip;
+ return (inet_ntoa($ip),($self->{"from_type"} || 0), ($self->{"from_subcode"} || 0));
+}
+
# 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.
$len_msg = length($msg);
$num_short = int($len_msg / 2);
$chk = 0;
- foreach $short (unpack("S$num_short", $msg))
+ foreach $short (unpack("n$num_short", $msg))
{
$chk += $short;
} # Add the odd byte in
my ($ret # The return value
);
- $@ = ""; $! = 0;
+ $! = 0;
$ret = $self -> tcp_connect( $ip, $timeout);
- if (!$self->{"tcp_econnrefused"} &&
+ if (!$self->{"econnrefused"} &&
$! == ECONNREFUSED) {
$ret = 1; # "Connection refused" means reachable
}
setsockopt($self->{"fh"}, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'}))
or croak("error binding to device $self->{'device'} $!");
}
+ if ($self->{'tos'}) {
+ setsockopt($self->{"fh"}, SOL_IP, IP_TOS(), pack("I*", $self->{'tos'}))
+ or croak "error configuring tos to $self->{'tos'} $!";
+ }
};
my $do_connect = sub {
- eval {
- die $! unless connect($self->{"fh"}, $saddr);
- $self->{"ip"} = $ip;
- $ret = 1;
- };
- $ret;
+ $self->{"ip"} = $ip;
+ # ECONNREFUSED is 10061 on MSWin32. If we pass it as child error through $?,
+ # we'll get (10061 & 255) = 77, so we cannot check it in the parent process.
+ return ($ret = connect($self->{"fh"}, $saddr) || ($! == ECONNREFUSED && !$self->{"econnrefused"}));
};
+ my $do_connect_nb = sub {
+ # Set O_NONBLOCK property on filehandle
+ $self->socket_blocking_mode($self->{"fh"}, 0);
+
+ # start the connection attempt
+ if (!connect($self->{"fh"}, $saddr)) {
+ if ($! == ECONNREFUSED) {
+ $ret = 1 unless $self->{"econnrefused"};
+ } elsif ($! != EINPROGRESS && ($^O ne 'MSWin32' || $! != EWOULDBLOCK)) {
+ # EINPROGRESS is the expected error code after a connect()
+ # on a non-blocking socket. But if the kernel immediately
+ # determined that this connect() will never work,
+ # Simply respond with "unreachable" status.
+ # (This can occur on some platforms with errno
+ # EHOSTUNREACH or ENETUNREACH.)
+ return 0;
+ } else {
+ # Got the expected EINPROGRESS.
+ # Just wait for connection completion...
+ my ($wbits, $wout, $wexc);
+ $wout = $wexc = $wbits = "";
+ vec($wbits, $self->{"fh"}->fileno, 1) = 1;
+
+ my $nfound = mselect(undef,
+ ($wout = $wbits),
+ ($^O eq 'MSWin32' ? ($wexc = $wbits) : undef),
+ $timeout);
+ warn("select: $!") unless defined $nfound;
+
+ if ($nfound && vec($wout, $self->{"fh"}->fileno, 1)) {
+ # the socket is ready for writing so the connection
+ # attempt completed. test whether the connection
+ # attempt was successful or not
+
+ if (getpeername($self->{"fh"})) {
+ # Connection established to remote host
+ $ret = 1;
+ } else {
+ # TCP ACK will never come from this host
+ # because there was an error connecting.
- if ($^O =~ /Win32/i) {
+ # This should set $! to the correct error.
+ my $char;
+ sysread($self->{"fh"},$char,1);
+ $! = ECONNREFUSED if ($! == EAGAIN && $^O =~ /cygwin/i);
- # Buggy Winsock API doesn't allow us to use alarm() calls.
+ $ret = 1 if (!$self->{"econnrefused"}
+ && $! == ECONNREFUSED);
+ }
+ } else {
+ # the connection attempt timed out (or there were connect
+ # errors on Windows)
+ if ($^O =~ 'MSWin32') {
+ # If the connect will fail on a non-blocking socket,
+ # winsock reports ECONNREFUSED as an exception, and we
+ # need to fetch the socket-level error code via getsockopt()
+ # instead of using the thread-level error code that is in $!.
+ if ($nfound && vec($wexc, $self->{"fh"}->fileno, 1)) {
+ $! = unpack("i", getsockopt($self->{"fh"}, SOL_SOCKET,
+ SO_ERROR));
+ }
+ }
+ }
+ }
+ } else {
+ # Connection established to remote host
+ $ret = 1;
+ }
+
+ # Unset O_NONBLOCK property on filehandle
+ $self->socket_blocking_mode($self->{"fh"}, 1);
+ $self->{"ip"} = $ip;
+ return $ret;
+ };
+
+ if ($syn_forking) {
+ # Buggy Winsock API doesn't allow nonblocking connect.
# Hence, if our OS is Windows, we need to create a separate
# process to do the blocking connect attempt.
+ # XXX Above comments are not true at least for Win2K, where
+ # nonblocking connect works.
$| = 1; # Clear buffer prior to fork to prevent duplicate flushing.
- my $pid = fork;
- if (!$pid) {
- if (!defined $pid) {
+ $self->{'tcp_chld'} = fork;
+ if (!$self->{'tcp_chld'}) {
+ if (!defined $self->{'tcp_chld'}) {
# Fork did not work
- warn "Win32 Fork error: $!";
+ warn "Fork error: $!";
return 0;
}
&{ $do_socket }();
# Try a slow blocking connect() call
- # and report the status to the pipe.
+ # and report the status to the parent.
if ( &{ $do_connect }() ) {
$self->{"fh"}->close();
# No error
exit 0;
} else {
# Pass the error status to the parent
- exit $!;
+ # Make sure that $! <= 255
+ exit($! <= 255 ? $! : 255);
}
}
my $patience = &time() + $timeout;
- my ($child);
- $? = 0;
+ my ($child, $child_errno);
+ $? = 0; $child_errno = 0;
# Wait up to the timeout
# And clean off the zombie
do {
- $child = waitpid($pid, &WNOHANG());
- $! = $? >> 8;
- $@ = $!;
+ $child = waitpid($self->{'tcp_chld'}, &WNOHANG());
+ $child_errno = $? >> 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 }();
+ } while &time() < $patience && $child != $self->{'tcp_chld'};
+
+ if ($child == $self->{'tcp_chld'}) {
+ if ($self->{"proto"} eq "stream") {
+ # We need the socket connected here, in parent
+ # Should be safe to connect because the child finished
+ # within the timeout
+ &{ $do_connect }();
+ }
+ # $ret cannot be set by the child process
+ $ret = !$child_errno;
} else {
# Time must have run out.
- $@ = "Timed out!";
# Put that choking client out of its misery
- kill "KILL", $pid;
+ kill "KILL", $self->{'tcp_chld'};
# Clean off the zombie
- waitpid($pid, 0);
+ waitpid($self->{'tcp_chld'}, 0);
$ret = 0;
}
- } else { # Win32
+ delete $self->{'tcp_chld'};
+ $! = $child_errno;
+ } else {
# Otherwise don't waste the resources to fork
&{ $do_socket }();
- local $SIG{'ALRM'} = sub { die "Timed out!"; };
- my $old = alarm($timeout); # Interrupt connect() if we have to
-
- &{ $do_connect }();
- alarm($old);
+ &{ $do_connect_nb }();
}
return $ret;
}
+sub DESTROY {
+ my $self = shift;
+ if ($self->{'proto'} eq 'tcp' &&
+ $self->{'tcp_chld'}) {
+ # Put that choking client out of its misery
+ kill "KILL", $self->{'tcp_chld'};
+ # Clean off the zombie
+ waitpid($self->{'tcp_chld'}, 0);
+ }
+}
+
# This writes the given string to the socket and then reads it
# back. It returns 1 on success, 0 on failure.
sub tcp_echo
vec($rout, $self->{"fh"}->fileno(), 1) = 1;
}
- if(select($rin, $rout, undef, ($time + $timeout) - &time())) {
+ if(mselect($rin, $rout, undef, ($time + $timeout) - &time())) {
if($rout && vec($rout,$self->{"fh"}->fileno(),1)) {
- my $num = syswrite($self->{"fh"}, $wrstr);
+ my $num = syswrite($self->{"fh"}, $wrstr, length $wrstr);
if($num) {
# If it was a partial write, update and try again.
$wrstr = substr($wrstr,$num);
# of time. Return the result of our efforts.
use constant UDP_FLAGS => 0; # Nothing special on send or recv
-
sub ping_udp
{
my ($self,
$ret, # The return value
$msg, # Message to be echoed
$finish_time, # Time ping should be finished
+ $flush, # Whether socket needs to be disconnected
+ $connect, # Whether socket needs to be connected
$done, # Set to 1 when we are done pinging
$rbits, # Read bits, filehandles for reading
$nfound, # Number of ready filehandles found
$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
+
+ if ($self->{"connected"}) {
+ if ($self->{"connected"} ne $saddr) {
+ # Still connected to wrong destination.
+ # Need to flush out the old one.
+ $flush = 1;
+ }
+ } else {
+ # Not connected yet.
+ # Need to connect() before send()
+ $connect = 1;
+ }
+
+ # Have to connect() and send() instead of sendto()
+ # in order to pick up on the ECONNREFUSED setting
+ # from recv() or double send() errno as utilized in
+ # the concept by rdw @ perlmonks. See:
+ # http://perlmonks.thepen.com/42898.html
+ if ($flush) {
+ # Need to socket() again to flush the descriptor
+ # This will disconnect from the old saddr.
+ socket($self->{"fh"}, PF_INET, SOCK_DGRAM,
+ $self->{"proto_num"});
+ }
+ # Connect the socket if it isn't already connected
+ # to the right destination.
+ if ($flush || $connect) {
+ connect($self->{"fh"}, $saddr); # Tie destination to socket
+ $self->{"connected"} = $saddr;
+ }
+ send($self->{"fh"}, $msg, UDP_FLAGS); # Send it
$rbits = "";
vec($rbits, $self->{"fh"}->fileno(), 1) = 1;
$ret = 0; # Default to unreachable
$done = 0;
+ my $retrans = 0.01;
+ my $factor = $self->{"retrans"};
$finish_time = &time() + $timeout; # Ping needs to be done by then
while (!$done && $timeout > 0)
{
- $nfound = select($rbits, undef, undef, $timeout); # Wait for response
+ if ($factor > 1)
+ {
+ $timeout = $retrans if $timeout > $retrans;
+ $retrans*= $factor; # Exponential backoff
+ }
+ $nfound = mselect((my $rout=$rbits), undef, undef, $timeout); # Wait for response
+ my $why = $!;
$timeout = $finish_time - &time(); # Get remaining time
if (!defined($nfound)) # Hmm, a strange error
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 (!$source_verify ||
- (($from_ip eq $ip) && # Does the packet check out?
- ($from_port == $self->{"port_num"}) &&
- ($from_msg eq $msg)))
- {
- $ret = 1; # It's a winner
+ $from_saddr = recv($self->{"fh"}, $from_msg, 1500, UDP_FLAGS);
+ if (!$from_saddr) {
+ # For example an unreachable host will make recv() fail.
+ if (!$self->{"econnrefused"} &&
+ ($! == ECONNREFUSED ||
+ $! == ECONNRESET)) {
+ # "Connection refused" means reachable
+ # Good, continue
+ $ret = 1;
+ }
$done = 1;
+ } else {
+ ($from_port, $from_ip) = sockaddr_in($from_saddr);
+ if (!$source_verify ||
+ (($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
+ elsif ($timeout <= 0) # Oops, timed out
{
$done = 1;
}
+ else
+ {
+ # Send another in case the last one dropped
+ if (send($self->{"fh"}, $msg, UDP_FLAGS)) {
+ # Another send worked? The previous udp packet
+ # must have gotten lost or is still in transit.
+ # Hopefully this new packet will arrive safely.
+ } else {
+ if (!$self->{"econnrefused"} &&
+ $! == ECONNREFUSED) {
+ # "Connection refused" means reachable
+ # Good, continue
+ $ret = 1;
+ }
+ $done = 1;
+ }
+ }
}
return $ret;
}
setsockopt($fh, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'}))
or croak("error binding to device $self->{'device'} $!");
}
-
- # Set O_NONBLOCK property on filehandle
- if (my $flags = fcntl($fh, F_GETFL, 0)) {
- fcntl($fh, F_SETFL, $flags | O_NONBLOCK);
- } else {
- croak("fcntl F_GETFL: $!");
+ if ($self->{'tos'}) {
+ setsockopt($fh, SOL_IP, IP_TOS(), pack("I*", $self->{'tos'}))
+ or croak "error configuring tos to $self->{'tos'} $!";
}
+ # Set O_NONBLOCK property on filehandle
+ $self->socket_blocking_mode($fh, 0);
# Attempt the non-blocking connect
# by just sending the TCP SYN packet
if (connect($fh, $saddr)) {
# Non-blocking, yet still connected?
- # Must have connected very quickly.
- # Can this ever really happen?
- }
- else {
+ # Must have connected very quickly,
+ # or else it wasn't very non-blocking.
+ #warn "WARNING: Nonblocking connect connected anyway? ($^O)";
+ } else {
# Error occurred connecting.
- # Hopefully the connection is just still in progress.
- if ($! != EINPROGRESS) {
- # If not, then it really is something bad.
+ if ($! == EINPROGRESS || ($^O eq 'MSWin32' && $! == EWOULDBLOCK)) {
+ # The connection is just still in progress.
+ # This is the expected condition.
+ } else {
+ # Just save the error and continue on.
+ # The ack() can check the status later.
$self->{"bad"}->{$host} = $!;
- return undef;
}
}
setsockopt($self->{"fh"}, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'}))
or croak("error binding to device $self->{'device'} $!");
}
+ if ($self->{'tos'}) {
+ setsockopt($self->{"fh"}, SOL_IP, IP_TOS(), pack("I*", $self->{'tos'}))
+ or croak "error configuring tos to $self->{'tos'} $!";
+ }
$!=0;
# Try to connect (could take a long time)
# Notify parent of connect error status
my $err = $!+0;
my $wrstr = "$$ $err";
- # Force to 10 chars including \n
- $wrstr .= " "x(9 - length $wrstr). "\n";
- syswrite($self->{"fork_wr"}, $wrstr);
+ # Force to 16 chars including \n
+ $wrstr .= " "x(15 - length $wrstr). "\n";
+ syswrite($self->{"fork_wr"}, $wrstr, length $wrstr);
exit;
}
} else {
if (my $host = shift) {
# Host passed as arg
if (exists $self->{"bad"}->{$host}) {
- return ();
+ if (!$self->{"econnrefused"} &&
+ $self->{"bad"}->{ $host } &&
+ (($! = ECONNREFUSED)>0) &&
+ $self->{"bad"}->{ $host } eq "$!") {
+ # "Connection refused" means reachable
+ # Good, continue
+ } else {
+ # ECONNREFUSED means no good
+ return ();
+ }
}
my $host_fd = undef;
foreach my $fd (keys %{ $self->{"syn"} }) {
$wbits = $self->{"wbits"};
}
- while ($wbits !~ /^\0*$/) {
+ while ($wbits !~ /^\0*\z/) {
my $timeout = $stop_time - &time();
# Force a minimum of 10 ms timeout.
- $timeout = 0.01 if $timeout <= .01;
- if (my $nfound = select(undef, (my $wout=$wbits), undef, $timeout)) {
- # Done waiting for one of the ACKs
- my $fd = 0;
- # Determine which one
- while (length $wout &&
- !vec($wout, $fd, 1)) {
- $fd++;
+ $timeout = 0.01 if $timeout <= 0.01;
+
+ my $winner_fd = undef;
+ my $wout = $wbits;
+ my $fd = 0;
+ # Do "bad" fds from $wbits first
+ while ($wout !~ /^\0*\z/) {
+ if (vec($wout, $fd, 1)) {
+ # Wipe it from future scanning.
+ vec($wout, $fd, 1) = 0;
+ if (my $entry = $self->{"syn"}->{$fd}) {
+ if ($self->{"bad"}->{ $entry->[0] }) {
+ $winner_fd = $fd;
+ last;
+ }
+ }
+ }
+ $fd++;
+ }
+
+ if (defined($winner_fd) or my $nfound = mselect(undef, ($wout=$wbits), undef, $timeout)) {
+ if (defined $winner_fd) {
+ $fd = $winner_fd;
+ } else {
+ # Done waiting for one of the ACKs
+ $fd = 0;
+ # Determine which one
+ while ($wout !~ /^\0*\z/ &&
+ !vec($wout, $fd, 1)) {
+ $fd++;
+ }
}
if (my $entry = $self->{"syn"}->{$fd}) {
- if (getpeername($entry->[2])) {
+ # Wipe it from future scanning.
+ delete $self->{"syn"}->{$fd};
+ vec($self->{"wbits"}, $fd, 1) = 0;
+ vec($wbits, $fd, 1) = 0;
+ if (!$self->{"econnrefused"} &&
+ $self->{"bad"}->{ $entry->[0] } &&
+ (($! = ECONNREFUSED)>0) &&
+ $self->{"bad"}->{ $entry->[0] } eq "$!") {
+ # "Connection refused" means reachable
+ # Good, continue
+ } elsif (getpeername($entry->[2])) {
# Connection established to remote host
- delete $self->{"syn"}->{$fd};
- vec($self->{"wbits"}, $fd, 1) = 0;
- return wantarray ?
- ($entry->[0], &time() - $entry->[3], inet_ntoa($entry->[1]))
- : $entry->[0];
+ # Good, continue
} else {
# TCP ACK will never come from this host
# because there was an error connecting.
- # Wipe it from future scanning.
- delete $self->{"syn"}->{$fd};
- vec($self->{"wbits"}, $fd, 1) = 0;
- vec($wbits, $fd, 1) = 0;
-
# This should set $! to the correct error.
my $char;
- read($entry->[2],$char,1);
+ sysread($entry->[2],$char,1);
# Store the excuse why the connection failed.
$self->{"bad"}->{$entry->[0]} = $!;
- if (!$self->{"tcp_econnrefused"} &&
- $! == ECONNREFUSED) {
+ if (!$self->{"econnrefused"} &&
+ (($! == ECONNREFUSED) ||
+ ($! == EAGAIN && $^O =~ /cygwin/i))) {
# "Connection refused" means reachable
- return wantarray ?
- ($entry->[0], &time() - $entry->[3], inet_ntoa($entry->[1]))
- : $entry->[0];
+ # Good, continue
+ } else {
+ # No good, try the next socket...
+ next;
}
- # Try another socket...
}
+ # Everything passed okay, return the answer
+ return wantarray ?
+ ($entry->[0], &time() - $entry->[3], inet_ntoa($entry->[1]))
+ : $entry->[0];
} else {
warn "Corrupted SYN entry: unknown fd [$fd] ready!";
vec($wbits, $fd, 1) = 0;
}
sub ack_unfork {
- my $self = shift;
+ my ($self,$host) = @_;
my $stop_time = $self->{"stop_time"};
- if (my $host = shift) {
+ if ($host) {
# Host passed as arg
- warn "Cannot specify host for ack on win32\n";
+ if (my $entry = $self->{"good"}->{$host}) {
+ delete $self->{"good"}->{$host};
+ return ($entry->[0], &time() - $entry->[3], inet_ntoa($entry->[1]));
+ }
}
my $rbits = "";
my $timeout;
+
if (keys %{ $self->{"syn"} }) {
# Scan all hosts that are left
vec($rbits, fileno($self->{"fork_rd"}), 1) = 1;
$timeout = $stop_time - &time();
+ # Force a minimum of 10 ms timeout.
+ $timeout = 0.01 if $timeout < 0.01;
} else {
# No hosts left to wait for
$timeout = 0;
}
if ($timeout > 0) {
- if (my $nfound = select((my $rout=$rbits), undef, undef, $timeout)) {
+ my $nfound;
+ while ( keys %{ $self->{"syn"} } and
+ $nfound = mselect((my $rout=$rbits), undef, undef, $timeout)) {
# Done waiting for one of the ACKs
- if (!sysread($self->{"fork_rd"}, $_, 10)) {
+ if (!sysread($self->{"fork_rd"}, $_, 16)) {
# Socket closed, which means all children are done.
return ();
}
# Connection attempt to remote host is done
delete $self->{"syn"}->{$pid};
if (!$how || # If there was no error connecting
- (!$self->{"tcp_econnrefused"} &&
+ (!$self->{"econnrefused"} &&
$how == ECONNREFUSED)) { # "Connection refused" means reachable
+ if ($host && $entry->[0] ne $host) {
+ # A good connection, but not the host we need.
+ # Move it from the "syn" hash to the "good" hash.
+ $self->{"good"}->{$entry->[0]} = $entry;
+ # And wait for the next winner
+ next;
+ }
return ($entry->[0], &time() - $entry->[3], inet_ntoa($entry->[1]));
}
} else {
} else {
die "Empty response from status socket?";
}
- } elsif (defined $nfound) {
+ }
+ if (defined $nfound) {
# Timed out waiting for ACK status
} else {
# Weird error occurred with select()
Net::Ping - check a remote host for reachability
-$Id: Ping.pm,v 1.33 2002/10/19 05:02:43 rob Exp $
-
=head1 SYNOPSIS
use Net::Ping;
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.
+privileges but has higher overhead than the "udp" and "icmp" 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
the return value does NOT determine if the remote host is alive or
not since the full TCP three-way handshake may not have completed
yet. The remote host is only considered reachable if it receives
-a TCP ACK within the timeout specifed. To begin waiting for the
+a TCP ACK within the timeout specified. To begin waiting for the
ACK packets, use the ack() method as explained below. Use the
"syn" protocol instead the "tcp" protocol to determine reachability
of multiple destinations simultaneously by sending parallel TCP
=over 4
-=item Net::Ping->new([$proto [, $def_timeout [, $bytes [, $device ]]]]);
+=item Net::Ping->new([$proto [, $def_timeout [, $bytes [, $device [, $tos ]]]]]);
Create a new ping object. All of the parameters are optional. $proto
specifies the protocol to use when doing a ping. The current choices
1024.
If $device is given, this device is used to bind the source endpoint
-before sending the ping packet. I beleive this only works with
+before sending the ping packet. I believe this only works with
superuser privileges and with udp and icmp protocols at this time.
+If $tos is given, this ToS is configured into the socket.
+
=item $p->ping($host [, $timeout]);
Ping the remote host and wait for a response. $host can be either the
This is enabled by default.
-=item $p->tcp_service_check( { 0 | 1 } );
+=item $p->service_check( { 0 | 1 } );
-Set whether or not the tcp connect behavior should enforce
+Set whether or not the connect behavior should enforce
remote service availability as well as reachability. Normally,
if the remote server reported ECONNREFUSED, it must have been
reachable because of the status packet that it reported.
throws the ACK packet, it is considered alive anyway. To
really determine if the server is responding well would be
application specific and is beyond the scope of Net::Ping.
+For udp protocol, enabling this option demands that the
+remote server replies with the same udp data that it was sent
+as defined by the udp echo service.
-This only affects "tcp" and "syn" protocols.
+This affects the "udp", "tcp", and "syn" protocols.
This is disabled by default.
+=item $p->tcp_service_check( { 0 | 1 } );
+
+Deprecated method, but does the same as service_check() method.
+
=item $p->hires( { 0 | 1 } );
Causes this module to use Time::HiRes module, allowing milliseconds
undef. In list context, the host, the ack time, and the
dotted ip string will be returned instead of just the host.
If the optional $host argument is specified, the return
-value will be partaining to that host only.
+value will be pertaining to that host only.
This call simply does nothing if you are using any protocol
other than syn.
=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
rpm -ih RPMS/noarch/perl-Net-Ping-xxxx.rpm
+=head1 BUGS
+
+For a list of known issues, visit:
+
+https://rt.cpan.org/NoAuth/Bugs.html?Dist=Net-Ping
+
+To report a new bug, visit:
+
+https://rt.cpan.org/NoAuth/ReportBug.html?Queue=Net-Ping
+
=head1 AUTHORS
Current maintainer:
=head1 COPYRIGHT
-Copyright (c) 2002, Rob Brown. All rights reserved.
+Copyright (c) 2002-2003, 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.
+$Id: Ping.pm,v 1.86 2003/06/27 21:31:07 rob Exp $
+
=cut
projects / p5sagit/p5-mst-13.2.git / blobdiff