you-dont-need-pihole/dev-t/doc-changelog-links.t

#!perl
use 5.012;
use warnings FATAL => 'all';

use Test::More 'no_plan';

use FindBin qw//;
my $changelog = "$FindBin::Bin/../CHANGELOG.md";
my $braced_inner_r = qr/(?:[^\]\\]|\\.)*/;
use constant PROJECT_GIT => 'https://codeberg.org/h3xx/you-dont-need-pihole';

SKIP: {
    my $clh;
    unless (open $clh, '<', $changelog) {
        skip("failed to open changelog file to test: $!");
    }
    my @cl_lines = <$clh>;
    close $clh;

    ok(scalar @cl_lines,
        'changelog contains at least one line'
    );

    my %end_links = _link_references(@cl_lines);
    my @reflinks = _ref_links(@cl_lines);

    my @unresolved = _unresolved_links(\%end_links, \@reflinks);
    ok(!scalar @unresolved, ChangelogError->new('unresolved links', @unresolved));

    my %unused_links = _unused_links(\%end_links, \@reflinks);
    ok(!scalar %unused_links, ChangelogError->new('unused end links', values %unused_links));

    my @incorrect_links = _incorrect_end_links(\%end_links, \@reflinks);
    ok(!scalar @incorrect_links, ChangelogError->new('incorrect end links', @incorrect_links));

}

sub _link_references {
    my @lines = @_;
    my $end_link_r = qr/^\s*\[(?<key>$braced_inner_r)\]:\s*(?<url>.*?)\s*$/;
    my %end_links;
    my $line_number = 0;
    foreach my $line (@lines) {
        ++$line_number;
        if ($line =~ $end_link_r) {
            $end_links{$+{key}} = {
                line_number => $line_number,
                url => $+{url},
                key => $+{key},
            };
        }
    }
    return %end_links;
}

sub _ref_links {
    my @lines = @_;
    my $ref_link_r = qr/\[(?<text>$braced_inner_r)\]\[(?<key>$braced_inner_r)\]/;
    # Make sure not to catch:
    # - Normal links "[text](url)"
    # - End links "[key]: url"
    my $bare_ref_link_r = qr/\[(?<textkey>$braced_inner_r)\](?!\s*[(:])/;
    my @reflinks;
    my $line_number = 0;
    foreach my $line (@lines) {
        ++$line_number;
        if ($line =~ $ref_link_r) {
            push @reflinks, {
                line_number => $line_number,
                text => $+{text},
                key => $+{key},
            };
        } elsif ($line =~ $bare_ref_link_r) {
            push @reflinks, {
                line_number => $line_number,
                text => $+{textkey},
                key => $+{textkey},
            };
        }
    }
    return @reflinks;
}

sub _unused_links {
    my ($end_links, $reflinks) = @_;
    # Make a copy, lest we destroy data
    my %unused = %{$end_links};
    foreach my $link (@{$reflinks}) {
        my $key = $link->{key};
        delete $unused{$key};
    }
    return %unused;
}

sub _unresolved_links {
    my ($end_links, $reflinks) = @_;
    my @unresolved;
    foreach my $link (@{$reflinks}) {
        my $key = $link->{key};
        unless (exists $end_links->{$key}) {
            push @unresolved, $link;
        }
    }
    return @unresolved;
}

sub _incorrect_end_links {
    my ($end_links, $reflinks) = @_;
    my @versions_in_order;
    my %versions_seen;
    foreach my $link (@{$reflinks}) {
        my $key = $link->{key};
        if (_is_version($key) && !exists $versions_seen{$key}) {
            $versions_seen{$key} = 1;
            push @versions_in_order, $key;
        }
    }
    my %expected_links = (
        Unreleased => _make_tag_link("v$versions_in_order[0]", 'HEAD'),
        $versions_in_order[-1] => _make_tag_link("v$versions_in_order[-1]"),
    );
    foreach my $idx (0 .. ($#versions_in_order - 1)) {
        my $this_version = $versions_in_order[$idx];
        my $last_version = $versions_in_order[$idx + 1];
        $expected_links{$this_version} = _make_tag_link("v$last_version", "v$this_version");
    }

    my @incorrect_links;
    while (my ($key, $link) = each %{$end_links}) {
        if (exists $expected_links{$key}) {
            my $got = $link->{url};
            my $expected = $expected_links{$key};
            if ($got ne $expected) {
                $link->{url_expected} = $expected;
                push @incorrect_links, $link;
            }
        }
    }
    return @incorrect_links;
}

sub _make_tag_link {
    my ($before_tag, $after_tag) = @_;
    unless (defined $after_tag) {
        return sprintf '%s/releases/tag/%s', PROJECT_GIT, $before_tag;
    }
    return sprintf '%s/compare/%s...%s', PROJECT_GIT, $before_tag, $after_tag;
}

sub _is_version {
    my $ver = shift;
    return $ver =~ /^[0-9.]+$/;
}

package ChangelogError;
use 5.012;
use warnings FATAL => 'all';
use overload '""' => '_as_string';

sub new {
    my ($class, $name, @data) = @_;
    return bless {
        _name => $name,
        _data => \@data,
    }, $class;
}

sub _as_string {
    my $self = shift;
    my @all = ($self->{_name});
    foreach my $datum (@{$self->{_data}}) {
        my @out;
        foreach my $key (qw/ line_number key text url url_expected /) {
            if (defined $datum->{$key}) {
                push @out, "$key: $datum->{$key}";
            }
        }
        push @all, '- ' . (join ', ', @out);
    }
    return join "\n", @all;
}