diff options
Diffstat (limited to 'lib/Lintian/Check/Scripts.pm')
| -rw-r--r-- | lib/Lintian/Check/Scripts.pm | 1070 |
1 files changed, 1070 insertions, 0 deletions
diff --git a/lib/Lintian/Check/Scripts.pm b/lib/Lintian/Check/Scripts.pm new file mode 100644 index 0000000..5539208 --- /dev/null +++ b/lib/Lintian/Check/Scripts.pm @@ -0,0 +1,1070 @@ +# scripts -- lintian check script -*- perl -*- +# +# Copyright (C) 1998 Richard Braakman +# Copyright (C) 2002 Josip Rodin +# Copyright (C) 2016-2019 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::Scripts; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use File::Basename; +use List::SomeUtils qw(any none); +use Unicode::UTF8 qw(encode_utf8); + +use Lintian::IPC::Run3 qw(safe_qx); +use Lintian::Relation; + +const my $EMPTY => q{}; +const my $SPACE => q{ }; +const my $SLASH => q{/}; +const my $AT_SIGN => q{@}; +const my $ASTERISK => q{*}; +const my $DOT => q{.}; +const my $DOUBLE_QUOTE => q{"}; +const my $NOT_EQUAL => q{!=}; + +const my $BAD_MAINTAINER_COMMAND_FIELDS => 5; +const my $UNVERSIONED_INTERPRETER_FIELDS => 2; +const my $VERSIONED_INTERPRETER_FIELDS => 5; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +# This is a map of all known interpreters. The key is the interpreter +# name (the binary invoked on the #! line). The value is an anonymous +# array of two elements. The first argument is the path on a Debian +# system where that interpreter would be installed. The second +# argument is the dependency that provides that interpreter. +# +# $INTERPRETERS maps names of (unversioned) interpreters to the path +# they are installed and what package to depend on to use them. +# +has INTERPRETERS => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my %unversioned; + + my $data + = $self->data->load('scripts/interpreters',qr/ \s* => \s* /msx); + + for my $interpreter ($data->all) { + + my $remainder = $data->value($interpreter); + + my ($folder, $prerequisites)= split(/ \s* , \s* /msx, + $remainder, $UNVERSIONED_INTERPRETER_FIELDS); + + $prerequisites //= $EMPTY; + + $unversioned{$interpreter} = { + folder => $folder, + prerequisites => $prerequisites + }; + } + + return \%unversioned; + } +); + +# The more complex case of interpreters that may have a version number. +# +# This is a hash from the base interpreter name to a list. The base +# interpreter name may appear by itself or followed by some combination of +# dashes, digits, and periods. +# +# The list contains the following values: +# [<path>, <dependency-relation>, <regex>, <dependency-template>, <version-list>] +# +# Their meaning is documented in Lintian's scripts/versioned-interpreters +# file, though they are ordered differently and there are a few differences +# as described below: +# +# * <regex> has been passed through qr/^<value>$/ +# * If <dependency-relation> was left out, it has been substituted by the +# interpreter. +# * The magic values of <dependency-relation> are represented as: +# @SKIP_UNVERSIONED@ -> undef (i.e the undefined value) +# * <version-list> has been split into a list of versions. +# (e.g. "1.6 1.8" will be ["1.6", "1.8"]) +# +# A full example is: +# +# data: +# lua => /usr/bin, lua([\d.]+), 'lua$1', 40 50 5.1 +# +# $VERSIONED_INTERPRETERS->value ('lua') is +# [ '/usr/bin', 'lua', qr/^lua([\d.]+)$/, 'lua$1', ["40", "50", "5.1"] ] +# +has VERSIONED_INTERPRETERS => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my %versioned; + + my $data = $self->data->load('scripts/versioned-interpreters', + qr/ \s* => \s* /msx); + + for my $interpreter ($data->all) { + + my $remainder = $data->value($interpreter); + + my ($folder, $pattern, $template, $version_list, $prerequisites) + = split(/ \s* , \s* /msx, + $remainder, $VERSIONED_INTERPRETER_FIELDS); + + my @versions = split(/ \s+ /msx, $version_list); + $prerequisites //= $EMPTY; + + if ($prerequisites eq $AT_SIGN . 'SKIP_UNVERSIONED' . $AT_SIGN) { + $prerequisites = undef; + + } elsif ($prerequisites =~ / @ /msx) { + die encode_utf8( +"Unknown magic value $prerequisites for versioned interpreter $interpreter" + ); + } + + $versioned{$interpreter} = { + folder => $folder, + prerequisites => $prerequisites, + regex => qr/^$pattern$/, + template => $template, + versions => \@versions + }; + } + + return \%versioned; + } +); + +# When detecting commands inside shell scripts, use this regex to match the +# beginning of the command rather than checking whether the command is at the +# beginning of a line. +const my $LEADING_PATTERN=> +'(?:(?:^|[`&;(|{])\s*|(?:if|then|do|while|!)\s+|env(?:\s+[[:alnum:]_]+=(?:\S+|\"[^"]*\"|\'[^\']*\'))*\s+)'; +const my $LEADING_REGEX => qr/$LEADING_PATTERN/; + +#forbidden command in maintainer scripts +has BAD_MAINTAINER_COMMANDS => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my %forbidden; + + my $data = $self->data->load('scripts/maintainer-script-bad-command', + qr/\s*\~\~/); + + for my $key ($data->all) { + + my $value = $data->value($key); + + my ($in_cat,$in_auto,$package_include_pattern, + $script_include_pattern,$command_pattern) + = split(/ \s* ~~ /msx, $value,$BAD_MAINTAINER_COMMAND_FIELDS); + + die encode_utf8( + "Syntax error in scripts/maintainer-script-bad-command: $.") + if any { !defined }( + $in_cat,$in_auto,$package_include_pattern, + $script_include_pattern,$command_pattern + ); + + # trim both ends + $in_cat =~ s/^\s+|\s+$//g; + $in_auto =~ s/^\s+|\s+$//g; + $package_include_pattern =~ s/^\s+|\s+$//g; + $script_include_pattern =~ s/^\s+|\s+$//g; + + $package_include_pattern ||= '\a\Z'; + + $script_include_pattern ||= $DOT . $ASTERISK; + + $command_pattern=~ s/\$[{]LEADING_PATTERN[}]/$LEADING_PATTERN/; + + $forbidden{$key} = { + ignore_automatic_sections => !!$in_auto, + in_cat_string => !!$in_cat, + package_exclude_regex => qr/$package_include_pattern/x, + script_include_regex => qr/$script_include_pattern/x, + command_pattern => $command_pattern, + }; + } + + return \%forbidden; + } +); + +# Appearance of one of these regexes in a maintainer script means that there +# must be a dependency (or pre-dependency) on the given package. The tag +# reported is maintainer-script-needs-depends-on-%s, so be sure to update +# scripts.desc when adding a new rule. +my %prerequisite_by_command_pattern = ( + '\badduser\s' => 'adduser', + '\bgconf-schemas\s' => 'gconf2', + '\bupdate-inetd\s' => +'update-inetd | inet-superserver | openbsd-inetd | inetutils-inetd | rlinetd | xinetd', + '\bucf\s' => 'ucf', + '\bupdate-xmlcatalog\s' => 'xml-core', + '\bupdate-fonts-(?:alias|dir|scale)\s' => 'xfonts-utils', +); + +# no dependency for install-menu, because the menu package specifically +# says not to depend on it. +has all_prerequisites => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $all_prerequisites + = $self->processable->relation('all') + ->logical_and($self->processable->relation('Provides'), + $self->processable->name); + + return $all_prerequisites; + } +); + +has strong_prerequisites => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my $strong_prerequisites = $self->processable->relation('strong'); + + return $strong_prerequisites; + } +); + +sub visit_installed_files { + my ($self, $item) = @_; + + return + unless $item->is_script; + + # Consider /usr/src/ scripts as "documentation" + # - packages containing /usr/src/ tend to be "-source" .debs + # and usually comes with overrides for most of the checks + # below. + # Supposedly, they could be checked as examples, but there is + # a risk that the scripts need substitution to be complete + # (so, syntax checking is not as reliable). + + # no checks necessary at all for scripts in /usr/share/doc/ + # unless they are examples + return + if ($item->name =~ m{^usr/share/doc/} || $item->name =~ m{^usr/src/}) + && $item->name !~ m{^usr/share/doc/[^/]+/examples/}; + + my $basename = basename($item->interpreter); + + # Ignore Python scripts that are shipped under dist-packages; these + # files aren't supposed to be called as scripts. + return + if $basename eq 'python' + && $item->name =~ m{^usr/lib/python3/dist-packages/}; + + # allow exception for .in files that have stuff like #!@PERL@ + return + if $item->name =~ /\.in$/ + && $item->interpreter =~ /^(\@|<\<)[A-Z_]+(\@|>\>)$/; + + my $is_absolute = ($item->interpreter =~ m{^/} || $item->calls_env); + + # As a special-exception, Policy 10.4 states that Perl scripts must use + # /usr/bin/perl directly and not via /usr/bin/env, etc. + $self->pointed_hint( + 'incorrect-path-for-interpreter', + $item->pointer,'/usr/bin/env perl', + $NOT_EQUAL, '/usr/bin/perl' + ) + if $item->calls_env + && $item->interpreter eq 'perl' + && $item->name !~ m{^usr/share/doc/[^/]+/examples/}; + + $self->pointed_hint( + 'example-incorrect-path-for-interpreter', + $item->pointer,'/usr/bin/env perl', + $NOT_EQUAL, '/usr/bin/perl' + ) + if $item->calls_env + && $item->interpreter eq 'perl' + && $item->name =~ m{^usr/share/doc/[^/]+/examples/}; + + # Skip files that have the #! line, but are not executable and + # do not have an absolute path and are not in a bin/ directory + # (/usr/bin, /bin etc). They are probably not scripts after + # all. + return + if ( $item->name !~ m{(?:bin/|etc/init\.d/)} + && (!$item->is_file || !$item->is_executable) + && !$is_absolute + && $item->name !~ m{^usr/share/doc/[^/]+/examples/}); + + # Example directories sometimes contain Perl libraries, and + # some people use initial lines like #!perl or #!python to + # provide editor hints, so skip those too if they're not + # executable. Be conservative here, since it's not uncommon + # for people to both not set examples executable and not fix + # the path and we want to warn about that. + return + if ( $item->name =~ /\.pm\z/ + && (!$item->is_file || !$item->is_executable) + && !$is_absolute + && $item->name =~ m{^usr/share/doc/[^/]+/examples/}); + + # Skip upstream source code shipped in /usr/share/cargo/registry/ + return + if $item->name =~ m{^usr/share/cargo/registry/}; + + if ($item->interpreter eq $EMPTY) { + + $self->pointed_hint('script-without-interpreter', $item->pointer) + if $item->name !~ m{^usr/share/doc/[^/]+/examples/}; + + $self->pointed_hint('example-script-without-interpreter', + $item->pointer) + if $item->name =~ m{^usr/share/doc/[^/]+/examples/}; + + return; + } + + # Either they use an absolute path or they use '/usr/bin/env interp'. + $self->pointed_hint('interpreter-not-absolute', $item->pointer, + $item->interpreter) + if !$is_absolute + && $item->name !~ m{^usr/share/doc/[^/]+/examples/}; + + $self->pointed_hint('example-interpreter-not-absolute', + $item->pointer,$item->interpreter) + if !$is_absolute + && $item->name =~ m{^usr/share/doc/[^/]+/examples/}; + + my $bash_completion_regex= qr{^usr/share/bash-completion/completions/.*}; + + $self->pointed_hint('script-not-executable', $item->pointer) + if (!$item->is_file || !$item->is_executable) + && $item->name !~ m{^usr/(?:lib|share)/.*\.pm} + && $item->name !~ m{^usr/(?:lib|share)/.*\.py} + && $item->name !~ m{^usr/(?:lib|share)/ruby/.*\.rb} + && $item->name !~ m{^usr/share/debconf/confmodule(?:\.sh)?$} + && $item->name !~ /\.in$/ + && $item->name !~ /\.erb$/ + && $item->name !~ /\.ex$/ + && $item->name ne 'etc/init.d/skeleton' + && $item->name !~ m{^etc/menu-methods} + && $item->name !~ $bash_completion_regex + && $item->name !~ m{^etc/X11/Xsession\.d} + && $item->name !~ m{^usr/share/doc/} + && $item->name !~ m{^usr/src/}; + + return + unless $item->is_open_ok; + + # Try to find the expected path of the script to check. First + # check $INTERPRETERS and %versioned_interpreters. If not + # found there, see if it ends in a version number and the base + # is found in $VERSIONED_INTERPRETERS + my $interpreter_data = $self->INTERPRETERS->{$basename}; + + my $versioned = 0; + unless (defined $interpreter_data) { + + $interpreter_data = $self->VERSIONED_INTERPRETERS->{$basename}; + + if (!defined $interpreter_data && $basename =~ /^(.*[^\d.-])-?[\d.]+$/) + { + $interpreter_data = $self->VERSIONED_INTERPRETERS->{$1}; + undef $interpreter_data + unless $interpreter_data + && $basename =~ /$interpreter_data->{regex}/; + } + + $versioned = 1 + if defined $interpreter_data; + } + + if (defined $interpreter_data) { + my $expected = $interpreter_data->{folder} . $SLASH . $basename; + + my @context = ($item->interpreter, $NOT_EQUAL, $expected); + + $self->pointed_hint('wrong-path-for-interpreter', $item->pointer, + @context) + if $item->interpreter ne $expected + && !$item->calls_env + && $expected ne '/usr/bin/env perl' + && $item->name !~ m{^usr/share/doc/[^/]+/examples/}; + + $self->pointed_hint('example-wrong-path-for-interpreter', + $item->pointer, @context) + if $item->interpreter ne $expected + && !$item->calls_env + && $expected ne '/usr/bin/env perl' + && $item->name =~ m{^usr/share/doc/[^/]+/examples/}; + + $self->pointed_hint('incorrect-path-for-interpreter', + $item->pointer, @context) + if $item->interpreter ne $expected + && !$item->calls_env + && $expected eq '/usr/bin/env perl' + && $item->name !~ m{^usr/share/doc/[^/]+/examples/}; + + $self->pointed_hint('example-incorrect-path-for-interpreter', + $item->pointer, @context) + if $item->interpreter ne $expected + && !$item->calls_env + && $expected eq '/usr/bin/env perl' + && $item->name =~ m{^usr/share/doc/[^/]+/examples/}; + + } elsif ($item->interpreter =~ m{^/usr/local/}) { + + $self->pointed_hint('interpreter-in-usr-local', $item->pointer, + $item->interpreter) + if $item->name !~ m{^usr/share/doc/[^/]+/examples/}; + + $self->pointed_hint('example-interpreter-in-usr-local', + $item->pointer,$item->interpreter) + if $item->name =~ m{^usr/share/doc/[^/]+/examples/}; + + } elsif ($item->interpreter eq '/bin/env') { + + $self->pointed_hint('script-uses-bin-env', $item->pointer, + $item->interpreter) + if $item->name !~ m{^usr/share/doc/[^/]+/examples/}; + + $self->pointed_hint('example-script-uses-bin-env', $item->pointer, + $item->interpreter) + if $item->name =~ m{^usr/share/doc/[^/]+/examples/}; + + } elsif ($item->interpreter eq 'nodejs') { + + $self->pointed_hint('script-uses-deprecated-nodejs-location', + $item->pointer,$item->interpreter) + if $item->name !~ m{^usr/share/doc/[^/]+/examples/}; + + $self->pointed_hint('example-script-uses-deprecated-nodejs-location', + $item->pointer,$item->interpreter) + if $item->name =~ m{^usr/share/doc/[^/]+/examples/}; + + # Check whether we have correct dependendies on nodejs regardless. + $interpreter_data = $self->INTERPRETERS->{'node'}; + + } elsif ($basename =~ /^php/) { + + $self->pointed_hint('php-script-with-unusual-interpreter', + $item->pointer,$item->interpreter) + if $item->name !~ m{^usr/share/doc/[^/]+/examples/}; + + $self->pointed_hint('example-php-script-with-unusual-interpreter', + $item->pointer, $item->interpreter) + if $item->name =~ m{^usr/share/doc/[^/]+/examples/}; + + # This allows us to still perform the dependencies checks + # below even when an unusual interpreter has been found. + $interpreter_data = $self->INTERPRETERS->{'php'}; + + } else { + my @private_interpreters; + + # Check if the package ships the interpreter (and it is + # executable). + my $name = $item->interpreter; + if ($name =~ s{^/}{}) { + my $file = $self->processable->installed->lookup($name); + push(@private_interpreters, $file) + if defined $file; + + } elsif ($item->calls_env) { + my @files= map { + $self->processable->installed->lookup( + $_ . $SLASH . $item->interpreter) + }qw{bin usr/bin}; + push(@private_interpreters, grep { defined } @files); + } + + $self->pointed_hint('unusual-interpreter', $item->pointer, + $item->interpreter) + if (none { $_->is_file && $_->is_executable } @private_interpreters) + && $item->name !~ m{^usr/share/doc/[^/]+/examples/}; + + $self->pointed_hint('example-unusual-interpreter', $item->pointer, + $item->interpreter) + if (none { $_->is_file && $_->is_executable } @private_interpreters) + && $item->name =~ m{^usr/share/doc/[^/]+/examples/}; + } + + # If we found the interpreter and the script is executable, + # check dependencies. This should be the last thing we do in + # the loop so that we can use next for an early exit and + # reduce the nesting. + return + unless $interpreter_data; + + return + unless $item->is_file && $item->is_executable; + + return + if $item->name =~ m{^usr/share/doc/} || $item->name =~ m{^usr/src/}; + + if (!$versioned) { + my $depends = $interpreter_data->{prerequisites}; + + if ($depends && !$self->all_prerequisites->satisfies($depends)) { + + if ($basename =~ /^php/) { + + $self->pointed_hint('php-script-but-no-php-cli-dep', + $item->pointer, $item->interpreter, + "(does not satisfy $depends)"); + + } elsif ($basename =~ /^(python\d|ruby|[mg]awk)$/) { + + $self->pointed_hint( + ( + "$basename-script-but-no-$basename-dep", + $item->pointer, + $item->interpreter, + "(does not satisfy $depends)" + ) + ); + + } elsif ($basename eq 'csh' + && $item->name =~ m{^etc/csh/login\.d/}){ + # Initialization files for csh. + + } elsif ($basename eq 'fish' && $item->name =~ m{^etc/fish\.d/}) { + # Initialization files for fish. + + } elsif ( + $basename eq 'ocamlrun' + && $self->all_prerequisites->matches( + qr/^ocaml(?:-base)?(?:-nox)?-\d\.[\d.]+/) + ) { + # ABI-versioned virtual packages for ocaml + + } elsif ($basename eq 'escript' + && $self->all_prerequisites->matches(qr/^erlang-abi-[\d+\.]+$/) + ) { + # ABI-versioned virtual packages for erlang + + } else { + + $self->pointed_hint('missing-dep-for-interpreter', + $item->pointer, $item->interpreter, + "(does not satisfy $depends)"); + } + } + + } elsif (exists $self->VERSIONED_INTERPRETERS->{$basename}) { + my @versions = @{ $interpreter_data->{versions} }; + + my @depends; + for my $version (@versions) { + my $d = $interpreter_data->{template}; + $d =~ s/\$1/$version/g; + push(@depends, $d); + } + + unshift(@depends, $interpreter_data->{prerequisites}) + if length $interpreter_data->{prerequisites}; + + my $depends = join(' | ', @depends); + unless ($self->all_prerequisites->satisfies($depends)) { + if ($basename =~ /^(wish|tclsh)/) { + + my $shell_name = $1; + + $self->pointed_hint( + "$shell_name-script-but-no-$shell_name-dep", + $item->pointer, $item->interpreter, + "(does not satisfy $depends)"); + + } else { + + $self->pointed_hint('missing-dep-for-interpreter', + $item->pointer, $item->interpreter, + "(does not satisfy $depends)"); + } + } + + } else { + + my ($version) = ($basename =~ /$interpreter_data->{regex}/); + my $depends = $interpreter_data->{template}; + $depends =~ s/\$1/$version/g; + + unless ($self->all_prerequisites->satisfies($depends)) { + if ($basename =~ /^(python|ruby)/) { + + $self->pointed_hint("$1-script-but-no-$1-dep", + $item->pointer, $item->interpreter, + "(does not satisfy $depends)"); + + } else { + + $self->pointed_hint('missing-dep-for-interpreter', + $item->pointer, $item->interpreter, + "(does not satisfy $depends)"); + } + } + } + + return; +} + +sub visit_control_files { + my ($self, $item) = @_; + + return + unless $item->is_maintainer_script; + + if ($item->is_elf) { + + $self->pointed_hint('elf-maintainer-script', $item->pointer); + return; + } + + # keep 'env', if present + my $interpreter = $item->hashbang; + + # keep base command without options + $interpreter =~ s/^(\S+).*/$1/; + + if ($interpreter eq $EMPTY) { + + $self->pointed_hint('script-without-interpreter', $item->pointer); + return; + } + + # tag for statistics + $self->pointed_hint('maintainer-script-interpreter', + $item->pointer, $interpreter); + + $self->pointed_hint('interpreter-not-absolute', $item->pointer, + $interpreter) + unless $interpreter =~ m{^/}; + + my $basename = basename($interpreter); + + if ($interpreter =~ m{^/usr/local/}) { + $self->pointed_hint('control-interpreter-in-usr-local', + $item->pointer, $interpreter); + + } elsif ($basename eq 'sh' || $basename eq 'bash' || $basename eq 'perl') { + my $expected + = $self->INTERPRETERS->{$basename}->{folder}. $SLASH. $basename; + + my $tag_name + = ($expected eq '/usr/bin/env perl') + ? + 'incorrect-path-for-interpreter' + : 'wrong-path-for-interpreter'; + + $self->pointed_hint( + $tag_name, $item->pointer, $interpreter, + $NOT_EQUAL, $expected + )unless $interpreter eq $expected; + + } elsif ($item->name eq 'config') { + $self->pointed_hint('forbidden-config-interpreter', + $item->pointer, $interpreter); + + } elsif ($item->name eq 'postrm') { + $self->pointed_hint('forbidden-postrm-interpreter', + $item->pointer, $interpreter); + + } elsif (exists $self->INTERPRETERS->{$basename}) { + + my $interpreter_data = $self->INTERPRETERS->{$basename}; + my $expected = $interpreter_data->{folder} . $SLASH . $basename; + + my $tag_name + = ($expected eq '/usr/bin/env perl') + ? + 'incorrect-path-for-interpreter' + : 'wrong-path-for-interpreter'; + + $self->pointed_hint( + $tag_name, $item->pointer, $interpreter, + $NOT_EQUAL, $expected + )unless $interpreter eq $expected; + + $self->pointed_hint('unusual-control-interpreter', $item->pointer, + $interpreter); + + # Interpreters used by preinst scripts must be in + # Pre-Depends. Interpreters used by postinst or prerm + # scripts must be in Depends. + if ($interpreter_data->{prerequisites}) { + + my $depends = Lintian::Relation->new->load( + $interpreter_data->{prerequisites}); + + if ($item->name eq 'preinst') { + + $self->pointed_hint( + 'control-interpreter-without-predepends', + $item->pointer, + $interpreter, + '(does not satisfy ' . $depends->to_string . ')' + ) + unless $self->processable->relation('Pre-Depends') + ->satisfies($depends); + + } else { + + $self->pointed_hint( + 'control-interpreter-without-depends', + $item->pointer, + $interpreter, + '(does not satisfy ' . $depends->to_string . ')' + ) + unless $self->processable->relation('strong') + ->satisfies($depends); + } + } + + } else { + $self->pointed_hint('unknown-control-interpreter', $item->pointer, + $interpreter); + + # no use doing further checks if it's not a known interpreter + return; + } + + return + unless $item->is_open_ok; + + # now scan the file contents themselves + open(my $fd, '<', $item->unpacked_path) + or die encode_utf8('Cannot open ' . $item->unpacked_path); + + my $saw_debconf; + my $saw_bange; + my $saw_sete; + my $saw_udevadm_guard; + + my $cat_string = $EMPTY; + + my $previous_line = $EMPTY; + my $in_automatic_section = 0; + + my $position = 1; + while (my $line = <$fd>) { + + my $pointer = $item->pointer($position); + + $saw_bange = 1 + if $position == 1 + && $item->is_shell_script + && $line =~ m{/$basename\s*.*\s-\w*e\w*\b}; + + $in_automatic_section = 1 + if $line =~ /^# Automatically added by \S+\s*$/; + + $in_automatic_section = 0 + if $line eq '# End automatically added section'; + + # skip empty lines + next + if $line =~ /^\s*$/; + + # skip comment lines + next + if $line =~ /^\s*\#/; + + $line = remove_comments($line); + + # Concatenate lines containing continuation character (\) + # at the end + if ($item->is_shell_script && $line =~ /\\$/) { + + $line =~ s/\\//; + chomp $line; + $previous_line .= $line; + + next; + } + + chomp $line; + + $line = $previous_line . $line; + $previous_line = $EMPTY; + + $saw_sete = 1 + if $item->is_shell_script + && $line =~ /${LEADING_REGEX}set\s*(?:\s+-(?:-.*|[^e]+))*\s-\w*e/; + + $saw_udevadm_guard = 1 + if $line =~ /\b(if|which|command)\s+.*udevadm/g; + + if ($line =~ m{$LEADING_REGEX(?:/bin/)?udevadm\s} && $saw_sete) { + + $self->pointed_hint('udevadm-called-without-guard',$pointer) + unless $saw_udevadm_guard + || $line =~ m{\|\|} + || $self->strong_prerequisites->satisfies('udev:any'); + } + + if ($item->is_shell_script) { + + $cat_string = $EMPTY + if $cat_string ne $EMPTY + && $line =~ /^\Q$cat_string\E$/; + + my $within_another_shell = 0; + + $within_another_shell = 1 + if $item->interpreter !~ m{(?:^|/)sh$} + && $item->interpreter_with_options =~ /\S+\s+-c/; + + if (!$cat_string) { + + $self->generic_check_bad_command($item, $line, + $position, 0,$in_automatic_section); + + $saw_debconf = 1 + if $line =~ m{/usr/share/debconf/confmodule}; + + $self->pointed_hint('read-in-maintainer-script',$pointer) + if $line =~ /^\s*read(?:\s|\z)/ && !$saw_debconf; + + $self->pointed_hint('multi-arch-same-package-calls-pycompile', + $pointer) + if $line =~ /^\s*py3?compile(?:\s|\z)/ + &&$self->processable->fields->value('Multi-Arch') eq 'same'; + + $self->pointed_hint('maintainer-script-modifies-inetd-conf', + $pointer) + if $line =~ m{>\s*/etc/inetd\.conf(?:\s|\Z)} + && !$self->processable->relation('Provides') + ->satisfies('inet-superserver:any'); + + $self->pointed_hint('maintainer-script-modifies-inetd-conf', + $pointer) + if $line=~ m{^\s*(?:cp|mv)\s+(?:.*\s)?/etc/inetd\.conf\s*$} + && !$self->processable->relation('Provides') + ->satisfies('inet-superserver:any'); + + # Check for running commands with a leading path. + # + # Unfortunately, our $LEADING_REGEX string doesn't work + # well for this in the presence of commands that + # contain backquoted expressions because it can't + # tell the difference between the initial backtick + # and the closing backtick. We therefore first + # extract all backquoted expressions and check + # them separately, and then remove them from a + # copy of a string and then check it for bashisms. + while ($line =~ /\`([^\`]+)\`/g) { + + my $mangled = $1; + + if ( + $mangled =~ m{ $LEADING_REGEX + (/(?:usr/)?s?bin/[\w.+-]+) + (?:\s|;|\Z)}xsm + ) { + my $command = $1; + + $self->pointed_hint( + 'command-with-path-in-maintainer-script', + $pointer, $command,'(in backticks)') + unless $in_automatic_section; + } + } + + # check for test syntax + if( + $line =~ m{\[\s+ + (?:!\s+)? -x \s+ + (/(?:usr/)?s?bin/[\w.+-]+) + \s+ \]}xsm + ){ + my $command = $1; + + $self->pointed_hint( + 'command-with-path-in-maintainer-script', + $pointer, $command,'(in test syntax)') + unless $in_automatic_section; + } + + my $mangled = $line; + $mangled =~ s/\`[^\`]+\`//g; + + if ($mangled + =~ m{$LEADING_REGEX(/(?:usr/)?s?bin/[\w.+-]+)(?:\s|;|$)}){ + my $command = $1; + + $self->pointed_hint( + 'command-with-path-in-maintainer-script', + $pointer, $command, '(plain script)') + unless $in_automatic_section; + } + } + } + + for my $pattern (keys %prerequisite_by_command_pattern) { + + next + unless $line =~ /($pattern)/; + + my $command = $1; + + next + if $line =~ /-x\s+\S*$pattern/ + || $line =~ /(?:which|type)\s+$pattern/ + || $line =~ /command\s+.*?$pattern/ + || $line =~ m{ [|][|] \s* true \b }x; + + my $requirement = $prerequisite_by_command_pattern{$pattern}; + + my $first_alternative = $requirement; + $first_alternative =~ s/[ \(].*//; + + $self->pointed_hint( + "maintainer-script-needs-depends-on-$first_alternative", + $pointer, $command,"(does not satisfy $requirement)") + unless $self->processable->relation('strong') + ->satisfies($requirement) + || $self->processable->name eq $first_alternative + || $item->name eq 'postrm'; + } + + $self->generic_check_bad_command($item, $line, $position, 1, + $in_automatic_section); + + if ($line =~ m{$LEADING_REGEX(?:/usr/sbin/)?update-inetd\s}) { + + $self->pointed_hint( + 'maintainer-script-has-invalid-update-inetd-options', + $pointer, '(--pattern with --add)') + if $line =~ /--pattern/ + && $line =~ /--add/; + + $self->pointed_hint( + 'maintainer-script-has-invalid-update-inetd-options', + $pointer, '(--group without --add)') + if $line =~ /--group/ + && $line !~ /--add/; + } + + } continue { + ++$position; + } + + close $fd; + + $self->pointed_hint('maintainer-script-without-set-e', $item->pointer) + if $item->is_shell_script && !$saw_sete && $saw_bange; + + $self->pointed_hint('maintainer-script-ignores-errors', $item->pointer) + if $item->is_shell_script && !$saw_sete && !$saw_bange; + + return; +} + +sub generic_check_bad_command { + my ($self, $script, $line, $position, $find_in_cat_string, + $in_automatic_section) + = @_; + + for my $tag_name (keys %{$self->BAD_MAINTAINER_COMMANDS}) { + + my $command_data= $self->BAD_MAINTAINER_COMMANDS->{$tag_name}; + + next + if $in_automatic_section + && $command_data->{ignore_automatic_sections}; + + next + unless $script->name =~ $command_data->{script_include_regex}; + + next + unless $find_in_cat_string == $command_data->{in_cat_string}; + + if ($line =~ m{ ( $command_data->{command_pattern} ) }x) { + + my $bad_command = $1 // $EMPTY; + + # trim both ends + $bad_command =~ s/^\s+|\s+$//g; + + my $pointer = $script->pointer($position); + + $self->pointed_hint($tag_name, $pointer, + $DOUBLE_QUOTE . $bad_command . $DOUBLE_QUOTE) + unless $self->processable->name + =~ $command_data->{package_exclude_regex}; + } + } + + return; +} + +sub remove_comments { + my ($line) = @_; + + return $line + unless length $line; + + my $simplified = $line; + + # Remove quoted strings so we can more easily ignore comments + # inside them + $simplified =~ s/(^|[^\\](?:\\\\)*)\'(?:\\.|[^\\\'])+\'/$1''/g; + $simplified =~ s/(^|[^\\](?:\\\\)*)\"(?:\\.|[^\\\"])+\"/$1""/g; + + # If the remaining string contains what looks like a comment, + # eat it. In either case, swap the unmodified script line + # back in for processing (if required) and return it. + if ($simplified =~ m/(?:^|[^[\\])[\s\&;\(\)](\#.*$)/) { + + my $comment = $1; + + # eat comment + $line =~ s/\Q$comment\E//; + } + + return $line; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et |