vcs.maemo.org Git - maemian/blob - nokia-lintian/checks/manpages

   1 # manpages -- lintian check script -*- perl -*-
   2
   3 # Copyright (C) 1998 Christian Schwarz
   4 #
   5 # This program is free software; you can redistribute it and/or modify
   6 # it under the terms of the GNU General Public License as published by
   7 # the Free Software Foundation; either version 2 of the License, or
   8 # (at your option) any later version.
   9 #
  10 # This program is distributed in the hope that it will be useful,
  11 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 # GNU General Public License for more details.
  14 #
  15 # You should have received a copy of the GNU General Public License
  16 # along with this program.  If not, you can find it on the World Wide
  17 # Web at http://www.gnu.org/copyleft/gpl.html, or write to the Free
  18 # Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
  19 # MA 02110-1301, USA.
  20
  21 package Lintian::manpages;
  22 use strict;
  23 use Dep;
  24 use Tags;
  25 use Util;
  26
  27 # Set to true if the man program supports --warnings based on its version
  28 # number.  This is probed if this variable is undefined and set to 0 or 1.
  29 our $MAN_WARNINGS;
  30
  31 sub run {
  32
  33 my $pkg = shift;
  34 my $type = shift;
  35
  36 use File::Basename;
  37
  38 my %file_info;
  39 my %binary;
  40 my %link;
  41 # my %sect_by_binary;
  42 # my %sect_by_manpage;
  43 my %manpage;
  44
  45 # Read file info...
  46 open(IN, '<', "file-info")
  47     or fail("cannot find file-info for $type package $pkg");
  48 while (<IN>) {
  49     chop;
  50
  51     m/^(.*?):\s+(.*)$/o or fail("an error in the file pkg is preventing lintian from checking this package: $_");
  52     my ($file,$info) = ($1,$2);
  53
  54     next unless $file =~ m/man/o;
  55     $file =~ s,^(\./)?,,;
  56
  57     $file_info{$file} = $info;
  58 }
  59 close(IN);
  60
  61 # Read package contents...
  62 open(IN, '<', "index") or fail("cannot open index file index: $!");
  63 while (<IN>) {
  64     chop;
  65
  66     my ($perm,$owner,$size,$date,$time,$file) = split(' ', $_, 6);
  67     my $link;
  68
  69     $file =~ s,^(\./),,;
  70     $file =~ s/ link to .*//;
  71
  72     if ($perm =~ m/^l/) {
  73         ($file, $link) = split(' -> ', $file);
  74     }
  75
  76     my ($fname,$path,$suffix) = fileparse($file);
  77
  78     # Binary that wants a manual page?
  79     #
  80     # It's tempting to check the section of the man page depending on the
  81     # location of the binary, but there are too many mismatches between
  82     # bin/sbin and 1/8 that it's not clear it's the right thing to do.
  83     if (($perm =~ m,^[\-l],o) and
  84         (($path =~ m,^bin/$,o) or
  85          ($path =~ m,^sbin/$,o) or
  86          ($path =~ m,^usr/bin/$,o) or
  87          ($path =~ m,^usr/bin/X11/$,o) or
  88          ($path =~ m,^usr/bin/mh/$,o) or
  89          ($path =~ m,^usr/sbin/$,o) or
  90          ($path =~ m,^usr/games/$,o) or
  91          ($path =~ m,^usr/X11R6/bin/$,o) )) {
  92
  93         my $bin = $fname;
  94
  95         $binary{$bin} = $file;
  96         $link{$bin} = $link if $link;
  97
  98         next;
  99     }
 100
 101     if (($path =~ m,usr/(share|X11R6)/man/$,) and ($fname ne "")) {
 102         tag "manpage-in-wrong-directory", "$file";
 103         next;
 104     }
 105
 106     # manual page?
 107     next unless ($perm =~ m,^[\-l],o) and
 108         (($path =~ m,^usr/man(/\S+),o)
 109          or ($path =~ m,^usr/X11R6/man(/\S+),o)
 110          or ($path =~ m,^usr/share/man(/\S+),o) );
 111
 112     my $t = $1;
 113     if (not $t =~ m,^.*man(\d)/$,o) {
 114         tag "manpage-in-wrong-directory", "$file";
 115         next;
 116     }
 117     my ($section,$name) = ($1,$fname);
 118     my $lang = "";
 119        $lang = $1 if $t =~ m,^/([^/]+)/man\d/$,o;
 120
 121     # The country should not be part of the man page locale directory unless
 122     # it's one of the known cases where the language is significantly
 123     # different between countries.
 124     if ($lang =~ /_/ && $lang !~ /^(pt_BR|zh_[A-Z][A-Z])$/) {
 125         tag "manpage-locale-dir-country-specific", "$file";
 126     }
 127
 128     my @pieces = split(/\./, $name);
 129     my $ext = pop @pieces;
 130     if ($ext ne 'gz') {
 131         push @pieces, $ext;
 132         tag "manpage-not-compressed", "$file";
 133     } elsif ($perm =~ m,^-,o) { # so it's .gz... files first; links later
 134         my $info = $file_info{$file};
 135         if ($info !~ m/gzip compressed data/o) {
 136             tag "manpage-not-compressed-with-gzip", "$file";
 137         } elsif ($info !~ m/max compression/o) {
 138             tag "manpage-not-compressed-with-max-compression", "$file";
 139         }
 140     }
 141     my $fn_section = pop @pieces;
 142     my $section_num = $fn_section;
 143     if (scalar @pieces && $section_num =~ s/^(\d).*$/$1/) {
 144         my $bin = join(".", @pieces);
 145                $manpage{$bin} = [] unless $manpage{$bin};
 146         push @{$manpage{$bin}}, { file => $file, lang => $lang };
 147
 148         # number of directory and manpage extension equal?
 149         if ($section_num != $section) {
 150             tag "manpage-in-wrong-directory", "$file";
 151         }
 152     } else {
 153         tag "manpage-has-wrong-extension", "$file";
 154     }
 155
 156     # special check for manual pages for X11 games
 157     if ($path =~ m,^usr/X11R6/man/man6/,o) {
 158         tag "x11-games-should-be-in-usr-games", "$file";
 159     }
 160
 161     # check symbolic links to other manual pages
 162     if ($perm =~ m,^l,o) {
 163         if ($link =~ m,(^|/)undocumented,o) {
 164             if ($path =~ m,^usr/share/man,o) {
 165                 # undocumented link in /usr/share/man -- possibilities
 166                 #    undocumented... (if in the appropriate section)
 167                 #    ../man?/undocumented...
 168                 #    ../../man/man?/undocumented...
 169                 #    ../../../share/man/man?/undocumented...
 170                 #    ../../../../usr/share/man/man?/undocumented...
 171                 if ((($link =~ m,^undocumented\.([237])\.gz,o) and
 172                     ($path =~ m,^usr/share/man/man$1,)) or
 173                     ($link =~ m,^\.\./man[237]/undocumented\.[237]\.gz$,o) or
 174                     ($link =~ m,^\.\./\.\./man/man[237]/undocumented\.[237]\.gz$,o) or
 175                     ($link =~ m,^\.\./\.\./\.\./share/man/man[237]/undocumented\.[237]\.gz$,o) or
 176                     ($link =~ m,^\.\./\.\./\.\./\.\./usr/share/man/man[237]/undocumented\.[237]\.gz$,o)) {
 177                     tag "link-to-undocumented-manpage", "$file";
 178                 } else {
 179                     tag "bad-link-to-undocumented-manpage", "$file";
 180                 }
 181             } else {
 182                 # undocumented link in /usr/X11R6/man -- possibilities:
 183                 #    ../../../share/man/man?/undocumented...
 184                 #    ../../../../usr/share/man/man?/undocumented...
 185                 if (($link =~ m,^\.\./\.\./\.\./share/man/man[237]/undocumented\.[237]\.gz$,o) or
 186                     ($link =~ m,^\.\./\.\./\.\./\.\./usr/share/man/man[237]/undocumented\.[237]\.gz$,o)) {
 187                     tag "link-to-undocumented-manpage", "$file";
 188                 } else {
 189                     tag "bad-link-to-undocumented-manpage", "$file";
 190                 }
 191             }
 192         }
 193     } else { # not a symlink
 194         open (MANFILE, '-|', "zcat unpacked/\Q$file\E 2>/dev/null")
 195             or fail("cannot open $file: $!");
 196         my @manfile = ();
 197         while (<MANFILE>) { push @manfile, $_; }
 198         close MANFILE;
 199         # Is it a .so link?
 200         if ($size < 256) {
 201             my ($i, $first) = (0, "");
 202             do {
 203                 $first = $manfile[$i++] || "";
 204             } while ($first =~ /^\.\\"/ && $manfile[$i]); #");
 205
 206             unless ($first) {
 207                 tag "empty-manual-page", "$file";
 208             } elsif ($first =~ /^\.so\s+(.+)?$/) {
 209                 my $dest = $1;
 210                 if ($dest =~ m,^([^/]+)/(.+)$,) {
 211                     my ($manxorlang, $rest) = ($1, $2);
 212                     if ($manxorlang !~ /^man\d+$/) {
 213                         # then it's likely a language subdir, so let's run
 214                         # the other component through the same check
 215                         if ($rest =~ m,^([^/]+)/(.+)$,) {
 216                             my ($lang, $rest) = ($1, $2);
 217                             if ($rest !~ m,^[^/]+\.\d(?:\S+)?(?:\.gz)?$,) {
 218                                 tag "bad-so-link-within-manual-page", "$file";
 219                             }
 220                         } else {
 221                             tag "bad-so-link-within-manual-page", "$file";
 222                         }
 223                     }
 224                 } else {
 225                     tag "bad-so-link-within-manual-page", "$file";
 226                 }
 227                 next;
 228             }
 229         }
 230
 231         # If it's not a .so link, use lexgrog to find out if the man page
 232         # parses correctly and make sure the short description is reasonable.
 233         #
 234         # This check is currently not applied to pages in language-specific
 235         # hierarchies, because those pages are not currently scanned by
 236         # mandb (bug #29448), and because lexgrog can't handle pages in all
 237         # languages at the moment, leading to huge numbers of false
 238         # negatives. When man-db is fixed, this limitation should be
 239         # removed.
 240         if ($path =~ m,/man/man\d/,) {
 241             my $pid = open LEXGROG, '-|';
 242             if (not defined $pid) {
 243                 fail("cannot run lexgrog: $!");
 244             } elsif ($pid == 0) {
 245                 my %newenv = (LANG => 'C', PATH => $ENV{PATH});
 246                 undef %ENV;
 247                 %ENV = %newenv;
 248                 exec "lexgrog unpacked/\Q$file\E 2>&1"
 249                     or fail("cannot run lexgrog: $!");
 250             }
 251             my $desc = <LEXGROG>;
 252             $desc =~ s/^[^:]+: \"(.*)\"$/$1/;
 253             if ($desc =~ /(\S+)\s+-\s+manual page for \1/i) {
 254                 tag "manpage-has-useless-whatis-entry", "$file";
 255             } elsif ($desc =~ /(\S+)\s+-\s+programs? to do something/i) {
 256                 tag "manpage-is-dh_make-template", "$file";
 257             }
 258             1 while <LEXGROG>;
 259             close LEXGROG;
 260             tag "manpage-has-bad-whatis-entry", "$file" if $? != 0;
 261         }
 262
 263         # If we've not probed yet, determine if man supports --warnings.
 264         # This can be removed once man 2.5.1 makes it to testing.
 265         unless (defined $MAN_WARNINGS) {
 266             my $version = `man -V 2>&1`;
 267             if ($? == 0 && $version =~ / (\d+\.[\d.]+)(,|\Z)/) {
 268                 $MAN_WARNINGS = Dep::versions_gte($1, '2.5.1');
 269             } else {
 270                 $MAN_WARNINGS = 0;
 271             }
 272         }
 273
 274         # If it's not a .so link, run it through "man" to check for errors.
 275         # If it is in a directory with the standard man layout, cd to the
 276         # parent directory before running man so that .so directives are
 277         # processed properly.  (Yes, there are man pages that include other
 278         # pages with .so but aren't simple links; rbash, for instance.)
 279         my $cmd;
 280         my $warnings = $MAN_WARNINGS ? ' --warnings' : '';
 281         if ($file =~ m,^(.*)/(man\d/.*)$,) {
 282             $cmd = "cd unpacked/\Q$1\E && man$warnings -l \Q$2\E";
 283         } else {
 284             $cmd = "man$warnings -l unpacked/\Q$file\E";
 285         }
 286         my $pid = open MANERRS, '-|';
 287         if (not defined $pid) {
 288             fail("cannot run man -l: $!");
 289         } elsif ($pid == 0) {
 290             my %newenv = (LANG => 'C', PATH => $ENV{PATH});
 291             undef %ENV;
 292             %ENV = %newenv;
 293             exec "($cmd >/dev/null) 2>&1"
 294                 or fail("cannot run man -l: $!");
 295         }
 296         while (<MANERRS>) {
 297             # ignore progress information from man
 298             next if /^Reformatting/;
 299             next if /^\s*$/;
 300             # ignore errors from gzip, will be dealt with at other places
 301             next if /^(man|gzip)/;
 302             # ignore wrapping failures for Asian man pages (groff problem)
 303             if ($lang =~ /^(?:ja|ko|zh)/) {
 304                 next if /warning \[.*\]: cannot adjust line/;
 305                 next if /warning \[.*\]: can\'t break line/;
 306             }
 307             # ignore charset issues with old versions of man for all man pages
 308             # since we can't know, with old versions, whether that was just a
 309             # Unicode issue
 310             if (!$MAN_WARNINGS and
 311                 (m/warning: can\'t find numbered character/
 312                  or m/a magic token is not allowed in a name/
 313                  or m/name expected \(got a magic token\)/)) {
 314                 next;
 315             }
 316             # ignore common undefined macros from pod2man << Perl 5.10
 317             next if /warning: \`(Tr|IX)\' not defined/;
 318             chomp;
 319             s/^[^:]+://o;
 320             tag "manpage-has-errors-from-man", "$file", "$_";
 321             last;
 322         }
 323         close(MANERRS);
 324         # Now we search through the whole man page for some common errors
 325         my $lc = 0;
 326         my $hc = 0;
 327         foreach my $line (@manfile) {
 328             $lc++;
 329             chomp $line;
 330             next if $line =~ /^\.\\\"/o; # comments .\"
 331             if ($line =~ /^\.TH\s/) { # header
 332                 require Text::ParseWords;
 333                 my ($th_command, $th_title, $th_section, $th_date ) =
 334                     Text::ParseWords::parse_line( '\s+', 0, $line);
 335                 if ($th_section && (lc($fn_section) ne lc($th_section))) {
 336                     tag "manpage-section-mismatch", "$file:$lc $fn_section != $th_section";
 337                 }
 338             }
 339             # Catch hyphens used as minus signs by looking for ones at the
 340             # beginning of a word, but don't generate false positives on \s-1
 341             # (small font), \*(-- (pod2man long dash), or things like \h'-1'.
 342             if ($line =~ /^(
 343                             ([^\.].*)?
 344                             [\s\'\"\`\(\[]
 345                             (?<! \\s | \*\( | \(- | \w\' )
 346                            )?
 347                            (--?\w+)/ox) {
 348                 $hc++;
 349                 tag "hyphen-used-as-minus-sign", "$file:$lc" if $hc <= 10 or $ENV{'LINTIAN_DEBUG'};
 350             }
 351             if (($line =~ m,(/usr/(dict|doc|etc|info|man|adm|preserve)/),o)
 352                 || ($line =~ m,(/var/(adm|catman|named|nis|preserve)/),o)) {
 353                 # FSSTND dirs in man pages
 354                 # regexes taken from checks/files
 355                 tag "FSSTND-dir-in-manual-page", "$file:$lc $1";
 356             }
 357         }
 358         tag "hyphen-used-as-minus-sign", $file, ($hc-10), "more occurrences not shown" if $hc > 10 and ! $ENV{'LINTIAN_DEBUG'};
 359     }
 360 }
 361 close(IN);
 362
 363 for my $f (sort keys %binary) {
 364     if (exists $manpage{$f}) {
 365         # X11 binary?  This shouldn't happen any more; these are no longer
 366         # allowed.
 367         if ($binary{$f} =~ m,usr/X11R6, or
 368              ($link{$f} && $link{$f} =~ m,(\.\.|usr)/X11R6,)) {
 369             # yes. manpage in X11 too?
 370             for my $manp_info (@{$manpage{$f}}) {
 371                 if ($manp_info->{file} =~ m/X11R6/) {
 372                     # ok.
 373                 } else {
 374                     tag "manpage-for-x11-binary-in-wrong-directory", "$binary{$f} $manp_info->{file}";
 375                 }
 376             }
 377         } else {
 378             for my $manp_info (@{$manpage{$f}}) {
 379                 # no. manpage in X11?
 380                 if ($manp_info->{file} =~ m/X11R6/) {
 381                     tag "manpage-for-non-x11-binary-in-wrong-directory", "$binary{$f} $manp_info->{file}";
 382                 } else {
 383                     # ok.
 384                 }
 385             }
 386         }
 387
 388         if (not grep { $_->{lang} eq "" } @{$manpage{$f}}) {
 389             tag "binary-without-english-manpage", "$binary{$f}";
 390         }
 391     } else {
 392         tag "binary-without-manpage", "$binary{$f}";
 393     }
 394 }
 395
 396 }
 397
 398 1;
 399
 400 # Local Variables:
 401 # indent-tabs-mode: t
 402 # cperl-indent-level: 4
 403 # End:
 404 # vim: syntax=perl sw=4 ts=8