1 # menus -- lintian check script -*- perl -*-
3 # somewhat of a misnomer -- it doesn't only check menus
5 # Copyright (C) 1998 Christian Schwarz
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.
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.
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,
23 package Maemian::menus;
26 use lib "$ENV{'MAEMIAN_ROOT'}/checks/";
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' );
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 = (
47 our %KNOWN_DOCBASE_FORMAT_FIELDS = (
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
77 if (-f 'control/preinst') {
78 check_script($pkg, 'preinst', \%preinst);
80 if (-f 'control/postinst') {
81 check_script($pkg, 'postinst', \%postinst);
83 if (-f 'control/prerm') {
84 check_script($pkg, 'prerm', \%prerm);
86 if (-f 'control/postrm') {
87 check_script($pkg, 'postrm', \%postrm);
90 # read package contents
91 for my $file (sort keys %{$info->index}) {
94 add_file_link_info ($info, $file, \%all_files, \%all_links);
95 my $index_info = $info->index->{$file};
96 my $operm = $index_info->{operm};
98 if ($index_info->{type} =~ m,^[-h],) { # file checks
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);
105 next if $file =~ m,^usr/(lib|share)/menu/README$,;
107 if ($file =~ m,^usr/lib/,o) {
108 tag "menu-file-in-usr-lib", $file;
113 if ($file =~ m,usr/(lib|share)/menu/menu$,o and $pkg ne 'menu') {
114 tag "bad-menu-file-name", $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);
122 $docbase_file = $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
130 my $menumethod_includes_menu_h = 0;
131 $menumethod_file = $file;
133 open(MM, '<', "unpacked/$file") or fail("cannot open menu-method file $file: $!");
136 if (m,^!include menu.h,o) {
137 $menumethod_includes_menu_h = 1;
142 tag "menu-method-should-include-menu-h", "$file"
143 unless $menumethod_includes_menu_h or $pkg eq 'menu';
149 # prerm scripts should not call update-menus
150 if ($prerm{'calls-updatemenus'}) {
151 tag "prerm-calls-updatemenus";
154 # postrm scripts should not call install-docs
155 if ($postrm{'calls-installdocs'} or $postrm{'calls-installdocs-r'}) {
156 tag "postrm-calls-installdocs";
159 # preinst scripts should not call either update-menus nor installdocs
160 if ($preinst{'calls-updatemenus'}) {
161 tag "preinst-calls-updatemenus";
164 if ($preinst{'calls-installdocs'}) {
165 tag "preinst-calls-installdocs";
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";
173 $anymenu_file = $menu_file || $menumethod_file;
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";
179 if ($prerm{'calls-installdocs'} or $prerm{'calls-installdocs-r'}) {
180 tag "prerm-has-useless-call-to-install-docs";
186 opendir DOCBASEDIR, "doc-base" or fail("cannot read doc-base directory.");
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);
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.
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";
209 if ($menumethod_file and not $postrm{'calls-updatemenus'}) {
210 tag "postrm-does-not-call-updatemenus", "$menumethod_file"
211 unless $pkg eq 'menu';
214 if ($postinst{'calls-updatemenus'}) {
215 tag "postinst-has-useless-call-to-update-menus";
217 if ($postrm{'calls-updatemenus'}) {
218 tag "postrm-has-useless-call-to-update-menus";
224 # -----------------------------------
226 sub check_doc_base_file {
227 my ($dbfile, $pkg, $type, $all_files, $all_links) = @_;
229 my $line = file_is_encoded_in_non_utf8("doc-base/$dbfile", $type, $pkg);
231 tag 'doc-base-file-uses-obsolete-national-encoding', "$dbfile:$line";
234 open (IN, '<', "doc-base/$dbfile")
235 or fail("cannot open doc-base file $dbfile for reading.");
237 my (@files, $field, @vals);
238 my $knownfields = \%KNOWN_DOCBASE_MAIN_FIELDS;
240 my %sawfields = (); # local for each section of control file
241 my %sawformats = (); # global for control file
246 # New field. check previous field, if we have any.
247 if (/^(\S+)\s*:\s*(.*)$/) {
248 my (@new) = ($1, $2);
250 check_doc_base_field($pkg, $dbfile, $line, $field, \@vals,
251 \%sawfields, \%sawformats, $knownfields,
252 $all_files, $all_links);
258 # Continuation of previously defined field.
259 } elsif ($field && /^\s+\S/) {
262 # All tags will be reported on the last continuation line of the
266 # Sections' separator.
267 } elsif (/^(\s*)$/) {
268 tag "doc-base-file-separator-extra-whitespaces", "$dbfile:$."
270 next unless $field; # skip successive empty lines
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);
279 # Intialize variables for new section.
285 # Each section except the first one is format section.
286 $knownfields = \%KNOWN_DOCBASE_FORMAT_FIELDS;
288 # Everything else is a syntax error.
290 tag "doc-base-file-syntax-error", "$dbfile:$.";
294 # Check the last field/section of the control file.
296 check_doc_base_field($pkg, $dbfile, $line, $field, \@vals, \%sawfields,
297 \%sawformats, $knownfields, $all_files,
299 check_doc_base_file_section($dbfile, $line, \%sawfields, \%sawformats,
303 # Make sure we saw at least one format.
304 tag "doc-base-file-no-format-section", "$dbfile:$." unless %sawformats;
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) = @_;
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;
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;
332 if ($field eq 'index' && @files > 1) {
333 tag "doc-base-index-references-multiple-files", "$dbfile:$line";
335 for my $file (@files) {
337 if ($file =~ m%^/usr/doc%) {
338 tag "doc-base-file-references-usr-doc", "$dbfile:$line";
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.
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;
352 $found = grep { /^$regex\z/ } keys %$all_files;
354 $found = $all_files->{$realfile} || $all_files->{"$realfile/"};
357 tag "doc-base-file-references-missing-file", "$dbfile:$line",
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;
375 # Save the current format for the later section check.
376 $sawformats->{' *current* '} = $format;
379 } elsif ($field eq 'document') {
380 $_ = join (' ', @$vals);
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"
386 tag "doc-base-document-field-not-in-first-line", "$dbfile:$line"
390 } elsif ($field eq 'title') {
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");
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
408 tag "doc-base-unknown-section", "$dbfile:$line", $_;
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.
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
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?
433 # Intentionally skipping the first line.
434 for my $idx (1 .. $#{$vals}) {
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;
450 if ($1 ne $leadsp) || ($1 eq $leadsp && $charafter);
453 unless ($leadsp_ok) {
454 tag "doc-base-abstract-might-contain-extra-leading-whitespaces",
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");
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) = @_;
473 tag "doc-base-file-no-format", "$dbfile:$line"
474 if ((defined $sawfields->{'files'} || defined $sawfields->{'index'})
475 && !(defined $sawfields->{'format'}));
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'});
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});
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');
497 $file = "/" . $file if (not $file =~ m%^/%); # make file absolute
498 $file =~ s%/+%/%g; # remove duplicated `/'
499 $all_files->{$file} = 1;
502 $link = './' . $link if $link !~ m,^/,;
505 } elsif (not $link =~ m,^/,) { # not absolute link
506 $link = "/" . $link; # make sure link starts with '/'
507 $link =~ s,/+\./+,/,g; # remove all /./ parts
509 while ($link =~ s,^/+\.\./+,/,) { #\ count & remove
510 $dcount++; #/ any leading /../ parts
513 while ($dcount--) { #\ remove last $dcount
514 $f =~ s,/[^/]*$,,; #/ path components from $file
516 $link = $f . $link; # now we should have absolute link
518 $all_links->{$file} = $link unless ($link eq $file);
523 # Dereference all symlinks in file.
525 my ($file, $all_links) = @_;
527 $file =~ s%/+%/%g; # remove duplicated '/'
528 return $file unless %$all_links; # package doesn't symlinks
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
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 == ""
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 '/'
552 while (($p2 =~ s%^(/[^/]*)%%g) > 0) {
554 if (defined $all_links->{$p1}) {
555 return '!!! SYMLINK LOOP !!!' if defined $used_links{$p1};
556 $p2 = $all_links->{$p1} . $p2;
558 $used_links{$p1} = 1;
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;
569 my ($pkg, $script, $pres) = @_;
570 my ($no_check_menu,$no_check_installdocs,$no_check_wmmenu,$calls_wmmenu);
573 open(IN, '<', "control/$script") or
574 fail("cannot open maintainer script control/$script for reading: $!");
576 $interp = '' unless defined $interp;
577 if ($interp =~ m,^\#\!\s*/bin/$known_shells_regex,) {
579 } elsif ($interp =~ m,^\#\!\s*/usr/bin/perl,) {
582 if ($interp =~ m,^\#\!\s*(.+),) {
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
599 # either update-menus or wm-menu-config will satisfy
600 # the checks that the menu file installed is properly used
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) {
607 $pres->{'checks-for-updatemenus'} = 1;
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|[;&|<>]|$)/) {
615 $pres->{'calls-updatemenus'} = 1;
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++;
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) {
627 $pres->{'checks-for-wmmenuconfig'} = 1;
630 # does the script call wm-menu-config?
631 if (m/(?:^\s*|[;&|]\s*|(?:then|do)\s+)(?:\/usr\/sbin\/)?wm-menu-config(?:\s|[;&|<>]|$)/) {
633 $pres->{'calls-wmmenuconfig'} = 1;
634 tag "maintainer-script-calls-deprecated-wm-menu-config", "$script:$." unless $calls_wmmenu++;
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++;
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;
648 if (m,rm\s+(-\w+\s+)?\"?/usr/doc/\S+, ) {
649 $pres->{'removes-link'} = 1;
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;
658 # just fall through for now
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) {
665 $pres->{'checks-for-installdocs'} = 1;
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;
674 $pres->{'calls-installdocs'} = 1;
677 if (not $pres->{'checks-for-installdocs'}) {
678 tag "maintainer-script-does-not-check-for-existence-of-installdocs", "$script" unless $no_check_installdocs++;
688 # indent-tabs-mode: t
689 # cperl-indent-level: 4