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