--- /dev/null
+# menus -- lintian check script -*- perl -*-
+
+# somewhat of a misnomer -- it doesn't only check menus
+
+# Copyright (C) 1998 Christian Schwarz
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at http://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Maemian::menus;
+use strict;
+
+use lib "$ENV{'MAEMIAN_ROOT'}/checks/";
+use common_data;
+
+use Maemian::Data;
+use Spelling;
+use Tags;
+use Util;
+
+# Supported documentation formats for doc-base files.
+our %known_doc_base_formats = map { $_ => 1 }
+ ( 'html', 'text', 'pdf', 'postscript', 'info', 'dvi', 'debiandoc-sgml' );
+
+# Known fields for doc-base files. The value is 1 for required fields and 0
+# for optional fields.
+our %KNOWN_DOCBASE_MAIN_FIELDS = (
+ 'document' => 1,
+ 'title' => 1,
+ 'section' => 1,
+ 'abstract' => 0,
+ 'author' => 0
+);
+our %KNOWN_DOCBASE_FORMAT_FIELDS = (
+ 'format' => 1,
+ 'files' => 1,
+ 'index' => 0
+);
+
+# Will contain the list of valid sections as a Maemian::Data object if it's
+# needed. We don't load it unless we need it since many packages don't have
+# doc-base files.
+our $SECTIONS;
+
+sub run {
+
+my $pkg = shift;
+my $type = shift;
+my $info = shift;
+
+my %all_files = ();
+my %all_links = ();
+
+my %preinst;
+my %postinst;
+my %prerm;
+my %postrm;
+
+my $docbase_file;
+my $menu_file;
+my $menumethod_file;
+my $anymenu_file;
+
+if (-f 'control/preinst') {
+ check_script($pkg, 'preinst', \%preinst);
+}
+if (-f 'control/postinst') {
+ check_script($pkg, 'postinst', \%postinst);
+}
+if (-f 'control/prerm') {
+ check_script($pkg, 'prerm', \%prerm);
+}
+if (-f 'control/postrm') {
+ check_script($pkg, 'postrm', \%postrm);
+}
+
+# read package contents
+for my $file (sort keys %{$info->index}) {
+ next if $file eq "";
+
+ add_file_link_info ($info, $file, \%all_files, \%all_links);
+ my $index_info = $info->index->{$file};
+ my $operm = $index_info->{operm};
+
+ if ($index_info->{type} =~ m,^[-h],) { # file checks
+ # menu file?
+ if ($file =~ m,^usr/(lib|share)/menu/\S,o) { # correct permissions?
+ if ($operm & 01 or $operm & 010 or $operm & 0100) {
+ tag "executable-menu-file", sprintf("$file %04o",$operm);
+ }
+
+ next if $file =~ m,^usr/(lib|share)/menu/README$,;
+
+ if ($file =~ m,^usr/lib/,o) {
+ tag "menu-file-in-usr-lib", $file;
+ }
+
+ $menu_file = $file;
+
+ if ($file =~ m,usr/(lib|share)/menu/menu$,o and $pkg ne 'menu') {
+ tag "bad-menu-file-name", $file;
+ }
+ }
+ # doc-base file?
+ elsif ($file =~ m,^usr/share/doc-base/\S,o) { # correct permissions?
+ if ($operm & 01 or $operm & 010 or $operm & 0100) {
+ tag "executable-in-usr-share-docbase", $file, sprintf("%04o",$operm);
+ }
+ $docbase_file = $file;
+ }
+ #menu-methods file?
+ elsif ( $file =~ m,^etc/menu-methods/\S,o ) {
+ #TODO: we should test if the menu-methods file
+ # is made executable in the postinst as recommended by
+ # the menu manual
+
+ my $menumethod_includes_menu_h = 0;
+ $menumethod_file = $file;
+
+ open(MM, '<', "unpacked/$file") or fail("cannot open menu-method file $file: $!");
+ while (<MM>) {
+ chomp;
+ if (m,^!include menu.h,o) {
+ $menumethod_includes_menu_h = 1;
+ last;
+ }
+ }
+ close MM;
+ tag "menu-method-should-include-menu-h", "$file"
+ unless $menumethod_includes_menu_h or $pkg eq 'menu';
+ }
+ }
+}
+close IN;
+
+# prerm scripts should not call update-menus
+if ($prerm{'calls-updatemenus'}) {
+ tag "prerm-calls-updatemenus";
+}
+
+# postrm scripts should not call install-docs
+if ($postrm{'calls-installdocs'} or $postrm{'calls-installdocs-r'}) {
+ tag "postrm-calls-installdocs";
+}
+
+# preinst scripts should not call either update-menus nor installdocs
+if ($preinst{'calls-updatemenus'}) {
+ tag "preinst-calls-updatemenus";
+}
+
+if ($preinst{'calls-installdocs'}) {
+ tag "preinst-calls-installdocs";
+}
+
+# don't set the /usr/doc link, the FHS transition is over (2002-10-08)
+if (defined $postinst{'sets-link'} && $postinst{'sets-link'} == 1) {
+ tag "postinst-should-not-set-usr-doc-link";
+}
+
+$anymenu_file = $menu_file || $menumethod_file;
+
+# No one needs to call install-docs any more; triggers now handles that.
+if ($postinst{'calls-installdocs'} or $postinst{'calls-installdocs-r'}) {
+ tag "postinst-has-useless-call-to-install-docs";
+}
+if ($prerm{'calls-installdocs'} or $prerm{'calls-installdocs-r'}) {
+ tag "prerm-has-useless-call-to-install-docs";
+}
+
+# check consistency
+# docbase file?
+if ($docbase_file) {
+ opendir DOCBASEDIR, "doc-base" or fail("cannot read doc-base directory.");
+ my $dbfile;
+ while (defined ($dbfile = readdir DOCBASEDIR)) {
+ # don't try to parse executables, plus we already warned about it
+ next if -x "doc-base/$dbfile";
+ check_doc_base_file($dbfile, $pkg, $type, \%all_files, \%all_links);
+ }
+ closedir DOCBASEDIR;
+}
+
+if ($anymenu_file) {
+ # postinst and postrm should not need to call update-menus unless there is
+ # a menu-method file. However, update-menus currently won't enable
+ # packages that have outstanding triggers, leading to an update-menus call
+ # being required for at least some packages right now. Until this bug is
+ # fixed, we still require it. See #518919 for more information.
+ #
+ # That bug does not require calling update-menus from postrm, but
+ # debhelper apparently currently still adds that to the maintainer script,
+ # so don't warn if it's done.
+ if (not $postinst{'calls-updatemenus'}) {
+ tag "postinst-does-not-call-updatemenus", "$anymenu_file";
+ }
+ if ($menumethod_file and not $postrm{'calls-updatemenus'}) {
+ tag "postrm-does-not-call-updatemenus", "$menumethod_file"
+ unless $pkg eq 'menu';
+ }
+} else {
+ if ($postinst{'calls-updatemenus'}) {
+ tag "postinst-has-useless-call-to-update-menus";
+ }
+ if ($postrm{'calls-updatemenus'}) {
+ tag "postrm-has-useless-call-to-update-menus";
+ }
+}
+
+}
+
+# -----------------------------------
+
+sub check_doc_base_file {
+ my ($dbfile, $pkg, $type, $all_files, $all_links) = @_;
+
+ my $line = file_is_encoded_in_non_utf8("doc-base/$dbfile", $type, $pkg);
+ if ($line) {
+ tag 'doc-base-file-uses-obsolete-national-encoding', "$dbfile:$line";
+ }
+
+ open (IN, '<', "doc-base/$dbfile")
+ or fail("cannot open doc-base file $dbfile for reading.");
+
+ my (@files, $field, @vals);
+ my $knownfields = \%KNOWN_DOCBASE_MAIN_FIELDS;
+ $line = 0; # global
+ my %sawfields = (); # local for each section of control file
+ my %sawformats = (); # global for control file
+
+ while (<IN>) {
+ chomp;
+
+ # New field. check previous field, if we have any.
+ if (/^(\S+)\s*:\s*(.*)$/) {
+ my (@new) = ($1, $2);
+ if ($field) {
+ check_doc_base_field($pkg, $dbfile, $line, $field, \@vals,
+ \%sawfields, \%sawformats, $knownfields,
+ $all_files, $all_links);
+ }
+ $field = lc $new[0];
+ @vals = ($new[1]);
+ $line = $.;
+
+ # Continuation of previously defined field.
+ } elsif ($field && /^\s+\S/) {
+ push (@vals, $_);
+
+ # All tags will be reported on the last continuation line of the
+ # doc-base field.
+ $line = $.;
+
+ # Sections' separator.
+ } elsif (/^(\s*)$/) {
+ tag "doc-base-file-separator-extra-whitespaces", "$dbfile:$."
+ if $1;
+ next unless $field; # skip successive empty lines
+
+ # Check previously defined field and section.
+ check_doc_base_field($pkg, $dbfile, $line, $field, \@vals,
+ \%sawfields, \%sawformats, $knownfields,
+ $all_files, $all_links);
+ check_doc_base_file_section($dbfile, $line + 1, \%sawfields,
+ \%sawformats, $knownfields);
+
+ # Intialize variables for new section.
+ undef $field;
+ undef $line;
+ @vals = ();
+ %sawfields = ();
+
+ # Each section except the first one is format section.
+ $knownfields = \%KNOWN_DOCBASE_FORMAT_FIELDS;
+
+ # Everything else is a syntax error.
+ } else {
+ tag "doc-base-file-syntax-error", "$dbfile:$.";
+ }
+ }
+
+ # Check the last field/section of the control file.
+ if ($field) {
+ check_doc_base_field($pkg, $dbfile, $line, $field, \@vals, \%sawfields,
+ \%sawformats, $knownfields, $all_files,
+ $all_links);
+ check_doc_base_file_section($dbfile, $line, \%sawfields, \%sawformats,
+ $knownfields);
+ }
+
+ # Make sure we saw at least one format.
+ tag "doc-base-file-no-format-section", "$dbfile:$." unless %sawformats;
+
+ close IN;
+}
+
+# Checks one field of a doc-base control file. $vals is array ref containing
+# all lines of the field. Modifies $sawfields and $sawformats.
+sub check_doc_base_field {
+ my ($pkg, $dbfile, $line, $field, $vals, $sawfields, $sawformats,
+ $knownfields, $all_files, $all_links) = @_;
+
+ tag "doc-base-file-unknown-field", "$dbfile:$line", "$field"
+ unless defined $knownfields->{$field};
+ tag "doc-base-file-duplicated-field", "$dbfile:$line", "$field"
+ if $sawfields->{$field};
+ $sawfields->{$field} = 1;
+
+ # Index/Files field.
+ #
+ # Check if files referenced by doc-base are included in the package. The
+ # Index field should refer to only one file without wildcards. The Files
+ # field is a whitespace-separated list of files and may contain wildcards.
+ # We skip without validating wildcard patterns containing character
+ # classes since otherwise we'd need to deal with wildcards inside
+ # character classes and aren't there yet.
+ if ($field eq 'index' or $field eq 'files') {
+ my @files = map { split ('\s+', $_) } @$vals;
+
+ if ($field eq 'index' && @files > 1) {
+ tag "doc-base-index-references-multiple-files", "$dbfile:$line";
+ }
+ for my $file (@files) {
+ next if $file eq '';
+ if ($file =~ m%^/usr/doc%) {
+ tag "doc-base-file-references-usr-doc", "$dbfile:$line";
+ }
+ my $realfile = delink ($file, $all_links);
+ # openoffice.org-dev-doc has thousands of files listed so try to
+ # use the hash if possible.
+ my $found;
+ if ($realfile =~ /[*?]/) {
+ my $regex = quotemeta ($realfile);
+ unless ($field eq 'index') {
+ next if $regex =~ /\[/;
+ $regex =~ s%\\\*%[^/]*%g;
+ $regex =~ s%\\\?%[^/]%g;
+ $regex .= '/?';
+ }
+ $found = grep { /^$regex\z/ } keys %$all_files;
+ } else {
+ $found = $all_files->{$realfile} || $all_files->{"$realfile/"};
+ }
+ unless ($found) {
+ tag "doc-base-file-references-missing-file", "$dbfile:$line",
+ $file;
+ }
+ }
+ undef @files;
+
+ # Format field.
+ } elsif ($field eq 'format') {
+ my $format = join (' ', @$vals);
+ $format =~ s/^\s+//o;
+ $format =~ s/\s+$//o;
+ $format = lc $format;
+ tag "doc-base-file-unknown-format", "$dbfile:$line", $format
+ unless $known_doc_base_formats{$format};
+ tag "doc-base-file-duplicated-format", "$dbfile:$line", $format
+ if $sawformats->{$format};
+ $sawformats->{$format} = 1;
+
+ # Save the current format for the later section check.
+ $sawformats->{' *current* '} = $format;
+
+ # Document field.
+ } elsif ($field eq 'document') {
+ $_ = join (' ', @$vals);
+
+ tag "doc-base-invalid-document-field", "$dbfile:$line", "$_"
+ unless /^[a-z0-9+.-]+$/;
+ tag "doc-base-document-field-ends-in-whitespace", "$dbfile:$line"
+ if /[ \t]$/;
+ tag "doc-base-document-field-not-in-first-line", "$dbfile:$line"
+ unless $line == 1;
+
+ # Title field.
+ } elsif ($field eq 'title') {
+ if (@$vals) {
+ spelling_check("spelling-error-in-doc-base-title-field",
+ join (' ', @$vals), "$dbfile:$line");
+ spelling_check_picky("spelling-error-in-doc-base-title-field",
+ join (' ', @$vals), "$dbfile:$line");
+ }
+
+ # Section field.
+ } elsif ($field eq 'section') {
+ $SECTIONS = Maemian::Data->new('doc-base/sections') unless $SECTIONS;
+ $_ = join (' ', @$vals);
+ unless ($SECTIONS->known($_)) {
+ if (m,^App(?:lication)?s/(.+)$, and $SECTIONS->known($1)) {
+ tag "doc-base-uses-applications-section", "$dbfile:$line", $_;
+ } elsif (m,^(.+)/([^/]+)$, and $SECTIONS->known($1)) {
+ # allows creating a new subsection to a known section
+ } else {
+ tag "doc-base-unknown-section", "$dbfile:$line", $_;
+ }
+ }
+
+ # Abstract field.
+ } elsif ($field eq 'abstract') {
+ # The three following variables are used for checking if the field is
+ # correctly phrased. We detect if each line (except for the first
+ # line and lines containing single dot) of the field starts with the
+ # same number of spaces, not followed by the same non-space character,
+ # and the number of spaces is > 1.
+ #
+ # We try to match fields like this:
+ # ||Abstract: The Boost web site provides free peer-reviewed portable
+ # || C++ source libraries. The emphasis is on libraries which work
+ # || well with the C++ Standard Library. One goal is to establish
+ #
+ # but not like this:
+ # ||Abstract: This is "Ding"
+ # || * a dictionary lookup program for Unix,
+ # || * DIctionary Nice Grep,
+ my $leadsp = undef; # string with leading spaces from second line
+ my $charafter = undef; # first non-whitespace char of second line
+ my $leadsp_ok = 1; # are spaces OK?
+
+ # Intentionally skipping the first line.
+ for my $idx (1 .. $#{$vals}) {
+ $_ = $vals->[$idx];
+ if (/manage\s+online\s+manuals\s.*Debian/o) {
+ tag "doc-base-abstract-field-is-template", "$dbfile:$line"
+ unless $pkg eq "doc-base";
+ } elsif (/^(\s+)\.(\s*)$/o and ($1 ne " " or $2)) {
+ tag "doc-base-abstract-field-separator-extra-whitespaces",
+ "$dbfile:" . ($line - $#{$vals} + $idx);
+ } elsif (!$leadsp && /^(\s+)(\S)/o) {
+ # The regexp should always match.
+ ($leadsp, $charafter) = ($1, $2);
+ $leadsp_ok = $leadsp eq " ";
+ } elsif (!$leadsp_ok && /^(\s+)(\S)/o) {
+ # The regexp should always match.
+ undef $charafter if $charafter && $charafter ne $2;
+ $leadsp_ok = 1
+ if ($1 ne $leadsp) || ($1 eq $leadsp && $charafter);
+ }
+ }
+ unless ($leadsp_ok) {
+ tag "doc-base-abstract-might-contain-extra-leading-whitespaces",
+ "$dbfile:$line";
+ }
+
+ # Check spelling.
+ if (@$vals) {
+ spelling_check("spelling-error-in-doc-base-abstract-field",
+ join (' ', @$vals), "$dbfile:$line");
+ spelling_check_picky("spelling-error-in-doc-base-abstract-field",
+ join (' ', @$vals), "$dbfile:$line");
+ }
+ }
+}
+
+# Checks the section of the doc-base control file. Tries to find required
+# fields missing in the section.
+sub check_doc_base_file_section {
+ my ($dbfile, $line, $sawfields, $sawformats, $knownfields) = @_;
+
+ tag "doc-base-file-no-format", "$dbfile:$line"
+ if ((defined $sawfields->{'files'} || defined $sawfields->{'index'})
+ && !(defined $sawfields->{'format'}));
+
+ # The current format is set by check_doc_base_field.
+ if ($sawfields->{'format'}) {
+ my $format = $sawformats->{' *current* '};
+ tag "doc-base-file-no-index", "$dbfile:$line"
+ if ($format && ($format eq 'html' || $format eq 'info')
+ && !$sawfields->{'index'});
+ }
+ for my $field (sort keys %$knownfields) {
+ tag "doc-base-file-lacks-required-field", "$dbfile:$line", "$field"
+ if ($knownfields->{$field} == 1 && !$sawfields->{$field});
+ }
+}
+
+# Add file and link to $all_files and $all_links. Note that both files and
+# links have to include a leading /.
+sub add_file_link_info {
+ my ($info, $file, $all_files, $all_links) = @_;
+ my $link = $info->index->{$file}->{link};
+ my $ishard = ($info->index->{$file}->{type} eq 'h');
+
+ $file = "/" . $file if (not $file =~ m%^/%); # make file absolute
+ $file =~ s%/+%/%g; # remove duplicated `/'
+ $all_files->{$file} = 1;
+
+ if (defined $link) {
+ $link = './' . $link if $link !~ m,^/,;
+ if ($ishard) {
+ $link =~ s,^\./,/,;
+ } elsif (not $link =~ m,^/,) { # not absolute link
+ $link = "/" . $link; # make sure link starts with '/'
+ $link =~ s,/+\./+,/,g; # remove all /./ parts
+ my $dcount = 1;
+ while ($link =~ s,^/+\.\./+,/,) { #\ count & remove
+ $dcount++; #/ any leading /../ parts
+ }
+ my $f = $file;
+ while ($dcount--) { #\ remove last $dcount
+ $f =~ s,/[^/]*$,,; #/ path components from $file
+ }
+ $link = $f . $link; # now we should have absolute link
+ }
+ $all_links->{$file} = $link unless ($link eq $file);
+ }
+}
+
+
+# Dereference all symlinks in file.
+sub delink {
+ my ($file, $all_links) = @_;
+
+ $file =~ s%/+%/%g; # remove duplicated '/'
+ return $file unless %$all_links; # package doesn't symlinks
+
+ my $p1 = "";
+ my $p2 = $file;
+ my %used_links = ();
+
+ # In the loop below we split $file into two parts on each '/' until
+ # there's no remaining slashes. We try substituting the first part with
+ # corresponding symlink and if it succeedes, we start the procedure from
+ # beginning.
+ #
+ # Example:
+ # Let $all_links{"/a/b"} == "/d", and $file == "/a/b/c"
+ # Then 0) $p1 == "", $p2 == "/a/b/c"
+ # 1) $p1 == "/a", $p2 == "/b/c"
+ # 2) $p1 == "/a/b", $p2 == "/c" ; substitute "/d" for "/a/b"
+ # 3) $p1 == "", $p2 == "/d/c"
+ # 4) $p1 == "/d", $p2 == "/c"
+ # 5) $p1 == "/d/c", $p2 == ""
+ #
+ # Note that the algorithm supposes, that
+ # i) $all_links{$X} != $X for each $X
+ # ii) both keys and values of %all_links start with '/'
+
+ while (($p2 =~ s%^(/[^/]*)%%g) > 0) {
+ $p1 .= $1;
+ if (defined $all_links->{$p1}) {
+ return '!!! SYMLINK LOOP !!!' if defined $used_links{$p1};
+ $p2 = $all_links->{$p1} . $p2;
+ $p1 = "";
+ $used_links{$p1} = 1;
+ }
+ }
+
+ # After the loop $p2 should be empty and $p1 should contain the target
+ # file. In some rare cases when $file contains no slashes, $p1 will be
+ # empty and $p2 will contain the result (which will be equal to $file).
+ return $p1 ne "" ? $p1 : $p2;
+}
+
+sub check_script {
+ my ($pkg, $script, $pres) = @_;
+ my ($no_check_menu,$no_check_installdocs,$no_check_wmmenu,$calls_wmmenu);
+ my $interp;
+
+ open(IN, '<', "control/$script") or
+ fail("cannot open maintainer script control/$script for reading: $!");
+ $interp = <IN>;
+ $interp = '' unless defined $interp;
+ if ($interp =~ m,^\#\!\s*/bin/$known_shells_regex,) {
+ $interp = 'sh';
+ } elsif ($interp =~ m,^\#\!\s*/usr/bin/perl,) {
+ $interp = 'perl';
+ } else {
+ if ($interp =~ m,^\#\!\s*(.+),) {
+ $interp = $1;
+ }
+ else { # hmm, doesn't seem to start with #!
+ # is it a binary? look for ELF header
+ if ($interp =~ m/^\177ELF/) {
+ return; # nothing to do here
+ }
+ $interp = 'unknown';
+ }
+ }
+
+ while (<IN>) {
+ # skip comments
+ s/\#.*$//o;
+
+ ##
+ # either update-menus or wm-menu-config will satisfy
+ # the checks that the menu file installed is properly used
+ ##
+
+ # does the script check whether update-menus exists?
+ if (/-x\s+\S*update-menus/o or /(which|type)\s+update-menus/o
+ or /command\s+.*?update-menus/o) {
+ # yes, it does.
+ $pres->{'checks-for-updatemenus'} = 1;
+ }
+
+ # does the script call update-menus?
+ # TODO this regex-magic should be moved to some lib for checking
+ # whether a certain word is likely called as command... --Jeroen
+ if (/(?:^\s*|[;&|]\s*|(?:then|do)\s+)(?:\/usr\/bin\/)?update-menus(?:\s|[;&|<>]|$)/) {
+ # yes, it does.
+ $pres->{'calls-updatemenus'} = 1;
+
+ # checked first?
+ if (not $pres->{'checks-for-updatemenus'} and $pkg ne 'menu') {
+ tag "maintainer-script-does-not-check-for-existence-of-updatemenus", "$script:$." unless $no_check_menu++;
+ }
+ }
+
+ # does the script check whether wm-menu-config exists?
+ if (s/-x\s+\S*wm-menu-config//o or /(which|type)\s+wm-menu-config/o
+ or s/command\s+.*?wm-menu-config//o) {
+ # yes, it does.
+ $pres->{'checks-for-wmmenuconfig'} = 1;
+ }
+
+ # does the script call wm-menu-config?
+ if (m/(?:^\s*|[;&|]\s*|(?:then|do)\s+)(?:\/usr\/sbin\/)?wm-menu-config(?:\s|[;&|<>]|$)/) {
+ # yes, it does.
+ $pres->{'calls-wmmenuconfig'} = 1;
+ tag "maintainer-script-calls-deprecated-wm-menu-config", "$script:$." unless $calls_wmmenu++;
+
+ # checked first?
+ if (not $pres->{'checks-for-wmmenuconfig'} and $pkg ne 'menu') {
+ tag "maintainer-script-does-not-check-for-existence-of-wm-menu-config", "$script:$." unless $no_check_wmmenu++;
+ }
+ }
+
+ # does the script set a link in /usr/doc?
+ # does the script remove a link in /usr/doc?
+ if ($interp eq 'sh') {
+ if (m,ln\s+(-\w+)?\s+\"?\.\./share/doc/\S+, ) {
+ $pres->{'sets-link'} = 1;
+ }
+ if (m,rm\s+(-\w+\s+)?\"?/usr/doc/\S+, ) {
+ $pres->{'removes-link'} = 1;
+ }
+ } elsif ($interp eq 'perl') {
+ if (m|symlink\s*\(?\s*[\"\']\.\./share/doc/\.+?[\"\']\s*,|) {
+ $pres->{'sets-link'} = 1;
+ } elsif (m,ln\s+(-\w+)?\s+\"?\.\./share/doc/\S+, ) {
+ $pres->{'sets-link'} = 1;
+ }
+ } else {
+ # just fall through for now
+ }
+
+ # does the script check whether install-docs exists?
+ if (s/-x\s+\S*install-docs//o or /(which|type)\s+install-docs/o
+ or s/command\s+.*?install-docs//o) {
+ # yes, it does.
+ $pres->{'checks-for-installdocs'} = 1;
+ }
+
+ # does the script call install-docs?
+ if (m/(?:^\s*|[;&|]\s*|(?:then|do)\s+)(?:\/usr\/sbin\/)?install-docs(?:\s|[;&|<>]|$)/) {
+ # yes, it does. Does it remove or add a doc?
+ if (m/install-docs\s+(-r|--remove)\s/) {
+ $pres->{'calls-installdocs-r'} = 1;
+ } else {
+ $pres->{'calls-installdocs'} = 1;
+ }
+ # checked first?
+ if (not $pres->{'checks-for-installdocs'}) {
+ tag "maintainer-script-does-not-check-for-existence-of-installdocs", "$script" unless $no_check_installdocs++;
+ }
+ }
+ }
+ close IN;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: t
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl
projects / maemian / blobdiff