Commit | Line | Data |
f569508e |
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 | |
69c74a9c |
40 | # Hopefully all these web ports are open |
f569508e |
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, |
69c74a9c |
47 | "127.0.0.1" => 1, |
f569508e |
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 | |
9c36735d |
58 | my $can_alarm = eval {alarm 0; 1;}; |
59 | |
60 | sub Alarm { |
61 | alarm(shift) if $can_alarm; |
62 | } |
63 | |
64 | Alarm(50); |
69c74a9c |
65 | $SIG{ALRM} = sub { |
66 | ok 0; |
67 | die "TIMED OUT!"; |
68 | }; |
69 | |
f569508e |
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 |
9c36735d |
82 | Alarm(50); # (Plenty for a DNS lookup) |
69c74a9c |
83 | if (!ok $p -> ping($host)) { |
84 | print STDERR "CANNOT RESOLVE $host $p->{bad}->{$host}\n"; |
f569508e |
85 | } |
86 | } |
87 | |
9c36735d |
88 | Alarm(20); |
f569508e |
89 | while (my $host = $p->ack()) { |
69c74a9c |
90 | if (!ok $webs->{$host}) { |
f569508e |
91 | print STDERR "SUPPOSED TO BE DOWN: http://$host/\n"; |
f569508e |
92 | } |
93 | delete $webs->{$host}; |
94 | } |
95 | |
9c36735d |
96 | Alarm(0); |
f569508e |
97 | foreach my $host (keys %{ $webs }) { |
69c74a9c |
98 | if (!ok !$webs->{$host}) { |
9c36735d |
99 | print STDERR "DOWN: http://$host/ [",($p->{bad}->{$host} || ""),"]\n"; |
f569508e |
100 | } |
101 | } |