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 EAGAIN WNOHANG );
+use POSIX qw( ENOTCONN ECONNREFUSED ECONNRESET EINPROGRESS EWOULDBLOCK EAGAIN WNOHANG );
use FileHandle;
use Carp;
@ISA = qw(Exporter);
@EXPORT = qw(pingecho);
-$VERSION = "2.29";
+$VERSION = "2.31";
+
+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";
# 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;
+ *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->{"retrans"} = $def_factor; # Default exponential backoff rate
$self->{"econnrefused"} = undef; # Default Connection refused behavior
$self->{"seq"} = 0; # For counting packets
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")
{
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);
+ $t -= $gran;
+ return $nfound if $nfound or !defined($nfound) or $t <= 0;
+
+ sleep(0);
+ ($_[0], $_[1], $_[2]) = @args;
+ }
+ }
+ else {
+ return select($_[0], $_[1], $_[2], $_[3]);
+ }
+}
# Description: Allow UDP source endpoint comparision to be
# skipped for those remote interfaces that do
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->{"retrans"} = shift;
+}
+
# Description: allows the module to use milliseconds as returned by
# the Time::HiRes module
# 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)) {
$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) = unpack("C2", substr($recv_msg, 20, 2));
- if ($from_type == ICMP_ECHOREPLY){
- ($from_pid, $from_seq) = unpack("n3", substr($recv_msg, 24, 4));
+ 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));
+ ($from_pid, $from_seq) = unpack("n3", substr($recv_msg, 52, 4))
+ if length $recv_msg >= 56;
}
$self->{"from_ip"} = $from_ip;
$self->{"from_type"} = $from_type;
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 {
$self->{"ip"} = $ip;
- return ($ret = connect($self->{"fh"}, $saddr));
+ # 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
if (!connect($self->{"fh"}, $saddr)) {
if ($! == ECONNREFUSED) {
$ret = 1 unless $self->{"econnrefused"};
- } elsif ($! != EINPROGRESS) {
+ } 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,
} else {
# Got the expected EINPROGRESS.
# Just wait for connection completion...
- my ($wbits, $wout);
- $wout = $wbits = "";
+ my ($wbits, $wout, $wexc);
+ $wout = $wexc = $wbits = "";
vec($wbits, $self->{"fh"}->fileno, 1) = 1;
- my $nfound = select(undef, ($wout = $wbits), undef, $timeout);
+ 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)) {
&& $! == ECONNREFUSED);
}
} else {
- # the connection attempt timed out
+ # 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 {
# 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.
$self->{'tcp_chld'} = fork;
exit 0;
} else {
# Pass the error status to the parent
- exit $!;
+ # Make sure that $! <= 255
+ exit($! <= 255 ? $! : 255);
}
}
# within the timeout
&{ $do_connect }();
}
+ # $ret cannot be set by the child process
+ $ret = !$child_errno;
} else {
# Time must have run out.
# Put that choking client out of its misery
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, length $wrstr);
$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
+
+ 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
- connect($self->{"fh"}, $saddr); # Tie destination to socket
+ 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 = "";
$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)
{
- $timeout = $retrans if $timeout > $retrans;
- $retrans*= 1.2; # Exponential backoff
- $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 (!$from_saddr) {
# For example an unreachable host will make recv() fail.
if (!$self->{"econnrefused"} &&
- $! == ECONNREFUSED) {
+ ($! == ECONNREFUSED ||
+ $! == ECONNRESET)) {
# "Connection refused" means reachable
# Good, continue
$ret = 1;
setsockopt($fh, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'}))
or croak("error binding to device $self->{'device'} $!");
}
-
+ 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);
#warn "WARNING: Nonblocking connect connected anyway? ($^O)";
} else {
# Error occurred connecting.
- if ($! == EINPROGRESS) {
+ if ($! == EINPROGRESS || ($^O eq 'MSWin32' && $! == EWOULDBLOCK)) {
# The connection is just still in progress.
# This is the expected condition.
} else {
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)
$fd++;
}
- if (defined($winner_fd) or my $nfound = select(undef, ($wout=$wbits), undef, $timeout)) {
+ if (defined($winner_fd) or my $nfound = mselect(undef, ($wout=$wbits), undef, $timeout)) {
if (defined $winner_fd) {
$fd = $winner_fd;
} else {
if ($timeout > 0) {
my $nfound;
while ( keys %{ $self->{"syn"} } and
- $nfound = select((my $rout=$rbits), undef, undef, $timeout)) {
+ $nfound = mselect((my $rout=$rbits), undef, undef, $timeout)) {
# Done waiting for one of the ACKs
if (!sysread($self->{"fork_rd"}, $_, 16)) {
# Socket closed, which means all children are done.
=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
before sending the ping packet. I beleive 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 soscket.
+
=item $p->ping($host [, $timeout]);
Ping the remote host and wait for a response. $host can be either the
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.75 2003/04/12 20:51:17 rob Exp $
+$Id: Ping.pm,v 1.86 2003/06/27 21:31:07 rob Exp $
=cut
projects / p5sagit/p5-mst-13.2.git / blobdiff