close stdin of gpg by shell builtin
[opensuse:supportability-analysis-module.git] / sam
1 #!/usr/bin/perl -w
2 # vim: set et ts=8 sts=4 sw=4 ai si:
3 #
4 #  sam - Supportability Analysis Module
5 #
6 #  Copyright (c) 2008, 2009 SuSE Linux Products GmbH, Nuernberg, Germany
7 #
8 #  Authors: Olaf Dabrunz <od@suse.de>
9 #           (based on 'sammi' by Raymund Will <rw@suse.de>)
10 #
11 #           David Sterba <dsterba@suse.cz>
12 #
13 #  This program is free software; you can redistribute it and/or modify
14 #  it under the terms of the GNU General Public License as published by
15 #  the Free Software Foundation; either version 2 of the License, or
16 #  (at your option) any later version.
17 #
18 #  This program is distributed in the hope that it will be useful,
19 #  but WITHOUT ANY WARRANTY; without even the implied warranty of
20 #  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
21 #  GNU General Public License for more details.
22 #
23 #  You should have received a copy of the GNU General Public License
24 #  along with this program; if not, write to the Free Software
25 #  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
26 #
27 # Notes:
28 #
29 # RPM epoch is not used at SUSE/Novell and elsewhere, as it is sticky
30 # (every version upgrade of any distribution's version of this package must
31 # contain the latest epoch value) and also not visible to the user. SAM still
32 # is aware of the epoch.
33 #
34 # Extensions for SELinux, ACLs, capabilities and others need to be added when
35 # they are supported by both the SUSE Linux kernel and the SUSE version of RPM.
36 #
37
38 use strict;
39 use warnings;
40 use POSIX qw(strftime WIFEXITED WEXITSTATUS WIFSIGNALED WTERMSIG);
41 # handle HUP INT PIPE TERM ABRT QUIT with die, so the END block is executed
42 # which unlinks temporary files
43 use sigtrap qw(die untrapped normal-signals ABRT QUIT);
44 use File::Find;
45 use File::Path qw(mkpath);
46 use File::Temp qw(tempdir);
47 use File::Basename qw(basename dirname);
48 use File::Spec qw(canonpath);
49 use Cwd qw(abs_path);
50
51 use satsolver;
52 use XML::Simple;
53
54 use Data::Dumper;
55 use Carp;
56
57 my $progname            = $0; $progname =~ s/^.*\///;
58 my $progspcs            = ' 'x(length($progname));
59 my $invocation_cmd_line = join (' ', $progname, @ARGV);
60
61 my $prog_version        = '@VERSION@';
62
63 # temporary directories
64 my $defaulttmp          = '/tmp';
65 my $tmpsubdir;
66 my $tmpsubdirtemplate;
67 my $tmpdir              = $ENV{'TMPDIR'} // $defaulttmp;
68 my $tmpsubdirprefix     = $progname;
69 my $pubring             = 'pubring';
70 my $sigfile             = 'sigfile';
71 my $signedfile          = 'signedfile';
72 my $reftempdir          = 'temp';
73 my $refsolvdir          = 'solv';
74 my $refkeysdir          = 'keys';
75
76 my $rm_command          = '/bin/rm';
77 my $tar_command         = '/bin/tar';
78 my $cp_command          = '/bin/cp -f';
79 my $repo2solv_command   = '/usr/bin/repo2solv.sh';
80 my $rpm_command         = '/bin/rpm';
81 my $gpg_exe             = '/usr/bin/gpg';
82 my $gpg_command         = "$gpg_exe --no-default-keyring --keyring $pubring " .
83                           '--trust-model always --batch <&-';
84 # remove temp files in the end (but not if the program ends before temp dir
85 # name is known)
86 END {
87     if (defined $tmpsubdir) {
88         system("$rm_command -rf -- $tmpsubdir");
89     }
90 }
91
92 my $sam_packages        = 'suse-sam suse-sam-data perl-satsolver satsolver-tools';
93 my %sam_version         = ();
94
95 $ENV{'LC_ALL'} = 'C';
96 delete $ENV{'LANG'};
97
98 my $root_dir            = '/';
99 my $reference_datadir   = '/usr/share/suse-sam';
100 my $products_dir        = '/etc/products.d';
101 my %prodinfo            = ();
102 my $num_our_products    = 0;
103 my $baseproduct;
104 my $skippedrepos        = 0;
105 my $needrefresh         = 0;
106
107 # caches -- for development and debugging
108 my $sam_cache           = 'sam-cache.d';
109 my $rpm_qa_cache        = "$sam_cache/rpm-qa";
110 my $rpm_Vv_cache        = "$sam_cache/rpm-Vv";
111 my $rpm_ql_cache        = "$sam_cache/rpm-ql";
112 my $rpm_e_cache         = "$sam_cache/rpm-e";
113 my $cache_file_version  = '0.8';
114
115 # repositories -- for gpg keys and inst source information
116 my $solvfilename        = 'solv';   # for all repo schemas
117
118 # config values for different repo setup schemas
119 my $repo_schema = 'zypper';
120 my %repo_config = (
121     'zypper' => {
122         # private vars
123         'zypp_conf'       => $ENV{'ZYPP_CONF'} // '/etc/zypp/zypp.conf', # libzypp
124         'def_zypp_cache'  => '/var/cache/zypp',
125         # interface
126         'get_conf'        => \&get_zypper_repo_conf,    # setup paths
127         'repos_dir'       => undef,
128         'keys_dir'        => undef,
129         'solv_dir'        => undef
130     },
131     'studio' => {
132         # interface
133         'get_conf'     => \&get_studio_repo_conf,
134         'repos_dir'    => undef,    # not used in this schema
135         'keys_dir'     => undef,
136         'solv_dir'     => undef
137     },
138     'none' => {
139         'get_conf'  => sub { },
140         'repos_dir' => $reference_datadir,
141         'keys_dir'  => "$reference_datadir/keys",
142         'solv_dir'  => $reference_datadir
143     }
144 );
145
146 my %archtable;
147 my %repoinfo            = ();
148 my $allowed_codestreams = '';
149
150 # installed package information
151 my %packinfo            = ();
152 my %foreigninfo         = ();
153 my %skipped_packages    = ();
154
155 my $num_sig_ok_packs    = 0;
156 my $num_prod_ok_packs   = 0;
157
158 # package signing keys
159 my %good_key_ids        = ();
160
161 # --------------------------------------------------------------------------
162 # data for verfication step
163 my %inodes;
164 my %file2rpm;
165 my %file2kind;  # to be moved to $packinfo{$pack}->{'file'}->{$file}->{'kind'}
166 use constant { FT_FILE => 0, FT_DIR => 1, FT_LINK => 2, FT_SPECIAL => 3 };
167 my %file2type;  # to be moved to ...
168 my %file2res;   # to be moved to ...
169 my %unsatisfied;
170 my %foreign_unsatisfied;
171 my %depends_on_foreign; # key: our package, value: array of dep foreign packages
172
173 my %newer_exists = ();  # key: pkg, value: array: [reponumber]=evr
174
175 my @file_modified;
176 my @file_tolerated;
177 my @file_missing;
178 my @file_dispensable;
179
180 my @foreign_file_modified;
181 my @foreign_file_tolerated;
182 my @foreign_file_missing;
183 my @foreign_file_dispensable;
184
185 my %unsupportable;  # key: rpm name, value: array of files
186 my %tolerable;      # dtto
187 my %harmless;       # dtto
188
189 my %repo_to_refresh;
190
191 # --------------------------------------------------------------------------
192 # cached data for summary
193 my $summary_nvra;
194 my $summary_orphaned;
195 my $summary_modif;
196 my $summary_unsatdeps;
197 my $summary_updates;
198
199 my @report; # save report output and prepend it to html report
200 my @xs; # xml tag stack
201
202 # --------------------------------------------------------------------------
203 # SAM configuration, defaults are set in main
204 my $ALLOW_MULTIHOMED_OBJECTS = 0;
205 my $opt_header_sig_check;
206 my $opt_rpm_verify;
207 my $opt_orphan_search;
208 my $opt_rpm_verify_md5;
209 my $opt_print_pkg_summary;
210 my $opt_log_commands;
211
212 my $debug               = 0;
213 # levels:
214 # 0 - batch run
215 # 1 - more interactive
216 # 2 - not so important
217 # 3 - annoying messages
218 my $opt_verbose;
219
220 # command line override of various directories used, from command line
221 my %opt_dirs;   # key: dir type, value: path
222 my @opt_exp;    # list of experimental options
223
224 my $opt_skip_unmatched_prod = 0;
225 my $sysarch;
226 my $opt_sysarch;
227
228 # hex encoding of RPM header prefix used when creating/verifying the header
229 # signature
230 my $headerprefix        = '8eade80100000000';
231
232 # regex for codestream schema
233 my $codestream_schema   = qr(obs://[^/]+/[^/]+/[^/]+)i;
234
235 # --------------------------------------------------------------------------
236 # statistics
237 my $time_of_start = time;
238 my ($sum_all_inodes, $sum_all_fsize, $sum_pkg_inodes, $sum_pkg_fsize) = (0, 0, 0, 0);
239
240 # --------------------------------------------------------------------------
241 # development only
242 sub Dbg {
243     print STDERR "DB: @_\n" if $debug;
244 }
245
246 # Log information to a file, extending information displayed directly
247 # - "%T" in the message are replaced with a timestamp.
248 sub Log($@) {
249     my ($msg, @args) = @_;
250     $msg = sprintf($msg, @args) if(@args);
251     if($msg =~ /\%T/) {
252         my $timestamp = strftime('%Y-%m-%d %H:%M:%S', gmtime(time));
253         $msg =~ s/\%T/$timestamp/g;
254     }
255     print(LOG $msg);
256     return $msg;
257 }
258
259 # Logger of executed commands and output
260 sub LogCmd {
261     return if !$opt_log_commands;
262     print LOG @_;
263 }
264
265 # Information displayed directly on screen
266 sub Report($@) {
267     my ($fmt,@args)=@_;
268     my $msg = Log($fmt, @args);
269     print($msg);
270     print(REPORT $msg);
271     push @report,$msg;
272 }
273 # Xml output
274 sub x_out($) {
275     print(XML @_);
276 }
277
278 # ---------------------------------------------------------------------------
279 # Exit the program with an error return value and an optional message.
280 # - pass errorcode and printf format string
281 #
282 # error code classes:
283 # 1 - external command failed
284 # 2 - internal check failed
285 sub Die($$@) {
286     my ($error_code, $format, @args) = @_;
287
288     if (defined $format) {
289         my $msg = sprintf($format, @args);
290         Log("FATAL: $msg");
291         print(STDERR "FATAL: $msg");
292         carp($msg) if $debug;
293     }
294
295     exit($error_code);
296 }
297
298 #
299 # html output helpers
300
301 sub showhidebutton($) {
302     my ($element) = @_;
303     my $showbutton = <<EOT;
304 <a id="but_$element" href="#" onclick="return showhide('but_$element','$element');">[hide]</a>
305 EOT
306 }
307
308 # print package information as HTML
309 sub init_html() {
310     print HTML <<EOT
311 <html><head>
312 <title>sam support status</title>
313 <script>
314 function showhide(button,id) {
315     var but=document.getElementById(button);
316     var el=document.getElementById(id);
317     if(but.innerHTML.match(/show/)) {
318         el.style.display='';
319         but.innerHTML='[hide]';
320     } else {
321         el.style.display='none';
322         but.innerHTML='[show]';
323     }
324     return false;
325 }
326 </script>
327 </head>
328 <body>
329 EOT
330 }
331 sub init_html_table {
332     my ($tabid) = @_;
333     print HTML <<EOT
334     <table id="$tabid" cellspacing=0 border=1>
335       <thead>
336         <th>Name</th><th>Version</th><th>Supported</th>
337           <th>Status</th><th>Details</th>
338       </thead>
339       <tbody>
340 EOT
341 }
342
343 sub finish_html() {
344     print HTML <<EOT
345   </body>
346 </html>
347 EOT
348 }
349
350 sub print_html_package($@) {
351     my ($pkg, @res) = @_;
352     my ($supp, $ver) = ('no');
353     my %notes;
354
355     if($res[0] eq 'foreign_pkg') {
356         $ver = $foreigninfo{$pkg}->{'evr'};
357         my $a = 'vendor: '. $foreigninfo{$pkg}->{'vendor'} .'<br>codestream: '. $foreigninfo{$pkg}->{'disturl'};
358         if(is_foreign_codestream($foreigninfo{$pkg}->{'disturl'})) {
359             $notes{'foreign codestream'} = $a;
360         } else {
361             $notes{'foreign vendor'} = $a;
362         }
363     } elsif ($res[0] eq 'ok') {
364         $ver = $packinfo{$pkg}->{'evr'};
365         $supp = 'yes';
366     } else {
367         $ver = $packinfo{$pkg}->{'evr'};
368         if(grep(/update/,@res)) {
369             my @vers;
370             map { push @vers, $_ if(!grep(/\Q$_/,@vers)) } grep {defined} @{$newer_exists{$pkg}};
371             $notes{'update needed'} = join('<br>',@vers);
372         }
373         if(grep(/foreign_deps/,@res)) {
374             $notes{'foreign dependencies'} = join('<br>', @{$depends_on_foreign{$pkg}});
375         }
376         if(grep(/file_mods/,@res)) {
377             map { $notes{'file modifications'} .= "$_: ". pretty_print_result($_,''). '<br>' }
378                 @{$unsupportable{$pkg}};
379         }
380         if(grep(/unsat_deps/,@res)) {
381             $notes{'unsatisfied dependencies'} = join('<br>', split(/, /, $unsatisfied{$pkg}));
382         }
383     }
384     my $rowspan = scalar(keys %notes) > 1 ? 'rowspan="'. scalar(keys %notes).'"' : '';
385     print(HTML "<tr>");
386     print(HTML "<td valign='top' $rowspan><b>$pkg</b></td>");
387     print(HTML "<td valign='top' align='right' $rowspan >$ver</td>");
388     print(HTML "<td valign='top' $rowspan>$supp</td>");
389     my $first=1;
390     foreach(keys %notes) {
391         print(HTML "<tr>") unless $first;
392         print(HTML "<td valign='top'>$_</td>\n");
393         print(HTML "<td valign='top'>$notes{$_}</td>\n");
394         print(HTML "</tr>\n");
395         $first=0;
396     }
397 }
398
399 sub print_package_table($$\@) {
400     my ($tabid, $title, $pkglist) = @_;
401
402     print(HTML "$title ");
403     print(HTML showhidebutton($tabid));
404     init_html_table($tabid);
405     my %seen = (); # use unique list
406     for my $pkg (sort grep { !$seen{$_}++ } @$pkglist) {
407         my @res=();
408         push @res, 'foreign_pkg', if (exists $foreigninfo{$pkg});
409         push @res, 'unsat_deps' if (exists $unsatisfied{$pkg});
410         push @res, 'file_mods' if (exists $unsupportable{$pkg});
411         push @res, 'foreign_deps' if (exists $depends_on_foreign{$pkg});
412         push @res, 'update' if (exists $newer_exists{$pkg});
413         push @res, 'ok' if (!@res);
414         print_html_package($pkg, @res);
415     }
416     print(HTML "</tbody></table><br>");
417 }
418
419 sub print_package($@) {
420     my ($pkg, @res) = @_;
421     my ($supp, $ver) = ('no');
422     my %notes;
423     my $s;
424
425     if($res[0] eq 'foreign_pkg') {
426         $ver = $foreigninfo{$pkg}->{'evr'};
427         my $a = 'vendor: '. $foreigninfo{$pkg}->{'vendor'} .'<br>codestream: '. $foreigninfo{$pkg}->{'disturl'};
428         if(is_foreign_codestream($foreigninfo{$pkg}->{'disturl'})) {
429             $notes{'foreign codestream'} = $a;
430         } else {
431             $notes{'foreign vendor'} = $a;
432         }
433     } elsif ($res[0] eq 'ok') {
434         $ver = $packinfo{$pkg}->{'evr'};
435         $supp = 'yes';
436     } else {
437         $ver = $packinfo{$pkg}->{'evr'};
438         if(grep(/update/,@res)) {
439             my @vers;
440             map { push @vers, $_ if(!grep(/\Q$_/,@vers)) } grep {defined} @{$newer_exists{$pkg}};
441             $notes{'update needed'} = join('<br>',@vers);
442         }
443         if(grep(/foreign_deps/,@res)) {
444             $notes{'foreign dependencies'} = join('<br>', @{$depends_on_foreign{$pkg}});
445         }
446         if(grep(/file_mods/,@res)) {
447             map { $notes{'file modifications'} .= "$_: ". pretty_print_result($_,''). '<br>' }
448                 @{$unsupportable{$pkg}};
449         }
450         if(grep(/unsat_deps/,@res)) {
451             $notes{'unsatisfied dependencies'} = join('<br>', split(/, /, $unsatisfied{$pkg}));
452         }
453     }
454     my $rowspan = scalar(keys %notes) > 1 ? 'rowspan="'. scalar(keys %notes).'"' : '';
455     $s=$pkg;
456     my $first=1;
457     foreach(keys %notes) {
458         $s=$s." ($_)";
459         #$s=$s.$notes{$_}. ;    #FIXME how to show details?
460         $first=0;
461     }
462     return $s;
463 }
464
465 my $xsp=2;
466
467 # return 2 column aligned table strings
468 # IN: key/value list or hash
469 sub fmt_table2 {
470     my ($pfix, @rest) = @_;
471     my $left = 0;
472     for(my $i=0;$i<@rest;$i+=2) {
473         $left=length($rest[$i]) if(length($rest[$i]) > $left);
474     }
475     my @out;
476     for(my $i=0;$i<@rest;$i+=2) {
477         my $l=$rest[$i];
478         my $r=$rest[$i+1] // '';
479         push @out,$pfix . "$l  " . ' 'x($left - length($l)) . "$r\n";
480     }
481     return join('',@out);
482 }
483 sub x_list {
484     my @rest = @_;
485     for(my $i=0;$i<@rest;$i+=2) {
486         my $l=$rest[$i];
487         $l =~ s/:$//;
488         $l =~ s/\s/-/g;
489         $l = lc($l);
490         my $r=$rest[$i+1] // '';
491         x_out(' 'x($xsp*scalar(@xs)) . "<$l>" . x_quote($r) . "</$l>\n");
492     }
493 }
494
495 # IN: attribute hash, attr name
496 sub attr_fmt($$) {
497     my ($h,$a)=@_;
498     return exists $h->{$a} ? " $a=\"" . $h->{$a} . '"' : '';
499 }
500 sub clean_tag($) {
501     my ($tag)=@_;
502     $tag =~ s/\//-/g;
503     $tag =~ s/[()]//g;
504     return $tag;
505 }
506
507 # quoted tag
508 sub x_t {
509     my ($tag, $cont)=@_;
510     $tag=clean_tag($tag);
511     x_out(' 'x($xsp*scalar(@xs)) . "<$tag>" . x_quote($cont) . "</$tag>\n");
512 }
513 # unquoted tag
514 sub x_tnq {
515     my ($tag, $cont)=@_;
516     $tag=clean_tag($tag);
517     x_out(' 'x($xsp*scalar(@xs)) . "<$tag>$cont</$tag>\n");
518 }
519 # attributed tag start
520 sub x_ts {
521     my ($tag, $attr)=@_;
522     my $s='';
523     $tag=clean_tag($tag);
524     foreach(keys %$attr) {
525         $s .= attr_fmt($attr, $_);
526     }
527     x_out(' 'x($xsp*scalar(@xs)) . "<$tag$s>\n");
528     push @xs, $tag;
529 }
530 # last tag end
531 sub x_te {
532     my $t=pop @xs;
533     x_out(' 'x($xsp*scalar(@xs)) . "</$t>\n");
534 }
535 # xml qoute
536 sub x_quote {
537     my @a=split(/[&]/, join('',@_));
538     foreach(@a) {
539         s/</\&lt;/g;
540         s/>/\&gt;/g;
541         s/'/\&apos;/g;
542         s/"/\&quot;/g;
543     }
544     return join('&amp;',@a);
545 }
546
547 # ---------------------------------------------------------------------------
548 # check if installed satsolver contains required stuff
549 sub check_satsolver {
550     my %needed_methods = (
551         'Pool'      =>  ['providers'],
552         'Repo'      =>  ['solvables'],
553         'Solvable'  =>  ['compare', 'identical'],
554     );
555
556     foreach my $subpack (keys %needed_methods) {
557         foreach my $sym (@{$needed_methods{$subpack}}) {
558             if (!(defined $satsolver::{"${subpack}::"}->{$sym} or
559                     defined $satsolver::{$sym})) {
560                 Die(2, "installed satsolver is missing symbol: ${subpack}::${sym}\n");
561             }
562         }
563     }
564 }
565
566 # ---------------------------------------------------------------------------
567 # Read the version of the installed SAM packages
568 #
569 sub get_installed_sam_version() {
570     my $sam_packages_re='(?:' . join('|',split(/\s+/,$sam_packages)).')';
571     my $rpm_q = "$rpm_command -q --qf " .
572         "'%{NAME}  %|EPOCH?{%{EPOCH}:}:{}|%{VERSION}-%{RELEASE}\n' " .
573         "$sam_packages";
574
575     LogCmd("+$rpm_q\n");
576     open(FH, "$rpm_q |") || Die(1, "rpm -q: $!\n");
577     while (<FH>) {
578         chomp;
579         if (/^(\S+)  (\S+)$/) {
580             $sam_version{$1} = $2;
581         } elsif (/\s+($sam_packages_re)\s+is not installed/o) {
582             $sam_version{$1} = '(not installed)';
583         } else {
584             Log("    rpm -q: unexpected query response: '%s'\n",$_);
585         }
586
587     }
588     close(FH);
589 }
590
591 # Create reference data: convert tarballs to solv-files
592 # -  if reference data are found, create a repo structure and create solv files
593 sub create_reference_data() {
594     Log("  using reference data from '$reference_datadir':\n");
595     x_ts('reference-data');
596     x_out("<pre>\n");
597
598     # solv -> repoinfo
599     if (-d "$reference_datadir/solv") {
600         foreach my $path (sort(glob("$reference_datadir/solv/*"))) {
601             my $subdir = basename($path);
602             if (-d $path) {
603                 if (-f "$path/solv") {
604                     Log("    $subdir (solv)\n");
605                     x_out("$subdir (solv)\n");
606                     $repoinfo{$subdir} = {
607                         name     => $subdir,
608                         repo_id  => $subdir,
609                         subdir   => $subdir,
610                         solvfile => "$path/solv",
611                         reference_data => 1
612                         # or not if supplied from non-default dir?
613                         # FIXME: ... may be confusing
614                     };
615                 } else {
616                     Dbg("solv file not present in subdir '$subdir'");
617                 }
618             } else {
619                 Dbg("non dir found under solv, skip: $subdir");
620             }
621         }
622     }
623
624     mkdir("$refsolvdir", 0700) || Die(1, "mkdir $refsolvdir: $!\n");
625     mkdir("$refkeysdir", 0700) || Die(1, "mkdir $refkeysdir: $!\n");
626
627     # metadata -> solv -> repoinfo
628     if (-d "$reference_datadir/raw") {
629         foreach my $path (sort(glob("$reference_datadir/raw/*"))) {
630             my $subdir = basename($path);
631             if (-d $path) {
632                 if (exists $repoinfo{$subdir}) {
633                     Dbg("repo generated from solv file already, $_");
634                     next;
635                 }
636                 my $solvfile = "$refsolvdir/$subdir/$solvfilename";
637                 mkdir("$refsolvdir/$subdir", 0700) || Die(1, "mkdir $refsolvdir/$subdir: $!\n");
638
639                 if ($opt_header_sig_check) {
640                     # save gpg keys for later
641                     my @gpg_files = glob("$path/*.{key,asc}");
642                     if (@gpg_files) {
643                         my $cmd = "$cp_command -- " . join(' ', @gpg_files) . " $refkeysdir";
644                         System($cmd);
645                     }
646                 }
647
648                 System("$repo2solv_command $path > $solvfile");
649
650                 Log("    $subdir (metadata)\n");
651                 x_out("$subdir (metadata)\n");
652                 $repoinfo{$subdir} = {
653                     name     => $subdir,
654                     repo_id  => $subdir,
655                     subdir   => $subdir,
656                     solvfile => $solvfile,
657                     reference_data => 1
658                 };
659             }
660         }
661     }
662
663     # tar -> metadata -> solv -> repoinfo
664     my %compr_flags = ( '.gz' => 'z', '.bz2' => 'j', '' => '');
665     foreach my $tarfile (sort(glob("$reference_datadir/*.tar{,.gz,.bz2}"))) {
666         $tarfile        =~ /^.*\/([^\/]*)\.tar(|\.gz|\.bz2)$/;
667         my $subdir      = $1;
668         my $compr_flag  = $compr_flags{$2};
669
670         if (exists $repoinfo{$subdir}) {
671             Dbg("repo generated already, $_");
672             next;
673         }
674
675         mkdir("$refsolvdir/$subdir", 0700) || Die(1, "mkdir $refsolvdir/$subdir: $!\n");
676         mkdir("$reftempdir", 0700)         || Die(1, "mkdir $reftempdir: $!\n");
677
678         my $cmd = "$tar_command xC${compr_flag}f $reftempdir $tarfile";
679         System($cmd);
680
681         if ($opt_header_sig_check) {
682             # save gpg keys for later
683             my @gpg_files = glob("$reftempdir/*.{key,asc}");
684             if (@gpg_files) {
685                 $cmd = "$cp_command -- " . join(' ', @gpg_files) . " $refkeysdir";
686                 System($cmd);
687             }
688         }
689
690         my $solvfile = "$refsolvdir/$subdir/$solvfilename";
691
692         $cmd = "$repo2solv_command $reftempdir > $solvfile";
693         System($cmd);
694
695         $cmd = "$rm_command -rf -- $reftempdir";
696         System($cmd);
697
698         Log("    $subdir (tar)\n");
699         x_out("$subdir (tar)\n");
700         $repoinfo{$subdir} = {
701             name            => $subdir,
702             repo_id         => $subdir,
703             subdir          => $subdir,
704             solvfile        => $solvfile,
705             reference_data  => 1
706         };
707     }
708     if (!scalar(keys %repoinfo)) {
709         Log("  no reference repository files found under '$reference_datadir'\n");
710         x_out("no reference repository files found under '$reference_datadir'\n");
711     }
712     x_out("</pre>\n");
713     x_te();
714 }
715
716 # SUSE/Novell vendors of supported packages
717 my $Vendors = join('|',(
718     'SuSE GmbH', 'SuSE AG', 'SuSE Linux AG', 'SUSE LINUX Products GmbH',
719     'UnitedLinux LLC', 'Novell'));
720
721 # Collect from products.d:
722 #   - list of installed products
723 #   - list of "codestreams" aka "Build Service repositories" that are used as
724 #     package sources for the installed products
725 #
726 sub get_products() {
727     my %codestreams = ();
728     my $products_d = File::Spec->catdir($root_dir, $products_dir);
729
730     if (not opendir(PD, $products_d)) {
731         Die(1, "unable to open product directory '$products_d': $!\nPlease make sure you installed package(s) describing product(s), eg. sles-release.\n");
732     } else {
733         foreach my $file (readdir(PD)) {
734             next    if $file !~ /^(?:baseproduct|.*\.prod)$/;
735             my $path = "$products_d/$file";
736
737             if ($file eq 'baseproduct') {
738                 $baseproduct = readlink($path);
739                 $baseproduct =~ s/^$products_d\/*//;
740                 next;
741             }
742
743             if (not -f $path) {
744                 Log("  skipping: not a regular file: $path\n");
745                 next;
746             } elsif (not -r $path) {
747                 Log("  skipping: not readable: $path\n");
748                 next;
749             }
750
751             # XML::Simple is required to read prod files
752             my $info = eval { XMLin($path, ForceArray => qr/^repository$/); };
753             if ($@) {
754                 Die(2, "  error parsing product xml file \"$path\": $@\n");
755                 next;
756             }
757
758             $prodinfo{$file} = $info;
759
760             if (defined $info->{'vendor'} and $info->{'vendor'} =~ /^$Vendors/o) {
761                 $num_our_products++;
762                 if ( defined $info->{'register'} and
763                     defined $info->{'register'}->{'repositories'} and
764                     defined $info->{'register'}->{'repositories'}->{'repository'} ) {
765                     foreach my $codestream (@{$info->{'register'}->{'repositories'}->{'repository'}}) {
766                         if (defined $codestream->{'path'} and
767                             $codestream->{'path'} =~ /^$codestream_schema$/o) {
768                             push @{$prodinfo{$file}->{'allowed_codestreams'}},
769                             $codestream->{'path'};
770                             $codestreams{$codestream->{'path'}} = $file;
771                             if($codestream->{'path'} =~ /SUSE:SLE-11:Update/) {
772                                 # additional Update:Test channel
773                                 $codestreams{"$`$&:Test$'"} = $file;
774                             }
775                         }
776                     }
777                 }
778             } else {
779                 Log(" skipping third-party product from vendor: %s\n", $info->{'vendor'} // '(unknown)');
780             }
781         }
782         # regex from the list of codestreams allowed by installed SUSE/Novell products
783         if(scalar(%codestreams)) {
784             $allowed_codestreams = '(?:' . join('|', map(quotemeta($_), (sort keys %codestreams))) . ')';
785         } else {
786             $allowed_codestreams = '(none)';
787         }
788         Log("  allowed codestreams:\n    %s\n", join("\n    ", sort keys %codestreams));
789         x_ts('allowed-codestreams');
790         foreach(sort keys %codestreams) {
791             x_t('codestream', $_);
792         }
793         x_te();
794     }
795 }
796
797 sub get_repo_conf() {
798     $repo_config{$repo_schema}->{'get_conf'}->();
799 }
800 sub get_zypper_repo_conf() {
801     my $rc = $repo_config{'zypper'};
802     my $zypp_conf = $rc->{'zypp_conf'};
803     my ($repos_dir, $solv_dir, $keys_dir);
804     my $cachedir;
805
806     $zypp_conf =~ /^(.*)\//;
807     my $zypp_confdir = $1;
808
809     if (!open(CONF, '<', "$root_dir/$zypp_conf")) {
810         x_tnq('warning', "Unable to open zypper config <quote>". x_quote("$root_dir/$zypp_conf")."</quote>");
811         Log("  unable to open zypper config '$root_dir/$zypp_conf', using defaults: $!\n");
812     } else {
813         # get reposdir (fallback) and solvfilesdir from zypp.conf
814         while (<CONF>) {
815             $cachedir  = $1, next if /^\s*cachedir\s*=\s*(\S+)\s*$/;
816             $repos_dir = $1, next if /^\s*reposdir\s*=\s*(\S+)\s*$/;
817             # metadatadir not used directly, but keys are stored there
818             $keys_dir  = $1, next if /^\s*metadatadir\s*=\s*(\S+)\s*$/;
819             $solv_dir  = $1, next if /^\s*solvfilesdir\s*=\s*(\S+)\s*$/;
820         }
821         close(CONF);
822     }
823
824     $cachedir = File::Spec->canonpath($rc->{'def_zypp_cache'}) if(!defined $cachedir);
825     $repos_dir = "$zypp_confdir/repos.d" if(!defined $repos_dir);
826     $keys_dir = "$cachedir/raw" if(!defined $keys_dir);
827     $solv_dir = "$cachedir/solv" if(!defined $solv_dir);
828
829     $rc->{'repos_dir'} = File::Spec->catdir($root_dir, $repos_dir);
830     $rc->{'keys_dir'} = File::Spec->catdir($root_dir, $keys_dir);
831     $rc->{'solv_dir'} = File::Spec->catdir($root_dir, $solv_dir);
832 }
833 sub get_studio_repo_conf() {
834     my $rc = $repo_config{'studio'};
835
836     for('repos','solv','keys') {
837         Die(2, "studio-scheme: '$_' not specified on command line via --dir") if(!defined $opt_dirs{$_});
838     }
839
840     $rc->{'repos_dir'} = File::Spec->catdir($root_dir, $opt_dirs{'repos'});
841     $rc->{'solv_dir'} = File::Spec->catdir($root_dir, $opt_dirs{'solv'});
842     $rc->{'keys_dir'} = File::Spec->catdir($root_dir, $opt_dirs{'keys'});
843 }
844
845 #
846 # Read (product) information from the repositories
847 #
848 # Examples:
849 #
850 # name          SUSE-Linux-Enterprise-Server 11.0-0     SUSE-Linux-Enterprise-SDK-x86_64 11.0-0
851 # baseurl       ftp://ftp.suse.x/SLES11/x86_64/DVD1/    http://www.suse.x/SLE-11-SDK/x86_64/DVD1
852 # label         SUSE Linux Enterprise Server 11         SUSE Linux Enterprise Software Development Kit 11
853 # dist          SUSE_SLE                                SUSE_SDK
854 # version       11                                      11
855 # sp_version    0                                       (none)
856 #
857 my @required_fields     = ('name', 'baseurl', 'label',
858                            'distribution:distproduct', 'version:distversion');
859 my @all_required_fields = ();
860 foreach my $field (@required_fields) {
861     push @all_required_fields, split(/:/, $field);
862 }
863
864 # read repos from pre-configured directories of current "schema"
865 sub get_repo_infos () {
866     Log("  Repositories:\n");   # section defined earlier
867     my $rc = $repo_config{$repo_schema};
868
869     foreach my $repofile (sort (glob($rc->{'repos_dir'}."/*.repo"))) {
870         if (!open(REPO, "<$repofile")) {
871             Log("  skip repo, unable to open repo file '$repofile': $!\n");
872             x_tnq('warning', "Skip repo, unable to open file <quote>".x_quote($repofile)."</quote>");
873             $skippedrepos++;
874         } else {
875             # get entries from this *.repo file
876             # we need reposubdir, name, baseurl and type
877             #
878             # Note: it does not matter whether the repo is enabled, we only
879             # want to know whether it has packages identical or comparable to
880             # installed ones, so that the packages in the repo might have been
881             # a source for the installed packages
882             my $repo_id;
883             while (<REPO>) {
884                 $repo_id    = $1, last    if /^\s*\[(.*)\]\s*$/;
885             }
886             if (defined $repo_id) {
887                 my $subdir = $repo_id;
888                 $subdir =~ tr/\//_/;
889
890                 # hash key might be created in creat_reference_data()
891                 my $unique_suffix = '';
892                 $unique_suffix++ while (exists $repoinfo{$subdir . $unique_suffix});
893
894                 $repoinfo{$subdir . $unique_suffix} = {
895                     repo_id     => $repo_id,
896                     subdir      => $subdir,
897                     solvfile    => $rc->{'solv_dir'}."/$subdir/$solvfilename",
898                 };
899
900                 $subdir = $subdir . $unique_suffix;
901                 # read all key=value lines from the file
902                 while (<REPO>) {
903                     $repoinfo{$subdir}->{$1} = $2, next     if /^\s*(\w+)\s*=\s*(.+)\s*$/;
904                     $repo_id = $1, next                     if /^\s*\[(.*)\]\s*$/;
905                 }
906                 close(REPO);
907             } else {
908                 Log("  skip repo without repo id in '$repofile'\n");
909                 x_tnq('warning', "Skip repo without repo id in <quote>".x_quote($repofile)."</quote>");
910                 $skippedrepos++;
911             }
912         }
913     }
914
915     # skip repos without solv file
916     foreach my $subdir (keys %repoinfo) {
917         my $repo_ref = $repoinfo{$subdir};
918         if (! -r $repo_ref->{'solvfile'}) {
919             x_ts('warning');
920             x_t('message', "Skip repo without solv file");
921             x_t('name', $repo_ref->{'name'} // '(none)');
922             x_t('solvfile', $repo_ref->{'solvfile'} // '(none)');
923             x_te();
924             Log("  skip repo '%s', no solv file found (refresh needed?):\n" .
925                    "    solvfile: %s\n    baseurl:  %s\n",
926                 $repo_ref->{'name'} // '(none)',
927                 $repo_ref->{'solvfile'} // '(none)',
928                 $repo_ref->{'baseurl'} // '(none)'
929             );
930             delete $repoinfo{$subdir};
931             $skippedrepos++;
932         }
933     }
934
935     # set up default values for optional fields
936     foreach my $subdir (keys %repoinfo) {
937         $repoinfo{$subdir}->{'sp_version'} = 0;
938     }
939
940     # TODO: get solv file mod time and evaluate repository:timestamp and
941     # repository:expire, and maybe consider evaluating the autorefresh tag
942     # - get repo : timestamp field
943     # - need to add perl binding for dumping repo data
944
945     # get label, dist, version, sp_version and others for repository
946     foreach my $subdir (keys %repoinfo) {
947         my $repo_ref = $repoinfo{$subdir};
948
949         # create pool
950         my $pool = new satsolver::Pool;
951
952         # set architecture: only compatible packages are considered
953         $pool->set_arch($sysarch);
954
955         my $repo = $pool->create_repo($subdir) || Die(2, "satsolver: create_repo($subdir)\n");
956         $repo->add_solv($repo_ref->{'solvfile'});
957         # FIXME: define precedence
958         # repository:timestamp - unused
959         #my $repo_ts = get_repo_ts($repo_ref->{'solvfile'}, $repo);
960         # file timestamp from cookie or stat
961         my $solv_ts = $repo_ref->{'solv_ts'} = get_solv_ts($repo_ref->{'solvfile'});
962
963         # find the "product:" solvable(s)
964         foreach my $solvable ($repo->solvables()) {
965             Die(2, "solvable not defined\n") if(!defined $solvable);
966
967             # FIXME: find multiple products via "product:" and/or via
968             # $prodinfo{...}->{release_{product_name,evr,arch}};
969             # print all products found in the repo
970
971             if ($solvable->name() =~ /^product:/i) {
972                 my $prod_ref;
973                 $repo_ref->{'num_products'}++;
974                 if ($repo_ref->{'num_products'} > 1) {
975                     # infos for product #2 and higher are stored under a
976                     # "product#" key
977                     $prod_ref = $repo_ref->{'product' . $repo_ref->{'num_products'}};
978                 } else {
979                     $prod_ref = $repo_ref;
980                 }
981                 $prod_ref->{'arch'}         = $solvable->attr('solvable:arch') || undef;
982                 $prod_ref->{'label'}        = $solvable->attr('solvable:summary') || undef;
983                 $prod_ref->{'distribution'} = $solvable->attr('solvable:distribution') || undef;
984                 $prod_ref->{'distproduct'}  = $solvable->attr('product:distproduct') || undef;
985                 $prod_ref->{'distversion'}  = $solvable->attr('product:distversion') || undef;
986                 if (exists $repo_ref->{'reference_data'}) {
987                     # provide a fake baseurl for reference data
988                     my $url = $solvable->attr('product:url');
989                     $url =~ /^(.*\/)[^\/]+/;
990                     $prod_ref->{'baseurl'}  = $1 // $url // 'http://www.novell.com/linux/';
991                 }
992                 if ($solvable->attr('solvable:evr') =~ /^(\d+)(?:-(\d+))?$/) {
993                     $prod_ref->{'version'}      = $1;
994                     $prod_ref->{'sp_version'}   = $2 // 0;
995                 }
996             }
997         }
998     }
999
1000     # check for required fields, delete repo if fields are missing
1001     foreach my $subdir (keys %repoinfo) {
1002         my $repo_ref = $repoinfo{$subdir};
1003         my $deleted = 0;
1004         foreach my $field_list (@required_fields) {
1005             my $found = 0;
1006             my $tries = 0;
1007             foreach my $field (split(/:/, $field_list)) {
1008                 $tries++;
1009                 $found = 1 if (defined $repo_ref->{$field});
1010             }
1011             if (!$found) {
1012                 my @a;
1013                 map { push @a, $_, $repo_ref->{$_} // '(undef)' } @all_required_fields;
1014
1015                 Log("  skip repo '$subdir', undefined field%s '%s':\n",
1016                     $tries > 1 ? 's' : '',
1017                     join("' or '", split(/:/, $field_list)));
1018                 Log(fmt_table2('    ', @a));
1019
1020                 x_ts('warning');
1021                 x_t('message', 'Skip repo with missing field');
1022                 x_ts('fields');
1023                 for(my $i=0;$i<=$#a;$i+=2) {
1024                     x_t('name', $a[$i]);
1025                     x_t('value', $a[$i+1]);
1026                 }
1027                 x_te();
1028                 x_te();
1029
1030                 delete $repoinfo{$subdir};
1031                 $skippedrepos++;
1032                 $deleted=1;
1033                 last;
1034             }
1035         }
1036
1037         # skip product repos with defined and incompatible arches
1038         # not all repos have architecture, but solver will handle that
1039         if(!$deleted && defined($repo_ref->{'arch'}) && !is_compatible_arch($sysarch, $repo_ref->{'arch'})) {
1040             Log("  skip repo '$subdir', incompatible arch %s\n", $repo_ref->{'arch'});
1041             x_ts('warning');
1042             x_t('message', 'Skip repo, incompatible arch');
1043             x_t('name', $subdir);
1044             x_t('arch', $repo_ref->{'arch'});
1045             x_te();
1046             delete $repoinfo{$subdir};
1047             $skippedrepos++;
1048             next;
1049         }
1050     }
1051
1052     # delete repos for other than installed products (if desired)
1053     if ($opt_skip_unmatched_prod) {
1054         foreach my $repo (keys %repoinfo) {
1055             my $repo_ref=$repoinfo{$repo};
1056             my $found=0;
1057             foreach my $prod (keys %prodinfo) {
1058                 my $prod_ref=$prodinfo{$prod};
1059                 if($repo_ref->{'distribution'} eq $prod_ref->{'installconfig'}->{'distribution'}) {
1060                     $found=1;
1061                     last;
1062                 }
1063             }
1064             if(!$found) {
1065                 Log("  skip repo '%s', product '%s' not installed\n",
1066                     $repo_ref->{'name'}, $repo_ref->{'distribution'});
1067                 x_ts('warning');
1068                 x_t('message', "Skip repo, product not installed");
1069                 x_t('name', $repo_ref->{'name'});
1070                 x_t('product', $repo_ref->{'distribution'});
1071                 x_te();
1072                 delete $repoinfo{$repo};
1073                 $skippedrepos++;
1074             }
1075         }
1076     }
1077
1078     # make duplicate names and labels unique
1079     foreach my $subdir (keys %repoinfo) {
1080         my $repo_ref = $repoinfo{$subdir};
1081
1082         my $name            = $repo_ref->{'name'};
1083         my $label           = $repo_ref->{'label'};
1084         my $next_name_cnt   = 2;
1085         my $next_label_cnt  = 2;
1086         foreach my $subdir2 (keys %repoinfo) {
1087             next        if ($subdir eq $subdir2);
1088
1089             if ($name eq $repoinfo{$subdir2}->{'name'}) {
1090                 $repoinfo{$subdir2}->{'name'} = "$name (" . ($next_name_cnt++) . ')';
1091             }
1092             if ($label eq $repoinfo{$subdir2}->{'label'}) {
1093                 $repoinfo{$subdir2}->{'label'} = "$label (" . ($next_label_cnt++) . ')';
1094             }
1095         }
1096         $repo_ref->{'name'}  = "$name (1)"     if $next_name_cnt > 2;
1097         $repo_ref->{'label'} = "$label (1)"    if $next_label_cnt > 2;
1098     }
1099
1100     foreach my $subdir (keys %repoinfo) {
1101         if(repo_too_old($repoinfo{$subdir}->{'solv_ts'})) {
1102             Log("  repository '$subdir' seems to be old, please refresh\n");
1103             x_ts('warning');
1104             x_t('message', 'Repository seems to be old, please refresh');
1105             x_t('name', $subdir);
1106             x_te();
1107             $needrefresh++;
1108             $repo_to_refresh{$subdir}=$repoinfo{$subdir};
1109             $repo_to_refresh{$subdir}->{'refresh_reason'}='not updated recently';
1110         }
1111     }
1112
1113
1114     # assign number and print found repos
1115     my $cnt = 0;
1116     foreach my $subdir (repo_keys_sorted(keys %repoinfo)) {
1117         my $repo_ref = $repoinfo{$subdir};
1118         $repo_ref->{'number'}   = ++$cnt;
1119
1120         my @a;
1121         push @a, 'name:',$repo_ref->{'name'}; 
1122         push @a, 'label:',$repo_ref->{'label'}; 
1123         push @a, 'distribution:',$repo_ref->{'distribution'}; 
1124         push @a, 'baseurl:',$repo_ref->{'baseurl'}; 
1125         push @a, 'reference_data:', $repo_ref->{'reference_data'} ? "yes" : "no";
1126
1127         Log("  found repository #%d:\n", $repo_ref->{'number'});
1128         Log(fmt_table2('    ', @a));
1129
1130         x_ts('repository');
1131         x_t('name', $repo_ref->{'name'});
1132         x_t('label', $repo_ref->{'label'});
1133         x_t('distribution', $repo_ref->{'distribution'});
1134         x_t('baseurl', $repo_ref->{'baseurl'});
1135         x_t('reference_data', $repo_ref->{'reference_data'} ? "yes" : "no");
1136         x_te();
1137     }
1138 }
1139
1140 sub get_sysarch {
1141     if(defined $opt_sysarch) {
1142         # forced by user
1143         $sysarch = $opt_sysarch;
1144     } else {
1145         # arch from baseproduct
1146         if (exists $prodinfo{$baseproduct}) {
1147             $sysarch = $prodinfo{$baseproduct}->{'arch'};
1148         } else {
1149             $sysarch = `uname -m` || Die(1, "Unable to read system architecture by 'uname -m', please specify with --sysarch option.\n");
1150         }
1151         # the rest must be compatible
1152         foreach (values %prodinfo) {
1153             my $prodarch = $_->{'arch'};
1154             if ($prodarch eq '(none)' or !defined $prodarch) {
1155                 Die(2, "  Found product without architecture. Please check your installation!\n");
1156             }
1157             if(!is_compatible_arch($sysarch, $prodarch)) {
1158                 Die(2, "Architectures for installed products incompatible (sys: $sysarch, found: $prodarch), please specify with --sysarch option.\n");
1159             }
1160         }
1161     }
1162 }
1163
1164 # ---------------------------------------------------------------------------
1165 # Setting up a keyring with SUSE/Novell build keys
1166 #
1167
1168 # SUSE/Novell build key of supported packages
1169 # FIXME: what about 3rd party packages? get some trusted repo of keys?
1170 my $Buildkeys = join('|', (
1171    'SuSE Package Signing Key',
1172    'SUSE PTF Signing Key',
1173    'SuSE Security Team',
1174    'Novell Provo Build',
1175    'Open Enterprise Server'
1176 ));
1177
1178 # SUSE/Novell repository content file labels for supported installation sources
1179 my $Labels = qr/(?:SUSE|Novell)/;
1180
1181 # parse key data from gpg output
1182 sub setup_key () {
1183     my $cmd;
1184     my ($key_id_string, $date, $pub_comment, $pub_line);
1185
1186     # only consider *.key and *.asc files
1187     return if not /\.(?:key|asc)$/i;
1188
1189     # find public keys and check comment string against SUSE/Novell vendor strings
1190     $cmd = "$gpg_command \"$File::Find::name\"";
1191     LogCmd("+$cmd\n");
1192     open(FH, "$cmd 2>&1 |") || Die(1, "$cmd: failed to execute: $!\n");
1193     while (<FH>) {
1194         chomp;
1195         if (/^pub\s+(\S+)\s+(\S+)\s+(.*)$/) {
1196             ($key_id_string, $date, $pub_comment) = ($1, $2, $3);
1197             $pub_line = $_;
1198         }
1199         LogCmd("  $_\n");
1200     }
1201     close(FH);
1202
1203     if (!defined $pub_comment) {
1204         LogCmd("  gpg: not a public key file: $File::Find::name\n");
1205     } elsif ($pub_comment =~ /^$Buildkeys/o) {
1206         if (!defined $good_key_ids{$key_id_string}) {
1207             LogCmd("  gpg: using SUSE/Novell public key file:\n       $File::Find::name\n       $pub_line\n");
1208             $good_key_ids{$key_id_string} = $pub_line;
1209
1210             $cmd = "$gpg_command --import \"$File::Find::name\"";
1211             System($cmd);
1212         } else {
1213             LogCmd("  gpg: already imported SUSE/Novell public key file:\n       $File::Find::name\n       $pub_line\n");
1214         }
1215     } else {
1216         LogCmd("  gpg: not using foreign public key file:\n       $File::Find::name\n       $pub_line\n");
1217     }
1218 }
1219
1220 # ---------------------------------------------------------------------------
1221 # Is the package from us?
1222 #
1223 sub is_our_package ($$$$$) {
1224     my ($rsaheadersig, $dsaheadersig, $rpmheader, $package_name, $vendor) = @_;
1225     my $headersig;
1226     my $cmd;
1227     my $is_ours = 0;
1228
1229     # user asked to skip sig check or
1230     # no SUSE/Novell keys we could use for checking?
1231     if (not $opt_header_sig_check or scalar (keys %good_key_ids) == 0) {
1232         #Dbg("no checksig and no keys, match vendorname only");
1233         # cannot check, so fall back to the vendor string in the RPM DB and
1234         # continue anyway, hoping for the best
1235
1236         $num_sig_ok_packs++;
1237         return $vendor =~ /^$Vendors/o;
1238     }
1239
1240     # does the RPM DB have a signature for the header?
1241     # use RSAHEADER (more hash bits) if available, or fall back to DSAHEADER
1242     $headersig = ($rsaheadersig =~ /\(none\)/) ? $dsaheadersig : $rsaheadersig;
1243     if ($headersig =~ /\(none\)/) {
1244         # cannot check, prepare log message
1245         if ($vendor =~ /^$Vendors/o) {
1246             # if one of 'our' packages had no signature (should not happen),
1247             # if it is a "foreign" package without signature
1248             Log("  no header signature but looks like our package: $package_name\n    vendor: $vendor\n");
1249         } else {
1250             Log("  no header signature, not our package: $package_name\n    vendor: $vendor\n");
1251         }
1252         # we have keys to verify signatures, but this package has no signature:
1253         # not ours
1254         return 0;
1255     }
1256
1257     # convert hex strings to binary
1258     my $rpmheader_bin = pack('H*H*', $headerprefix, $rpmheader);
1259     my $headersig_bin = pack('H*', $headersig);
1260
1261     # save RPM header and signature
1262     open(FH, ">$signedfile") || Die(1, "open($signedfile): $!\n");
1263     print(FH $rpmheader_bin);
1264     close(FH);
1265     open(FH, ">$sigfile") || Die(1, "open($sigfile): $!\n");
1266     print(FH $headersig_bin);
1267     close(FH);
1268
1269     # check the signature of the RPM header with our selected keys
1270     $cmd = "$gpg_command --verify $sigfile $signedfile";
1271     open(FH, "$cmd 2>&1 |") || Die(1, "command failed: $cmd: $!\n");
1272     while (<FH>) {
1273         chomp;
1274         if (/^gpg:\s*Good\s+signature/i) {
1275             LogCmd("  $_: $package_name: $vendor\n");
1276             $is_ours = 1;
1277
1278             # warn if VENDOR does not look ok
1279             if ($vendor !~ /^$Vendors/o) {
1280                 Log("  header signature ok, wrong vendor for: $package_name $vendor\n");
1281             }
1282         } elsif (/^gpg:\s*(?:Can't|Cannot)\s+check\s+signature/i) {
1283             LogCmd("  $_: $package_name: $vendor\n");
1284         }
1285     }
1286     close(FH);
1287
1288     $num_sig_ok_packs += $is_ours;
1289
1290     return $is_ours;
1291 }
1292
1293 # ---------------------------------------------------------------------------
1294 # Check if the package match the installed products (matching codestream)
1295 sub matches_installed_products ($) {
1296     my ($disturl) = @_;
1297     my $matches_installed_products = 0;
1298
1299     # does "codestream" part of disturl match codestreams from installed
1300     # SUSE/Novell prod files?
1301     # schema: obs://build.suse.de/SUSE:SLE-11:GA/standard
1302     if ($disturl =~ /^($codestream_schema)/o and $1 =~ /^$allowed_codestreams$/o) {
1303         $matches_installed_products = 1;
1304     }
1305
1306     $num_prod_ok_packs += $matches_installed_products;
1307
1308     return $matches_installed_products;
1309 }
1310
1311
1312 # return pretty-printed result
1313 sub pretty_print_result($) {
1314     my ($file, $modstr) = @_;
1315     my ($pretty, $result);
1316
1317     my %pretty_print_result = (
1318         'S' => 'size',
1319         'M' => 'mode',
1320         '5' => 'checksum',
1321         'D' => 'device-node',
1322         'L' => 'sym-link',
1323         'U' => 'owner',
1324         'G' => 'group',
1325         'T' => 'mod-time',
1326         '?' => 'cannot-read',
1327     );
1328
1329     $result = $file2res{$file};
1330     if (!defined $result) {
1331         Dbg("undefined file result for $file");
1332         return 'UNKNOWN';
1333     }
1334
1335     $modstr = 'mod: ' unless defined $modstr;
1336     $_ = $result;
1337     if (/^U\:miss\s*(.)(\s+(.*))?$/) {
1338         $pretty = 'missing' . (defined $3 ? " $3" : '');
1339     } elsif (/^(U|T)\:mod (?:.):([SM5?DLUGT]+)(?: (?:.*)|)$/) {
1340         # type, (kind), summary, (rest)
1341         my @l = map( $pretty_print_result{$_}, split(//, $2));
1342         $pretty = ($1 eq 'U' ? $modstr : 'tolerable: ') . join(' ', @l);
1343     }
1344     return $pretty;
1345 }
1346
1347 #
1348 # Create pretty-printed string for a size in bytes
1349 #
1350 sub pretty_print_size($) {
1351     my ($n) = @_;
1352
1353     my ($f, $p);
1354     my @P = ('M', 'G', 'T');
1355
1356     if ($n < 0) {
1357         return sprintf('%3d kB??', $n);
1358     } elsif ( $n < 1000 ) {
1359         return sprintf('%3d kB', $n);
1360     }
1361
1362     while ($n > 999) {
1363         $p = shift(@P);
1364         $f = $n % 1024;
1365         $n = $n >> 10;
1366     }
1367
1368     if ($n > 9) {
1369         return sprintf('%3d %sB', $n, $p);
1370     }
1371
1372     $f = int(($f * 10 ) / 1024);
1373     return sprintf('%d.%d %sB', $n, $f, $p);
1374 }
1375
1376 #
1377 # Execute program and die on errors with appropriate message
1378 # Program output is logged at log level 2
1379 # Also logs the command at log level 8
1380 #
1381 sub System ($) {
1382     my ($cmd) = @_;
1383     my @C = split(/ /, $cmd);
1384
1385     LogCmd("+$cmd\n");
1386
1387     # open a pipe to catch output as well
1388     open(FH, "$cmd 2>&1 |") || Die(1, "$C[0]: failed to execute: $!\n");
1389     LogCmd("  $_") while (<FH>);
1390     close(FH);
1391
1392     if (WIFSIGNALED($?)) {
1393         Die(1, "$C[0]: died with signal %d, %s coredump\n",
1394                 (WTERMSIG($?)),  ($? & 128) ? 'with' : 'without');
1395     } elsif (WEXITSTATUS($?) != 0) {
1396         Die(1, "$C[0]: failed with error code %d\n", WEXITSTATUS($?));
1397     }
1398 }
1399
1400 # ---------------------------------------------------------------------------
1401 # Find files that do not belong to any RPM package
1402 #
1403 # TODO: handle exclusion of directories
1404 #
1405
1406 my @orphans = ('undef');
1407 my %dirpath2devinode;
1408 my %dircontents;
1409
1410 sub find_orphans($) {
1411     our ($rootdir) = @_;
1412     our ($rootlen, $rootdev, $ignoredir);
1413     # based on 'airbag,v 1.2 2001/10/02 15:04:30'
1414     # created by Torsten Duwe
1415     # modified by Raymund Will
1416
1417     # "find" of additional files; more precisely files and directories that
1418     # do not come from installed RPMs.
1419
1420     # We take a fsck-like approach: %dirpath2devinode holds a [dev:inode]
1421     # pair for given directory path(s) and %dircontents stores the
1422     # directory content's names, as if they had been received via
1423     # opendir() and readdir().
1424
1425     # First we fill the %dirpath2devinode / %dircontents cache with
1426     # list info from "rpm -qal", then we do a "find /" and report all new
1427     # files and dirs encountered, pruning dirs, of course. A few
1428     # well-known candidates are suppressed, for convenience.
1429
1430     # subroutine pathhash: make sure [dev:inode] pair for this path is
1431     # known as well as those of all of its parents. Argument is a path
1432     # string.
1433     sub pathhash($);
1434     sub pathhash($){
1435         my($path) = @_;
1436         my($dev,$ino,$mode,@rest,$parent,$myname);
1437
1438         # defensive programming: make sure our path string has exactly
1439         # one slash at the beginning and for subdir separation, and no
1440         # slash at the end.
1441         $path =~ s,/+,/,g;
1442         #$path =~ s,/$,,g;
1443         $path =~ s,^/,,g;
1444         $path = "/$path";
1445         Dbg("pathhash($path): -> '$path'");
1446
1447         if (defined $dirpath2devinode{$path}) {
1448             Dbg(" => known");
1449             return;
1450         } # already known
1451         Dbg(" : stat\n");
1452
1453         ($dev,$ino,$mode,@rest) = stat($rootdir . $path);
1454         if (@rest < 10) {
1455             Dbg("cannot stat($rootdir,$path): $!");
1456             return;
1457         }
1458
1459         # if we stat()ed a directory, let's remember it.
1460         if (($mode & 0xf000) == 0x4000) {
1461             $dirpath2devinode{$path} = "$dev:$ino";
1462             $dircontents{"$dev:$ino"} = '' unless defined($dircontents{"$dev:$ino"});
1463         }
1464
1465         # so this one was new. how about the parent dir ? recursion will
1466         # stop at "/" (provided it's the real root!), which is its own
1467         # parent and will be "already known" above.
1468         return if ($path eq '/');
1469
1470         $parent = $path;
1471         $parent =~ s,/([^/]*)/?$,,;
1472         $myname = $1;
1473
1474         $parent =~ s,^/,,;
1475         $parent = "/$parent";
1476         #  print(STDERR "parent='$parent' myname='$myname'   %> ");
1477
1478         pathhash($parent);
1479
1480         # back from recursion -- ensure this path's name is listed in
1481         # parent's contents.
1482         if ($dircontents{$dirpath2devinode{$parent}} =~ m,/\Q$myname/, ){
1483             #    print " already have $parent##/##$myname\n";
1484         } else {
1485             $dircontents{$dirpath2devinode{$parent}} .= "/$myname/";
1486             #    print " $parent##/##$myname\n";
1487         }
1488     }
1489
1490     $rootlen = length($rootdir);
1491     $rootdev = (lstat($rootdir))[0];
1492     $ignoredir = 1;
1493     $| = 1;
1494
1495     if ($> == 0 && ( -x './bin/rpm')) {
1496         open(FLIST, "chroot '$rootdir' ./bin/rpm -qal |") ||
1497         Die(1, "cannot exec 'chroot rpm -qa': $!\n");
1498     } else {
1499         open(FLIST, "/bin/rpm -qal --root '$rootdir'|") ||
1500         Die(1, "cannot exec 'rpm -qa': $!\n");
1501     }
1502
1503     while(<FLIST>){
1504         my($dir, $fname, $inode);
1505         chomp;
1506         s,/$,,;                 # doesn't ever happen, anyway.
1507         s,/+,/,g;
1508         m,^(.*/)([^/]+)$, || next;
1509         $dir = $1;
1510         $fname = $2;
1511
1512         $dir =~ s,^/,,;
1513         $dir = "/$dir";
1514
1515         next unless (-d "$rootdir$dir");
1516         pathhash($dir);
1517         $inode = $dirpath2devinode{$dir};
1518         $dircontents{$inode} .= "/$fname/";
1519     }
1520     close(FLIST);
1521
1522     # subroutine wanted: called by the file tree walk for every node, with
1523     # the basename() of the current node as string argument.
1524     sub wanted() {
1525         my($dir) = '/' . substr($File::Find::dir, $rootlen) . '/';
1526         $dir =~ s,/+,/,g;
1527         Dbg("wanted: $_, dir='$dir'") if ($debug > 1);
1528
1529         # omit dot and dotdot, backup files, and well-known boring paths.
1530         /^\.\.?$/ && return;
1531         /~$/ && return;
1532
1533         my ($dev,$ino,$mode,$size) = (lstat)[0,1,2,7];
1534         $sum_all_inodes++;
1535         $sum_all_fsize += ($size + 512) / 1024;
1536         # only root device is checked
1537         if ($dev != $rootdev ) { $File::Find::prune = 1; return; }
1538         if ($File::Find::name =~ m,^/vmlinu, ) { return; }
1539         if ($File::Find::name =~ m,^/initrd, ) { return; }
1540         if ($File::Find::name =~ m,/man/whatis$, ) { return; }
1541         if ($File::Find::name =~ m,^/proc, ) { $File::Find::prune = 1; return; }
1542         if ($File::Find::name =~ m,^/root, ) { $File::Find::prune = 1; return; }
1543         if ($File::Find::name =~ m,^/home, ) { $File::Find::prune = 1; return; }
1544         if ($File::Find::name =~ m,^/tmp, ) { $File::Find::prune = 1; return; }
1545         #if ($File::Find::name =~ m,^/var, ) { $File::Find::prune = 1; return; }
1546         #if ($File::Find::name =~ m,^/usr, ) { $File::Find::prune = 1; return; }
1547         if ($File::Find::name =~ m,^/etc/rc\.d/rc[0-6]\.d, )
1548             { $File::Find::prune = 1; return; }
1549
1550         # see if we know the dir we're in
1551         pathhash($dir);
1552         my $inode = $dirpath2devinode{$dir};
1553
1554         # does it know about the file/dir we're examining at this invocation ?
1555         if ($dircontents{$inode} =~ /\/\Q$_\//) {               # yes, ok.
1556             Dbg("known: ($dir) $_") if ($debug > 2);
1557             return;
1558         } elsif ($dir eq '/home/httpd/icons/') {
1559             Dbg("UNknown: ($dir) $_") if ($debug > 2);
1560             Dbg("$inode=>'$dircontents{$inode}'") if ($debug > 2);
1561         }
1562
1563         # if not, let's have a closer look.
1564
1565         # we're not interested in symlinks at all.
1566         if (($mode & 0xf000) == 0xa000) { return;  }
1567
1568         my $isdir = '';
1569         if (($mode & 0xf000) == 0x4000) {
1570             return if ($ignoredir);
1571             $isdir =  '/';
1572             # maybe we know this directory, but by another name, if
1573             # the installation has followed symlinks like /opt -> /usr/opt
1574             return if (defined $dircontents{"$dev:$ino"});
1575         }
1576
1577         $File::Find::prune = 1;
1578         # the rare case of a l+f directory under a mount point. Checked here
1579         # because of its low probability and because we want prune=1 for it.
1580         return if ($isdir eq '/' && $_ eq 'lost+found' && $inode =~ /:2$/);
1581         #print" $File::Find::name$isdir\n";
1582         push @orphans, "$dir$_$isdir";
1583     }
1584
1585     find(\&wanted, $rootdir); # Launch !
1586 }
1587
1588 # ---------------------------------------------------------------------------
1589 # Return filehandle for the list of RPMs with ancillary data.
1590 # May use cached data or pipe directly from the rpm command.
1591 #
1592 sub rpm_qa($) {
1593     my $FH;
1594     my $rpmQ = "$rpm_command -qa --qf " .
1595         "'%{NAME}  %{VERSION}-%{RELEASE}  %|EPOCH?{%{EPOCH}:}:{}|%{VERSION}-%{RELEASE}  %{ARCH}  " .
1596         "%{INSTALLTIME}  %{BUILDTIME}  " .
1597         "%{VENDOR:shescape}  %{DISTRIBUTION:shescape}  %{DISTURL}  " .
1598         "%{RSAHEADER}  %{DSAHEADER}  %{HEADERIMMUTABLE}\n'";
1599
1600     # Either use cache if available...
1601     if ( -d $sam_cache && -r $rpm_qa_cache ) {
1602         open($FH, "< $rpm_qa_cache") || Die(1, "open(rpm -qa): $!\n");
1603         $_ = <$FH>;
1604         if (!/^# (\S+) -- (.*)$/ ) {
1605             Die(2, "$progname: unknown cache format! Please remove.\n" .
1606                 "(e.g. with 'rm -rf $sam_cache/rpm-{qa,Vv})'\n");
1607         } else {
1608             my ($wrong_vers, $wrong_root) = ($cache_file_version ne $1, $root_dir ne $2);
1609             if ($wrong_vers or $wrong_root) {
1610                 Die(2, "$progname: invalid cache: %s%s%s. Please remove it.\n" .
1611                     "(e.g. with 'rm -rf $sam_cache/*')\n",
1612                       ( $wrong_vers ?  "wrong version (found $1, need $cache_file_version)" : '' ),
1613                       ( $wrong_vers and $wrong_root ? ' and' : '' ),
1614                       ( $wrong_root ? "different root dir checked (found $2, checking $root_dir)" : '' ));
1615             } else {
1616                 # use this cache only when debugging -- if not, we prefer to
1617                 # have current information
1618                 if ($debug) {
1619                     return $FH;
1620                 } else {
1621                     close($FH);
1622                 }
1623             }
1624         }
1625     }
1626
1627     LogCmd("+$rpmQ\n");
1628     # ... or read directly from rpm command (and recreate cache if possible)
1629     open($FH, "$rpmQ |") || Die(1, "rpm: $!\n");
1630     if (-d $sam_cache) {
1631         if (open(OUT, "> $rpm_qa_cache") ) {
1632             print OUT "# $cache_file_version -- $root_dir\n";
1633             print OUT while (<$FH>);
1634             close(OUT);
1635             close($FH);
1636
1637             open($FH, "< $rpm_qa_cache") || Die(1, "reopen: $rpm_qa_cache: $!\n");
1638             # skip version / root_dir string
1639             $_ = <$FH>;
1640             # pre-create directory for rpm_V()
1641             if (! -d $rpm_Vv_cache) {
1642                 mkdir($rpm_Vv_cache) || warn "mkdir $rpm_Vv_cache: $!\n";
1643             }
1644             # pre-create directory for rpm_e()
1645             if (! -d $rpm_e_cache) {
1646                 mkdir($rpm_e_cache) || warn "mkdir $rpm_e_cache: $!\n";
1647             }
1648             # rpm -ql cache
1649             if (! -d $rpm_ql_cache) {
1650                 mkdir($rpm_ql_cache) || warn "mkdir $rpm_ql_cache: $!\n";
1651             }
1652         } else {
1653             warn("create: $rpm_qa_cache: $!\n");
1654         }
1655     }
1656     return $FH;
1657 }
1658
1659 #
1660 # return filehandle for the output of "rpm -V..." on a package
1661 # may use cached data or pipe directly from the rpm command
1662 #
1663 sub rpm_V($) {
1664     my ($package) = @_;
1665
1666     my $FH;
1667     my $cache_file = "$rpm_Vv_cache/$package";
1668     my $cache_list_file = "$rpm_ql_cache/$package";
1669     my $extraflags = '';
1670
1671     my %rpm_list;
1672     if (-r $cache_list_file) {
1673         open($FH, "< $cache_list_file") || Die(1, "open($cache_list_file): $!\n");
1674     } else {
1675         open($FH, "$rpm_command -ql '$package' |") || Die(1, "rpm -ql: $!\n");
1676         if (-d $rpm_ql_cache) {
1677             open(OUT, "> $cache_list_file");
1678             print OUT while (<$FH>);
1679             close(OUT);
1680             close($FH);
1681             open($FH, "< $cache_list_file");
1682         }
1683     }
1684     map { my $a=$_; chomp $a; $rpm_list{$a} = undef } <$FH>;
1685     close($FH);
1686
1687     # skip running verify flags (need chroot) for non root
1688     # (yes, this *is* --noscripts option for rpm)
1689     $extraflags .= '--noscript ' if($root_dir ne '/' && $< != 0);
1690     $extraflags .= '--nomd5 ' if(!$opt_rpm_verify_md5);
1691     # not important for supportability check
1692     $extraflags .= '--nouser --nomtime --nogroup';
1693     # --nomode catches permissions AND file type, we want to catch dir 'in place of' file
1694
1695     my $rpmV = "$rpm_command -Vv $extraflags '$package' 2>&1";
1696
1697     if (-r $cache_file) {
1698         open($FH, "< $cache_file") || Die(1, "open($cache_file): $!\n");
1699         LogCmd("+(cached) $rpmV\n");
1700         return ($FH, \%rpm_list);
1701     }
1702
1703     LogCmd("+$rpmV\n");
1704     open($FH, "$rpmV |") || Die(1, "rpm -V: $!\n");
1705     if (-d $rpm_Vv_cache) {
1706         if (open(OUT, "> $cache_file")) {
1707             print OUT while (<$FH>);
1708             close(OUT);
1709             close($FH);
1710
1711             open($FH, "< $cache_file") || Die(1, "reopen($cache_file): $!\n");
1712         } else {
1713             warn("create: $cache_file: $!\n");
1714         }
1715     }
1716     return ($FH, \%rpm_list);
1717 }
1718
1719 #
1720 # return filehandle for the output of "rpm -e --test ..." on a package
1721 # may use cached data or pipe directly from the rpm command
1722 #
1723 sub rpm_e($) {
1724     my ($package) = @_;
1725
1726     my $FH;
1727     my $cache_file  = "$rpm_e_cache/$package";
1728     my $rpme        = "$rpm_command -e --test '$package' 2>&1";
1729
1730     if (-r $cache_file) {
1731         open($FH, "< $cache_file") || Die(1, "open($cache_file): $!\n");
1732         LogCmd("+(cached) $rpme\n");
1733         return $FH;
1734     }
1735
1736     LogCmd("+$rpme\n");
1737     open($FH, "$rpme |") || Die(1, "rpm -e: $!\n");
1738     if (-d $rpm_e_cache) {
1739         if (open(OUT, "> $cache_file") ) {
1740             print OUT while (<$FH>);
1741             close(OUT);
1742             close($FH);
1743
1744             open($FH, "< $cache_file") || Die(1, "reopen($cache_file): $!\n");
1745         } else {
1746             warn("create: $cache_file: $!\n");
1747         }
1748     }
1749     return $FH;
1750 }
1751
1752 # ---------------------------------------------------------------------------
1753 # Assess if this file was changed in an unsupportable way. Return descriptive
1754 # string for the supportability information based on the evaluation of the
1755 # "rpm -V..." output for a single file from some package.
1756 #
1757 # assessment results:
1758 # O:   OK               (miss/mod: no,  supportability problem: no,  report: lvl 4)
1759 # H:   Harmless         (miss/mod: yes, supportability problem: no,  report: lvl 3)
1760 # T:   Tolerable        (miss/mod: yes, supportability problem: no,  report: lvl 2)
1761 # U:   Unsupportable    (miss/mod: yes, supportability problem: yes, report: lvl 1)
1762 #
1763 # change state of files:
1764 #   OK      OK, no changes
1765 #   miss    missing
1766 #   mod     modified
1767 #
1768 # TODO: check report levels are well chosen and documented corrrectly
1769 #
1770 sub assess($$$$$) {
1771     my ($rpm, $file, $kind, $result, $error) = @_;
1772     my $summary_result = $result;
1773     $summary_result =~ tr/.//d;
1774     $error = (defined $error ? " ($error)" : '');
1775
1776     if ($result =~ /^\.{8}$/) {
1777         # file is not modified at all: OK
1778         return 'O:OK';
1779     } elsif ($result eq 'missing ' && $kind eq 'd') {
1780         # missing documentation: Harmless
1781         return 'H:miss doc' . $error;
1782     } elsif ($result eq 'missing ') {
1783         # missing non-documentation file: Unsupportable
1784         return "U:miss   $kind" . $error;
1785
1786     } elsif ($kind eq 'c') {
1787         # existing config file with any kind of changes:
1788         # Harmless
1789         return "H:mod c:$summary_result";
1790
1791     } elsif ($result =~ /^[L.]{8}$/) {
1792         # symlink problem, not always unsupported, just log as tolerated
1793         return "T:mod $kind:$summary_result";
1794     } elsif ($result =~ /^[UG.]{8}$/) {
1795         # existing (non-config) file with ownership change only:
1796         # Tolerable
1797         return "T:mod $kind:$summary_result";
1798     } elsif ($result =~ /^[MUG.]{8}$/) {
1799         # existing (non-config) file with exactly some kind of
1800         # ownership change and file mode change
1801         # can be source of problem: report as tolerable
1802         return "T:mod $kind:$summary_result";
1803     } elsif ($result =~ /^[T.]{8}$/) {
1804         # existing (non-config) file with some kind of metadata
1805         # change that does not affect ownership or file mode (and
1806         # no other changes): Tolerable
1807         return "T:mod $kind:$summary_result";
1808
1809     } else {
1810         # existing (non-config) file
1811         #   - has a change in file size
1812         #   - has a content change
1813         #   - is a device node and major/minor has changed
1814         #   - is a softlink that has changed
1815         # -> Unsupportable
1816         return "U:mod $kind:$summary_result";
1817     }
1818 }
1819
1820 #
1821 # Enumerate packages, keep info about each package, filter out unneeded (gpg keys)
1822 sub enumerate_packages {
1823
1824     sub x_issue {
1825         x_ts('issue', $_[3]);   # + attributes
1826         x_t('package', $_[0]);
1827         x_t('message', $_[1]);
1828         x_t('details', $_[2]);
1829         x_te();
1830     }
1831
1832     Log("%%T: Enumerate packages\n");
1833     x_ts('package-enumeration');
1834     my $IN = rpm_qa($root_dir);
1835     while (<$IN>) {
1836         chomp;
1837         if (!/^(\S+)  (\S+)  (\S+)  (\S+)  ([0-9]+)  ([0-9]+)  '(.*?)'  '(.*?)'  (\S+)  (\S+)  (\S+)  (\S+)$/) {
1838             Log("  rpm: unexpected query response: '%s'\n",$_);
1839             x_ts('warning');
1840             x_t('message', 'RPM unexpected query response');
1841             x_t('response', $_);
1842             x_te();
1843             next;
1844         }
1845
1846         my ($name, $ver, $evr, $arch, $inst_time, $build_time, $vendor, $dist,
1847             $disturl, $rsaheadersig, $dsaheadersig, $rpmheader) =
1848             ($1, $2, $3, $4, $5, $6, $7, $8, $9, $10, $11, $12);
1849         # 'ver' is not always the same as 'evr', both access methods into hashes are possible
1850         # keys share the same data
1851         my $package_name = "$name-$ver.$arch";
1852         my $package_name_evr = "$name-$evr.$arch";
1853         $vendor //= 'undef';
1854
1855         if ($arch eq '(none)' and $package_name =~ /^gpg-pubkey-/) {
1856             # "silently" drop verification keys
1857             Log("  skip key package: $package_name\n");
1858             x_issue($package_name, 'pubkey package', 'skipped', {severity => 'harmless'});
1859             $skipped_packages{$package_name} = "$inst_time $vendor";
1860             next;
1861         }
1862
1863         # check for SUSE/Novell package
1864         my $is_ours = is_our_package($rsaheadersig, $dsaheadersig, $rpmheader, $package_name, $vendor);
1865         my $matches_installed_products = matches_installed_products($disturl);
1866
1867         if ($arch eq '(none)' and $is_ours) {
1868             #if ( $vendor =~ m(^$Vendors)o ) {
1869             # ignore SUSE/Novell packages without architecture info
1870             Log("  skip package without arch: $package_name\n");
1871             x_issue($package_name, 'package without arch', 'skipped', {severity => 'harmless'});
1872             $skipped_packages{$package_name} = "$inst_time $vendor";
1873             next;
1874         }
1875
1876         if (!$is_ours or !$matches_installed_products) {
1877             # remember packages that do not match installed products or come from
1878             # other vendors
1879             if (!$is_ours and $vendor !~ /^$Vendors/o) {
1880                 Log("  foreign vendor package: $package_name\n    vendor: $vendor\n");
1881                 x_issue($package_name, 'foreign vendor', $vendor, {severity => 'critical'});
1882             } elsif (!$matches_installed_products) {
1883                 Log("  foreign codestream package: $package_name\n    codestream: %s\n",
1884                     $disturl =~ /^($codestream_schema)/o ? $1 : $disturl);
1885                 x_issue($package_name, 'foreign codestream',
1886                     $disturl =~ /^($codestream_schema)/o ? $1 : $disturl,
1887                     {severity => 'critical'});
1888             }
1889             $foreigninfo{$package_name} = {
1890                 name       => $name,
1891                 evr        => $evr,
1892                 ver        => $ver,
1893                 arch       => $arch,
1894                 inst_time  => $inst_time,
1895                 build_time => $build_time,
1896                 vendor     => $vendor,
1897                 dist       => $dist,
1898                 disturl    => $disturl,
1899             };
1900             if ($package_name ne $package_name_evr) {
1901                 $foreigninfo{$package_name_evr} = $foreigninfo{$package_name};
1902             }
1903             next;
1904         }
1905
1906         $packinfo{$package_name} = {
1907             name       => $name,
1908             evr        => $evr,
1909             ver        => $ver,
1910             arch       => $arch,
1911             inst_time  => $inst_time,
1912             build_time => $build_time,
1913             vendor     => $vendor,
1914             dist       => $dist,
1915             disturl    => $disturl,
1916         };
1917         if ($package_name ne $package_name_evr) {
1918             $packinfo{$package_name_evr} = $packinfo{$package_name};
1919         }
1920     }
1921     close($IN);
1922     x_te();
1923 }
1924
1925 # have we seen this filename already? -> handle duplicates
1926 # - ignore foreign packages when file is unmodified and present
1927 sub check_and_log_duplicate_file ($) {
1928     my ($args) = @_;
1929     my $file = $args->{'file'};
1930     my $kind = $args->{'kind'};
1931     my $rpm = $args->{'rpm'};
1932     my $is_ours = $args->{'is_ours'};
1933     my $log_buffer_ref = $args->{'r_logbuf'};
1934     my $verify_result = $args->{'verify_result'};
1935     my $error = $args->{'error'};
1936     # verify_result + error: passed down to assess
1937     # is_ours: need to push $file to the correct filelist
1938
1939     my $issue_msg = '';
1940     my $issue_sev = '';
1941
1942     # FIXME:
1943     # this will be used later for improved multihomed file handling: file2*
1944     # will become $file_ref->{*}->...  (except for %file2rpm, the index)
1945     #my $file_ref = $packhash_ref{$rpm}->{'file'}; # unused ATM
1946
1947     if ($ALLOW_MULTIHOMED_OBJECTS) {
1948         # if multihomed files are allowed, all the packages for such a file are
1949         # remembered
1950         push @{ $file2rpm{$file} }, $rpm;
1951         if (exists $file2kind{$file} && $file2kind{$file} ne $kind) {
1952             # FIXME: "... please report" ? or log only for higher verbosity level ?
1953             Log( "    $file: conflicting attributes: $file2kind{$file} != $kind, packaging problem\n");
1954         } else {
1955             $file2kind{$file} = $kind;
1956             #Log("$file\n") if $kind eq "d" && $verify_result eq "missing ";
1957         }
1958     } else {
1959         # if multihomed files are not allowed, log entries will be generated
1960         if (exists $file2rpm{$file}) {
1961             # file is multihomed
1962             $_ = $file2res{$file};
1963             $$log_buffer_ref .= ' 'x4 . "$file in more than one package:\n";
1964             $$log_buffer_ref .= ' 'x6 . "$file2rpm{$file}: ";
1965             if (/^[UTH]:miss/) {
1966                 # a duplicate of a missing object hardly makes it worse...
1967                 $$log_buffer_ref .= "duplicate of missing file: unsupportable\n";
1968                 $file2res{$file} .= " && U:dup :$rpm";
1969                 $issue_msg='duplicate of a missing file';
1970                 $issue_sev='critical';
1971                 if($is_ours) {
1972                     push @file_missing, $file;
1973                     push @{ $unsupportable{$rpm} }, $file;
1974                 } else {
1975                     push @foreign_file_missing, $file;
1976                 }
1977             } elsif (/^U:/) {
1978                 if ($file2type{$file} == FT_DIR) {
1979                     # packaging directories multiple times is OK...
1980                     if($opt_verbose >= 3) {
1981                         $$log_buffer_ref .= "duplicate directory: harmless\n";
1982                         $issue_msg='duplicate directory';
1983                         $issue_sev='harmless';
1984                     } else {
1985                         # stay silent, about this, very common and not useful
1986                         $$log_buffer_ref = undef;
1987                     }
1988                     $file2res{$file} .= " && H:dup:$rpm";
1989                 } else {
1990                     # ...but not other objects
1991                     $$log_buffer_ref .= "duplicate non-directory: unsupportable\n";
1992                     $file2res{$file} .= " && U:dup:$rpm";
1993                     $issue_msg='duplicate non-directory';
1994                     $issue_sev='critical';
1995                     if($is_ours) {
1996                         push @file_modified, $file;
1997                         push @{ $unsupportable{$rpm} }, $file;
1998                     } else {
1999                         push @foreign_file_modified, $file;
2000                     }
2001                 }
2002             } elsif ($file2type{$file} == FT_DIR) {
2003                 # again, packaging directories multiple times is OK...
2004                 if($opt_verbose >= 3) {
2005                     # stay silent, about this, very common and not useful
2006                     $$log_buffer_ref .= "duplicate directory: harmless\n";
2007                     $issue_msg='duplicate directory';
2008                     $issue_sev='harmless';
2009                 } else {
2010                     $$log_buffer_ref = undef;
2011                 }
2012                 $file2res{$file} .= "H:dup: $rpm";
2013             } else {
2014                 $_ = assess($rpm, $file, $kind, $verify_result, $error);
2015                 if (!/^U:/) {
2016                     # ...if it verifies OK, only note
2017                     if($opt_verbose >= 3) {
2018                         $$log_buffer_ref .= "duplicate files are identical\n";
2019                         $issue_msg='duplicate files are identical';
2020                         $issue_sev='harmless';
2021                     } else {
2022                         $$log_buffer_ref = undef;
2023                     }
2024                     $file2res{$file} .= "H:dup: $rpm";
2025                 } else {
2026                     # ...otherwise promote to "Unsupportable"
2027                     $$log_buffer_ref .= "duplicate files differ: unsupportable\n";
2028                     $file2res{$file} = "$_ && U:dup: $rpm && $file2res{$file}";
2029                     x_issue($rpm, 'duplicate files differ', $file, {severity=>'critical'});
2030                     $issue_msg='duplicate files differ';
2031                     $issue_sev='critical';
2032                     if($is_ours) {
2033                         push @file_modified, $file;
2034                         push @{ $unsupportable{$file2rpm{$file}} }, $file;
2035                         push @{ $unsupportable{$rpm} }, $file;
2036                     } else {
2037                         push @foreign_file_modified, $file;
2038                     }
2039                 }
2040             }
2041             # duplicate issues not interesting for foreign packages
2042             if(!$is_ours && $opt_verbose < 2) {
2043                 $$log_buffer_ref = '';
2044             } else {
2045                 x_issue($rpm, $issue_msg, $file, {severity=>$issue_sev});
2046             }
2047             return 1;
2048         }
2049
2050         # not multihomed: record package for this file
2051         $file2rpm{$file} = $rpm;
2052         $file2kind{$file} = $kind;
2053     }
2054     return 0;
2055 }
2056
2057 sub evaluate_supportability_and_record_results ($$) {
2058     my ($args, $assess_output) = @_;
2059     my $file = $args->{'file'};
2060     my $kind = $args->{'kind'};
2061     my $rpm = $args->{'rpm'};
2062     my $is_ours = $args->{'is_ours'};
2063
2064     $file2res{$file} = $_ = $assess_output;
2065     if (/^U:miss/) {
2066         if ($is_ours) {
2067             push @file_missing, $file;
2068             push @{ $unsupportable{$rpm} }, $file;
2069         } else {
2070             push @foreign_file_missing, $file;
2071         }
2072         return;
2073     } elsif (/^T:miss/) {
2074         if ($is_ours) {
2075             push @file_dispensable, $file;
2076             push @{ $tolerable{$rpm} }, $file;
2077         } else {
2078             push @foreign_file_dispensable, $file;
2079         }
2080         return;
2081     } elsif (/^H:miss/) {
2082         if ($is_ours) {
2083             push @file_dispensable, $file;
2084             push @{ $harmless{$rpm} }, $file;
2085         } else {
2086             push @foreign_file_dispensable, $file;
2087         }
2088         return;
2089
2090     } elsif (/^U/) {
2091         if ($is_ours) {
2092             push @file_modified, $file;
2093             push @{ $unsupportable{$rpm} }, $file;
2094         } else {
2095             push @foreign_file_modified, $file;
2096         }
2097     } elsif (/^T/) {
2098         if ($is_ours) {
2099             push @file_tolerated, $file;
2100             push @{ $tolerable{$rpm} }, $file;
2101         } else {
2102             push @foreign_file_tolerated, $file;
2103         }
2104     } elsif (/^H/) {
2105         if ($is_ours) {
2106             push @{ $harmless{$rpm} }, $file;
2107         }
2108     } elsif (/^O/) {
2109     } else {
2110         Die(2, "$progname: internal error. Unknown assessment output '$_'\n");
2111     }
2112
2113     # when we see the file for the first time, add to total size of all files,
2114     # increase number of different files and remember type of file (file, dir,
2115     # link, special)
2116     my ($dev,$ino,$size) = (lstat($root_dir . $file))[0,1,7];
2117     if(!defined($dev) || !defined($ino)) {
2118         if ($is_ours) {
2119             push @file_missing, $file;
2120             push @{ $unsupportable{$rpm} }, $file;
2121         } else {
2122             push @foreign_file_missing, $file;
2123         }
2124         return;
2125     }
2126
2127     if (-f _) {
2128         $file2type{$file} = FT_FILE;
2129         if (!exists $inodes{"$dev:$ino"}) {
2130             $sum_pkg_fsize += ($size + 512) / 1024;
2131         }
2132     } elsif (-d _) {
2133         $file2type{$file} = FT_DIR;
2134     } elsif (-l _) {
2135         $file2type{$file} = FT_LINK;
2136     } else {
2137         $file2type{$file} = FT_SPECIAL;
2138     }
2139
2140     if (!exists $inodes{"$dev:$ino"}) {
2141         $inodes{"$dev:$ino"} = 1;
2142         $sum_pkg_inodes++;
2143     }
2144 }
2145
2146 # verify installed packages state
2147 # run 'rpm -V' command, capture output and categorize the packages
2148 #from rpm
2149 #
2150 #file kinds/attributes:
2151 #    c %config configuration file.
2152 #    d %doc documentation file.
2153 #    g %ghost file (i.e. the file contents are not included in the package payload).
2154 #    l %license license file.
2155 #    r %readme readme file.
2156
2157
2158 sub verify_packages ($$$$) {
2159     my ($packhash_ref, $unsatisfied_ref, $msg, $is_ours) = @_;
2160
2161     foreach my $rpm (sort(keys %$packhash_ref)) {
2162         my $log_buffer = '';
2163         my %args=('r_logbuf' => \$log_buffer, 'rpm' => $rpm, 'is_ours' => $is_ours);
2164
2165         Log("  $msg: $rpm\n");
2166         my ($IN, $rpm_list) = rpm_V($rpm);
2167         while (<$IN>) {
2168             chomp;
2169             /^.{12}(.*)$/;
2170             my $fn = $1;
2171             if (/^([S.][M.][5?.][D.][L.][U.][G.][T.]|missing )  ([cdglr ]) (\S.+)$/) {
2172                 if (!exists $rpm_list->{$fn}) {
2173                     # probably installed with --excludepath
2174                     Log("    $fn: verified file does not exist in rpm's file list, skip\n");
2175                     next;
2176                 }
2177                 # note: rpm(8) calls the file kind (%config, %doc, ...) an
2178                 # "attribute" of the file
2179                 my ($verify_result, $kind, $file, $error) = ($1, $2, $3, undef);
2180                 if ($verify_result =~ /missing/ and $file =~ /^(\S.+) \(([^\(\)]*)\)$/) {
2181                     $file = $1;
2182                     $error = $2;
2183                 }
2184                 $args{'file'}=$file;
2185                 $args{'kind'}=$kind;
2186                 $args{'verify_result'}=$verify_result;
2187                 $args{'error'}=$error;
2188
2189                 next if(check_and_log_duplicate_file(\%args));
2190
2191                 # is the result for the file a supportability problem? classify...
2192                 my $assess_output = assess($rpm, $file, $kind, $verify_result, $error);
2193                 evaluate_supportability_and_record_results(\%args, $assess_output);
2194             } elsif (/^Unsatisfied dependencies for ([^:]+)\: (\S.+)$/) {
2195                 my ($pkg, $deps) = ($1, $2);
2196                 $$unsatisfied_ref{$pkg} = $deps;
2197             } else {
2198                 next if (/^package\s+(.*)\s+is not installed$/);
2199                 # glue next line of output
2200                 my $nextline = <$IN>;
2201                 $_ .= "\n$nextline" if (defined $nextline);
2202                 Die(1, "$progname: rpm: unexpected query response:\n$_\n");
2203             }
2204         }
2205         close($IN);
2206
2207         Log($log_buffer) if($log_buffer);
2208     }
2209 }
2210
2211 sub identify_package_sources {
2212
2213     sub x_version {
2214         x_ts('repo-entry');
2215         x_t('package', $_[0]);
2216         x_t('type', $_[1]);
2217         x_t('repository', $_[2]);
2218         x_tnq('version', $_[3]);
2219         x_te();
2220     }
2221
2222     # create pool
2223     my $pool = new satsolver::Pool;
2224
2225     # set architecture: only compatible packages are considered
2226     $pool->set_arch($sysarch);
2227
2228     # create repo with RPM database
2229     my $installed = $pool->create_repo('installed') || Die(2, "satsolver: cannot create repository of installed packages\n");
2230     $installed->add_rpmdb($root_dir);
2231
2232     x_ts('package-sources');
2233
2234     # create a repo each for SUSE/Novell installation sources
2235     foreach my $subdir (repo_keys_sorted(keys %repoinfo)) {
2236         my $label = $repoinfo{$subdir}->{'label'};
2237         if($label !~ /$Labels/o) {
2238             Log("  skip foreign repo '$label' ($subdir)\n") if($opt_verbose >= 1);
2239             next;
2240         }
2241
2242         Log("  use repo '$label' ($subdir)\n");
2243         x_tnq('note', 'Use repository <quote>'.x_quote($label).'</quote>, subdir <quote>'.
2244             x_quote($subdir).'</quote>');
2245
2246         my $repo = $pool->create_repo($subdir) || Die(2, "satsolver: cannot create repository for '$subdir'\n");
2247         $repo->add_solv($repoinfo{$subdir}->{'solvfile'});
2248     }
2249
2250     # create dependencies to provides table
2251     $pool->prepare();
2252
2253     my @a=(
2254         '+', 'repo has newer version',
2255         '=', 'repo has identical name/version/vendor/arch (verbose: 1)',
2256         '~', 'repo has similar name/version (verbose: 2)',
2257         '?', 'not found in SUSE/Novell repos',
2258         'm', 'no such package in any repo');
2259     Log("  Legend:\n");
2260     Log(fmt_table2('    ', @a));
2261
2262     x_ts('legend');
2263     for(my $i=0;$i<scalar(@a);$i+=2) {
2264         x_ts('entry');
2265         x_t('symbol', $a[$i]);
2266         x_t('meaning', $a[$i+1]);
2267         x_te();
2268     }
2269     x_te();
2270
2271     # find providers for each installed package
2272     foreach my $inst_solvable ($installed->solvables()) {
2273         Die(2, "undefined solvable in installed repo\n") if(!defined $inst_solvable);
2274
2275         my $inst_solvname   = $inst_solvable->name();
2276         my $inst_solvevr    = $inst_solvable->evr();
2277         my $inst_solvstring = $inst_solvable->string();
2278
2279         # skip foreign
2280         next if(!exists $packinfo{$inst_solvstring});
2281
2282         my ($msg, $msg_initial);
2283         $msg = $msg_initial = "  $inst_solvstring\n";
2284         my ($found_id, $found_new, $found_similar) = (0,0,0);
2285         foreach my $solvable ($pool->providers($inst_solvname)) {
2286             next if (!defined $solvable);
2287
2288             my $subdir      = $solvable->repo()->name();
2289             # do not use matches on the 'installed' repo
2290             next            if $subdir eq 'installed';
2291
2292             my $reponame    = $repoinfo{$subdir}->{'name'};
2293             my $reponumber  = $repoinfo{$subdir}->{'number'};
2294
2295             # identical package? (name, arch, evr, vendor, build time,
2296             # requires, ...)
2297             if ($solvable->identical($inst_solvable)) {
2298                 if($opt_verbose >= 1) {
2299                     $msg .= "    = in repo '$reponame' version $inst_solvevr\n";
2300                     x_version($inst_solvstring, '=', $reponame, $inst_solvevr);
2301                 }
2302                 $found_id++;
2303             } else {
2304                 # find out if the repository provides an older or newer package
2305                 my $result      = $solvable->compare($inst_solvable);
2306                 my $solv_evr    = $solvable->evr();
2307                 if ($result < 0) {
2308                     # we are not interested in these now
2309                     if(0) {
2310                     Log("  - %-35s %-15s > %-15s (older evr: %s)\n",
2311                         $inst_solvname, $inst_solvevr, $solv_evr, $reponame);
2312                     }
2313                     #$found{'older'}++;
2314                 } elsif ($result > 0) {
2315                     $msg .= "    + in '$reponame' version $solv_evr\n";
2316                     x_version($inst_solvstring, '+', $reponame, $solv_evr);
2317                     ${$newer_exists{$inst_solvstring}}[$reponumber] = $solv_evr;;
2318                     $found_new++;
2319                 } else {
2320                     # identical evr, different package: manual rebuild installed or in other repo
2321                     if($opt_verbose >= 2) {
2322                         $msg .= "    ~ in repo '$reponame' version $solv_evr\n";
2323                     }
2324                     x_version($inst_solvstring, '~', $reponame, $solv_evr);
2325                     $found_similar++;
2326                 }
2327             }
2328         }
2329         if ($found_id + $found_new + $found_similar == 0) {
2330             $msg .= "    m no such package name exists in SUSE/Novell repos\n";
2331             x_version($inst_solvable, 'm', 'no such package name in Novell repos', '');
2332         } elsif (!$found_id && !$found_new) {
2333             $msg .= "  ? not found in SUSE/Novell repos\n";
2334             x_version($inst_solvstring, '?', 'not found in Novell repos', '');
2335         } elsif ($found_new) {
2336             if (exists $unsupportable{$inst_solvstring}) {
2337                 # FIXME: C&P
2338                 my $xmods='';
2339                 foreach my $pfile (@{ $unsupportable{$inst_solvstring} }) {
2340                     my $res = pretty_print_result($pfile);
2341                     if (length($pfile) + length($res) > 72) {
2342                         $msg .= "    ! package modifications for: $pfile\n".' 'x6 ."$res\n";
2343                     } else {
2344                         $msg .= sprintf(' 'x4 ."%-*s  %s\n", 55 - max((72 - 55), length($res)), $pfile, $res);
2345                     }
2346                     $xmods .= 'package modifications for <quote>' . x_quote($pfile) .
2347                         '</quote>: <quote>' . x_quote($res) . '</quote>';
2348                 }
2349                 x_version($inst_solvstring, '!', 'package modifications', $xmods);
2350             }
2351         }
2352         if($msg ne $msg_initial) {
2353             if ($opt_verbose >= 1) {
2354                 Report($msg);
2355             } else {
2356                 Log($msg);
2357             }
2358         }
2359     }
2360     x_te();
2361 }
2362
2363 # ---------------------------------------------------------------------------
2364 # dependency checker
2365
2366 sub check_dependencies {
2367 # full dependency tree is needed, rpm -e --test does not give indirect deps
2368 # we want to report this too: OUR1 -> OUR2 -> FOREIGN1
2369 # now, OUR1 is not printed
2370
2371 # build list of forward deps
2372 our (%deps, %revdeps, %fulldeps);
2373 foreach my $rpm ((keys %packinfo, keys %foreigninfo)) {
2374     my $IN = rpm_e($rpm);
2375     while (<$IN>) {
2376         chomp;
2377         if(/^error: Failed dependencies:$/) {
2378             $deps{$rpm} = [];
2379         } else {
2380             if (/^error: package\s+(.*)\s+is not installed$/) {
2381                 # missing package found in cache or deleted meanwhile?
2382                 next;
2383             }
2384             /^.*\s+(\S+)$/;
2385             if(!exists $deps{$rpm}) {
2386                 Die(1, "$progname: rpm: unexpected query response:\n  %s\n",$_);
2387             } else {
2388                 push @{ $deps{$rpm} }, $1;
2389             }
2390         }
2391     }
2392     close($IN);
2393 }
2394
2395 # reverse deps
2396 foreach my $dep (keys %deps) {
2397     foreach (@{$deps{$dep}}) {
2398         $revdeps{$_} = [] if(!exists $revdeps{$_});
2399         push @{$revdeps{$_}}, $dep;
2400     }
2401 }
2402
2403 # remove duplicates
2404 foreach (keys %revdeps) {
2405     if(exists $revdeps{$_}) {
2406         my %seen = ();
2407         $revdeps{$_} = [ grep { !$seen{$_}++ } @{$revdeps{$_}} ];
2408     }
2409 }
2410
2411 # generate full dependency list
2412 sub fulldeps_r {
2413     my ($pkg,$vref,$oref)=@_;
2414     return if(exists $vref->{$pkg});
2415     $vref->{$pkg} = undef;
2416     return if(!exists $revdeps{$pkg});
2417     push @$oref, (@{$revdeps{$pkg}});
2418     map { fulldeps_r($_, $vref, $oref) } @{$revdeps{$pkg}};
2419 };
2420 sub fulldeps($) {
2421     return () if(!exists $revdeps{$_[0]});
2422     my %visited = ($_[0] => undef);
2423     my @out = @{$revdeps{$_[0]}};
2424     map { fulldeps_r($_, \%visited, \@out) } @{$revdeps{$_[0]}};
2425     my %seen = ();
2426     return grep { !$seen{$_}++ } @out;
2427 };
2428 map { @{ $fulldeps{$_} } = fulldeps($_) } keys %deps;
2429
2430 # find our with any dependency on foreign
2431 foreach my $rpm (keys %deps) {
2432     next if(!exists $packinfo{$rpm});
2433     my @deplist = sort(grep { exists $foreigninfo{$_} } @{$fulldeps{$rpm}});
2434     next if(!scalar(@deplist));
2435     @{$depends_on_foreign{$rpm}} = @deplist;
2436 }
2437
2438 }
2439
2440 # ---------------------------------------------------------------------------
2441 # utility functions
2442
2443 sub max($$) {
2444     my ($a, $b) = @_;
2445     return ($a > $b) ? $a : $b;
2446 }
2447 # push reference repo keys to the end
2448 sub repo_keys_sorted(@) {
2449     return sort {
2450         $repoinfo{$a}->{'reference_data'} && $repoinfo{$b}->{'reference_data'} ?  $a cmp $b :
2451         $repoinfo{$a}->{'reference_data'} ? 1 : # a < b
2452         -1 # a > b
2453     } @_;
2454 }
2455
2456 # check if system arch is compatible with given arch
2457 my %archstack;
2458 sub is_compatible_arch_step($$);
2459 sub is_compatible_arch_step($$) {
2460     my ($sysarch,$arch)=@_;
2461     return 1 if($sysarch eq $arch);
2462     return 0 if(exists $archstack{$sysarch});
2463
2464     $archstack{$sysarch}=undef;
2465     for my $i (@{$archtable{$sysarch}}) {
2466         next if(exists $archstack{$i});
2467         return 1 if(is_compatible_arch_step($i,$arch));
2468     }
2469     return 0;
2470 }
2471 sub is_compatible_arch($$) {
2472     %archstack=();
2473     return is_compatible_arch_step($_[0], $_[1]);
2474 }
2475 sub filter_hw_arches(@) {
2476     return grep { defined && exists $archtable{$_} } @_;
2477 }
2478 # read repo timestamp (not 100% reliable)
2479 sub get_repo_ts($$) {
2480     my ($solv, $repo) = @_;
2481     if (defined $satsolver::{"Repo::"}->{attr}) {
2482         return $repo->attr('repository:timestamp') // undef;
2483     }
2484     Dbg("Repo::attr not defined (old satsolver package), using fallback 'dumpsolv'");
2485     # solv file existence is checked earlier
2486     open(F, "dumpsolv $solv |") or Die(2, "cannot read solv file '$solv': $!");
2487     my @d = grep(/^repository:/, <F>);
2488     close(F);
2489     chomp @d;
2490     foreach(@d) {
2491         return $1 if(/repository:timestamp:\s*(\d+)/);
2492     }
2493     return undef;
2494 }
2495 sub get_solv_ts($) {
2496     my ($fn) = @_;
2497     my $dir = dirname($fn);
2498     if (open(F, "< $dir/cookie")) {
2499         $_ = <F>;
2500         /[a-z0-9]+\s+(\d+)/;
2501         close(F);
2502         return $1;
2503     } else {
2504         return (stat($fn))[9];   # mtime
2505     }
2506 }
2507
2508 sub repo_too_old($) {
2509     my ($ts) = @_;
2510     return 0 if(!defined $ts);
2511     my $now = time;
2512     my $limit = 7; # days
2513     return 1 if ($now - $ts > 3600*24*$limit);
2514 }
2515
2516 sub is_foreign_codestream($) {
2517     return $_[0] !~ /^($codestream_schema)/ || $1 !~ /^$allowed_codestreams/;
2518 }
2519
2520 # ---------------------------------------------------------------------------
2521 # Main program
2522 #
2523
2524 my $log_timestamp = 1;
2525 my $opt_outdir = './';
2526 {
2527     use Getopt::Long;
2528     use Pod::Usage;
2529     $Getopt::Long::debug = 0;
2530     $Getopt::Long::ignorecase = 0;
2531     $Getopt::Long::bundling = 1;
2532     $Getopt::Long::passthrough = 0;
2533     my $help = 0;
2534     my $man = 0;
2535
2536     # defaults
2537     $opt_verbose = 0;
2538     $opt_header_sig_check = 1;
2539     $opt_rpm_verify = 1;
2540     $opt_orphan_search = 0;
2541     $opt_rpm_verify_md5 = 1;
2542     $opt_print_pkg_summary = 0;
2543     $opt_log_commands = 0;
2544
2545     pod2usage(1) unless (GetOptions(
2546           'help|h' => \$help,
2547           'man', \$man,
2548           'verbose|v+' => \$opt_verbose,
2549           'debug|d+' => \$debug,
2550           'tmpdir|t=s' => \$tmpdir,
2551           'outdir|o=s' => \$opt_outdir,
2552           'refdata|r=s' => \$reference_datadir,
2553           'sysarch=s' => \$opt_sysarch,
2554           'header-sig-check!' => \$opt_header_sig_check,
2555           'log-commands!' => \$opt_log_commands,
2556           'pkg-summary!' => \$opt_print_pkg_summary,
2557           'log-timestamp!' => \$log_timestamp,
2558           'rpm-verify!' => \$opt_rpm_verify,
2559           'rpm-verify-md5!' => \$opt_rpm_verify_md5,
2560           'skip-unmatched-prod!' => \$opt_skip_unmatched_prod,
2561           'orphan-search!' => \$opt_orphan_search,
2562           'dir=s%' => \%opt_dirs,
2563           'exp=s@' => \@opt_exp
2564       ));
2565
2566     pod2usage(-noperldoc => 1, -exitval => 0, -verbose => 1, -message => "This is SAM $prog_version") if ($help);
2567     pod2usage(-noperldoc => 1, -exitval => 0, -verbose => 2) if ($man);
2568 }
2569 $debug = 0 if ($debug <= 0);
2570
2571 if (exists($ARGV[0]) && -d $ARGV[0]) {
2572     $root_dir = File::Spec->canonpath(abs_path($ARGV[0]));
2573     $rpm_command .= " --root \Q$root_dir\E";
2574 }
2575
2576 # ---------------------------------------------------------------------------
2577 # prepare runtime environment
2578
2579 # setup logfiles
2580 my $ts='';
2581 my (undef,$min,$hour,$mday,$mon,$year)=localtime(time);
2582 my $report_ts = sprintf("%2d.%2d.%4d %02d:%02d", $mday, $mon, $year+1900, $hour, $min);
2583 if($log_timestamp) {
2584     $ts=sprintf("-%4d%02d%02d-%02d:%02d", $year+1900,$mon+1,$mday,$hour,$min);
2585 }
2586
2587 $opt_outdir = File::Spec->canonpath($opt_outdir);
2588 mkpath($opt_outdir, { 'mode' => 0755, 'error' => \my $err, 'verbose' => 0 }) if(! -d $opt_outdir);
2589 for my $diag (@$err) {
2590     my ($file, $msg) = each %$diag;
2591     print STDERR "FATAL: outdir: $file does not exist and cannot be created: $msg\n";
2592     exit(-1);
2593 }
2594 if(!(-d $opt_outdir && -w $opt_outdir)) {
2595     print STDERR "FATAL: outdir: $opt_outdir is not a writable directory\n";
2596     exit(-1);
2597 }
2598 $reference_datadir = File::Spec->canonpath(abs_path($reference_datadir));
2599
2600 if(!open(LOG, "> $opt_outdir/sam$ts.log")) {
2601     print STDERR "cannot create logfile: $!\n";
2602     exit(-1);
2603 }
2604 open(XML,      "> $opt_outdir/sam$ts.xml")    || Die(1, "open(XML): $!\n");
2605 open(REPORT,   "> $opt_outdir/sam$ts.report") || Die(1, "open(REPORT): $!\n");
2606 open(HTML,     "> $opt_outdir/sam$ts.html")   || Die(1, "open(HTML): $!\n");
2607
2608 # create a temp subdir and set up temp file names
2609 Die(1, "tmpdir: $tmpdir is not a writable directory") if (!(-d $tmpdir and -w $tmpdir));
2610
2611 # create subdir name and create subdir
2612 $tmpsubdirtemplate = File::Spec->canonpath("$tmpdir/$tmpsubdirprefix.XXXXXX");
2613 eval { $tmpsubdir  = tempdir($tmpsubdirtemplate, CLEANUP => 1); };
2614 Die(1, "cannot create temp subdir $tmpsubdirtemplate: $@\n") if ($@);
2615
2616 # set temp file names
2617 $pubring    = "$tmpsubdir/$pubring";
2618 $sigfile    = "$tmpsubdir/$sigfile";
2619 $signedfile = "$tmpsubdir/$signedfile";
2620 $refsolvdir = "$tmpsubdir/$refsolvdir";
2621 $refkeysdir = "$tmpsubdir/$refkeysdir";
2622 $reftempdir = "$tmpsubdir/$reftempdir";
2623
2624 check_satsolver();
2625
2626 # ---------------------------------------------------------------------------
2627 # experimental stuff