lib/Net/Ping/t/400_ping_syn.t

   1 BEGIN {
   2   if ($ENV{PERL_CORE}) {
   3     unless ($ENV{PERL_TEST_Net_Ping}) {
   4       print "1..0 # Skip: network dependent test\n";
   5         exit;
   6     }
   7     chdir 't' if -d 't';
   8     @INC = qw(../lib);
   9   }
  10   unless (eval "require Socket") {
  11     print "1..0 \# Skip: no Socket\n";
  12     exit;
  13   }
  14   unless (getservbyname('echo', 'tcp')) {
  15     print "1..0 \# Skip: no echo port\n";
  16     exit;
  17   }
  18   unless (getservbyname('http', 'tcp')) {
  19     print "1..0 \# Skip: no http port\n";
  20     exit;
  21   }
  22 }
  23
  24 # Remote network test using syn protocol.
  25 #
  26 # NOTE:
  27 #   Network connectivity will be required for all tests to pass.
  28 #   Firewalls may also cause some tests to fail, so test it
  29 #   on a clear network.  If you know you do not have a direct
  30 #   connection to remote networks, but you still want the tests
  31 #   to pass, use the following:
  32 #
  33 # $ PERL_CORE=1 make test
  34
  35 # Try a few remote servers
  36 my $webs = {
  37   # Hopefully this is never a routeable host
  38   "172.29.249.249" => 0,
  39
  40   # Hopefully all these web ports are open
  41   "www.geocities.com." => 1,
  42   "www.freeservers.com." => 1,
  43   "yahoo.com." => 1,
  44   "www.yahoo.com." => 1,
  45   "www.about.com." => 1,
  46   "www.microsoft.com." => 1,
  47   "127.0.0.1" => 1,
  48 };
  49
  50 use strict;
  51 use Test;
  52 use Net::Ping;
  53 plan tests => ((keys %{ $webs }) * 2 + 3);
  54
  55 # Everything loaded fine
  56 ok 1;
  57
  58 my $can_alarm = eval {alarm 0; 1;};
  59
  60 sub Alarm {
  61   alarm(shift) if $can_alarm;
  62 }
  63
  64 Alarm(50);
  65 $SIG{ALRM} = sub {
  66   ok 0;
  67   die "TIMED OUT!";
  68 };
  69
  70 my $p = new Net::Ping "syn", 10;
  71
  72 # new() worked?
  73 ok !!$p;
  74
  75 # Change to use the more common web port.
  76 # (Make sure getservbyname works in scalar context.)
  77 ok ($p -> {port_num} = getservbyname("http", "tcp"));
  78
  79 foreach my $host (keys %{ $webs }) {
  80   # ping() does dns resolution and
  81   # only sends the SYN at this point
  82   Alarm(50); # (Plenty for a DNS lookup)
  83   if (!ok $p -> ping($host)) {
  84     print STDERR "CANNOT RESOLVE $host $p->{bad}->{$host}\n";
  85   }
  86 }
  87
  88 Alarm(20);
  89 while (my $host = $p->ack()) {
  90   if (!ok $webs->{$host}) {
  91     print STDERR "SUPPOSED TO BE DOWN: http://$host/\n";
  92   }
  93   delete $webs->{$host};
  94 }
  95
  96 Alarm(0);
  97 foreach my $host (keys %{ $webs }) {
  98   if (!ok !$webs->{$host}) {
  99     print STDERR "DOWN: http://$host/ [",($p->{bad}->{$host} || ""),"]\n";
 100   }
 101 }