dslinux/user/perl/lib/Net/Ping/t 100_load.t 110_icmp_inst.t 120_udp_inst.t 130_tcp_inst.t 140_stream_inst.t 150_syn_inst.t 190_alarm.t 200_ping_tcp.t 250_ping_hires.t 300_ping_stream.t 400_ping_syn.t 410_syn_host.t 450_service.t 500_ping_icmp.t 510_ping_udp.t

cayenne dslinux_cayenne at user.in-berlin.de
Mon Dec 4 18:00:53 CET 2006


Update of /cvsroot/dslinux/dslinux/user/perl/lib/Net/Ping/t
In directory antilope:/tmp/cvs-serv17422/lib/Net/Ping/t

Added Files:
	100_load.t 110_icmp_inst.t 120_udp_inst.t 130_tcp_inst.t 
	140_stream_inst.t 150_syn_inst.t 190_alarm.t 200_ping_tcp.t 
	250_ping_hires.t 300_ping_stream.t 400_ping_syn.t 
	410_syn_host.t 450_service.t 500_ping_icmp.t 510_ping_udp.t 
Log Message:
Adding fresh perl source to HEAD to branch from

--- NEW FILE: 500_ping_icmp.t ---
# Test to perform icmp protocol testing.
# Root access is required.

BEGIN {
  unless (eval "require Socket") {
    print "1..0 \# Skip: no Socket\n";
    exit;
  }
}

use Test;
use Net::Ping;
plan tests => 2;

# Everything loaded fine
ok 1;

if (($> and $^O ne 'VMS' and $^O ne 'cygwin')
    or ($^O eq 'MSWin32'
        and Win32::IsWinNT())
    or ($^O eq 'VMS'
        and (`write sys\$output f\$privilege("SYSPRV")` =~ m/FALSE/))) {
  skip "icmp ping requires root privileges.", 1;
} elsif ($^O eq 'MacOS') {
  skip "icmp protocol not supported.", 1;
} else {
  my $p = new Net::Ping "icmp";
  ok $p->ping("127.0.0.1");
}

--- NEW FILE: 140_stream_inst.t ---
# Test to make sure object can be instantiated for stream protocol.

BEGIN {
  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;
  }
}

use Test;
use Net::Ping;
plan tests => 2;

# Everything loaded fine
ok 1;

my $p = new Net::Ping "stream";
ok !!$p;

--- NEW FILE: 450_service.t ---
# Testing service_check method using tcp and syn protocols.

BEGIN {
  unless (eval "require IO::Socket") {
    print "1..0 \# Skip: no IO::Socket\n";
    exit;
  }
  unless (getservbyname('echo', 'tcp')) {
    print "1..0 \# Skip: no echo port\n";
    exit;
  }
}

use strict;
use Test;
use Net::Ping;

# 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 => 26, ($^O eq 'MSWin32' ? (todo => [18]) :
		   $^O eq "hpux"    ? (todo => [9, 18]) : ());

# Everything loaded fine
ok 1;

# Start a tcp listen server on ephemeral port
my $sock1 = new IO::Socket::INET
  LocalAddr => "127.0.0.1",
  Proto => "tcp",
  Listen => 8,
  or warn "bind: $!";

# Make sure it worked.
ok !!$sock1;

# Start listening on another ephemeral port
my $sock2 = new IO::Socket::INET
  LocalAddr => "127.0.0.1",
  Proto => "tcp",
  Listen => 8,
  or warn "bind: $!";

# Make sure it worked too.
ok !!$sock2;

my $port1 = $sock1->sockport;
ok $port1;

my $port2 = $sock2->sockport;
ok $port2;

# Make sure the sockets are listening on different ports.
ok ($port1 != $port2);

$sock2->close;

# This is how it should be:
# 127.0.0.1:$port1 - service ON
# 127.0.0.1:$port2 - service OFF

#####
# First, we test using the "tcp" protocol.
# (2 seconds should be long enough to connect to loopback.)
my $p = new Net::Ping "tcp", 2;

# new() worked?
ok !!$p;

# Disable service checking
$p->service_check(0);

# Try on the first port
$p->{port_num} = $port1;

# Make sure it is reachable
ok $p -> ping("127.0.0.1");

# Try on the other port
$p->{port_num} = $port2;

# Make sure it is reachable
ok $p -> ping("127.0.0.1");



# Enable service checking
$p->service_check(1);

# Try on the first port
$p->{port_num} = $port1;

# Make sure service is on
ok $p -> ping("127.0.0.1");

# Try on the other port
$p->{port_num} = $port2;

# Make sure service is off
ok !$p -> ping("127.0.0.1");

# test 11 just finished.

#####
# Lastly, we test using the "syn" protocol.
$p = new Net::Ping "syn", 2;

# new() worked?
ok !!$p;

# Disable service checking
$p->service_check(0);

# Try on the first port
$p->{port_num} = $port1;

# Send SYN
if (!ok $p -> ping("127.0.0.1")) {warn "ERRNO: $!";}

# IP should be reachable
ok $p -> ack();
# No more sockets?
ok !$p -> ack();

###
# Get a fresh object
$p = new Net::Ping "syn", 2;

# new() worked?
ok !!$p;

# Disable service checking
$p->service_check(0);

# Try on the other port
$p->{port_num} = $port2;

# Send SYN
if (!ok $p -> ping("127.0.0.1")) {warn "ERRNO: $!";}

# IP should still be reachable
ok $p -> ack();
# No more sockets?
ok !$p -> ack();


###
# Get a fresh object
$p = new Net::Ping "syn", 2;

# new() worked?
ok !!$p;

# Enable service checking
$p->service_check(1);

# Try on the first port
$p->{port_num} = $port1;

# Send SYN
ok $p -> ping("127.0.0.1");

# Should have service on
ok ($p -> ack(),"127.0.0.1");
# No more good sockets?
ok !$p -> ack();


###
# Get a fresh object
$p = new Net::Ping "syn", 2;

# new() worked?
ok !!$p;

# Enable service checking
$p->service_check(1);

# Try on the other port
$p->{port_num} = $port2;

# Send SYN
if (!ok $p -> ping("127.0.0.1")) {warn "ERRNO: $!";}

# No sockets should have service on
ok !$p -> ack();

--- NEW FILE: 510_ping_udp.t ---
# Test to perform udp protocol testing.

BEGIN {
  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;
  }
}

use Test;
use Net::Ping;
plan tests => 2;

# Everything loaded fine
ok 1;

my $p = new Net::Ping "udp";
ok $p->ping("127.0.0.1");

--- NEW FILE: 250_ping_hires.t ---
# Test to make sure hires feature works.

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 (eval "require Time::HiRes") {
    print "1..0 \# Skip: no Time::HiRes\n";
    exit;
  }
  unless (getservbyname('echo', 'tcp')) {
    print "1..0 \# Skip: no echo port\n";
    exit;
  }
}

use Test;
use Net::Ping;
plan tests => 8;

# Everything loaded fine
ok 1;

my $p = new Net::Ping "tcp";

# new() worked?
ok !!$p;

# Default is to not use Time::HiRes
ok !$Net::Ping::hires;

# Enable hires
$p -> hires();
ok $Net::Ping::hires;

# Make sure disable works
$p -> hires(0);
ok !$Net::Ping::hires;

# Enable again
$p -> hires(1);
ok $Net::Ping::hires;

# Test on the default port
my ($ret, $duration) = $p -> ping("localhost");

# localhost should always be reachable, right?
ok $ret;

# It is extremely likely that the duration contains a decimal
# point if Time::HiRes is functioning properly, except when it
# it is fast enough to be "zero".
print "# duration=[$duration]\n";
ok $duration =~ /\.|^0$/;

--- NEW FILE: 200_ping_tcp.t ---
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;
  }
}

# Remote network test using tcp 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

use Test;
use Net::Ping;
plan tests => 13;

# Everything loaded fine
ok 1;

my $p = new Net::Ping "tcp",9;

# new() worked?
ok !!$p;

# Test on the default port
ok $p -> ping("localhost");

# Change to use the more common web port.
# This will pull from /etc/services on UNIX.
# (Make sure getservbyname works in scalar context.)
ok ($p -> {port_num} = (getservbyname("http", "tcp") || 80));

# Test localhost on the web port
ok $p -> ping("localhost");

# Hopefully this is never a routeable host
ok !$p -> ping("172.29.249.249");

# Test a few remote servers
# Hopefully they are up when the tests are run.

ok $p -> ping("www.geocities.com");
ok $p -> ping("ftp.geocities.com");

ok $p -> ping("www.freeservers.com");
ok $p -> ping("ftp.freeservers.com");

ok $p -> ping("yahoo.com");
ok $p -> ping("www.yahoo.com");
ok $p -> ping("www.about.com");

--- NEW FILE: 150_syn_inst.t ---
# Test to make sure object can be instantiated for syn protocol.

BEGIN {
  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;
  }
}

use Test;
use Net::Ping;
plan tests => 2;

# Everything loaded fine
ok 1;

my $p = new Net::Ping "syn";
ok !!$p;

--- NEW FILE: 300_ping_stream.t ---
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;
  }
  if (my $port = getservbyname('echo', 'tcp')) {
    socket(*ECHO, &Socket::PF_INET(), &Socket::SOCK_STREAM(), (getprotobyname 'tcp')[2]);
    unless (connect(*ECHO, scalar &Socket::sockaddr_in($port, &Socket::inet_aton("localhost")))) {
      print "1..0 \# Skip: loopback tcp echo service is off ($!)\n";
      exit;
    }
    close (*ECHO);
  } else {
    print "1..0 \# Skip: no echo port\n";
    exit;
  }
}

# Test of stream protocol using loopback interface.
#
# NOTE:
#   The echo service must be enabled on localhost
#   to really test the stream protocol ping.  See
#   the end of this document on how to enable it.

use Test;
use Net::Ping;
plan tests => 22;

my $p = new Net::Ping "stream";

# new() worked?
ok !!$p;

# Attempt to connect to the echo port
ok ($p -> ping("localhost"));

# Try several pings while it is connected
for (1..20) {
  select (undef,undef,undef,0.1);
  ok $p -> ping("localhost");
}

__END__

A simple xinetd configuration to enable the echo service can easily be made.
Just create the following file before restarting xinetd:

/etc/xinetd.d/echo:

# description: An echo server.
service echo
{
        type            = INTERNAL
        id              = echo-stream
        socket_type     = stream
        protocol        = tcp
        user            = root
        wait            = no
        disable         = no
}


Or if you are using inetd, before restarting, add
this line to your /etc/inetd.conf:

echo   stream  tcp     nowait  root    internal

--- NEW FILE: 130_tcp_inst.t ---
# Test to make sure object can be instantiated for tcp protocol.

BEGIN {
  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;
  }
}

use Test;
use Net::Ping;
plan tests => 2;

# Everything loaded fine
ok 1;

my $p = new Net::Ping "tcp";
ok !!$p;

--- NEW FILE: 190_alarm.t ---
# Test to make sure alarm / SIGALM does not interfere
# with Net::Ping.  (This test was derived to ensure
# compatibility with the "spamassassin" utility.)
# Based on code written by radu at netsoft.ro (Radu Greab).

BEGIN {
  unless (eval "require Socket") {
    print "1..0 \# Skip: no Socket\n";
    exit;
  }
  unless (eval {alarm 0; 1;}) {
    print "1..0 \# Skip: alarm borks on $^O $^X $] ?\n";
    exit;
  }
  unless (getservbyname('echo', 'tcp')) {
    print "1..0 \# Skip: no echo port\n";
    exit;
  }
}

use strict;
use Test;
use Net::Ping;

plan tests => 6;

# Everything compiled
ok 1;

eval {
  my $timeout = 11;

  ok 1; # In eval
  local $SIG{ALRM} = sub { die "alarm works" };
  ok 1; # SIGALRM can be set on this platform
  alarm $timeout;
  ok 1; # alarm() can be set on this platform

  my $start = time;
  while (1) {
    my $ping = Net::Ping->new("tcp", 2);
    # It does not matter if alive or not
    $ping->ping("127.0.0.1");
    $ping->ping("172.29.249.249");
    die "alarm failed" if time > $start + $timeout + 1;
  }
};
# Got out of "infinite loop" okay
ok 1;

# Make sure it died for a good excuse
ok $@ =~ /alarm works/ or die $@;

alarm 0; # Reset alarm

--- NEW FILE: 400_ping_syn.t ---
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;

my $can_alarm = eval {alarm 0; 1;};

sub Alarm {
  alarm(shift) if $can_alarm;
}

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);
while (my $host = $p->ack()) {
  if (!ok $webs->{$host}) {
    print STDERR "SUPPOSED TO BE DOWN: http://$host/\n";
  }
  delete $webs->{$host};
}

Alarm(0);
foreach my $host (keys %{ $webs }) {
  if (!ok !$webs->{$host}) {
    print STDERR "DOWN: http://$host/ [",($p->{bad}->{$host} || ""),"]\n";
  }
}

--- NEW FILE: 110_icmp_inst.t ---
# Test to make sure object can be instantiated for icmp protocol.
# Root access is required to actually perform icmp testing.

BEGIN {
  unless (eval "require Socket") {
    print "1..0 \# Skip: no Socket\n";
    exit;
  }
}

use Test;
use Net::Ping;
plan tests => 2;

# Everything loaded fine
ok 1;

if (($> and $^O ne 'VMS' and $^O ne 'cygwin')
    or ($^O eq 'MSWin32'
        and Win32::IsWinNT())
    or ($^O eq 'VMS'
        and (`write sys\$output f\$privilege("SYSPRV")` =~ m/FALSE/))) {
  skip "icmp ping requires root privileges.", 1;
} elsif ($^O eq 'MacOS') {
  skip "icmp protocol not supported.", 1;
} else {
  my $p = new Net::Ping "icmp";
  ok !!$p;
}

--- NEW FILE: 120_udp_inst.t ---
# Test to make sure object can be instantiated for udp protocol.
# I do not know of any servers that support udp echo anymore.

BEGIN {
  unless (eval "require Socket") {
    print "1..0 \# Skip: no Socket\n";
    exit;
  }
  unless (getservbyname('echo', 'udp')) {
    print "1..0 \# Skip: no echo port\n";
    exit;
  }
}

use Test;
use Net::Ping;
plan tests => 2;

# Everything loaded fine
ok 1;

my $p = new Net::Ping "udp";
ok !!$p;

--- NEW FILE: 100_load.t ---
# Before `make install' is performed this script should be runnable with
# `make test'. After `make install' it should work as `perl test.t'

######################### We start with some black magic to print on failure.

BEGIN {
  unless (eval "require Socket") {
    print "1..0 \# Skip: no Socket\n";
    exit;
  }
}

use Test;
BEGIN { plan tests => 1; $loaded = 0}
END { ok $loaded;}

# Just make sure everything compiles
use Net::Ping;

$loaded = 1;

######################### End of black magic.

# Insert your test code below (better if it prints "ok 13"
# (correspondingly "not ok 13") depending on the success of chunk 13
# of the test code):

--- NEW FILE: 410_syn_host.t ---
# 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;

my $can_alarm = eval {alarm 0; 1;};

sub Alarm {
  alarm(shift) if $can_alarm;
}

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);




More information about the dslinux-commit mailing list