michael@428: ## michael@428: ## lint-rpm.pl -- OpenPKG *.rpm File Checker michael@428: ## Copyright (c) 2000-2012 OpenPKG GmbH michael@428: ## michael@428: ## This software is property of the OpenPKG GmbH, DE MUC HRB 160208. michael@428: ## All rights reserved. Licenses which grant limited permission to use, michael@428: ## copy, modify and distribute this software are available from the michael@428: ## OpenPKG GmbH. michael@428: ## michael@428: ## THIS SOFTWARE IS PROVIDED "AS IS" AND ANY EXPRESSED OR IMPLIED michael@428: ## WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF michael@428: ## MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. michael@428: ## IN NO EVENT SHALL THE AUTHORS AND COPYRIGHT HOLDERS AND THEIR michael@428: ## CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, michael@428: ## SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT michael@428: ## LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF michael@428: ## USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND michael@428: ## ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, michael@428: ## OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT michael@428: ## OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF michael@428: ## SUCH DAMAGE. michael@428: ## michael@428: michael@428: # Perl run-time requirement michael@428: require 5; michael@428: BEGIN { michael@428: eval "use Getopt::Long; use IO;"; michael@428: if ($@) { michael@428: print STDERR michael@428: "lint-rpm: ERROR: This command requires a full-size Perl installation!\n" . michael@428: "lint-rpm: HINT: Install OpenPKG \"perl\" package to use this command.\n"; michael@428: exit(1); michael@428: } michael@428: } michael@428: michael@428: # OpenPKG instance prefix michael@428: my $my_prefix = $ENV{'OPENPKG_PREFIX'}; michael@428: delete $ENV{'OPENPKG_PREFIX'}; michael@428: michael@428: # program information michael@428: my $progname = "lint-rpm"; michael@428: my $progvers = "1.0.0"; michael@428: michael@428: # parameters (defaults) michael@428: my $version = 0; michael@428: my $verbose = 0; michael@428: my $help = 0; michael@428: my $check = 'all'; michael@428: my $tmpdir = ($ENV{TMPDIR} || $ENV{TEMPDIR} || "/tmp") . "/$progname"; michael@428: my $rpm = "$my_prefix/bin/openpkg rpm"; michael@428: my $rpm2cpio = "$my_prefix/bin/openpkg rpm2cpio"; michael@428: michael@428: # exception handling support michael@428: $SIG{__DIE__} = sub { michael@428: my ($err) = @_; michael@428: $err =~ s|\s+at\s+.*||s if (not $verbose); michael@428: print STDERR "$progname:ERROR: $err ". ($! ? "($!)" : "") . "\n"; michael@428: exit(1); michael@428: }; michael@428: michael@428: # command line parsing michael@428: Getopt::Long::Configure("bundling"); michael@428: my $result = GetOptions( michael@428: 'V|version' => \$version, michael@428: 'v|verbose' => \$verbose, michael@428: 'h|help' => \$help, michael@428: 'c|check=s' => \$check, michael@428: 't|tmpdir=s' => \$tmpdir, michael@428: 'r|rpm=s' => \$rpm, michael@428: ) || die "option parsing failed"; michael@428: if ($help) { michael@428: print "Usage: $progname [options] [RPMFILE ...]\n" . michael@428: "Available options:\n" . michael@428: " -v,--verbose enable verbose run-time mode\n" . michael@428: " -h,--help print out this usage page\n" . michael@428: " -c,--check=CHECKS select checks to perform (default='all')\n" . michael@428: " -r,--rpm=FILE filesystem path to RPM program\n" . michael@428: " -t,--tmpdir=PATH filesystem path to temporary directory\n" . michael@428: " -V,--version print program version\n"; michael@428: exit(0); michael@428: } michael@428: if ($version) { michael@428: print "OpenPKG $progname $progvers\n"; michael@428: exit(0); michael@428: } michael@428: michael@428: # verbose message printing michael@428: sub msg_verbose { michael@428: my ($msg) = @_; michael@428: print STDERR "$msg\n" if ($verbose); michael@428: } michael@428: michael@428: # warning message printing michael@428: sub msg_warning { michael@428: my ($msg) = @_; michael@428: print STDERR "$progname:WARNING: $msg\n"; michael@428: } michael@428: michael@428: # error message printing michael@428: sub msg_error { michael@428: my ($msg) = @_; michael@428: print STDERR "$progname:ERROR: $msg\n"; michael@428: } michael@428: michael@428: # determine check list michael@428: my @check_list = (qw( michael@428: layout michael@428: attrib michael@428: content michael@428: )); michael@428: my @checks = (); michael@428: if ($check eq 'all') { michael@428: @checks = @check_list; michael@428: } michael@428: else { michael@428: foreach my $c (split(/,/, $check)) { michael@428: if (not grep(/^$c$/, @check_list)) { michael@428: die "invalid check \"$c\""; michael@428: } michael@428: push(@checks, $c); michael@428: } michael@428: } michael@428: michael@428: # global return code michael@428: $main::GRC = 0; michael@428: michael@428: # environment preparation michael@428: system("rm -rf $tmpdir"); michael@428: system("mkdir -p $tmpdir"); michael@428: michael@428: # iterate over all .rpm files michael@428: foreach my $filename (@ARGV) { michael@428: die "unable to open file \"$filename\" for reading" michael@428: if (not -f $filename); michael@428: my $info = &rpm_info($filename, \@checks); michael@428: foreach my $check (@checks) { michael@428: eval "\&check_$check(\$filename, \$info);"; michael@428: } michael@428: &rpm_info_cleanup($filename, \@checks, $info); michael@428: } michael@428: michael@428: # environment cleanup michael@428: system("rm -rf $tmpdir"); michael@428: michael@428: # die gracefully michael@428: exit($main::GRC); michael@428: michael@428: ## _________________________________________________________________ michael@428: ## michael@428: ## COMMON SUBROUTINES michael@428: ## _________________________________________________________________ michael@428: ## michael@428: michael@428: sub lint_message { michael@428: my ($type, $file, $msg) = @_; michael@428: $file =~ s|^.+?/([^/]+)$|$1|s; michael@428: printf(STDERR "%s:%s: %s: %s\n", $progname, $type, $file, $msg); michael@428: } michael@428: michael@428: sub lint_warning { michael@428: my ($file, $msg) = @_; michael@428: &lint_message("WARNING", $file, $msg); michael@428: $main::GRC = 1 if ($main::GRC < 1); michael@428: } michael@428: michael@428: sub lint_error { michael@428: my ($file, $msg) = @_; michael@428: &lint_message("ERROR", $file, $msg); michael@428: $main::GRC = 2 if ($main::GRC < 2); michael@428: } michael@428: michael@428: ## _________________________________________________________________ michael@428: ## michael@428: ## RPM INFORMATION GATHERING michael@428: ## _________________________________________________________________ michael@428: ## michael@428: michael@428: sub rpm_info { michael@428: my ($filename, $checks) = @_; michael@428: my $info = {}; michael@428: michael@428: # query package name michael@428: &msg_verbose("++ querying RPM package name"); michael@428: $info->{name} = `$rpm -qp --qf '%{NAME}' $filename`; michael@428: michael@428: # query prefix michael@428: &msg_verbose("++ querying RPM package installation prefix"); michael@428: $info->{prefix} = `$rpm -qp --qf '%{PREFIXES}' $filename`; michael@428: michael@428: # query file listing michael@428: &msg_verbose("++ querying RPM package file listing"); michael@428: my @list = `$rpm -qplv $filename`; michael@428: my @config = `$rpm -qplc $filename`; michael@428: michael@428: # process file listing michael@428: $info->{ls} = {}; michael@428: foreach my $entry (@list) { michael@428: if ($entry =~ m|^\(contains no files\)\s*$|s) { michael@428: next; michael@428: } michael@428: elsif ($entry =~ m|^(\S+)\s+(\d+)\s+(\S+)\s+(\S+)\s+(\d+)\s+(.{12})\s+(.+)\s*$|s) { michael@428: my ($perm, $links, $owner, $group, $size, $mtime, $path) = ($1, $2, $3, $4, $5, $6, $7); michael@428: my $symlink = ""; michael@428: if ($path =~ m|^(\S+)\s+->\s+(\S+)$|) { michael@428: ($path, $symlink) = ($1, $2); michael@428: } michael@428: $path =~ s|\s+$||s; michael@428: my $config = 0; michael@428: if (grep(m|^$path$|, @config)) { michael@428: $config = 1; michael@428: } michael@428: $info->{ls}->{$path} = { michael@428: 'perm' => $perm, michael@428: 'links' => $links, michael@428: 'owner' => $owner, michael@428: 'group' => $group, michael@428: 'size' => $size, michael@428: 'time' => $mtime, michael@428: 'path' => $path, michael@428: 'symlink' => $symlink, michael@428: 'config' => $config, michael@428: }; michael@428: } michael@428: else { michael@428: &lint_error($filename, "invalid file listing entry: \"$entry\""); michael@428: } michael@428: } michael@428: michael@428: # unpacking files michael@428: if (grep(/^content$/, @{$checks})) { michael@428: &msg_verbose("++ unpacking RPM package files"); michael@428: $info->{root} = "$tmpdir/root"; michael@428: system("mkdir -p ".$info->{root}); michael@428: system("$rpm2cpio $filename | (cd ".$info->{root}." && cpio -idmu 2>/dev/null)"); michael@428: } michael@428: michael@428: return $info; michael@428: } michael@428: michael@428: sub rpm_info_cleanup { michael@428: my ($filename, $checks, $info) = @_; michael@428: michael@428: if (grep(/^content$/, @{$checks})) { michael@428: system("rm -rf ".$info->{root}) if ($info->{root} =~ m/^\/.+/ and -d $info->{root}); michael@428: } michael@428: } michael@428: michael@428: ## _________________________________________________________________ michael@428: ## michael@428: ## CHECK "layout": file path layout michael@428: ## _________________________________________________________________ michael@428: ## michael@428: michael@428: sub check_layout { michael@428: my ($rpm, $info) = @_; michael@428: michael@428: # no need to check 'openpkg' package because it michael@428: # has a hard-coded file list! michael@428: return if ($rpm =~ m|^(.+?/)?openpkg-\d[^/]+$|); michael@428: michael@428: # check prefix michael@428: if ($info->{prefix} !~ m|^/.+$|) { michael@428: &lint_error($rpm, "invalid installation prefix ".$info->{prefix}. michael@428: " (expected to match \"^/.+\$\")"); michael@428: return; michael@428: } michael@428: michael@428: # check top-level path (all-in-one) michael@428: my @topdirs = (qw( michael@428: bin cgi etc include info lib libexec michael@428: local man pub sbin share usr var michael@428: )); michael@428: my $topdirs = "{".join(",", @topdirs)."}"; michael@428: if (not keys(%{$info->{ls}})) { michael@428: &lint_error($rpm, "invalid empty package (expected at least one file)"); michael@428: return; michael@428: } michael@428: foreach my $path (keys(%{$info->{ls}})) { michael@428: my $ok = 0; michael@428: foreach my $topdir (@topdirs) { michael@428: my $prefix = quotemeta($info->{prefix} . "/" . $topdir); michael@428: if ($path =~ m/^$prefix$/ && $rpm !~ m|^openpkg-\d+|) { michael@428: &lint_error($rpm, "top-level directory \"$topdir\" provided" . michael@428: " (expected none except for 'openpkg' package)"); michael@428: } michael@428: if ($path =~ m/^$prefix/) { michael@428: $ok = 1; michael@428: last; michael@428: } michael@428: } michael@428: if (not $ok) { michael@428: &lint_error($rpm, "invalid top-level directory in path \"$path\"". michael@428: " (expected one of $topdirs)"); michael@428: } michael@428: } michael@428: michael@428: # check for second-level path (all-in-one) michael@428: my @topdirs_subdir_no = (qw(bin cgi info sbin)); michael@428: my @topdirs_subdir_yes = (qw(etc libexec share var)); michael@428: foreach my $path (keys(%{$info->{ls}})) { michael@428: foreach my $topdir (@topdirs_subdir_yes) { michael@428: my $prefix = quotemeta($info->{prefix} . "/" . $topdir); michael@428: if ($path =~ m/^$prefix\/[^\/]+$/) { michael@428: if ($info->{ls}->{$path}->{perm} !~ m|^d|) { michael@428: &lint_error($rpm, "invalid positioned file \"$path\" under topdir \"$topdir\" (expected directory)"); michael@428: } michael@428: } michael@428: } michael@428: foreach my $topdir (@topdirs_subdir_no) { michael@428: my $prefix = quotemeta($info->{prefix} . "/" . $topdir); michael@428: if ($path =~ m/^$prefix\/[^\/]+$/) { michael@428: if ($info->{ls}->{$path}->{perm} =~ m|^d|) { michael@428: &lint_error($rpm, "invalid positioned directory \"$path\" under topdir \"$topdir\" (expected file)"); michael@428: } michael@428: } michael@428: } michael@428: } michael@428: michael@428: # check "bin" and "sbin" directories michael@428: foreach my $path (keys(%{$info->{ls}})) { michael@428: foreach my $topdir (qw(bin sbin)) { michael@428: my $prefix = quotemeta($info->{prefix} . "/" . $topdir); michael@428: if ($path =~ m/^$prefix\/(.+)$/) { michael@428: my $file = $1; michael@428: if ($file =~ m|^[^/]+\.[^/.]+$|) { michael@428: &lint_warning($rpm, "strange executable filename \"$path\" containing an extension (expected no extension)"); michael@428: } michael@428: my $perm = $info->{ls}->{$path}->{'perm'}; michael@428: if ($perm =~ m|^-| && $perm !~ m|^-[-r][-w][sx][-r][-w][-sx][-r][-w][-tx]$|) { michael@428: &lint_error($rpm, "non-executable file \"$path\" (with permissions \"$perm\" under topdir \"$topdir\" (expected to be executable)"); michael@428: } michael@428: } michael@428: } michael@428: } michael@428: michael@428: # check for symbolic link targets (outside absolute, dangling) michael@428: foreach my $path (keys(%{$info->{ls}})) { michael@428: my $symlink = $info->{ls}->{$path}->{'symlink'}; michael@428: if ($symlink ne '') { michael@428: # check for outside absolute target michael@428: my $prefix = quotemeta($info->{prefix}); michael@428: if ($symlink =~ m|^/.*| and $symlink !~ m|^$prefix|s) { michael@428: &lint_warning($rpm, "symbolic link \"$path\" points to absolute path \"$symlink\" outside prefix \"$info->{prefix}\" (expected it to be under prefix only)"); michael@428: } michael@428: # check for dangling target michael@428: my $resolved = &resolve($info, $path); michael@428: sub resolve { michael@428: my ($info, $path) = @_; michael@428: if (not defined($info->{ls}->{$path})) { michael@428: return $path; michael@428: } michael@428: my $symlink = $info->{ls}->{$path}->{'symlink'}; michael@428: if ($symlink eq '') { michael@428: return $path; michael@428: } michael@428: else { michael@428: my $resolved; michael@428: if ($symlink =~ m|^/|) { michael@428: $resolved = $symlink; michael@428: } michael@428: else { michael@428: $resolved = $path; michael@428: $resolved =~ s|/[^/]+$||s; michael@428: $resolved .= "/" . $symlink; michael@428: $resolved =~ s|/{2,}|/|sg; michael@428: $resolved =~ s|/\.(?=/)||sg; michael@428: $resolved =~ s|/\.$||sg; michael@428: 1 while ($resolved =~ s|/[^/]+/\.\./|/|s); michael@428: $resolved =~ s|/[^/]+/\.\.$||s; michael@428: $resolved =~ s|(.)/$|$1|s; michael@428: } michael@428: return &resolve($info, $resolved); michael@428: } michael@428: } michael@428: if (not defined($info->{ls}->{$resolved})) { michael@428: &lint_error($rpm, "symbolic link \"$path\" points to not existing target path \"$resolved\" (expected existing target path)"); michael@428: } michael@428: } michael@428: } michael@428: } michael@428: michael@428: ## _________________________________________________________________ michael@428: ## michael@428: ## CHECK "attrib": file attributes michael@428: ## _________________________________________________________________ michael@428: ## michael@428: michael@428: sub check_attrib { michael@428: my ($rpm, $info) = @_; michael@428: michael@428: # check for empty files michael@428: foreach my $path (keys(%{$info->{ls}})) { michael@428: if ( $info->{ls}->{$path}->{'size'} == 0 michael@428: and $info->{ls}->{$path}->{'perm'} !~ m|^d| michael@428: and $path !~ m/^.*\/lib\/perl\/.+\.bs$/ michael@428: and $rpm !~ m/\bopenpkg-[0-9]+/) { michael@428: &lint_warning($rpm, "empty file \"$path\" found (expected no empty files)"); michael@428: } michael@428: } michael@428: michael@428: # check for %config flagged files michael@428: my $prefix = quotemeta($info->{'prefix'}); michael@428: my $name = quotemeta($info->{'name'}); michael@428: foreach my $path (keys(%{$info->{ls}})) { michael@428: my $config = $info->{ls}->{$path}->{'config'}; michael@428: my $path = $info->{ls}->{$path}->{'path'}; michael@428: if ($rpm !~ m/\bopenpkg-[0-9]+/ and $config and $path !~ m/^$prefix\/etc\/($name\d*|fsl)\/.+/) { michael@428: &lint_warning($rpm, "non-config file \"$path\" flagged as \%config (expected only \"$prefix/etc/$name/*\" files to be \%config files)"); michael@428: } michael@428: if ($config and $path =~ m/^$prefix\/s?bin\/[^\/]+$/) { michael@428: &lint_error($rpm, "executable file \"$path\" flagged as \%config"); michael@428: } michael@428: if ($config and $path =~ m/^$prefix\/etc\/rc\.d\/rc\.$name$/) { michael@428: &lint_error($rpm, "run-command file \"$path\" flagged as \%config"); michael@428: } michael@428: } michael@428: michael@428: # check for permissions michael@428: foreach my $path (keys(%{$info->{ls}})) { michael@428: my $perm = $info->{ls}->{$path}->{'perm'}; michael@428: if ($path =~ m/^$prefix\/(bin|sbin)\/[^\/]+$/) { michael@428: if ($perm !~ m|^[^d]..[xs]..[xs]..[xt]$|) { michael@428: &lint_warning($rpm, "executable file \"$path\" has permissions \"$perm\" only (expected it to be executable by everyone)"); michael@428: } michael@428: } michael@428: } michael@428: michael@428: # TODO: user/group? michael@428: } michael@428: michael@428: ## _________________________________________________________________ michael@428: ## michael@428: ## CHECK "content": file content michael@428: ## _________________________________________________________________ michael@428: ## michael@428: michael@428: sub check_content { michael@428: my ($rpm, $info) = @_; michael@428: michael@428: # TODO: stripped (file) michael@428: # TODO: syslibs (ldd) michael@428: # TODO: hard-coded paths pointing outside instance michael@428: # TODO: sanity check for shebang-lines michael@428: # TODO: contained temporary path michael@428: # TODO: bad-files: .po michael@428: } michael@428: