OpenPKG Specs: openpkg/lint-rpm.pl@a2c6460cfb16 (annotated)

openpkg/lint-rpm.pl@a2c6460cfb16 (annotated)

openpkg/lint-rpm.pl

Mon, 28 Jan 2013 17:37:18 +0100

author: Michael Schloh von Bennewitz <michael@schloh.com>
date: Mon, 28 Jan 2013 17:37:18 +0100
changeset 758: a2c6460cfb16
permissions: -rw-r--r--

Correct socket error reporting improvement with IPv6 portable code,
after helpful recommendation by Saúl Ibarra Corretgé on OSips devlist.

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

OpenPKG Specs / annotate

openpkg/lint-rpm.pl@a2c6460cfb16 (annotated)

openpkg/lint-rpm.pl