From: Hugo van der Sanden Date: Tue, 17 Dec 2002 02:58:12 +0000 (+0000) Subject: Integrate Net::Ping v2.26. (lib/Net/Ping/t/450_service.t should work now) X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=69c74a9cf75f986f610f13d1567297e884d75c25;p=p5sagit%2Fp5-mst-13.2.git Integrate Net::Ping v2.26. (lib/Net/Ping/t/450_service.t should work now) p4raw-id: //depot/perl@18317 --- diff --git a/MANIFEST b/MANIFEST index 01dba28..26e13bc 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1348,6 +1348,7 @@ lib/Net/Ping/t/250_ping_hires.t Ping Net::Ping lib/Net/Ping/t/300_ping_stream.t Ping Net::Ping lib/Net/Ping/t/300_ping_stream.t Ping Net::Ping lib/Net/Ping/t/400_ping_syn.t Ping Net::Ping +lib/Net/Ping/t/410_syn_host.t Ping Net::Ping lib/Net/Ping/t/450_service.t Ping Net::Ping lib/Net/POP3.pm libnet lib/Net/protoent.pm By-name interface to Perl's builtin getproto* diff --git a/lib/Net/Ping.pm b/lib/Net/Ping.pm index 1192663..e27692f 100644 --- a/lib/Net/Ping.pm +++ b/lib/Net/Ping.pm @@ -1,6 +1,6 @@ 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; @@ -11,13 +11,13 @@ use vars qw(@ISA @EXPORT $VERSION 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 @@ -157,6 +157,8 @@ sub new $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"} = {}; @@ -665,7 +667,8 @@ sub open # 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, @@ -761,8 +764,11 @@ sub ping_syn } # 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: $!"); } @@ -771,16 +777,18 @@ sub ping_syn # 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; } } @@ -863,7 +871,16 @@ sub ack 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"} }) { @@ -889,46 +906,75 @@ sub ack 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; @@ -957,26 +1003,34 @@ sub ack } 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. @@ -992,6 +1046,13 @@ sub ack_unfork { 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 { @@ -1001,7 +1062,8 @@ sub ack_unfork { } 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() @@ -1051,7 +1113,7 @@ __END__ 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 diff --git a/lib/Net/Ping/t/400_ping_syn.t b/lib/Net/Ping/t/400_ping_syn.t index 3b84af7..29022d2 100644 --- a/lib/Net/Ping/t/400_ping_syn.t +++ b/lib/Net/Ping/t/400_ping_syn.t @@ -37,13 +37,14 @@ my $webs = { # Hopefully this is never a routeable host "172.29.249.249" => 0, - # Hopefully all these web servers are on + # 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; @@ -54,6 +55,12 @@ 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? @@ -66,29 +73,23 @@ ok ($p -> {port_num} = getservbyname("http", "tcp")); foreach my $host (keys %{ $webs }) { # ping() does dns resolution and # only sends the SYN at this point - if ($p -> ping($host)) { - ok 1; - } else { - print STDERR "CANNOT RESOLVE $host\n"; - ok 0; + alarm(50); # (Plenty for a DNS lookup) + if (!ok $p -> ping($host)) { + print STDERR "CANNOT RESOLVE $host $p->{bad}->{$host}\n"; } } +alarm(20); while (my $host = $p->ack()) { - if ($webs->{$host}) { - ok 1; - } else { + if (!ok $webs->{$host}) { print STDERR "SUPPOSED TO BE DOWN: http://$host/\n"; - ok 0; } delete $webs->{$host}; } +alarm(0); foreach my $host (keys %{ $webs }) { - if ($webs->{$host}) { - print STDERR "DOWN: http://$host/\n"; - ok 0; - } else { - ok 1; + if (!ok !$webs->{$host}) { + print STDERR "DOWN: http://$host/ [$p->{bad}->{$host}]\n"; } } diff --git a/lib/Net/Ping/t/410_syn_host.t b/lib/Net/Ping/t/410_syn_host.t new file mode 100644 index 0000000..38bc7f2 --- /dev/null +++ b/lib/Net/Ping/t/410_syn_host.t @@ -0,0 +1,99 @@ +# 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); diff --git a/lib/Net/Ping/t/450_service.t b/lib/Net/Ping/t/450_service.t index 2ee856c..97d3caf 100644 --- a/lib/Net/Ping/t/450_service.t +++ b/lib/Net/Ping/t/450_service.t @@ -9,50 +9,37 @@ BEGIN { 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; @@ -66,11 +53,11 @@ ok $port2; # 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. @@ -86,20 +73,15 @@ $p->tcp_service_check(0); # 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 @@ -108,21 +90,16 @@ $p->tcp_service_check(1); # 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. @@ -137,12 +114,10 @@ $p->tcp_service_check(0); # 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(); @@ -160,12 +135,10 @@ $p->tcp_service_check(0); # 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(); @@ -184,12 +157,11 @@ $p->tcp_service_check(1); # 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(); @@ -207,11 +179,8 @@ $p->tcp_service_check(1); # 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();