#!/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;