X-Git-Url: https://vcs.maemo.org/git/?a=blobdiff_plain;f=nokia-lintian%2Fchecks%2Fscripts;fp=nokia-lintian%2Fchecks%2Fscripts;h=946cdb2d4d1eaf21d78112139c751d158812ab66;hb=1975b83207a518d59ef6b04c7c16233cb353ca86;hp=0000000000000000000000000000000000000000;hpb=208f636c44e0ec2b53c70aaed2399d8e9cf0e741;p=maemian diff --git a/nokia-lintian/checks/scripts b/nokia-lintian/checks/scripts new file mode 100644 index 0000000..946cdb2 --- /dev/null +++ b/nokia-lintian/checks/scripts @@ -0,0 +1,909 @@ +# scripts -- lintian check script -*- perl -*- +# +# 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 +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::scripts; +use strict; +use Dep; +use Tags; +use Util; + +# 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 one +# or two elements. The first, mandatory argument is the path on a Debian +# system where that interpreter would be installed. The second, optional +# argument is the dependency that provides that interpreter. If the second +# argument isn't given, the package name is assumed to be the same as the +# interpreter name. (Saves some typing.) +# +# Some interpreters list empty dependencies (as opposed to undefined ones). +# Those interpreters should not have any dependency for one reason or another +# (usually because they're essential packages or aren't used in a normal way). +# +# Do not list versioned patterns here (such as pythonX.Y, rubyX.Y, etc.). For +# those, see %versioned_interpreters below. +our %interpreters = + (ash => [ '/bin' ], + awk => [ '/usr/bin', '' ], + bash => [ '/bin', '' ], + bltwish => [ '/usr/bin', 'blt' ], + clisp => [ '/usr/bin' ], + csh => [ '/bin', 'tcsh | csh | c-shell' ], + dash => [ '/bin' ], + expect => [ '/usr/bin' ], + expectk => [ '/usr/bin' ], + fish => [ '/usr/bin' ], + gawk => [ '/usr/bin' ], + gbr2 => [ '/usr/bin', 'gambas2-runtime' ], + gbx => [ '/usr/bin', 'gambas-runtime' ], + gbx2 => [ '/usr/bin', 'gambas2-runtime' ], + gforth => [ '/usr/bin' ], + gnuplot => [ '/usr/bin' ], + gosh => [ '/usr/bin', 'gauche' ], + 'install-menu' => [ '/usr/bin', '' ], + jed => [ '/usr/bin' ], + 'jed-script' => [ '/usr/bin', 'jed | xjed' ], + kaptain => [ '/usr/bin' ], + ksh => [ '/bin', 'mksh | pdksh' ], + lefty => [ '/usr/bin', 'graphviz' ], + magicfilter => [ '/usr/sbin' ], + make => [ '/usr/bin', 'make | build-essential' ], + mawk => [ '/usr/bin' ], + ocamlrun => [ '/usr/bin', + 'ocaml-base-nox | ocaml-base | ocaml-nox | ocaml' ], + pagsh => [ '/usr/bin', 'openafs-client | heimdal-clients' ], + parrot => [ '/usr/bin' ], + perl => [ '/usr/bin', '' ], + procmail => [ '/usr/bin' ], + python => [ '/usr/bin', 'python | python-minimal' ], + pforth => [ '/usr/bin' ], + rc => [ '/usr/bin' ], + regina => [ '/usr/bin', 'regina-rexx' ], + rexx => [ '/usr/bin', 'regina-rexx' ], + rrdcgi => [ '/usr/bin', 'rrdtool' ], + ruby => [ '/usr/bin' ], + runhugs => [ '/usr/bin', 'hugs | hugs98' ], + sed => [ '/bin', '' ], + sh => [ '/bin', '' ], + slsh => [ '/usr/bin' ], + speedy => [ '/usr/bin', 'speedy-cgi-perl' ], + tcsh => [ '/usr/bin' ], + tixwish => [ '/usr/bin', 'tix' ], + trs => [ '/usr/bin', 'konwert' ], + xjed => [ '/usr/bin', 'xjed' ], + yforth => [ '/usr/bin', 'yforth' ], + yorick => [ '/usr/bin' ], + zsh => [ '/bin', 'zsh | zsh-beta' ], + ); + +# The more complex case of interpreters that may have a version number. +# +# This is a hash from the base interpreter name to a list. The base +# interpreter name may appear by itself or followed by some combination of +# dashes, digits, and periods. The values are the directory in which the +# interpreter is found, the dependency to add for a version-less interpreter, +# a regular expression to match versioned interpreters and extract the version +# number, the package dependency for a versioned interpreter, and the list of +# known versions. +# +# An interpreter with a version must have a dependency on the specific package +# formed by taking the fourth element of the list and replacing $1 with the +# version number. An interpreter without a version is rejected if the second +# element is undef; otherwise, the package must depend on the disjunction of +# the second argument (if non-empty) and all the packages formed by taking the +# list of known versions (the fifth element and on) and replacing $1 in the +# fourth argument with them. +# +# For example: +# +# lua => [ '/usr/bin', 'lua', qr/^lua([\d.]+)$/, 'lua$1', qw(40 50 5.1) ] +# +# says that any lua interpreter must be in /usr/bin, a package using +# /usr/bin/lua50 must depend on lua50, and a package using just /usr/bin/lua +# must satisfy lua | lua40 | lusa50 | lua5.1. +# +# The list of known versions is the largest maintenance headache here, but +# it's only used for the unversioned dependency handling, and then only when +# someone uses the unversioned script but depends on a specific version for +# some reason. So it's not a huge problem if it's a little out of date. +our %versioned_interpreters = + (guile => [ '/usr/bin', 'guile', + qr/^guile-([\d.]+)$/, 'guile-$1', qw(1.6 1.8) + ], + jruby => [ '/usr/bin', undef, + qr/^jruby([\d.]+)$/, 'jruby$1', qw(0.9 1.0) + ], + lua => [ '/usr/bin', 'lua', + qr/^lua([\d.]+)$/, 'lua$1', qw(40 50 5.1) + ], + octave => [ '/usr/bin', 'octave', + qr/^octave([\d.]+)$/, 'octave$1', qw(2.1 2.9 3.0) + ], + php => [ '/usr/bin', '', + qr/^php(\d+)$/, 'php$1-cli', qw(4 5) + ], + pike => [ '/usr/bin', '', + qr/^pike([\d.]+)$/, 'pike$1 | pike$1-core', qw(7.6 7.7) + ], + python => [ '/usr/bin', undef, + qr/^python([\d.]+)$/, 'python$1 | python$1-minimal', + qw(2.4 2.5) + ], + ruby => [ '/usr/bin', undef, + qr/^ruby([\d.]+)$/, 'ruby$1', qw(1.8 1.9) + ], + scsh => [ '/usr/bin', 'scsh', + qr/^scsh-([\d.]+)$/, 'scsh-$1', qw(0.6) + ], + tclsh => [ '/usr/bin', 'tclsh | tcl', + qr/^tclsh([\d.]+)$/, 'tcl$1', qw(8.3 8.4 8.5) + ], + wish => [ '/usr/bin', 'wish | tk', + qr/^wish([\d.]+)$/, 'tk$1', qw(8.3 8.4 8.5) + ], + ); + +# Any of the following packages can satisfy an update-inetd dependency. +our $update_inetd + = join (' | ', qw(update-inetd inet-superserver openbsd-inetd + inetutils-inetd rlinetd xinetd)); + +# 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. +our @depends_needed = ( + [ adduser => '\badduser\b' ], + [ gconf2 => '\bgconf-schemas\b' ], + [ $update_inetd => '\bupdate-inetd\b' ], + [ ucf => '\bucf\s' ], + [ 'xml-core' => '\bupdate-xmlcatalog\b' ], +); + +sub run { + +my %executable = (); +my %suid = (); +my %ELF = (); +my %scripts = (); +my %deps = (); + +# no dependency for install-menu, because the menu package specifically +# says not to depend on it. + +my $pkg = shift; +my $type = shift; + +open(INDEX, '<', "index") or fail("cannot open lintian index file: $!"); +while () { + next unless (m/^-[rw-]*[xs]/); + chop; + s/ link to .*//; + my $is_suid = m/^-[rw-]*s/; + $executable{(split(' ', $_, 6))[5]} = 1; + $suid{(split(' ', $_, 6))[5]} = $is_suid; +} +close(INDEX); + +# Urgle... this is ambiguous, since the sequence ": " can occur in +# the output of file and also in the filename. +# Fortunately no filenames containing ": " currently occur in Debian packages. +open(FILEINFO, '<', "file-info") + or fail("cannot open lintian file-info file: $!"); +while () { + m/^(.*?): (.*)/ or fail("bad line in file-info: $_"); + my $file = $1; + $ELF{$file} = 1 if $2 =~ /^[^,]*\bELF\b/o; +} +close(FILEINFO); + +my $all_deps = ''; +for my $field (qw/suggests recommends depends pre-depends provides/) { + $deps{$field} = ''; + if (open(IN, '<', "fields/$field")) { + $_ = join('', ); + close(IN); + chomp; + $deps{$field} = $_; + $all_deps .= ', ' if $all_deps; + $all_deps .= $_; + } + $deps{$field} = Dep::parse($deps{$field}); +} +$all_deps .= ', ' if $all_deps; +$all_deps .= $pkg; +$deps{all} = Dep::parse($all_deps); + +open(SCRIPTS, '<', "scripts") or fail("cannot open lintian scripts file: $!"); +while () { + chop; + + # This used to be split(' ', $_, 2), but that didn't handle empty + # interpreter lines correctly. + my ($calls_env, $interpreter, $filename) = m/^(env )?(\S*) (.*)$/ or + fail("bad line in scripts file: $_"); + + $scripts{$filename} = 1; + + # no checks necessary at all for scripts in /usr/share/doc/ + next if $filename =~ m,usr/share/doc/,; + + 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); + + # 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/), and !$executable{$filename} + and !$is_absolute); + + if ($interpreter eq "") { + tag("script-without-interpreter", $filename); + next; + } + + # Either they use an absolute path or they use '/usr/bin/env interp'. + 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,\.in$, + or $filename =~ m,\.ex$, + or $filename eq './etc/init.d/skeleton' + or $filename =~ m,^\./etc/menu-methods, + or $filename =~ m,^\./etc/X11/Xsession.d,); + + # Warn about csh scripts. + tag("csh-considered-harmful", $filename) + if (($base eq 'csh' or $base eq 'tcsh') + and $executable{$filename} + and $filename !~ m,^./etc/csh/login.d/,); + + # 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. + # zsh -n is broken, see #485885 + if ($base =~ /^(?:(?:b|d)?a|k)?sh$/) { + if (-x "$interpreter" && ! script_is_evil_and_wrong("unpacked/$filename")) { + if ($filename !~ m,\.dpatch$,) { + if (check_script_syntax($interpreter, "unpacked/$filename")) { + tag("shell-script-fails-syntax-check", $filename); + } + } + } + } + + # 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{$base}; + my $versioned = 0; + if (not defined $data) { + $data = $versioned_interpreters{$base}; + undef $data if ($data and not defined ($data->[1])); + if (not defined ($data) and $base =~ /^(.*[^\d.-])-?[\d.]+$/) { + $data = $versioned_interpreters{$1}; + undef $data unless ($data and $base =~ /$data->[2]/); + } + $versioned = 1 if $data; + } + if ($data) { + my $expected = $data->[0] . '/' . $base; + unless ($interpreter eq $expected or defined $calls_env) { + tag("wrong-path-for-interpreter", + "#!$interpreter != $expected", "($filename)"); + } + } elsif ($interpreter =~ m,/usr/local/,) { + tag("interpreter-in-usr-local", $filename, "#!$interpreter"); + } elsif ($executable{'.' . $interpreter}) { + # Package installs the interpreter itself, so it's probably ok. Don't + # emit any tag for this. + } elsif ($base eq 'suidperl') { + tag("calls-suidperl-directly", $filename); + } elsif ($interpreter eq '/bin/env') { + tag("script-uses-bin-env", $filename); + } else { + tag("unusual-interpreter", $filename, "#!$interpreter"); + } + + # 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 && $executable{$filename}); + if (!$versioned) { + my $depends = $data->[1]; + if (not defined $depends) { + $depends = $base; + } + if ($depends && !Dep::implies($deps{all}, Dep::parse($depends))) { + if ($base =~ /^(python|ruby|(m|g)awk)$/) { + tag("$base-script-but-no-$base-dep", $filename); + } 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. + } else { + tag('missing-dep-for-interpreter', "$base => $depends", + "($filename)"); + } + } + if ($base eq 'perl' && $suid{$filename}) { + tag("suid-perl-script-but-no-perl-suid-dep", $filename) + unless Dep::implies($deps{all}, Dep::parse('perl-suid')); + } + } elsif ($versioned_interpreters{$base}) { + my @versions = @$data[4 .. @$data - 1]; + my @depends = map { + my $d = $data->[3]; + $d =~ s/\$1/$_/g; + $d; + } @versions; + my $depends = join (' | ', $data->[1], @depends); + unless (Dep::implies($deps{all}, Dep::parse($depends))) { + if ($base eq 'php') { + tag('php-script-but-no-phpX-cli-dep', $filename); + } elsif ($base =~ /^(wish|tclsh)/) { + tag("$1-script-but-no-$1-dep", $filename); + } else { + tag("missing-dep-for-interpreter", "$base => $depends", + "($filename)"); + } + } + } else { + my ($version) = ($base =~ /$data->[2]/); + my $depends = $data->[3]; + $depends =~ s/\$1/$version/g; + unless (Dep::implies($deps{all}, Dep::parse($depends))) { + if ($base =~ /^php/) { + tag('php-script-but-no-phpX-cli-dep', $filename); + } elsif ($base =~ /^(python|ruby)/) { + tag("$1-script-but-no-$1-dep", $filename); + } else { + tag("missing-dep-for-interpreter", "$base => $depends", + "($filename)"); + } + } + } +} +close(SCRIPTS); + +foreach (keys %executable) { + tag("executable-not-elf-or-script", $_) + unless ( $ELF{$_} + or $scripts{$_} + or $_ =~ m,^usr(/X11R6)?/man/, + or $_ =~ m/\.exe$/ # mono convention + ); +} + +open(SCRIPTS, '<', "control-scripts") + or fail("cannot open lintian control-scripts file: $!"); + +# 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. + +while () { + chop; + + m/^(\S*) (.*)$/ or fail("bad line in control-scripts file: $_"); + my $interpreter = $1; + my $file = $2; + my $filename = "control/$file"; + + $interpreter =~ m|([^/]*)$|; + my $base = $1; + + if ($interpreter eq "") { + tag("script-without-interpreter", $filename); + next; + } + + tag("interpreter-not-absolute", $filename, "#!$interpreter") + unless ($interpreter =~ m|^/|); + + if (exists $interpreters{$base}) { + my $data = $interpreters{$base}; + my $expected = $data->[0] . '/' . $base; + tag("wrong-path-for-interpreter", "#!$interpreter != $expected", + "($filename)") + unless ($interpreter eq $expected); + unless ($base eq 'sh' or $base eq 'bash' or $base eq 'perl') { + my $tag; + if ($file eq 'config') { + $tag = 'forbidden-config-interpreter'; + } else { + $tag = 'unusual-control-interpreter'; + } + tag($tag, "#!$interpreter"); + } + unless (defined ($data->[1]) and not $data->[1]) { + my $depends = $data->[1] || $base; + unless (Dep::implies($deps{'pre-depends'}, Dep::parse($depends))) { + tag("interpreter-without-predep", $filename, "#!$interpreter"); + } + } + } elsif ($interpreter =~ m|/usr/local/|) { + tag("interpreter-in-usr-local", $filename, "#!$interpreter"); + } else { + tag("unusual-interpreter", $filename, "#!$interpreter"); + next; # no use doing further checks if it's not a known interpreter + } + + # perhaps we should warn about *csh even if they're somehow screwed, + # but that's not really important... + tag("csh-considered-harmful", $filename) + if ($base eq 'csh' or $base eq 'tcsh'); + + my $shellscript = $base =~ /^((b|d)?a|t?c|(pd)?k)?sh$/ ? 1 : 0; + + # 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') { + if (check_script_syntax("/bin/bash", $filename)) { + tag("maintainer-shell-script-fails-syntax-check", $file); + } + } + } + + # now scan the file contents themselves + open (C, '<', "$filename") + or fail("cannot open maintainer script $filename for reading: $!"); + + my %warned; + my ($saw_init, $saw_invoke, $saw_debconf, $has_code); + my $cat_string = ""; + + while () { + next if m,^\s*$,; # skip empty lines + next if m,^\s*\#,; # skip comment lines + s/\#.*$//; # eat comments + chomp(); + + # 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 + || 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*$/) { + $has_code = 1; + } + + 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/) { + 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:$."; + } + + # Collect information about init script invocations to catch running + # init scripts directory 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 = $.; + } + if (m%^\s*invoke-rc.d\s+%) { + $saw_invoke = $.; + } + + if ($shellscript) { + if ($cat_string ne "" and m/^\Q$cat_string\E$/) { + $cat_string = ""; + } + my $within_another_shell = 0; + if (m,(^|\s+)((/usr)?/bin/)?((b|d)?a|k|z|t?c)sh\s+-c\s*.+,) { + $within_another_shell = 1; + } + # if cat_string is set, we are in a HERE document and need not + # check for things + if ($cat_string eq "" and $checkbashisms and !$within_another_shell) { + my $found = 0; + my $match = ''; + my $LEADIN = qr'(?:(^|[`&;(|{])\s*|(if|then|do|while)\s+)'; + my @bashism_single_quote_regexs = ( + $LEADIN . qr'echo\s+(?:-[^e\s]+\s+)?\'[^\']*(\\[\\abcEfnrtv0])+.*?[\']', + # unsafe echo with backslashes + ); + my @bashism_string_regexs = ( + qr'\$\[\w+\]', # arith not allowed + qr'\$\{\w+\:\d+(?::\d+)?\}', # ${foo:3[:1]} + qr'\$\{\w+(/.+?){1,2}\}', # ${parm/?/pat[/str]} + qr'\$\{\#?\w+\[[0-9\*\@]+\]\}',# bash arrays, ${name[0|*|@]} + qr'\$\{!\w+[\@*]\}', # ${!prefix[*|@]} + qr'\$\{!\w+\}', # ${!name} + qr'(\$\(|\`)\s*\<\s*\S+\s*(\)|\`)', # $(\< foo) should be $(cat foo) + qr'\$\{?RANDOM\}?\b', # $RANDOM + 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" + qr'\$\{?UID\}?\b', # $UID should be "id -ru" + qr'\$\{?SECONDS\}?\b', # $SECONDS + qr'\$\{?BASH_[A-Z]+\}?\b', # $BASH_SOMETHING + qr'\$\{?SHELLOPTS\}?\b', # $SHELLOPTS + qr'\$\{?PIPESTATUS\}?\b', # $PIPESTATUS + qr'\$\{?SHLVL\}?\b', # $SHLVL + qr'<<<', # <<< here string + $LEADIN . qr'echo\s+(?:-[^e\s]+\s+)?\"[^\"]*(\\[\\abcEfnrtv0])+.*?[\"]', + # unsafe echo with backslashes + ); + my @bashism_regexs = ( + qr'(?:^|\s+)function \w+(\s|\(|\Z)', # function is useless + # should be '.', not 'source' + $LEADIN . qr'source\s+(?:\.\/|\/|\$)[^\s]+', + qr'(test|-o|-a)\s*[^\s]+\s+==\s', # should be 'b = a' + qr'\[\s+[^\]]+\s+==\s', # should be 'b = a' + qr'\s(\|\&)', # pipelining is not POSIX + qr'[^\\\$]\{(?:[^\s\\\}]+?,)+[^\\\}\s]+\}', # brace expansion + qr'(?:^|\s+)\w+\[\d+\]=', # bash arrays, H[0] + $LEADIN . qr'(read\s*(-[^r]+)*(?:;|$))', + # read without variable or with option other than -r + $LEADIN . qr'kill\s+-[^sl]\w*',# kill -[0-9] or -[A-Z] + $LEADIN . qr'trap\s+["\']?.*["\']?\s+.*[1-9]', # trap with signal numbers + qr'\&>', # cshism + qr'(<\&|>\&)\s*((-|\d+)[^\s;|)`&\\\\]|[^-\d\s]+)', # should be >word 2>&1 + qr'\[\[(?!:)', # alternative test command + $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 + qr'(?:^|\s+)let\s', # let ... + qr'(?]\(.*?\)', # <() process substituion + 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 + ); + + # 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/^\s*\.\s+(\"[^\"]+\"|\'[^\']+\')\s*(\&|\||\d?>|<|;|\Z)/ + and m/^\s*(\.\s+[^\s;\`:]+\s+([^\s;]+))/) { + + my $extra; + ($match, $extra) = ($1, $2); + if ($extra =~ /^(\&|\||\d?>|<)/) { + # everything is ok + ; + } else { + $found = 1; + } + } + + my $line = $_; + + unless ($found) { + for my $re (@bashism_single_quote_regexs) { + if ($line =~ m/($re)/) { + $found = 1; + ($match) = m/($re)/; + last; + } + } + } + + # 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 + # if the quote is immediately preceeded by a < or 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; + } + } + } + + # 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; + } + } + } + + if ($found) { + tag "possible-bashism-in-maintainer-script", "$file:$. \'$match\'"; + } + + # 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+)|[\'\"](.*?)[\'\"])/) { + $cat_string = $1; + $cat_string = $2 if not defined $cat_string; + } + } + if (!$cat_string) { + if (/^\s*start-stop-daemon\s+/ && !/\s--stop\b/) { + tag 'start-stop-daemon-in-maintainer-script', "$file:$."; + } + # Don't use chown foo.bar + if (/(chown(\s+--?[A-Za-z-]+)*\s+[-_A-Za-z0-9]+\.[-_A-Za-z0-9]+)\s+/) { + tag "deprecated-chown-usage", "$file:$. \'$1\'"; + } + if (/invoke-rc.d.*\|\| exit 0/) { + tag "maintainer-script-hides-init-failure", "$file:$."; + } + if (m,/usr/share/debconf/confmodule,) { + $saw_debconf = 1; + } + if (m/^\s*read(?:\s|\z)/ && !$saw_debconf) { + tag "read-in-maintainer-script", "$file:$."; + } + if (m,^\s*rm\s+([^>]*\s)?/dev/,) { + tag "maintainer-script-removes-device-files", "$file:$."; + } + if (m,>\s*(/etc/(?:services|protocols|rpc))(\s|\Z),) { + tag "maintainer-script-modifies-netbase-managed-file", "$file:$. $1"; + } + if (m,^\s*(?:cp|mv)\s.*(/etc/(?:services|protocols|rpc))\s*$,) { + tag "maintainer-script-modifies-netbase-managed-file", "$file:$. $1"; + } + if (m,>\s*/etc/inetd\.conf(\s|\Z),) { + tag "maintainer-script-modifies-inetd-conf", "$file:$." + unless Dep::implies($deps{provides}, Dep::parse('inet-superserver')); + } + if (m,^\s*(?:cp|mv)\s+(?:.*\s)?/etc/inetd\.conf\s*$,) { + tag "maintainer-script-modifies-inetd-conf", "$file:$." + unless Dep::implies($deps{provides}, Dep::parse('inet-superserver')); + } + + # Ancient dpkg feature tests. + if (m/^\s*dpkg\s+--assert-support-predepends\b/) { + tag "ancient-dpkg-predepends-check", "$file:$."; + } + if (m/^\s*dpkg\s+--assert-working-epoch\b/) { + tag "ancient-dpkg-epoch-check", "$file:$."; + } + if (m/^dpkg\s+--assert-long-filenames\b/) { + tag "ancient-dpkg-long-filenames-check", "$file:$."; + } + if (m/^dpkg\s+--assert-multi-conrep\b/) { + tag "ancient-dpkg-multi-conrep-check", "$file:$."; + } + } + } + if (m,\bsuidregister\b,) { + tag "suidregister-used-in-maintainer-script", "$file"; + } + if ($file eq 'postrm') { + if (m,update\-alternatives \-\-remove,) { + tag "update-alternatives-remove-called-in-postrm", ""; + } + } else { + for my $rule (@depends_needed) { + my ($package, $regex) = @$rule; + if ($pkg ne $package and /$regex/ and ! $warned{$package}) { + if (m,-x\s+\S*$regex, or m,which\s+$regex, or m,command\s+.*?$regex,) { + $warned{$package} = 1; + } else { + my $needed = Dep::parse($package); + unless (Dep::implies($deps{depends}, $needed) || Dep::implies($deps{'pre-depends'}, $needed)) { + my $shortpackage = $package; + $shortpackage =~ s/[ \(].*//; + tag "maintainer-script-needs-depends-on-$shortpackage", "$file"; + $warned{$package} = 1; + } + } + } + } + } + if (m,\bgconftool(-2)?(\s|\Z),) { + tag "gconftool-used-in-maintainer-script", "$file:$."; + } + if (m,\binstall-sgmlcatalog\b, && !(m,--remove, && ($file eq 'prerm' || $file eq 'postinst'))) { + tag "install-sgmlcatalog-deprecated", "$file:$."; + } + if (m,/var/lib/dpkg/status\b, && $pkg ne 'base-files' && $pkg ne 'dpkg') { + tag "maintainer-script-uses-dpkg-status-directly", "$file"; + } + } + + if ($saw_init && ! $saw_invoke) { + tag "maintainer-script-calls-init-script-directly", "$file:$saw_init"; + } + unless ($has_code) { + tag "maintainer-script-empty", $file; + } + + close C; + +} +close(SCRIPTS); + +} + +# ----------------------------------- + +# Returns non-zero if the given file is not actually a shell script, +# just looks like one. +sub script_is_evil_and_wrong { + my ($filename) = @_; + my $ret = 0; + open (IN, '<', $filename) or fail("cannot open $filename: $!"); + my $i = 0; + my $var = "0"; + my $backgrounded = 0; + local $_; + while () { + chomp; + next if m/^#/o; + next if m/^$/o; + last if (++$i > 55); + if (m~ + # the exec should either be "eval"ed or a new statement + (^\s*|\beval\s*[\'\"]|(;|&&)\s*) + + # eat anything between the exec and $0 + exec\s*.+\s* + + # optionally quoted executable name (via $0) + .?\$$var.?\s* + + # optional "end of options" indicator + (--\s*)? + + # 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 + .?(\${1:?\+.?)?(\$(\@|\*))?~x) { + $ret = 1; + last; + } elsif (/^\s*(\w+)=\$0;/) { + $var = $1; + } elsif (m~ + # Match scripts which use "foo $0 $@ &\nexec true\n" + # Program name + \S+\s+ + + # As above + .?\$$var.?\s* + (--\s*)? + .?(\${1:?\+.?)?(\$(\@|\*))?.?\s*\&~x) { + + $backgrounded = 1; + } elsif ($backgrounded and m~ + # the exec should either be "eval"ed or a new statement + (^\s*|\beval\s*[\'\"]|(;|&&)\s*) + exec\s+true(\s|\Z)~x) { + + $ret = $1; + last; + } + } + close IN; + return $ret; +} + +# Given an interpretor and a file, run the interpretor on that file with the +# -n option to check syntax, discarding output and returning the exit status. +sub check_script_syntax { + my ($interpreter, $script) = @_; + my $pid = fork; + if (!defined $pid) { + fail("cannot fork: $!"); + } elsif ($pid == 0) { + open STDOUT, '>/dev/null' or fail("cannot reopen stdout: $!"); + open STDERR, '>&STDOUT' or fail("cannot reopen stderr: $!"); + exec $interpreter, '-n', $script + or fail("cannot exec $interpreter: $!"); + } else { + waitpid $pid, 0; + } + return $?; +} + +1; + +# Local Variables: +# indent-tabs-mode: t +# cperl-indent-level: 4 +# End: +# vim: syntax=perl ts=8 sw=4