scripts.pm 56.2 KB
Newer Older
1
# scripts -- lintian check script -*- perl -*-
2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21
#
# This is probably the right file to add a check for the use of
# set -e in bash and sh scripts.
#
# Copyright (C) 1998 Richard Braakman
# Copyright (C) 2002 Josip Rodin
#
# 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
Frank Lichtenheld's avatar
Frank Lichtenheld committed
22 23
# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
# MA 02110-1301, USA.
24

Jeroen van Wolffelaar's avatar
Jeroen van Wolffelaar committed
25
package Lintian::scripts;
26
use strict;
27
use warnings;
28
use autodie;
29

30
use POSIX qw(strftime);
31 32
use List::MoreUtils qw(any);

33
use Lintian::Check qw($known_shells_regex);
34
use Lintian::Data;
35
use Lintian::Relation;
36
use Lintian::Tags qw(tag);
37
use Lintian::Util qw(do_fork internal_error strip);
38

39 40 41 42 43
# 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.
Russ Allbery's avatar
Russ Allbery committed
44
#
45 46
# $INTERPRETERS maps names of (unversioned) interpreters to the path
# they are installed and what package to depend on to use them.
Russ Allbery's avatar
Russ Allbery committed
47
#
48 49
my $INTERPRETERS = Lintian::Data->new('scripts/interpreters', qr/\s*=\>\s*/o,
    \&_parse_interpreters);
50

Russ Allbery's avatar
Russ Allbery committed
51 52 53 54
# 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
55 56 57
# dashes, digits, and periods.
#
# The list contains the following values:
Jakub Wilk's avatar
Jakub Wilk committed
58
#  [<path>, <dependency-relation>, <regex>, <dependency-template>, <version-list>]
59 60 61 62
#
# 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:
Russ Allbery's avatar
Russ Allbery committed
63
#
64 65 66 67 68 69 70 71
# * <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:
#   @NO_DEFAULT_DEPS@  -> '' (i.e. an empty string)
#   @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"])
Russ Allbery's avatar
Russ Allbery committed
72
#
73
# A full example is:
Russ Allbery's avatar
Russ Allbery committed
74
#
75 76
#    data:
#        lua => /usr/bin, lua([\d.]+), 'lua$1', 40 50 5.1
Russ Allbery's avatar
Russ Allbery committed
77
#
78 79
#    $VERSIONED_INTERPRETERS->value ('lua') is
#       [ '/usr/bin', 'lua', qr/^lua([\d.]+)$/, 'lua$1', ["40", "50", "5.1"] ]
Russ Allbery's avatar
Russ Allbery committed
80
#
81 82 83
my $VERSIONED_INTERPRETERS
  = Lintian::Data->new('scripts/versioned-interpreters',
    qr/\s*=\>\s*/o,\&_parse_versioned_interpreters);
84

85 86 87
# 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.
88
my $LEADINSTR
89
  = '(?:(?:^|[`&;(|{])\s*|(?:if|then|do|while|!)\s+|env(?:\s+[[:alnum:]_]+=(?:\S+|\"[^"]*\"|\'[^\']*\'))*\s+)';
90 91
my $LEADIN = qr/$LEADINSTR/;

92 93 94
# date --date="Sat, 17 Jun 2017 20:22:36 -1000" +%s
# <https://lists.debian.org/debian-announce/2017/msg00003.html>
my $OLDSTABLE_RELEASE = 1_497_766_956
95

96
#forbidden command in maintainer scripts
97 98
my $BAD_MAINT_CMD = Lintian::Data->new(
    'scripts/maintainer-script-bad-command',
99
    qr/\s*\~\~/,
100
    sub {
101 102
        my @sliptline = split(/\s*\~\~/, $_[1], 5);
        if(scalar(@sliptline) != 5) {
103 104
            internal_error(
                'Syntax error in scripts/maintainer-script-bad-command:', $.);
105
        }
106
        my ($incat,$inauto,$exceptinpackage,$inscript,$regexp) = @sliptline;
107
        $regexp =~ s/\$[{]LEADIN[}]/$LEADINSTR/;
108 109 110
   # allow empty $exceptinpackage and set it synonymous to check in all package
        $exceptinpackage
          = defined($exceptinpackage) ? strip($exceptinpackage) : '';
111 112 113
        if (length($exceptinpackage) == 0) {
            $exceptinpackage = '\a\Z';
        }
114 115 116 117 118
        # allow empty $inscript and set to synonymous to check in all script
        $inscript = defined($inscript) ? strip($inscript) : '';
        if (length($inscript) == 0) {
            $inscript = '.*';
        }
119 120
        return {
            # use not not to normalize boolean
121
            'ignore_automatically_added' => not(not(strip($inauto))),
122
            'in_cat_string' => not(not(strip($incat))),
123
            'in_package' => qr/$exceptinpackage/x,
124
            'in_script' => qr/$inscript/x,
125 126 127
            'regexp' => qr/$regexp/x,
        };
    });
128

129
# Any of the following packages can satisfy an update-inetd dependency.
130 131 132 133
my $update_inetd = join(
    ' | ', qw(update-inetd inet-superserver openbsd-inetd
      inetutils-inetd rlinetd xinetd)
);
134

135 136 137 138
# 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.
139
my @depends_needed = (
140 141 142 143 144
    [adduser       => '\badduser\s'],
    [gconf2        => '\bgconf-schemas\s'],
    [$update_inetd => '\bupdate-inetd\s'],
    [ucf           => '\bucf\s'],
    ['xml-core'    => '\bupdate-xmlcatalog\s'],
145
    ['xfonts-utils' => '\bupdate-fonts-(?:alias|dir|scale)\s'],
146 147
);

148
my @bashism_single_quote_regexs = (
149
    $LEADIN . qr'echo\s+(?:-[^e\s]+\s+)?\'[^\']*(\\[abcEfnrtv0])+.*?[\']',
150
    # unsafe echo with backslashes
151
    $LEADIN . qr'source\s+[\"\']?(?:\.\/|\/|\$|[\w~.-])\S*',
152
    # should be '.', not 'source'
153
);
154
my @bashism_string_regexs = (
155
    qr'\$\[\w+\]',               # arith not allowed
156
    qr'\$\{\w+\:\d+(?::\d+)?\}',   # ${foo:3[:1]}
157
    qr'\$\{\w+(/.+?){1,2}\}',    # ${parm/?/pat[/str]}
158
    qr'\$\{\#?\w+\[[0-9\*\@]+\]\}',# bash arrays, ${name[0|*|@]}
159 160
    qr'\$\{!\w+[\@*]\}',                 # ${!prefix[*|@]}
    qr'\$\{!\w+\}',              # ${!name}
161
    qr'(\$\(|\`)\s*\<\s*\S+\s*(\)|\`)', # $(\< foo) should be $(cat foo)
162
    qr'\$\{?RANDOM\}?\b',                # $RANDOM
163 164 165 166
    qr'\$\{?(OS|MACH)TYPE\}?\b',   # $(OS|MACH)TYPE
    qr'\$\{?HOST(TYPE|NAME)\}?\b', # $HOST(TYPE|NAME)
    qr'\$\{?DIRSTACK\}?\b',        # $DIRSTACK
    qr'\$\{?EUID\}?\b',            # $EUID should be "id -u"
167 168
    qr'\$\{?UID\}?\b',           # $UID should be "id -ru"
    qr'\$\{?SECONDS\}?\b',       # $SECONDS
169 170 171
    qr'\$\{?BASH_[A-Z]+\}?\b',     # $BASH_SOMETHING
    qr'\$\{?SHELLOPTS\}?\b',       # $SHELLOPTS
    qr'\$\{?PIPESTATUS\}?\b',      # $PIPESTATUS
172
    qr'\$\{?SHLVL\}?\b',                 # $SHLVL
173
    qr'<<<',                       # <<< here string
174
    $LEADIN . qr'echo\s+(?:-[^e\s]+\s+)?\"[^\"]*(\\[abcEfnrtv0])+.*?[\"]',
175
    # unsafe echo with backslashes
176
);
177
my @bashism_regexs = (
178 179 180
    qr'(?:^|\s+)function \w+(\s|\(|\Z)',  # function is useless
    qr'(test|-o|-a)\s*[^\s]+\s+==\s', # should be 'b = a'
    qr'\[\s+[^\]]+\s+==\s',        # should be 'b = a'
181
    qr'\s(\|\&)',                        # pipelining is not POSIX
182 183 184
    qr'[^\\\$]\{(?:[^\s\\\}]*?,)+[^\\\}\s]*\}', # brace expansion
    qr'(?:^|\s+)\w+\[\d+\]=',      # bash arrays, H[0]
    $LEADIN . qr'read\s+(?:-[a-qs-zA-Z\d-]+)',
185
    # read with option other than -r
186
    $LEADIN . qr'read\s*(?:-\w+\s*)*(?:\".*?\"|[\'].*?[\'])?\s*(?:;|$)',
187
    # read without variable
188
    qr'\&>',                     # cshism
189
    qr'(<\&|>\&)\s*((-|\d+)[^\s;|)`&\\\\]|[^-\d\s]+)', # should be >word 2>&1
190
    qr'\[\[(?!:)',               # alternative test command
191 192 193
    $LEADIN . qr'select\s+\w+',    # 'select' is not POSIX
    $LEADIN . qr'echo\s+(-n\s+)?-n?en?',  # echo -e
    $LEADIN . qr'exec\s+-[acl]',   # exec -c/-l/-a name
194
    qr'(?:^|\s+)let\s',          # let ...
195
    qr'(?<![\$\(])\(\(.*\)\)',     # '((' should be '$(('
196 197 198 199
    qr'\$\[[^][]+\]',            # '$[' should be '$(('
    qr'(\[|test)\s+-a',          # test with unary -a (should be -e)
    qr'/dev/(tcp|udp)',          # /dev/(tcp|udp)
    $LEADIN . qr'\w+\+=',                # should be "VAR="${VAR}foo"
200 201 202 203 204 205 206 207 208 209 210 211 212
    $LEADIN . qr'suspend\s',
    $LEADIN . qr'caller\s',
    $LEADIN . qr'complete\s',
    $LEADIN . qr'compgen\s',
    $LEADIN . qr'declare\s',
    $LEADIN . qr'typeset\s',
    $LEADIN . qr'disown\s',
    $LEADIN . qr'builtin\s',
    $LEADIN . qr'set\s+-[BHT]+',   # set -[BHT]
    $LEADIN . qr'alias\s+-p',      # alias -p
    $LEADIN . qr'unalias\s+-a',    # unalias -a
    $LEADIN . qr'local\s+-[a-zA-Z]+', # local -opt
    qr'(?:^|\s+)\s*\(?\w*[^\(\w\s]+\S*?\s*\(\)\s*([\{|\(]|\Z)',
213
    # function names should only contain [a-z0-9_]
214 215 216 217 218 219 220
    $LEADIN . qr'(push|pop)d(\s|\Z)',   # (push|pod)d
    $LEADIN . qr'export\s+-[^p]',  # export only takes -p as an option
    $LEADIN . qr'ulimit(\s|\Z)',
    $LEADIN . qr'shopt(\s|\Z)',
    $LEADIN . qr'type\s',
    $LEADIN . qr'time\s',
    $LEADIN . qr'dirs(\s|\Z)',
221
    qr'(?:^|\s+)[<>]\(.*?\)',      # <() process substitution
222 223 224 225 226 227
    qr'(?:^|\s+)readonly\s+-[af]', # readonly -[af]
    $LEADIN . qr'(sh|\$\{?SHELL\}?) -[rD]', # sh -[rD]
    $LEADIN . qr'(sh|\$\{?SHELL\}?) --\w+', # sh --long-option
    $LEADIN . qr'(sh|\$\{?SHELL\}?) [-+]O', # sh [-+]O
);

228 229
# a local function to help use separate tags for example scripts
sub script_tag {
230
    my($tag, $filename, @rest) = @_;
231 232

    $tag = "example-$tag"
233
      if $filename and $filename =~ m,usr/share/doc/[^/]+/examples/,;
234

235
    tag($tag, $filename, @rest);
236
    return;
237
}
238

Russ Allbery's avatar
Russ Allbery committed
239
sub run {
240
    my ($pkg, undef, $info) = @_;
Russ Allbery's avatar
Russ Allbery committed
241

242
    my (%executable, %ELF, %scripts, %seen_helper_cmds);
243

244 245
    # no dependency for install-menu, because the menu package specifically
    # says not to depend on it.
246

247
    foreach my $file ($info->sorted_index) {
248
        next if not $file->is_file;
249 250
        $ELF{$file} = 1 if $file->file_info =~ /^[^,]*\bELF\b/o;
        next unless $file->operm & 0111;
251
        $executable{$file} = 1;
252 253
    }

254 255 256 257
    my $all_parsed = Lintian::Relation->and($info->relation('all'),
        $info->relation('provides'),$pkg);
    my $str_deps = $info->relation('strong');

258 259 260 261
    my @x11_fonts
      = grep {m,^usr/share/fonts/X11/.*\.(?:afm|pcf|pfa|pfb)(?:\.gz)?$,}
      $info->sorted_index;

262 263
    my %old_versions;
    for my $entry ($info->changelog ? $info->changelog->data : ()) {
264 265 266
        my $timestamp = $entry->Timestamp // $OLDSTABLE_RELEASE;
        $old_versions{$entry->Version} = $timestamp
          if $timestamp < $OLDSTABLE_RELEASE;
267
    }
268

269
    for my $filename (sort keys %{$info->scripts}) {
270 271
        my $interpreter = $info->scripts->{$filename}{interpreter};
        my $calls_env = $info->scripts->{$filename}{calls_env};
272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297
        my $path;
        $scripts{$filename} = 1;

        # 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).
        my $in_docs = $filename =~ m,^usr/(?:share/doc|src)/,;
        my $in_examples = $filename =~ m,^usr/share/doc/[^/]+/examples/,;

        # no checks necessary at all for scripts in /usr/share/doc/
        # unless they are examples
        next if $in_docs and not $in_examples;

        my ($base) = $interpreter =~ m,([^/]*)$,;

        # allow exception for .in files that have stuff like #!@PERL@
        next
          if (  $filename =~ m,\.in$,
            and $interpreter =~ m,^(\@|<\<)[A-Z_]+(\@|>\>)$,);

        my $is_absolute = ($interpreter =~ m,^/, or defined $calls_env);

298 299
        # As a special-exception, Policy 10.4 states that Perl scripts must use
        # /usr/bin/perl directly and not via /usr/bin/env, etc.
300 301
        script_tag(bad_interpreter_tag_name('/usr/bin/env perl'),
            $filename, '(#!/usr/bin/env perl != /usr/bin/perl)')
302 303
          if defined $calls_env and $interpreter eq 'perl';

304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325
        # 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.
        next
          if ( $filename !~ m,(?:bin/|etc/init\.d/),
            && !$executable{$filename}
            && !$is_absolute
            && !$in_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.
        next
          if ( $filename =~ /\.pm\z/
            && !$executable{$filename}
            && !$is_absolute
            && $in_examples);

326 327 328 329
        # Skip upstream source code shipped in /usr/share/cargo/registry/
        next
          if $filename =~ m,^usr/share/cargo/registry/,;

330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354
        if ($interpreter eq '') {
            script_tag('script-without-interpreter', $filename);
            next;
        }

        # Either they use an absolute path or they use '/usr/bin/env interp'.
        script_tag('interpreter-not-absolute', $filename, "#!$interpreter")
          unless $is_absolute;
        tag 'script-not-executable', $filename
          unless ($executable{$filename}
            or $filename =~ m,^usr/(?:lib|share)/.*\.pm,
            or $filename =~ m,^usr/(?:lib|share)/.*\.py,
            or $filename =~ m,^usr/(?:lib|share)/ruby/.*\.rb,
            or $filename =~ m,^usr/share/debconf/confmodule(?:\.sh)?$,
            or $filename =~ m,\.in$,
            or $filename =~ m,\.erb$,
            or $filename =~ m,\.ex$,
            or $filename eq 'etc/init.d/skeleton'
            or $filename =~ m,^etc/menu-methods,
            or $filename =~ m,^etc/X11/Xsession\.d,)
          or $in_docs;

        # Warn about csh scripts.
        tag 'csh-considered-harmful', $filename
          if (  ($base eq 'csh' or $base eq 'tcsh')
355 356
            and $executable{$filename}
            and $filename !~ m,^etc/csh/login\.d/,)
357 358
          and not $in_docs;

359 360
        $path = $info->index_resolved_path($filename);
        next if not $path or not $path->is_open_ok;
361 362 363 364 365 366 367 368 369 370 371
        # Syntax-check most shell scripts, but don't syntax-check
        # scripts that end in .dpatch.  bash -n doesn't stop checking
        # at exit 0 and goes on to blow up on the patch itself.
        if ($base =~ /^$known_shells_regex$/) {
            if (
                    -x $interpreter
                and not script_is_evil_and_wrong($path)
                and $filename !~ m,\.dpatch$,
                and $filename !~ m,\.erb$,
                # exclude some shells. zsh -n is broken, see #485885
                and $base !~ m/^(?:z|t?c)sh$/
372
            ) {
373 374 375 376

                if (check_script_syntax($interpreter, $path)) {
                    script_tag('shell-script-fails-syntax-check', $filename);
                }
377 378
            }
        }
Russ Allbery's avatar
Russ Allbery committed
379

380 381 382 383 384 385 386 387 388 389 390 391 392 393
        # 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 $data = $INTERPRETERS->value($base);
        my $versioned = 0;
        if (not defined $data) {
            $data = $VERSIONED_INTERPRETERS->value($base);
            undef $data if ($data and not defined($data->[1]));
            if (not defined($data) and $base =~ /^(.*[^\d.-])-?[\d.]+$/) {
                $data = $VERSIONED_INTERPRETERS->value($1);
                undef $data unless ($data and $base =~ /$data->[2]/);
            }
            $versioned = 1 if $data;
394
        }
395 396 397
        if ($data) {
            my $expected = $data->[0] . '/' . $base;
            unless ($interpreter eq $expected or defined $calls_env) {
398 399
                script_tag(bad_interpreter_tag_name($expected),
                    $filename, "(#!$interpreter != $expected)");
400 401 402 403 404
            }
        } elsif ($interpreter =~ m,/usr/local/,) {
            script_tag('interpreter-in-usr-local', $filename,"#!$interpreter");
        } elsif ($interpreter eq '/bin/env') {
            script_tag('script-uses-bin-env', $filename);
405 406 407 408
        } elsif ($interpreter eq 'nodejs') {
            script_tag('script-uses-deprecated-nodejs-location',$filename);
            # Check whether we have correct dependendies on nodejs regardless.
            $data = $INTERPRETERS->value('node');
409 410 411 412 413 414 415
        } elsif ($base =~ /^php/) {
            script_tag('php-script-with-unusual-interpreter',
                $filename, "$interpreter");

            # This allows us to still perform the dependencies checks
            # below even when an unusual interpreter has been found.
            $data = $INTERPRETERS->value('php');
416 417 418 419 420 421
        } else {
            my $pinter = 0;
            if ($interpreter =~ m,^/,) {
                # Check if the package ships the interpreter (and it is
                # executable).
                my $interfile = substr $interpreter, 1;
422
                $pinter = 1 if $executable{$interfile};
423 424 425 426 427 428 429
            } elsif (defined $calls_env) {
                for my $dir (qw(usr/bin bin)) {
                    if ($executable{"$dir/$interpreter"}) {
                        $pinter = 1;
                        last;
                    }
                }
430 431 432
            }
            script_tag('unusual-interpreter', $filename, "#!$interpreter")
              unless $pinter;
433

434
        }
435

436 437 438 439 440
        # Check for obsolete perl libraries
        if (
            $base eq 'perl'
            &&!$str_deps->implies(
                'libperl4-corelibs-perl | perl (<< 5.12.3-7)')
441
        ) {
442
            my $fd = $path->open;
443 444
            while (<$fd>) {
                if (
445
                    m{ (?:do|require)\s+['"] # do/require
446 447 448 449 450 451 452 453 454

                          # Huge list of perl4 modules...
                          (abbrev|assert|bigfloat|bigint|bigrat
                          |cacheout|complete|ctime|dotsh|exceptions
                          |fastcwd|find|finddepth|flush|getcwd|getopt
                          |getopts|hostname|importenv|look|newgetopt
                          |open2|open3|pwd|shellwords|stat|syslog
                          |tainted|termcap|timelocal|validate)
                          # ... so they end with ".pl" rather than ".pm"
455
                          \.pl['"]
456
               }xsm
457
                ) {
458 459 460
                    tag 'script-uses-perl4-libs-without-dep',
                      "$filename:$. ${1}.pl";
                }
461
            }
462
            close($fd);
463 464
        }

465 466 467 468 469 470 471 472 473
        # 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.
        next unless ($data and $executable{$filename} and not $in_docs);
        if (!$versioned) {
            my $depends = $data->[1];
            if (not defined $depends) {
                $depends = $base;
474
            }
475
            if ($depends && !$all_parsed->implies($depends)) {
476
                if ($base =~ /^php/) {
477 478
                    tag 'php-script-but-no-php-cli-dep', $filename,
                      "#!$interpreter";
479
                } elsif ($base =~ /^(python|ruby|[mg]awk)$/) {
480 481
                    tag("$base-script-but-no-$base-dep",
                        $filename, "#!$interpreter");
482 483 484 485 486 487 488 489
                } elsif ($base eq 'csh' && $filename =~ m,^etc/csh/login\.d/,){
                    # Initialization files for csh.
                } elsif ($base eq 'fish' && $filename =~ m,^etc/fish\.d/,) {
                    # Initialization files for fish.
                } elsif (
                    $base eq 'ocamlrun'
                    && $all_parsed->matches(
                        qr/^ocaml(?:-base)?(?:-nox)?-\d\.[\d.]+/)
490
                ) {
491
                    # ABI-versioned virtual packages for ocaml
492 493 494
                } elsif ($base eq 'escript'
                    && $all_parsed->matches(qr/^erlang-abi-[\d+\.]+$/)) {
                    # ABI-versioned virtual packages for erlang
495 496
                } else {
                    tag 'missing-dep-for-interpreter', "$base => $depends",
497
                      "($filename)", "#!$interpreter";
498
                }
499
            }
500 501 502 503 504 505 506 507 508 509
        } elsif ($VERSIONED_INTERPRETERS->known($base)) {
            my @versions = @{ $data->[4] };
            my @depends = map {
                my $d = $data->[3];
                $d =~ s/\$1/$_/g;
                $d;
            } @versions;
            unshift(@depends, $data->[1]) if length $data->[1];
            my $depends = join(' | ',  @depends);
            unless ($all_parsed->implies($depends)) {
510
                if ($base =~ /^(wish|tclsh)/) {
511
                    tag "$1-script-but-no-$1-dep", $filename, "#!$interpreter";
512 513
                } else {
                    tag 'missing-dep-for-interpreter', "$base => $depends",
514
                      "($filename)", "#!$interpreter";
515 516 517 518 519 520 521
                }
            }
        } else {
            my ($version) = ($base =~ /$data->[2]/);
            my $depends = $data->[3];
            $depends =~ s/\$1/$version/g;
            unless ($all_parsed->implies($depends)) {
522
                if ($base =~ /^(python|ruby)/) {
523
                    tag "$1-script-but-no-$1-dep", $filename,"#!$interpreter";
524 525
                } else {
                    tag 'missing-dep-for-interpreter', "$base => $depends",
526
                      "($filename)", "#!$interpreter";
527
                }
528 529
            }
        }
530 531
    }

532 533 534 535 536 537 538 539 540 541
    foreach (keys %executable) {
        my $index_info = $info->index($_);
        my $ok = 0;
        if ($index_info->is_hardlink) {
            # We don't collect script information for hardlinks, so check
            # if the target is a script.
            my $target = $index_info->link_normalized;
            if (exists $info->scripts->{$target}) {
                $ok = 1;
            }
542
        }
543 544 545 546 547 548 549 550 551 552

        tag 'executable-not-elf-or-script', $_
          unless (
               $ok
            or $ELF{$_}
            or $scripts{$_}
            or $_ =~ m,^usr(?:/X11R6)?/man/,
            or $_ =~ m/\.exe$/ # mono convention
            or $_ =~ m/\.jar$/ # Debian Java policy 2.2
          );
553 554
    }

555
    open(my $ctrl_fd, '<', $info->lab_data_path('control-scripts'));
556

557 558 559
    # Handle control scripts.  This is an edited version of the code for
    # normal scripts above, because there were just enough differences to
    # make a shared function awkward.
560

561
    my (%added_diversions, %removed_diversions, %dh_cmd_substs);
562 563 564
    my $expand_diversions = 0;
    while (<$ctrl_fd>) {
        chop;
565

566 567
        m/^(\S*) (.*)$/
          or internal_error("bad line in control-scripts file: $_");
568 569
        my $interpreter = $1;
        my $file = $2;
570
        my $path = $info->control_index_resolved_path($file);
571

572 573
        $interpreter =~ m|([^/]*)$|;
        my $base = $1;
574

575 576 577
        # tag for statistics
        tag 'maintainer-script-interpreter', "control/$file", $interpreter;

578 579 580 581
        if ($interpreter eq '') {
            tag 'script-without-interpreter', "control/$file";
            next;
        }
582

583 584 585 586 587
        if ($interpreter eq 'ELF') {
            tag 'elf-maintainer-script', "control/$file";
            next;
        }

588 589
        tag 'interpreter-not-absolute', "control/$file", "#!$interpreter"
          unless ($interpreter =~ m|^/|);
590

591 592 593 594 595
        if ($interpreter =~ m|/usr/local/|) {
            tag 'control-interpreter-in-usr-local', "control/$file",
              "#!$interpreter";
        } elsif ($base eq 'sh' or $base eq 'bash' or $base eq 'perl') {
            my $expected = ($INTERPRETERS->value($base))->[0] . '/' . $base;
596 597 598
            tag bad_interpreter_tag_name($expected),
              "#!$interpreter != $expected","(control/$file)"
              unless $interpreter eq $expected;
599 600 601 602 603 604 605 606
        } elsif ($file eq 'config') {
            tag 'forbidden-config-interpreter', "#!$interpreter";
        } elsif ($file eq 'postrm') {
            tag 'forbidden-postrm-interpreter', "#!$interpreter";
        } elsif ($INTERPRETERS->known($base)) {
            my $data = $INTERPRETERS->value($base);
            my $expected = $data->[0] . '/' . $base;
            unless ($interpreter eq $expected) {
607
                tag bad_interpreter_tag_name($expected),
608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629
                  "#!$interpreter != $expected",
                  "(control/$file)";
            }
            tag 'unusual-control-interpreter', "control/$file",
              "#!$interpreter";

            # Interpreters used by preinst scripts must be in
            # Pre-Depends.  Interpreters used by postinst or prerm
            # scripts must be in Depends.
            unless (not $data->[1]) {
                my $depends = Lintian::Relation->new($data->[1]);
                if ($file eq 'preinst') {
                    unless ($info->relation('pre-depends')->implies($depends)){
                        tag 'preinst-interpreter-without-predepends',
                          "#!$interpreter";
                    }
                } else {
                    unless ($info->relation('strong')->implies($depends)) {
                        tag 'control-interpreter-without-depends',
                          "control/$file",
                          "#!$interpreter";
                    }
630 631
                }
            }
632 633 634 635
        } else {
            tag 'unknown-control-interpreter', "control/$file",
              "#!$interpreter";
            next; # no use doing further checks if it's not a known interpreter
636
        }
637

638 639 640 641
        # perhaps we should warn about *csh even if they're somehow screwed,
        # but that's not really important...
        tag 'csh-considered-harmful', "control/$file"
          if ($base eq 'csh' or $base eq 'tcsh');
642

643 644
        next if not $path or not $path->is_open_ok;

645
        my $shellscript = $base =~ /^$known_shells_regex$/ ? 1 : 0;
646

647 648 649 650 651
        # Only syntax-check scripts we can check with bash.
        my $checkbashisms;
        if ($shellscript) {
            $checkbashisms = $base eq 'sh' ? 1 : 0;
            if ($base eq 'sh' or $base eq 'bash') {
652
                if (check_script_syntax("/bin/${base}", $path)) {
653 654
                    tag 'maintainer-shell-script-fails-syntax-check', $file;
                }
655 656
            }
        }
657

658
        # now scan the file contents themselves
659
        my $fd = $path->open;
660

661 662 663 664 665
        my (
            $saw_init, $saw_invoke,
            $saw_debconf,$saw_bange,
            $saw_sete, $has_code,
            $saw_statoverride_list, $saw_statoverride_add,
666
            $saw_udevadm_guard, $saw_update_fonts
667
        );
668 669
        my %warned;
        my $cat_string = '';
670

671
        my $previous_line = '';
672
        my $in_automatic_section = 0;
673 674 675 676
        while (<$fd>) {
            if ($. == 1 && $shellscript && m,/$base\s*.*\s-\w*e\w*\b,) {
                $saw_bange = 1;
            }
677

678 679 680
            if (/\#DEBHELPER\#/) {
                tag 'maintainer-script-has-unexpanded-debhelper-token', $file;
            }
681
            if (/^# Automatically added by (\S+)\s*$/) {
682
                my $dh_cmd = $1;
683 684
                # dh_python puts a trailing ":", remove that.
                $dh_cmd =~ s/:++$//g;
685 686
                tag 'debhelper-autoscript-in-maintainer-scripts', $dh_cmd
                  if not $dh_cmd_substs{$dh_cmd}++;
687
                $in_automatic_section = 1;
688
            }
689 690
            $in_automatic_section = 0
              if $_ eq '# End automatically added section';
691

692 693 694 695 696 697 698 699 700 701 702 703
            next if m,^\s*$,;  # skip empty lines
            next if m,^\s*\#,; # skip comment lines
            $_ = remove_comments($_);

            # Concatenate lines containing continuation character (\)
            # at the end
            if ($shellscript && /\\$/) {
                s/\\//;
                chomp;
                $previous_line .= $_;
                next;
            }
704 705

            chomp;
706 707
            $_ = $previous_line . $_;
            $previous_line = '';
708

709 710 711 712
            # Don't consider the standard dh-make boilerplate to be code.  This
            # means ignoring the framework of a case statement, the labels, the
            # echo complaining about unknown arguments, and an exit.
            unless ($has_code
713 714 715 716 717 718 719
                || m/^\s*set\s+-\w+\s*$/
                || m/^\s*case\s+\"?\$1\"?\s+in\s*$/
                || m/^\s*(?:[a-z|-]+|\*)\)\s*$/
                || m/^\s*[:;]+\s*$/
                || m/^\s*echo\s+\"[^\"]+\"(?:\s*>&2)?\s*$/
                || m/^\s*esac\s*$/
                || m/^\s*exit\s+\d+\s*$/) {
720 721
                $has_code = 1;
            }
722

723 724 725 726
            if ($shellscript
                && m,${LEADIN}set\s*(?:\s+-(?:-.*|[^e]+))*\s-\w*e,) {
                $saw_sete = 1;
            }
727

728 729 730 731 732
            if (m,$LEADIN(?:/usr/bin/)?dpkg-statoverride\s,) {
                $saw_statoverride_add = $. if /--add/;
                $saw_statoverride_list = 1 if /--list/;
            }

733 734 735 736 737 738
            if (m,$LEADIN(?:/usr/bin/)?dpkg-maintscript-helper\s(\S+),) {
                my $cmd = $1;
                $seen_helper_cmds{$cmd} = () unless $seen_helper_cmds{$cmd};
                $seen_helper_cmds{$cmd}{$file} = 1;
            }

739
            $saw_update_fonts = 1
740 741
              if
              m,$LEADIN(?:/usr/bin/)?update-fonts-(?:alias|dir|scale)\s(\S+),;
742

743
            $saw_udevadm_guard = 1 if m/\b(if|which|command)\s+.*udevadm/g;
744 745
            if (m,$LEADIN(?:/bin/)?udevadm\s, and $saw_sete) {
                tag 'udevadm-called-without-guard', "$file:$."
746 747 748
                  unless $saw_udevadm_guard
                  or m/\|\|/
                  or $str_deps->implies('udev');
749 750
            }

751 752 753 754
            if (    m,[^\w](?:(?:/var)?/tmp|\$TMPDIR)/[^)\]}\s],
                and not m/\bmks?temp\b/
                and not m/\btempfile\b/
                and not m/\bmkdir\b/
755
                and not m/\bXXXXXX\b/
756 757 758 759 760 761 762 763 764 765 766 767 768 769 770
                and not m/\$RANDOM/) {
                #<<< no perltidy - tag name too long
                tag 'possibly-insecure-handling-of-tmp-files-in-maintainer-script',
                #>>>
                  "$file:$."
                  unless $warned{tmp};
                $warned{tmp} = 1;
            }
            if (m/^\s*killall(?:\s|\z)/) {
                tag 'killall-is-dangerous', "$file:$." unless $warned{killall};
                $warned{killall} = 1;
            }
            if (m/^\s*mknod(?:\s|\z)/ and not m/\sp\s/) {
                tag 'mknod-in-maintainer-script', "$file:$.";
            }
771

772 773 774 775 776 777 778 779 780
            # Collect information about init script invocations to
            # catch running init scripts directly rather than through
            # invoke-rc.d.  Since the script is allowed to run the
            # init script directly if invoke-rc.d doesn't exist, only
            # tag direct invocations where invoke-rc.d is never used
            # in the same script.  Lots of false negatives, but
            # hopefully not many false positives.
            if (m%^\s*/etc/init\.d/(?:\S+)\s+[\"\']?(?:\S+)[\"\']?%) {
                $saw_init = $.;
781
            }
782 783
            if (m%^\s*invoke-rc\.d\s+%) {
                $saw_invoke = $.;
784
            }
785 786 787 788 789 790 791 792 793 794 795 796

            if ($shellscript) {
                if ($cat_string ne '' and m/^\Q$cat_string\E$/) {
                    $cat_string = '';
                }
                my $within_another_shell = 0;
                if (
                    m{
                      (?:^|\s+)(?:(?:/usr)?/bin/)?
                      ($known_shells_regex)\s+-c\s*.+
                    }xsm
                    and $1 ne 'sh'
797
                ) {
798
                    $within_another_shell = 1;
799
                }
800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816
                # if cat_string is set, we are in a HERE document and need not
                # check for things
                if (   $cat_string eq ''
                    && $checkbashisms
                    && !$within_another_shell) {
                    my $found = 0;
                    my $match = '';

                 # since this test is ugly, I have to do it by itself
                 # detect source (.) trying to pass args to the command it runs
                 # The first expression weeds out '. "foo bar"'
                    if (
                            not $found
                        and not m{\A \s*\.\s+
                                   (?:\"[^\"]+\"|\'[^\']+\')\s*
                                   (?:\&|\||\d?>|<|;|\Z)}xsm
                        and m/^\s*(\.\s+[^\s;\`:]+\s+([^\s;]+))/
817
                    ) {
818 819 820 821 822 823 824 825 826 827

                        my $extra;
                        ($match, $extra) = ($1, $2);
                        if ($extra =~ /^(\&|\||\d?>|<)/) {
                            # everything is ok
                            ;
                        } else {
                            $found = 1;
                        }
                    }
828

829
                    my $line = $_;
830

831 832 833 834 835 836 837
                    unless ($found) {
                        for my $re (@bashism_single_quote_regexs) {
                            if ($line =~ m/($re)/) {
                                $found = 1;
                                ($match) = m/($re)/;
                                last;
                            }
838 839 840
                        }
                    }

841 842 843 844 845 846 847 848 849 850 851 852
                    # Ignore anything inside single quotes; it could be an
                    # argument to grep or the like.

                    # $cat_line contains the version of the line we'll check
                    # for heredoc delimiters later. Initially, remove any
                    # spaces between << and the delimiter to make the following
                    # updates to $cat_line easier.
                    my $cat_line = $line;
                    $cat_line =~ s/(<\<-?)\s+/$1/g;

                    # Remove single quoted strings, with the exception
                    # that we don't remove the string
853
                    # if the quote is immediately preceded by a < or
854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877
                    # a -, so we can match "foo <<-?'xyz'" as a
                    # heredoc later The check is a little more greedy
                    # than we'd like, but the heredoc test itself will
                    # weed out any false positives
                    $cat_line
                      =~ s/(^|[^<\\\"-](?:\\\\)*)\'(?:\\.|[^\\\'])+\'/$1''/g;

                    unless ($found) {
                        # Remove "quoted quotes". They're likely to be
                        # inside another pair of quotes; we're not
                        # interested in them for their own sake and
                        # removing them makes finding the limits of
                        # the outer pair far easier.
                        $line =~ s/(^|[^\\\'\"])\"\'\"/$1/g;
                        $line =~ s/(^|[^\\\'\"])\'\"\'/$1/g;

                        $line
                          =~ s/(^|[^\\\"](?:\\\\)*)\'(?:\\.|[^\\\'])+\'/$1''/g;
                        for my $re (@bashism_string_regexs) {
                            if ($line =~ m/($re)/) {
                                $found = 1;
                                ($match) = m/($re)/;
                                last;
                            }
878 879 880
                        }
                    }

881 882 883 884 885 886 887 888 889 890 891 892 893 894
                    # We've checked for all the things we still want
                    # to notice in double-quoted strings, so now
                    # remove those strings as well.
                    $cat_line
                      =~ s/(^|[^<\\\'-](?:\\\\)*)\"(?:\\.|[^\\\"])+\"/$1""/g;
                    unless ($found) {
                        $line
                          =~ s/(^|[^\\\'](?:\\\\)*)\"(?:\\.|[^\\\"])+\"/$1""/g;
                        for my $re (@bashism_regexs) {
                            if ($line =~ m/($re)/) {
                                $found = 1;
                                ($match) = m/($re)/;
                                last;
                            }
895 896 897
                        }
                    }

898 899 900 901
                    if ($found) {
                        tag 'possible-bashism-in-maintainer-script',
                          "$file:$. \'$match\'";
                    }
902

903 904 905 906 907
                    # Only look for the beginning of a heredoc here,
                    # after we've stripped out quoted material, to
                    # avoid false positives.
                    if ($cat_line
                        =~ m/(?:^|[^<])\<\<\-?\s*(?:[\\]?(\w+)|[\'\"](.*?)[\'\"])/
908
                    ) {
909 910
                        $cat_string = $1;
                        $cat_string = $2 if not defined $cat_string;
911
                    }
912
                }
913
                if (!$cat_string) {
914 915
                    generic_check_bad_command($_, $file, $., $pkg, 0,
                        $in_automatic_section);
916

917 918 919 920 921 922
                    if (m,/usr/share/debconf/confmodule,) {
                        $saw_debconf = 1;
                    }
                    if (m/^\s*read(?:\s|\z)/ && !$saw_debconf) {
                        tag 'read-in-maintainer-script', "$file:$.";
                    }
923

924 925 926 927
                    tag 'multi-arch-same-package-calls-pycompile', "$file:$."
                      if m/^\s*py3?compile(?:\s|\z)/
                      and $info->field('multi-arch', 'no') eq 'same';

928
                    if (m,>\s*/etc/inetd\.conf(?:\s|\Z),) {
929
                        tag 'maintainer-script-modifies-inetd-conf',"$file:$."
930 931 932 933
                          unless $info->relation('provides')
                          ->implies('inet-superserver');
                    }
                    if (m,^\s*(?:cp|mv)\s+(?:.*\s)?/etc/inetd\.conf\s*$,) {
934
                        tag 'maintainer-script-modifies-inetd-conf',"$file:$."
935 936 937
                          unless $info->relation('provides')
                          ->implies('inet-superserver');
                    }
938

939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954
                    # Check for running commands with a leading path.
                    #
                    # Unfortunately, our $LEADIN 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 (m,\`([^\`]+)\`,g) {
                        my $cmd = $1;
                        if (
                            $cmd =~ m{ $LEADIN
                                      (/(?:usr/)?s?bin/[\w.+-]+)
                                      (?:\s|;|\Z)}xsm
955
                        ) {
956
                            tag 'command-with-path-in-maintainer-script',
957 958
                              "$file:$. $1"
                              unless $in_automatic_section;
959 960 961
                        }
                    }
                    my $cmd = $_;
962 963 964 965 966 967
                    # check for test syntax
                    if(
                        $cmd =~ m{\[\s+
                          (?:!\s+)? -x \s+
                          (/(?:usr/)?s?bin/[\w.+-]+)
                          \s+ \]}xsm
968
                    ){
969
                        tag 'command-with-path-in-maintainer-script',
970 971
                          "$file:$. $1"
                          unless $in_automatic_section;
972 973
                    }

974 975 976
                    $cmd =~ s/\`[^\`]+\`//g;
                    if ($cmd =~ m,$LEADIN(/(?:usr/)?s?bin/[\w.+-]+)(?:\s|;|$),)
                    {
977
                        tag 'command-with-path-in-maintainer-script',
978 979
                          "$file:$. $1"
                          unless $in_automatic_section;
980 981 982
                    }
                }
            }
983
            unless ($file eq 'postrm') {
984 985 986 987 988 989 990 991
                for my $rule (@depends_needed) {
                    my ($package, $regex) = @$rule;
                    if (    $pkg ne $package
                        and /$regex/
                        and not $warned{$package}) {
                        if (   m,-x\s+\S*$regex,
                            or m,(?:which|type)\s+$regex,
                            or m,command\s+.*?$regex,) {
992
                            $warned{$package} = 1;
993 994 995 996 997 998 999 1000 1001 1002 1003
                        } elsif (!/\|\|\s*true\b/) {
                            unless (
                                $info->relation('strong')->implies($package)) {
                                my $shortpackage = $package;
                                $shortpackage =~ s/[ \(].*//;
                                #<<< no perltidy - tag name too long
                                tag "maintainer-script-needs-depends-on-$shortpackage",
                                #>>>
                                  $file;
                                $warned{$package} = 1;
                            }
1004 1005 1006 1007
                        }
                    }
                }
            }
1008

1009 1010
            generic_check_bad_command($_, $file, $., $pkg, 1,
                $in_automatic_section);
1011

1012 1013 1014
            for my $ver (sort keys %old_versions) {
                next if $ver =~ /^\d+$/;
                #<<< no perltidy
1015
                if (m,$LEADIN(?:/usr/bin/)?dpkg\s+--compare-versions\s+.*\b\Q$ver\E(?!\.)\b,) {
1016 1017
                    my $date = strftime('%Y-%m-%d', gmtime $old_versions{$ver});
                    my $epoch = strftime('%Y-%m-%d', gmtime $OLDSTABLE_RELEASE);
1018
                    tag 'maintainer-script-supports-ancient-package-version',
1019
                      "$file:$.", $ver, "($date < $epoch)";
1020 1021 1022 1023 1024
                    last;
                }
                #>>>
            }

1025 1026 1027 1028 1029 1030 1031 1032 1033
            if (m,$LEADIN(?:/usr/sbin/)?update-inetd\s,) {
                tag 'maintainer-script-has-invalid-update-inetd-options',
                  "$file:$.", '(--pattern with --add)'
                  if /--pattern/ && /--add/;
                tag 'maintainer-script-has-invalid-update-inetd-options',
                  "$file:$.", '(--group without --add)'
                  if /--group/ && !/--add/;
            }

1034 1035 1036 1037 1038
            my $pdepends = $info->relation('pre-depends');
            tag 'skip-systemd-native-flag-missing-pre-depends', "$file:$."
              if m/invoke-rc.d\b.*--skip-systemd-native\b/
              && !$pdepends->implies('init-system-helpers (>= 1.54~)');

1039 1040 1041 1042 1043 1044
            my $depends = $info->relation('depends');
            tag 'missing-versioned-depends-on-init-system-helpers',
              "$file:$.", "\"$1 $2\" needs init-system-helpers >= 1.50"
              if m/(update-rc\.d)\b.*(defaults-disabled)\b/
              && !$depends->implies('init-system-helpers (>= 1.50)');

1045 1046 1047 1048 1049 1050 1051
            if (m,$LEADIN(?:/usr/sbin/)?dpkg-divert\s,
                && !/--(?:help|list|truename|version)/) {
                if (/--local/) {
                    tag 'package-uses-local-diversion', "$file:$.";
                }
                my $mode = /--remove/ ? 'remove' : 'add';
                my ($divert) = /dpkg-divert\s*(.*)$/;
1052
                $divert =~ s{\s*(?:\$[{]?[\w:=-]+[}]?)*\s*
1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067
                                # options without arguments
                              --(?:add|quiet|remove|rename|test|local
                                # options with arguments
                                |(?:admindir|divert|package) \s+ \S+)
                              \s*}{}gxsm;
                # Remove unpaired opening or closing parenthesis
                1 while ($divert =~ m/\G.*?\(.+?\)/gc);
                $divert =~ s/\G(.*?)[()]/$1/;
                pos($divert) = undef;
                # Remove unpaired opening or closing braces
                1 while ($divert =~ m/\G.*?{.+?}/gc);
                $divert =~ s/\G(.*?)[{}]/$1/;
                pos($divert) = undef;

                # position after the last pair of quotation marks, if any
1068
                1 while ($divert =~ m/\G.*?(["']).+?\1/gc);
1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087
                # Strip anything matching and after '&&', '||', ';', or '>'
                # this is safe only after we are positioned after the last pair
                # of quotation marks
                $divert =~ s/\G.+?\K(?: && | \|\| | ; | \d*> ).*$//x;
                pos($divert) = undef;
                # Remove quotation marks, they affect:
                # * our var to regex trick
                # * stripping the initial slash if the path was quoted
                $divert =~ s/[\"\']//g;
                # remove the leading / because it's not in the index hash
                $divert =~ s,^/,,;

                # remove any remaining leading or trailing whitespace.
                strip($divert);

                $divert = quotemeta($divert);

                # For now just replace variables, they will later be normalised
                $expand_diversions = 1 if $divert =~ s/\\\$\w+/.+/g;
bastien's avatar
bastien committed
1088 1089
                $expand_diversions = 1
                  if $divert =~ s/\\\$\\[{]\w+.*?\\[}]/.+/g;
1090 1091 1092 1093 1094 1095 1096 1097 1098 1099
                # handle $() the same way:
                $expand_diversions = 1 if $divert =~ s/\\\$\\\(.+?\\\)/.+/g;

                if ($mode eq 'add') {
                    $added_diversions{$divert}
                      = {'script' => $file, 'line' => $.};
                } elsif ($mode eq 'remove') {
                    push @{$removed_diversions{$divert}},
                      {'script' => $file, 'line' => $.};
                } else {
1100
                    internal_error("\$mode has unknown value: $mode");
1101 1102
                }
            }
1103
        }
1104

1105 1106 1107 1108 1109
        foreach my $font (@x11_fonts) {
            tag 'missing-call-to-update-fonts', $font
              if $file eq 'postinst' and not $saw_update_fonts;
        }

1110 1111 1112
        if ($saw_init && !$saw_invoke) {
            tag 'maintainer-script-calls-init-script-directly',
              "$file:$saw_init";
1113
        }
1114 1115
        unless ($has_code) {
            tag 'maintainer-script-empty', $file;
1116
        }
1117 1118 1119
        if ($shellscript && !$saw_sete) {
            if ($saw_bange) {
                tag 'maintainer-script-without-set-e', $file;
1120
            } else {
1121
                tag 'maintainer-script-ignores-errors', $file;
1122 1123
            }
        }
1124

1125 1126 1127 1128 1129
        if ($saw_statoverride_add && !$saw_statoverride_list) {
            tag 'unconditional-use-of-dpkg-statoverride',
              "$file:$saw_statoverride_add";
        }

1130
        close($fd);
1131

1132 1133
    }
    close($ctrl_fd);
1134

1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145
    for my $cmd (qw(rm_conffile mv_conffile symlink_to_dir)) {
        next unless $seen_helper_cmds{$cmd};

        # dpkg-maintscript-helper(1) recommends the snippets are in all
        # maintainer scripts but they are not strictly required in prerm.
        for my $file (qw(preinst postinst postrm)) {
            tag 'missing-call-to-dpkg-maintscript-helper', "$file ($cmd)"
              unless $seen_helper_cmds{$cmd}{$file};
        }
    }

1146 1147 1148 1149
    # If any of the maintainer scripts used a variable in the file or
    # diversion name normalise them all
    if ($expand_diversions) {
        for my $divert (keys %removed_diversions, keys %added_diversions) {
1150

1151 1152 1153 1154
            # if a wider regex was found, the entries might no longer be there
            unless (exists($removed_diversions{$divert})
                or exists($added_diversions{$divert})) {
                next;
1155 1156
            }

1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176
            my $widerrx = $divert;
            my $wider = $widerrx;
            $wider =~ s/\\//g;

            # find the widest regex:
            my @matches = grep {
                my $lrx = $_;
                my $l = $lrx;
                $l =~ s/\\//g;

                if ($wider =~ m/^$lrx$/) {
                    $widerrx = $lrx;
                    $wider = $l;
                    1;
                } elsif ($l =~ m/^$widerrx$/) {
                    1;
                } else {
                    0;
                }
            } (keys %removed_diversions, keys %added_diversions);
1177

Jakub Wilk's avatar
Jakub Wilk committed
1178
            # replace all the occurrences with the widest regex:
1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189
            for my $k (@matches) {
                next if ($k eq $widerrx);

                if (exists($removed_diversions{$k})) {
                    $removed_diversions{$widerrx} = $removed_diversions{$k};
                    delete $removed_diversions{$k};
                }
                if (exists($added_diversions{$k})) {
                    $added_diversions{$widerrx} = $added_diversions{$k};
                    delete $added_diversions{$k};
                }
1190 1191
            }
        }
1192 1193
    }

1194 1195 1196 1197 1198 1199 1200 1201 1202 1203
    for my $divert (keys %removed_diversions) {
        if (exists $added_diversions{$divert}) {
            # just mark the entry, because a --remove might
            # happen in two branches in the script, i.e. we
            # see it twice, which is not a bug
            $added_diversions{$divert}{'removed'} = 1;
        } else {
            for my $item (@{$removed_diversions{$divert}}) {
                my $script = $item->{'script'};
                my $line = $item->{'line'};
1204

1205
                next unless ($script eq 'postrm');
1206

1207 1208 1209
                # Allow preinst and postinst to remove diversions the
                # package doesn't add to clean up after previous
                # versions of the package.
1210

1211
                $divert = unquote($divert, $expand_diversions);
1212

1213 1214
                tag 'remove-of-unknown-diversion', $divert, "$script:$line";
            }
1215
        }
1216 1217
    }

1218 1219 1220
    for my $divert (keys %added_diversions) {
        my $script = $added_diversions{$divert}{'script'};
        my $line = $added_diversions{$divert}{'line'};
1221

1222 1223
        my $divertrx = $divert;
        $divert = unquote($divert, $expand_diversions);
1224

1225 1226 1227
        if (not exists $added_diversions{$divertrx}{'removed'}) {
            tag 'orphaned-diversion', $divert, $script;
        }
1228

1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244
        # Handle man page diversions somewhat specially.  We may
        # divert away a man page in one section without replacing that
        # same file, since we're installing a man page in a different
        # section.  An example is diverting a man page in section 1
        # and replacing it with one in section 1p (such as
        # libmodule-corelist-perl at the time of this writing).
        #
        # Deal with this by turning all man page diversions into
        # wildcard expressions instead that match everything in the
        # same numeric section so that they'll match the files shipped
        # in the package.
        if ($divertrx =~ m,^(usr\\/share\\/man\\/\S+\\/.*\\\.\d)\w*(\\\.gz\z),)
        {
            $divertrx = "$1.*$2";
            $expand_diversions = 1;
        }
1245

1246 1247 1248 1249 1250 1251 1252
        if ($expand_diversions) {
            tag 'diversion-for-unknown-file', $divert, "$script:$line"
              unless (any { $_ =~ m/$divertrx/ } $info->sorted_index);
        } else {
            tag 'diversion-for-unknown-file', $divert, "$script:$line"
              unless $info->index($divert);
        }
1253
    }
1254

1255
    return;
Jeroen van Wolffelaar's avatar
Jeroen van Wolffelaar committed
1256
}
1257 1258 1259

# -----------------------------------

1260 1261
# try generic bad maintainer script command tagging
sub generic_check_bad_command {
1262 1263
    my ($line, $file, $lineno, $pkg, $findincatstring, $in_automatic_section)
      = @_;
1264
    # try generic bad maintainer script command tagging
1265
  BAD_CMD:
1266
    foreach my $bad_cmd_tag ($BAD_MAINT_CMD->all) {
1267 1268
        my $bad_cmd_data = $BAD_MAINT_CMD->value($bad_cmd_tag);
        my $inscript = $bad_cmd_data->{'in_script'};
1269 1270 1271
        next
          if $in_automatic_section
          and $bad_cmd_data->{'ignore_automatically_added'};
1272
        my $incat;
1273 1274 1275
        if ($file !~ m{$inscript}) {
            next BAD_CMD;
        }
1276
        $incat = $bad_cmd_data->{'in_cat_string'};
1277
        if ($incat == $findincatstring) {
1278
            my $regex = $bad_cmd_data->{'regexp'};
1279
            if ($line =~ m{$regex}) {
1280
                my $extrainfo = defined($1) ? "\'$1\'" : '';
1281
                my $inpackage = $bad_cmd_data->{'in_package'};
1282
                unless($pkg =~ m{$inpackage}) {
1283
                    tag $bad_cmd_tag, "$file:$lineno", $extrainfo;
1284
                }
1285 1286 1287
            }
        }
    }
1288
    return;
1289 1290
}

Jari Aalto's avatar
Jari Aalto committed
1291
# Returns non-zero if the given file is not actually a shell script,
1292 1293
# just looks like one.
sub script_is_evil_and_wrong {
1294
    my ($path) = @_;
1295 1296
    my $ret = 0;
    my $i = 0;
1297
    my $var = '0';
1298
    my $backgrounded = 0;
1299
    my $fd = $path->open;
Russ Allbery's avatar
Russ Allbery committed
1300
    local $_;
1301
    while (<$fd>) {
1302 1303 1304 1305
        chomp;
        next if m/^#/o;
        next if m/^$/o;
        last if (++$i > 55);
1306 1307
        if (
            m~
Frank Lichtenheld's avatar
Frank Lichtenheld committed
1308
            # the exec should either be "eval"ed or a new statement
1309
            (?:^\s*|\beval\s*[\'\"]|(?:;|&&|\b(?:then|else))\s*)
Frank Lichtenheld's avatar
Frank Lichtenheld committed
1310 1311 1312 1313 1314 1315 1316 1317

            # eat anything between the exec and $0
            exec\s*.+\s*

            # optionally quoted executable name (via $0)
            .?\$$var.?\s*

            # optional "end of options" indicator
1318
            (?:--\s*)?
Frank Lichtenheld's avatar
Frank Lichtenheld committed
1319 1320 1321 1322 1323 1324 1325 1326 1327

            # Match expressions of the form '${1+$@}', '${1:+"$@"',
            # '"${1+$@', "$@", etc where the quotes (before the dollar
            # sign(s)) are optional and the second (or only if the $1
            # clause is omitted) parameter may be $@ or $*.
            #
            # Finally the whole subexpression may be omitted for scripts
            # which do not pass on their parameters (i.e. after re-execing
            # they take their parameters (and potentially data) from stdin
1328
            .?(?:\$[{]1:?\+.?)?(?:\$[\@\*])?~x
1329
        ) {
1330 1331 1332 1333
            $ret = 1;
            last;
        } elsif (/^\s*(\w+)=\$0;/) {
            $var = $1;
1334 1335
        } elsif (
            m~
1336 1337 1338 1339 1340 1341
            # Match scripts which use "foo $0 $@ &\nexec true\n"
            # Program name
            \S+\s+

            # As above
            .?\$$var.?\s*
1342
            (?:--\s*)?
1343
            .?(?:\$[{]1:?\+.?)?(?:\$[\@\*])?.?\s*\&~x
1344
        ) {
1345 1346

            $backgrounded = 1;
1347 1348 1349
        } elsif (
            $backgrounded
            and m~
1350
            # the exec should either be "eval"ed or a new statement
1351
            (?:^\s*|\beval\s*[\'\"]|(?:;|&&|\b(?:then|else))\s*)
1352
            exec\s+true(?:\s|\Z)~x
1353
        ) {
1354 1355 1356 1357

            $ret = 1;
            last;
        }
1358
    }
1359
    close($fd);
1360 1361
    return $ret;
}
Jeroen van Wolffelaar's avatar
Jeroen van Wolffelaar committed
1362

Ron Lee's avatar
Ron Lee committed
1363
# Given an interpreter and a file, run the interpreter on that file with the
1364 1365
# -n option to check syntax, discarding output and returning the exit status.
sub check_script_syntax {
1366 1367
    my ($interpreter, $path) = @_;
    my $fs_path = $path->fs_path;
1368
    my $pid = do_fork();
1369 1370 1371
    if ($pid == 0) {
        open(STDOUT, '>', '/dev/null');
        open(STDERR, '>&', \*STDOUT);
1372
        exec $interpreter, '-n', $fs_path
1373
          or internal_error("cannot exec $interpreter: $!");
1374
    } else {
1375
        waitpid $pid, 0;
1376 1377 1378 1379
    }
    return $?;
}