michael@428: ##
michael@428: ##  build.pl -- OpenPKG Package Building and Installing
michael@428: ##  Copyright (c) 2000-2012 OpenPKG GmbH <http://openpkg.com/>
michael@428: ##
michael@428: ##  This software is property of the OpenPKG GmbH, DE MUC HRB 160208.
michael@428: ##  All rights reserved. Licenses which grant limited permission to use,
michael@428: ##  copy, modify and distribute this software are available from the
michael@428: ##  OpenPKG GmbH.
michael@428: ##
michael@428: ##  THIS SOFTWARE IS PROVIDED "AS IS" AND ANY EXPRESSED OR IMPLIED
michael@428: ##  WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
michael@428: ##  MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
michael@428: ##  IN NO EVENT SHALL THE AUTHORS AND COPYRIGHT HOLDERS AND THEIR
michael@428: ##  CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
michael@428: ##  SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
michael@428: ##  LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
michael@428: ##  USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
michael@428: ##  ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
michael@428: ##  OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT
michael@428: ##  OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
michael@428: ##  SUCH DAMAGE.
michael@428: ##
michael@428: 
michael@428: #############################################################################
michael@428: ##
michael@428: ##  MAIN PROCEDURE
michael@428: ##
michael@428: #############################################################################
michael@428: 
michael@428: require 5;
michael@428: #use strict;
michael@428: my (
michael@428:    $opt_h,
michael@428:    $opt_R, $opt_r, $opt_f, $opt_u, $opt_U, $opt_a, $opt_A,
michael@428:    $opt_z, $opt_Z, $opt_P, $opt_N, $opt_E, $opt_H, $opt_i,
michael@428:    $opt_D, $opt_p, $opt_q, $opt_s, $opt_S, $opt_X, $opt_M,
michael@428:    $opt_L, $opt_W, $opt_K, $opt_e, $opt_b, $opt_B, $opt_g,
michael@428:    $opt_k
michael@428: );
michael@428: 
michael@428: #   global context variables
michael@428: my $prg = "openpkg build";
michael@428: my %env = ('' => {});
michael@428: 
michael@428: ##
michael@428: ##  OPTION PARSING
michael@428: ##
michael@428: 
michael@428: #   parse command line options
michael@428: my $getopts = 'hR:r:f:uUaAzZP:N:E:H:iD:p:qsSXMLWKebBgk';
michael@428: getopts($getopts);
michael@428: 
michael@428: #   parse configuration script options
michael@428: if (open(FH, "<$ENV{'HOME'}/.openpkg/build")) {
michael@428:     my ($env) = $env{''};
michael@428:     my ($go) = $getopts;
michael@428:     $go =~ s/[^a-zA-Z]//g;
michael@428:     while (my $line = <FH>) {
michael@428:         if ($line =~ m/^\s*\[([^\]]*)\]/) {
michael@428:             $env{$1} = {} unless ($env{$1});
michael@428:             $env = $env{$1};
michael@428:         } elsif (my ($opt, $val) = ($line =~ m/^\-([$go])\s*(.*?)\s*$/)) {
michael@428:             $val = 1 unless (defined($val));
michael@428:             if (exists($env->{$opt})) {
michael@428:                 $env->{$opt} .= " " . $val;
michael@428:             } else {
michael@428:                 $env->{$opt} = $val;
michael@428:             }
michael@428:         }
michael@428:     }
michael@428:     close(FH);
michael@428: }
michael@428: 
michael@428: #   usage sanity check and usage help
michael@428: sub usage {
michael@428:     my ($rc) = @_;
michael@428:     my $usage =
michael@428:         "openpkg:build:USAGE: $prg [options] [pattern ...]\n" .
michael@428:         " -a                operate on all installed packages\n" .
michael@428:         " -A                operate on all repository packages\n" .
michael@428:         " -R <rpm>          path to \"openpkg rpm\" command\n" .
michael@428:         " -r <repository>   URL to package repository directory\n" .
michael@428:         " -f <index.rdf>    URL to package repository index file\n" .
michael@428:         " -u                ignore local binary RPMs\n" .
michael@428:         " -U                upgrade all selected packages including dependencies\n" .
michael@428:         " -z                rebuild from zero all selected installed packages\n" .
michael@428:         " -Z                rebuild from zero all selected available packages\n" .
michael@428:         " -i                ignore errors in the generated script\n" .
michael@428:         " -q                ignore all reverse dependencies\n" .
michael@428:         " -s                generate status map instead of shell script\n" .
michael@428:         " -S                generate status map instead of shell script (including new)\n" .
michael@428:         " -X                use external XML/RDF parser instead of internal one\n" .
michael@428:         " -M                generate short dependency map instead of shell script\n" .
michael@428:         " -L                generate list of packages in repository depending on target\n" .
michael@428:         " -W                include dependencies as if all build options are enabled\n" .
michael@428:         " -K                keep temporarily installed packages\n" .
michael@428:         " -k                keep temporarily downloaded packages\n" .
michael@428:         " -e                rebuild exact version of a package from repository\n" .
michael@428:         " -b                build-time check existing binaries for dependencies only\n" .
michael@428:         " -B                build-time check existing binaries for dependencies and target\n" .
michael@428:         " -g                rebuild packages even when most recent version is installed\n" .
michael@428:         " -P <priv-cmd>     command prefix for privileged commands\n" .
michael@428:         " -N <non-priv-cmd> command prefix for non-privileged commands\n" .
michael@428:         " -p <platform>     match platform against repository index for binary packages\n" .
michael@428:         " -E <name>         exclude package\n" .
michael@428:         " -H <name>         hint about packages to resolve ambiquity\n" .
michael@428:         " -D <name>[=<val>] set build option for packages\n";
michael@428:     if ($rc == 0) {
michael@428:         print STDOUT $usage;
michael@428:     }
michael@428:     else {
michael@428:         print STDERR $usage;
michael@428:     }
michael@428:     exit($rc);
michael@428: }
michael@428: if ($opt_h) {
michael@428:     usage(0);
michael@428: }
michael@428: if (not (   ($#ARGV >= 0  && !($opt_a || $opt_A))
michael@428:          || ($#ARGV == -1 &&  ($opt_a || $opt_A)))) {
michael@428:     usage(1);
michael@428: };
michael@428: 
michael@428: #   determine RPM run-time information
michael@428: my $config = rpm_runtime_info();
michael@428: 
michael@428: #   override command line options with configuration script options
michael@428: #   now that the effectively used OpenPKG RPM command is known
michael@428: foreach my $env (sort { $a cmp $b } grep {
michael@428:        $config->{"rpm"}    =~ m/^\Q$_\E/ # compatibility
michael@428:     or $config->{"prefix"} =~ m/^\Q$_\E/ # regular
michael@428: } keys %env) {
michael@428:     while (my ($opt, $val) = each(%{$env{$env}})) {
michael@428:         eval "\$opt_$opt = '$val' unless defined \$opt_$opt;";
michael@428:     }
michael@428: }
michael@428: 
michael@428: ##
michael@428: ##  OPTION POST-PROCESSING
michael@428: ##
michael@428: 
michael@428: my ($url, $repository, $installed, $env, $list, $bonly, $clist);
michael@428: my ($pattern, %with, %exclude, %hint);
michael@428: 
michael@428: #   determine package goal pattern
michael@428: if ($opt_a) {
michael@428:     $pattern = undef;
michael@428: } else {
michael@428:     $pattern = join(' ', @ARGV);
michael@428: }
michael@428: if ($opt_A) {
michael@428:     $pattern = '*';
michael@428: }
michael@428: 
michael@428: #   parse build options
michael@428: %with = map {
michael@428:       m/([^\s=]+)(?:\=(\S+))?/
michael@428:     ? ($1 => (defined($2) ? $2 : 'yes'))
michael@428:     : ()
michael@428: } split(/\s+/, $opt_D);
michael@428: 
michael@428: #   split accumulated option values
michael@428: %exclude = map { $_ => 1 } split(/\s+/, $opt_E);
michael@428: %hint    = map { $_ => 1 } split(/\s+/, $opt_H);
michael@428: 
michael@428: if (defined($opt_p)) {
michael@428:     $config->{platform} = $opt_p;
michael@428: }
michael@428: 
michael@428: #   determine RPM package repository information
michael@428: if (defined $opt_r) {
michael@428:     $url = $opt_r;
michael@428:     $url .= '/' unless $url =~ m/\/$/;
michael@428: } else {
michael@428:     $url = rpm_release_url();
michael@428: }
michael@428: #   if we read the index from a file we can no longer deduce
michael@428: #   repository paths from index paths. For now lets assume
michael@428: #   that everything is below SRC/ to be compatible with
michael@428: #   existing file indexes.
michael@428: if (defined($opt_f) and not defined($opt_r)) {
michael@428:     $url .= 'SRC/';
michael@428: }
michael@428: 
michael@428: #   determine information about INSTALLED packages (virtual and regular),
michael@428: #   including their options, provides and requirements
michael@428: my $installed = get_installed();
michael@428: 
michael@428: #   SPECIAL CASE post-processing for
michael@428: #   -Z (ignore installed packages)
michael@428: #   -a (operate for all installed packages)
michael@428: if ($opt_a and $opt_Z) {
michael@428:     #   This allows one to correctly upgrade an existing OpenPKG
michael@428:     #   instance to a newer major version by querying all installed
michael@428:     #   packages and their options (-a) but then ignore them (-Z) during
michael@428:     #   the later processing and instead perform more or less a fresh
michael@428:     #   rebuild from scratch. This ensures that during the process the
michael@428:     #   installed packages are effectively picked up as dependencies
michael@428:     #   only after they in turn were already updated.
michael@428:     foreach my $package (keys(%{$installed})) {
michael@428:         next if ($package =~ m/::/);
michael@428:         if (exists($installed->{$package}->{""})) {
michael@428:             #   virtual package
michael@428:             $hint{$installed->{$package}->{""}->[0]->{"name"}} = 1
michael@428:                 if (exists($installed->{$package}->{""}->[0]->{"name"}));
michael@428:         }
michael@428:         else {
michael@428:             #   regular package
michael@428:             $pattern .= " $package";
michael@428:             foreach my $version (keys(%{$installed->{$package}})) {
michael@428:                 foreach my $rec (@{$installed->{$package}->{$version}}) {
michael@428:                     if (defined($rec->{"OPTIONS"})) {
michael@428:                         my $options = $rec->{"OPTIONS"};
michael@428:                         foreach my $option (keys(%{$options})) {
michael@428:                             $with{$package."::".$option} = $options->{$option};
michael@428:                         }
michael@428:                     }
michael@428:                 }
michael@428:             }
michael@428:         }
michael@428:     }
michael@428: }
michael@428: if ($opt_Z) {
michael@428:     $installed = {};
michael@428: }
michael@428: 
michael@428: #   determine information about AVAILABLE packages
michael@428: #   by fetching and parsing a package repository XML/RDF index
michael@428: $repository = get_index(
michael@428:     $url . '00INDEX.rdf',
michael@428:     $opt_f,
michael@428:     $opt_X,
michael@428:     $config->{platform},
michael@428:     $installed
michael@428: );
michael@428: 
michael@428: #   assemble together all determined environment information
michael@428: $env = {
michael@428:     config     => $config,
michael@428:     installed  => $installed,
michael@428:     repository => $repository,
michael@428:     built      => {},
michael@428:     revdep     => undef,
michael@428:     with       => \%with,
michael@428:     exclude    => \%exclude,
michael@428:     hint       => \%hint,
michael@428:     upgrade    => ($opt_a || $opt_U),
michael@428:     zero       => ($opt_z || $opt_Z),
michael@428:     exact      => $opt_e,
michael@428:     quick      => ($opt_q || $opt_z || $opt_Z),
michael@428:     status     => ($opt_s || $opt_S),
michael@428:     fatal      => [],
michael@428:     goals      => $opt_g,
michael@428:     sourceonly => ($opt_u || $opt_U || $opt_z || $opt_Z)
michael@428: };
michael@428: 
michael@428: ##
michael@428: ##  PERFORM REQUESTED OPERATION
michael@428: ##
michael@428: 
michael@428: if ($opt_L) {
michael@428:     #   case 1: calculate dependencies only and
michael@428:     #           print packages depending on target
michael@428:     ($list) = build_deps($pattern, $env);
michael@428:     print_deps($list);
michael@428: } else {
michael@428:     #   case 2: calculate build commands and
michael@428:     #           print results in different formats
michael@428:     ($list, $bonly, $clist) = build_list($pattern, $env);
michael@428:     die "openpkg:build:FATAL: cannot find package\n" if (not defined($list));
michael@428:     if ($opt_M) {
michael@428:         print_map($installed, $repository, $list, $bonly, $clist);
michael@428:     } elsif ($opt_S) {
michael@428:         print_status($installed, $repository, $list, $bonly, $clist);
michael@428:     } elsif ($opt_s) {
michael@428:         print_status($installed, {}, $list, $bonly, $clist);
michael@428:     } else {
michael@428:         if (@{$env->{fatal}}) {
michael@428:             die "openpkg:build:FATAL: errors occured while building:\n", @{$env->{fatal}}, "\n";
michael@428:         }
michael@428:         print_list1($list, $config, $opt_a || $opt_u || $opt_U, $env->{with}, $opt_i, $opt_b, $opt_B);
michael@428:         print_list2($bonly, $config) if (not $opt_K);
michael@428:     }
michael@428: }
michael@428: 
michael@428: #   die gracefully
michael@428: exit(0);
michael@428: 
michael@428: #############################################################################
michael@428: ##
michael@428: ##  FUNCTIONS: PARSING & RUN-TIME INFORMATION
michael@428: ##
michael@428: #############################################################################
michael@428: 
michael@428: #   home-brewn getopt(3) style option parser
michael@428: sub getopts ($) {
michael@428:     my ($opts) = @_;
michael@428:     my (%optf) = map { m/(\w)/; $1 => $_ } $opts =~ m/(\w:|\w)/g;
michael@428:     my (%opts, @argv, $optarg);
michael@428: 
michael@428:     foreach (@ARGV) {
michael@428:         if (@argv) {
michael@428:             push @argv, $_;
michael@428:         } elsif (defined $optarg) {
michael@428:             if (exists $opts{$optarg}) {
michael@428:                 $opts{$optarg} .= " $_";
michael@428:             } else {
michael@428:                 $opts{$optarg} = $_;
michael@428:             }
michael@428:             $optarg = undef;
michael@428:         } elsif (!/^[-]/) {
michael@428:             push @argv, $_;
michael@428:         } else {
michael@428:             while (/^\-(\w)(.*)/) {
michael@428:                 if (exists $optf{$1}) {
michael@428:                     if (length($optf{$1}) > 1) {
michael@428:                         if ($2 ne '') {
michael@428:                             if (exists $opts{$1}) {
michael@428:                                 $opts{$1} .= " $2";
michael@428:                             } else {
michael@428:                                 $opts{$1} = $2;
michael@428:                             }
michael@428:                         } else {
michael@428:                             $optarg = $1;
michael@428:                         }
michael@428:                         last;
michael@428:                     } else {
michael@428:                         $opts{$1} = 1;
michael@428:                     }
michael@428:                 } else {
michael@428:                     warn "openpkg:build:WARNING: unknown option $_\n";
michael@428:                 }
michael@428:                 $_ = "-$2";
michael@428:             }
michael@428:         }
michael@428:     }
michael@428:     if (defined $optarg) {
michael@428:         warn "openpkg:build:WARNING: option $optarg requires an argument\n";
michael@428:     }
michael@428:     foreach (keys %opts) {
michael@428:         eval '$opt_'.$_.' = "'.quotemeta($opts{$_}).'";';
michael@428:     }
michael@428:     @ARGV = @argv;
michael@428: }
michael@428: 
michael@428: #   determine RPM run-time information
michael@428: sub rpm_runtime_info () {
michael@428:     #   determine OpenPKG instance prefix via
michael@428:     #   1. the environment of the "openpkg build" framework
michael@428:     #   2. the installation path of the script
michael@428:     #   3. the installation path of the Perl interpreter
michael@428:     #   4. the path of the "openpkg" command in $PATH
michael@428:     my $l_prefix = $ENV{'OPENPKG_PREFIX'};
michael@428:     if (not $l_prefix) {
michael@428:         ($l_prefix) = ($0 =~ m/^(.+)\/lib(exec)?\/openpkg(-tools)?\/build(\.pl)?$/);
michael@428:     }
michael@428:     if (not $l_prefix) {
michael@428:         ($l_prefix) = ($^X =~ m/^(.+)\/bin\/perl.*$/);
michael@428:     }
michael@428:     if (not $l_prefix) {
michael@428:         $l_prefix = (`(which openpkg) 2>/dev/null` =~ m/^(.+)\/bin\/openpkg$/);
michael@428:     }
michael@428:     if (not -x "$l_prefix/bin/openpkg") {
michael@428:         die "openpkg:build:FATAL: cannot determine OpenPKG instance prefix";
michael@428:     }
michael@428:     print "# operating with OpenPKG instance $l_prefix\n";
michael@428: 
michael@428:     #   determine OpenPKG RPM command
michael@428:     my $rpm = $opt_R || $env{''}->{'R'} ||
michael@428:         ((-f "$l_prefix/bin/openpkg" && -f "$l_prefix/libexec/openpkg/rpm") ?
michael@428:         "$l_prefix/bin/openpkg rpm" : "$l_prefix/bin/rpm");
michael@428:     $rpm = (`(which $rpm) 2>/dev/null` =~ m{^(/.*)})[0] if ($rpm !~ m|^/|);
michael@428:     die "openpkg:build:FATAL: cannot locate OpenPKG RPM in path" unless ($rpm =~ m{^/});
michael@428:     print "# operating with OpenPKG RPM $rpm\n";
michael@428: 
michael@428:     #   determine additional tools
michael@428:     my $mkp = "$l_prefix/bin/openpkg makeproxy";
michael@428:     my $rel = "$l_prefix/bin/openpkg release";
michael@428:     my $bzip2 = $rpm;
michael@428:     $bzip2 =~ s/\/bin\/openpkg rpm$/\/lib\/openpkg\/bzip2/;
michael@428:     my $curl = $rpm;
michael@428:     $curl =~ s/\/bin\/openpkg rpm$/\/lib\/openpkg\/curl/;
michael@428:     $curl = "$l_prefix/bin/openpkg curl" if (system("$l_prefix/bin/openpkg curl file://$l_prefix/etc/openpkg/platform >/dev/null 2>&1") == 0);
michael@428: 
michael@428:     #   expand RPM macros holding information
michael@428:     my $c = run("$rpm --eval '%{_rpmdir} %{_rpmfilename} %{_target_os} %{_target_cpu} %{_srcrpmdir}'");
michael@428: 
michael@428:     #   parse and post-process information
michael@428:     chomp($c);
michael@428:     my (@q) = split(/\s+/, $c);
michael@428:     $q[1] =~ s/%{OS}/$q[2]/;
michael@428:     $q[1] =~ s/%{ARCH}/$q[3]/;
michael@428: 
michael@428:     #   expand RPM rc information about tools
michael@428:     $c = run("$rpm --showrc");
michael@428:     my @g = ($c =~ m/\%\{l_tool_locate\s+([^\s\}]+)/g);
michael@428: 
michael@428:     #   return accumulated information
michael@428:     return {
michael@428:         rpm      => $rpm,
michael@428:         mkp      => $mkp,
michael@428:         rel      => $rel,
michael@428:         bzip2    => $bzip2,
michael@428:         curl     => $curl,
michael@428:         rpmdir   => $q[0],
michael@428:         srcrpmdir=> $q[4],
michael@428:         template => $q[1],
michael@428:         platform => '',
michael@428:         prefix   => $l_prefix,
michael@428:         optreg   => '(?:'. join('|', map { "\Quse_$_\E" } @g) .')'
michael@428:     };
michael@428: }
michael@428: 
michael@428: #   determine RPM release URL
michael@428: sub rpm_release_url ($$) {
michael@428:     my ($rel, $url);
michael@428: 
michael@428:     #   determine the release URL the newer way
michael@428:     $url = run("(".$config->{"rel"}." --fmt='%u') 2>/dev/null || true") || "";
michael@428:     $url =~ s/^\s+//s;
michael@428:     $url =~ s/\s+$//s;
michael@428: 
michael@428:     #   use a local jumpstart RDF
michael@428:     if (-f $config->{"prefix"}."/etc/openpkg/build.rdf") {
michael@428:         $url = "file://".$config->{"prefix"}."/etc/openpkg/build.rdf"
michael@428:     }
michael@428: 
michael@428:     return $url;
michael@428: }
michael@428: 
michael@428: #############################################################################
michael@428: ##
michael@428: ##  FUNCTIONS: VERSION STRING HANDLING
michael@428: ##
michael@428: #############################################################################
michael@428: 
michael@428: #   compare two package versions
michael@428: #   - "openpkg rpm":
michael@428: #     splits according to !isalnum(3) ([a-zA-Z0-9])
michael@428: #     and between isdigit(3) ([0-9]) and isalpha(3) ([a-zA-Z])
michael@428: #   - "openpkg build" (this):
michael@428: #     splits on "." characters
michael@428: sub vcmp_version ($$) {
michael@428:     my ($a, $b) = @_;
michael@428:     my (@a, @b, $c);
michael@428:     my ($ax, $bx);
michael@428: 
michael@428:     #   split according to dots
michael@428:     @a = split(/\./, $a);
michael@428:     @b = split(/\./, $b);
michael@428: 
michael@428:     #   compare as long as components exist
michael@428:     while (@a && @b) {
michael@428:         if ($a[0] =~ m/^\d+$/ && $b[0] =~ m/^\d+$/) {
michael@428:             #   numerical comparison
michael@428:             $c = $a[0] <=> $b[0];
michael@428:         } elsif ((($a, $ax) = $a[0] =~ m/^(\d+)(.*)$/) &&
michael@428:                  (($b, $bx) = $b[0] =~ m/^(\d+)(.*)$/)) {
michael@428:             #   numerical comparison for prefix,
michael@428:             #   string comparison for remainder
michael@428:             $c = $a <=> $b;
michael@428:             $c = $ax cmp $bx unless ($c);
michael@428:         } else {
michael@428:             #   string comparison
michael@428:             $c = $a[0] cmp $b[0];
michael@428:         }
michael@428: 
michael@428:         #   stop comparison if components already mismatched
michael@428:         return $c if ($c != 0);
michael@428: 
michael@428:         #   else reduce by one component level
michael@428:         shift(@a);
michael@428:         shift(@b);
michael@428:     }
michael@428: 
michael@428:     #   finally compare number of remaining components
michael@428:     #   (in case one is more specific)
michael@428:     $c = (scalar(@a) <=> scalar(@b));
michael@428:     return $c;
michael@428: }
michael@428: 
michael@428: #   compare two package releases
michael@428: #   - "openpkg rpm":
michael@428: #     uses "vcmp_version" semantics 1:1 again
michael@428: #   - "openpkg build" (this):
michael@428: #     uses "vcmp_version" semantics 1:1 again (>= 20060719)
michael@428: #     trivial string comparison               (<= 20060719)
michael@428: sub vcmp_release ($$) {
michael@428:     my ($a, $b) = @_;
michael@428: 
michael@428:     return vcmp_version($a, $b);
michael@428: }
michael@428: 
michael@428: #   compare two package "version" or "version-release" strings
michael@428: #   - "openpkg rpm":
michael@428: #     compares "epoch", "version", "release" (in this order)
michael@428: #   - "openpkg build" (this):
michael@428: #     compares "release", "version", (in this order)
michael@428: sub vcmp ($$) {
michael@428:     my ($a, $b) = @_;
michael@428:     my ($c);
michael@428: 
michael@428:     #   short-circuit comparison for simple case
michael@428:     return 0 if ($a eq $b);
michael@428: 
michael@428:     #   split into "version" and "release"
michael@428:     my ($av, $ar) = ($a =~ m/^(.*?)(?:\-([\d\.]+))?$/);
michael@428:     my ($bv, $br) = ($b =~ m/^(.*?)(?:\-([\d\.]+))?$/);
michael@428: 
michael@428:     #   compare "release"
michael@428:     if (defined($ar) and defined($br)) {
michael@428:         $c = vcmp_release($ar, $br);
michael@428:         return $c if ($c); # short-circuit
michael@428:     }
michael@428: 
michael@428:     #   compare "version"
michael@428:     if (defined($av) && defined($bv)) {
michael@428:         $c = vcmp_version($av, $bv);
michael@428:         return $c if ($c); # short-circuit
michael@428:     }
michael@428: 
michael@428:     #   equality
michael@428:     return 0;
michael@428: }
michael@428: 
michael@428: #   create "version" or "version-release" string
michael@428: #   from a provide object (see parse_provides)
michael@428: sub vs ($) {
michael@428:     my ($t) = @_;
michael@428:     return (
michael@428:           defined($t->{release})
michael@428:         ? "$t->{version}-$t->{release}"
michael@428:         : $t->{version}
michael@428:     );
michael@428: }
michael@428: 
michael@428: #   create "name-version" or "name-version-release" string
michael@428: #   from a provide object (see parse_provides)
michael@428: sub vsn ($) {
michael@428:     my ($t) = @_;
michael@428:     return "$t->{name}-".vs($t);
michael@428: }
michael@428: 
michael@428: #############################################################################
michael@428: ##
michael@428: ##  FUNCTIONS: INSTALLATION INFORMATION
michael@428: ##
michael@428: #############################################################################
michael@428: 
michael@428: #   parse OpenPKG RPM 'provide' string
michael@428: #   "<virtual-name>"               (virtual package)
michael@428: #   "<name> = <version>-<release>" (regular package)
michael@428: #   "<name>::<option> = <value>"   (regular package build option)
michael@428: sub parse_provides ($) {
michael@428:     my ($s) = @_;
michael@428:     my ($nam, $val, $pre, $with, $pxy, $ver, $rel);
michael@428: 
michael@428:     ($nam, $val) = ($s =~ m/^([^\s\(]+(?:\([^\)]*\))?)\s*(?:=\s*(\S*?))?$/);
michael@428:     if (($pre, $with) = ($nam =~ m/^(\S+?)::(\S*)$/)) {
michael@428:         #   build option
michael@428:         $val =~ s/(?:\%([0-9a-fA-F][0-9a-fA-F]))/chr(hex($1))/eg; # hex decode
michael@428:         ($ver, $rel, $pxy) = ($val, undef, undef);
michael@428:     } else {
michael@428:         #   virtual or real package
michael@428:         ($ver, $rel, $pxy) = ($val =~ m/^([^\s\-]+)-([^\s\+]+)(\+PROXY)?$/);
michael@428:     }
michael@428: 
michael@428:     #   return accumulated information
michael@428:     return {
michael@428:         name    => $nam,     # the full name of the resource
michael@428:         version => $ver,     # the version        (or value)
michael@428:         release => $rel,     # and release number (or undef)
michael@428:         proxy   => $pxy,     # whether the resource is a PROXY resource (or undef)
michael@428:         prefix  => $pre,     # the packagename (if resource is an option)
michael@428:         with    => $with     # the buildoption (if resource is an option)
michael@428:     };
michael@428: }
michael@428: 
michael@428: #   parse option from RPM 'provides' list
michael@428: sub parse_provideslist ($) {
michael@428:     my ($l) = @_;
michael@428:     my ($p);
michael@428:     my ($nam, $val, %opts);
michael@428: 
michael@428:     foreach (@$l) {
michael@428:         $p = parse_provides($_);
michael@428:         next if (not (defined $p->{with} && defined $p->{prefix}));
michael@428:         $opts{$p->{with}} = $p->{version};
michael@428:     }
michael@428:     return \%opts;
michael@428: }
michael@428: 
michael@428: #   translate dependency object into provides object
michael@428: sub depends2provides ($) {
michael@428:     my ($dep) = @_;
michael@428:     my ($ver, $rel, $pxy, $pre, $with);
michael@428: 
michael@428:     ($ver, $rel, $pxy) = ($dep->{val} =~ m/^([^\s\-]+)-([^\s\+]+)(\+PROXY)?$/);
michael@428:     ($pre, $with) = ($dep->{name} =~ m/^(\S+?)::(\S*)$/);
michael@428: 
michael@428:     return {
michael@428:         name    => $dep->{name},
michael@428:         version => (defined $ver ? $ver : $dep->{val}),
michael@428:         release => $rel,
michael@428:         proxy   => $pxy,
michael@428:         prefix  => $pre,
michael@428:         with    => $with
michael@428:     }
michael@428: }
michael@428: 
michael@428: #   parse OpenPKG RPM 'require' string
michael@428: #   "<virtual-name>"                              (virtual package)
michael@428: #   "<name> =|<|<=|>|>= <version>[-<release>]"    (regular package)
michael@428: #   "<name>::<option> =|<|<=|>|>= <value>"        (regular package build option)
michael@428: sub parse_depends ($) {
michael@428:     my ($dep) = @_;
michael@428:     my ($name, $op, $val);
michael@428: 
michael@428:     if (ref($dep)) {
michael@428:         #   dependency from new index stored as a node
michael@428:         #   - content of the node is the name
michael@428:         #   - certain attributes denote the comparison operator
michael@428:         #   - the value of such an attribute is the comparison operand
michael@428:         #   - the operator (and operand) are optional and there can only be one
michael@428:         $name = $dep->{content};
michael@428:         $op = undef;
michael@428:         $op = 'equ' if (exists($dep->{equ}));
michael@428:         $op = 'geq' if (exists($dep->{geq}));
michael@428:         $op = 'leq' if (exists($dep->{leq}));
michael@428:         $op = 'gt'  if (exists($dep->{gt}));
michael@428:         $op = 'lt'  if (exists($dep->{lt}));
michael@428:         if (defined($op)) {
michael@428:             $val = $dep->{$op};
michael@428:         }
michael@428:     } elsif ($dep =~ m/\S/) {
michael@428:         #   dependency from old index stored as text string
michael@428:         #   "name operator operand" or "name"
michael@428:         ($name, $op, $val) = ($dep =~ m/(\S+)\s*(?:(\S+)\s*(\S+))?\s*$/);
michael@428:         if (defined($op)) {
michael@428:             $op = {
michael@428:                 '=='  => 'equ', '='   => 'equ',
michael@428:                 '>='  => 'geq', '=>'  => 'geq',
michael@428:                 '<='  => 'leq', '=<'  => 'leq',
michael@428:                 '>'   => 'gt',  '<'   => 'lt'
michael@428:             }->{$op};
michael@428:             if (not defined($op)) {
michael@428:                 print "# don't know how to handle dependency: $dep (invalid operator)\n";
michael@428:                 return;
michael@428:             }
michael@428:         }
michael@428:     }
michael@428:     return {
michael@428:         name => $name,
michael@428:         op   => $op,
michael@428:         val  => $val
michael@428:     };
michael@428: }
michael@428: 
michael@428: #   retrieve the local installed package base.
michael@428: #   for packages that provide option resources (packagename::buildoption)
michael@428: #   the options are parsed into the OPTIONS hash.
michael@428: #   other packages will query options on demand.
michael@428: sub get_installed () {
michael@428:     my (%map);
michael@428:     my (@l, $p);
michael@428:     my ($nam, $val, %options);
michael@428:     my ($vs, $rec, @list);
michael@428:     my ($name, $version, $release);
michael@428:     my ($req);
michael@428: 
michael@428:     #   generated total result:
michael@428:     #   $map = {
michael@428:     #       #   regular package
michael@428:     #       "<package-name>" <foo> => {
michael@428:     #            "<version>-<release>" <1.2.3-20060622> => [
michael@428:     #                <<1>{
michael@428:     #                    "name"    => $name,
michael@428:     #                    "version" => $version,
michael@428:     #                    "release" => $release,
michael@428:     #                    "PROXY"   => $proxy,
michael@428:     #                    "depends" => [
michael@428:     #                          <<3>>{
michael@428:     #                              "cond"  => '',
michael@428:     #                              "value" => {
michael@428:     #                                  name => $name,
michael@428:     #                                  op   => $op,
michael@428:     #                                  val  => $val
michael@428:     #                              },
michael@428:     #                          },
michael@428:     #                          ...
michael@428:     #                    ],
michael@428:     #                    "keeps" => [
michael@428:     #                          \<<3>
michael@428:     #                          ...
michael@428:     #                    ],
michael@428:     #                    "OPTIONS" => {
michael@428:     #                        "<option>" => "<value>",
michael@428:     #                        "<option>" => "<value>",
michael@428:     #                        ...
michael@428:     #                    },
michael@428:     #                },
michael@428:     #                ...
michael@428:     #            ],
michael@428:     #       },
michael@428:     #       #   build option
michael@428:     #       "<package-name>::<option>" <foo::with_baz> => {
michael@428:     #            "<value>" <yes> => [
michael@428:     #                \<<1>>
michael@428:     #                ...
michael@428:     #            ],
michael@428:     #       },
michael@428:     #       #   virtual package
michael@428:     #       "<package-name>" <BAR> => {
michael@428:     #            "" => [
michael@428:     #                \<<1>>,
michael@428:     #                ...
michael@428:     #            ],
michael@428:     #       },
michael@428:     #       ...
michael@428:     #   };
michael@428: 
michael@428:     #   query and parse all provides of all packages
michael@428:     #   HINT: We assume(!) that OpenPKG RPM outputs "provides" in order:
michael@428:     #         1. virtual package & build option
michael@428:     #         2. regular package
michael@428:     #   FIXME: The better long-term solution for all this fiddling would be something like:
michael@428:     #          "openpkg rpm -qa -qf '%{NAME} %{VERSION} %{RELEASE}[ .%{PROVIDENAME} .%{PROVIDEFLAGS:depflags} .%{PROVIDEVERSION}]\\n'"
michael@428:     @l = run($config->{"rpm"}. " --provides -qa");
michael@428:     @list = ();
michael@428:     foreach (@l) {
michael@428:         #   parse into provide object
michael@428:         $p = parse_provides($_) or next;
michael@428: 
michael@428:         #   short-circuit processing for RPM special case
michael@428:         next if ($p->{name} =~ m/^gpg\(/);
michael@428: 
michael@428:         #   is this an option?
michael@428:         if (defined($p->{with})) {
michael@428:             $options{$p->{prefix}}->{$p->{with}} = $p->{version};
michael@428:             push(@list, $p);
michael@428:             next;
michael@428:         }
michael@428: 
michael@428:         #   is this a virtual target?
michael@428:         $vs = vs($p);
michael@428:         if ($vs eq '') {
michael@428:             push(@list, $p);
michael@428:             next;
michael@428:         }
michael@428: 
michael@428:         #   assemble package details
michael@428:         $name    = $p->{name};
michael@428:         $version = defined($p->{version}) ? $p->{version} : '*';
michael@428:         $release = defined($p->{release}) ? $p->{release} : '*';
michael@428:         push(@list, {
michael@428:             name    => $name,
michael@428:             version => $version,
michael@428:             release => $release
michael@428:         });
michael@428: 
michael@428:         #   create target record
michael@428:         $rec = {
michael@428:             name       => $name,
michael@428:             version    => $version,
michael@428:             release    => $release,
michael@428:             PROXY      => $p->{proxy},
michael@428:             depends    => [],
michael@428:             keeps      => []
michael@428:         };
michael@428:         foreach (@list) {
michael@428:             push(@{$map{$_->{name}}->{vs($_)}}, $rec);
michael@428:         }
michael@428: 
michael@428:         #   remove assembled details
michael@428:         @list = ();
michael@428:     }
michael@428:     if (@list) {
michael@428:         print "# ATTENTION: ", scalar(@list), " froods (unassignable RPM 'provides') left\n";
michael@428:     }
michael@428: 
michael@428:     #   options are provided for a package,
michael@428:     #   apply them to all instances of the package
michael@428:     #   FIXME: duplicate copying because record exists multiple times (but harmless)
michael@428:     #   FIXME: merges all "provides" of all package instances together -- which might be wrong
michael@428:     foreach $nam (keys(%options)) {
michael@428:         foreach $val (keys(%{$map{$nam}})) {
michael@428:             foreach (@{$map{$nam}->{$val}}) {
michael@428:                 $_->{OPTIONS} = $options{$nam};
michael@428:             }
michael@428:         }
michael@428:     }
michael@428: 
michael@428:     #   query all 'requires' of all installed packages
michael@428:     #   to determine the package dependencies
michael@428:     @l = run($config->{"rpm"} . " --qf '%{NAME}:::%{VERSION}:::%{RELEASE}[ :::%{REQUIRENAME}:::%{REQUIREFLAGS:depflags}:::%{REQUIREVERSION}:::]\\n' -qa");
michael@428:     @list = ();
michael@428:     foreach (@l) {
michael@428:         ($name, $version, $release, $req) = m/^([^:]+):::([^:]+):::([^:]+)(.*?)$/;
michael@428:         next if ($name eq 'gpg-pubkey');
michael@428:         $release =~ s/\+PROXY$//;
michael@428:         #   for each requirement triple...
michael@428:         while ($req =~ m/\s+:::(.+?):::\s*(.*?)\s*:::(.*?):::/g) {
michael@428:             $p = parse_depends("$1 $2 $3");
michael@428:             next if ($p->{name} =~ m/^(rpmlib|gpg)\(/);
michael@428:             $vs = vs({ version => $version, release => $release });
michael@428:             $p = { cond => '', value => $p };
michael@428:             foreach $rec (@{$map{$name}->{$vs}}) {
michael@428:                 push(@{$rec->{depends}}, $p);
michael@428:                 push(@{$rec->{keeps}},   $p);
michael@428:             }
michael@428:         }
michael@428:     }
michael@428:     if (@list) {
michael@428:         print "# ATTENTION: ",scalar(@list)," fnords (unassignable RPM 'requires') left\n";
michael@428:     }
michael@428: 
michael@428:     #   return final result
michael@428:     return \%map;
michael@428: }
michael@428: 
michael@428: #############################################################################
michael@428: ##
michael@428: ##  FUNCTIONS: REPOSITORY INDEX INFORMATION
michael@428: ##
michael@428: #############################################################################
michael@428: 
michael@428: #   fetch XML/RDF index from file or URL
michael@428: #   (recursively fetches sub-indexes, too)
michael@428: sub get_index ($$$$$) {
michael@428:     my ($url, $fn, $xml, $pfmatch, $installed) = @_;
michael@428:     my (%map, $include);
michael@428:     my ($fetch, $bzip2, $path);
michael@428:     my ($parser);
michael@428: 
michael@428:     #   determine command/path to fetch/open index
michael@428:     $bzip2 = $config->{"bzip2"};
michael@428:     $fetch = defined($fn) ? $fn : $url;
michael@428:     $fetch !~ m/\.bz2$/ || -x $bzip2
michael@428:         or die "openpkg:build:FATAL: $bzip2 not found\n";
michael@428:     if ($fetch =~ m/^\w+:/) {
michael@428:         #   looks like URL scheme
michael@428:         print "# fetching XML/RDF index from URL $fetch\n";
michael@428:         $path = $config->{"curl"} . " -s -o - \"$fetch\" |";
michael@428:         $path .= "$bzip2 -dc |" if ($fetch =~ m/\.bz2$/);
michael@428:     } else {
michael@428:         print "# reading XML/RDF index from file $fetch\n";
michael@428:         if ($fetch =~ m/\.bz2$/) {
michael@428:             $path = "$bzip2 -dc $fetch |";
michael@428:         } else {
michael@428:             $path = "<$fetch";
michael@428:         }
michael@428:     }
michael@428: 
michael@428:     #   open index
michael@428:     open(RFH, $path) or
michael@428:         die "openpkg:build:FATAL: cannot open '$fetch' ($!)\n";
michael@428: 
michael@428:     #   if XML parser can be used, try to lazy-load it
michael@428:     if ($xml) {
michael@428:         eval { require XML::Simple; };
michael@428:         $xml = 0 if ($@);
michael@428:     }
michael@428: 
michael@428:     #   determine and run XML parser
michael@428:     #   (returns contained index includes)
michael@428:     $parser = ($xml ? \&xml_parser : \&simple_text_parser);
michael@428:     $include = $parser->(\*RFH, $url, \%map, $pfmatch, $installed);
michael@428: 
michael@428:     #   close index
michael@428:     close(RFH)
michael@428:         or die "openpkg:build:FATAL: an I/O error occured\n";
michael@428: 
michael@428:     #   cannot do real recursions on file handles, so we simply append
michael@428:     #   (instead of inserting at the correct position) all sub-RDFs, as
michael@428:     #   the result is flattend into a big hash anyway
michael@428:     foreach (@$include) {
michael@428:         my ($submap);
michael@428:         my ($suburl, $subfn) = relurl($url, $fn, $_);
michael@428:         $submap = get_index($suburl, $subfn, $xml, $pfmatch, $installed); # RECURSION
michael@428:         while (my ($name, $vmap) = each(%$submap)) {
michael@428:             while (my ($vs, $recs) = each(%$vmap)) {
michael@428:                 push(@{$map{$name}->{$vs}}, @$recs);
michael@428:             }
michael@428:         }
michael@428:     }
michael@428: 
michael@428:     #   return final result
michael@428:     #   $map = {
michael@428:     #       <package-name> => {
michael@428:     #           "<version>-<release>" => {
michael@428:     #                href      => ...,
michael@428:     #                name      => ...,
michael@428:     #                version   => ...,
michael@428:     #                release   => ...,
michael@428:     #                platform  => ...,
michael@428:     #                prefix    => ...,
michael@428:     #                depends   => [ ... ],
michael@428:     #                keeps     => [ ... ],
michael@428:     #                conflicts => [ ... ],
michael@428:     #                source    => ...,
michael@428:     #                nosource  => ...,
michael@428:     #                desc      => $desc,
michael@428:     #                OPTIONS   => $options,
michael@428:     #                DEFOPTS   => { %$options },
michael@428:     #           };
michael@428:     #       };
michael@428:     #   };
michael@428:     return \%map;
michael@428: }
michael@428: 
michael@428: #   compute absolute paths
michael@428: #   - (url, fn) point to a base document
michael@428: #     the location is the file path fn if fn is
michael@428: #     defined, otherwise it is url.
michael@428: #   - augment the pointer with suburl
michael@428: #   - suburl can be an absolute url
michael@428: #     then the new pointer is (suburl, undef)
michael@428: #   - suburl can be a absolute file path
michael@428: #     then the new pointer is (suburl, suburl)
michael@428: #   - suburl can be a relative path
michael@428: #     then it augments url or fn accordingly
michael@428: sub relurl ($$$) {
michael@428:     my ($url, $fn, $suburl) = @_;
michael@428:     my ($subfn);
michael@428: 
michael@428:     if ($suburl =~ m/^\w+:\/\//) {
michael@428:         # NOP
michael@428:     } elsif ($suburl =~ m/^\//) {
michael@428:         $subfn = $suburl;
michael@428:     } else {
michael@428:         if (defined($fn)) {
michael@428:             $subfn = $fn;
michael@428:             $subfn =~ s/(\/)?\/*[^\/]*$/$1$suburl/;
michael@428:             $suburl = $subfn;
michael@428:         } else {
michael@428:             $subfn = $url;
michael@428:             $subfn =~ s/(\/)?\/*[^\/]*$/$1$suburl/;
michael@428:             $suburl = $subfn;
michael@428:             $subfn  = undef;
michael@428:         }
michael@428:     }
michael@428:     1 while ($suburl =~ s/\/\.\//\//s);
michael@428:     1 while ($suburl =~ s/\/[^\/]+\/\.\.\//\//s);
michael@428:     return ($suburl, $subfn);
michael@428: }
michael@428: 
michael@428: #   XML/RDF parser (simple way)
michael@428: sub simple_text_parser ($$$$$) {
michael@428:     my ($fh, $url, $map, $pfmatch, $installed) = @_;
michael@428:     my (@include);
michael@428:     my ($section);
michael@428:     my ($name, $version);
michael@428:     my ($href, $release, $desc, $bags);
michael@428:     my (%options, @provides);
michael@428:     my ($platform, $prefix);
michael@428:     my ($rec);
michael@428:     my ($tag, $cond, $attrname, $attrval, $body);
michael@428:     my ($usecond);
michael@428:     my ($options);
michael@428: 
michael@428:     print "# using internal XML/RDF parser\n";
michael@428: 
michael@428:     #   read XML/RDF line-wise as we know that our
michael@428:     #   OpenPKG XML/RDF indices follow a strict formatting
michael@428:     while (<$fh>) {
michael@428:         #   unescape some XML entities
michael@428:         s/&gt;/>/g;
michael@428:         s/&lt;/</g;
michael@428: 
michael@428:         if (!(defined($href)) && m/<rdf:Description.*?href="([^"]*)"/) {
michael@428:             #   start of new package description
michael@428:             $href      = $1;
michael@428:             $section   = undef;
michael@428:             $name      = undef;
michael@428:             $release   = undef;
michael@428:             $desc      = '';
michael@428:             $platform  = undef;
michael@428:             $prefix    = undef;
michael@428:             $bags      = {};
michael@428:             @provides  = ();
michael@428:         }
michael@428: 
michael@428:         if (!(defined($href)) && m/<Repository.*?href="([^"]*)"(?:\s*platform="([^"]*)")?/) {
michael@428:             #   external XML/RDF index reference for particular binary platform
michael@428:             if (goodpf($2, $pfmatch)) {
michael@428:                 push(@include, $1);
michael@428:             }
michael@428:             next;
michael@428:         }
michael@428: 
michael@428:         #   skip content unless referenced piece was found
michael@428:         next if (not defined($href));
michael@428: 
michael@428:         #   parse XML/RDF element into components
michael@428:         ($tag, $cond, $attrname, $attrval, $body) = m{
michael@428:             <                      # start delimiter
michael@428:             (\/?[\w:]+)            # begin element name
michael@428:             \s*                    # optional space before attributes
michael@428:             (?:cond="([^"]+)")?    # known attribute
michael@428:             (?:(\w+)="([^"]+)")?   # unknown attribute
michael@428:             >                      # end delimiter
michael@428:             (.*?)                  # optional element body
michael@428:             (?:<\/\1>)?            # optional end tag
michael@428:             $                      # end of string
michael@428:         }mx;
michael@428: 
michael@428:         #   recognize the various XML/RDF elements
michael@428:         if ($tag eq 'Description') {
michael@428:             $usecond = $cond;
michael@428:             $section = 'description';
michael@428:         } elsif ($tag eq '/Description') {
michael@428:             $usecond = $cond;
michael@428:             $section = undef;
michael@428:         } elsif ($section eq 'description') {
michael@428:             $desc .= $_;
michael@428:         } elsif ($tag eq 'PreReq') {
michael@428:             $usecond = $cond;
michael@428:             $section = 'prereq';
michael@428:         } elsif ($tag eq '/PreReq') {
michael@428:             $usecond = undef;
michael@428:             $section = undef;
michael@428:         } elsif ($tag eq 'BuildPreReq') {
michael@428:             $usecond = $cond;
michael@428:             $section = 'bprereq';
michael@428:         } elsif ($tag eq '/BuildPreReq') {
michael@428:             $usecond = undef;
michael@428:             $section = undef;
michael@428:         } elsif ($tag eq 'Provides') {
michael@428:             $usecond = $cond;
michael@428:             $section = 'provides';
michael@428:         } elsif ($tag eq '/Provides') {
michael@428:             $usecond = undef;
michael@428:             $section = undef;
michael@428:         } elsif ($tag eq 'Conflicts') {
michael@428:             $usecond = $cond;
michael@428:             $section = 'conflicts';
michael@428:         } elsif ($tag eq '/Conflicts') {
michael@428:             $usecond = undef;
michael@428:             $section = undef;
michael@428:         } elsif ($tag eq 'NoSource') {
michael@428:             $usecond = $cond;
michael@428:             $section = 'nosource';
michael@428:         } elsif ($tag eq '/NoSource') {
michael@428:             $usecond = undef;
michael@428:             $section = undef;
michael@428:         } elsif ($tag eq 'Source') {
michael@428:             $usecond = $cond;
michael@428:             $section = 'source';
michael@428:         } elsif ($tag eq '/Source') {
michael@428:             $usecond = undef;
michael@428:             $section = undef;
michael@428:         } elsif ($tag eq 'Name') {
michael@428:             $name = $body;
michael@428:         } elsif ($tag eq 'Version') {
michael@428:             $version = $body;
michael@428:         } elsif ($tag eq 'Release') {
michael@428:             $release = $body;
michael@428:         } elsif ($tag eq 'Platform') {
michael@428:             $platform = $body;
michael@428:         } elsif ($tag eq 'Prefixes') {
michael@428:             $prefix = $body;
michael@428:         } elsif ($tag eq 'rdf:li' || $tag eq 'resource') {
michael@428:             if (defined($attrname)) {
michael@428:                 $body = {
michael@428:                     $attrname => $attrval,
michael@428:                     content   => $body
michael@428:                 };
michael@428:             }
michael@428:             if ($section eq 'provides') {
michael@428:                 push(@provides, $body) if (!defined($usecond));
michael@428:             } elsif ($section ne '') {
michael@428:                 push(@{$bags->{"$usecond"}->{$section}}, $body);
michael@428:             }
michael@428:         } elsif ($tag eq '/rdf:Description') {
michael@428:             if (   defined($href)
michael@428:                 && defined($name)
michael@428:                 && defined($version)
michael@428:                 && defined($release)) {
michael@428:                 #   process the accumulated package information
michael@428:                 @provides = map {
michael@428:                     depends2provides(parse_depends($_))
michael@428:                 } @provides;
michael@428:                 %options = map {
michael@428:                     ($_->{with} => $_->{version})
michael@428:                 } grep {
michael@428:                     defined($_->{with})
michael@428:                 } @provides;
michael@428:                 push(@provides, {
michael@428:                     name    => $name,
michael@428:                     version => $version,
michael@428:                     release => $release
michael@428:                 });
michael@428:                 $options =
michael@428:                       %options
michael@428:                     ? { %options }
michael@428:                     : parse_options($desc);
michael@428:                 if ($options) {
michael@428:                     my (@t) = get_targets($installed->{$name}, sub { 1; });
michael@428:                 }
michael@428:                 #   store accumulated package information
michael@428:                 eval {
michael@428:                     $rec = {
michael@428:                         href      => (relurl($url, undef, $href))[0],
michael@428:                         name      => $name,
michael@428:                         version   => $version,
michael@428:                         release   => $release,
michael@428:                         depends   => depend_list(swith($bags, 'bprereq')),
michael@428:                         keeps     => depend_list(swith($bags, 'prereq')),
michael@428:                         conflicts => swith($bags, 'conflicts'),
michael@428:                         source    => swith($bags, 'source'),
michael@428:                         nosource  => swith($bags, 'nosource'),
michael@428:                         desc      => $desc,
michael@428:                         platform  => $platform,
michael@428:                         prefix    => $prefix,
michael@428:                         OPTIONS   => $options,
michael@428:                         DEFOPTS   => { %$options }
michael@428:                     };
michael@428:                 };
michael@428:                 if ($@) {
michael@428:                     die "openpkg:build:FATAL: when reading entry '$name':\n" . $@;
michael@428:                 }
michael@428:                 foreach (@provides) {
michael@428:                     push(@{$map->{$_->{name}}->{vs($_)}}, $rec);
michael@428:                 }
michael@428:             }
michael@428:             #   prepare to recognize next package
michael@428:             $href = undef;
michael@428:         }
michael@428:     }
michael@428: 
michael@428:     #   return contained XML/RDF indices
michael@428:     return \@include;
michael@428: }
michael@428: 
michael@428: #   XML/RDF parser (usual way)
michael@428: sub xml_parser ($$$$$) {
michael@428:     my ($fh, $url, $map, $pfmatch, $installed) = @_;
michael@428:     my (@include);
michael@428:     my ($xml, $rep, $sub);
michael@428:     my (@provides, %options, $rec);
michael@428:     my ($href, $name, $version, $release, $desc);
michael@428:     my ($options);
michael@428: 
michael@428:     print "# using external XML/RDF parser\n";
michael@428: 
michael@428:     #   parse XML/RDF with XML::Simple parser
michael@428:     $xml = XML::Simple::XMLin($fh, forcearray => 1);
michael@428:     $rep = $xml->{'Repository'}->[0]->{'rdf:Description'};
michael@428:     $sub = $xml->{'Repository'}->[0]->{'Repository'};
michael@428: 
michael@428:     #   iterate over all package descriptions
michael@428:     foreach (@$rep) {
michael@428:         #   fetch package information
michael@428:         $href    = $_->{'href'};
michael@428:         $name    = xel($_->{'Name'});
michael@428:         $version = xel($_->{'Version'});
michael@428:         $release = xel($_->{'Release'});
michael@428:         next if (not (
michael@428:                defined($href)
michael@428:             && defined($name)
michael@428:             && defined($version)
michael@428:             && defined($release)
michael@428:         ));
michael@428: 
michael@428:         #   determine package "provides"
michael@428:         @provides = ();
michael@428:         if ($_->{'Provides'}) {
michael@428:             @provides = map {
michael@428:                 $_ = $_->{'rdf:bag'}->[0];
michael@428:                 $_ = $_->{'rdf:li'} ? $_->{'rdf:li'} : $_->{'resource'};
michael@428:                 @$_;
michael@428:             } grep {
michael@428:                 !exists $_->{'cond'}
michael@428:             } @{$_->{'Provides'}};
michael@428:         }
michael@428:         @provides = map {
michael@428:             depends2provides(parse_depends($_))
michael@428:         } @provides;
michael@428:         %options = map {
michael@428:             ($_->{with} => $_->{version})
michael@428:         } grep {
michael@428:             defined $_->{with}
michael@428:         } @provides;
michael@428:         push(@provides, {
michael@428:             name    => $name,
michael@428:             version => $version,
michael@428:             release => $release
michael@428:         });
michael@428: 
michael@428:         #   determine targets
michael@428:         $desc = xel($_->{'Description'});
michael@428:         $options =
michael@428:               %options
michael@428:             ? { %options }
michael@428:             : parse_options($desc);
michael@428:         if ($options) {
michael@428:             my (@t) = get_targets($installed->{$name}, sub { 1; });
michael@428:         }
michael@428: 
michael@428:         #   store accumulated package information
michael@428:         eval {
michael@428:             $rec = {
michael@428:                 href      => (relurl($url, undef, $href))[0],
michael@428:                 name      => $name,
michael@428:                 version   => $version,
michael@428:                 release   => $release,
michael@428:                 platform  => xel($_->{'Platform'}),
michael@428:                 prefix    => xel($_->{'Prefixes'}),
michael@428:                 depends   => depend_list(xwith($_->{'BuildPreReq'})),
michael@428:                 keeps     => depend_list(xwith($_->{'PreReq'})),
michael@428:                 conflicts => xwith($_->{'Conflicts'}),
michael@428:                 source    => xwith($_->{'Source'}),
michael@428:                 nosource  => xwith($_->{'NoSource'}),
michael@428:                 desc      => $desc,
michael@428:                 OPTIONS   => $options,
michael@428:                 DEFOPTS   => { %$options }
michael@428:             };
michael@428:         };
michael@428:         if ($@) {
michael@428:             die "openpkg:build:FATAL: when reading entry '$name'\n".$@;
michael@428:         }
michael@428:         foreach (@provides) {
michael@428:             push(@{$map->{$_->{name}}->{vs($_)}}, $rec);
michael@428:         }
michael@428:     }
michael@428: 
michael@428:     #   determine contained XML/RDF indices
michael@428:     if ($sub) {
michael@428:         @include = map {
michael@428:             goodpf($_->{platform}, $pfmatch)
michael@428:             ? ( $_->{href} )
michael@428:             : ( )
michael@428:         } @$sub;
michael@428:     }
michael@428: 
michael@428:     #   return contained XML/RDF indices
michael@428:     return \@include;
michael@428: }
michael@428: 
michael@428: #   convert XML parser output to dependency records
michael@428: sub depend_list ($) {
michael@428:     my ($dl) = @_;
michael@428:     foreach (@$dl) {
michael@428:         $_->{value} = parse_depends($_->{value});
michael@428:     }
michael@428:     return $dl;
michael@428: }
michael@428: 
michael@428: #   convert simple XML parser Bag into flat list
michael@428: sub swith ($$) {
michael@428:     my ($bags,$name) = @_;
michael@428:     my ($cond);
michael@428:     my (@out);
michael@428: 
michael@428:     foreach $cond (keys %$bags) {
michael@428:         foreach (@{$bags->{$cond}->{$name}}) {
michael@428:             push @out, {
michael@428:                 cond  => $cond,
michael@428:                 value => $_
michael@428:             };
michael@428:         }
michael@428:     }
michael@428:     return \@out;
michael@428: }
michael@428: 
michael@428: #   convert (conditional) XML/RDF Bag into flat list
michael@428: sub xwith ($) {
michael@428:     my ($bags) = @_;
michael@428:     my ($bag, $li, $el);
michael@428:     my (@out);
michael@428: 
michael@428:     foreach $bag (@$bags) {
michael@428:         foreach $li (@{$bag->{'rdf:bag'}}) {
michael@428:             $el = $li->{'resource'} || $li->{'rdf:li'};
michael@428:             foreach (@$el) {
michael@428:                 push @out, {
michael@428:                     cond   => $bag->{'cond'},
michael@428:                     value  => $_
michael@428:                 };
michael@428:             }
michael@428:         }
michael@428:     }
michael@428:     return \@out;
michael@428: }
michael@428: 
michael@428: #   return node value from XML parser
michael@428: sub xel($) {
michael@428:     my ($a) = @_;
michael@428:     my ($l) = $a->[0];
michael@428:     return '' if ref($l);
michael@428:     return $l;
michael@428: }
michael@428: 
michael@428: #   is the platform a good one?
michael@428: sub goodpf ($$) {
michael@428:     my ($l, $p) = @_;
michael@428:     return 1 if $l eq '';
michael@428:     return ($l =~ m/(?:^|\s)\Q$p\E(?:\s|$)/);
michael@428: }
michael@428: 
michael@428: 
michael@428: #############################################################################
michael@428: ##
michael@428: ##  FUNCTIONS: HELPER FUNCTIONS FOR XML PARSING & DEPENDENCY PROCESSING
michael@428: ##
michael@428: #############################################################################
michael@428: 
michael@428: #   parse option from RPM output
michael@428: #   < "%option with_foo bar"
michael@428: #   > $with{"with_foo"} = "bar"
michael@428: sub parse_options ($) {
michael@428:     my ($l) = @_;
michael@428:     $l = join("\n", @$l) if (ref($l));
michael@428:     return {} if ($l !~ m/(--define|\%option\s+)/s);
michael@428:     my $with = {};
michael@428:     $l =~ s/--define\s*'(\S+)\s+(\S+?)'/$with->{$1} = $2, ''/sge;  # before openpkg-20021230
michael@428:     $l =~ s/\%option\s+(\S+)\s+(\S+)/$with->{$1} = $2, ''/sge;     # after  openpkg-20021230
michael@428:     return $with;
michael@428: }
michael@428: 
michael@428: #   fetch targets of a name that satisfy a condition and sort by target
michael@428: #   version. Input is a hash of versions(?) on which the condition has
michael@428: #   to be true and which points to an array of records with package
michael@428: #   version information. Output is the list of version sorted package
michael@428: #   version information records.
michael@428: sub get_targets ($$) {
michael@428:     my ($relmap, $cond) = @_;
michael@428:     return (
michael@428:         sort {
michael@428:             vcmp(vs($a), vs($b));
michael@428:         } map {
michael@428:             @{$relmap->{$_}}
michael@428:         } grep {
michael@428:             $cond->($_);
michael@428:         } keys %$relmap
michael@428:    );
michael@428: }
michael@428: 
michael@428: #############################################################################
michael@428: ##
michael@428: ##  FUNCTIONS: DEPENDENCY PROCESSING
michael@428: ##
michael@428: #############################################################################
michael@428: 
michael@428: #   search environment for packages that match a pattern
michael@428: sub search_pattern ($$) {
michael@428:     my ($pattern, $env) = @_;
michael@428:     my (@todo);
michael@428: 
michael@428:     if (defined($pattern)) {
michael@428:         #   explicitly given package pattern
michael@428:         @todo = map {
michael@428:             my ($p) = $_;
michael@428:             my ($s, $iswildcard);
michael@428:             $s = $1 if ($p =~ s/(,[^\s,]+)$//);
michael@428:             if ($p =~ s/\*+$//) {
michael@428:                 $p = '^'.quotemeta($p).'';
michael@428:                 $iswildcard = 1;
michael@428:             } else {
michael@428:                 $p = '^'.quotemeta($p).'$';
michael@428:             }
michael@428:             map { "$_$s" }
michael@428:                 grep { m/$p/ && !($iswildcard && exists($env->{exclude}->{$_})) }
michael@428:                     keys %{$env->{repository}}
michael@428:         } split(/\s+/, $pattern);
michael@428:     } else {
michael@428:         #   undefined pattern means "-a" option that selects
michael@428:         #   all packages from repository that are installed
michael@428:         #   and not explicitly excluded on command line
michael@428:         @todo = grep {
michael@428:             my ($n) = $_;
michael@428:                (ref($env->{installed}->{$n}))
michael@428:             && !exists($env->{exclude}->{$n})
michael@428:             && grep { $_ ne '-' } keys %{$env->{installed}->{$n}}
michael@428:         } keys(%{$env->{repository}});
michael@428:     }
michael@428:     return \@todo;
michael@428: }
michael@428: 
michael@428: #   pull in OPTIONS for a package or an RPM file
michael@428: my $get_with_cache = {};
michael@428: sub get_with ($;$) {
michael@428:     my ($t, $fn) = @_;
michael@428:     my (@l, %with);
michael@428:     my ($optmap, $opt);
michael@428: 
michael@428:     if ($t->{OPTIONS}) {
michael@428:         $opt = $t->{OPTIONS};
michael@428:     } else {
michael@428:         if (defined($fn)) {
michael@428:             @l = run($config->{"rpm"} . " -q --provides -p $fn");
michael@428:         } else {
michael@428:             if (not exists($get_with_cache->{-provides})) {
michael@428:                 #   pre-cache the "provides" query for all(!) packages at once for speedup
michael@428:                 my @c = run($config->{"rpm"} . " -qa --qf " .
michael@428:                     '\'%{NAME}[ :::%{PROVIDENAME}:::%{PROVIDEFLAGS:depflags}:::%{PROVIDEVERSION}:::]\n\'');
michael@428:                 $get_with_cache->{-provides} = {};
michael@428:                 foreach my $c (@c) {
michael@428:                     if ($c =~ m/^(\S+)(.*)$/s) {
michael@428:                         my ($name, $provides) = ($1, $2);
michael@428:                         while ($provides =~ m/\s+:::(.+?):::\s*(.*?)\s*:::(.*?):::/g) {
michael@428:                             $get_with_cache->{-provides}->{$name} = [] if (not exists($get_with_cache->{-provides}->{$name}));
michael@428:                             push(@{$get_with_cache->{-provides}->{$name}}, "$1 $2 $3");
michael@428:                         }
michael@428:                     }
michael@428:                 }
michael@428:             }
michael@428:             @l = $get_with_cache->{-provides}->{$t->{name}};
michael@428:             if (not @l) {
michael@428:                 #   (should not happen in practice, but anyway)
michael@428:                 @l = run($config->{"rpm"} . " -q --provides $t->{name}");
michael@428:                 $get_with_cache->{-provides}->{$t->{name}} = [ @l ];
michael@428:             }
michael@428:         }
michael@428:         $opt = parse_provideslist(\@l);
michael@428:         if (scalar(keys(%$opt)) == 0) {
michael@428:             if (defined($fn)) {
michael@428:                 @l = run($config->{"rpm"} . " -qi -p $fn");
michael@428:             } else {
michael@428:                 if (not exists($get_with_cache->{-infos})) {
michael@428:                     #   pre-cache the "infos" query for all(!) packages at once for speedup
michael@428:                     my @c = run($config->{"rpm"} . " -qi -a");
michael@428:                     my $p = "";
michael@428:                     $get_with_cache->{-infos} = {};
michael@428:                     foreach my $c (@c) {
michael@428:                         $p = $1 if ($c =~ m/^Name:\s+(\S+)/s);
michael@428:                         $get_with_cache->{-infos}->{$p} = [] if (not exists($get_with_cache->{-infos}->{$p}));
michael@428:                         push(@{$get_with_cache->{-infos}->{$p}}, $c);
michael@428:                     }
michael@428:                 }
michael@428:                 @l = $get_with_cache->{-infos}->{$t->{name}};
michael@428:                 if (not @l) {
michael@428:                     #   (should not happen in practice, but anyway)
michael@428:                     @l = run($config->{"rpm"} . " -qi $t->{name}");
michael@428:                     $get_with_cache->{-infos}->{$t->{name}} = [ @l ];
michael@428:                 }
michael@428:             }
michael@428:             $opt = parse_options(\@l);
michael@428:         }
michael@428:         $t->{OPTIONS} = $opt;
michael@428:     }
michael@428:     return $opt;
michael@428: }
michael@428: 
michael@428: #   copy options from new to old
michael@428: #   where option already exists in old or option key
michael@428: #   matches regular expression
michael@428: sub override_options ($$$) {
michael@428:     my ($old, $new, $reg) = @_;
michael@428:     my ($k);
michael@428: 
michael@428:     foreach $k (keys(%$new)) {
michael@428:         if ((exists($old->{$k}) && $old->{$k} ne $new->{$k}) || $k =~ m/^$reg$/) {
michael@428:             $old->{$k} = $new->{$k};
michael@428:         }
michael@428:     }
michael@428: }
michael@428: 
michael@428: #   filter package options
michael@428: sub filter_name_with ($$$) {
michael@428:     my ($name, $with, $global) = @_;
michael@428:     my (@keys);
michael@428: 
michael@428:     if ($global) {
michael@428:         push(@keys, grep { !/::/ } keys %$with);
michael@428:     }
michael@428:     push(@keys, grep { m/::/ } keys %$with);
michael@428:     return {
michael@428:         map {
michael@428:             my ($k) = $_;
michael@428:               $k !~ m/::/ || $k =~ s/^\Q$name\E:://
michael@428:             ? ( $k => $with->{$_} )
michael@428:             : ( )
michael@428:         } @keys
michael@428:     };
michael@428: }
michael@428: 
michael@428: #   filter out package relevant options
michael@428: sub name_with ($$) {
michael@428:     filter_name_with($_[0], $_[1], 1);
michael@428: }
michael@428: 
michael@428: #   filter out package specific options
michael@428: sub name_only_with ($$) {
michael@428:     filter_name_with($_[0], $_[1], 0);
michael@428: }
michael@428: 
michael@428: #   evaluate a condition attribute from an option set
michael@428: sub conditional ($$) {
michael@428:     my ($cond, $with) = @_;
michael@428:     my (@s, $res);
michael@428: 
michael@428:     return 1 if ($cond eq '' || !defined($with));
michael@428:     foreach (split(/\s+/,$cond)) {
michael@428:         if ($_ eq '+') {
michael@428:             die "openpkg:build:FATAL: stack underflow in: $cond\n" if scalar(@s) < 2;
michael@428:             my ($a) = pop(@s);
michael@428:             my ($b) = pop(@s);
michael@428:             push(@s, $a && $b);
michael@428:         } elsif ($_ eq '|') {
michael@428:             die "openpkg:build:FATAL: stack underflow in: $cond\n" if scalar(@s) < 2;
michael@428:             my ($a) = pop(@s);
michael@428:             my ($b) = pop(@s);
michael@428:             push(@s, $a || $b);
michael@428:         } elsif ($_ eq '!') {
michael@428:             die "openpkg:build:FATAL: stack underflow in: $cond\n" if scalar(@s) < 1;
michael@428:             my ($a) = pop(@s);
michael@428:             push(@s, !$a);
michael@428:         } else {
michael@428:             push(@s, ($with->{$_} eq 'yes') ? 1 : 0);
michael@428:         }
michael@428:     }
michael@428:     die "openpkg:build:FATAL: stack underflow in: $cond\n" if scalar(@s) < 1;
michael@428:     $res = pop(@s);
michael@428: 
michael@428:     die "openpkg:build:FATAL: stack not empty in: $cond\n" if scalar(@s) > 0;
michael@428:     return $res;
michael@428: }
michael@428: 
michael@428: #   retrieve conditional target attributes in map
michael@428: sub target_attribute ($$$;$) {
michael@428:     my ($target, $env, $attr, $with) = @_;
michael@428:     my ($optreg) = $env->{config}->{optreg};
michael@428:     my ($name, @out);
michael@428: 
michael@428:     return if (not $target);
michael@428:     $name = $target->{name};
michael@428: 
michael@428:     my ($mywith) = ($with ? $with : get_with($target));
michael@428:     override_options($mywith, name_with($name, $env->{with}), $optreg);
michael@428: 
michael@428:     foreach (@{$target->{$attr}}) {
michael@428:         next if (not conditional($_->{'cond'}, $mywith));
michael@428:         push(@out, $_->{'value'});
michael@428:     }
michael@428:     return \@out;
michael@428: }
michael@428: 
michael@428: #   see whether target is in map
michael@428: sub target_exists ($$) {
michael@428:     my ($target, $map) = @_;
michael@428:     my ($vmap) = $map->{$target->{name}};
michael@428:     return if (not $vmap);
michael@428:     return (
michael@428:            !defined $target->{version}
michael@428:         || defined $vmap->{vs($target)}
michael@428:     );
michael@428: }
michael@428: 
michael@428: #   see whether target has conflicts
michael@428: sub target_conflicts ($$) {
michael@428:     my ($target, $env) = @_;
michael@428:     return target_attribute($target, $env, 'conflicts');
michael@428: }
michael@428: 
michael@428: #   retrieve build dependencies for target
michael@428: sub target_depends ($$) {
michael@428:     my ($target, $env) = @_;
michael@428:     return target_attribute($target, $env, 'depends');
michael@428: }
michael@428: 
michael@428: #   retrieve runtime dependencies for target
michael@428: sub target_keeps ($$) {
michael@428:     my ($target, $env) = @_;
michael@428:     return target_attribute($target, $env, 'keeps');
michael@428: }
michael@428: 
michael@428: #   retrieve source list for target
michael@428: sub target_source ($$) {
michael@428:     my ($target, $env) = @_;
michael@428:     return target_attribute($target, $env, 'source');
michael@428: }
michael@428: 
michael@428: #   retrieve nosource list for target
michael@428: sub target_nosource ($$) {
michael@428:     my ($target, $env) = @_;
michael@428:     return target_attribute($target, $env, 'nosource');
michael@428: }
michael@428: 
michael@428: #   check whether target conflicts against map
michael@428: sub target_has_conflicts ($$$) {
michael@428:     my ($target, $map, $env) = @_;
michael@428:     my ($conflicts, $t);
michael@428: 
michael@428:     $conflicts = target_conflicts($target, $env);
michael@428:     foreach (@$conflicts) {
michael@428:         my ($t) = find_target($_, $map, 0);
michael@428:         return $t if $t;
michael@428:     }
michael@428:     return;
michael@428: }
michael@428: 
michael@428: #   record target status
michael@428: sub target_setstatus ($$$) {
michael@428:     my ($target, $status, $pri) = @_;
michael@428: 
michael@428:     if ($pri > $target->{STATUSPRI}) {
michael@428:         $target->{STATUSPRI} = $pri;
michael@428:         $target->{STATUS}    = $status;
michael@428:     }
michael@428: }
michael@428: 
michael@428: #   strip doubles from depend/keep lists
michael@428: #   and return a map name => depend/keep
michael@428: sub unique_map {
michael@428:     my (%out);
michael@428:     foreach (@_) {
michael@428:         foreach (@$_) {
michael@428:             $out{$_->{name}} = $_;
michael@428:         }
michael@428:     }
michael@428:     return %out;
michael@428: }
michael@428: 
michael@428: #   check whether installed package matches build options. If default
michael@428: #   = 1 then options which are not required must be identical to the
michael@428: #   DEFOPTS.
michael@428: sub target_suitable ($$$) {
michael@428:     my ($target, $with, $default) = @_;
michael@428:     my ($iwith, $dwith);
michael@428:     my ($k, $v);
michael@428: 
michael@428:     if ($target->{GOAL}) {
michael@428:         $with = name_with($target->{name}, $with);
michael@428:     } else {
michael@428:         $with = name_only_with($target->{name}, $with);
michael@428:     }
michael@428:     $iwith = $target->{OPTIONS};
michael@428:     $dwith = $target->{DEFOPTS};
michael@428:     while (($k,$v) = each(%$iwith)) {
michael@428:         if (exists($with->{$k})) {
michael@428:             return 0 if ($iwith->{$k} ne $with->{$k});
michael@428:         } elsif ($default) {
michael@428:             return 0 if ($iwith->{$k} ne $dwith->{$k});
michael@428:         }
michael@428:     }
michael@428:     return 1;
michael@428: }
michael@428: 
michael@428: #   determine whether target should be rebuild
michael@428: sub target_better ($$$) {
michael@428:     my ($env, $target, $map) = @_;
michael@428:     my ($vs) = vs($target);
michael@428:     my ($vmap) = $map->{$target->{name}};
michael@428: 
michael@428:     #   rebuild if target isn't installed
michael@428:     return 'new' unless $vmap;
michael@428: 
michael@428:     #   if "-e" then
michael@428:     #   always update if installed version is different from repository
michael@428:     if ($env->{exact} && !grep { vcmp($vs, $_) == 0; } keys(%$vmap)) {
michael@428:         return 'exact';
michael@428:     }
michael@428: 
michael@428:     #   if target is goal
michael@428:     #   always update if installed version is older than repository
michael@428:     if ($target->{GOAL} && !grep { vcmp($vs, $_) <= 0; } keys(%$vmap)) {
michael@428:         return 'goal';
michael@428:     }
michael@428: 
michael@428:     #   if -U then
michael@428:     #   always update if installed version is older than repository
michael@428:     if ($env->{upgrade} && !grep { vcmp($vs, $_) <= 0; } keys(%$vmap)) {
michael@428:         return 'upgrade';
michael@428:     }
michael@428: 
michael@428:     #   if -z/-Z then
michael@428:     #   always update if installed version is equal or older than repository
michael@428:     if ($env->{zero} && grep { vcmp($vs, $_) >= 0; } keys(%$vmap)) {
michael@428:         return 'zero';
michael@428:     }
michael@428: 
michael@428:     #   keep installed target
michael@428:     return;
michael@428: }
michael@428: 
michael@428: #   check if target record describes a source package
michael@428: sub is_source ($) {
michael@428:     my ($t) = @_;
michael@428:     return !(defined $t->{'prefix'});
michael@428: }
michael@428: 
michael@428: #   there can be multiple sources for a target release
michael@428: sub chose_source ($$$$$) {
michael@428:     my ($env, $name, $select, $vmap, $cond) = @_;
michael@428:     my (@targ, @recs, @nrecs, $rec, %nam);
michael@428: 
michael@428:     #   resolve name into a list of versions
michael@428:     #   for virtual targets this resolves to a list
michael@428:     #   of real targets that provide the virtual target
michael@428:     @targ = get_targets($vmap, sub { 1; });
michael@428:     return unless @targ;
michael@428: 
michael@428:     #   find usable binary targets add all source targets
michael@428:     @recs = (
michael@428:         ( grep {
michael@428:                !$env->{sourceonly}
michael@428:             && !is_source($_)
michael@428:             && $_->{'platform'} eq $env->{config}->{platform}
michael@428:             && $_->{'prefix'} eq $env->{config}->{prefix}
michael@428:         } get_targets($vmap, $cond) ),
michael@428:         ( grep {
michael@428:             is_source($_)
michael@428:         } @targ )
michael@428:     );
michael@428:     return if (not @recs);
michael@428: 
michael@428:     #   limit list to exact matches if provided by "-e"
michael@428:     if (defined($select)) {
michael@428:         @recs = grep {
michael@428:             vsn($_) =~ m/^\Q$select\E/
michael@428:         } @recs;
michael@428:     }
michael@428: 
michael@428:     #   try to resolve ambiguity against installed targets
michael@428:     #   and targets previously selected
michael@428:     if (scalar(@recs) > 1) {
michael@428:         @nrecs = grep {
michael@428:                $env->{built}->{$_->{name}}
michael@428:             || $env->{installed}->{$_->{name}}
michael@428:         } @recs;
michael@428:         @recs = @nrecs if (@nrecs);
michael@428:     }
michael@428: 
michael@428:     #   try to resolve ambiguity against hints
michael@428:     if ($env->{hint}) {
michael@428:         @nrecs = grep {
michael@428:             exists($env->{hint}->{$_->{name}})
michael@428:         } @recs;
michael@428:         @recs = @nrecs if (@nrecs);
michael@428:     }
michael@428: 
michael@428:     #   try to resolve ambiguity against targets that match
michael@428:     #   the exact name
michael@428:     if (scalar(@recs) > 1) {
michael@428:         @nrecs = grep {
michael@428:             $name eq $_->{name}
michael@428:         } @recs;
michael@428:         @recs = @nrecs if (@nrecs);
michael@428:     }
michael@428: 
michael@428:     #   try to resolve ambiguity by preferring binaries
michael@428:     if (scalar(@recs) > 1 && !$env->{sourceonly}) {
michael@428:         @nrecs = grep {
michael@428:             defined($_->{'platform'})
michael@428:         } @recs;
michael@428:         @recs = @nrecs if (@nrecs);
michael@428:     }
michael@428: 
michael@428:     #   if we still have non-unique targets, complain
michael@428:     if (scalar(@recs) > 1) {
michael@428:         %nam = map { $_->{name} => 1 } @recs;
michael@428:         if (scalar(keys(%nam)) > 1) {
michael@428:             print "# ambigous sources for $name\n";
michael@428:             my ($i) = 0;
michael@428:             foreach (@recs) {
michael@428:                 print "# $i: ".vsn($_)." = $_->{href}\n";
michael@428:                 $i++;
michael@428:             }
michael@428:             return;
michael@428:         }
michael@428:     }
michael@428: 
michael@428:     #   prefer full-source packages
michael@428:     if (scalar(@recs) > 1) {
michael@428:         @nrecs = grep {
michael@428:                ! $_->{nosource}
michael@428:             || ! @{$_->{nosource}}
michael@428:         } @recs;
michael@428:         unless (@nrecs) {
michael@428:             @nrecs = grep {
michael@428:                 $_->{href} !~ m/\.nosrc.rpm$/
michael@428:             } @recs;
michael@428:         }
michael@428:         @recs = @nrecs if (@nrecs);
michael@428:     }
michael@428: 
michael@428:     #   nothing left -> exit
michael@428:     return if (scalar(@recs) == 0);
michael@428: 
michael@428:     #   chose last (= max version) in list of targets
michael@428:     $rec = $recs[-1];
michael@428:     print "# source for $name is ".vsn($rec)."\n";
michael@428:     return $rec;
michael@428: }
michael@428: 
michael@428: #   locate target for a dependency
michael@428: sub dep2target ($$$) {
michael@428:     my ($dep, $env, $source) = @_;
michael@428:     my ($name, $op, @targ);
michael@428:     my ($i, $r, $b, $cond, $version);
michael@428:     my ($t, $tdef, $why);
michael@428: 
michael@428:     ($name, $op, $version) = ($dep->{name}, $dep->{op}, $dep->{val});
michael@428: 
michael@428:     $i = $env->{installed}->{$name};
michael@428:     $r = $env->{repository}->{$name};
michael@428:     $b = $env->{built}->{$name};
michael@428: 
michael@428:     return if (not ($i || $r || $b));
michael@428: 
michael@428:     if (!defined($op)) {
michael@428:         $cond = sub { 1; };
michael@428:     } elsif ($op eq 'geq') {
michael@428:         $cond = sub { vcmp($_[0],$version) >= 0; };
michael@428:     } elsif ($op eq 'leq') {
michael@428:         $cond = sub { vcmp($_[0],$version) <= 0; };
michael@428:     } elsif ($op eq 'gt') {
michael@428:         $cond = sub { vcmp($_[0],$version) >  0; };
michael@428:     } elsif ($op eq 'lt') {
michael@428:         $cond = sub { vcmp($_[0],$version) <  0; };
michael@428:     } elsif ($op eq 'equ') {
michael@428:         $cond = sub { vcmp($_[0],$version) == 0; };
michael@428:     } else {
michael@428:         die "openpkg:build:FATAL: internal error in dep2target\n";
michael@428:     }
michael@428: 
michael@428:     $tdef = undef;
michael@428: 
michael@428:     #   search installed target that matches requirement
michael@428:     #   use it if we are not upgrading (no -U and no -z/-Z)
michael@428:     if ($i && (@targ = get_targets($i, $cond))) {
michael@428:         foreach $t (@targ) {
michael@428:             get_with($t);
michael@428:             if (target_suitable($t, $env->{with}, 0)) {
michael@428:                 $tdef = $t;
michael@428:                 if (not ($env->{upgrade} || $env->{zero} || $source)) {
michael@428:                     return ($t, 1);
michael@428:                 }
michael@428:             }
michael@428:         }
michael@428:     }
michael@428: 
michael@428:     #   search target in current build list that matches requirement
michael@428:     #   use it if it exists
michael@428:     if ($b && (@targ = get_targets($b, $cond))) {
michael@428:         $t = $targ[0];
michael@428:         return ($t, 1);
michael@428:     }
michael@428: 
michael@428:     #   search target in repository and install it, if it is newer than
michael@428:     #   corresponding installed versions avoid repository packages that
michael@428:     #   would install 'new' (i.e. are not an upgrade of an existing
michael@428:     #   package)
michael@428:     $t = chose_source($env, $name, undef, $r, $cond);
michael@428:     if ($t) {
michael@428:         if (!$tdef || (
michael@428:             ($why = target_better($env, $t, $env->{installed})) &&
michael@428:             $why ne 'new'
michael@428:             ) || $source) {
michael@428:             return ($t, 0);
michael@428:         }
michael@428:     }
michael@428: 
michael@428:     #   if nothing is suitable in repository then fall back to
michael@428:     #   anything we already have installed but that we skipped
michael@428:     #   above to look for upgrades.
michael@428:     if ($tdef) {
michael@428:         return ($tdef, 1);
michael@428:     }
michael@428: 
michael@428:     return;
michael@428: }
michael@428: 
michael@428: #   compute reverse dependency map
michael@428: sub get_revdep ($) {
michael@428:     my ($env) = @_;
michael@428:     my ($i) = $env->{'installed'};
michael@428:     my ($r) = $env->{'repository'};
michael@428:     my ($pkg, %dep, %dlist, %rev);
michael@428:     my (@targ, $t, $t1, $t2, $with, $name, $vmap);
michael@428:     my ($d, $k, %d, $old, %name, %pkg);
michael@428: 
michael@428:     print "# computing reverse dependencies\n";
michael@428: 
michael@428:     #   iterate over all installed packages
michael@428:     foreach $pkg (keys(%$i)) {
michael@428:         $vmap = $r->{$pkg};
michael@428:         if (not $vmap) {
michael@428:             print "# ATTENTION: $pkg has no upgrade path (installed package not found in repository)\n";
michael@428:             next;
michael@428:         }
michael@428: 
michael@428:         #   get forward dependencies from installed packages
michael@428:         #   dep{a}{b} is true if b depends directly on a
michael@428:         #   dlist{a}  is list of packages that depend on a
michael@428:         @targ = get_targets($i->{$pkg}, sub { 1; });
michael@428:         foreach $t (@targ) {
michael@428:             $with = get_with($t);
michael@428:             $d = target_attribute($t, $env, 'depends', $with);
michael@428:             $k = target_attribute($t, $env, 'keeps', $with);
michael@428:             next if (not (@$d || @$k));
michael@428:             %d = unique_map($d,$k);
michael@428: 
michael@428:             #   resolve package
michael@428:             if (not exists($pkg{$pkg})) {
michael@428:                 ($t2, $old) = dep2target({ name => $pkg }, $env, 1);
michael@428:                 $t2 = undef if ($old);
michael@428:                 $pkg{$pkg} = $t2;
michael@428:             }
michael@428:             $t2 = $pkg{$pkg};
michael@428:             next if (not $t2);
michael@428:             foreach (keys(%d)) {
michael@428:                 next if ($_ eq 'OpenPKG');
michael@428:                 #   resolve target
michael@428:                 unless (exists($name{$_})) {
michael@428:                     ($t1, $old) = dep2target($d{$_}, $env, 0);
michael@428:                     $name{$_} = ($t1 ? $t1->{name} : $_);
michael@428:                 }
michael@428:                 $name = $name{$_};
michael@428:                 if (not $dep{$name}{$t->{name}}) {
michael@428:                     $dep{$name}{$t->{name}} = 1;
michael@428:                     push(@{$dlist{$name}}, $t2);
michael@428:                 }
michael@428:             }
michael@428:         }
michael@428:     }
michael@428: 
michael@428:     #   sort reverse dependencies
michael@428:     foreach $pkg (keys(%dep)) {
michael@428:         $rev{$pkg} = [
michael@428:             sort {
michael@428:                    $dep{$b->{name}}{$a->{name}}
michael@428:                 || -$dep{$a->{name}}{$b->{name}}
michael@428:                 || $a->{name} cmp $b->{name}
michael@428:             } @{$dlist{$pkg}}
michael@428:         ];
michael@428:     }
michael@428: 
michael@428:     #   return hash of package reverse dependencies
michael@428:     return \%rev;
michael@428: }
michael@428: 
michael@428: #   build package dependencies
michael@428: #   (all input and output is passed in 'env' hash)
michael@428: sub build_deps ($$) {
michael@428:     my ($pattern, $env) = @_;
michael@428:     my ($todo, @list, $list, @out);
michael@428: 
michael@428:     #   determine all packages which match the pattern
michael@428:     $todo = search_pattern($pattern, $env);
michael@428: 
michael@428:     #   unfold target names into all(!) real targets names
michael@428:     @list =
michael@428:     map {
michael@428:         map {
michael@428:             map {
michael@428:                 $_->{name}
michael@428:             } @$_
michael@428:         } values(%{$env->{repository}->{$_}})
michael@428:     } @$todo;
michael@428: 
michael@428:     #   also add target name
michael@428:     push @list, @$todo;
michael@428: 
michael@428:     #   strip duplicate names
michael@428:     @list = keys %{ { map { $_ => 1 } @list } };
michael@428: 
michael@428:     #   cache reverse dependencies
michael@428:     if (not $env->{revdep}) {
michael@428:         $env->{revdep} = get_revdep($env);
michael@428:     }
michael@428: 
michael@428:     #   map targets into list of dependency names
michael@428:     @list = map {
michael@428:           $env->{revdep}->{$_}
michael@428:         ? (@{$env->{revdep}->{$_}})
michael@428:         : ()
michael@428:     } @list;
michael@428: 
michael@428:     #   iterate over dependencies
michael@428:     foreach (@list) {
michael@428:         #   avoiding cycles
michael@428:         next if ($env->{builddeps}->{$_->{name}});
michael@428:         $env->{builddeps}->{$_->{name}} = 1;
michael@428: 
michael@428:         #   generate result
michael@428:         push(@out, $_);
michael@428: 
michael@428:         #   generate result recursively
michael@428:         $list = build_deps($_->{name}, $env); # RECURSION
michael@428:         push(@out, @$list);
michael@428:     }
michael@428: 
michael@428:     #   return final results
michael@428:     return \@out;
michael@428: }
michael@428: 
michael@428: #   report options that are not used for
michael@428: sub warn_about_options ($$$) {
michael@428:     my ($target, $with, $c) = @_;
michael@428:     my ($iwith) = $target->{OPTIONS};
michael@428:     my ($k, $v);
michael@428: 
michael@428:     return if (not defined($iwith));
michael@428:     $with = name_with($target->{name}, $with);
michael@428:     while (($k,$v) = each %$with) {
michael@428:         if (not ($k =~ m/^$c->{optreg}$/ || exists $iwith->{$k})) {
michael@428:             print "# ATTENTION: $target->{name} ignores option '$k'\n";
michael@428:         }
michael@428:     }
michael@428: }
michael@428: 
michael@428: #   find target in map
michael@428: sub find_target ($$$) {
michael@428:     my ($name, $map, $pos) = @_;
michael@428:     my ($vmap) = $map->{$name};
michael@428:     my (@vs);
michael@428: 
michael@428:     return if (not $vmap);
michael@428:     @vs = sort { vcmp($b,$a) } keys(%$vmap);
michael@428:     return $vmap->{$vs[$pos]}->[-1];
michael@428: }
michael@428: 
michael@428: #   add dependency as build option
michael@428: sub depend_option ($$$) {
michael@428:     my ($target, $dep, $env) = @_;
michael@428:     my ($with, $opt, $relmap, @t, $t);
michael@428:     my ($pro) = depends2provides($dep);
michael@428:     my ($conflict) = 0;
michael@428: 
michael@428:     return 1 if (not defined($pro->{with}));
michael@428: 
michael@428:     my ($val) = defined($pro->{version}) ? $pro->{version} : 'yes';
michael@428: 
michael@428:     $with = $env->{with};
michael@428:     $opt  = $pro->{prefix}.'::'.$pro->{with};
michael@428:     if (defined($with->{$opt}) && $with->{$opt} ne $val) {
michael@428:         print "# ", vsn($target), " has conflicting requirement $opt = $with->{$opt} != $val\n";
michael@428:         $conflict = 1;
michael@428:     }
michael@428: 
michael@428:     $relmap = $env->{built}->{$pro->{prefix}};
michael@428:     @t = get_targets($relmap, sub { 1; });
michael@428:     foreach $t (@t) {
michael@428:         $with = $t->{OPTIONS};
michael@428:         $opt  = $pro->{with};
michael@428:         if (defined($with->{$opt}) && $with->{$opt} ne $val) {
michael@428:             print "# ", vsn($t), " has conflicting requirement $opt = $with->{$opt} != $val\n";
michael@428:             $conflict = 1;
michael@428:         }
michael@428:     }
michael@428: 
michael@428:     return 0 if ($conflict);
michael@428: 
michael@428:     print "# ", vsn($target), " adds option $opt = $val\n";
michael@428:     $with->{$opt} = $val;
michael@428:     return 1;
michael@428: }
michael@428: 
michael@428: #   remember fatal error
michael@428: sub pusherr ($$$) {
michael@428:     my ($env, $target, $mess) = @_;
michael@428:     print "# $mess\n";
michael@428:     push(@{$env->{fatal}}, vsn($target).": $mess\n");
michael@428: }
michael@428: 
michael@428: #   generate dependencies
michael@428: sub make_dep ($$$$$$$) {
michael@428:     my ($who, $target, $depth, $env, $list, $blist, $clist) = @_;
michael@428:     my ($d, $k, %d, %k, $t, $old);
michael@428:     my (@deps, $conflict, $why);
michael@428: 
michael@428:     #   check whether target is already in list of to be build packages
michael@428:     if (target_exists($target, $env->{built})) {
michael@428:         print "# $target->{name} is already in list\n";
michael@428:         return;
michael@428:     }
michael@428: 
michael@428:     #   check whether target is in conflict with already installed package
michael@428:     if ($t = target_has_conflicts($target, $env->{installed}, $env)) {
michael@428:         target_setstatus($target, 'CONFLICT', 4);
michael@428:         push(@$clist, $target);
michael@428:         pusherr($env, $target, "$target->{name} conflicts with ".vsn($t));
michael@428:         return;
michael@428:     }
michael@428: 
michael@428:     #   check whether target is in conflict with to be build package
michael@428:     if ($t = target_has_conflicts($target, $env->{built}, $env)) {
michael@428:         target_setstatus($target, 'CONFLICT', 4);
michael@428:         push(@$clist, $target);
michael@428:         pusherr($env, $target, "$target->{name} conflicts with ".vsn($t));
michael@428:         return;
michael@428:     }
michael@428: 
michael@428:     #   see if a target is already installed and requires a rebuild
michael@428:     if ($t = find_target($target->{name}, $env->{installed}, -1)) {
michael@428:         if (exists($env->{exclude}->{$target->{name}})) {
michael@428:             print "# excluding $target->{name} (no upgrade allowed)\n";
michael@428:             return;
michael@428:         }
michael@428: 
michael@428:         #   pull in options (for status report)
michael@428:         if ($target->{REBUILD}) {
michael@428:             target_setstatus($target, 'DEPEND', 1);
michael@428:             print "# rebuilding $target->{name} (dependency)\n";
michael@428:         } elsif ($env->{zero}) {
michael@428:             target_setstatus($target, 'ZERO', 1);
michael@428:             print "# rebuilding $target->{name} (zero)\n";
michael@428:         } elsif (vs($target) ne vs($t)) {
michael@428:             target_setstatus($target, 'UPDATE', 3);
michael@428:             print "# rebuilding $target->{name} (update)\n";
michael@428:         } elsif (!target_suitable($t, $env->{with}, 0)) {
michael@428:             target_setstatus($target, 'MISMATCH', 2);
michael@428:             print "# rebuilding $target->{name} (parameter mismatch)\n";
michael@428:         } elsif ($env->{goals} && $target->{GOAL}) {
michael@428:             target_setstatus($target, 'GOAL', 3);
michael@428:             print "# rebuilding $target->{name} (goal)\n";
michael@428:         } else {
michael@428:             print "# $target->{name} is already installed\n";
michael@428:             return;
michael@428:         }
michael@428: 
michael@428:         #   use options from installed base
michael@428:         override_options(get_with($target), get_with($t), $env->{config}->{optreg});
michael@428: 
michael@428:         #   remember this is a rebuild for a proxy package
michael@428:         $target->{PROXY} = $t->{PROXY};
michael@428:         $target->{REBUILD} = 1;
michael@428:     } else {
michael@428:         print "# creating $target->{name}\n";
michael@428:         target_setstatus($target, 'ADD', 3);
michael@428:     }
michael@428: 
michael@428:     if (exists($env->{exclude}->{$target->{name}})) {
michael@428:         die "openpkg:build:FATAL: target ".vsn($target)." is forbidden\n";
michael@428:     }
michael@428: 
michael@428:     #   mark this as a target before reverse dependencies trigger it again
michael@428:     push(@{$env->{built}->{$target->{name}}->{vs($target)}}, $target);
michael@428:     $target->{LIMBO} = 1;
michael@428: 
michael@428:     #   recurse over dependencies
michael@428:     $d = target_depends($target, $env);
michael@428:     $k = target_keeps($target, $env);
michael@428:     if (@$d || @$k) {
michael@428:         %d = unique_map($d, $k);
michael@428:         %k = unique_map($k);
michael@428:         @deps     = ();
michael@428:         $conflict = 0;
michael@428:         foreach (keys %d) {
michael@428:             #   old index misses a OpenPKG provider in the index... skip it
michael@428:             next if ($_ eq 'OpenPKG');
michael@428:             ($t, $old) = dep2target($d{$_}, $env, 0);
michael@428:             if ($t) {
michael@428:                 if ($old) {
michael@428:                     print "# $target->{name} uses ".vsn($t)." for $_\n";
michael@428:                     if ($t->{LIMBO}) {
michael@428:                         print "# ATTENTION: ".vsn($t)." is in LIMBO\n";
michael@428:                     }
michael@428:                     next;
michael@428:                 }
michael@428:                 if (not depend_option($t, $d{$_}, $env)) {
michael@428:                     push(@$clist, $target);
michael@428:                     pusherr($env, $target, "$target->{name} has conflicting requirement");
michael@428:                     target_setstatus($target, 'UNDEF', 4);
michael@428:                     $conflict = 1;
michael@428:                     next;
michael@428:                 }
michael@428:                 if ($k{$_}) {
michael@428:                     push(@$blist, $t);
michael@428:                     print "# $target->{name} installs ".vsn($t)." for $_\n";
michael@428:                 } else {
michael@428:                     print "# $target->{name} requires ".vsn($t)." for $_\n";
michael@428:                 }
michael@428:                 push(@deps, $t);
michael@428:             } else {
michael@428:                 push(@$clist, $target);
michael@428:                 pusherr($env, $target, "$target->{name} searches a frood called '$_'");
michael@428:                 target_setstatus($target, 'UNDEF', 4);
michael@428:                 $conflict = 1;
michael@428:             }
michael@428:         }
michael@428:         if (not $conflict) {
michael@428:             foreach $t (@deps) {
michael@428:                 make_dep($target, $t, $depth+1, $env, $list, $blist, $clist); # RECURSION
michael@428:             }
michael@428:         }
michael@428:     }
michael@428: 
michael@428:     print "# adding ".vsn($target)." to list\n";
michael@428:     $target->{WHO} = $who;
michael@428:     $target->{WHY} = $target->{STATUS};
michael@428:     push(@$list, $target);
michael@428: 
michael@428:     #   remember new options
michael@428:     override_options(get_with($target), name_with($target->{name}, $env->{with}), '');
michael@428: 
michael@428:     #   moan about non-source packages
michael@428:     foreach (@{target_nosource($target, $env)}) {
michael@428:         my ($p) = target_source($target, $env)->[$_];
michael@428:         $p =~ s/.*\///;
michael@428:         print "# ATTENTION: unpackaged source $_: $p\n";
michael@428:     }
michael@428: 
michael@428:     #   cleanup limbo
michael@428:     $target->{LIMBO} = 0;
michael@428: 
michael@428:     #   a dependency could not be resolved, don't bother with reverse
michael@428:     #   dependencies for this target
michael@428:     return if ($conflict);
michael@428: 
michael@428:     if (!$env->{quick} && $target->{name} ne 'openpkg' ) {
michael@428:         if (not $env->{revdep}) {
michael@428:             $env->{revdep} = get_revdep($env);
michael@428:         }
michael@428:         foreach $t (@{$env->{revdep}->{$target->{name}}}) {
michael@428:             #   this is a rebuild, triggering further revdeps
michael@428:             $t->{REBUILD} = 1;
michael@428: 
michael@428:             #   this is a rebuild, keep this installed
michael@428:             push(@$blist, $t);
michael@428: 
michael@428:             print "# rebuilding reverse dependency ".vsn($t)."\n";
michael@428:             make_dep($target, $t, $depth+1, $env, $list, $blist, $clist); # RECURSION
michael@428:         }
michael@428:     }
michael@428: }
michael@428: 
michael@428: #   generate build lists for targets matched by pattern
michael@428: #   (all input and output is passed in 'env' hash)
michael@428: sub build_list ($$) {
michael@428:     my ($pattern, $env) = @_;
michael@428:     my (@goals, @targets, @keeps, @conflicts, @bonly, $t);
michael@428:     my ($name, $select, $r, $i);
michael@428:     my ($todo, %keep);
michael@428: 
michael@428:     #   determine all packages which match the pattern
michael@428:     $todo = search_pattern($pattern, $env);
michael@428: 
michael@428:     #   chose sources for goals from repository
michael@428:     foreach $name (@$todo) {
michael@428:         $select = undef;
michael@428:         $select = $1 if ($name =~ s/,([^\s,]+)$//);
michael@428:         $t = undef;
michael@428: 
michael@428:         #   keeping installed packages for goals is ugly
michael@428:         #   - we currently do not support installed source RPMs
michael@428:         #   - source RPMs might already have expired from repository
michael@428:         #   consequence:
michael@428:         #   - goals are always upgraded to repository versions
michael@428:         #if (not $env->{upgrade}) {
michael@428:         #    $i = $env->{installed}->{$name};
michael@428:         #    $t = chose_source($env, $name, $select, $i, sub { 1; });
michael@428:         #}
michael@428:         if (not $t) {
michael@428:             $r = $env->{repository}->{$name};
michael@428:             $t = chose_source($env, $name, $select, $r, sub { 1; });
michael@428:         }
michael@428: 
michael@428:         if ($t) {
michael@428:             warn_about_options($t, $env->{with}, $env->{config});
michael@428:             $t->{GOAL} = 1;
michael@428:             push @goals, $t;
michael@428:         } else {
michael@428:             #   error
michael@428:             if ($env->{status}) {
michael@428:                 print "# dropping goal '$name'\n";
michael@428:             } else {
michael@428:                 die "openpkg:build:FATAL: cannot find source for '$name'\n";
michael@428:             }
michael@428:         }
michael@428:     }
michael@428:     return if (not @goals);
michael@428: 
michael@428:     #   recurse over dependencies
michael@428:     @targets = ();
michael@428:     @keeps   = @goals;
michael@428:     foreach $t (@goals) {
michael@428:         print "# recursing over dependencies for ".vsn($t)."\n";
michael@428:         make_dep(undef, $t, 0, $env, \@targets, \@keeps, \@conflicts);
michael@428:     }
michael@428: 
michael@428:     #   determine "binary only" packages which should be not kept
michael@428:     #   as they were not installed and are used temporarily only.
michael@428:     %keep = map { $_ => 1 } @keeps;
michael@428:     @bonly = reverse grep {
michael@428:         !$keep{$_} && !$env->{installed}->{$_->{name}}
michael@428:     } @targets;
michael@428: 
michael@428:     #   return results
michael@428:     return (\@targets, \@bonly, \@conflicts);
michael@428: }
michael@428: 
michael@428: 
michael@428: #############################################################################
michael@428: ##
michael@428: ##  FUNCTIONS: RESULT PRINTING
michael@428: ##
michael@428: #############################################################################
michael@428: 
michael@428: #   determine execution command
michael@428: sub cmd ($$) {
michael@428:     my ($w,$s) = @_;
michael@428:     if (!defined($w)) {
michael@428:         return $s;
michael@428:     } elsif ($w =~ m/^-(.*)/) {
michael@428:         return "$1 \"$s\"";
michael@428:     } else {
michael@428:         return "$w $s";
michael@428:     }
michael@428: }
michael@428: sub priv  ($) { cmd($opt_P, $_[0]); }
michael@428: sub npriv ($) { cmd($opt_N, $_[0]); }
michael@428: 
michael@428: #   execute a command
michael@428: my $run_cache = {};
michael@428: sub run ($) {
michael@428:     my $cmd = cmd($opt_N, $_[0]);
michael@428:     my $out = $run_cache->{$cmd};
michael@428:     if (not defined($out)) {
michael@428:         my @out = `$cmd`;
michael@428:         $out = [ @out ];
michael@428:         $run_cache->{$cmd} = $out;
michael@428:     }
michael@428:     return (wantarray ? @{$out} : join(//, @{$out}));
michael@428: }
michael@428: 
michael@428: #   print dependency list
michael@428: sub print_deps ($) {
michael@428:     my ($list) = @_;
michael@428: 
michael@428:     print join("\n", sort map { vsn($_) } @$list), "\n";
michael@428: }
michael@428: 
michael@428: #   print dependency map
michael@428: sub print_map ($$$$$) {
michael@428:     my ($installed, $repository, $list, $bonly, $clist) = @_;
michael@428:     my (%dep);
michael@428: 
michael@428:     foreach (@$bonly) {
michael@428:         $_->{status} = 'TEMP';
michael@428:     }
michael@428:     foreach (reverse(@$list)) {
michael@428:         printf("%-35s %-8s %s\n",
michael@428:             $_->{WHO} ? vsn($_->{WHO}) : "GOAL",
michael@428:             $_->{WHY} ? $_->{WHY} : '???',
michael@428:             vsn($_)
michael@428:         );
michael@428:     }
michael@428: }
michael@428: 
michael@428: #   instead of printing a command list, print a status map
michael@428: #   that shows all packages and how the build process would
michael@428: #   change their status
michael@428: sub print_status ($$$$$) {
michael@428:     my ($installed, $repository, $list, $bonly, $clist) = @_;
michael@428:     my (%bonly) = map { $_ => 1 } @$bonly;
michael@428:     my (%map, $n, @names, $t);
michael@428:     my ($old, $tag, $new);
michael@428: 
michael@428:     #   augment map with additional information
michael@428:     #   about conflicting and binary only (temporary) packages
michael@428:     foreach (@$list, @$clist) {
michael@428:         next if (not $_->{release} =~ m/\S/);
michael@428:         $map{$_->{name}} = {
michael@428:             rel    => "$_->{version}-$_->{release}",
michael@428:             status => $_->{STATUS}
michael@428:         };
michael@428:     }
michael@428:     foreach (@$bonly) {
michael@428:         next if (not $_->{release} =~ m/\S/);
michael@428:         $map{$_->{name}} = {
michael@428:             rel    => "$_->{version}-$_->{release}",
michael@428:             status => 'TEMP'
michael@428:         };
michael@428:     }
michael@428: 
michael@428:     #   augment map with additional information
michael@428:     #   about up-to-date and new packages
michael@428:     @names = keys(%map);
michael@428:     foreach $n (keys(%$installed)) {
michael@428:         next if ($n =~ m/::/);
michael@428:         next if (exists($map{$n}));
michael@428:         next if (not (grep { $_ ne '' } keys(%{$installed->{$n}})));
michael@428:         $map{$n}->{'status'} = 'OK';
michael@428:         push(@names, $n);
michael@428:     }
michael@428:     foreach $n (keys(%$repository)) {
michael@428:         next if ($n =~ m/::/);
michael@428:         next if (exists($map{$n}));
michael@428:         next if (not (grep { $_ ne '' } keys(%{$repository->{$n}})));
michael@428:         $t = find_target($n, $repository, 0);
michael@428:         $map{$n}->{'status'} = 'NEW';
michael@428:         $map{$n}->{'rel'}    = vs($t);
michael@428:         push(@names, $n);
michael@428:     }
michael@428: 
michael@428:     #   generate status output
michael@428:     foreach $n (sort(@names)) {
michael@428:         $old = join(',',
michael@428:             map { "$n-$_" }
michael@428:             sort
michael@428:             grep { $_ ne '-' }
michael@428:             keys(%{$installed->{$n}})
michael@428:         );
michael@428:         $old = $n if ($old eq '');
michael@428:         $tag = $map{$n}->{status};
michael@428:         $new = defined($map{$n}->{rel}) ? " $n-$map{$n}->{rel}" : '';
michael@428:         printf("%-35s %-8s%s\n", $old, $tag, $new);
michael@428:     }
michael@428: }
michael@428: 
michael@428: #   compute path to source RPM from rpm config and target data
michael@428: sub target2srcrpm ($$) {
michael@428:     my ($target, $c) = @_;
michael@428:     return $c->{srcrpmdir}.'/'.$target->{name}.'-'.$target->{version}.'-'.$target->{release}.'.src.rpm';
michael@428: }
michael@428: 
michael@428: #   compute path to binary RPM from rpm config and target data
michael@428: sub target2rpm ($$) {
michael@428:     my ($target, $c) = @_;
michael@428:     my ($tmpl) = $c->{template};
michael@428:     my ($popt) = $target->{PROXY} ? '+PROXY' : '';
michael@428: 
michael@428:     $tmpl =~ s/%{NAME}/$target->{name}/;
michael@428:     $tmpl =~ s/%{VERSION}/$target->{version}/;
michael@428:     $tmpl =~ s/%{RELEASE}/$target->{release}$popt/;
michael@428: 
michael@428:     return $c->{rpmdir}.'/'.$tmpl;
michael@428: }
michael@428: 
michael@428: #   merge parameters from installed package
michael@428: #   with new parameter set and global parameters
michael@428: #   from configuration
michael@428: #   then map the result to --define command line arguments
michael@428: #   suitable for rpm
michael@428: sub make_defines ($$$$) {
michael@428:     my ($old, $new, $def, $c) = @_;
michael@428:     my ($with);
michael@428: 
michael@428:     $old = {} unless $old;
michael@428:     $def = {} unless $def;
michael@428: 
michael@428:     #   override old parameters with new parameters
michael@428:     #   drop new parameters that do not exist in old set
michael@428:     $old = { %$old };
michael@428:     override_options($old, $new, $c->{optreg});
michael@428: 
michael@428:     #   convert parameters to --define command line options
michael@428:     #   skip parameter templates from index
michael@428:     #   skip parameters that are identical to defaults
michael@428:     $with = join(' ',
michael@428:         map { "--define '$_ $old->{$_}'" }
michael@428:         sort grep {
michael@428:             $old->{$_} =~ m/\S/ &&
michael@428:             $old->{$_} !~ m/^%/ &&
michael@428:             $old->{$_} ne $def->{$_}
michael@428:         } keys %$old
michael@428:     );
michael@428: 
michael@428:     $with = ' '.$with if ($with ne '');
michael@428: 
michael@428:     return $with;
michael@428: }
michael@428: 
michael@428: #   compute new target based on old target augmented with options from
michael@428: #   a binary RPM file
michael@428: sub binary_target ($$) {
michael@428:     my ($t, $fn) = @_;
michael@428:     my (%target) = %$t;
michael@428: 
michael@428:     #   pull in options from binary RPM file
michael@428:     delete $target{'OPTIONS'};
michael@428:     get_with(\%target, $fn);
michael@428:     return \%target;
michael@428: }
michael@428: 
michael@428: #   return path to master package for a proxy package
michael@428: sub find_proxy ($$) {
michael@428:     my ($t, $bpkg) = @_;
michael@428:     my (@l) = run($config->{"rpm"} . " -ql $t->{name}");
michael@428:     my ($link) = (grep { $_ =~ m/\/\.prefix-$t->{name}$/ } @l)[0];
michael@428:     return if (not defined($link));
michael@428:     chomp $link;
michael@428:     my ($prefix) = readlink($link);
michael@428:     return if (not defined($prefix));
michael@428:     $bpkg =~ s/.*\///;
michael@428:     $bpkg =~ s/\+PROXY(\.[^-]+-[^-]+)-[^-]+\.rpm$/$1-*.rpm/;
michael@428:     return (glob("$prefix/RPM/PKG/$bpkg"))[0];
michael@428: }
michael@428: 
michael@428: #   indent text to form a block
michael@428: sub indent ($) {
michael@428:     my ($txt) = @_;
michael@428:     $txt =~ s/^/    /gm;
michael@428:     return $txt;
michael@428: }
michael@428: 
michael@428: #   print commands from package build list
michael@428: #   c      -> configuration to derive paths from
michael@428: #   uncond -> always do the --rebuild
michael@428: #   with   -> parameter set passed to build tool
michael@428: #   ignore -> generate script that does not stop on error
michael@428: #   usebin -> build-time check to skip rebuild when binary exists
michael@428: #   allbin -> usebin also for goals
michael@428: sub print_list1 ($$$$$$$) {
michael@428:     my ($list, $c, $uncond, $with, $ignore, $usebin, $allbin) = @_;
michael@428:     my ($pkg, $spkg, $bpkg, $uvhpkg, $ppkg);
michael@428:     my ($opt);
michael@428:     my ($cmd1, $cmd2, $mark);
michael@428:     my ($cmd3, $srcpkg);
michael@428: 
michael@428:     $mark = '::::';
michael@428: 
michael@428:     my $err;
michael@428:     if ($ignore) { $err = "|| true" } else { $err = "|| exit \$?" };
michael@428:     foreach (@$list) {
michael@428:         $pkg = $_->{name};
michael@428:         $spkg = $_->{href};
michael@428:         unless ($spkg =~ m/\S/) {
michael@428:             die "openpkg:build:FATAL: internal error, ",vsn($_)," without source URL\n";
michael@428:         }
michael@428:         $bpkg = target2rpm($_, $c); $uvhpkg = $bpkg;
michael@428:         $srcpkg = target2srcrpm($_, $c);
michael@428:         $cmd3 = '';
michael@428: 
michael@428:         #   rebuild binary package IF
michael@428:         #   'unconditional' option
michael@428:         #   OR target is tagged as rebuilding
michael@428:         #   OR there is no binary package
michael@428:         #   OR dependency check found that installed package is not suitable
michael@428:         #   OR existing binary package doesn't satisfy wanted options
michael@428:         $cmd1 = undef;
michael@428:         if (   $uncond
michael@428:             || !-f $bpkg
michael@428:             || !target_suitable(binary_target($_, $bpkg), $with, 1)) {
michael@428: 
michael@428:             $opt = make_defines($_->{OPTIONS}, $with,
michael@428:                                 $_->{DEFOPTS}, $c);
michael@428: 
michael@428:             #   proxy packages are rebuilt from their maste
michael@428:             #   hierachy
michael@428:             #   someone preferred a binary from the repository
michael@428:             #   just copy it to the local store
michael@428:             if ($_->{PROXY}) {
michael@428:                 $ppkg = find_proxy($_,$bpkg) or
michael@428:                 die "openpkg:build:FATAL: proxy package ",vsn($_)," does not exist\n";
michael@428: 
michael@428:                 #   rpm doesn't support additional parameters to the
michael@428:                 #   mkproxy script
michael@428:                 #   $cmd1 = npriv($config->{"mkp"} . " $ppkg -- -o $bpkg");
michael@428:                 $cmd1 = "( cd $c->{rpmdir} && ".
michael@428:                         npriv($config->{"mkp"} . " $ppkg").
michael@428:                         " )";
michael@428:             } elsif (defined $_->{prefix}) {
michael@428:                 $cmd1 = '';
michael@428:                 if ($spkg =~ m|^\.?/|) {
michael@428:                     $uvhpkg = $spkg;
michael@428:                 }
michael@428:                 else {
michael@428:                     $cmd1 .= npriv($config->{"curl"} . " -# -o $bpkg $spkg $err\n");
michael@428:                     $cmd3 = npriv("rm -f $bpkg >/dev/null 2>&1 $err\n") unless ($opt_k);
michael@428:                 }
michael@428:             } else {
michael@428:                 $cmd1 = '';
michael@428:                 if ($spkg =~ m|^\.?/|) {
michael@428:                     $cmd1 .= npriv($config->{"rpm"} . "$opt --rebuild $spkg $err\n");
michael@428:                 }
michael@428:                 else {
michael@428:                     $cmd1 .= "if test ! -f $srcpkg; then\n";
michael@428:                     $cmd1 .= indent(npriv($config->{"curl"} . " -# -o $srcpkg $spkg $err\n"));
michael@428:                     $cmd1 .= "fi\n";
michael@428:                     $cmd1 .= npriv($config->{"rpm"} . "$opt --rebuild $srcpkg $err\n");
michael@428:                     $cmd1 .= npriv("rm -f $srcpkg >/dev/null 2>&1 $err\n") unless ($opt_k);
michael@428:                 }
michael@428:             }
michael@428:         }
michael@428: 
michael@428:         #   wrap build command with build-time check for existing
michael@428:         #   binary target
michael@428:         if (defined($cmd1) && ($allbin || ($usebin && !$_->{GOAL}))) {
michael@428:             $cmd1 = "if test ! -f $uvhpkg; then\n".indent($cmd1)."fi\n";
michael@428:         }
michael@428: 
michael@428:         #   if package exist force rpm to copy over new files
michael@428:         #   better than erasing everything and losing configuration
michael@428:         #   files
michael@428:         $opt = ($_->{REBUILD} || ($allbin || ($usebin && !$_->{GOAL}))) ? ' --force' : '';
michael@428:         $cmd2 = '';
michael@428:         $cmd2 .= priv($config->{"rpm"} . "$opt -Uvh $uvhpkg $err\n");
michael@428:         if ($allbin || ($usebin && !$_->{GOAL})) {
michael@428:             $cmd2 = "if test \".`".$config->{"rpm"}." -q --qf '\%{SIGMD5}' $pkg`\" != \".`".$config->{"rpm"}." -qp --qf '\%{SIGMD5}' $uvhpkg`\"; then\n".indent($cmd2)."fi\n";
michael@428:         }
michael@428:         $cmd2 = $cmd1.$cmd2 if ($cmd1);
michael@428:         $cmd2 = $cmd2.$cmd3 if ($cmd3);
michael@428:         print "echo $mark $spkg $mark\n".$cmd2."echo $mark $spkg = \$? $mark\n";
michael@428:     }
michael@428: }
michael@428: 
michael@428: #   print commands for the temporary package list
michael@428: #   temporary packages are only used for building other packages
michael@428: #   and are removed when everything is done
michael@428: sub print_list2 ($$) {
michael@428:     my ($list, $c) = @_;
michael@428:     my ($pkg);
michael@428: 
michael@428:     foreach (@$list) {
michael@428:         $pkg = "$_->{name}-$_->{version}-$_->{release}";
michael@428:         print priv($config->{"rpm"} . " -e $pkg\n");
michael@428:     }
michael@428: }
michael@428: