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

   1 # menus -- lintian check script -*- perl -*-
   2
   3 # somewhat of a misnomer -- it doesn't only check menus
   4
   5 # Copyright (C) 1998 Christian Schwarz
   6 #
   7 # This program is free software; you can redistribute it and/or modify
   8 # it under the terms of the GNU General Public License as published by
   9 # the Free Software Foundation; either version 2 of the License, or
  10 # (at your option) any later version.
  11 #
  12 # This program is distributed in the hope that it will be useful,
  13 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 # GNU General Public License for more details.
  16 #
  17 # You should have received a copy of the GNU General Public License
  18 # along with this program.  If not, you can find it on the World Wide
  19 # Web at http://www.gnu.org/copyleft/gpl.html, or write to the Free
  20 # Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
  21 # MA 02110-1301, USA.
  22
  23 package Lintian::menus;
  24 use strict;
  25 use lib "$ENV{'LINTIAN_ROOT'}/checks/";
  26 use common_data;
  27
  28 use Lintian::Data;
  29 use Spelling;
  30 use Tags;
  31 use Util;
  32
  33 my $pkg;
  34 my %all_files = ();
  35 my %all_links = ();
  36
  37 # Known fields for doc-base files.  The value is 1 for required fields and 0
  38 # for optional fields.
  39 my %known_docbase_main_fields = (
  40         'document' => 1,
  41         'title'    => 1,
  42         'section'  => 1,
  43         'abstract' => 0,
  44         'author'   => 0
  45 );
  46 my %known_docbase_format_fields = (
  47         'format'  => 1,
  48         'files'   => 1,
  49         'index'   => 0
  50 );
  51
  52 sub run {
  53
  54 $pkg = shift;
  55 my $type = shift;
  56
  57 my %preinst;
  58 my %postinst;
  59 my %prerm;
  60 my %postrm;
  61
  62 my $docbase_file;
  63 my $menu_file;
  64 my $menumethod_file;
  65 my $anymenu_file;
  66
  67 # check preinst script
  68 if ( -f "control/preinst" ) {
  69     # parse script...
  70     check_script("preinst",\%preinst);
  71 }
  72
  73 # check postinst script
  74 if ( -f "control/postinst" ) {
  75     # parse script...
  76     check_script("postinst",\%postinst);
  77 }
  78
  79 # check prerm script
  80 if ( -f "control/prerm" ) {
  81     # parse script...
  82     check_script("prerm",\%prerm);
  83 }
  84
  85 # check postrm script
  86 if ( -f "control/postrm" ) {
  87     # parse script...
  88     check_script("postrm",\%postrm);
  89 }
  90
  91 # read package contents
  92 open(IN, '<', "index") or fail("cannot open index file index: $!");
  93 while (<IN>) {
  94     chomp;
  95     my ($perm,$owner,$size,$date,$time,$file) = split(' ', $_, 6);
  96     $file =~ s,^(\./),,;
  97     add_file_link_info ($file);
  98     $file =~ s/ link to .*//;
  99     $file =~ s/ -> .*//;
 100
 101     my $operm = perm2oct($perm);
 102
 103     if ($perm =~ m,^-,o) { # file checks
 104         # menu file?
 105         if ($file =~ m,^usr/(lib|share)/menu/\S,o) { # correct permissions?
 106             if ($perm =~ m,x,o) {
 107                 tag "executable-menu-file", sprintf("$file %04o",$operm);
 108             }
 109
 110             next if $file =~ m,^usr/(lib|share)/menu/README$,;
 111
 112             if ($file =~ m,^usr/lib/,o) {
 113                 tag "menu-file-in-usr-lib", $file;
 114             }
 115
 116             $menu_file = $file;
 117
 118             if ($file =~ m,usr/(lib|share)/menu/menu$,o and $pkg ne 'menu') {
 119                 tag "bad-menu-file-name", $file;
 120             }
 121         }
 122         # doc-base file?
 123         elsif ($file =~ m,^usr/share/doc-base/\S,o) { # correct permissions?
 124             if ($perm =~ m,x,o) {
 125                 tag "executable-in-usr-share-docbase", $file, sprintf("%04o",$operm);
 126             }
 127             $docbase_file = $file;
 128         }
 129         #menu-methods file?
 130         elsif ( $file =~ m,^etc/menu-methods/\S,o ) {
 131             #TODO: we should test if the menu-methods file
 132             # is made executable in the postinst as recommended by
 133             # the menu manual
 134
 135             my $menumethod_includes_menu_h = 0;
 136             $menumethod_file = $file;
 137
 138             open(MM, '<', "unpacked/$file") or fail("cannot open menu-method file $file: $!");
 139             while (<MM>) {
 140                 chomp;
 141                 if (m,^!include menu.h,o) {
 142                     $menumethod_includes_menu_h = 1;
 143                     last;
 144                 }
 145             }
 146             close MM;
 147             tag "menu-method-should-include-menu-h", "$file"
 148                 unless $menumethod_includes_menu_h or $pkg eq 'menu';
 149         }
 150     }
 151 }
 152 close IN;
 153
 154 # prerm scripts should not call update-menus
 155 if ($prerm{'calls-updatemenus'}) {
 156     tag "prerm-calls-updatemenus", "";
 157 }
 158
 159 # postrm scripts should not call install-docs
 160 if ($postrm{'calls-installdocs'} or $postrm{'calls-installdocs-r'}) {
 161     tag "postrm-calls-installdocs", "";
 162 }
 163
 164 # preinst scripts should not call either update-menus nor installdocs
 165 if ($preinst{'calls-updatemenus'}) {
 166     tag "preinst-calls-updatemenus", "";
 167 }
 168
 169 if ($preinst{'calls-installdocs'}) {
 170     tag "preinst-calls-installdocs", "";
 171 }
 172
 173 # don't set the /usr/doc link, the FHS transition is over (2002-10-08)
 174 if (defined $postinst{'sets-link'} && $postinst{'sets-link'} == 1) {
 175     tag "postinst-should-not-set-usr-doc-link", "";
 176 }
 177
 178 $anymenu_file = $menu_file || $menumethod_file;
 179
 180 # check consistency
 181 # docbase file?
 182 if ($docbase_file) {            # postinst has to call install-docs
 183     if (not $postinst{'calls-installdocs'}) {
 184         tag "postinst-does-not-call-installdocs", "$docbase_file";
 185     }
 186     # prerm has to call install-docs -r
 187     if (not $prerm{'calls-installdocs-r'}) {
 188         tag "prerm-does-not-call-installdocs", "$docbase_file";
 189     }
 190
 191     # check the contents of the doc-base file(s)
 192     opendir DOCBASEDIR, "doc-base" or fail("cannot read doc-base directory.");
 193     my $dbfile;
 194     while (defined ($dbfile = readdir DOCBASEDIR)) {
 195         # don't try to parse executables, plus we already warned about it
 196         next if -x "doc-base/$dbfile";
 197         check_doc_base_file($dbfile, $pkg, $type);
 198     }
 199     closedir DOCBASEDIR;
 200 } else {
 201     # postinst and postrm should not need to call install-docs
 202     if ($postinst{'calls-installdocs'} or $postinst{'calls-installdocs-r'}) {
 203         tag "postinst-has-useless-call-to-install-docs", "";
 204     }
 205     if ($prerm{'calls-installdocs'} or $prerm{'calls-installdocs-r'}) {
 206         tag "prerm-has-useless-call-to-install-docs", "";
 207     }
 208 }
 209
 210 if ($anymenu_file) {
 211     # postinst has to call update-menus
 212     if (not $postinst{'calls-updatemenus'}) {
 213         tag "postinst-does-not-call-updatemenus", "$anymenu_file";
 214     }
 215     # postrm has to call update-menus
 216     if (not $postrm{'calls-updatemenus'}) {
 217         tag "postrm-does-not-call-updatemenus", "$anymenu_file" unless $pkg eq 'menu';
 218     }
 219 } else {
 220     # postinst and postrm should not need to call update-menus
 221     if ($postinst{'calls-updatemenus'}) {
 222         tag "postinst-has-useless-call-to-update-menus", "";
 223     }
 224     if ($postrm{'calls-updatemenus'}) {
 225         tag "postrm-has-useless-call-to-update-menus", "";
 226     }
 227 }
 228
 229 }
 230
 231 # -----------------------------------
 232
 233 sub check_doc_base_file {
 234     my ($dbfile, $pkg, $type) = @_;
 235
 236     my $line = file_is_encoded_in_non_utf8("doc-base/$dbfile", $type, $pkg);
 237     if ($line) {
 238         tag 'doc-base-file-uses-obsolete-national-encoding', "$dbfile:$line";
 239     }
 240
 241     open (IN, '<', "doc-base/$dbfile")
 242         or fail("cannot open doc-base file $dbfile for reading.");
 243
 244     my (@files, $field, @vals);
 245     my $knownfields = \%known_docbase_main_fields;
 246     $line           = 0;  # global
 247     my %sawfields   = (); # local for each section of control file
 248     my %sawformats  = (); # global for control file
 249
 250     while (<IN>) {
 251         chomp;
 252
 253         # New field.  check previous field, if we have any.
 254         if (/^(\S+)\s*:\s*(.*)$/) {
 255             my (@new) = ($1, $2);
 256             if ($field) {
 257                 check_doc_base_field($dbfile, $line, $field, \@vals,
 258                                      \%sawfields, \%sawformats, $knownfields);
 259             }
 260             $field = lc $new[0];
 261             @vals  = ($new[1]);
 262             $line  = $.;
 263
 264         # Continuation of previously defined field.
 265         } elsif ($field && /^\s+\S/) {
 266             push (@vals, $_);
 267
 268             # All tags will be reported on the last continuation line of the
 269             # doc-base field.
 270             $line  = $.;
 271
 272         # Sections' separator.
 273         } elsif (/^(\s*)$/) {
 274             tag "doc-base-file-separator-extra-whitespaces", "$dbfile:$."
 275                 if $1;
 276             next unless $field; # skip successive empty lines
 277
 278             # Check previously defined field and section.
 279             check_doc_base_field($dbfile, $line, $field, \@vals, \%sawfields,
 280                                  \%sawformats, $knownfields);
 281             check_doc_base_file_section($dbfile, $line + 1, \%sawfields,
 282                                         \%sawformats, $knownfields);
 283
 284             # Intialize variables for new section.
 285             undef $field;
 286             undef $line;
 287             @vals      = ();
 288             %sawfields = ();
 289
 290             # Each section except the first one is format section.
 291             $knownfields = \%known_docbase_format_fields;
 292
 293         # Everything else is a syntax error.
 294         } else {
 295             tag "doc-base-file-syntax-error", "$dbfile:$.";
 296         }
 297     }
 298
 299     # Check the last field/section of the control file.
 300     if ($field) {
 301         check_doc_base_field($dbfile, $line, $field, \@vals, \%sawfields,
 302                              \%sawformats, $knownfields);
 303         check_doc_base_file_section($dbfile, $line, \%sawfields, \%sawformats,
 304                                     $knownfields);
 305     }
 306
 307     # Make sure we saw at least one format.
 308     tag "doc-base-file-no-format-section", "$dbfile:$." unless %sawformats;
 309
 310     close IN;
 311 }
 312
 313 # Checks one field of a doc-base control file.  $vals is array ref containing
 314 # all lines of the field.  Modifies $sawfields and $sawformats.
 315 sub check_doc_base_field {
 316     my ($dbfile, $line, $field, $vals, $sawfields, $sawformats,
 317         $knownfields) = @_;
 318
 319     tag "doc-base-file-unknown-field", "$dbfile:$line", "$field"
 320         unless defined $knownfields->{$field};
 321     tag "doc-base-file-duplicated-field", "$dbfile:$line", "$field"
 322         if $sawfields->{$field};
 323     $sawfields->{$field} = 1;
 324
 325     # Index/Files field.
 326     #
 327     # Check if files referenced by doc-base are included in the package.  The
 328     # Index field should refer to only one file without wildcards.  The Files
 329     # field is a whitespace-separated list of files and may contain wildcards.
 330     # We skip without validating wildcard patterns containing character
 331     # classes since otherwise we'd need to deal with wildcards inside
 332     # character classes and aren't there yet.
 333     if ($field eq 'index' or $field eq 'files') {
 334         my @files = map { split ('\s+', $_) } @$vals;
 335
 336         if ($field eq 'index' && @files > 1) {
 337             tag "doc-base-index-references-multiple-files", "$dbfile:$line";
 338         }
 339         for my $file (@files) {
 340             if ($file =~ m%^/usr/doc%) {
 341                 tag "doc-base-file-references-usr-doc", "$dbfile:$line";
 342             }
 343             my $realfile = delink ($file);
 344
 345             # openoffice.org-dev-doc has thousands of files listed so try to
 346             # use the hash if possible.
 347             my $found;
 348             if ($realfile =~ /[*?]/) {
 349                 my $regex = quotemeta ($realfile);
 350                 unless ($field eq 'index') {
 351                     next if $regex =~ /\[/;
 352                     $regex =~ s%\\\*%[^/]*%g;
 353                     $regex =~ s%\\\?%[^/]%g;
 354                     $regex .= '/?';
 355                 }
 356                 $found = grep { /^$regex\z/ } keys %all_files;
 357             } else {
 358                 $found = $all_files{$realfile} || $all_files{"$realfile/"};
 359             }
 360             unless ($found) {
 361                 tag "doc-base-file-references-missing-file", "$dbfile:$line",
 362                     $file;
 363             }
 364         }
 365         undef @files;
 366
 367     # Format field.
 368     } elsif ($field eq 'format') {
 369         my $format = join (' ', @$vals);
 370         $format =~ s/^\s+//o;
 371         $format =~ s/\s+$//o;
 372         $format = lc $format;
 373         tag "doc-base-file-unknown-format", "$dbfile:$line", $format
 374             unless $known_doc_base_formats{$format};
 375         tag "doc-base-file-duplicated-format", "$dbfile:$line", $format
 376             if $sawformats->{$format};
 377         $sawformats->{$format} = 1;
 378
 379         # Save the current format for the later section check.
 380         $sawformats->{' *current* '} = $format;
 381
 382     # Document field.
 383     } elsif ($field eq 'document') {
 384         $_ = join (' ', @$vals);
 385
 386         tag "doc-base-invalid-document-field", "$dbfile:$line", "$_"
 387             unless /^[a-z0-9+.-]+$/;
 388         tag "doc-base-document-field-ends-in-whitespace", "$dbfile:$line"
 389             if /[ \t]$/;
 390         tag "doc-base-document-field-not-in-first-line", "$dbfile:$line"
 391             unless $line == 1;
 392
 393     # Title field.
 394     } elsif ($field eq 'title') {
 395         if (@$vals) {
 396             spelling_check("spelling-error-in-doc-base-title-field",
 397                            join (' ', @$vals), "$dbfile:$line");
 398             spelling_check_picky("spelling-error-in-doc-base-title-field",
 399                                  join (' ', @$vals), "$dbfile:$line");
 400         }
 401
 402     # Section field.
 403     } elsif ($field eq 'section') {
 404         my $sections = Lintian::Data->new('doc-base/sections');
 405         $_ = join (' ', @$vals);
 406         tag "doc-base-unknown-section", "$dbfile:$line", $_
 407             unless $sections->known($_);
 408
 409     # Abstract field.
 410     } elsif ($field eq 'abstract') {
 411         # The three following variables are used for checking if the field is
 412         # correctly phrased.  We detect if each line (except for the first
 413         # line and lines containing single dot) of the field starts with the
 414         # same number of spaces, not followed by the same non-space character,
 415         # and the number of spaces is > 1.
 416         #
 417         # We try to match fields like this:
 418         #  ||Abstract: The Boost web site provides free peer-reviewed portable
 419         #  ||  C++ source libraries.  The emphasis is on libraries which work
 420         #  ||  well with the C++ Standard Library.  One goal is to establish
 421         #
 422         # but not like this:
 423         #  ||Abstract:  This is "Ding"
 424         #  ||  * a dictionary lookup program for Unix,
 425         #  ||  * DIctionary Nice Grep,
 426         my $leadsp    = undef; # string with leading spaces from second line
 427         my $charafter = undef; # first non-whitespace char of second line
 428         my $leadsp_ok = 1;     # are spaces OK?
 429
 430         # Intentionally skipping the first line.
 431         for my $idx (1 .. $#{$vals}) {
 432             $_ = $vals->[$idx];
 433             if (/manage\s+online\s+manuals\s.*Debian/o) {
 434                 tag "doc-base-abstract-field-is-template", "$dbfile:$line"
 435                     unless $pkg eq "doc-base";
 436             } elsif (/^(\s+)\.(\s*)$/o and ($1 ne " " or $2)) {
 437                 tag "doc-base-abstract-field-separator-extra-whitespaces",
 438                     "$dbfile:" . ($line - $#{$vals} + $idx);
 439             } elsif (!$leadsp && /^(\s+)(\S)/o) {
 440                 # The regexp should always match.
 441                 ($leadsp, $charafter) = ($1, $2);
 442                 $leadsp_ok = $leadsp eq " ";
 443             } elsif (!$leadsp_ok && /^(\s+)(\S)/o) {
 444                 # The regexp should always match.
 445                 undef $charafter if $charafter && $charafter ne $2;
 446                 $leadsp_ok = 1
 447                     if ($1 ne $leadsp) || ($1 eq $leadsp && $charafter);
 448             }
 449         }
 450         unless ($leadsp_ok) {
 451             tag "doc-base-abstract-might-contain-extra-leading-whitespaces",
 452                 "$dbfile:$line";
 453         }
 454
 455         # Check spelling.
 456         if (@$vals) {
 457             spelling_check("spelling-error-in-doc-base-abstract-field",
 458                            join (' ', @$vals), "$dbfile:$line");
 459             spelling_check_picky("spelling-error-in-doc-base-abstract-field",
 460                                  join (' ', @$vals), "$dbfile:$line");
 461         }
 462     }
 463 }
 464
 465 # Checks the section of the doc-base control file.  Tries to find required
 466 # fields missing in the section.
 467 sub check_doc_base_file_section {
 468     my ($dbfile, $line, $sawfields, $sawformats, $knownfields) = @_;
 469
 470     tag "doc-base-file-no-format", "$dbfile:$line"
 471         if ((defined $sawfields->{'files'} || defined $sawfields->{'index'})
 472             && !(defined $sawfields->{'format'}));
 473
 474     # The current format is set by check_doc_base_field.
 475     if ($sawfields->{'format'}) {
 476         my $format =  $sawformats->{' *current* '};
 477         tag "doc-base-file-no-index", "$dbfile:$line"
 478             if ($format && ($format eq 'html' || $format eq 'info')
 479                 && !$sawfields->{'index'});
 480     }
 481     for my $field (sort keys %$knownfields) {
 482         tag "doc-base-file-lacks-required-field", "$dbfile:$line", "$field"
 483             if ($knownfields->{$field} == 1 && !$sawfields->{$field});
 484     }
 485 }
 486
 487 # Add file and link to %all_files and %all_links.  Note that both files and
 488 # links have to include a leading /.
 489 sub add_file_link_info {
 490     my $file = shift;
 491     my $link = undef;
 492
 493     $file = "/" . $file if (not $file =~ m%^/%); # make file absolute
 494     $file =~ s%/+%/%g;                           # remove duplicated `/'
 495     my $ishard = ($file =~ / link to /);
 496     ($file, $link) = split(/ (?:->|link to) /, $file);
 497
 498     $all_files{$file} = 1;
 499
 500     if (defined $link) {
 501         if ($ishard) {
 502             $link =~ s,^\./,/,;
 503         } elsif (not $link =~ m,^/,) {            # not absolute link
 504             $link = "/" . $link;                  # make sure link starts with '/'
 505             $link =~ s,/+\./+,/,g;                # remove all /./ parts
 506             my $dcount = 1;
 507             while ($link =~ s,^/+\.\./+,/,) {     #\ count & remove
 508                $dcount++;                         #/ any leading /../ parts
 509             }
 510             my $f = $file;
 511             while ($dcount--) {                   #\ remove last $dcount
 512                 $f =~ s,/[^/]*$,,;                #/ path components from $file
 513             }
 514             $link = $f . $link;                   # now we should have absolute link
 515         }
 516         $all_links{$file} = $link unless ($link eq $file);
 517     }
 518 }
 519
 520
 521 # Dereference all symlinks in file.  Uses %all_links.
 522 sub delink {
 523     my $file = shift;
 524
 525     $file =~ s%/+%/%g;                            # remove duplicated '/'
 526     return $file unless %all_links;               # package doesn't symlinks
 527
 528     my $p1 = "";
 529     my $p2 = $file;
 530     my %used_links = ();
 531
 532     # In the loop below we split $file into two parts on each '/' until
 533     # there's no remaining slashes.  We try substituting the first part with
 534     # corresponding symlink and if it succeedes, we start the procedure from
 535     # beginning.
 536     #
 537     # Example:
 538     #    Let $all_links{"/a/b"} == "/d", and $file == "/a/b/c"
 539     #    Then 0) $p1 == "",     $p2 == "/a/b/c"
 540     #         1) $p1 == "/a",   $p2 == "/b/c"
 541     #         2) $p1 == "/a/b", $p2 == "/c"      ; substitute "/d" for "/a/b"
 542     #         3) $p1 == "",     $p2 == "/d/c"
 543     #         4) $p1 == "/d",   $p2 == "/c"
 544     #         5) $p1 == "/d/c", $p2 == ""
 545     #
 546     # Note that the algorithm supposes, that
 547     #    i) $all_links{$X} != $X for each $X
 548     #   ii) both keys and values of %all_links start with '/'
 549
 550     while (($p2 =~ s%^(/[^/]*)%%g) > 0) {
 551         $p1 .= $1;
 552         if (defined $all_links{$p1}) {
 553             return '!!! SYMLINK LOOP !!!' if defined $used_links{$p1};
 554             $p2 = $all_links{$p1} . $p2;
 555             $p1 = "";
 556             $used_links{$p1} = 1;
 557         }
 558     }
 559
 560     # After the loop $p2 should be empty and $p1 should contain the target
 561     # file.  In some rare cases when $file contains no slashes, $p1 will be
 562     # empty and $p2 will contain the result (which will be equal to $file).
 563     return $p1 ne "" ? $p1 : $p2;
 564 }
 565
 566 sub check_script {
 567     my ($script,$pres) = @_;
 568     my ($no_check_menu,$no_check_installdocs,$no_check_wmmenu,$calls_wmmenu);
 569     my $interp;
 570
 571     open(IN, '<', "control/$script") or
 572         fail("cannot open maintainer script control/$script for reading: $!");
 573     $interp = <IN>;
 574     $interp = '' unless defined $interp;
 575     if ($interp =~ m,^\#\!\s*/bin/(a|ba|k|pdk)?sh,) {
 576         $interp = 'sh';
 577     } elsif ($interp =~ m,^\#\!\s*/usr/bin/perl,) {
 578         $interp = 'perl';
 579     } else {
 580         if ($interp =~ m,^\#\!\s*(.+),) {
 581             $interp = $1;
 582         }
 583         else { # hmm, doesn't seem to start with #!
 584             # is it a binary? look for ELF header
 585             if ($interp =~ m/^\177ELF/) {
 586                 return; # nothing to do here
 587             }
 588             $interp = 'unknown';
 589         }
 590     }
 591
 592     while (<IN>) {
 593         # skip comments
 594         s/\#.*$//o;
 595
 596         ##
 597         # either update-menus or wm-menu-config will satisfy
 598         # the checks that the menu file installed is properly used
 599         ##
 600
 601         # does the script check whether update-menus exists?
 602         if (/-x\s+\S*update-menus/o or /(which|command)(\s+\S+)?\s+update-menus/o) {
 603             # yes, it does.
 604             $pres->{'checks-for-updatemenus'} = 1;
 605         }
 606
 607         # does the script call update-menus?
 608         # TODO this regex-magic should be moved to some lib for checking
 609         # whether a certain word is likely called as command... --Jeroen
 610         if (/(?:^\s*|[;&|]\s*|(?:then|do)\s+)(?:\/usr\/bin\/)?update-menus(?:\s|[;&|<>]|$)/) {
 611             # yes, it does.
 612             $pres->{'calls-updatemenus'} = 1;
 613
 614             # checked first?
 615             if (not $pres->{'checks-for-updatemenus'} and $pkg ne 'menu') {
 616                 tag "maintainer-script-does-not-check-for-existence-of-updatemenus", "$script:$." unless $no_check_menu++;
 617             }
 618         }
 619
 620         # does the script check whether wm-menu-config exists?
 621         if (s/-x\s+\S*wm-menu-config//o or /which\s+wm-menu-config/o
 622             or s/command\s+.*?wm-menu-config//o) {
 623             # yes, it does.
 624             $pres->{'checks-for-wmmenuconfig'} = 1;
 625         }
 626
 627         # does the script call wm-menu-config?
 628         if (m/(?:^\s*|[;&|]\s*|(?:then|do)\s+)(?:\/usr\/sbin\/)?wm-menu-config(?:\s|[;&|<>]|$)/) {
 629             # yes, it does.
 630             $pres->{'calls-wmmenuconfig'} = 1;
 631             tag "maintainer-script-calls-deprecated-wm-menu-config", "$script:$." unless $calls_wmmenu++;
 632
 633             # checked first?
 634             if (not $pres->{'checks-for-wmmenuconfig'} and $pkg ne 'menu') {
 635                 tag "maintainer-script-does-not-check-for-existence-of-wm-menu-config", "$script:$." unless $no_check_wmmenu++;
 636             }
 637         }
 638
 639         # does the script set a link in /usr/doc?
 640         # does the script remove a link in /usr/doc?
 641         if ($interp eq 'sh') {
 642             if (m,ln\s+(-\w+)?\s+\"?\.\./share/doc/\S+, ) {
 643                 $pres->{'sets-link'} = 1;
 644             }
 645             if (m,rm\s+(-\w+\s+)?\"?/usr/doc/\S+, ) {
 646                 $pres->{'removes-link'} = 1;
 647             }
 648         } elsif ($interp eq 'perl') {
 649             if (m|symlink\s*\(?\s*[\"\']\.\./share/doc/\.+?[\"\']\s*,|) {
 650                 $pres->{'sets-link'} = 1;
 651             } elsif (m,ln\s+(-\w+)?\s+\"?\.\./share/doc/\S+, ) {
 652                 $pres->{'sets-link'} = 1;
 653             }
 654         } else {
 655             # just fall through for now
 656         }
 657
 658         # does the script check whether install-docs exists?
 659         if (s/-x\s+\S*install-docs//o or /which\s+install-docs/o
 660             or s/command\s+.*?install-docs//o) {
 661             # yes, it does.
 662             $pres->{'checks-for-installdocs'} = 1;
 663         }
 664
 665         # does the script call install-docs?
 666         if (m/(?:^\s*|[;&|]\s*|(?:then|do)\s+)(?:\/usr\/sbin\/)?install-docs(?:\s|[;&|<>]|$)/) {
 667             # yes, it does.  Does it remove or add a doc?
 668             if (m/install-docs\s+(-r|--remove)\s/) {
 669                 $pres->{'calls-installdocs-r'} = 1;
 670             } else {
 671                 $pres->{'calls-installdocs'} = 1;
 672             }
 673             # checked first?
 674             if (not $pres->{'checks-for-installdocs'}) {
 675                 tag "maintainer-script-does-not-check-for-existence-of-installdocs", "$script" unless $no_check_installdocs++;
 676             }
 677         }
 678     }
 679     close IN;
 680 }
 681
 682 1;
 683
 684 # Local Variables:
 685 # indent-tabs-mode: t
 686 # cperl-indent-level: 4
 687 # End:
 688 # vim: syntax=perl