util/check-doc-links.pl

   1 #! /usr/bin/env perl
   2 # Copyright 2002-2016 The OpenSSL Project Authors. All Rights Reserved.
   3 #
   4 # Licensed under the OpenSSL license (the "License").  You may not use
   5 # this file except in compliance with the License.  You can obtain a copy
   6 # in the file LICENSE in the source distribution or at
   7 # https://www.openssl.org/source/license.html
   8
   9
  10 require 5.10.0;
  11 use warnings;
  12 use strict;
  13 use File::Basename;
  14
  15 # Collection of links in each POD file.
  16 # filename => [ "foo(1)", "bar(3)", ... ]
  17 my %link_collection = ();
  18 # Collection of names in each POD file.
  19 # "name(s)" => filename
  20 my %name_collection = ();
  21
  22 sub collect {
  23     my $filename = shift;
  24     $filename =~ m|man(\d)/|;
  25     my $section = $1;
  26     my $simplename = basename($filename, ".pod");
  27     my $err = 0;
  28
  29     my $contents = '';
  30     {
  31         local $/ = undef;
  32         open POD, $filename or die "Couldn't open $filename, $!";
  33         $contents = <POD>;
  34         close POD;
  35     }
  36
  37     $contents =~ /=head1 NAME([^=]*)=head1 /ms;
  38     my $tmp = $1;
  39     unless (defined $tmp) {
  40         warn "weird name section in $filename\n";
  41         return 1;
  42     }
  43     $tmp =~ tr/\n/ /;
  44     $tmp =~ s/-.*//g;
  45
  46     my @names = map { s/\s+//g; $_ } split(/,/, $tmp);
  47     unless (grep { $simplename eq $_ } @names) {
  48         warn "$simplename missing among the names in $filename\n";
  49         push @names, $simplename;
  50     }
  51     foreach my $name (@names) {
  52         next if $name eq "";
  53         my $namesection = "$name($section)";
  54         if (exists $name_collection{$namesection}) {
  55             warn "$namesection, found in $filename, already exists in $name_collection{$namesection}\n";
  56             $err++;
  57         } else {
  58             $name_collection{$namesection} = $filename;
  59         }
  60     }
  61
  62     my @foreign_names =
  63         map { map { s/\s+//g; $_ } split(/,/, $_) }
  64         $contents =~ /=for\s+comment\s+foreign\s+manuals:\s*(.*)\n\n/;
  65     foreach (@foreign_names) {
  66         $name_collection{$_} = undef; # It still exists!
  67     }
  68
  69     my @links = $contents =~ /L<
  70                               # if the link is of the form L<something|name(s)>,
  71                               # then remove 'something'.  Note that 'something'
  72                               # may contain POD codes as well...
  73                               (?:(?:[^\|]|<[^>]*>)*\|)?
  74                               # we're only interested in referenses that have
  75                               # a one digit section number
  76                               ([^\/>\(]+\(\d\))
  77                              /gx;
  78     $link_collection{$filename} = [ @links ];
  79
  80     return $err;
  81 }
  82
  83 sub check {
  84     foreach my $filename (sort keys %link_collection) {
  85         foreach my $link (@{$link_collection{$filename}}) {
  86             warn "$link in $filename refers to a non-existing manual\n"
  87                 unless exists $name_collection{$link};
  88         }
  89     }
  90 }
  91
  92
  93 my $errs = 0;
  94 foreach (@ARGV ? @ARGV : glob('doc/*/*.pod')) {
  95     $errs += collect($_);
  96 }
  97 check() unless $errs > 0;
  98
  99 exit;