$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 ECONNRESET 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.30";
+$VERSION = "2.31_04";
+
+sub SOL_IP { 0; };
+sub IP_TOS { 1; };
# Constants
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")
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);
+ 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.
# 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)) {
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 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
+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
{
$finish_time = &time() + $timeout; # Must be done by this time
while (!$done && $timeout > 0) # Keep trying if we have time
{
- $nfound = select((my $rout=$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
{
$self->{"from_subcode"} = $from_subcode;
if (($from_pid == $self->{"pid"}) && # Does the packet check out?
($from_seq == $self->{"seq"})) {
- if ($from_type == ICMP_ECHOREPLY){
+ if ($from_type == ICMP_ECHOREPLY) {
$ret = 1;
+ $done = 1;
+ } elsif ($from_type == ICMP_UNREACHABLE) {
+ $done = 1;
}
- $done = 1;
}
} else { # Oops, timed out
$done = 1;
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);
$timeout = $retrans if $timeout > $retrans;
$retrans*= $factor; # Exponential backoff
}
- $nfound = select((my $rout=$rbits), undef, undef, $timeout); # Wait for response
+ $nfound = mselect((my $rout=$rbits), undef, undef, $timeout); # Wait for response
my $why = $!;
$timeout = $finish_time - &time(); # Get remaining time
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.
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
=item $p->tcp_service_check( { 0 | 1 } );
-Depricated method, but does the same as service_check() method.
+Deprecated method, but does the same as service_check() method.
=item $p->hires( { 0 | 1 } );
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.
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.81 2003/04/18 04:16:03 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