lib/Net/Ping/t/410_syn_host.t

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