openpkg/lint-rpm.pl@a2c6460cfb16
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.
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 ##
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 }
36 # OpenPKG instance prefix
37 my $my_prefix = $ENV{'OPENPKG_PREFIX'};
38 delete $ENV{'OPENPKG_PREFIX'};
40 # program information
41 my $progname = "lint-rpm";
42 my $progvers = "1.0.0";
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";
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 };
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 }
87 # verbose message printing
88 sub msg_verbose {
89 my ($msg) = @_;
90 print STDERR "$msg\n" if ($verbose);
91 }
93 # warning message printing
94 sub msg_warning {
95 my ($msg) = @_;
96 print STDERR "$progname:WARNING: $msg\n";
97 }
99 # error message printing
100 sub msg_error {
101 my ($msg) = @_;
102 print STDERR "$progname:ERROR: $msg\n";
103 }
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 }
124 # global return code
125 $main::GRC = 0;
127 # environment preparation
128 system("rm -rf $tmpdir");
129 system("mkdir -p $tmpdir");
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 }
142 # environment cleanup
143 system("rm -rf $tmpdir");
145 # die gracefully
146 exit($main::GRC);
148 ## _________________________________________________________________
149 ##
150 ## COMMON SUBROUTINES
151 ## _________________________________________________________________
152 ##
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 }
160 sub lint_warning {
161 my ($file, $msg) = @_;
162 &lint_message("WARNING", $file, $msg);
163 $main::GRC = 1 if ($main::GRC < 1);
164 }
166 sub lint_error {
167 my ($file, $msg) = @_;
168 &lint_message("ERROR", $file, $msg);
169 $main::GRC = 2 if ($main::GRC < 2);
170 }
172 ## _________________________________________________________________
173 ##
174 ## RPM INFORMATION GATHERING
175 ## _________________________________________________________________
176 ##
178 sub rpm_info {
179 my ($filename, $checks) = @_;
180 my $info = {};
182 # query package name
183 &msg_verbose("++ querying RPM package name");
184 $info->{name} = `$rpm -qp --qf '%{NAME}' $filename`;
186 # query prefix
187 &msg_verbose("++ querying RPM package installation prefix");
188 $info->{prefix} = `$rpm -qp --qf '%{PREFIXES}' $filename`;
190 # query file listing
191 &msg_verbose("++ querying RPM package file listing");
192 my @list = `$rpm -qplv $filename`;
193 my @config = `$rpm -qplc $filename`;
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 }
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 }
237 return $info;
238 }
240 sub rpm_info_cleanup {
241 my ($filename, $checks, $info) = @_;
243 if (grep(/^content$/, @{$checks})) {
244 system("rm -rf ".$info->{root}) if ($info->{root} =~ m/^\/.+/ and -d $info->{root});
245 }
246 }
248 ## _________________________________________________________________
249 ##
250 ## CHECK "layout": file path layout
251 ## _________________________________________________________________
252 ##
254 sub check_layout {
255 my ($rpm, $info) = @_;
257 # no need to check 'openpkg' package because it
258 # has a hard-coded file list!
259 return if ($rpm =~ m|^(.+?/)?openpkg-\d[^/]+$|);
261 # check prefix
262 if ($info->{prefix} !~ m|^/.+$|) {
263 &lint_error($rpm, "invalid installation prefix ".$info->{prefix}.
264 " (expected to match \"^/.+\$\")");
265 return;
266 }
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 }
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 }
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 }
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 }
382 ## _________________________________________________________________
383 ##
384 ## CHECK "attrib": file attributes
385 ## _________________________________________________________________
386 ##
388 sub check_attrib {
389 my ($rpm, $info) = @_;
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 }
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 }
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 }
428 # TODO: user/group?
429 }
431 ## _________________________________________________________________
432 ##
433 ## CHECK "content": file content
434 ## _________________________________________________________________
435 ##
437 sub check_content {
438 my ($rpm, $info) = @_;
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 }
