comparison: openpkg/lint-rpm.pl
openpkg/lint-rpm.pl
- changeset 514
- b0b94589986b
equal
deleted
inserted
replaced
| -1:000000000000 | 0:da6050461589 |
|---|---|
| 1 ## | |
| 2 ## lint-rpm.pl -- OpenPKG *.rpm File Checker | |
| 3 ## Copyright (c) 2000-2012 OpenPKG GmbH <http://openpkg.com/> | |
| 4 ## | |
| 5 ## This software is property of the OpenPKG GmbH, DE MUC HRB 160208. | |
| 6 ## All rights reserved. Licenses which grant limited permission to use, | |
| 7 ## copy, modify and distribute this software are available from the | |
| 8 ## OpenPKG GmbH. | |
| 9 ## | |
| 10 ## THIS SOFTWARE IS PROVIDED "AS IS" AND ANY EXPRESSED OR IMPLIED | |
| 11 ## WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF | |
| 12 ## MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. | |
| 13 ## IN NO EVENT SHALL THE AUTHORS AND COPYRIGHT HOLDERS AND THEIR | |
| 14 ## CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, | |
| 15 ## SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT | |
| 16 ## LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF | |
| 17 ## USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND | |
| 18 ## ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, | |
| 19 ## OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT | |
| 20 ## OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF | |
| 21 ## SUCH DAMAGE. | |
| 22 ## | |
| 23 | |
| 24 # Perl run-time requirement | |
| 25 require 5; | |
| 26 BEGIN { | |
| 27 eval "use Getopt::Long; use IO;"; | |
| 28 if ($@) { | |
| 29 print STDERR | |
| 30 "lint-rpm: ERROR: This command requires a full-size Perl installation!\n" . | |
| 31 "lint-rpm: HINT: Install OpenPKG \"perl\" package to use this command.\n"; | |
| 32 exit(1); | |
| 33 } | |
| 34 } | |
| 35 | |
| 36 # OpenPKG instance prefix | |
| 37 my $my_prefix = $ENV{'OPENPKG_PREFIX'}; | |
| 38 delete $ENV{'OPENPKG_PREFIX'}; | |
| 39 | |
| 40 # program information | |
| 41 my $progname = "lint-rpm"; | |
| 42 my $progvers = "1.0.0"; | |
| 43 | |
| 44 # parameters (defaults) | |
| 45 my $version = 0; | |
| 46 my $verbose = 0; | |
| 47 my $help = 0; | |
| 48 my $check = 'all'; | |
| 49 my $tmpdir = ($ENV{TMPDIR} || $ENV{TEMPDIR} || "/tmp") . "/$progname"; | |
| 50 my $rpm = "$my_prefix/bin/openpkg rpm"; | |
| 51 my $rpm2cpio = "$my_prefix/bin/openpkg rpm2cpio"; | |
| 52 | |
| 53 # exception handling support | |
| 54 $SIG{__DIE__} = sub { | |
| 55 my ($err) = @_; | |
| 56 $err =~ s|\s+at\s+.*||s if (not $verbose); | |
| 57 print STDERR "$progname:ERROR: $err ". ($! ? "($!)" : "") . "\n"; | |
| 58 exit(1); | |
| 59 }; | |
| 60 | |
| 61 # command line parsing | |
| 62 Getopt::Long::Configure("bundling"); | |
| 63 my $result = GetOptions( | |
| 64 'V|version' => \$version, | |
| 65 'v|verbose' => \$verbose, | |
| 66 'h|help' => \$help, | |
| 67 'c|check=s' => \$check, | |
| 68 't|tmpdir=s' => \$tmpdir, | |
| 69 'r|rpm=s' => \$rpm, | |
| 70 ) || die "option parsing failed"; | |
| 71 if ($help) { | |
| 72 print "Usage: $progname [options] [RPMFILE ...]\n" . | |
| 73 "Available options:\n" . | |
| 74 " -v,--verbose enable verbose run-time mode\n" . | |
| 75 " -h,--help print out this usage page\n" . | |
| 76 " -c,--check=CHECKS select checks to perform (default='all')\n" . | |
| 77 " -r,--rpm=FILE filesystem path to RPM program\n" . | |
| 78 " -t,--tmpdir=PATH filesystem path to temporary directory\n" . | |
| 79 " -V,--version print program version\n"; | |
| 80 exit(0); | |
| 81 } | |
| 82 if ($version) { | |
| 83 print "OpenPKG $progname $progvers\n"; | |
| 84 exit(0); | |
| 85 } | |
| 86 | |
| 87 # verbose message printing | |
| 88 sub msg_verbose { | |
| 89 my ($msg) = @_; | |
| 90 print STDERR "$msg\n" if ($verbose); | |
| 91 } | |
| 92 | |
| 93 # warning message printing | |
| 94 sub msg_warning { | |
| 95 my ($msg) = @_; | |
| 96 print STDERR "$progname:WARNING: $msg\n"; | |
| 97 } | |
| 98 | |
| 99 # error message printing | |
| 100 sub msg_error { | |
| 101 my ($msg) = @_; | |
| 102 print STDERR "$progname:ERROR: $msg\n"; | |
| 103 } | |
| 104 | |
| 105 # determine check list | |
| 106 my @check_list = (qw( | |
| 107 layout | |
| 108 attrib | |
| 109 content | |
| 110 )); | |
| 111 my @checks = (); | |
| 112 if ($check eq 'all') { | |
| 113 @checks = @check_list; | |
| 114 } | |
| 115 else { | |
| 116 foreach my $c (split(/,/, $check)) { | |
| 117 if (not grep(/^$c$/, @check_list)) { | |
| 118 die "invalid check \"$c\""; | |
| 119 } | |
| 120 push(@checks, $c); | |
| 121 } | |
| 122 } | |
| 123 | |
| 124 # global return code | |
| 125 $main::GRC = 0; | |
| 126 | |
| 127 # environment preparation | |
| 128 system("rm -rf $tmpdir"); | |
| 129 system("mkdir -p $tmpdir"); | |
| 130 | |
| 131 # iterate over all .rpm files | |
| 132 foreach my $filename (@ARGV) { | |
| 133 die "unable to open file \"$filename\" for reading" | |
| 134 if (not -f $filename); | |
| 135 my $info = &rpm_info($filename, \@checks); | |
| 136 foreach my $check (@checks) { | |
| 137 eval "\&check_$check(\$filename, \$info);"; | |
| 138 } | |
| 139 &rpm_info_cleanup($filename, \@checks, $info); | |
| 140 } | |
| 141 | |
| 142 # environment cleanup | |
| 143 system("rm -rf $tmpdir"); | |
| 144 | |
| 145 # die gracefully | |
| 146 exit($main::GRC); | |
| 147 | |
| 148 ## _________________________________________________________________ | |
| 149 ## | |
| 150 ## COMMON SUBROUTINES | |
| 151 ## _________________________________________________________________ | |
| 152 ## | |
| 153 | |
| 154 sub lint_message { | |
| 155 my ($type, $file, $msg) = @_; | |
| 156 $file =~ s|^.+?/([^/]+)$|$1|s; | |
| 157 printf(STDERR "%s:%s: %s: %s\n", $progname, $type, $file, $msg); | |
| 158 } | |
| 159 | |
| 160 sub lint_warning { | |
| 161 my ($file, $msg) = @_; | |
| 162 &lint_message("WARNING", $file, $msg); | |
| 163 $main::GRC = 1 if ($main::GRC < 1); | |
| 164 } | |
| 165 | |
| 166 sub lint_error { | |
| 167 my ($file, $msg) = @_; | |
| 168 &lint_message("ERROR", $file, $msg); | |
| 169 $main::GRC = 2 if ($main::GRC < 2); | |
| 170 } | |
| 171 | |
| 172 ## _________________________________________________________________ | |
| 173 ## | |
| 174 ## RPM INFORMATION GATHERING | |
| 175 ## _________________________________________________________________ | |
| 176 ## | |
| 177 | |
| 178 sub rpm_info { | |
| 179 my ($filename, $checks) = @_; | |
| 180 my $info = {}; | |
| 181 | |
| 182 # query package name | |
| 183 &msg_verbose("++ querying RPM package name"); | |
| 184 $info->{name} = `$rpm -qp --qf '%{NAME}' $filename`; | |
| 185 | |
| 186 # query prefix | |
| 187 &msg_verbose("++ querying RPM package installation prefix"); | |
| 188 $info->{prefix} = `$rpm -qp --qf '%{PREFIXES}' $filename`; | |
| 189 | |
| 190 # query file listing | |
| 191 &msg_verbose("++ querying RPM package file listing"); | |
| 192 my @list = `$rpm -qplv $filename`; | |
| 193 my @config = `$rpm -qplc $filename`; | |
| 194 | |
| 195 # process file listing | |
| 196 $info->{ls} = {}; | |
| 197 foreach my $entry (@list) { | |
| 198 if ($entry =~ m|^\(contains no files\)\s*$|s) { | |
| 199 next; | |
| 200 } | |
| 201 elsif ($entry =~ m|^(\S+)\s+(\d+)\s+(\S+)\s+(\S+)\s+(\d+)\s+(.{12})\s+(.+)\s*$|s) { | |
| 202 my ($perm, $links, $owner, $group, $size, $mtime, $path) = ($1, $2, $3, $4, $5, $6, $7); | |
| 203 my $symlink = ""; | |
| 204 if ($path =~ m|^(\S+)\s+->\s+(\S+)$|) { | |
| 205 ($path, $symlink) = ($1, $2); | |
| 206 } | |
| 207 $path =~ s|\s+$||s; | |
| 208 my $config = 0; | |
| 209 if (grep(m|^$path$|, @config)) { | |
| 210 $config = 1; | |
| 211 } | |
| 212 $info->{ls}->{$path} = { | |
| 213 'perm' => $perm, | |
| 214 'links' => $links, | |
| 215 'owner' => $owner, | |
| 216 'group' => $group, | |
| 217 'size' => $size, | |
| 218 'time' => $mtime, | |
| 219 'path' => $path, | |
| 220 'symlink' => $symlink, | |
| 221 'config' => $config, | |
| 222 }; | |
| 223 } | |
| 224 else { | |
| 225 &lint_error($filename, "invalid file listing entry: \"$entry\""); | |
| 226 } | |
| 227 } | |
| 228 | |
| 229 # unpacking files | |
| 230 if (grep(/^content$/, @{$checks})) { | |
| 231 &msg_verbose("++ unpacking RPM package files"); | |
| 232 $info->{root} = "$tmpdir/root"; | |
| 233 system("mkdir -p ".$info->{root}); | |
| 234 system("$rpm2cpio $filename | (cd ".$info->{root}." && cpio -idmu 2>/dev/null)"); | |
| 235 } | |
| 236 | |
| 237 return $info; | |
| 238 } | |
| 239 | |
| 240 sub rpm_info_cleanup { | |
| 241 my ($filename, $checks, $info) = @_; | |
| 242 | |
| 243 if (grep(/^content$/, @{$checks})) { | |
| 244 system("rm -rf ".$info->{root}) if ($info->{root} =~ m/^\/.+/ and -d $info->{root}); | |
| 245 } | |
| 246 } | |
| 247 | |
| 248 ## _________________________________________________________________ | |
| 249 ## | |
| 250 ## CHECK "layout": file path layout | |
| 251 ## _________________________________________________________________ | |
| 252 ## | |
| 253 | |
| 254 sub check_layout { | |
| 255 my ($rpm, $info) = @_; | |
| 256 | |
| 257 # no need to check 'openpkg' package because it | |
| 258 # has a hard-coded file list! | |
| 259 return if ($rpm =~ m|^(.+?/)?openpkg-\d[^/]+$|); | |
| 260 | |
| 261 # check prefix | |
| 262 if ($info->{prefix} !~ m|^/.+$|) { | |
| 263 &lint_error($rpm, "invalid installation prefix ".$info->{prefix}. | |
| 264 " (expected to match \"^/.+\$\")"); | |
| 265 return; | |
| 266 } | |
| 267 | |
| 268 # check top-level path (all-in-one) | |
| 269 my @topdirs = (qw( | |
| 270 bin cgi etc include info lib libexec | |
| 271 local man pub sbin share usr var | |
| 272 )); | |
| 273 my $topdirs = "{".join(",", @topdirs)."}"; | |
| 274 if (not keys(%{$info->{ls}})) { | |
| 275 &lint_error($rpm, "invalid empty package (expected at least one file)"); | |
| 276 return; | |
| 277 } | |
| 278 foreach my $path (keys(%{$info->{ls}})) { | |
| 279 my $ok = 0; | |
| 280 foreach my $topdir (@topdirs) { | |
| 281 my $prefix = quotemeta($info->{prefix} . "/" . $topdir); | |
| 282 if ($path =~ m/^$prefix$/ && $rpm !~ m|^openpkg-\d+|) { | |
| 283 &lint_error($rpm, "top-level directory \"$topdir\" provided" . | |
| 284 " (expected none except for 'openpkg' package)"); | |
| 285 } | |
| 286 if ($path =~ m/^$prefix/) { | |
| 287 $ok = 1; | |
| 288 last; | |
| 289 } | |
| 290 } | |
| 291 if (not $ok) { | |
| 292 &lint_error($rpm, "invalid top-level directory in path \"$path\"". | |
| 293 " (expected one of $topdirs)"); | |
| 294 } | |
| 295 } | |
| 296 | |
| 297 # check for second-level path (all-in-one) | |
| 298 my @topdirs_subdir_no = (qw(bin cgi info sbin)); | |
| 299 my @topdirs_subdir_yes = (qw(etc libexec share var)); | |
| 300 foreach my $path (keys(%{$info->{ls}})) { | |
| 301 foreach my $topdir (@topdirs_subdir_yes) { | |
| 302 my $prefix = quotemeta($info->{prefix} . "/" . $topdir); | |
| 303 if ($path =~ m/^$prefix\/[^\/]+$/) { | |
| 304 if ($info->{ls}->{$path}->{perm} !~ m|^d|) { | |
| 305 &lint_error($rpm, "invalid positioned file \"$path\" under topdir \"$topdir\" (expected directory)"); | |
| 306 } | |
| 307 } | |
| 308 } | |
| 309 foreach my $topdir (@topdirs_subdir_no) { | |
| 310 my $prefix = quotemeta($info->{prefix} . "/" . $topdir); | |
| 311 if ($path =~ m/^$prefix\/[^\/]+$/) { | |
| 312 if ($info->{ls}->{$path}->{perm} =~ m|^d|) { | |
| 313 &lint_error($rpm, "invalid positioned directory \"$path\" under topdir \"$topdir\" (expected file)"); | |
| 314 } | |
| 315 } | |
| 316 } | |
| 317 } | |
| 318 | |
| 319 # check "bin" and "sbin" directories | |
| 320 foreach my $path (keys(%{$info->{ls}})) { | |
| 321 foreach my $topdir (qw(bin sbin)) { | |
| 322 my $prefix = quotemeta($info->{prefix} . "/" . $topdir); | |
| 323 if ($path =~ m/^$prefix\/(.+)$/) { | |
| 324 my $file = $1; | |
| 325 if ($file =~ m|^[^/]+\.[^/.]+$|) { | |
| 326 &lint_warning($rpm, "strange executable filename \"$path\" containing an extension (expected no extension)"); | |
| 327 } | |
| 328 my $perm = $info->{ls}->{$path}->{'perm'}; | |
| 329 if ($perm =~ m|^-| && $perm !~ m|^-[-r][-w][sx][-r][-w][-sx][-r][-w][-tx]$|) { | |
| 330 &lint_error($rpm, "non-executable file \"$path\" (with permissions \"$perm\" under topdir \"$topdir\" (expected to be executable)"); | |
| 331 } | |
| 332 } | |
| 333 } | |
| 334 } | |
| 335 | |
| 336 # check for symbolic link targets (outside absolute, dangling) | |
| 337 foreach my $path (keys(%{$info->{ls}})) { | |
| 338 my $symlink = $info->{ls}->{$path}->{'symlink'}; | |
| 339 if ($symlink ne '') { | |
| 340 # check for outside absolute target | |
| 341 my $prefix = quotemeta($info->{prefix}); | |
| 342 if ($symlink =~ m|^/.*| and $symlink !~ m|^$prefix|s) { | |
| 343 &lint_warning($rpm, "symbolic link \"$path\" points to absolute path \"$symlink\" outside prefix \"$info->{prefix}\" (expected it to be under prefix only)"); | |
| 344 } | |
| 345 # check for dangling target | |
| 346 my $resolved = &resolve($info, $path); | |
| 347 sub resolve { | |
| 348 my ($info, $path) = @_; | |
| 349 if (not defined($info->{ls}->{$path})) { | |
| 350 return $path; | |
| 351 } | |
| 352 my $symlink = $info->{ls}->{$path}->{'symlink'}; | |
| 353 if ($symlink eq '') { | |
| 354 return $path; | |
| 355 } | |
| 356 else { | |
| 357 my $resolved; | |
| 358 if ($symlink =~ m|^/|) { | |
| 359 $resolved = $symlink; | |
| 360 } | |
| 361 else { | |
| 362 $resolved = $path; | |
| 363 $resolved =~ s|/[^/]+$||s; | |
| 364 $resolved .= "/" . $symlink; | |
| 365 $resolved =~ s|/{2,}|/|sg; | |
| 366 $resolved =~ s|/\.(?=/)||sg; | |
| 367 $resolved =~ s|/\.$||sg; | |
| 368 1 while ($resolved =~ s|/[^/]+/\.\./|/|s); | |
| 369 $resolved =~ s|/[^/]+/\.\.$||s; | |
| 370 $resolved =~ s|(.)/$|$1|s; | |
| 371 } | |
| 372 return &resolve($info, $resolved); | |
| 373 } | |
| 374 } | |
| 375 if (not defined($info->{ls}->{$resolved})) { | |
| 376 &lint_error($rpm, "symbolic link \"$path\" points to not existing target path \"$resolved\" (expected existing target path)"); | |
| 377 } | |
| 378 } | |
| 379 } | |
| 380 } | |
| 381 | |
| 382 ## _________________________________________________________________ | |
| 383 ## | |
| 384 ## CHECK "attrib": file attributes | |
| 385 ## _________________________________________________________________ | |
| 386 ## | |
| 387 | |
| 388 sub check_attrib { | |
| 389 my ($rpm, $info) = @_; | |
| 390 | |
| 391 # check for empty files | |
| 392 foreach my $path (keys(%{$info->{ls}})) { | |
| 393 if ( $info->{ls}->{$path}->{'size'} == 0 | |
| 394 and $info->{ls}->{$path}->{'perm'} !~ m|^d| | |
| 395 and $path !~ m/^.*\/lib\/perl\/.+\.bs$/ | |
| 396 and $rpm !~ m/\bopenpkg-[0-9]+/) { | |
| 397 &lint_warning($rpm, "empty file \"$path\" found (expected no empty files)"); | |
| 398 } | |
| 399 } | |
| 400 | |
| 401 # check for %config flagged files | |
| 402 my $prefix = quotemeta($info->{'prefix'}); | |
| 403 my $name = quotemeta($info->{'name'}); | |
| 404 foreach my $path (keys(%{$info->{ls}})) { | |
| 405 my $config = $info->{ls}->{$path}->{'config'}; | |
| 406 my $path = $info->{ls}->{$path}->{'path'}; | |
| 407 if ($rpm !~ m/\bopenpkg-[0-9]+/ and $config and $path !~ m/^$prefix\/etc\/($name\d*|fsl)\/.+/) { | |
| 408 &lint_warning($rpm, "non-config file \"$path\" flagged as \%config (expected only \"$prefix/etc/$name/*\" files to be \%config files)"); | |
| 409 } | |
| 410 if ($config and $path =~ m/^$prefix\/s?bin\/[^\/]+$/) { | |
| 411 &lint_error($rpm, "executable file \"$path\" flagged as \%config"); | |
| 412 } | |
| 413 if ($config and $path =~ m/^$prefix\/etc\/rc\.d\/rc\.$name$/) { | |
| 414 &lint_error($rpm, "run-command file \"$path\" flagged as \%config"); | |
| 415 } | |
| 416 } | |
| 417 | |
| 418 # check for permissions | |
| 419 foreach my $path (keys(%{$info->{ls}})) { | |
| 420 my $perm = $info->{ls}->{$path}->{'perm'}; | |
| 421 if ($path =~ m/^$prefix\/(bin|sbin)\/[^\/]+$/) { | |
| 422 if ($perm !~ m|^[^d]..[xs]..[xs]..[xt]$|) { | |
| 423 &lint_warning($rpm, "executable file \"$path\" has permissions \"$perm\" only (expected it to be executable by everyone)"); | |
| 424 } | |
| 425 } | |
| 426 } | |
| 427 | |
| 428 # TODO: user/group? | |
| 429 } | |
| 430 | |
| 431 ## _________________________________________________________________ | |
| 432 ## | |
| 433 ## CHECK "content": file content | |
| 434 ## _________________________________________________________________ | |
| 435 ## | |
| 436 | |
| 437 sub check_content { | |
| 438 my ($rpm, $info) = @_; | |
| 439 | |
| 440 # TODO: stripped (file) | |
| 441 # TODO: syslibs (ldd) | |
| 442 # TODO: hard-coded paths pointing outside instance | |
| 443 # TODO: sanity check for shebang-lines | |
| 444 # TODO: contained temporary path | |
| 445 # TODO: bad-files: .po | |
| 446 } | |
| 447 |
