vcs.maemo.org Git - maemian/blob - nokia-lintian/checks/scripts

   1 # scripts -- lintian check script -*- perl -*-
   2 #
   3 # This is probably the right file to add a check for the use of
   4 # set -e in bash and sh scripts.
   5 #
   6 # Copyright (C) 1998 Richard Braakman
   7 # Copyright (C) 2002 Josip Rodin
   8 #
   9 # This program is free software; you can redistribute it and/or modify
  10 # it under the terms of the GNU General Public License as published by
  11 # the Free Software Foundation; either version 2 of the License, or
  12 # (at your option) any later version.
  13 #
  14 # This program is distributed in the hope that it will be useful,
  15 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 # GNU General Public License for more details.
  18 #
  19 # You should have received a copy of the GNU General Public License
  20 # along with this program.  If not, you can find it on the World Wide
  21 # Web at http://www.gnu.org/copyleft/gpl.html, or write to the Free
  22 # Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
  23 # MA 02110-1301, USA.
  24
  25 package Lintian::scripts;
  26 use strict;
  27 use Dep;
  28 use Tags;
  29 use Util;
  30
  31 # This is a map of all known interpreters.  The key is the interpreter name
  32 # (the binary invoked on the #! line).  The value is an anonymous array of one
  33 # or two elements.  The first, mandatory argument is the path on a Debian
  34 # system where that interpreter would be installed.  The second, optional
  35 # argument is the dependency that provides that interpreter.  If the second
  36 # argument isn't given, the package name is assumed to be the same as the
  37 # interpreter name.  (Saves some typing.)
  38 #
  39 # Some interpreters list empty dependencies (as opposed to undefined ones).
  40 # Those interpreters should not have any dependency for one reason or another
  41 # (usually because they're essential packages or aren't used in a normal way).
  42 #
  43 # Do not list versioned patterns here (such as pythonX.Y, rubyX.Y, etc.).  For
  44 # those, see %versioned_interpreters below.
  45 our %interpreters =
  46     (ash            => [ '/bin' ],
  47      awk            => [ '/usr/bin', '' ],
  48      bash           => [ '/bin', '' ],
  49      bltwish        => [ '/usr/bin', 'blt' ],
  50      clisp          => [ '/usr/bin' ],
  51      csh            => [ '/bin', 'tcsh | csh | c-shell' ],
  52      dash           => [ '/bin' ],
  53      expect         => [ '/usr/bin' ],
  54      expectk        => [ '/usr/bin' ],
  55      fish           => [ '/usr/bin' ],
  56      gawk           => [ '/usr/bin' ],
  57      gbr2           => [ '/usr/bin', 'gambas2-runtime' ],
  58      gbx            => [ '/usr/bin', 'gambas-runtime' ],
  59      gbx2           => [ '/usr/bin', 'gambas2-runtime' ],
  60      gforth         => [ '/usr/bin' ],
  61      gnuplot        => [ '/usr/bin' ],
  62      gosh           => [ '/usr/bin', 'gauche' ],
  63      'install-menu' => [ '/usr/bin', '' ],
  64      jed            => [ '/usr/bin' ],
  65      'jed-script'   => [ '/usr/bin', 'jed | xjed' ],
  66      kaptain        => [ '/usr/bin' ],
  67      ksh            => [ '/bin', 'mksh | pdksh' ],
  68      lefty          => [ '/usr/bin', 'graphviz' ],
  69      magicfilter    => [ '/usr/sbin' ],
  70      make           => [ '/usr/bin', 'make | build-essential' ],
  71      mawk           => [ '/usr/bin' ],
  72      ocamlrun       => [ '/usr/bin',
  73                          'ocaml-base-nox | ocaml-base | ocaml-nox | ocaml' ],
  74      pagsh          => [ '/usr/bin', 'openafs-client | heimdal-clients' ],
  75      parrot         => [ '/usr/bin' ],
  76      perl           => [ '/usr/bin', '' ],
  77      procmail       => [ '/usr/bin' ],
  78      python         => [ '/usr/bin', 'python | python-minimal' ],
  79      pforth         => [ '/usr/bin' ],
  80      rc             => [ '/usr/bin' ],
  81      regina         => [ '/usr/bin', 'regina-rexx' ],
  82      rexx           => [ '/usr/bin', 'regina-rexx' ],
  83      rrdcgi         => [ '/usr/bin', 'rrdtool' ],
  84      ruby           => [ '/usr/bin' ],
  85      runhugs        => [ '/usr/bin', 'hugs | hugs98' ],
  86      sed            => [ '/bin', '' ],
  87      sh             => [ '/bin', '' ],
  88      slsh           => [ '/usr/bin' ],
  89      speedy         => [ '/usr/bin', 'speedy-cgi-perl' ],
  90      tcsh           => [ '/usr/bin' ],
  91      tixwish        => [ '/usr/bin', 'tix' ],
  92      trs            => [ '/usr/bin', 'konwert' ],
  93      xjed           => [ '/usr/bin', 'xjed' ],
  94      yforth         => [ '/usr/bin', 'yforth' ],
  95      yorick         => [ '/usr/bin' ],
  96      zsh            => [ '/bin', 'zsh | zsh-beta' ],
  97     );
  98
  99 # The more complex case of interpreters that may have a version number.
 100 #
 101 # This is a hash from the base interpreter name to a list.  The base
 102 # interpreter name may appear by itself or followed by some combination of
 103 # dashes, digits, and periods.  The values are the directory in which the
 104 # interpreter is found, the dependency to add for a version-less interpreter,
 105 # a regular expression to match versioned interpreters and extract the version
 106 # number, the package dependency for a versioned interpreter, and the list of
 107 # known versions.
 108 #
 109 # An interpreter with a version must have a dependency on the specific package
 110 # formed by taking the fourth element of the list and replacing $1 with the
 111 # version number.  An interpreter without a version is rejected if the second
 112 # element is undef; otherwise, the package must depend on the disjunction of
 113 # the second argument (if non-empty) and all the packages formed by taking the
 114 # list of known versions (the fifth element and on) and replacing $1 in the
 115 # fourth argument with them.
 116 #
 117 # For example:
 118 #
 119 #    lua => [ '/usr/bin', 'lua', qr/^lua([\d.]+)$/, 'lua$1', qw(40 50 5.1) ]
 120 #
 121 # says that any lua interpreter must be in /usr/bin, a package using
 122 # /usr/bin/lua50 must depend on lua50, and a package using just /usr/bin/lua
 123 # must satisfy lua | lua40 | lusa50 | lua5.1.
 124 #
 125 # The list of known versions is the largest maintenance headache here, but
 126 # it's only used for the unversioned dependency handling, and then only when
 127 # someone uses the unversioned script but depends on a specific version for
 128 # some reason.  So it's not a huge problem if it's a little out of date.
 129 our %versioned_interpreters =
 130     (guile   => [ '/usr/bin', 'guile',
 131                   qr/^guile-([\d.]+)$/, 'guile-$1', qw(1.6 1.8)
 132                 ],
 133      jruby   => [ '/usr/bin', undef,
 134                   qr/^jruby([\d.]+)$/, 'jruby$1', qw(0.9 1.0)
 135                 ],
 136      lua     => [ '/usr/bin', 'lua',
 137                   qr/^lua([\d.]+)$/, 'lua$1', qw(40 50 5.1)
 138                 ],
 139      octave  => [ '/usr/bin', 'octave',
 140                   qr/^octave([\d.]+)$/, 'octave$1', qw(2.1 2.9 3.0)
 141                 ],
 142      php     => [ '/usr/bin', '',
 143                   qr/^php(\d+)$/, 'php$1-cli', qw(4 5)
 144                 ],
 145      pike    => [ '/usr/bin', '',
 146                   qr/^pike([\d.]+)$/, 'pike$1 | pike$1-core', qw(7.6 7.7)
 147                 ],
 148      python  => [ '/usr/bin', undef,
 149                   qr/^python([\d.]+)$/, 'python$1 | python$1-minimal',
 150                   qw(2.4 2.5)
 151                 ],
 152      ruby    => [ '/usr/bin', undef,
 153                   qr/^ruby([\d.]+)$/, 'ruby$1', qw(1.8 1.9)
 154                 ],
 155      scsh    => [ '/usr/bin', 'scsh',
 156                   qr/^scsh-([\d.]+)$/, 'scsh-$1', qw(0.6)
 157                 ],
 158      tclsh   => [ '/usr/bin', 'tclsh | tcl',
 159                   qr/^tclsh([\d.]+)$/, 'tcl$1', qw(8.3 8.4 8.5)
 160                 ],
 161      wish    => [ '/usr/bin', 'wish | tk',
 162                   qr/^wish([\d.]+)$/, 'tk$1', qw(8.3 8.4 8.5)
 163                 ],
 164     );
 165
 166 # Any of the following packages can satisfy an update-inetd dependency.
 167 our $update_inetd
 168     = join (' | ', qw(update-inetd inet-superserver openbsd-inetd
 169                       inetutils-inetd rlinetd xinetd));
 170
 171 # Appearance of one of these regexes in a maintainer script means that there
 172 # must be a dependency (or pre-dependency) on the given package.  The tag
 173 # reported is maintainer-script-needs-depends-on-%s, so be sure to update
 174 # scripts.desc when adding a new rule.
 175 our @depends_needed = (
 176         [ adduser       => '\badduser\b'           ],
 177         [ gconf2        => '\bgconf-schemas\b'     ],
 178         [ $update_inetd => '\bupdate-inetd\b'      ],
 179         [ ucf           => '\bucf\s'               ],
 180         [ 'xml-core'    => '\bupdate-xmlcatalog\b' ],
 181 );
 182
 183 sub run {
 184
 185 my %executable = ();
 186 my %suid = ();
 187 my %ELF = ();
 188 my %scripts = ();
 189 my %deps = ();
 190
 191 # no dependency for install-menu, because the menu package specifically
 192 # says not to depend on it.
 193
 194 my $pkg = shift;
 195 my $type = shift;
 196
 197 open(INDEX, '<', "index") or fail("cannot open lintian index file: $!");
 198 while (<INDEX>) {
 199     next unless (m/^-[rw-]*[xs]/);
 200     chop;
 201     s/ link to .*//;
 202     my $is_suid = m/^-[rw-]*s/;
 203     $executable{(split(' ', $_, 6))[5]} = 1;
 204     $suid{(split(' ', $_, 6))[5]} = $is_suid;
 205 }
 206 close(INDEX);
 207
 208 # Urgle... this is ambiguous, since the sequence ": " can occur in
 209 # the output of file and also in the filename.
 210 # Fortunately no filenames containing ": " currently occur in Debian packages.
 211 open(FILEINFO, '<', "file-info")
 212     or fail("cannot open lintian file-info file: $!");
 213 while (<FILEINFO>) {
 214     m/^(.*?): (.*)/ or fail("bad line in file-info: $_");
 215     my $file = $1;
 216     $ELF{$file} = 1 if $2 =~ /^[^,]*\bELF\b/o;
 217 }
 218 close(FILEINFO);
 219
 220 my $all_deps = '';
 221 for my $field (qw/suggests recommends depends pre-depends provides/) {
 222     $deps{$field} = '';
 223     if (open(IN, '<', "fields/$field")) {
 224         $_ = join('', <IN>);
 225         close(IN);
 226         chomp;
 227         $deps{$field} = $_;
 228         $all_deps .= ', ' if $all_deps;
 229         $all_deps .= $_;
 230     }
 231     $deps{$field} = Dep::parse($deps{$field});
 232 }
 233 $all_deps .= ', ' if $all_deps;
 234 $all_deps .= $pkg;
 235 $deps{all} = Dep::parse($all_deps);
 236
 237 open(SCRIPTS, '<', "scripts") or fail("cannot open lintian scripts file: $!");
 238 while (<SCRIPTS>) {
 239     chop;
 240
 241     # This used to be split(' ', $_, 2), but that didn't handle empty
 242     # interpreter lines correctly.
 243     my ($calls_env, $interpreter, $filename) = m/^(env )?(\S*) (.*)$/ or
 244          fail("bad line in scripts file: $_");
 245
 246     $scripts{$filename} = 1;
 247
 248     # no checks necessary at all for scripts in /usr/share/doc/
 249     next if $filename =~ m,usr/share/doc/,;
 250
 251     my ($base) = $interpreter =~ m,([^/]*)$,;
 252
 253     # allow exception for .in files that have stuff like #!@PERL@
 254     next if ($filename =~ m,\.in$, and $interpreter =~ m,^(\@|<\<)[A-Z_]+(\@|>\>)$,);
 255
 256     my $is_absolute = ($interpreter =~ m,^/, or defined $calls_env);
 257
 258     # Skip files that have the #! line, but are not executable and do not have
 259     # an absolute path and are not in a bin/ directory (/usr/bin, /bin etc)
 260     # They are probably not scripts after all.
 261     next if ($filename !~ m,(bin/|etc/init.d/), and !$executable{$filename}
 262              and !$is_absolute);
 263
 264     if ($interpreter eq "") {
 265         tag("script-without-interpreter", $filename);
 266         next;
 267     }
 268
 269     # Either they use an absolute path or they use '/usr/bin/env interp'.
 270     tag("interpreter-not-absolute", $filename, "#!$interpreter")
 271         unless $is_absolute;
 272     tag("script-not-executable", $filename)
 273         unless ($executable{$filename}
 274                 or $filename =~ m,^\./usr/(lib|share)/.*\.pm,
 275                 or $filename =~ m,^\./usr/(lib|share)/.*\.py,
 276                 or $filename =~ m,^\./usr/(lib|share)/ruby/.*\.rb,
 277                 or $filename =~ m,\.in$,
 278                 or $filename =~ m,\.ex$,
 279                 or $filename eq './etc/init.d/skeleton'
 280                 or $filename =~ m,^\./etc/menu-methods,
 281                 or $filename =~ m,^\./etc/X11/Xsession.d,);
 282
 283     # Warn about csh scripts.
 284     tag("csh-considered-harmful", $filename)
 285         if (($base eq 'csh' or $base eq 'tcsh')
 286             and $executable{$filename}
 287             and $filename !~ m,^./etc/csh/login.d/,);
 288
 289     # Syntax-check most shell scripts, but don't syntax-check scripts that end
 290     # in .dpatch.  bash -n doesn't stop checking at exit 0 and goes on to blow
 291     # up on the patch itself.
 292     # zsh -n is broken, see #485885
 293     if ($base =~ /^(?:(?:b|d)?a|k)?sh$/) {
 294         if (-x "$interpreter" && ! script_is_evil_and_wrong("unpacked/$filename")) {
 295             if ($filename !~ m,\.dpatch$,) {
 296                 if (check_script_syntax($interpreter, "unpacked/$filename")) {
 297                     tag("shell-script-fails-syntax-check", $filename);
 298                 }
 299             }
 300         }
 301     }
 302
 303     # Try to find the expected path of the script to check.  First check
 304     # %interpreters and %versioned_interpreters.  If not found there, see if
 305     # it ends in a version number and the base is found in
 306     # %versioned_interpreters.
 307     my $data = $interpreters{$base};
 308     my $versioned = 0;
 309     if (not defined $data) {
 310         $data = $versioned_interpreters{$base};
 311         undef $data if ($data and not defined ($data->[1]));
 312         if (not defined ($data) and $base =~ /^(.*[^\d.-])-?[\d.]+$/) {
 313             $data = $versioned_interpreters{$1};
 314             undef $data unless ($data and $base =~ /$data->[2]/);
 315         }
 316         $versioned = 1 if $data;
 317     }
 318     if ($data) {
 319         my $expected = $data->[0] . '/' . $base;
 320         unless ($interpreter eq $expected or defined $calls_env) {
 321             tag("wrong-path-for-interpreter",
 322                 "#!$interpreter != $expected", "($filename)");
 323         }
 324     } elsif ($interpreter =~ m,/usr/local/,) {
 325         tag("interpreter-in-usr-local", $filename, "#!$interpreter");
 326     } elsif ($executable{'.' . $interpreter}) {
 327         # Package installs the interpreter itself, so it's probably ok.  Don't
 328         # emit any tag for this.
 329     } elsif ($base eq 'suidperl') {
 330         tag("calls-suidperl-directly", $filename);
 331     } elsif ($interpreter eq '/bin/env') {
 332         tag("script-uses-bin-env", $filename);
 333     } else {
 334         tag("unusual-interpreter", $filename, "#!$interpreter");
 335     }
 336
 337     # If we found the interpreter and the script is executable, check
 338     # dependencies.  This should be the last thing we do in the loop so that
 339     # we can use next for an early exit and reduce the nesting.
 340     next unless ($data && $executable{$filename});
 341     if (!$versioned) {
 342         my $depends = $data->[1];
 343         if (not defined $depends) {
 344             $depends = $base;
 345         }
 346         if ($depends && !Dep::implies($deps{all}, Dep::parse($depends))) {
 347             if ($base =~ /^(python|ruby|(m|g)awk)$/) {
 348                 tag("$base-script-but-no-$base-dep", $filename);
 349             } elsif ($base eq 'csh' && $filename =~ m,^\./etc/csh/login.d/,) {
 350                 # Initialization files for csh.
 351             } elsif ($base eq 'fish' && $filename =~ m,^./etc/fish.d/,) {
 352                 # Initialization files for fish.
 353             } else {
 354                 tag('missing-dep-for-interpreter', "$base => $depends",
 355                     "($filename)");
 356             }
 357         }
 358         if ($base eq 'perl' && $suid{$filename}) {
 359             tag("suid-perl-script-but-no-perl-suid-dep", $filename)
 360                 unless Dep::implies($deps{all}, Dep::parse('perl-suid'));
 361         }
 362     } elsif ($versioned_interpreters{$base}) {
 363         my @versions = @$data[4 .. @$data - 1];
 364         my @depends = map {
 365             my $d = $data->[3];
 366             $d =~ s/\$1/$_/g;
 367             $d;
 368         } @versions;
 369         my $depends = join (' | ', $data->[1], @depends);
 370         unless (Dep::implies($deps{all}, Dep::parse($depends))) {
 371             if ($base eq 'php') {
 372                 tag('php-script-but-no-phpX-cli-dep', $filename);
 373             } elsif ($base =~ /^(wish|tclsh)/) {
 374                 tag("$1-script-but-no-$1-dep", $filename);
 375             } else {
 376                 tag("missing-dep-for-interpreter", "$base => $depends",
 377                     "($filename)");
 378             }
 379         }
 380     } else {
 381         my ($version) = ($base =~ /$data->[2]/);
 382         my $depends = $data->[3];
 383         $depends =~ s/\$1/$version/g;
 384         unless (Dep::implies($deps{all}, Dep::parse($depends))) {
 385             if ($base =~ /^php/) {
 386                 tag('php-script-but-no-phpX-cli-dep', $filename);
 387             } elsif ($base =~ /^(python|ruby)/) {
 388                 tag("$1-script-but-no-$1-dep", $filename);
 389             } else {
 390                 tag("missing-dep-for-interpreter", "$base => $depends",
 391                     "($filename)");
 392             }
 393         }
 394     }
 395 }
 396 close(SCRIPTS);
 397
 398 foreach (keys %executable) {
 399     tag("executable-not-elf-or-script", $_)
 400         unless ( $ELF{$_}
 401                  or $scripts{$_}
 402                  or $_ =~ m,^usr(/X11R6)?/man/,
 403                  or $_ =~ m/\.exe$/ # mono convention
 404                  );
 405 }
 406
 407 open(SCRIPTS, '<', "control-scripts")
 408     or fail("cannot open lintian control-scripts file: $!");
 409
 410 # Handle control scripts.  This is an edited version of the code for
 411 # normal scripts above, because there were just enough differences to
 412 # make a shared function awkward.
 413
 414 while (<SCRIPTS>) {
 415     chop;
 416
 417     m/^(\S*) (.*)$/ or fail("bad line in control-scripts file: $_");
 418     my $interpreter = $1;
 419     my $file = $2;
 420     my $filename = "control/$file";
 421
 422     $interpreter =~ m|([^/]*)$|;
 423     my $base = $1;
 424
 425     if ($interpreter eq "") {
 426         tag("script-without-interpreter", $filename);
 427         next;
 428     }
 429
 430     tag("interpreter-not-absolute", $filename, "#!$interpreter")
 431         unless ($interpreter =~ m|^/|);
 432
 433     if (exists $interpreters{$base}) {
 434         my $data = $interpreters{$base};
 435         my $expected = $data->[0] . '/' . $base;
 436         tag("wrong-path-for-interpreter", "#!$interpreter != $expected",
 437             "($filename)")
 438             unless ($interpreter eq $expected);
 439         unless ($base eq 'sh' or $base eq 'bash' or $base eq 'perl') {
 440             my $tag;
 441             if ($file eq 'config') {
 442                 $tag = 'forbidden-config-interpreter';
 443             } else {
 444                 $tag = 'unusual-control-interpreter';
 445             }
 446             tag($tag, "#!$interpreter");
 447         }
 448         unless (defined ($data->[1]) and not $data->[1]) {
 449             my $depends = $data->[1] || $base;
 450             unless (Dep::implies($deps{'pre-depends'}, Dep::parse($depends))) {
 451                 tag("interpreter-without-predep", $filename, "#!$interpreter");
 452             }
 453         }
 454     } elsif ($interpreter =~ m|/usr/local/|) {
 455         tag("interpreter-in-usr-local", $filename, "#!$interpreter");
 456     } else {
 457         tag("unusual-interpreter", $filename, "#!$interpreter");
 458         next; # no use doing further checks if it's not a known interpreter
 459     }
 460
 461     # perhaps we should warn about *csh even if they're somehow screwed,
 462     # but that's not really important...
 463     tag("csh-considered-harmful", $filename)
 464         if ($base eq 'csh' or $base eq 'tcsh');
 465
 466     my $shellscript = $base =~ /^((b|d)?a|t?c|(pd)?k)?sh$/ ? 1 : 0;
 467
 468     # Only syntax-check scripts we can check with bash.
 469     my $checkbashisms;
 470     if ($shellscript) {
 471         $checkbashisms = $base eq "sh" ? 1 : 0;
 472         if ($base eq 'sh' or $base eq 'bash') {
 473             if (check_script_syntax("/bin/bash", $filename)) {
 474                 tag("maintainer-shell-script-fails-syntax-check", $file);
 475             }
 476         }
 477     }
 478
 479     # now scan the file contents themselves
 480     open (C, '<', "$filename")
 481         or fail("cannot open maintainer script $filename for reading: $!");
 482
 483     my %warned;
 484     my ($saw_init, $saw_invoke, $saw_debconf, $has_code);
 485     my $cat_string = "";
 486
 487     while (<C>) {
 488         next if m,^\s*$,;  # skip empty lines
 489         next if m,^\s*\#,; # skip comment lines
 490         s/\#.*$//;         # eat comments
 491         chomp();
 492
 493         # Don't consider the standard dh-make boilerplate to be code.  This
 494         # means ignoring the framework of a case statement, the labels, the
 495         # echo complaining about unknown arguments, and an exit.
 496         unless ($has_code
 497                 || m/^\s*set\s+-\w+\s*$/
 498                 || m/^\s*case\s+\"?\$1\"?\s+in\s*$/
 499                 || m/^\s*(?:[a-z|-]+|\*)\)\s*$/
 500                 || m/^\s*[:;]+\s*$/
 501                 || m/^\s*echo\s+\"[^\"]+\"(?:\s*>&2)?\s*$/
 502                 || m/^\s*esac\s*$/
 503                 || m/^\s*exit\s+\d+\s*$/) {
 504             $has_code = 1;
 505         }
 506
 507         if (m,[^\w=](/var)?/tmp\b, and not m/\bmktemp\b/ and not m/\btempfile\b/ and not m/\bmkdir\b/ and not m/\bmkstemp\b/) {
 508             tag "possibly-insecure-handling-of-tmp-files-in-maintainer-script", "$file:$."
 509                 unless $warned{tmp};
 510             $warned{tmp} = 1;
 511         }
 512         if (m/^\s*killall(?:\s|\z)/) {
 513             tag "killall-is-dangerous", "$file:$." unless $warned{killall};
 514             $warned{killall} = 1;
 515         }
 516         if (m/^\s*mknod(?:\s|\z)/ and not m/\sp\s/) {
 517             tag "mknod-in-maintainer-script", "$file:$.";
 518         }
 519
 520         # Collect information about init script invocations to catch running
 521         # init scripts directory rather than through invoke-rc.d.  Since the
 522         # script is allowed to run the init script directly if invoke-rc.d
 523         # doesn't exist, only tag direct invocations where invoke-rc.d is
 524         # never used in the same script.  Lots of false negatives, but
 525         # hopefully not many false positives.
 526         if (m%^\s*/etc/init.d/(\S+)\s+[\"\']?(\S+)[\"\']?%) {
 527             $saw_init = $.;
 528         }
 529         if (m%^\s*invoke-rc.d\s+%) {
 530             $saw_invoke = $.;
 531         }
 532
 533         if ($shellscript) {
 534             if ($cat_string ne "" and m/^\Q$cat_string\E$/) {
 535                 $cat_string = "";
 536             }
 537             my $within_another_shell = 0;
 538             if (m,(^|\s+)((/usr)?/bin/)?((b|d)?a|k|z|t?c)sh\s+-c\s*.+,) {
 539                 $within_another_shell = 1;
 540             }
 541             # if cat_string is set, we are in a HERE document and need not
 542             # check for things
 543             if ($cat_string eq "" and $checkbashisms and !$within_another_shell) {
 544                 my $found = 0;
 545                 my $match = '';
 546                 my $LEADIN = qr'(?:(^|[`&;(|{])\s*|(if|then|do|while)\s+)';
 547                 my @bashism_single_quote_regexs = (
 548                   $LEADIN . qr'echo\s+(?:-[^e\s]+\s+)?\'[^\']*(\\[\\abcEfnrtv0])+.*?[\']',
 549                         # unsafe echo with backslashes
 550                 );
 551                 my @bashism_string_regexs = (
 552                   qr'\$\[\w+\]',                 # arith not allowed
 553                   qr'\$\{\w+\:\d+(?::\d+)?\}',   # ${foo:3[:1]}
 554                   qr'\$\{\w+(/.+?){1,2}\}',      # ${parm/?/pat[/str]}
 555                   qr'\$\{\#?\w+\[[0-9\*\@]+\]\}',# bash arrays, ${name[0|*|@]}
 556                   qr'\$\{!\w+[\@*]\}',           # ${!prefix[*|@]}
 557                   qr'\$\{!\w+\}',                # ${!name}
 558                   qr'(\$\(|\`)\s*\<\s*\S+\s*(\)|\`)', # $(\< foo) should be $(cat foo)
 559                   qr'\$\{?RANDOM\}?\b',          # $RANDOM
 560                   qr'\$\{?(OS|MACH)TYPE\}?\b',   # $(OS|MACH)TYPE
 561                   qr'\$\{?HOST(TYPE|NAME)\}?\b', # $HOST(TYPE|NAME)
 562                   qr'\$\{?DIRSTACK\}?\b',        # $DIRSTACK
 563                   qr'\$\{?EUID\}?\b',            # $EUID should be "id -u"
 564                   qr'\$\{?UID\}?\b',             # $UID should be "id -ru"
 565                   qr'\$\{?SECONDS\}?\b',         # $SECONDS
 566                   qr'\$\{?BASH_[A-Z]+\}?\b',     # $BASH_SOMETHING
 567                   qr'\$\{?SHELLOPTS\}?\b',       # $SHELLOPTS
 568                   qr'\$\{?PIPESTATUS\}?\b',      # $PIPESTATUS
 569                   qr'\$\{?SHLVL\}?\b',           # $SHLVL
 570                   qr'<<<',                       # <<< here string
 571                   $LEADIN . qr'echo\s+(?:-[^e\s]+\s+)?\"[^\"]*(\\[\\abcEfnrtv0])+.*?[\"]',
 572                         # unsafe echo with backslashes
 573                 );
 574                 my @bashism_regexs = (
 575                   qr'(?:^|\s+)function \w+(\s|\(|\Z)',  # function is useless
 576                                                  # should be '.', not 'source'
 577                   $LEADIN . qr'source\s+(?:\.\/|\/|\$)[^\s]+',
 578                   qr'(test|-o|-a)\s*[^\s]+\s+==\s', # should be 'b = a'
 579                   qr'\[\s+[^\]]+\s+==\s',        # should be 'b = a'
 580                   qr'\s(\|\&)',                  # pipelining is not POSIX
 581                   qr'[^\\\$]\{(?:[^\s\\\}]+?,)+[^\\\}\s]+\}', # brace expansion
 582                   qr'(?:^|\s+)\w+\[\d+\]=',      # bash arrays, H[0]
 583                   $LEADIN . qr'(read\s*(-[^r]+)*(?:;|$))',
 584                         # read without variable or with option other than -r
 585                   $LEADIN . qr'kill\s+-[^sl]\w*',# kill -[0-9] or -[A-Z]
 586                   $LEADIN . qr'trap\s+["\']?.*["\']?\s+.*[1-9]', # trap with signal numbers
 587                   qr'\&>',                       # cshism
 588                   qr'(<\&|>\&)\s*((-|\d+)[^\s;|)`&\\\\]|[^-\d\s]+)', # should be >word 2>&1
 589                   qr'\[\[(?!:)',                 # alternative test command
 590                   $LEADIN . qr'select\s+\w+',    # 'select' is not POSIX
 591                   $LEADIN . qr'echo\s+(-n\s+)?-n?en?',  # echo -e
 592                   $LEADIN . qr'exec\s+-[acl]',   # exec -c/-l/-a name
 593                   qr'(?:^|\s+)let\s',            # let ...
 594                   qr'(?<![\$\(])\(\(.*\)\)',     # '((' should be '$(('
 595                   qr'\$\[[^][]+\]',              # '$[' should be '$(('
 596                   qr'(\[|test)\s+-a',            # test with unary -a (should be -e)
 597                   qr'/dev/(tcp|udp)',            # /dev/(tcp|udp)
 598                   $LEADIN . qr'\w+\+=',          # should be "VAR="${VAR}foo"
 599                   $LEADIN . qr'suspend\s',
 600                   $LEADIN . qr'caller\s',
 601                   $LEADIN . qr'complete\s',
 602                   $LEADIN . qr'compgen\s',
 603                   $LEADIN . qr'declare\s',
 604                   $LEADIN . qr'typeset\s',
 605                   $LEADIN . qr'disown\s',
 606                   $LEADIN . qr'builtin\s',
 607                   $LEADIN . qr'set\s+-[BHT]+',   # set -[BHT]
 608                   $LEADIN . qr'alias\s+-p',      # alias -p
 609                   $LEADIN . qr'unalias\s+-a',    # unalias -a
 610                   $LEADIN . qr'local\s+-[a-zA-Z]+', # local -opt
 611                   $LEADIN . qr'local\s+\w+=',    # local foo=bar
 612                   qr'(?:^|\s+)\s*\(?\w*[^\(\w\s]+\S*?\s*\(\)\s*([\{|\(]|\Z)',
 613                         # function names should only contain [a-z0-9_]
 614                   $LEADIN . qr'(push|pop)d(\s|\Z)',   # (push|pod)d
 615                   $LEADIN . qr'export\s+-[^p]',  # export only takes -p as an option
 616                   $LEADIN . qr'ulimit(\s|\Z)',
 617                   $LEADIN . qr'shopt(\s|\Z)',
 618                   $LEADIN . qr'type\s',
 619                   $LEADIN . qr'time\s',
 620                   $LEADIN . qr'dirs(\s|\Z)',
 621                   qr'(?:^|\s+)[<>]\(.*?\)',      # <() process substituion
 622                   qr'(?:^|\s+)readonly\s+-[af]', # readonly -[af]
 623                   $LEADIN . qr'(sh|\$\{?SHELL\}?) -[rD]', # sh -[rD]
 624                   $LEADIN . qr'(sh|\$\{?SHELL\}?) --\w+', # sh --long-option
 625                   $LEADIN . qr'(sh|\$\{?SHELL\}?) [-+]O', # sh [-+]O
 626                 );
 627
 628                 # since this test is ugly, I have to do it by itself
 629                 # detect source (.) trying to pass args to the command it runs
 630                 # The first expression weeds out '. "foo bar"'
 631                 if (not $found and
 632                     not m/^\s*\.\s+(\"[^\"]+\"|\'[^\']+\')\s*(\&|\||\d?>|<|;|\Z)/
 633                     and m/^\s*(\.\s+[^\s;\`:]+\s+([^\s;]+))/) {
 634
 635                     my $extra;
 636                     ($match, $extra) = ($1, $2);
 637                     if ($extra =~ /^(\&|\||\d?>|<)/) {
 638                         # everything is ok
 639                         ;
 640                     } else {
 641                         $found = 1;
 642                     }
 643                 }
 644
 645                 my $line = $_;
 646
 647                 unless ($found) {
 648                     for my $re (@bashism_single_quote_regexs) {
 649                         if ($line =~ m/($re)/) {
 650                             $found = 1;
 651                             ($match) = m/($re)/;
 652                             last;
 653                         }
 654                     }
 655                 }
 656
 657                 # Ignore anything inside single quotes; it could be an
 658                 # argument to grep or the like.
 659
 660                 # $cat_line contains the version of the line we'll check
 661                 # for heredoc delimiters later. Initially, remove any
 662                 # spaces between << and the delimiter to make the following
 663                 # updates to $cat_line easier.
 664                 my $cat_line = $line;
 665                 $cat_line =~ s/(<\<-?)\s+/$1/g;
 666
 667                 # Remove single quoted strings, with the exception that we
 668                 # don't remove the string
 669                 # if the quote is immediately preceeded by a < or a -, so we
 670                 # can match "foo <<-?'xyz'" as a heredoc later
 671                 # The check is a little more greedy than we'd like, but the
 672                 # heredoc test itself will weed out any false positives
 673                 $cat_line =~ s/(^|[^<\\\"-](?:\\\\)*)\'(?:\\.|[^\\\'])+\'/$1''/g;
 674
 675                 unless ($found) {
 676                     # Remove "quoted quotes". They're likely to be inside
 677                     # another pair of quotes; we're not interested in
 678                     # them for their own sake and removing them makes finding
 679                     # the limits of the outer pair far easier.
 680                     $line =~ s/(^|[^\\\'\"])\"\'\"/$1/g;
 681                     $line =~ s/(^|[^\\\'\"])\'\"\'/$1/g;
 682
 683                     $line =~ s/(^|[^\\\"](?:\\\\)*)\'(?:\\.|[^\\\'])+\'/$1''/g;
 684                     for my $re (@bashism_string_regexs) {
 685                         if ($line =~ m/($re)/) {
 686                             $found = 1;
 687                             ($match) = m/($re)/;
 688                             last;
 689                         }
 690                     }
 691                 }
 692
 693                 # We've checked for all the things we still want to notice in
 694                 # double-quoted strings, so now remove those strings as well.
 695                 $cat_line =~ s/(^|[^<\\\'-](?:\\\\)*)\"(?:\\.|[^\\\"])+\"/$1""/g;
 696                 unless ($found) {
 697                     $line =~ s/(^|[^\\\'](?:\\\\)*)\"(?:\\.|[^\\\"])+\"/$1""/g;
 698                     for my $re (@bashism_regexs) {
 699                         if ($line =~ m/($re)/) {
 700                             $found = 1;
 701                             ($match) = m/($re)/;
 702                             last;
 703                         }
 704                     }
 705                 }
 706
 707                 if ($found) {
 708                     tag "possible-bashism-in-maintainer-script", "$file:$. \'$match\'";
 709                 }
 710
 711                 # Only look for the beginning of a heredoc here, after we've
 712                 # stripped out quoted material, to avoid false positives.
 713                 if ($cat_line =~ m/(?:^|[^<])\<\<\-?\s*(?:[\\]?(\w+)|[\'\"](.*?)[\'\"])/) {
 714                     $cat_string = $1;
 715                     $cat_string = $2 if not defined $cat_string;
 716                 }
 717             }
 718             if (!$cat_string) {
 719                 if (/^\s*start-stop-daemon\s+/ && !/\s--stop\b/) {
 720                     tag 'start-stop-daemon-in-maintainer-script', "$file:$.";
 721                 }
 722                 # Don't use chown foo.bar
 723                 if (/(chown(\s+--?[A-Za-z-]+)*\s+[-_A-Za-z0-9]+\.[-_A-Za-z0-9]+)\s+/) {
 724                     tag "deprecated-chown-usage", "$file:$. \'$1\'";
 725                 }
 726                 if (/invoke-rc.d.*\|\| exit 0/) {
 727                     tag "maintainer-script-hides-init-failure", "$file:$.";
 728                 }
 729                 if (m,/usr/share/debconf/confmodule,) {
 730                     $saw_debconf = 1;
 731                 }
 732                 if (m/^\s*read(?:\s|\z)/ && !$saw_debconf) {
 733                     tag "read-in-maintainer-script", "$file:$.";
 734                 }
 735                 if (m,^\s*rm\s+([^>]*\s)?/dev/,) {
 736                     tag "maintainer-script-removes-device-files", "$file:$.";
 737                 }
 738                 if (m,>\s*(/etc/(?:services|protocols|rpc))(\s|\Z),) {
 739                     tag "maintainer-script-modifies-netbase-managed-file", "$file:$. $1";
 740                 }
 741                 if (m,^\s*(?:cp|mv)\s.*(/etc/(?:services|protocols|rpc))\s*$,) {
 742                     tag "maintainer-script-modifies-netbase-managed-file", "$file:$. $1";
 743                 }
 744                 if (m,>\s*/etc/inetd\.conf(\s|\Z),) {
 745                     tag "maintainer-script-modifies-inetd-conf", "$file:$."
 746                         unless Dep::implies($deps{provides}, Dep::parse('inet-superserver'));
 747                 }
 748                 if (m,^\s*(?:cp|mv)\s+(?:.*\s)?/etc/inetd\.conf\s*$,) {
 749                     tag "maintainer-script-modifies-inetd-conf", "$file:$."
 750                         unless Dep::implies($deps{provides}, Dep::parse('inet-superserver'));
 751                 }
 752
 753                 # Ancient dpkg feature tests.
 754                 if (m/^\s*dpkg\s+--assert-support-predepends\b/) {
 755                     tag "ancient-dpkg-predepends-check", "$file:$.";
 756                 }
 757                 if (m/^\s*dpkg\s+--assert-working-epoch\b/) {
 758                     tag "ancient-dpkg-epoch-check", "$file:$.";
 759                 }
 760                 if (m/^dpkg\s+--assert-long-filenames\b/) {
 761                     tag "ancient-dpkg-long-filenames-check", "$file:$.";
 762                 }
 763                 if (m/^dpkg\s+--assert-multi-conrep\b/) {
 764                     tag "ancient-dpkg-multi-conrep-check", "$file:$.";
 765                 }
 766             }
 767         }
 768         if (m,\bsuidregister\b,) {
 769             tag "suidregister-used-in-maintainer-script", "$file";
 770         }
 771         if ($file eq 'postrm') {
 772             if (m,update\-alternatives \-\-remove,) {
 773                 tag "update-alternatives-remove-called-in-postrm", "";
 774             }
 775         } else {
 776             for my $rule (@depends_needed) {
 777                 my ($package, $regex) = @$rule;
 778                 if ($pkg ne $package and /$regex/ and ! $warned{$package}) {
 779                     if (m,-x\s+\S*$regex, or m,which\s+$regex, or m,command\s+.*?$regex,) {
 780                         $warned{$package} = 1;
 781                     } else {
 782                         my $needed = Dep::parse($package);
 783                         unless (Dep::implies($deps{depends}, $needed) || Dep::implies($deps{'pre-depends'}, $needed)) {
 784                             my $shortpackage = $package;
 785                             $shortpackage =~ s/[ \(].*//;
 786                             tag "maintainer-script-needs-depends-on-$shortpackage", "$file";
 787                             $warned{$package} = 1;
 788                         }
 789                     }
 790                 }
 791             }
 792         }
 793         if (m,\bgconftool(-2)?(\s|\Z),) {
 794             tag "gconftool-used-in-maintainer-script", "$file:$.";
 795         }
 796         if (m,\binstall-sgmlcatalog\b, && !(m,--remove, && ($file eq 'prerm' || $file eq 'postinst'))) {
 797             tag "install-sgmlcatalog-deprecated", "$file:$.";
 798         }
 799         if (m,/var/lib/dpkg/status\b, && $pkg ne 'base-files' && $pkg ne 'dpkg') {
 800             tag "maintainer-script-uses-dpkg-status-directly", "$file";
 801         }
 802     }
 803
 804     if ($saw_init && ! $saw_invoke) {
 805         tag "maintainer-script-calls-init-script-directly", "$file:$saw_init";
 806     }
 807     unless ($has_code) {
 808         tag "maintainer-script-empty", $file;
 809     }
 810
 811     close C;
 812
 813 }
 814 close(SCRIPTS);
 815
 816 }
 817
 818 # -----------------------------------
 819
 820 # Returns non-zero if the given file is not actually a shell script,
 821 # just looks like one.
 822 sub script_is_evil_and_wrong {
 823     my ($filename) = @_;
 824     my $ret = 0;
 825     open (IN, '<', $filename) or fail("cannot open $filename: $!");
 826     my $i = 0;
 827     my $var = "0";
 828     my $backgrounded = 0;
 829     local $_;
 830     while (<IN>) {
 831         chomp;
 832         next if m/^#/o;
 833         next if m/^$/o;
 834         last if (++$i > 55);
 835         if (m~
 836             # the exec should either be "eval"ed or a new statement
 837             (^\s*|\beval\s*[\'\"]|(;|&&)\s*)
 838
 839             # eat anything between the exec and $0
 840             exec\s*.+\s*
 841
 842             # optionally quoted executable name (via $0)
 843             .?\$$var.?\s*
 844
 845             # optional "end of options" indicator
 846             (--\s*)?
 847
 848             # Match expressions of the form '${1+$@}', '${1:+"$@"',
 849             # '"${1+$@', "$@", etc where the quotes (before the dollar
 850             # sign(s)) are optional and the second (or only if the $1
 851             # clause is omitted) parameter may be $@ or $*.
 852             #
 853             # Finally the whole subexpression may be omitted for scripts
 854             # which do not pass on their parameters (i.e. after re-execing
 855             # they take their parameters (and potentially data) from stdin
 856             .?(\${1:?\+.?)?(\$(\@|\*))?~x) {
 857             $ret = 1;
 858             last;
 859         } elsif (/^\s*(\w+)=\$0;/) {
 860             $var = $1;
 861         } elsif (m~
 862             # Match scripts which use "foo $0 $@ &\nexec true\n"
 863             # Program name
 864             \S+\s+
 865
 866             # As above
 867             .?\$$var.?\s*
 868             (--\s*)?
 869             .?(\${1:?\+.?)?(\$(\@|\*))?.?\s*\&~x) {
 870
 871             $backgrounded = 1;
 872         } elsif ($backgrounded and m~
 873             # the exec should either be "eval"ed or a new statement
 874             (^\s*|\beval\s*[\'\"]|(;|&&)\s*)
 875             exec\s+true(\s|\Z)~x) {
 876
 877             $ret = $1;
 878             last;
 879         }
 880     }
 881     close IN;
 882     return $ret;
 883 }
 884
 885 # Given an interpretor and a file, run the interpretor on that file with the
 886 # -n option to check syntax, discarding output and returning the exit status.
 887 sub check_script_syntax {
 888     my ($interpreter, $script) = @_;
 889     my $pid = fork;
 890     if (!defined $pid) {
 891         fail("cannot fork: $!");
 892     } elsif ($pid == 0) {
 893         open STDOUT, '>/dev/null' or fail("cannot reopen stdout: $!");
 894         open STDERR, '>&STDOUT' or fail("cannot reopen stderr: $!");
 895         exec $interpreter, '-n', $script
 896             or fail("cannot exec $interpreter: $!");
 897     } else {
 898         waitpid $pid, 0;
 899     }
 900     return $?;
 901 }
 902
 903 1;
 904
 905 # Local Variables:
 906 # indent-tabs-mode: t
 907 # cperl-indent-level: 4
 908 # End:
 909 # vim: syntax=perl ts=8 sw=4