#!/usr/bin/env perl # Copyright (c) 2026 Petr Balvín (https://petrbalvin.org) # SPDX-License-Identifier: MIT # Checks for network-diag.pl: the address arithmetic, the address classification, the # ping parsing, the MTU family fallback and the small helpers. # # Run from anywhere: perl tests/network-diag.pl use strict; use warnings; my $root = $0 =~ m{^(.*)/[^/]+$} ? "$1/.." : '..'; $root = "./$root" if $root !~ m{^/}; require "$root/network-diag.pl"; my ($passed, $failed) = (0, 0); sub is { my ($got, $want, $label) = @_; $got = 'undef' unless defined $got; $want = 'undef' unless defined $want; if ($got eq $want) { $passed++; print "ok $label\n"; return 1; } $failed++; print "FAIL $label\n got: $got\n want: $want\n"; return 0; } sub check { my ($cond, $label) = @_; return is($cond ? 1 : 0, 1, $label); } sub hex_of { my ($bytes) = @_; return join(' ', map { sprintf('%02x', $_) } unpack('C*', $bytes)); } # --------------------------------------------------------------------------- # IPv4 and IPv6 parsing # --------------------------------------------------------------------------- is(hex_of(ip4_bytes('127.0.0.1')), '7f 00 00 01', 'ip4: 127.0.0.1'); is(hex_of(ip4_bytes('0.0.0.0')), '00 00 00 00', 'ip4: the unspecified address'); is(hex_of(ip4_bytes('255.255.255.255')), 'ff ff ff ff', 'ip4: the broadcast address'); is(ip4_bytes('256.0.0.1'), undef, 'ip4: an octet above 255 is refused'); is(ip4_bytes('1.2.3'), undef, 'ip4: three octets are refused'); is(ip4_bytes('1.2.3.4.5'), undef, 'ip4: five octets are refused'); is(ip4_bytes('::1'), undef, 'ip4: an IPv6 address is refused'); is(hex_of(ip6_bytes('::')), '00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00', 'ip6: the unspecified address'); is(hex_of(ip6_bytes('::1')), '00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 01', 'ip6: loopback in shorthand'); is(hex_of(ip6_bytes('2001:db8::1')), '20 01 0d b8 00 00 00 00 00 00 00 00 00 00 00 01', 'ip6: shorthand in the middle'); is(hex_of(ip6_bytes('::ffff:127.0.0.1')), '00 00 00 00 00 00 00 00 00 00 ff ff 7f 00 00 01', 'ip6: an embedded IPv4 address'); is(hex_of(ip6_bytes('fe80::1%eth0')), 'fe 80 00 00 00 00 00 00 00 00 00 00 00 00 00 01', 'ip6: a scope suffix is dropped'); is(hex_of(ip6_bytes('2001:0db8:0000:0000:0000:0000:0000:0001')), '20 01 0d b8 00 00 00 00 00 00 00 00 00 00 00 01', 'ip6: the full form'); is(ip6_bytes('127.0.0.1'), undef, 'ip6: an IPv4 address is refused'); is(ip6_bytes('2001:db8:::1'), undef, 'ip6: a malformed address is refused'); is(ip6_bytes('2001:db8::1::2'), undef, 'ip6: two shorthands are refused'); is(is_mapped6('::ffff:10.0.0.1'), 1, 'mapped: an IPv4-mapped address'); is(is_mapped6('::1'), 0, 'mapped: loopback is not mapped'); is(is_mapped6('2001:db8::1'), 0, 'mapped: a global address is not mapped'); # --------------------------------------------------------------------------- # sockaddr packing # --------------------------------------------------------------------------- my $sa = sa_in('127.0.0.1', 80); is(length($sa), 16, 'sa_in: a sockaddr_in is 16 bytes'); is(unpack('S', substr($sa, 0, 2)), 2, 'sa_in: the family is AF_INET'); is(unpack('n', substr($sa, 2, 2)), 80, 'sa_in: the port is network order'); is(hex_of(substr($sa, 4, 4)), '7f 00 00 01', 'sa_in: the address follows'); is(hex_of(substr($sa, 8)), '00 00 00 00 00 00 00 00', 'sa_in: the padding is zero'); is(sa_in('::1', 80), undef, 'sa_in: an IPv6 address is refused'); my $sa6 = sa_in6('::1', 443); is(length($sa6), 28, 'sa_in6: a sockaddr_in6 is 28 bytes'); is(unpack('n', substr($sa6, 2, 2)), 443, 'sa_in6: the port is network order'); is(hex_of(substr($sa6, 8, 16)), '00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 01', 'sa_in6: the address follows the flow information'); is(sa_in6('127.0.0.1', 443), undef, 'sa_in6: an IPv4 address is refused'); # --------------------------------------------------------------------------- # Address classification # --------------------------------------------------------------------------- is(class4(ip4_bytes('127.0.0.1')), 'loopback', 'class4: loopback'); is(class4(ip4_bytes('169.254.1.1')), 'linklocal', 'class4: link-local'); is(class4(ip4_bytes('0.0.0.0')), 'unspecified', 'class4: unspecified'); is(class4(ip4_bytes('224.0.0.1')), 'multicast', 'class4: multicast'); is(class4(ip4_bytes('10.0.0.1')), 'private', 'class4: the ten network'); is(class4(ip4_bytes('192.168.1.1')), 'private', 'class4: the 192.168 network'); is(class4(ip4_bytes('172.16.0.1')), 'private', 'class4: the 172.16 network'); is(class4(ip4_bytes('100.64.0.1')), 'private', 'class4: carrier-grade NAT'); is(class4(ip4_bytes('8.8.8.8')), 'global', 'class4: a global address'); is(class6(ip6_bytes('::')), 'unspecified', 'class6: unspecified'); is(class6(ip6_bytes('::1')), 'loopback', 'class6: loopback'); is(class6(ip6_bytes('::ffff:1.2.3.4')), 'mapped', 'class6: IPv4-mapped'); is(class6(ip6_bytes('fe80::1')), 'linklocal', 'class6: link-local'); is(class6(ip6_bytes('ff02::1')), 'multicast', 'class6: multicast'); is(class6(ip6_bytes('fd00::1')), 'private', 'class6: unique local'); is(class6(ip6_bytes('2002::1')), 'private', 'class6: 6to4'); is(class6(ip6_bytes('2001:db8::1')), 'global', 'class6: a documentation prefix'); is(address_kind('v4', '127.0.0.1'), 'loopback', 'address_kind: an IPv4 class'); is(address_kind('v6', '::1'), 'loopback', 'address_kind: an IPv6 class'); is(address_kind('v4', 'not-an-address'), '', 'address_kind: unparsable input is empty'); # --------------------------------------------------------------------------- # Ping output # --------------------------------------------------------------------------- my $iputils = <<'PING'; PING cloudflare.com (104.16.132.229) 56(84) bytes of data. 64 bytes from 104.16.132.229: icmp_seq=1 ttl=57 time=11.2 ms 64 bytes from 104.16.132.229: icmp_seq=2 ttl=57 time=12.4 ms 64 bytes from 104.16.132.229: icmp_seq=3 ttl=57 time=10.1 ms --- cloudflare.com ping statistics --- 3 packets transmitted, 3 received, 0% packet loss, time 2003ms rtt min/avg/max/mdev = 10.109/11.233/12.401/0.938 ms PING my ($latencies, $received) = parse_ping_output($iputils); is(scalar(@$latencies), 3, 'ping: three replies are parsed'); is($latencies->[0], '11.2', 'ping: the first latency'); is($latencies->[2], '10.1', 'ping: the last latency'); is($received, 3, 'ping: the received counter'); my $lossy = <<'PING'; 2 packets transmitted, 1 received, 50% packet loss, time 1001ms PING my ($none, $one) = parse_ping_output($lossy); is(scalar(@$none), 0, 'ping: a transcript without replies has no latencies'); is($one, 1, 'ping: a partial loss is counted'); my ($min, $max, $sum) = min_max_sum([3, 1, 2]); is($min, 1, 'latency: the minimum'); is($max, 3, 'latency: the maximum'); is($sum, 6, 'latency: the sum'); # --------------------------------------------------------------------------- # Listening sockets # --------------------------------------------------------------------------- my @ss_ports = parse_ss_output( "State Recv-Q Send-Q Local Address:Port Peer Address:Port Process\n" . "LISTEN 0 128 0.0.0.0:22 0.0.0.0:* users:((\"sshd daemon\",pid=977,fd=3))\n" . "LISTEN 0 128 [::]:22 [::]:*\n" ); is($ss_ports[0]{process}, 'users:(("sshd daemon",pid=977,fd=3))', 'ss: a process name with spaces is kept whole'); is($ss_ports[0]{bucket}, 'tcp4', 'ss: a plain local address is IPv4'); is($ss_ports[1]{process}, '', 'ss: a socket without permission has no process'); is($ss_ports[1]{bucket}, 'tcp6', 'ss: a bracketed local address is IPv6'); # --------------------------------------------------------------------------- # Grading # --------------------------------------------------------------------------- is(grade_letter(100), 'A', 'grade: a perfect score'); is(grade_letter(90), 'A', 'grade: the A boundary'); is(grade_letter(89.9), 'B', 'grade: just under the A boundary'); is(grade_letter(80), 'B', 'grade: the B boundary'); is(grade_letter(70), 'C', 'grade: the C boundary'); is(grade_letter(60), 'D', 'grade: the D boundary'); is(grade_letter(59.9), 'F', 'grade: just under the D boundary'); is(grade_letter(0), 'F', 'grade: zero'); my $graded = compute_grade({}); is(ref($graded), 'HASH', 'grade: the verdict is a hash'); is($graded->{score}, 0, 'grade: no data scores zero'); is($graded->{grade}, 'F', 'grade: no data fails'); check($graded->{max_score} > 0, 'grade: the maximum is reported'); check(ref($graded->{breakdown}) eq 'HASH', 'grade: the breakdown is a hash'); my $full = compute_grade({ ping => { loss_pct => 0, avg_ms => 10 }, dns => { v4 => { 'example.org' => [{ ms => 5 }] } }, }); check($full->{score} >= 0 && $full->{score} <= $full->{max_score}, 'grade: a measured run stays within the maximum'); is(ms_colour(undef), "\033[2m", 'colour: an unmeasured latency is dim'); is(ms_colour(0), "\033[2m", 'colour: a zero latency is dim'); check(ms_colour(5) ne ms_colour(5000), 'colour: the bands differ'); # --------------------------------------------------------------------------- # Serialisation and arguments # --------------------------------------------------------------------------- is(perl_literal(5), '5', 'literal: an integer stays bare'); is(perl_literal(1.5), '1.5', 'literal: a float stays bare'); is(perl_literal('abc'), "'abc'", 'literal: a word is quoted'); is(perl_literal('42x'), "'42x'", 'literal: a number-like word is quoted'); is(perl_literal(undef), 'undef', 'literal: undef'); is(perl_literal("it's"), "'it\\'s'", 'literal: a quote is escaped'); is(perl_literal([1, 2]), '[1, 2]', 'literal: an array'); is(perl_literal({ b => 2, a => 1 }), "{ 'a' => 1, 'b' => 2 }", 'literal: a hash in key order'); eval { write_literal('/nonexistent/network-diag-check', 1) }; check(scalar($@ =~ /cannot write /), 'result write: a failed write names the operation'); { local $ENV{TMPDIR} = ''; my $scratch = eval { scratch_dir() }; check(defined($scratch) && index($scratch // '', '/tmp/') == 0, 'scratch: an empty TMPDIR falls back to /tmp'); remove_scratch() if defined $scratch; } my $report_out = ''; open(my $report_cap, '>', \$report_out) or die "cannot capture the report: $!\n"; { local *STDOUT = $report_cap; print_report({ hostname => 'testhost', os => 'linux', dns => { error => 'probe boom' } }); } close($report_cap); check(index($report_out, 'unavailable: probe boom') >= 0, 'report: a failed DNS check names its error'); my @saved = @ARGV; @ARGV = ('--target', 'example.org', '--protocol', 'v6'); my %args = parse_args(); is($args{target}, 'example.org', 'args: --target takes a value'); is($args{protocol}, 'v6', 'args: --protocol takes a value'); @ARGV = @saved; @ARGV = (); my %defaults = parse_args(); is($defaults{protocol}, 'auto', 'args: the family defaults to auto'); is($defaults{target}, 'cloudflare.com', 'args: the target has a default'); @ARGV = @saved; # --------------------------------------------------------------------------- # The MTU probe, through fixture binaries on a private PATH # --------------------------------------------------------------------------- # A fake getent answers the resolver probe and one fixed name, and a fake ping # models a host whose IPv6 path is dead while IPv4 passes a 1500 B DF probe. # Together they exercise the family fallback of check_mtu end to end without # touching the network. sub install_fake_bin { my ($dir, $name, $body) = @_; open(my $fh, '>', "$dir/$name") or die "cannot write $dir/$name: $!\n"; print {$fh} "#!/usr/bin/env perl\n", $body; close($fh); chmod(0755, "$dir/$name") or die "cannot chmod $dir/$name: $!\n"; return; } my $bindir = "/tmp/network-diag-test-bin.$$"; mkdir($bindir, 0700) or die "cannot create $bindir: $!\n"; { local $ENV{PATH} = "$bindir:$ENV{PATH}"; install_fake_bin($bindir, 'getent', <<'FIXTURE'); my ($verb, $host) = @ARGV; if ($verb eq 'ahostsv4' && $host eq 'localhost') { print "127.0.0.1 STREAM\n"; print "# the localhost resolver probe\n"; exit 0; } if ($host eq 'mtu-fallback.test') { print $verb eq 'ahostsv6' ? "2001:db8::1 STREAM\n" : "192.0.2.10 STREAM\n"; exit 0; } exit 2; FIXTURE install_fake_bin($bindir, 'ping', <<'FIXTURE'); my ($family, $payload) = ('', 0); for (my $i = 0; $i < @ARGV; $i++) { $family = $ARGV[$i] if $ARGV[$i] eq '-4' || $ARGV[$i] eq '-6'; $payload = $ARGV[$i + 1] if $ARGV[$i] eq '-s'; } if ($family eq '-6' || $payload > 1472) { print "1 packets transmitted, 0 received, 100% packet loss, time 0ms\n"; exit 1; } print "1 packets transmitted, 1 received, 0% packet loss, time 0ms\n"; exit 0; FIXTURE my $auto = check_mtu('mtu-fallback.test', 'auto', 'linux'); is($auto->{path_mtu}, 1500, 'mtu: a dead preferred family falls back to the other'); check(index($auto->{method} // '', 'IPv4 fallback') >= 0, 'mtu: the fallback names the family that answered'); my $v6 = check_mtu('mtu-fallback.test', 'v6', 'linux'); is($v6->{path_mtu}, 0, 'mtu: an explicit protocol choice does not fall back'); is($v6->{method}, 'ping DF probe (no probe size succeeded)', 'mtu: an explicit protocol choice reports the failure'); my $v4 = check_mtu('mtu-fallback.test', 'v4', 'linux'); is($v4->{path_mtu}, 1500, 'mtu: the preferred family answering needs no fallback'); is($v4->{method}, 'ping DF probe (1500B OK)', 'mtu: a direct hit carries no fallback note'); } unlink(glob("$bindir/*")); rmdir($bindir) or die "cannot remove $bindir: $!\n"; print "\n" . ($failed ? "$failed FAILED of " . ($passed + $failed) : "all $passed checks passed") . "\n"; exit($failed ? 1 : 0);