1# Test to perform icmp protocol testing.
2# Root access is required.
3# In the core test suite it calls itself via sudo -n (no password) to test it.
4
5use strict;
6use Config;
7
8use Test::More;
9use Net::Ping;
10use Cwd;
11use File::Spec;
12BEGIN {
13  unless (eval "require Socket;") {
14    plan skip_all => 'no Socket';
15  }
16  unless ($Config{d_getpbyname}) {
17    plan skip_all => 'no getprotobyname';
18  }
19}
20
21my $is_devel = $ENV{PERL_CORE} || -d ".git" ? 1 : 0;
22# Note this rawsocket test code is considered anti-social in p5p and was removed in
23# their variant.
24# See http://nntp.perl.org/group/perl.perl5.porters/240707
25# Problem is that ping_icmp needs root perms, and previous bugs were
26# never caught. So I rather execute it via sudo in the core test suite
27# and on devel CPAN dirs, than not at all and risk further bitrot of this API.
28if ( 0 && !Net::Ping::_isroot()) { # disable in blead via 7bfdd8260c
29    my $file = __FILE__;
30    my $lib = $ENV{PERL_CORE} ? '-I../../lib' : '-Mblib';
31    if ($is_devel and $Config{ccflags} =~ /fsanitize=address/ and $^O eq 'linux') {
32      plan skip_all => 'asan leak detector';
33    }
34    # -n prevents from asking for a password. rather fail then
35    # A technical problem is with leak-detectors, like asan, which
36    # require PERL_DESTRUCT_LEVEL=2 to be set in the root env.
37    my $env = "PERL_DESTRUCT_LEVEL=2";
38    if ($ENV{TEST_PING_HOST}) {
39      $env .= " TEST_PING_HOST=$ENV{TEST_PING_HOST}";
40    }
41    if ($ENV{PERL_CORE} && $Config{ldlibpthname}) {
42      my $up = File::Spec->updir();
43      my $dir = Cwd::abs_path(File::Spec->catdir($up, $up));
44      $env .= " $Config{ldlibpthname}=\"$dir\"";
45    }
46    if ($is_devel and
47        system("sudo -n $env \"$^X\" $lib $file") == 0)
48    {
49      exit;
50    } else {
51      plan skip_all => 'no sudo/failed';
52    }
53}
54
55SKIP: {
56  skip "icmp ping requires root privileges.", 2
57    if !Net::Ping::_isroot() or $^O eq 'MSWin32';
58  my $p = new Net::Ping "icmp";
59  is($p->message_type(), 'echo', "default icmp message type is 'echo'");
60  # message_type fails on wrong message type
61  eval {
62    $p->message_type('information');
63  };
64  like($@, qr/icmp message type are limited to 'echo' and 'timestamp'/, "Failure on wrong message type");
65  my $result = $p->ping("127.0.0.1");
66  if ($result == 1) {
67    is($result, 1, "icmp ping 127.0.0.1");
68  } else {
69  TODO: {
70      local $TODO = "localhost icmp firewalled?";
71      if (exists $ENV{TEST_PING_HOST}) {
72        my $result = $p->ping($ENV{TEST_PING_HOST});
73        is($result, 1, "icmp ping $ENV{TEST_PING_HOST}");
74      } else {
75        is($result, 1, "icmp ping 127.0.0.1");
76      }
77    }
78  }
79}
80
81done_testing;
82