Add util/check-doc-links.pl, to be used to check referenses in manuals

Reviewed-by: Rich Salz <rsalz@openssl.org>
(Merged from https://github.com/openssl/openssl/pull/1900)

1 files changed, 99 insertions, 0 deletions

diff --git a/util/check-doc-links.pl b/util/check-doc-links.pl
new file mode 100644
index 0000000000..2cc4b31d54
--- /dev/null
+++ b/util/check-doc-links.pl
@@ -0,0 +1,99 @@
+#! /usr/bin/env perl
+# Copyright 2002-2016 The OpenSSL Project Authors. All Rights Reserved.
+#
+# Licensed under the OpenSSL license (the "License").  You may not use
+# this file except in compliance with the License.  You can obtain a copy
+# in the file LICENSE in the source distribution or at
+# https://www.openssl.org/source/license.html
+
+
+require 5.10.0;
+use warnings;
+use strict;
+use File::Basename;
+
+# Collection of links in each POD file.
+# filename => [ "foo(1)", "bar(3)", ... ]
+my %link_collection = ();
+# Collection of names in each POD file.
+# "name(s)" => filename
+my %name_collection = ();
+
+sub collect {
+    my $filename = shift;
+    $filename =~ m|man(\d)/|;
+    my $section = $1;
+    my $simplename = basename($filename, ".pod");
+    my $err = 0;
+
+    my $contents = '';
+    {
+        local $/ = undef;
+        open POD, $filename or die "Couldn't open $filename, $!";
+        $contents = <POD>;
+        close POD;
+    }
+
+    $contents =~ /=head1 NAME([^=]*)=head1 /ms;
+    my $tmp = $1;
+    unless (defined $tmp) {
+        warn "weird name section in $filename\n";
+        return 1;
+    }
+    $tmp =~ tr/\n/ /;
+    $tmp =~ s/-.*//g;
+
+    my @names = map { s/\s+//g; $_ } split(/,/, $tmp);
+    unless (grep { $simplename eq $_ } @names) {
+        warn "$simplename missing among the names in $filename\n";
+        push @names, $simplename;
+    }
+    foreach my $name (@names) {
+        next if $name eq "";
+        my $namesection = "$name($section)";
+        if (exists $name_collection{$namesection}) {
+            warn "$namesection, found in $filename, already exists in $name_collection{$namesection}\n";
+            $err++;
+        } else {
+            $name_collection{$namesection} = $filename;
+        }
+    }
+
+    my @foreign_names =
+        map { map { s/\s+//g; $_ } split(/,/, $_) }
+        $contents =~ /=for\s+comment\s+foreign\s+manuals:\s*(.*)\n\n/;
+    foreach (@foreign_names) {
+        $name_collection{$_} = undef; # It still exists!
+    }
+
+    my @links = $contents =~ /L<
+                              # if the link is of the form L<something|name(s)>,
+                              # then remove 'something'.  Note that 'something'
+                              # may contain POD codes as well...
+                              (?:(?:[^\|]|<[^>]*>)*\|)?
+                              # we're only interested in referenses that have
+                              # a one digit section number
+                              ([^\/>\(]+\(\d\))
+                             /gx;
+    $link_collection{$filename} = [ @links ];
+
+    return $err;
+}
+
+sub check {
+    foreach my $filename (sort keys %link_collection) {
+        foreach my $link (@{$link_collection{$filename}}) {
+            warn "$link in $filename refers to a non-existing manual\n"
+                unless exists $name_collection{$link};
+        }
+    }
+}
+
+
+my $errs = 0;
+foreach (@ARGV ? @ARGV : glob('doc/*/*.pod')) {
+    $errs += collect($_);
+}
+check() unless $errs > 0;
+
+exit;