package Net::Ping;
-# $Id: Ping.pm,v 1.33 2002/10/19 05:02:43 rob Exp $
+# $Id: Ping.pm,v 1.46 2002/12/02 19:17:09 rob Exp $
require 5.002;
require Exporter;
use Fcntl qw( F_GETFL F_SETFL O_NONBLOCK );
use Socket qw( SOCK_DGRAM SOCK_STREAM SOCK_RAW PF_INET SOL_SOCKET
inet_aton inet_ntoa sockaddr_in );
-use POSIX qw( ECONNREFUSED EINPROGRESS WNOHANG );
+use POSIX qw( ECONNREFUSED EINPROGRESS EAGAIN WNOHANG );
use FileHandle;
use Carp;
@ISA = qw(Exporter);
@EXPORT = qw(pingecho);
-$VERSION = "2.23";
+$VERSION = "2.26";
# Constants
$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"} = {};
# of time. Return the result of our efforts.
use constant UDP_FLAGS => 0; # Nothing special on send or recv
-
+# XXX - Use concept by rdw @ perlmonks
+# http://perlmonks.thepen.com/42898.html
sub ping_udp
{
my ($self,
}
# Set O_NONBLOCK property on filehandle
- if (my $flags = fcntl($fh, F_GETFL, 0)) {
- fcntl($fh, F_SETFL, $flags | O_NONBLOCK);
+ my $flags = 0;
+ if (fcntl($fh, F_GETFL, $flags)) {
+ if (!fcntl($fh, F_SETFL, $flags | O_NONBLOCK)) {
+ croak("fcntl F_SETFL: $!");
+ }
} else {
croak("fcntl F_GETFL: $!");
}
# 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) {
+ # 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;
}
}
if (my $host = shift) {
# Host passed as arg
if (exists $self->{"bad"}->{$host}) {
- return ();
+ if (!$self->{"tcp_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"} }) {
while ($wbits !~ /^\0*$/) {
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*$/) {
+ 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 = select(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*$/ &&
+ !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->{"tcp_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);
# Store the excuse why the connection failed.
$self->{"bad"}->{$entry->[0]} = $!;
if (!$self->{"tcp_econnrefused"} &&
- $! == 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 = select((my $rout=$rbits), undef, undef, $timeout)) {
# Done waiting for one of the ACKs
if (!sysread($self->{"fork_rd"}, $_, 10)) {
# Socket closed, which means all children are done.
if (!$how || # If there was no error connecting
(!$self->{"tcp_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 $
+$Id: Ping.pm,v 1.46 2002/12/02 19:17:09 rob Exp $
=head1 SYNOPSIS
--- /dev/null
+# Same as 400_ping_syn.t but testing ack( $host ) instead of ack( ).
+
+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 (getservbyname('echo', 'tcp')) {
+ print "1..0 \# Skip: no echo port\n";
+ exit;
+ }
+ unless (getservbyname('http', 'tcp')) {
+ print "1..0 \# Skip: no http port\n";
+ exit;
+ }
+}
+
+# Remote network test using syn protocol.
+#
+# NOTE:
+# Network connectivity will be required for all tests to pass.
+# Firewalls may also cause some tests to fail, so test it
+# on a clear network. If you know you do not have a direct
+# connection to remote networks, but you still want the tests
+# to pass, use the following:
+#
+# $ PERL_CORE=1 make test
+
+# Try a few remote servers
+my $webs = {
+ # Hopefully this is never a routeable host
+ "172.29.249.249" => 0,
+
+ # Hopefully all these web ports are open
+ "www.geocities.com." => 1,
+ "www.freeservers.com." => 1,
+ "yahoo.com." => 1,
+ "www.yahoo.com." => 1,
+ "www.about.com." => 1,
+ "www.microsoft.com." => 1,
+ "127.0.0.1" => 1,
+};
+
+use strict;
+use Test;
+use Net::Ping;
+plan tests => ((keys %{ $webs }) * 2 + 3);
+
+# Everything loaded fine
+ok 1;
+
+alarm(50);
+$SIG{ALRM} = sub {
+ ok 0;
+ die "TIMED OUT!";
+};
+
+my $p = new Net::Ping "syn", 10;
+
+# new() worked?
+ok !!$p;
+
+# Change to use the more common web port.
+# (Make sure getservbyname works in scalar context.)
+ok ($p -> {port_num} = getservbyname("http", "tcp"));
+
+foreach my $host (keys %{ $webs }) {
+ # ping() does dns resolution and
+ # only sends the SYN at this point
+ alarm(50); # (Plenty for a DNS lookup)
+ if (!ok($p -> ping($host))) {
+ print STDERR "CANNOT RESOLVE $host $p->{bad}->{$host}\n";
+ }
+}
+
+alarm(20);
+foreach my $host (sort keys %{ $webs }) {
+ my $on = $p->ack($host);
+ if (!ok (($on && $webs->{$host}) ||
+ (!$on && !$webs->{$host}))) {
+ if ($on) {
+ print STDERR "SUPPOSED TO BE DOWN: http://$host/\n";
+ } else {
+ print STDERR "DOWN: http://$host/ $p->{bad}->{$host}\n";
+ }
+ }
+ delete $webs->{$host};
+ alarm(20);
+}
+
+alarm(0);
print "1..0 \# Skip: no echo port\n";
exit;
}
- unless (0) {
- print "1..0 \# Skip: too many problems right now\n";
- exit;
- }
}
use strict;
use Test;
use Net::Ping;
-use IO::Socket;
# I'm lazy so I'll just use IO::Socket
# for the TCP Server stuff instead of doing
# all that direct socket() junk manually.
-plan tests => 37;
+plan tests => 26;
# Everything loaded fine
ok 1;
-"0" =~ /(0)/; # IO::Socket::INET ephemeral buttwag hack
-
# Start a tcp listen server on ephemeral port
my $sock1 = new IO::Socket::INET
- LocalAddr => "127.1.1.1",
+ LocalAddr => "127.0.0.1",
Proto => "tcp",
Listen => 8,
- Reuse => 1,
- Type => SOCK_STREAM,
- ;
+ or warn "bind: $!";
# Make sure it worked.
ok !!$sock1;
-"0" =~ /(0)/; # IO::Socket::INET ephemeral buttwag hack
-
# Start listening on another ephemeral port
my $sock2 = new IO::Socket::INET
- LocalAddr => "127.2.2.2",
+ LocalAddr => "127.0.0.1",
Proto => "tcp",
Listen => 8,
- Reuse => 1,
- Type => SOCK_STREAM,
- ;
+ or warn "bind: $!";
# Make sure it worked too.
ok !!$sock2;
# Make sure the sockets are listening on different ports.
ok ($port1 != $port2);
+$sock2->close;
+
# This is how it should be:
-# 127.1.1.1:$port1 - service ON
-# 127.2.2.2:$port2 - service ON
-# 127.1.1.1:$port2 - service OFF
-# 127.2.2.2:$port1 - service OFF
+# 127.0.0.1:$port1 - service ON
+# 127.0.0.1:$port2 - service OFF
#####
# First, we test using the "tcp" protocol.
# Try on the first port
$p->{port_num} = $port1;
-# Make sure IP1 is reachable
-ok $p -> ping("127.1.1.1");
-
-# Make sure IP2 is reachable
-ok $p -> ping("127.2.2.2");
+# Make sure it is reachable
+ok $p -> ping("127.0.0.1");
# Try on the other port
$p->{port_num} = $port2;
-# Make sure IP1 is reachable
-ok $p -> ping("127.1.1.1");
+# Make sure it is reachable
+ok $p -> ping("127.0.0.1");
-# Make sure IP2 is reachable
-ok $p -> ping("127.2.2.2");
# Enable service checking
# Try on the first port
$p->{port_num} = $port1;
-# Make sure service on IP1
-ok $p -> ping("127.1.1.1");
-
-# Make sure not service on IP2
-ok !$p -> ping("127.2.2.2");
+# Make sure service is on
+ok $p -> ping("127.0.0.1");
# Try on the other port
$p->{port_num} = $port2;
-# Make sure not service on IP1
-ok !$p -> ping("127.1.1.1");
-
-# Make sure service on IP2
-ok $p -> ping("127.2.2.2");
+# Make sure service is off
+ok !$p -> ping("127.0.0.1");
+# test 11 just finished.
#####
# Lastly, we test using the "syn" protocol.
# Try on the first port
$p->{port_num} = $port1;
-# Send SYN to both IPs
-ok $p -> ping("127.1.1.1");
-ok $p -> ping("127.2.2.2");
+# Send SYN
+if (!ok $p -> ping("127.0.0.1")) {warn "ERRNO: $!";}
-# Both IPs should be reachable
-ok $p -> ack();
+# IP should be reachable
ok $p -> ack();
# No more sockets?
ok !$p -> ack();
# Try on the other port
$p->{port_num} = $port2;
-# Send SYN to both IPs
-ok $p -> ping("127.1.1.1");
-ok $p -> ping("127.2.2.2");
+# Send SYN
+if (!ok $p -> ping("127.0.0.1")) {warn "ERRNO: $!";}
-# Both IPs should be reachable
-ok $p -> ack();
+# IP should still be reachable
ok $p -> ack();
# No more sockets?
ok !$p -> ack();
# Try on the first port
$p->{port_num} = $port1;
-# Send SYN to both IPs
-ok $p -> ping("127.1.1.1");
-ok $p -> ping("127.2.2.2");
+# Send SYN
+ok $p -> ping("127.0.0.1");
-# Only IP1 should have service
-ok "127.1.1.1",$p -> ack();
+# Should have service on
+ok ($p -> ack(),"127.0.0.1");
# No more good sockets?
ok !$p -> ack();
# Try on the other port
$p->{port_num} = $port2;
-# Send SYN to both IPs
-ok $p -> ping("127.1.1.1");
-ok $p -> ping("127.2.2.2");
+# Send SYN
+if (!ok $p -> ping("127.0.0.1")) {warn "ERRNO: $!";}
-# Only IP2 should have service
-ok "127.2.2.2",$p -> ack();
-# No more good sockets?
+# No sockets should have service on
ok !$p -> ack();
projects / platform / upstream / perl.git / commitdiff