summaryrefslogtreecommitdiffstats
path: root/lib/Lintian/Check/Menus.pm
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Lintian/Check/Menus.pm')
-rw-r--r--lib/Lintian/Check/Menus.pm818
1 files changed, 818 insertions, 0 deletions
diff --git a/lib/Lintian/Check/Menus.pm b/lib/Lintian/Check/Menus.pm
new file mode 100644
index 0000000..2e8f3d1
--- /dev/null
+++ b/lib/Lintian/Check/Menus.pm
@@ -0,0 +1,818 @@
+# menus -- lintian check script -*- perl -*-
+
+# somewhat of a misnomer -- it doesn't only check menus
+
+# Copyright (C) 1998 Christian Schwarz
+# Copyright (C) 2018 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# 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 https://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 Lintian::Check::Menus;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use Path::Tiny;
+use Unicode::UTF8 qw(encode_utf8);
+
+use Lintian::Spelling qw(check_spelling check_spelling_picky);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $EMPTY => q{};
+const my $SPACE => q{ };
+const my $SLASH => q{/};
+const my $DOT => q{.};
+const my $QUESTION_MARK => q{?};
+
+# Supported documentation formats for doc-base files.
+my %known_doc_base_formats
+ = map { $_ => 1 }qw(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.
+my %KNOWN_DOCBASE_MAIN_FIELDS = (
+ 'Document' => 1,
+ 'Title' => 1,
+ 'Section' => 1,
+ 'Abstract' => 0,
+ 'Author' => 0
+);
+
+my %KNOWN_DOCBASE_FORMAT_FIELDS = (
+ 'Format' => 1,
+ 'Files' => 1,
+ 'Index' => 0
+);
+
+has menu_item => (is => 'rw');
+has menumethod_item => (is => 'rw');
+has documentation => (is => 'rw', default => 0);
+
+sub spelling_tag_emitter {
+ my ($self, @orig_args) = @_;
+
+ return sub {
+ return $self->pointed_hint(@orig_args, @_);
+ };
+}
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ if ($item->is_file) { # file checks
+ # menu file?
+ if ($item->name =~ m{^usr/(lib|share)/menu/\S}){ # correct permissions?
+
+ $self->pointed_hint('executable-menu-file', $item->pointer,
+ $item->octal_permissions)
+ if $item->is_executable;
+
+ return
+ if $item->name =~ m{^usr/(?:lib|share)/menu/README$};
+
+ if ($item->name =~ m{^usr/lib/}) {
+ $self->pointed_hint('menu-file-in-usr-lib', $item->pointer);
+ }
+
+ $self->menu_item($item);
+
+ $self->pointed_hint('bad-menu-file-name', $item->pointer)
+ if $item->name =~ m{^usr/(?:lib|share)/menu/menu$}
+ && $self->processable->name ne 'menu';
+ }
+ #menu-methods file?
+ elsif ($item->name =~ m{^etc/menu-methods/\S}) {
+ #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;
+ $self->menumethod_item($item);
+
+ if ($item->is_open_ok) {
+ open(my $fd, '<', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ while (my $line = <$fd>) {
+ chomp $line;
+ if ($line =~ /^!include menu.h/) {
+ $menumethod_includes_menu_h = 1;
+ last;
+ }
+ }
+ close($fd);
+ }
+
+ $self->pointed_hint('menu-method-lacks-include', $item->pointer)
+ unless $menumethod_includes_menu_h
+ or $self->processable->name eq 'menu';
+ }
+ # package doc dir?
+ elsif (
+ $item->name =~ m{ \A usr/share/doc/(?:[^/]+/)?
+ (.+\.(?:html|pdf))(?:\.gz)?
+ \Z}xsm
+ ) {
+ my $name = $1;
+ unless ($name =~ m/^changelog\.html$/
+ or $name =~ m/^README[.-]/
+ or $name =~ m/examples/) {
+ $self->documentation(1);
+ }
+ }
+ }
+
+ return;
+}
+
+sub installable {
+ my ($self) = @_;
+
+ my $pkg = $self->processable->name;
+ my $processable = $self->processable;
+ my $group = $self->group;
+
+ my (%all_files, %all_links);
+
+ my %preinst;
+ my %postinst;
+ my %prerm;
+ my %postrm;
+
+ $self->check_script($processable->control->lookup('preinst'),\%preinst);
+ $self->check_script($processable->control->lookup('postinst'),\%postinst);
+ $self->check_script($processable->control->lookup('prerm'),\%prerm);
+ $self->check_script($processable->control->lookup('postrm'),\%postrm);
+
+ # Populate all_{files,links} from current package and its dependencies
+ for my $installable ($group->get_installables) {
+ next
+ unless $processable->name eq $installable->name
+ || $processable->relation('strong')->satisfies($installable->name);
+
+ for my $item (@{$installable->installed->sorted_list}) {
+ add_file_link_info($installable, $item->name, \%all_files,
+ \%all_links);
+ }
+ }
+
+ # prerm scripts should not call update-menus
+ $self->pointed_hint('prerm-calls-updatemenus',$prerm{'calls-updatemenus'})
+ if defined $prerm{'calls-updatemenus'};
+
+ # postrm scripts should not call install-docs
+ $self->pointed_hint('postrm-calls-installdocs',
+ $postrm{'calls-installdocs'})
+ if defined $postrm{'calls-installdocs'};
+ $self->pointed_hint('postrm-calls-installdocs',
+ $postrm{'calls-installdocs-r'})
+ if defined $postrm{'calls-installdocs-r'};
+
+ # preinst scripts should not call either update-menus nor installdocs
+ $self->pointed_hint('preinst-calls-updatemenus',
+ $preinst{'calls-updatemenus'})
+ if defined $preinst{'calls-updatemenus'};
+
+ $self->pointed_hint('preinst-calls-installdocs',
+ $preinst{'calls-installdocs'})
+ if defined $preinst{'calls-installdocs'};
+
+ my $anymenu_item = $self->menu_item || $self->menumethod_item;
+
+ # No one needs to call install-docs any more; triggers now handles that.
+ $self->pointed_hint('postinst-has-useless-call-to-install-docs',
+ $postinst{'calls-installdocs'})
+ if defined $postinst{'calls-installdocs'};
+ $self->pointed_hint('postinst-has-useless-call-to-install-docs',
+ $postinst{'calls-installdocs-r'})
+ if defined $postinst{'calls-installdocs-r'};
+
+ $self->pointed_hint('prerm-has-useless-call-to-install-docs',
+ $prerm{'calls-installdocs'})
+ if defined $prerm{'calls-installdocs'};
+ $self->pointed_hint('prerm-has-useless-call-to-install-docs',
+ $prerm{'calls-installdocs-r'})
+ if defined $prerm{'calls-installdocs-r'};
+
+ # check consistency
+ # docbase file?
+ if (my $db_dir
+ = $processable->installed->resolve_path('usr/share/doc-base/')){
+ for my $item ($db_dir->children) {
+ next
+ if !$item->is_open_ok;
+
+ if ($item->resolve_path->is_executable) {
+
+ $self->pointed_hint('executable-in-usr-share-docbase',
+ $item->pointer, $item->octal_permissions);
+ next;
+ }
+
+ $self->check_doc_base_file($item, \%all_files,\%all_links);
+ }
+ } elsif ($self->documentation) {
+ if ($pkg =~ /^libghc6?-.*-doc$/) {
+ # This is the library documentation for a haskell library. Haskell
+ # libraries register their documentation via the ghc compiler's
+ # documentation registration mechanism. See bug #586877.
+ } else {
+ $self->hint('possible-documentation-but-no-doc-base-registration');
+ }
+ }
+
+ if ($anymenu_item) {
+ # 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.
+ $self->pointed_hint('postinst-does-not-call-updatemenus',
+ $anymenu_item->pointer)
+ if !defined $postinst{'calls-updatemenus'};
+
+ $self->pointed_hint(
+ 'postrm-does-not-call-updatemenus',
+ $self->menumethod_item->pointer
+ )
+ if defined $self->menumethod_item
+ && !defined $postrm{'calls-updatemenus'}
+ && $pkg ne 'menu';
+
+ } else {
+ $self->pointed_hint('postinst-has-useless-call-to-update-menus',
+ $postinst{'calls-updatemenus'})
+ if defined $postinst{'calls-updatemenus'};
+
+ $self->pointed_hint('postrm-has-useless-call-to-update-menus',
+ $postrm{'calls-updatemenus'})
+ if defined $postrm{'calls-updatemenus'};
+ }
+
+ return;
+}
+
+# -----------------------------------
+
+sub check_doc_base_file {
+ my ($self, $item, $all_files, $all_links) = @_;
+
+ my $pkg = $self->processable->name;
+ my $group = $self->group;
+
+ # another check complains about invalid encoding
+ return
+ unless ($item->is_valid_utf8);
+
+ my $contents = $item->decoded_utf8;
+ my @lines = split(/\n/, $contents);
+
+ my $knownfields = \%KNOWN_DOCBASE_MAIN_FIELDS;
+ my ($field, @vals);
+ my %sawfields; # local for each section of control file
+ my %sawformats; # global for control file
+ my $line = 0; # global
+
+ my $position = 1;
+ while (defined(my $string = shift @lines)) {
+ chomp $string;
+
+ # New field. check previous field, if we have any.
+ if ($string =~ /^(\S+)\s*:\s*(.*)$/) {
+ my (@new) = ($1, $2);
+ if ($field) {
+ $self->check_doc_base_field(
+ $item, $line, $field,
+ \@vals,\%sawfields, \%sawformats,
+ $knownfields,$all_files, $all_links
+ );
+ }
+
+ $field = $new[0];
+
+ @vals = ($new[1]);
+ $line = $position;
+
+ # Continuation of previously defined field.
+ } elsif ($field && $string =~ /^\s+\S/) {
+ push(@vals, $string);
+
+ # All tags will be reported on the last continuation line of the
+ # doc-base field.
+ $line = $position;
+
+ # Sections' separator.
+ } elsif ($string =~ /^(\s*)$/) {
+ $self->pointed_hint('doc-base-file-separator-extra-whitespace',
+ $item->pointer($position))
+ if $1;
+ next unless $field; # skip successive empty lines
+
+ # Check previously defined field and section.
+ $self->check_doc_base_field(
+ $item, $line, $field,
+ \@vals,\%sawfields, \%sawformats,
+ $knownfields,$all_files, $all_links
+ );
+ $self->check_doc_base_file_section($item, $line + 1,\%sawfields,
+ \%sawformats, $knownfields);
+
+ # Initialize 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 {
+ $self->pointed_hint('doc-base-file-syntax-error',
+ $item->pointer($position));
+ }
+
+ } continue {
+ ++$position;
+ }
+
+ # Check the last field/section of the control file.
+ if ($field) {
+ $self->check_doc_base_field(
+ $item, $line, $field,
+ \@vals, \%sawfields,\%sawformats,
+ $knownfields,$all_files,$all_links
+ );
+ $self->check_doc_base_file_section($item, $line, \%sawfields,
+ \%sawformats,$knownfields);
+ }
+
+ # Make sure we saw at least one format.
+ $self->pointed_hint('doc-base-file-no-format-section', $item->pointer)
+ unless %sawformats;
+
+ return;
+}
+
+# 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 (
+ $self, $item, $position, $field,$vals,
+ $sawfields, $sawformats,$knownfields,$all_files, $all_links
+ ) = @_;
+
+ my $pkg = $self->processable->name;
+ my $group = $self->group;
+
+ my $SECTIONS = $self->data->load('doc-base/sections');
+
+ $self->pointed_hint('doc-base-file-unknown-field',
+ $item->pointer($position), $field)
+ unless defined $knownfields->{$field};
+ $self->pointed_hint('duplicate-field-in-doc-base',
+ $item->pointer($position), $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($SPACE) } @{$vals};
+
+ if ($field eq 'Index' && @files > 1) {
+ $self->pointed_hint('doc-base-index-references-multiple-files',
+ $item->pointer($position));
+ }
+ for my $file (@files) {
+ next if $file =~ m{^/usr/share/doc/};
+ next if $file =~ m{^/usr/share/info/};
+
+ $self->pointed_hint('doc-base-file-references-wrong-path',
+ $item->pointer($position), $file);
+ }
+ for my $file (@files) {
+ 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 .= $SLASH . $QUESTION_MARK;
+ }
+ $found = grep { /^$regex\z/ } keys %{$all_files};
+ } else {
+ $found = $all_files->{$realfile} || $all_files->{"$realfile/"};
+ }
+ unless ($found) {
+ $self->pointed_hint('doc-base-file-references-missing-file',
+ $item->pointer($position),$file);
+ }
+ }
+ undef @files;
+
+ # Format field.
+ } elsif ($field eq 'Format') {
+ my $format = join($SPACE, @{$vals});
+
+ # trim both ends
+ $format =~ s/^\s+|\s+$//g;
+
+ $format = lc $format;
+ $self->pointed_hint('doc-base-file-unknown-format',
+ $item->pointer($position), $format)
+ unless $known_doc_base_formats{$format};
+ $self->pointed_hint('duplicate-format-in-doc-base',
+ $item->pointer($position), $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($SPACE, @{$vals});
+
+ $self->pointed_hint('doc-base-invalid-document-field',
+ $item->pointer($position), $_)
+ unless /^[a-z0-9+.-]+$/;
+ $self->pointed_hint('doc-base-document-field-ends-in-whitespace',
+ $item->pointer($position))
+ if /[ \t]$/;
+ $self->pointed_hint('doc-base-document-field-not-in-first-line',
+ $item->pointer($position))
+ unless $position == 1;
+
+ # Title field.
+ } elsif ($field eq 'Title') {
+ if (@{$vals}) {
+ my $stag_emitter
+ = $self->spelling_tag_emitter(
+ 'spelling-error-in-doc-base-title-field',
+ $item->pointer($position));
+ check_spelling(
+ $self->data,
+ join($SPACE, @{$vals}),
+ $group->spelling_exceptions,
+ $stag_emitter
+ );
+ check_spelling_picky($self->data, join($SPACE, @{$vals}),
+ $stag_emitter);
+ }
+
+ # Section field.
+ } elsif ($field eq 'Section') {
+ $_ = join($SPACE, @{$vals});
+ unless ($SECTIONS->recognizes($_)) {
+ if (m{^App(?:lication)?s/(.+)$} && $SECTIONS->recognizes($1)) {
+ $self->pointed_hint('doc-base-uses-applications-section',
+ $item->pointer($position), $_);
+ } elsif (m{^(.+)/(?:[^/]+)$} && $SECTIONS->recognizes($1)) {
+ # allows creating a new subsection to a known section
+ } else {
+ $self->pointed_hint('doc-base-unknown-section',
+ $item->pointer($position), $_);
+ }
+ }
+
+ # 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; # string with leading spaces from second line
+ my $charafter; # 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/) {
+ $self->pointed_hint('doc-base-abstract-field-is-template',
+ $item->pointer($position))
+ unless $pkg eq 'doc-base';
+
+ } elsif (/^(\s+)\.(\s*)$/ and ($1 ne $SPACE or $2)) {
+ $self->pointed_hint(
+ 'doc-base-abstract-field-separator-extra-whitespace',
+ $item->pointer($position - $#{$vals} + $idx)
+ );
+
+ } elsif (!$leadsp && /^(\s+)(\S)/) {
+ # The regexp should always match.
+ ($leadsp, $charafter) = ($1, $2);
+ $leadsp_ok = $leadsp eq $SPACE;
+
+ } elsif (!$leadsp_ok && /^(\s+)(\S)/) {
+ # 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) {
+ $self->pointed_hint(
+ 'doc-base-abstract-might-contain-extra-leading-whitespace',
+ $item->pointer($position));
+ }
+
+ # Check spelling.
+ if (@{$vals}) {
+ my $stag_emitter
+ = $self->spelling_tag_emitter(
+ 'spelling-error-in-doc-base-abstract-field',
+ $item->pointer($position));
+ check_spelling(
+ $self->data,
+ join($SPACE, @{$vals}),
+ $group->spelling_exceptions,
+ $stag_emitter
+ );
+ check_spelling_picky($self->data, join($SPACE, @{$vals}),
+ $stag_emitter);
+ }
+ }
+
+ return;
+}
+
+# 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 ($self, $item, $position, $sawfields, $sawformats, $knownfields) = @_;
+
+ $self->pointed_hint('doc-base-file-no-format', $item->pointer($position))
+ 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* '};
+ $self->pointed_hint('doc-base-file-no-index',$item->pointer($position))
+ if ( $format
+ && ($format eq 'html' || $format eq 'info')
+ && !$sawfields->{'Index'});
+ }
+ for my $field (sort keys %{$knownfields}) {
+ $self->pointed_hint('doc-base-file-lacks-required-field',
+ $item->pointer($position), $field)
+ if ($knownfields->{$field} == 1 && !$sawfields->{$field});
+ }
+
+ return;
+}
+
+# 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 ($processable, $file, $all_files, $all_links) = @_;
+
+ my $link = $processable->installed->lookup($file)->link;
+ my $ishard = $processable->installed->lookup($file)->is_hardlink;
+
+ # make name absolute
+ $file = $SLASH . $file
+ unless $file =~ m{^/};
+
+ $file =~ s{/+}{/}g; # remove duplicated `/'
+ $all_files->{$file} = 1;
+
+ if (length $link) {
+
+ $link = $DOT . $SLASH . $link
+ if $link !~ m{^/};
+
+ if ($ishard) {
+ $link =~ s{^\./}{/};
+ } elsif ($link !~ m{^/}) { # not absolute link
+ $link
+ = $SLASH
+ . $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);
+ }
+
+ return;
+}
+
+# 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 = $EMPTY;
+ 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 succeeds, 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 = $EMPTY;
+ $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 $EMPTY ? $p1 : $p2;
+}
+
+sub check_script {
+ my ($self, $item, $pres) = @_;
+
+ my $pkg = $self->processable->name;
+
+ my ($no_check_menu, $no_check_installdocs);
+
+ # control files are regular files and not symlinks, pipes etc.
+ return
+ unless defined $item;
+
+ return
+ if $item->is_symlink;
+
+ return
+ unless $item->is_open_ok;
+
+ # nothing to do for ELF
+ return
+ if $item->is_elf;
+
+ my $interpreter = $item->interpreter || 'unknown';
+
+ if ($item->is_shell_script) {
+ $interpreter = 'sh';
+
+ } elsif ($interpreter =~ m{^/usr/bin/perl}) {
+ $interpreter = 'perl';
+ }
+
+ open(my $fd, '<', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ my $position = 1;
+ while (my $line = <$fd>) {
+ # skip comments
+ $line =~ s/\#.*$//;
+
+ ##
+ # update-menus will satisfy the checks that the menu file
+ # installed is properly used
+ ##
+
+ # does the script check whether update-menus exists?
+ $pres->{'checks-for-updatemenus'} = $item->pointer($position)
+ if $line =~ /-x\s+\S*update-menus/
+ || $line =~ /(?:which|type)\s+update-menus/
+ || $line =~ /command\s+.*?update-menus/;
+
+ # 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 (
+ $line =~m{ (?:^\s*|[;&|]\s*|(?:then|do|exec)\s+)
+ (?:\/usr\/bin\/)?update-menus
+ (?:\s|[;&|<>]|\Z)}xsm
+ ) {
+ # yes, it does.
+ $pres->{'calls-updatemenus'} = $item->pointer($position);
+
+ # checked first?
+ if (not $pres->{'checks-for-updatemenus'} and $pkg ne 'menu') {
+ $self->pointed_hint(
+'maintainer-script-does-not-check-for-existence-of-updatemenus',
+ $item->pointer($position)
+ ) unless $no_check_menu++;
+ }
+ }
+
+ # does the script check whether install-docs exists?
+ $pres->{'checks-for-installdocs'} = $item->pointer($position)
+ if $line =~ s/-x\s+\S*install-docs//
+ || $line =~/(?:which|type)\s+install-docs/
+ || $line =~ s/command\s+.*?install-docs//;
+
+ # does the script call install-docs?
+ if (
+ $line =~ m{ (?:^\s*|[;&|]\s*|(?:then|do)\s+)
+ (?:\/usr\/sbin\/)?install-docs
+ (?:\s|[;&|<>]|\Z) }xsm
+ ) {
+ # yes, it does. Does it remove or add a doc?
+ if ($line =~ /install-docs\s+(?:-r|--remove)\s/) {
+ $pres->{'calls-installdocs-r'} = $item->pointer($position);
+ } else {
+ $pres->{'calls-installdocs'} = $item->pointer($position);
+ }
+
+ # checked first?
+ if (not $pres->{'checks-for-installdocs'}) {
+ $self->pointed_hint(
+'maintainer-script-does-not-check-for-existence-of-installdocs',
+ $item->pointer($position)
+ ) unless $no_check_installdocs++;
+ }
+ }
+
+ } continue {
+ ++$position;
+ }
+
+ close($fd);
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
generated by cgit v1.2.3 (git 2.39.1) at 2024-08-10 04:25:02 +0000