petrbalvin/scripts
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
9455c65f108bebf74f1ebef002fee384b1b61bd0
scripts/network-diag.pl
T

1585 lines
56 KiB
Perl
Raw Normal View History

feat: initial release of the scripts collection
2026-09-10 04:00:00 +00:00
#!/usr/bin/env perl
# Copyright (c) 2026 Petr Balvín <opensource@petrbalvin.org> (https://petrbalvin.org)
# SPDX-License-Identifier: MIT
# Network diagnostics: latency, DNS, MTU, packet loss, dual-stack and port checks.
#
# Perl builtins only. No module is required to run this. The two capabilities
# that Perl no longer exposes as builtins are handled the way the rules prescribe:
#
# * Address arithmetic (inet_aton and its relatives moved into Socket) is
# hand-rolled below, in ip4_bytes and ip6_bytes.
# * Name resolution, sockets aside, is delegated to a system binary that speaks
# getaddrinfo, which keeps /etc/hosts, nsswitch and any caching resolver in the
# picture. getent is preferred and host, present in the FreeBSD base system and
# shipped with bind-utils on Linux, is the fallback. Which one is in use is
# probed at run time rather than assumed.
#
# One capability has no builtin substitute at all: a monotonic clock with
# millisecond resolution, which the TCP and DNS latency figures are measured with.
# Time::HiRes is therefore loaded opportunistically inside eval and never assumed.
# The measurement behind that caution: on Fedora, perl-Time-HiRes is its own RPM
# and is not among the requirements of perl-interpreter, so a bare perl need not
# have it. Where it is absent the report says the figure was not measured and the
# grade drops that component rather than inventing a number.
#
# External binaries used: ping, ip, ifconfig, netstat, ss, sockstat, sudo, getent
# or host, and uname.
#
# Linux and FreeBSD are supported in their current releases, with no branch for a
# superseded one: the unified ping that understands -4 and -6 is the only one
# driven here.
#
# Usage:
# network-diag.pl # full diagnostic
# network-diag.pl --target cloudflare.com # target a specific host
# network-diag.pl --protocol v4 # IPv4 only
# network-diag.pl --protocol v6 # IPv6 only
use strict;
use warnings;
my $VERSION = '2.0.0';
my $BOLD = "\033[1m";
my $RED = "\033[31m";
my $GREEN = "\033[32m";
my $YELLOW = "\033[33m";
my $DIM = "\033[2m";
my $RESET = "\033[0m";
# Well-known hosts for the connectivity tests, in report order.
my @CONNECTIVITY_HOSTS = (['cloudflare.com', 443], ['google.com', 443]);
# The optional clock. Loaded here, once, and guarded everywhere it is used.
my $HAVE_HIRES = eval { require Time::HiRes; 1 } ? 1 : 0;
# Socket constants. AF_INET6 is 10 on Linux and 28 on FreeBSD, the only two
# platforms this script supports; the other values are the same on both.
sub af_inet6 { return $^O eq 'freebsd' ? 28 : 10 }
my $AF_INET = 2;
my $SOCK_STREAM = 1;
my $IPPROTO_TCP = 6;
# Address families as the user names them.
my $FAMILY_LABEL = { v4 => 'IPv4', v6 => 'IPv6' };
my $TMP_DIR; # private scratch directory, created only when needed
my $PARENT_PID = $$; # forked children must never clean up for the parent
my $RESOLVER; # cached resolver transport: 'getent', 'host' or ''
my $RESOLVER_OVERHEAD; # measured start-up cost of that transport, in ms
# ---------------------------------------------------------------------------
# Small helpers
# ---------------------------------------------------------------------------
# Monotonic milliseconds source. Returns undef when no clock is available, and
# every caller then reports the figure as not measured instead of guessing.
sub now {
return $HAVE_HIRES ? Time::HiRes::time() : undef;
}
# One decimal place, as the report prints it.
sub round1 {
my ($value) = @_;
return sprintf('%.1f', $value);
}
sub detect_os {
return $^O eq 'freebsd' ? 'freebsd' : 'linux';
}
sub status {
my ($msg) = @_;
print STDERR " $msg...";
}
sub status_done {
my ($msg) = @_;
$msg = 'done' unless defined $msg;
print STDERR " $msg\n";
}
# A hand-rolled which(1): the system command is the transport, so the lookup
# itself must not need one.
sub find_exe {
my ($name) = @_;
return undef unless defined $name && length $name;
if (index($name, '/') >= 0) {
return (-f $name && -x _) ? $name : undef;
}
for my $dir (split /:/, ($ENV{PATH} // '')) {
next unless length $dir;
my $path = "$dir/$name";
return $path if -f $path && -x _;
}
return undef;
}
# Run a command, capturing stdout and stderr merged, with a timeout.
#
# The child is forked rather than opened as a pipe because the two streams have to
# be merged and a wedged process has to be killable, which the builtin pipe forms
# do not offer. The locale is forced to C because iputils translates its own
# output (under a Czech locale "time=" becomes "cas=" and the statistics line stops
# saying "transmitted"), and the whole report parses English. Returns the output
# and a status: 'ok', 'timeout' when the wait expired, or 'notfound' when the
# binary is missing, so callers can tell "tool unavailable" from "no output".
sub run {
my ($cmd, $timeout) = @_;
$timeout = 15 unless defined $timeout;
my $exe = find_exe($cmd->[0]);
return ('', 'notfound') unless defined $exe;
my ($rd, $wr);
pipe($rd, $wr) or die "cannot create a pipe: $!\n";
my $pid = fork();
die "cannot fork: $!\n" unless defined $pid;
if ($pid == 0) {
close($rd);
open(STDOUT, '>&', $wr) or exit 127;
open(STDERR, '>&', $wr) or exit 127;
close($wr);
$ENV{LANG} = 'C';
$ENV{LC_ALL} = 'C';
exec { $exe } @$cmd;
exit 127; # reached only when exec itself fails
}
close($wr);
my $out = '';
my $timed_out = 0;
eval {
local $SIG{ALRM} = sub { die "alarm\n" };
alarm($timeout);
local $/ = undef;
$out = <$rd>;
alarm(0);
1;
} or do { $timed_out = 1; alarm(0) };
$out = '' unless defined $out;
close($rd);
# Terminate the child, then reap it. A Term-ed process that ignores the
# signal is followed by a KILL, so the wait below cannot hang.
kill('TERM', $pid);
select(undef, undef, undef, 0.1);
kill('KILL', $pid);
waitpid($pid, 0);
my $exit_code = $? >> 8;
return ('', 'timeout') if $timed_out;
return ($out, 'notfound') if $exit_code == 127;
return ($out, 'ok');
}
# ---------------------------------------------------------------------------
# ICMP latency
# ---------------------------------------------------------------------------
# Per-reply latencies and the received counter, which differ between iputils and
# FreeBSD: "5 packets transmitted, 5 received" against "5 packets transmitted,
# 5 packets received". The counter is undef when no statistics line was seen, and
# callers then fall back to the number of parsed replies.
sub parse_ping_output {
my ($output) = @_;
my @latencies = $output =~ /time=(\d+(?:\.\d+)?)/g;
my $received;
for my $line (split /\n/, $output, -1) {
next unless index($line, 'transmitted') >= 0;
$received = $1 if $line =~ /(\d+)\s+(?:packets?\s+)?received/;
last;
}
return (\@latencies, $received);
}
sub min_max_sum {
my ($values) = @_;
my ($min, $max, $sum) = ($values->[0], $values->[0], 0);
for my $v (@$values) {
$min = $v if $v < $min;
$max = $v if $v > $max;
$sum += $v;
}
return ($min, $max, $sum);
}
# A standardised ping result. loss_pct comes from the received counter rather
# than from the number of parsed replies, which is the authoritative figure.
sub ping_result {
my ($host, $latencies, $received, $count, $protocol) = @_;
my $loss = $count > 0 ? round1(($count - $received) / $count * 100) : '100.0';
my %result = (
host => $host,
protocol => $protocol,
sent => $count,
received => $received,
loss_pct => $loss,
min_ms => '0.0',
avg_ms => '0.0',
max_ms => '0.0',
stddev_ms => '0.0',
);
if (@$latencies) {
my ($min, $max, $sum) = min_max_sum($latencies);
my $n = scalar @$latencies;
$result{min_ms} = round1($min);
$result{avg_ms} = round1($sum / $n);
$result{max_ms} = round1($max);
if ($n > 1) {
my $mean = $sum / $n;
my $sq = 0;
$sq += ($_ - $mean) ** 2 for @$latencies;
$result{stddev_ms} = round1(sqrt($sq / ($n - 1)));
}
}
return \%result;
}
# The ping command for an address family. Every supported release ships the
# unified ping that understands -4 and -6, so there is nothing to choose between.
sub ping_base_cmd {
my ($family) = @_;
return ['ping', ($family eq 'v6' ? '-6' : '-4')];
}
# Per-reply wait flag: iputils -W takes seconds, and FreeBSD ping -W takes
# milliseconds, which is the one difference between the two.
sub ping_wait_args {
my ($os_type, $timeout) = @_;
return $os_type eq 'freebsd' ? ['-W', $timeout * 1000] : ['-W', $timeout];
}
sub ping_host {
my ($host, $os_type, %opt) = @_;
my $count = $opt{count} // 5;
my $timeout = $opt{timeout} // 5;
my $protocol = $opt{protocol} // 'v4';
my $base = ping_base_cmd($protocol);
my @cmd = (@$base, '-c', $count, @{ping_wait_args($os_type, $timeout)}, '--', $host);
# The timeout must also cover the resolution ping does itself.
my ($out, $run_status) = run(\@cmd, $count + $timeout + 10);
if ($run_status eq 'notfound') {
my $result = ping_result($host, [], 0, $count, $protocol);
$result->{note} = "'$base->[0]' not found";
return $result;
}
my ($latencies, $parsed_received) = parse_ping_output($out);
my $received = defined $parsed_received ? $parsed_received : scalar @$latencies;
return ping_result($host, $latencies, $received, $count, $protocol);
}
# ---------------------------------------------------------------------------
# Address arithmetic, hand-rolled because Socket no longer shares it
# ---------------------------------------------------------------------------
# Dotted quad to four bytes, or undef when it is not a dotted quad.
sub ip4_bytes {
my ($ip) = @_;
my @octets = split /\./, $ip, -1;
return undef unless @octets == 4;
for my $octet (@octets) {
return undef unless $octet =~ /^\d{1,3}$/ && $octet <= 255;
}
return pack('C4', @octets);
}
# Textual IPv6 to sixteen bytes, or undef. Handles the :: shorthand and a
# trailing embedded IPv4 form, and ignores a zone suffix.
sub ip6_bytes {
my ($ip) = @_;
$ip =~ s/%.*//;
return undef unless $ip =~ /^[0-9a-fA-F:.]+$/ && index($ip, ':') >= 0;
my ($head, $tail) = ($ip, '');
my $shorthand = 0;
if (index($ip, '::') >= 0) {
($head, $tail) = split /::/, $ip, 2;
$shorthand = 1;
}
my @head = length($head // '') ? split(/:/, $head, -1) : ();
my @tail = length($tail // '') ? split(/:/, $tail, -1) : ();
if (@tail && $tail[-1] =~ /\./) {
my $quad = ip4_bytes(pop @tail);
return undef unless defined $quad;
my @words = unpack('n2', $quad);
push @tail, sprintf('%x', $words[0]), sprintf('%x', $words[1]);
}
return undef if @head + @tail > ($shorthand ? 7 : 8);
my @groups = $shorthand ? (@head, (0) x (8 - @head - @tail), @tail) : (@head, @tail);
return undef unless @groups == 8;
for my $group (@groups) {
return undef unless $group =~ /^[0-9a-fA-F]{1,4}$/;
}
return pack('n8', map { hex } @groups);
}
# Is this textual address an IPv4-mapped IPv6 one (::ffff:a.b.c.d)? glibc's
# ahostsv6 answers with a mapped address for a name that has no AAAA record, and
# connecting to it silently uses IPv4, so it must never be taken for IPv6.
sub is_mapped6 {
my ($addr) = @_;
my $bytes = ip6_bytes($addr);
return 0 unless defined $bytes;
# Twelve bytes: ten of zero, then the 0xffff marker.
return substr($bytes, 0, 12) eq ("\0" x 10) . "\xff\xff" ? 1 : 0;
}
# sockaddr_in and sockaddr_in6, packed by hand. Linux has a two-byte sin_family
# and no length field; FreeBSD has sin_len first and a one-byte family.
sub sa_in {
my ($ip, $port) = @_;
my $bytes = ip4_bytes($ip);
return undef unless defined $bytes;
return pack('S n a4 x8', $AF_INET, $port, $bytes);
}
sub sa_in6 {
my ($ip, $port) = @_;
my $bytes = ip6_bytes($ip);
return undef unless defined $bytes;
return $^O eq 'freebsd'
? pack('C C n N a16 N', 28, 28, $port, 0, $bytes, 0)
: pack('S n N a16 N', 10, $port, 0, $bytes, 0);
}
# Address classification, approximating the IANA tables: 'global' is what the
# report calls a globally scoped
# address, 'private' everything else that is still usable, and the remaining
# kinds are excluded from consideration entirely.
sub class4 {
my ($bytes) = @_;
my @o = unpack('C4', $bytes);
return 'loopback' if $o[0] == 127;
return 'linklocal' if $o[0] == 169 && $o[1] == 254;
return 'unspecified' if $o[0] == 0;
return 'multicast' if $o[0] >= 224 && $o[0] <= 239;
return 'private' if $o[0] >= 240;
return 'private' if $o[0] == 10;
return 'private' if $o[0] == 172 && $o[1] >= 16 && $o[1] <= 31;
return 'private' if $o[0] == 192 && $o[1] == 168;
return 'private' if $o[0] == 100 && $o[1] >= 64 && $o[1] <= 127;
return 'private' if $o[0] == 192 && $o[1] == 0 && $o[2] == 0;
return 'private' if $o[0] == 192 && $o[1] == 0 && $o[2] == 2;
return 'private' if $o[0] == 192 && $o[1] == 88 && $o[2] == 99;
return 'private' if $o[0] == 198 && ($o[1] == 18 || $o[1] == 19);
return 'private' if $o[0] == 198 && $o[1] == 51 && $o[2] == 100;
return 'private' if $o[0] == 203 && $o[1] == 0 && $o[2] == 113;
return 'global';
}
sub class6 {
my ($bytes) = @_;
my @w = unpack('n8', $bytes);
return 'unspecified' if !grep { $_ } @w;
# The parentheses matter: without them the && joins grep's list and the
# condition collapses, which reported other addresses as loopback.
return 'loopback' if !(grep { $_ } @w[0 .. 6]) && $w[7] == 1;
return 'mapped' if !(grep { $_ } @w[0 .. 4]) && $w[5] == 0xffff;
return 'linklocal' if ($w[0] & 0xffc0) == 0xfe80;
return 'multicast' if ($w[0] & 0xff00) == 0xff00;
return 'private' if ($w[0] & 0xfe00) == 0xfc00; # unique local
return 'private' if $w[0] == 0x2002; # 6to4
return 'private' if $w[0] == 0x2001 && $w[1] == 0x0000; # Teredo
return 'global';
}
# Usable addresses of one family from the collected interface data, globally
# scoped ones first. Loopback, link-local, unspecified and multicast addresses
# are dropped.
sub family_addresses {
my ($iface_info, $family) = @_;
my (@global, @other);
for my $iface (@{ $iface_info->{interfaces} // [] }) {
for my $raw (@{ $iface->{ips} // [] }) {
my $addr = $raw;
$addr =~ s{/.*$}{};
my $kind;
if ($family eq 'v6') {
next unless index($addr, ':') >= 0;
my $bytes = ip6_bytes($addr);
next unless defined $bytes;
$kind = class6($bytes);
next if $kind eq 'loopback' || $kind eq 'linklocal'
|| $kind eq 'unspecified' || $kind eq 'multicast';
}
else {
next if index($addr, ':') >= 0;
my $bytes = ip4_bytes($addr);
next unless defined $bytes;
$kind = class4($bytes);
next if $kind eq 'loopback' || $kind eq 'linklocal'
|| $kind eq 'unspecified' || $kind eq 'multicast';
}
push @{ $kind eq 'global' ? \@global : \@other }, $addr;
}
}
return (@global, @other);
}
sub address_kind {
my ($family, $addr) = @_;
my $bytes = $family eq 'v6' ? ip6_bytes($addr) : ip4_bytes($addr);
return '' unless defined $bytes;
return $family eq 'v6' ? class6($bytes) : class4($bytes);
}
# ---------------------------------------------------------------------------
# Interfaces
# ---------------------------------------------------------------------------
sub interface_info {
my ($os_type) = @_;
my %info = (
interfaces => [],
default_route_v4 => '',
default_route_v6 => '',
error => '',
);
return interface_info_freebsd(\%info) if $os_type eq 'freebsd';
return interface_info_linux(\%info);
}
sub interface_info_linux {
my ($info) = @_;
my ($out, $run_status) = run(['ip', '-br', 'addr', 'show']);
if ($run_status eq 'notfound') {
$info->{error} = "'ip' not found";
return $info;
}
for my $line (split /\n/, $out, -1) {
my @parts = split ' ', $line;
next if @parts < 2 || $parts[0] eq 'lo';
push @{ $info->{interfaces} }, {
name => $parts[0],
state => $parts[1],
ips => [ @parts[2 .. $#parts] ],
};
}
for my $item (['-4', 'default_route_v4'], ['-6', 'default_route_v6']) {
my ($family_flag, $key) = @$item;
my ($route, $route_status) = run(['ip', $family_flag, 'route', 'show', 'default']);
next unless $route_status eq 'ok';
my @parts = split ' ', $route;
for my $i (0 .. $#parts) {
next unless $parts[$i] eq 'via' && $i + 1 <= $#parts;
$info->{$key} = $parts[$i + 1];
last;
}
}
return $info;
}
sub interface_info_freebsd {
my ($info) = @_;
my ($iflist, $list_status) = run(['ifconfig', '-l']);
if ($list_status eq 'notfound') {
$info->{error} = "'ifconfig' not found";
return $info;
}
my @names = split ' ', $iflist;
return $info unless @names;
for my $name (@names) {
next if $name eq 'lo0';
my ($out, $run_status) = run(['ifconfig', $name]);
next unless $run_status eq 'ok';
my @lines = split /\n/, $out, -1;
next unless @lines && length $lines[0];
my $state = (index($lines[0], '<UP,') >= 0 || index($lines[0], '<UP>') >= 0)
? 'UP' : 'DOWN';
my @ips;
for my $line (@lines[1 .. $#lines]) {
my $stripped = $line;
$stripped =~ s/^\s+//;
$stripped =~ s/\s+$//;
if ($stripped =~ /^inet /) {
my @parts = split ' ', $stripped;
push @ips, $parts[1] if @parts >= 2 && $parts[1] ne '127.0.0.1';
}
elsif ($stripped =~ /^inet6 /) {
my @parts = split ' ', $stripped;
next if @parts < 2;
my $addr = $parts[1];
$addr =~ s/%.*//;
next if $addr =~ /^fe80:/ || $addr eq '::1';
push @ips, $addr;
}
}
push @{ $info->{interfaces} }, { name => $name, state => $state, ips => \@ips };
}
my ($route, $route_status) = run(['netstat', '-rn']);
return $info unless $route_status eq 'ok';
for my $line (split /\n/, $route, -1) {
next unless $line =~ /^default/;
my @parts = split ' ', $line;
next if @parts < 2;
my $gateway = $parts[1];
$gateway =~ s/%.*//;
if (index($gateway, ':') >= 0) {
$info->{default_route_v6} = $gateway unless $info->{default_route_v6};
}
elsif (!$info->{default_route_v4}) {
$info->{default_route_v4} = $gateway;
}
}
return $info;
}
# ---------------------------------------------------------------------------
# Name resolution
# ---------------------------------------------------------------------------
# The transport is probed once: getent implements getaddrinfo directly, so it is
# preferred, and host is the fallback for systems without the ahosts databases.
sub resolver_transport {
return $RESOLVER if defined $RESOLVER;
$RESOLVER = '';
if (defined find_exe('getent')) {
my ($out, $run_status) = run(['getent', 'ahostsv4', 'localhost']);
$RESOLVER = 'getent' if $run_status eq 'ok' && index($out, 'localhost') >= 0;
}
$RESOLVER = 'host' if !$RESOLVER && defined find_exe('host');
return $RESOLVER;
}
# Resolve a name for one address family, in resolver order, with IPv4-mapped
# answers excluded. An empty list means the name has no address of that family.
sub resolve_family {
my ($host, $family) = @_;
my $transport = resolver_transport();
return () if $transport eq '';
if ($transport eq 'getent') {
my ($out, $run_status) = run(['getent', $family eq 'v6' ? 'ahostsv6' : 'ahostsv4', $host]);
return () unless $run_status eq 'ok';
my @addrs;
for my $line (split /\n/, $out, -1) {
my @parts = split ' ', $line;
next unless @parts >= 2 && $parts[1] eq 'STREAM';
next if is_mapped6($parts[0]);
push @addrs, $parts[0];
}
return @addrs;
}
my ($out, $run_status) = run(['host', '-W', 3, '-t', $family eq 'v6' ? 'AAAA' : 'A', $host]);
return () unless $run_status eq 'ok';
my @addrs;
for my $line (split /\n/, $out, -1) {
if ($family eq 'v6') {
push @addrs, $1 if $line =~ /\bhas IPv6 address (\S+)/;
}
else {
push @addrs, $1 if $line =~ /\bhas address (\S+)/;
}
}
return @addrs;
}
# The resolver runs as a separate process, so its start-up cost sits inside every
# sample taken around it. That cost is measured once against a name that never
# leaves the machine and subtracted, leaving the resolution itself. The
# subtraction is conservative: the calibration name is answered from the hosts
# file and so never exercises the code path a network query goes through, which
# leaves a residual measured at about 3 ms per sample on this workstation. That
# residual is a fraction of the 20 ms that separates one DNS score from the next,
# so it does not move the grade, and it is recorded rather than hidden because
# the figure is not exact.
sub resolver_overhead {
return $RESOLVER_OVERHEAD if defined $RESOLVER_OVERHEAD;
$RESOLVER_OVERHEAD = 0;
return 0 unless $HAVE_HIRES && resolver_transport() ne '';
my @samples;
for (1 .. 5) {
my $start = now();
my @ignored = resolve_family('localhost', 'v4');
push @samples, (now() - $start) * 1000;
}
@samples = sort { $a <=> $b } @samples;
$RESOLVER_OVERHEAD = $samples[int(@samples / 2)];
return $RESOLVER_OVERHEAD;
}
sub dns_samples {
my ($domain, $family) = @_;
# One untimed resolution first. The resolver's machinery, an NSS module for
# instance, is loaded once per process, and letting the first sample pay for
# that would report the loader instead of the resolver. Measured here: the
# first AAAA sample taken in a fresh process cost 37 ms against 3 ms for the
# rest, because the calibration below resolves a name that never reaches the
# module in question.
my @warm_up = resolve_family($domain, $family);
my @results;
for (1 .. 3) {
my $start = now();
my @addrs = resolve_family($domain, $family);
my $ms;
if (defined $start) {
$ms = (now() - $start) * 1000 - resolver_overhead();
$ms = 0 if $ms < 0;
}
my %sample = (ip => (@addrs ? $addrs[0] : 'N/A'));
$sample{ms} = defined $ms ? round1($ms) : -1;
push @results, \%sample;
}
return \@results;
}
# The machine's own name, and its fully qualified form. The hostname comes from
# uname; the qualified name is only chased when the short name carries no dot.
sub check_hostname {
my ($out, $run_status) = run(['uname', '-n']);
my $name = $run_status eq 'ok' ? $out : '';
$name =~ s/\s+$//;
return $name;
}
sub check_fqdn {
my ($name) = @_;
return '' unless length $name;
return $name if index($name, '.') >= 0;
my ($canonical, $aliases, $addrtype, $length, @addresses) = gethostbyname($name);
return $name unless @addresses;
my ($reverse, $r_aliases) = gethostbyaddr($addresses[0], $AF_INET);
return $name unless defined $reverse && index($reverse, '.') >= 0;
return $reverse;
}
sub check_dns {
my ($protocol) = @_;
my $hostname = check_hostname();
my %info = (
hostname => $hostname,
fqdn => check_fqdn($hostname),
resolvers => [],
v4 => {},
v6 => {},
);
# Without a clock the latency column has nothing to report, and the grade
# leaves that component out rather than scoring a figure that was not taken.
$info{no_clock} = 1 unless $HAVE_HIRES;
for my $entry (@CONNECTIVITY_HOSTS) {
my $domain = $entry->[0];
$info{v6}{$domain} = dns_samples($domain, 'v6') if $protocol ne 'v4';
$info{v4}{$domain} = dns_samples($domain, 'v4') if $protocol ne 'v6';
}
if (open(my $fh, '<', '/etc/resolv.conf')) {
while (my $line = <$fh>) {
next unless $line =~ /^nameserver/;
my @parts = split ' ', $line;
push @{ $info{resolvers} }, $parts[1] if @parts >= 2;
}
close($fh);
}
return \%info;
}
# ---------------------------------------------------------------------------
# TCP reachability
# ---------------------------------------------------------------------------
# A TCP handshake to one host over one family. Candidates are tried in resolver
# order and the first success wins; the timing covers the connect alone.
sub tcp_probe {
my ($host, $port, $family) = @_;
my @addrs = resolve_family($host, $family);
return { reachable => 0 } unless @addrs;
for my $addr (@addrs) {
my $sockaddr = $family eq 'v6' ? sa_in6($addr, $port) : sa_in($addr, $port);
next unless defined $sockaddr;
my $family_const = $family eq 'v6' ? af_inet6() : $AF_INET;
socket(my $sock, $family_const, $SOCK_STREAM, $IPPROTO_TCP) or next;
my $start = now();
my $connected = 0;
eval {
local $SIG{ALRM} = sub { die "alarm\n" };
alarm(5);
$connected = connect($sock, $sockaddr);
alarm(0);
1;
} or do { $connected = 0; alarm(0) };
my $ms = defined $start ? round1((now() - $start) * 1000) : undef;
close($sock);
next unless $connected;
my %result = (reachable => 1, ip => $addr);
$result{ms} = $ms if defined $ms;
return \%result;
}
return { reachable => 0 };
}
# TCP handshake probes to well-known hosts over both families, IPv6 first. This
# is the only place TCP probes are made; the per-family reachability sections
# reuse these results. A family excluded with --protocol is left empty, so the
# reachability section and the grade skip it instead of penalising a probe the
# user asked not to make.
sub check_connectivity {
my ($protocol) = @_;
my %info = (v4 => {}, v6 => {});
for my $entry (@CONNECTIVITY_HOSTS) {
my ($host, $port) = @$entry;
$info{v6}{$host} = tcp_probe($host, $port, 'v6') if $protocol ne 'v4';
$info{v4}{$host} = tcp_probe($host, $port, 'v4') if $protocol ne 'v6';
}
return \%info;
}
# The best address for the target over one family, preferring IPv6, together with
# the family it belongs to. Resolving here rather than letting ping decide keeps
# the family deterministic, which the MTU header arithmetic depends on.
sub resolve_probe_target {
my ($target, $protocol) = @_;
my @order = $protocol eq 'auto' ? ('v6', 'v4') : ($protocol);
for my $family (@order) {
my @addrs = resolve_family($target, $family);
return ($family, $addrs[0]) if @addrs;
}
return (undef, undef);
}
# ---------------------------------------------------------------------------
# Path MTU
# ---------------------------------------------------------------------------
# A DF probe walk from 1500 downwards over one family. Success is a parsed
# reply, and header sizes are per family: 28 bytes for IPv4, 48 for IPv6. Every
# failure falls through to the next size, whether it was a definitive "too big"
# answer or a timeout. Returns the largest size that drew a reply (0 when none
# did) and, when the ping binary itself is missing, the method note for it.
sub mtu_probe_walk {
my ($addr, $family, $os_type) = @_;
my $header = $family eq 'v6' ? 48 : 28;
my $base = ping_base_cmd($family);
my @df_args = $os_type eq 'freebsd' ? ('-D') : ('-M', 'do');
my @wait_args = @{ ping_wait_args($os_type, 2) };
for my $size (1500, 1400, 1300, 1280, 1200, 1000) {
my $payload = $size - $header;
my @cmd = (@$base, @df_args, '-c', 1, @wait_args, '-s', $payload, '--', $addr);
my ($out, $run_status) = run(\@cmd, 12);
return (0, "'$base->[0]' not found") if $run_status eq 'notfound';
my ($latencies, $received) = parse_ping_output($out);
return ($size, undef) if defined $received && $received > 0;
}
return (0, undef);
}
sub check_mtu {
my ($target, $protocol, $os_type) = @_;
my %info = (path_mtu => 0, target => $target, method => '');
my %family_label = (v4 => 'IPv4', v6 => 'IPv6');
my ($family, $addr) = resolve_probe_target($target, $protocol);
if (!defined $family) {
$info{method} = 'target did not resolve';
return \%info;
}
my ($size, $missing) = mtu_probe_walk($addr, $family, $os_type);
if (defined $missing) {
$info{method} = $missing;
return \%info;
}
# A name that resolves over the preferred family but has no route there must
# not read as a missing path MTU: with --protocol auto the other family gets
# the same walk before the section gives up. An explicit --protocol keeps
# the single family the user asked for.
if (!$size && $protocol eq 'auto') {
my $other = $family eq 'v6' ? 'v4' : 'v6';
my @addrs = resolve_family($target, $other);
if (@addrs) {
my ($alt_size, $alt_missing) = mtu_probe_walk($addrs[0], $other, $os_type);
if (defined $alt_missing) {
$info{method} = $alt_missing;
return \%info;
}
if ($alt_size) {
$info{path_mtu} = $alt_size;
$info{method} = "ping DF probe (${alt_size}B OK, $family_label{$other} fallback)";
return \%info;
}
}
}
if ($size) {
$info{path_mtu} = $size;
$info{method} = "ping DF probe (${size}B OK)";
}
else {
$info{method} = 'ping DF probe (no probe size succeeded)';
}
return \%info;
}
# ---------------------------------------------------------------------------
# Listening ports
# ---------------------------------------------------------------------------
sub parse_ss_output {
my ($out) = @_;
my @lines = split /\n/, $out, -1;
shift @lines; # header
my @entries;
for my $line (@lines) {
next unless index($line, 'LISTEN') >= 0;
my @parts = split ' ', $line;
next if @parts < 5;
# State Recv-Q Send-Q LocalAddress:Port PeerAddress:Port Process
my $local = $parts[3];
push @entries, {
addr => $local,
# A process name may contain a space, so the tail is joined whole.
process => (@parts > 5 ? join(' ', @parts[5 .. $#parts]) : ''),
# IPv6 sockets are written in bracket notation, [::]:port
bucket => index($local, '[') == 0 ? 'tcp6' : 'tcp4',
};
}
return @entries;
}
sub listening_ports {
my ($os_type) = @_;
return listening_ports_freebsd() if $os_type eq 'freebsd';
return listening_ports_linux();
}
sub listening_ports_linux {
my %info = (tcp4 => [], tcp6 => [], tcp46 => [], error => '');
my ($out, $run_status) = run(['ss', '-tlnp'], 5);
if ($run_status eq 'notfound') {
$info{error} = "'ss' not found";
return \%info;
}
my @entries = parse_ss_output($out);
# Ports owned by other users come back without a process name; sudo without a
# password prompt fills those in where it can.
if (grep { $_->{process} eq '' } @entries) {
my ($sudo_out, $sudo_status) = run(['sudo', '-n', 'ss', '-tlnp'], 5);
if ($sudo_status eq 'ok' && length $sudo_out) {
my %by_addr;
$by_addr{ $_->{addr} } = $_ for parse_ss_output($sudo_out);
for my $entry (@entries) {
next unless $entry->{process} eq '' && exists $by_addr{ $entry->{addr} };
$entry->{process} = $by_addr{ $entry->{addr} }{process};
}
}
}
for my $entry (@entries) {
my $process = length $entry->{process} ? $entry->{process} : '(no permission)';
push @{ $info{ $entry->{bucket} } }, { addr => $entry->{addr}, process => $process };
}
return \%info;
}
sub listening_ports_freebsd {
my %info = (tcp4 => [], tcp6 => [], tcp46 => [], error => '');
my ($out, $run_status) = run(['sockstat', '-l4', '-l6'], 5);
if ($run_status eq 'notfound') {
$info{error} = "'sockstat' not found";
return \%info;
}
my @lines = split /\n/, $out, -1;
shift @lines; # header
for my $line (@lines) {
my @parts = split ' ', $line;
next if @parts < 6;
my $proto = $parts[4]; # tcp4, tcp6, or tcp46 for a dual-stack socket
next unless $proto eq 'tcp4' || $proto eq 'tcp6' || $proto eq 'tcp46';
push @{ $info{$proto} }, { addr => $parts[5], process => $parts[1] };
}
return \%info;
}
# ---------------------------------------------------------------------------
# Reachability sections
# ---------------------------------------------------------------------------
sub reachability_report {
my ($family, $iface_info, $probes) = @_;
my @addresses = family_addresses($iface_info, $family);
my $best = $addresses[0];
return {
available => defined $best ? 1 : 0,
addr => defined $best ? $best : '',
is_global => defined $best && address_kind($family, $best) eq 'global' ? 1 : 0,
test_sites => $probes,
};
}
# ---------------------------------------------------------------------------
# Grade
# ---------------------------------------------------------------------------
sub grade_letter {
my ($pct) = @_;
return 'A' if $pct >= 90;
return 'B' if $pct >= 80;
return 'C' if $pct >= 70;
return 'D' if $pct >= 60;
return 'F';
}
# Five components of twenty points each: packet loss, latency, DNS speed, IPv4
# reachability and IPv6 support. A component that was not measured, because the
# family was excluded with --protocol or because no clock was available, is
# removed from the maximum, so the letter grades the achievable points.
sub compute_grade {
my ($data) = @_;
my $score = 0;
my %breakdown;
my $ping = $data->{ping} // {};
my $loss = $ping->{loss_pct} // 100;
my $loss_score =
$loss <= 0 ? 20
: $loss <= 5 ? 15
: $loss <= 10 ? 10
: $loss <= 30 ? 5
: 0;
$breakdown{packet_loss} = $loss_score;
$score += $loss_score;
my $avg_ms = $ping->{avg_ms} // 0;
my $latency_score =
$avg_ms <= 0 ? 0
: $avg_ms < 30 ? 20
: $avg_ms < 80 ? 15
: $avg_ms < 150 ? 10
: $avg_ms < 300 ? 5
: 0;
$breakdown{latency} = $latency_score;
$score += $latency_score;
my $max_score = 100;
my $dns = $data->{dns} // {};
my $dns_score = 0;
if ($dns->{no_clock}) {
$max_score -= 20;
}
else {
my ($samples, $total) = (0, 0);
for my $family ('v6', 'v4') {
for my $domain (keys %{ $dns->{$family} // {} }) {
for my $sample (@{ $dns->{$family}{$domain} }) {
next unless $sample->{ms} > 0;
$samples++;
$total += $sample->{ms};
}
}
}
if ($samples > 0) {
my $average = $total / $samples;
$dns_score =
$average < 20 ? 20
: $average < 50 ? 15
: $average < 100 ? 10
: $average < 200 ? 5
: 0;
}
}
$breakdown{dns_speed} = $dns_score;
$score += $dns_score;
my $ipv4 = $data->{ipv4} // {};
my $v4_score = 0;
if ($ipv4->{skipped}) {
$max_score -= 20;
}
elsif ($ipv4->{available}) {
$v4_score += 10;
my $reachable = grep { $_->{reachable} } values %{ $ipv4->{test_sites} // {} };
$v4_score += $reachable * 5 > 10 ? 10 : $reachable * 5;
}
$breakdown{ipv4_reachability} = $v4_score;
$score += $v4_score;
my $ipv6 = $data->{ipv6} // {};
my $v6_score = 0;
if ($ipv6->{skipped}) {
$max_score -= 20;
}
elsif ($ipv6->{available}) {
$v6_score += 10;
my $reachable = grep { $_->{reachable} } values %{ $ipv6->{test_sites} // {} };
$v6_score += $reachable * 5 > 10 ? 10 : $reachable * 5;
}
$breakdown{ipv6_dualstack} = $v6_score;
$score += $v6_score;
my $pct = $max_score > 0 ? sprintf('%.0f', $score * 100 / $max_score) : 0;
my $letter = grade_letter($pct);
my $colour = ($letter eq 'A' || $letter eq 'B') ? $GREEN
: ($letter eq 'C' || $letter eq 'D') ? $YELLOW
: $RED;
return {
grade => $letter,
score => $score,
max_score => $max_score,
colour => $colour,
breakdown => \%breakdown,
};
}
# ---------------------------------------------------------------------------
# Report
# ---------------------------------------------------------------------------
sub ms_colour {
my ($ms) = @_;
return $DIM if !defined $ms || $ms <= 0;
return $GREEN if $ms < 50;
return $YELLOW if $ms < 200;
return $RED;
}
sub print_ping_block {
my ($label, $info) = @_;
return unless ref $info eq 'HASH';
if (($info->{received} // 0) == 0) {
my $note = $info->{note} // $info->{error} // '';
my $suffix = length $note ? " ($note)" : '';
print " $label: ${RED}no response$suffix$RESET\n";
return;
}
my $loss = $info->{loss_pct} // 0;
my $loss_colour = $loss > 10 ? $RED : $loss > 0 ? $YELLOW : $GREEN;
my $avg = $info->{avg_ms} // 0;
my $latency_colour = ms_colour($avg);
printf " %s: %s/%s received Loss: %s%.1f%%%s Avg: %s%.1fms%s Min/Max: %.1f/%.1fms σ: %.1fms\n",
$label,
$info->{sent} // 0, $info->{received} // 0,
$loss_colour, $loss, $RESET,
$latency_colour, $avg, $RESET,
$info->{min_ms} // 0, $info->{max_ms} // 0,
$info->{stddev_ms} // 0;
}
sub print_reachability {
my ($family, $info) = @_;
return unless ref $info eq 'HASH';
my $label = $FAMILY_LABEL->{$family};
if ($info->{skipped}) {
my $protocol_note = $family eq 'v6' ? '--protocol v4' : '--protocol v6';
print " ${DIM}○$RESET $label reachability skipped ($protocol_note)\n";
return;
}
if (!$info->{available}) {
print " ${YELLOW}○$RESET No $label address detected on any interface\n";
return;
}
my $scope = $info->{is_global} ? 'Global' : 'Private';
print " ${GREEN}✓$RESET $scope $label address: $info->{addr}\n";
my $suffix = $family eq 'v6' ? ' over IPv6' : '';
for my $entry (@CONNECTIVITY_HOSTS) {
my $site = $entry->[0];
my $result = $info->{test_sites}{$site};
next unless ref $result eq 'HASH';
if ($result->{reachable}) {
printf " %s✓%s %-20s %sms (%s)\n",
$GREEN, $RESET, $site, round1($result->{ms} // 0), $result->{ip} // '';
}
else {
print " ${RED}✗$RESET ", sprintf('%-20s', $site), " unreachable$suffix\n";
}
}
}
sub print_report {
my ($data) = @_;
my $grade_info = $data->{grade} // {};
my $grade_letter = $grade_info->{grade} // '?';
my $grade_colour = $grade_info->{colour} // $RESET;
my $bar = "═" x 60;
# Header
my $os_label = ucfirst($data->{os} // 'linux');
print "\n${BOLD}${bar}$RESET\n";
print "${BOLD} Network Diagnostics v$VERSION ($os_label)$RESET\n";
print "${BOLD}${bar}$RESET\n";
print " Hostname: $data->{hostname}\n";
print " Protocol: ", ($data->{protocol} // 'auto'), "\n";
print " Summary Grade: ${grade_colour}${BOLD}${grade_letter}$RESET ",
"(", ($grade_info->{score} // '?'), "/", ($grade_info->{max_score} // 100), ")\n";
# Interfaces
print "\n${BOLD}── Interfaces ──$RESET\n";
my $iface = $data->{interfaces} // {};
print " ${DIM}unavailable: $iface->{error}$RESET\n" if $iface->{error};
for my $entry (@{ $iface->{interfaces} // [] }) {
my $state_colour = $entry->{state} eq 'UP' ? $GREEN : $RED;
printf " %-8s %s%-5s%s %s\n",
$entry->{name}, $state_colour, $entry->{state}, $RESET,
join(', ', @{ $entry->{ips} // [] });
}
print " Default IPv6 route → $iface->{default_route_v6}\n" if $iface->{default_route_v6};
print " Default IPv4 route → $iface->{default_route_v4}\n" if $iface->{default_route_v4};
# Internet connectivity
print "\n${BOLD}── Internet Connectivity ──$RESET\n";
my $conn = $data->{connectivity} // {};
if ($conn->{error}) {
print " ${DIM}unavailable: $conn->{error}$RESET\n";
}
elsif (%$conn) {
for my $item (['IPv6', 'v6'], ['IPv4', 'v4']) {
my ($family_label, $family) = @$item;
my $family_probes = ref $conn->{$family} eq 'HASH' ? $conn->{$family} : {};
my @parts;
for my $entry (@CONNECTIVITY_HOSTS) {
my $host = $entry->[0];
my $result = $family_probes->{$host};
next unless ref $result eq 'HASH';
if ($result->{reachable}) {
my $ms = $result->{ms};
if (defined $ms) {
push @parts, sprintf("%s✓%s %s %s%.0fms%s", $GREEN, $RESET, $host, ms_colour($ms), $ms, $RESET);
}
else {
push @parts, sprintf("%s✓%s %s", $GREEN, $RESET, $host);
}
}
else {
push @parts, sprintf("%s✗%s %s", $RED, $RESET, $host);
}
}
my $hosts_line = @parts ? join(', ', @parts) : "${DIM}(none)$RESET";
print " $family_label: $hosts_line\n";
}
}
# Latency
print "\n${BOLD}── Latency (ICMP ping) ──$RESET\n";
print_ping_block('IPv6', $data->{ping_v6});
print_ping_block('IPv4', $data->{ping_v4});
# DNS
print "\n${BOLD}── DNS Resolution ──$RESET\n";
my $dns = $data->{dns} // {};
if ($dns->{error}) {
print " ${DIM}unavailable: $dns->{error}$RESET\n";
}
elsif (%$dns) {
print " FQDN: ", ($dns->{fqdn} // '?'), "\n";
print " Resolvers: ", join(', ', @{ $dns->{resolvers} // [] }), "\n" if @{ $dns->{resolvers} // [] };
print " ${DIM}latency not measured: no millisecond clock available$RESET\n" if $dns->{no_clock};
for my $item (['AAAA (IPv6)', 'v6'], ['A (IPv4)', 'v4']) {
my ($family_label, $family) = @$item;
my $domains = $dns->{$family} // {};
next unless %$domains;
print " ${BOLD}${family_label}:$RESET\n";
for my $entry (@CONNECTIVITY_HOSTS) {
my $domain = $entry->[0];
my $results = $domains->{$domain};
next unless ref $results eq 'ARRAY';
my @valid = grep { $_->{ms} > 0 } @$results;
my $average = @valid ? (eval { my $t = 0; $t += $_->{ms} for @valid; $t / scalar @valid }) : 0;
my $colour = ms_colour($average);
my @ips = grep { $_->{ip} ne 'N/A' } @$results;
my $ip_str = @ips ? $ips[0]{ip} : 'N/A';
if ($dns->{no_clock}) {
printf " %-25s → %s\n", $domain, $ip_str;
}
else {
printf " %-25s → %s%-18s%s %.0fms\n",
$domain, $colour, $ip_str, $RESET, $average;
}
}
}
}
# Reachability
print "\n${BOLD}── IPv6 Reachability ──$RESET\n";
print_reachability('v6', $data->{ipv6});
print "\n${BOLD}── IPv4 Reachability ──$RESET\n";
print_reachability('v4', $data->{ipv4});
# Path MTU
print "\n${BOLD}── Path MTU ──$RESET\n";
my $mtu = $data->{mtu} // {};
if (%$mtu) {
if ($mtu->{path_mtu}) {
my $colour = $mtu->{path_mtu} < 1500 ? $YELLOW : $GREEN;
print " ${colour}$mtu->{path_mtu}B$RESET (", ($mtu->{method} // ''), ")\n";
}
elsif ($mtu->{method}) {
print " ${DIM}$mtu->{method}$RESET\n";
}
elsif ($mtu->{error}) {
print " ${DIM}unavailable: $mtu->{error}$RESET\n";
}
}
# Listening ports
print "\n${BOLD}── Listening Ports ──$RESET\n";
my $ports = $data->{listening} // {};
if (%$ports) {
if ($ports->{error}) {
print " ${DIM}unavailable: $ports->{error}$RESET\n";
}
else {
my $total = 0;
$total += scalar @{ $ports->{$_} } for grep { ref $ports->{$_} eq 'ARRAY' } keys %$ports;
if ($total > 0) {
for my $version ('tcp6', 'tcp4', 'tcp46') {
for my $entry (@{ $ports->{$version} // [] }) {
printf " %s %-22s %s%s%s\n", $version, $entry->{addr}, $DIM, $entry->{process}, $RESET;
}
}
}
else {
print " (none)\n";
}
}
}
# Grade breakdown
print "\n${BOLD}── Grade Breakdown ──$RESET\n";
my $breakdown = $grade_info->{breakdown} // {};
my @labels = (
['packet_loss', 'Packet loss'],
['latency', 'Latency'],
['dns_speed', 'DNS speed'],
['ipv6_dualstack', 'IPv6 / dual-stack'],
['ipv4_reachability', 'IPv4 reachability'],
);
for my $item (@labels) {
my ($key, $label) = @$item;
my $points = $breakdown->{$key} // 0;
my $filled = int($points / 2);
my $bar_line = ("█" x $filled) . ("░" x (10 - $filled));
printf " %-20s %s %s/20\n", $label, $bar_line, $points;
}
# Footer
print "\n${BOLD}${bar}$RESET\n";
print " ${BOLD}Overall Grade: ${grade_colour}${grade_letter}$RESET ";
print "(", ($grade_info->{score} // '?'), "/", ($grade_info->{max_score} // 100), ")\n";
print "${BOLD}${bar}$RESET\n\n";
}
# ---------------------------------------------------------------------------
# Parallel collection
# ---------------------------------------------------------------------------
# The checks are independent and each is dominated by waiting, so they run as
# forked children, one per check. A child writes its result as a Perl literal
# into the private scratch directory and the parent reads it back once the child
# has been reaped, because the builtin pipe forms give no way to collect several
# results without a select loop over them. Progress lines appear in completion
# order.
sub scratch_dir {
return $TMP_DIR if defined $TMP_DIR;
# An empty TMPDIR counts as unset: an empty base would place the scratch
# directory at the filesystem root, where a root run would even succeed.
my $base = defined $ENV{TMPDIR} && length $ENV{TMPDIR} ? $ENV{TMPDIR} : '/tmp';
for my $attempt (0 .. 9) {
my $dir = "$base/network-diag.$$" . ($attempt ? ".$attempt" : '');
# mkdir is atomic and refuses to follow a symlink, so a hostile entry in a
# shared /tmp cannot redirect the writes.
if (mkdir($dir, 0700)) {
$TMP_DIR = $dir;
return $dir;
}
}
die "cannot create a scratch directory under $base\n";
}
sub remove_scratch {
return unless defined $TMP_DIR;
# Every forked child inherits the END block, so removal is restricted to the
# process that created the directory. Without this the first child to finish
# would delete the result files its siblings have yet to write.
return unless $$ == $PARENT_PID;
if (opendir(my $dh, $TMP_DIR)) {
for my $entry (readdir($dh)) {
next if $entry eq '.' || $entry eq '..';
unlink("$TMP_DIR/$entry");
}
closedir($dh);
}
rmdir($TMP_DIR);
undef $TMP_DIR;
}
# A value as Perl source, which is what the parent eval's back. Only the
# characters a single-quoted string cannot carry are escaped.
sub perl_literal {
my ($value) = @_;
return 'undef' unless defined $value;
if (ref $value eq 'HASH') {
return '{ ' . join(', ', map { perl_literal($_) . ' => ' . perl_literal($value->{$_}) }
sort keys %$value) . ' }';
}
if (ref $value eq 'ARRAY') {
return '[' . join(', ', map { perl_literal($_) } @$value) . ']';
}
return $value if !ref $value && $value =~ /^-?(?:0|[1-9][0-9]*)(?:\.[0-9]+)?$/;
my $text = $value;
$text =~ s/([\\'])/\\$1/g;
return "'$text'";
}
sub write_literal {
my ($file, $value) = @_;
open(my $fh, '>', $file) or die "cannot write the result file $file: $!\n";
print {$fh} perl_literal($value), "\n";
close($fh) or die "cannot write the result file $file: $!\n";
return 1;
}
sub read_literal {
my ($file) = @_;
return (undef, 'result file was not written') unless -f $file;
open(my $fh, '<', $file) or return (undef, "cannot read the result: $!");
local $/ = undef;
my $text = <$fh>;
close($fh);
return (undef, 'empty result') unless defined $text && length $text;
my $value = eval $text; # written by our own child, read before it is removed
return (undef, 'unreadable result') if $@;
return ($value, '');
}
sub collect_checks {
my ($data, $os_type, $target, $protocol) = @_;
my @plan = (
['connectivity', 'internet connectivity', sub { check_connectivity($protocol) }],
);
# Only the families the user asked for, IPv6 first.
if ($protocol ne 'v4') {
push @plan, ['ping_v6', 'ping (IPv6)', sub { ping_host($target, $os_type, protocol => 'v6') }];
}
if ($protocol ne 'v6') {
push @plan, ['ping_v4', 'ping (IPv4)', sub { ping_host($target, $os_type, protocol => 'v4') }];
}
push @plan,
['dns', 'DNS resolution', sub { check_dns($protocol) }],
['mtu', 'path MTU', sub { check_mtu($target, $protocol, $os_type) }],
['listening', 'listening ports', sub { listening_ports($os_type) }];
my $dir = scratch_dir();
my (%pid_of, %file_of, %label_of);
for my $item (@plan) {
my ($key, $label, $code) = @$item;
my $file = "$dir/$key";
$file_of{$key} = $file;
$label_of{$key} = $label;
my $pid = fork();
die "cannot fork: $!\n" unless defined $pid;
if ($pid == 0) {
# A child must not inherit the parent's interrupt handling, or one
# Ctrl-C would print the message once per process.
$SIG{INT} = 'DEFAULT';
$SIG{TERM} = 'DEFAULT';
my $ok = eval { write_literal($file, $code->()) };
unless ($ok) {
my $error = $@ || 'unknown error';
$error =~ s/\s+\z//;
write_literal($file, { error => $error });
}
exit($ok ? 0 : 1);
}
$pid_of{$pid} = $key;
}
my $count = scalar @plan;
print STDERR " Running $count checks in parallel...\n";
for (1 .. $count) {
my $pid = waitpid(-1, 0);
last if $pid <= 0;
my $key = $pid_of{$pid};
next unless defined $key;
my $exit_status = $? >> 8;
my ($result, $read_error) = read_literal($file_of{$key});
my $label = $label_of{$key};
if ($exit_status != 0 || !defined $result) {
my $message = $read_error;
$message = $result->{error} if ref $result eq 'HASH' && $result->{error};
$message = 'check failed' unless defined $message && length $message;
$data->{$key} = { error => $message };
print STDERR " $label... failed ($message)\n";
next;
}
$data->{$key} = $result;
if (ref $result eq 'HASH' && $result->{note}) {
print STDERR " $label... warning ($result->{note})\n";
}
else {
print STDERR " $label... done\n";
}
}
remove_scratch();
return;
}
# ---------------------------------------------------------------------------
# Entry point
# ---------------------------------------------------------------------------
sub usage {
my $name = $0;
$name =~ s{.*/}{};
return <<"USAGE";
Usage: $name [options]
Network diagnostics: latency, DNS, MTU, dual-stack, ports
Options:
--target HOST Target host for tests (default: cloudflare.com)
--protocol FAMILY Address family: auto (dual-stack), v4 (IPv4 only),
v6 (IPv6 only) (default: auto)
--version Show the version and exit
-h, --help Show this help and exit
USAGE
}
sub parse_args {
my %opt = (target => 'cloudflare.com', protocol => 'auto');
my @argv = @ARGV;
while (defined(my $arg = shift @argv)) {
if ($arg eq '--target' || $arg eq '--protocol') {
my $value = shift @argv;
if (!defined $value) {
print STDERR "argument $arg: expected one argument\n";
print STDERR usage();
exit 2;
}
$opt{ substr($arg, 2) } = $value;
}
elsif ($arg =~ /^--(target|protocol)=(.*)$/s) {
$opt{$1} = $2;
}
elsif ($arg eq '--help' || $arg eq '-h') {
print usage();
exit 0;
}
elsif ($arg eq '--version') {
my $name = $0;
$name =~ s{.*/}{};
print "$name $VERSION\n";
exit 0;
}
else {
print STDERR "unrecognised argument: $arg\n";
print STDERR usage();
exit 2;
}
}
if ($opt{protocol} ne 'auto' && $opt{protocol} ne 'v4' && $opt{protocol} ne 'v6') {
print STDERR "argument --protocol: invalid choice: '$opt{protocol}' (choose from auto, v4, v6)\n";
print STDERR usage();
exit 2;
}
return %opt;
}
sub main {
my %opt = parse_args();
my $target = $opt{target};
my $protocol = $opt{protocol};
my $os_type = detect_os();
my $hostname = check_hostname();
my $data = {
hostname => $hostname,
version => $VERSION,
os => $os_type,
protocol => $protocol,
interfaces => {},
connectivity => {},
ping => {},
ping_v4 => undef,
ping_v6 => undef,
dns => {},
ipv4 => {},
ipv6 => {},
mtu => {},
listening => {},
grade => {},
};
# Interfaces first: instant, sequential, and the reachability sections
# below depend on the result.
status('Checking interfaces');
$data->{interfaces} = interface_info($os_type);
my $iface_error = $data->{interfaces}{error};
status_done($iface_error ? "warning: $iface_error" : 'done');
collect_checks($data, $os_type, $target, $protocol);
# Per-family reachability from interface data plus the shared probes.
my $conn = $data->{connectivity} // {};
my $probes_v4 = ref $conn->{v4} eq 'HASH' ? $conn->{v4} : {};
my $probes_v6 = ref $conn->{v6} eq 'HASH' ? $conn->{v6} : {};
$data->{ipv6} = reachability_report('v6', $data->{interfaces}, $probes_v6);
$data->{ipv4} = reachability_report('v4', $data->{interfaces}, $probes_v4);
if ($protocol eq 'v4') { $data->{ipv6}{skipped} = 1 }
elsif ($protocol eq 'v6') { $data->{ipv4}{skipped} = 1 }
# The ping that summarises the run: the requested family, or IPv6 when it
# answered, which is the dual-stack preference.
if ($protocol eq 'v4') {
$data->{ping} = $data->{ping_v4} // {};
}
elsif ($protocol eq 'v6') {
$data->{ping} = $data->{ping_v6} // {};
}
else {
my $ping_v4 = $data->{ping_v4};
my $ping_v6 = $data->{ping_v6};
my $v6_received = ref $ping_v6 eq 'HASH' ? ($ping_v6->{received} // 0) : 0;
if ($v6_received > 0 && ref $ping_v6 eq 'HASH') {
$data->{ping} = $ping_v6;
}
elsif (ref $ping_v4 eq 'HASH') {
$data->{ping} = $ping_v4;
}
else {
$data->{ping} = {};
}
}
$data->{grade} = compute_grade($data);
print_report($data);
return 0;
}
$SIG{INT} = sub {
print STDERR "\nInterrupted.\n";
remove_scratch();
exit 130;
};
$SIG{TERM} = sub {
remove_scratch();
exit 143;
};
END {
remove_scratch();
}
exit(main()) unless caller;
Reference in New Issue Copy Permalink