$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";
+
+sub SOL_IP { 0; };
+sub IP_TOS { 1; };
# Constants
# 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")
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
# 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((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
{
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.
=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.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