openpkg-packages/openpkg-tool/openpkg-build.pl

##
##  openpkg-build.pl -- create build scripts from package index
##
##  Copyright (c) 2000-2002 Cable & Wireless Deutschland GmbH
##  Copyright (c) 2000-2002 The OpenPKG Project <http://www.openpkg.org/>
##  Copyright (c) 2000-2002 Ralf S. Engelschall <rse@engelschall.com>
##
##  Permission to use, copy, modify, and distribute this software for
##  any purpose with or without fee is hereby granted, provided that
##  the above copyright notice and this permission notice appear in all
##  copies.
##
##  THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESSED OR IMPLIED
##  WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
##  MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
##  IN NO EVENT SHALL THE AUTHORS AND COPYRIGHT HOLDERS AND THEIR
##  CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
##  SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
##  LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
##  USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
##  ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
##  OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT
##  OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
##  SUCH DAMAGE.
##

require 5;

$|=1; # autoflush

use strict;
use vars qw/$opt_R $opt_r $opt_f $opt_u $opt_U $opt_a $opt_A $opt_z $opt_Z $opt_P $opt_N $opt_E $opt_i $opt_D $opt_p $opt_q $opt_s $opt_S/;
getopts('R:r:f:uUaAzZP:N:E:iD:p:qsS');

##########################################################################

sub getopts ($) {
    my($opts) = @_;
    my(%optf) = map { /(\w)/; $1 => $_ } $opts =~ /(\w:|\w)/g;
    my(%opts,@argv,$optarg);

    foreach (@ARGV) {
        if (@argv) {
            push @argv, $_;
        } elsif (defined $optarg) {
            if (exists $opts{$optarg}) {
                $opts{$optarg} .= " $_";
            } else {
                $opts{$optarg} = $_;
            }
            $optarg = undef;
        } elsif (!/^[-]/) {
            push @argv, $_;
        } else {
            while (/^\-(\w)(.*)/) {
                if (exists $optf{$1}) {
                    if (length($optf{$1}) > 1) {
                        if ($2 ne '') {
                            if (exists $opts{$1}) {
                                $opts{$1} .= " $2";
                            } else {
                                $opts{$1} = $2;
                            }
                        } else {
                            $optarg = $1;
                        }
                        last;
                    } else {
                        $opts{$1} = 1;
                    }
                } else {
                    warn "warning: unknown option $_\n";
                }
                $_ = "-$2";
            }
        }
    }
    if (defined $optarg) {
        warn "warning: option $optarg requires an argument\n";
    }

    foreach (keys %opts) {
        eval '$opt_'.$_.' = "'.quotemeta($opts{$_}).'";';
    }

    @ARGV = @argv;
}

my(%env) = ( '' => { } );
if (open(FH, "< $ENV{'HOME'}/.openpkg/build")) {
    my($env) = $env{''};
    while (<FH>) {
        if (/^\s*\[([^\]]*)\]/) {
            $env{$1} = { } unless $env{$1};
            $env = $env{$1};
        } elsif (my($opt,$val) = /^\-([RfruUaAzPN])\s*(.*?)\s*$/) {
            $val = 1 unless defined $val;
            $env->{$opt} = $val;
        }
    }
    close(FH);
}

die "openpkg:build:USAGE: $0 [-R rpm] [-r repository] [-f index.rdf] [-uUzZiqS] [-P priv-cmd] [-N non-priv-cmd] [-p platform] [-Dwith ...] [-Ename ...] ( [-aA] | patternlist )\n"
    unless $#ARGV >= 0 || ($#ARGV == -1 && ($opt_a || $opt_A));

##########################################################################

sub conditional ($$) {
    my($cond,$with) = @_;
    my(@s,$res);

    return 1 if $cond eq '';

    foreach (split(/\s+/,$cond)) {
        if ($_ eq '+') {
            die "FATAL: stack underflow in: $cond\n" if scalar(@s)<2;
            my($a) = pop @s;
            my($b) = pop @s;
            push @s, $a && $b;
        } elsif ($_ eq '|') {
            die "FATAL: stack underflow in: $cond\n" if scalar(@s)<2;
            my($a) = pop @s;
            my($b) = pop @s;
            push @s, $a || $b;
        } elsif ($_ eq '!') {
            die "FATAL: stack underflow in: $cond\n" if scalar(@s)<1;
            my($a) = pop @s;
            push @s, !$a;
        } else {
            push @s, ($with->{$_} eq 'yes') ? 1 : 0;
        }
    }
    die "FATAL: stack underflow in: $cond\n" if scalar(@s)<1;
    $res = pop @s;

    die "FATAL: stack not empty in: $cond\n" if scalar(@s)>0;
    return $res;
}

sub with_list ($$) {
    my($bags,$with) = @_;
    my($bag,$li);
    my(@out);

    foreach $bag (@$bags) {
        next unless conditional($bag->{'cond'}, $with);
        foreach $li (@{$bag->{'rdf:bag'}}) {
            push @out, @{$li->{'rdf:li'}};
        }
    }

    return \@out;
}

##########################################################################

my($RPM,$RPM_PRIV,$RPM_NPRIV,$CURL,$PROG);

$RPM = $opt_R || $env{''}->{opt}->{'R'} || '@l_prefix@/bin/rpm';
$RPM = (`which $RPM` =~ m{^(/.*)})[0];
die "FATAL: cannot locate rpm in path\n" unless $RPM =~ m{^/};

# augment command line parameters
foreach my $env (sort { $a cmp $b } grep { $RPM =~ /^\Q$_\E/ } keys %env) {
    while (my($opt,$val) = each %{$env{$env}}) {
        eval "\$opt_$opt = '$val' unless defined \$opt_$opt;";
    }
}

$RPM_PRIV  = ($opt_P ? $opt_P." ".$RPM : $RPM);
$RPM_NPRIV = ($opt_N ? $opt_N." ".$RPM : $RPM);
$CURL = $RPM;
$CURL =~ s/\/bin\/rpm$/\/lib\/openpkg\/curl/
    or die "FATAL: cannot deduce curl path from $RPM\n";

($PROG) = $0 =~ /(?:.*\/)?(.*)/;

sub version_cmp ($$) {
    my($a,$b) = @_;
    my(@a,@b,$c);
    my($ax,$bx);

    @a = split(/\./, $a);
    @b = split(/\./, $b);

    while (@a && @b) {
        if ($a[0] =~ /^\d+$/ && $b[0] =~ /^\d+$/) {
            $c = $a[0] <=> $b[0];
        } elsif ((($a,$ax) = $a[0] =~ /^(\d+)(.*)$/) &&
                 (($b,$bx) = $b[0] =~ /^(\d+)(.*)$/)) {
            $c = $a <=> $b;
            $c = $ax cmp $bx unless $c;
        } else {
            $c = $a[0] cmp $b[0];
        }
        return $c if $c;
        shift @a;
        shift @b;
    }

    $c = scalar(@a) <=> scalar(@b);

    return $c;
}

sub release_cmp ($$) {
    my($a,$b) = @_;

    return $a cmp $b;
}

sub vcmp ($$) {
    my($a,$b) = @_;
    my($av,$ar) = $a =~ /^(.*?)(?:\-([\d\.]+))?$/;
    my($bv,$br) = $b =~ /^(.*?)(?:\-([\d\.]+))?$/;
    my($c);

    if ((defined $ar) && (defined $br)) {
        $c = release_cmp($ar,$br);
        return $c if $c;
    }
    if ((defined $av) && (defined $bv)) {
        $c = version_cmp($av,$bv);
        return $c if $c;
    }
    return 0;
}

sub vs ($) {
    my($t) = @_;
    return "$t->{version}-$t->{release}";
}

sub vsn ($) {
    my($t) = @_;
    return "$t->{name}-$t->{version}-$t->{release}";
}

##########################################################################

sub get_config ()
{
    my($c,@q,@g);

    $c = `$RPM_NPRIV --eval '%{_rpmdir} %{_rpmfilename} %{_target_os} %{_target_cpu} %{_target_platform} %{_prefix}'`;
    chomp($c);
    (@q) = split(/\s+/,$c);

    $q[1] =~ s/%{OS}/$q[2]/;
    $q[1] =~ s/%{ARCH}/$q[3]/;


    $c = `$RPM_NPRIV --showrc`;
    @g = $c =~ /\%\{l_tool_locate\s+([^\s\}]+)/g;

    return {
        rpmdir   => $q[0],
        template => $q[1],
        platform => $q[4],
        prefix   => $q[5],
        optreg   => '(?:'.join('|', map { "\Qwith_$_\E" } @g).')'
        };
}

sub get_release () {
    my($rel,$url);

    ($rel) =`$RPM_NPRIV -qi openpkg` =~ /Version:\s*(\S+)/m;

    if ($rel =~ /^\d+$/) {
        print "# $PROG current($rel)\n";
        print "# using '$RPM_NPRIV' (build) and '$RPM_PRIV' (install)\n";
        $url = "ftp://ftp.openpkg.org/current/";
    } elsif ($rel =~ /^(\d+\.\d+)/) {
        $rel = $1;
        print "# $PROG release($rel)\n";
        $url = "ftp://ftp.openpkg.org/release/$rel/";
    } else {
        die "FATAL: don't know how to handle this release\n";
    }

    return $url;
}

sub get_installed () {
    my(%map);
    my(@l) = `$RPM_NPRIV --provides -qa`;

    foreach (@l) {
        /^(\S+)\s*(?:=\s*([^\s\-]+)-([^\s\+]+)(\+PROXY)?)?$/;
        push(@{$map{$1}->{"$2-$3"}}, {
            name       => $1,
            version    => (defined $2 ? $2 : '*'),
            release    => (defined $3 ? $3 : '*'),
            PROXY      => $4
        });
    }

    return \%map;
}

sub revdep ($$$) {
    my($rev,$t,$name) = @_;

    return 1 if $name eq $t->{name};

    foreach (@{$rev->{$_}}) {
        return 1 if revdep($rev,$t,$_->{name});
    }
    return -1;
}

sub get_revdep ($) {
    my($env) = @_;
    my($i) = $env->{'installed'};
    my($r) = $env->{'repository'};
    my($pkg, %rev);
    my(@vers,$t,@names);

    print "# computing reverse dependencies\n";

    foreach $pkg (keys %$i) {

        unless ($r->{$pkg}) {
            print "# ATTENTION: $pkg has no upgrade path\n";
            next;
        }

        @vers = get_versions($r->{$pkg}, sub { 1; });
        foreach (@vers) {
            foreach $t (@{$r->{$pkg}->{$_}}) {
                next unless $i->{$t->{name}};
                next unless $t->{depends};

                @names = grep { $_ ne '' }
                         map { /^(\S+)/ }
                         @{$t->{depends}};
                next unless @names;
                push @{$rev{$_}}, $t foreach @names;
            }
        }
    }

    foreach $pkg (keys %rev) {
        $rev{$pkg} = [
            sort {
                revdep(\%rev, $b, $a->{name});
            } @{$rev{$pkg}}
        ];
    }

    return \%rev;
}

sub parse_options ($) {
    my($l) = @_;
    $l = join("\n",@$l) if ref $l;
    return unless $l =~ s/.*Options//;
    my(%with) = $l =~ /--define\s*'(\S+)\s+(\S+?)'/g;
    return \%with;
}

sub override_options ($$$) {
    my($old, $new, $reg) = @_;

    foreach my $k (keys %$new) {
        $old->{$k} = $new->{$k} if exists $old->{$k} || $k =~ /^$reg$/;
    }
}

sub get_with ($;$) {
    my($t,$fn) = @_;
    my(@l,%with);

    unless ($t->{OPTIONS}) {
        if (defined $fn) {
            @l = `$RPM_NPRIV -qi -p $fn`;
        } else {
            @l = `$RPM_NPRIV -qi $t->{name}`;
        }
        $t->{OPTIONS} = parse_options(\@l);
    }
    return $t->{OPTIONS};
}

sub relurl ($$$) {
    my($url,$fn,$suburl) = @_;
    my($subfn,$submap);

    unless ($suburl =~ /^\w+:\/\// || $suburl =~ /^\//) {
        if (defined $fn) {
            $subfn = $fn;
            $subfn =~ s/\/[^\/]*$//;
            $subfn .= '/' unless $subfn =~ /\/$/;
            $subfn .= $suburl;
            $suburl = $subfn;
        } else {
            $subfn = $url;
            $subfn =~ s/\/[^\/]*$//;
            $subfn .= '/' unless $subfn =~ /\/$/;
            $suburl = "$subfn$suburl";
            $subfn  = undef;
        }
    }

    return ($suburl, $subfn);
}

sub xel($) {
    my($a) = @_;
    my($l) = $a->[0];
    return '' if ref $l;
    return $l;
}
    
sub get_index ($$$) {
    my($url,$fn,$with) = @_;
    my($ua,$req,$res,$rdf);
    my($bzip2,$path);
    my(%map,@include);
    my($fetch);

    $fetch = defined $fn ? $fn : $url;

    $bzip2 = $RPM;
    $bzip2 =~ s/bin\/rpm$/lib\/openpkg\/bzip2/
        or die "FATAL: cannot deduce bzip2 path from $RPM\n";

    $fetch !~ /\.bz2$/ || -x $bzip2
        or die "FATAL: $bzip2 not found\n";

    if ($fetch =~ /^\w+:/) { # looks like URL scheme

        print "# curling index $fetch\n";
        if ($fetch =~ /\.bz2$/) {
            $path = "$CURL -q -s -o - \"$fetch\" | $bzip2 -dc |";
        } else {
            $path = "$CURL -q -s -o - \"$fetch\" |";
        }
    } else {
        print "# reading index file $fn\n";
        if ($fetch =~ /\.bz2$/) {
            $path = "$bzip2 -dc $fetch |";
        } else {
            $path = "< $fetch";
        }
    }

    open(RFH, $path) or
        die "FATAL: cannot open '$fetch' ($!)\n";

    eval {
        require XML::Simple;
    };
    if ($@) {

        print "# using simple text parser\n";

        my($section);
        my($name,$version);
        my($href,$release,$desc);
        my(@prereq,@bprereq);
        my(@provides,@conflicts);
        my($platform,$prefix);
        my($rec);
        my($tag,$cond,$body);
        my($useit);

        while (<RFH>) {

            s/&gt;/>/g;
            s/&lt;/</g;

            if (!(defined $href) && /<rdf:Description.*?href="([^"]*)"/) {
                $href      = $1;
                $section   = undef;
                $name      = undef;
                $release   = undef;
                $desc      = '';
                $platform  = undef;
                $prefix    = undef;
                @prereq    = ();
                @bprereq   = ();
                @provides  = ();
                @conflicts = ();
            }

            if (!(defined $href) && /<Repository.*?href="([^"]*)"/) {
                push(@include, $1);
                next;
            }

            next unless defined $href;

            ($tag,$cond,$body) = /<(\/?[\w:]+)\s*(?:cond="([^"]+)")?>([^<]*)/;

            $useit = conditional($cond,$with);

            if ($tag eq 'Description') {
                $section = 'description';
            } elsif ($tag eq '/Description') {
                $section = undef;
            } elsif ($section eq 'description') {
                $desc .= $_;
            } elsif ($tag eq 'PreReq') {
                $section = 'prereq' if $useit;
            } elsif ($tag eq '/PreReq') {
                $section = undef;
            } elsif ($tag eq 'BuildPreReq') {
                $section = 'bprereq' if $useit;
            } elsif ($tag eq '/BuildPreReq') {
                $section = undef;
            } elsif ($tag eq 'Provides') {
                $section = 'provides' if $useit;
            } elsif ($tag eq '/Provides') {
                $section = undef;
            } elsif ($tag eq 'Conflicts') {
                $section = 'conflicts' if $useit;
            } elsif ($tag eq '/Conflicts') {
                $section = undef;
            } elsif ($tag eq 'Name') {
                $name = $body;
            } elsif ($tag eq 'Version') {
                $version = $body;
            } elsif ($tag eq 'Release') {
                $release = $body;
            } elsif ($tag eq 'Platform') {
                $platform = $body;
            } elsif ($tag eq 'Prefixes') {
                $prefix = $body;
            } elsif ($tag eq 'rdf:li') {
                if ($section eq 'prereq') {
                    push(@prereq, $body);
                } elsif ($section eq 'bprereq') {
                    push(@bprereq, $body);
                } elsif ($section eq 'provides') {
                    push(@provides, $body);
                } elsif ($section eq 'conflicts') {
                    push(@conflicts, $body);
                }
            } elsif ($tag eq '/rdf:Description') {

                if (defined $href &&
                    defined $name &&
                    defined $version &&
                    defined $release) {

                    @provides = map {
                        /(\S+)\s*(?:=\s*(\S+?)\-(\S+))?$/;
                        {
                            name    => $1,
                            version => $2,
                            release => $3
                        }
                    } @provides;

                    unless (grep($_->{name} eq $name, @provides)) {
                        push(@provides, {
                            name    => $name,
                            version => $version,
                            release => $release
                        });
                    }

                    $rec = {
                        href      => (relurl($url, undef, $href))[0],
                        name      => $name,
                        version   => $version,
                        release   => $release,
                        depends   => [ @bprereq ],
                        keeps     => [ @prereq ],
                        conflicts => [ @conflicts ],
                        desc      => $desc,
                        platform  => $platform,
                        prefix    => $prefix
                    };
                    $rec->{OPTIONS} = parse_options($rec->{desc});

                    foreach (@provides) {
                        push(@{$map{$_->{name}}->{vs($_)}}, $rec);
                    }
                }

                $href = undef;
            }
        }
    } else {

        print "# using XML parser\n";

        my($xml) = XML::Simple::XMLin(\*RFH, forcearray => 1);
        my($desc) = $xml->{'Repository'}->[0]->{'rdf:Description'};
        my($sub)  = $xml->{'Repository'}->[0]->{'Repository'};
        my($provides,@provides,$rec);
        my($href,$name,$version,$release);

        foreach (@$desc) {

            $href    = $_->{'href'};
            $name    = xel($_->{'Name'});
            $version = xel($_->{'Version'});
            $release = xel($_->{'Release'});

            next unless defined $href &&
                        defined $name &&
                        defined $version &&
                        defined $release;

            $provides = $_->{'Provides'}->[0]->{'rdf:bag'}->[0]->{'rdf:li'};

            @provides = map {
                /(\S+)\s*(?:=\s*(\S+?)\-(\S+))?$/;
                {
                    name    => $1,
                    version => $2,
                    release => $3
                }
            } @$provides;

            unless (grep($_->{name} eq $name, @provides)) {
                push(@provides, {
                    name    => $name,
                    version => $version,
                    release => $release
                });
            }

            $rec = {
                href     => (relurl($url, undef, $href))[0],
                name     => $name,
                version  => $version,
                release  => $release,
                platform => xel($_->{'Platform'}),
                prefix   => xel($_->{'Prefixes'}),
                depends  => with_list($_->{'BuildPreReq'}, $with),
                keeps    => with_list($_->{'PreReq'}, $with),
                conflicts => with_list($_->{'Conflicts'}, $with),
                desc     => xel($_->{'Description'})
            };
            $rec->{OPTIONS} = parse_options($rec->{desc});

            foreach (@provides) {
                push(@{$map{$_->{name}}->{vs($_)}}, $rec);
            }
        }

        if ($sub) {
            @include = map { $_->{href} } @$sub;
        }
    }

    close(RFH)
        or die "FATAL: an I/O error occured\n";

    #
    # cannot do real recursions on file handles, so we simply append
    # all sub-RDFs, the result is flattend into a big hash anyway
    #
    foreach (@include) {
        my($submap);
        my($suburl,$subfn) = relurl($url,$fn,$_);
        $submap = get_index($suburl,$subfn,$with);
        while (my($name,$vmap) = each %$submap) {
            while (my($vs,$recs) = each %$vmap) {
                push @{$map{$name}->{$vs}}, @$recs;
            }
        }
    }

    return \%map;
}

#
# grep all versions of a name that
# satisfy a condition
#
sub get_versions ($$) {
    my($relmap, $cond) = @_;
    return grep { $cond->($_); }
           sort { vcmp($a,$b); } keys %$relmap;
}

#
# there can be multiple sources for a target release
#
sub chose_source ($$@) {
    my($env, $name, $vmap, @vers) = @_;
    my(@recs,@nrecs,$rec);

    return unless @vers;

    @recs = grep {
                $env->{sourceonly} ? (
                    !(defined $_->{'platform'})
                ) : (
                    !(defined $_->{'platform'}) || (
                       defined $_->{'prefix'} &&
                       $_->{'platform'} eq $env->{config}->{platform} &&
                       $_->{'prefix'} eq $env->{config}->{prefix}
                    )
                )
            } map { @{$vmap->{$_}} } @vers;
    return unless @recs;

    if (scalar(@recs) > 1) {
        @nrecs = grep {
            $env->{built}->{$_->{name}} ||
            $env->{installed}->{$_->{name}}
            } @recs;
        @recs = @nrecs if @nrecs;
    }

    if (scalar(@recs) > 1 && !$env->{sourceonly}) {
        @nrecs = grep {
            defined $_->{'platform'}
        } @recs;
        @recs = @nrecs if @nrecs;
    }

    if (scalar(@recs) > 1) {

        print "# ambigous sources for $name\n";
        my($i) = 0;
        foreach (@recs) {
            print "# $i: ".vsn($_)." = $_->{href}\n";
            $i++;
        }
        return;

    } else {
        if ($env->{upgrade}) {
            $rec = $recs[-1];
        } else {
            $rec = $recs[0];
        }
    }

    print "# source for $name is ".vsn($rec)."\n";

    return $rec;
}

#
# see wether target is in map
#
sub target_exists ($$) {
    my($target, $map) = @_;
    my($vmap) = $map->{$target->{name}};

    return unless $vmap;

    return !defined $target->{version} ||
            defined $vmap->{vs($target)};
}

#
# find target in map
#
sub find_target ($$) {
    my($name, $map) = @_;
    my($vmap) = $map->{$name};
    my(@vs);

    return unless $vmap;

    @vs = sort { vcmp($b,$a) } keys %$vmap;
    return $vmap->{$vs[0]}->[-1];
}

#
# see wether target has conflicts in map
#
sub target_conflicts ($$) {
    my($target, $map) = @_;
    my($t);

    foreach (@{$target->{conflicts}}) {
        $t = find_target($_, $map);
        return $t if $t;
    }

    return;
}

#
# retrieve build dependencies for target in map
#
sub target_depends ($$) {
    my($target, $map) = @_;
    my($vmap,$vers);

    die "FATAL: ",vsn($target)," not in depend map\n"
        unless
        ( $vmap = $map->{$target->{name}} ) &&
        ( defined $target->{version}      ) &&
        ( $vers = $vmap->{vs($target)}    ) &&
        @$vers;

    return $vers->[0]->{depends};
}

#
# retrieve runtime dependencies for target in map
#
sub target_keeps ($$) {
    my($target, $map) = @_;
    my($vmap,$vers);

    die "FATAL: ",vsn($target)," not in keep map\n"
        unless
        ( $vmap = $map->{$target->{name}} ) &&
        ( defined $target->{version}      ) &&
        ( $vers = $vmap->{vs($target)}    ) &&
        @$vers;

    return $vers->[0]->{keeps};
}

#
# test wether target could be upgraded
#
sub target_newer ($$) {
    my($target, $map) = @_;
    my($vs) = vs($target);
    my($vmap) = $map->{$target->{name}};

    return 1 unless $vmap;

    return !grep { vcmp($vs, $_) <= 0; } keys %$vmap;
}

#
# check wether installed package matches
# build options
#
sub target_suitable ($$) {
    my($target, $with) = @_;
    my($iwith);
    my($k,$v);

    $iwith = $target->{OPTIONS};
    while (($k,$v) = each %$with) {
        if (exists $iwith->{$k}) {
            return 0 if $iwith->{$k} ne $with->{$k};
        }
    }

    return 1;
}

#
# record target status
#
sub target_setstatus ($$$) {
    my($target, $status, $pri) = @_;

    if ($pri > $target->{STATUSPRI}) {
        $target->{STATUSPRI} = $pri;
        $target->{STATUS}    = $status;
    }
}

#
# report options that are not used for 
#
sub warn_about_options ($$$) {
    my($target, $with, $c) = @_;
    my($iwith) = $target->{OPTIONS};
    my($k,$v);

    return unless defined $iwith;
    while (($k,$v) = each %$with) {
        if (!exists $iwith->{$k} && $k !~ $c->{optreg}) {
            print "# ATTENTION: $target->{name} ignores option '$k'\n";
        }
    }
}

#
# locate target for a dependency
#
sub dep2target ($$) {
    my($dep, $env) = @_;
    my($name,@vers);
    my($i,$r,$b,$cond,$version);
    my($t,$tdef);

    $dep =~ s/(\S+)\s*//;
    $name = $1;

    $i = $env->{installed}->{$name};
    $r = $env->{repository}->{$name};
    $b = $env->{built}->{$name};

    return unless $i || $r || $b;

    if ($dep =~ /^>=\s*(\S+)$/) {
        $version = $1;
        $cond = sub { vcmp($_[0],$version) >= 0; };
    } elsif ($dep =~ /^=\s*(\S+)$/) {
        $version = $1;
        $cond = sub { vcmp($_[0],$version) == 0; };
    } elsif ($dep =~ /^\s*$/) {
        $cond = sub { 1; };
    } else {
        print "# don't know how to handle PreReq: $name $dep\n";
        return;
    }

    $tdef = undef;

    if ($i && (@vers = get_versions($i, $cond))) {
        foreach (@vers) {
            $t = $i->{$_}->[0];
            if (get_with($t), target_suitable($t, $env->{with})) {
                $tdef = $t;
                if (!$env->{upgrade}) {
                    return ($t, 1);
                }
            }
        }
    }
    if ($b && (@vers = get_versions($b, $cond))) {
        return ($b->{$vers[0]}->[0], 1);
    }

    $t = chose_source($env, $name, $r, get_versions($r, $cond));
    if ($t) {
        return ($t, 0);
    }

    if ($tdef) {
        return ($tdef, 1);
    }

    return;
}


sub make_dep ($$$$$$) {
    my($target,$depth,$env,$list,$blist,$clist) = @_;
    my($d,$k,%d,%k,$t,$old);
    my(@deps,$conflict);

    if (target_exists($target, $env->{built})) {
        print "# $target->{name} is already in list\n";
        return;
    }

    if ($t = target_conflicts($target, $env->{installed})) {
        target_setstatus($target,'CONFLICT',4);
        push(@$clist,$target);
        print "# $target->{name} conflicts with ",vsn($t),"\n";
        return;
    }

    if ($t = target_conflicts($target, $env->{built})) {
        target_setstatus($target,'CONFLICT',4);
        push(@$clist,$target);
        print "# $target->{name} conflicts with ",vsn($t),"\n";
        return;
    }

    #
    # see if a target is already installed and requires a rebuild
    #
    if ($t = find_target($target->{name}, $env->{installed})) {
        if (exists $env->{exclude}->{$target->{name}}) {
            print "# excluding $target->{name} (no upgrade allowed)\n";
            return;
        }
        get_with($t);
        if ($target->{REBUILD}) {
            target_setstatus($target,'DEPEND',1);
            print "# rebuilding $target->{name} (dependency)\n";
        } elsif ($env->{zero}) {
            target_setstatus($target,'ZERO',1);
            print "# rebuilding $target->{name} (zero)\n";
        } elsif (target_newer($target, $env->{installed})) {
            target_setstatus($target,'UPGRADE',3);
            print "# rebuilding $target->{name} (upgrade)\n";
        } elsif (!target_suitable($t, $env->{with})) {
            target_setstatus($target,'MISMATCH',2);
            print "# rebuilding $target->{name} (parameter mismatch)\n";
        } else {
            print "# $target->{name} is already installed\n";
            return;
        }
        # use options from installed base
        override_options($target->{OPTIONS}, $t->{OPTIONS},
                         $env->{config}->{optreg});
        # remember this is a rebuild for a proxy package
        $target->{PROXY} = $t->{PROXY};
        $target->{REBUILD} = 1;
    } else {
        target_setstatus($target,'ADD',3);
    }

    if (exists $env->{exclude}->{$target->{name}}) {
        die "FATAL: target ".vsn($target)." is forbidden\n";
    }

    # mark this as a target before reverse dependencies trigger
    # it again
    push(@{$env->{built}->{$target->{name}}->{vs($target)}}, $target);

    $d = target_depends($target, $env->{repository});
    $k = target_keeps($target, $env->{repository});

    #
    # recurse over dependencies
    #
    if (@$d || @$k) {

        %d = map { $_ => 1 } @$d, @$k;
        %k = map { $_ => 1 } @$k;

        @deps     = ();
        $conflict = 0;
        foreach (keys %d) {

            # old index misses a OpenPKG provider in the index... skip it
            next if $_ eq 'OpenPKG';

            ($t,$old) = dep2target($_, $env);
            if ($t) {
                if ($old) {
                    print "# $target->{name} uses ".vsn($t)." for $_\n";
                    next;
                }

                # record which targets to keep in blist
                if ($k{$_}) {
                    push @$blist,$t;
                    print "# $target->{name} installs ".vsn($t)." for $_\n";
                } else {
                    print "# $target->{name} requires ".vsn($t)." for $_\n";
                }
                push @deps, $t;
            } else {
                print "# $target->{name} searches a frood called '$_'\n";
                push(@{$env->{fatal}},vsn($target));
                target_setstatus($target,'UNDEF',4);
                push @$clist, $target;
                $conflict = 1;
            }
        }

        unless ($conflict) {
            foreach $t (@deps) {
                make_dep($t,$depth+1,$env,$list,$blist,$clist);
            }
        }
    }

    print "# adding ".vsn($target)." to list\n";
    push(@$list, $target);

    return if $conflict;

    if (!$env->{quick} &&
        $target->{name} ne 'openpkg' &&
        $target->{REBUILD}) {

        unless ($env->{revdep}) {
            $env->{revdep} = get_revdep($env);
        }

        foreach $t (@{$env->{revdep}->{$target->{name}}}) {

            # this is a rebuild, triggering further revdeps
            $t->{REBUILD} = 1;

            # this is a rebuild, keep this installed
            push(@$blist, $t);

            print "# rebuilding revdep ".vsn($t)."\n";
            make_dep($t,$depth+1,$env,$list,$blist,$clist);
        }
    }
}

sub remove_list ($$$) {
    my($targets, $keeps, $installed) = @_;
    my(%keep);

    %keep = map { $_ => 1 } @$keeps;
    return [ grep {
               !$keep{$_} && !$installed->{$_->{name}}->{vs($_)};
             } @$targets
           ];
}

sub build_list ($$) {
    my($pattern, $env) = @_;
    my(@goals,@targets,@keeps,@conflicts,$bonly,$t);
    my($name,$r,$i,@vers);
    my(@todo);

    if (defined $pattern) {
        @todo = ();
        foreach (split(/\s+/,$pattern)) {
            next unless /\S/;
            if (s/\*+$//) {
                push @todo, '^'.quotemeta($_).'';
            } else {
                push @todo, '^'.quotemeta($_).'$';
            }
        }
        @todo = map {
            my($p) = $_;
            grep(/$p/, keys %{$env->{repository}})
        } @todo;
    } else {
        @todo = grep {
                    my($n) = $_;
                    (ref $env->{installed}->{$n}) &&
                    grep { $_ ne '-' } keys %{$env->{installed}->{$n}}
                } keys %{$env->{repository}};
    }

    #
    # chose sources for goals from repository
    #
    foreach $name (@todo) {
        $t = undef;

        #
        # keeping installed packages for goals is ugly
        # -> we currently do not support installed source RPMs
        # -> source RPMs might already have expired from repository
        #
        # consequence:
        # -> goals are always upgraded to repository versions
        #
        #unless ($env->{upgrade}) {
        #    $i = $env->{installed}->{$name};
        #    if (@vers = get_versions($i, sub { 1; })) {
        #        $t = chose_source($env, $name, $i, @vers);
        #    }
        #}

        unless ($t) {
            $r = $env->{repository}->{$name};
            if (@vers = get_versions($r, sub { 1; })) {
                $t = chose_source($env, $name, $r, @vers);
            }
        }

        if ($t) {
            warn_about_options($t, $env->{with}, $env->{config});
            push(@goals, $t);
        } else {
            if ($env->{status}) {
                print "# dropping goal '$name'\n";
            } else {
                die "FATAL: cannot find source for '$name'\n";
            }
        }
    }
    return unless @goals;

    @targets = ();
    @keeps   = @goals;
    foreach $t (@goals) {
        print "# recursing over dependencies for ".vsn($t)."\n";
        make_dep($t,0,$env,\@targets,\@keeps,\@conflicts);
    }

    $bonly = remove_list(\@targets, \@keeps, $env->{installed});

    return (\@targets, $bonly, \@conflicts);
}

#######################################################################

sub target2rpm ($$) {
    my($target,$c) = @_;
    my($tmpl) = $c->{template};
    my($popt) = $target->{PROXY} ? '+PROXY' : '';

    $tmpl =~ s/%{NAME}/$target->{name}/;
    $tmpl =~ s/%{VERSION}/$target->{version}/;
    $tmpl =~ s/%{RELEASE}/$target->{release}$popt/;

    return $c->{rpmdir}.'/'.$tmpl;
}

#######################################################################

sub binary_target ($$) {
    my($t, $fn) = @_;
    my(%target) = %$t;

    get_with(\%target, $fn);

    return \%target;
}

sub find_proxy ($$) {
    my($t,$bpkg) = @_;
    my(@l) = `$RPM_NPRIV -ql $t->{name}`;
    my($link) = (grep { $_ =~ /\/\.prefix-$t->{name}$/ } @l)[0];
    return unless defined $link;
    chomp $link;
    my($prefix) = readlink($link);
    return unless defined $prefix;
    $bpkg =~ s/.*\///;
    $bpkg =~ s/\+PROXY(\.[^-]+-[^-]+)-[^-]+\.rpm$/$1-*.rpm/;
    return (glob("$prefix/RPM/PKG/$bpkg"))[0];
}

sub make_defines ($$$) {
    my($old, $new, $c) = @_;
    my($with);

    #
    # override old parameters with new parameters
    # drop new parameters that do not exist in old set
    #
    # if there is no old set at all (which happens if there
    # is no template and no installed package), just use the
    # new parameters and assume these are useful.
    #
    if ($old) {
        $old = { %$old };
        override_options($old, $new, $c->{optreg});
    } else {
        $old = $new;
    }

    #
    # convert parameters to --define command line options
    # skip parameter templates from index
    #
    $with = join(' ',map { "--define '$_ $old->{$_}'" }
                     grep { $old->{$_} !~ /^%/ } keys %$old);

    $with = ' '.$with if $with ne '';

    return $with;
}

sub print_list1 ($$$@$) {
    my($list,$c,$uncond,$with,$ignore) = @_;
    my($spkg,$bpkg,$ppkg);
    my($opt);
    my($cmd1, $cmd2, $mark);

    $mark = '::::';

    foreach (@$list) {
        $spkg = $_->{href};
        $bpkg = target2rpm($_, $c);

        #
        # rebuild binary package IF
        #
        # 'unconditional' option
        # OR there is no binary package
        # OR dependency check found that installed package is not suitable
        # OR existing binary package doesn't satisfy wanted options
        #
        $cmd1 = undef;
        if ($uncond || !-f $bpkg || $_->{REBUILD} ||
            !target_suitable(binary_target($_, $bpkg),$with)) {

            $opt = make_defines($_->{OPTIONS}, $with, $c);

            #
            # proxy packages are rebuilt from their maste
            # hierachy
            #
            # someone preferred a binary from the repository
            # just copy it to the local store
            #
            if ($_->{PROXY}) {
                $ppkg = find_proxy($_,$bpkg) or
                die "FATAL: proxy package ",vsn($_)," does not exist\n";
                #
                # rpm doesn't support additional parameters to the
                # mkproxy script
                # $cmd1 = "$RPM_NPRIV$opt --makeproxy $ppkg -- -o $bpkg";
                #
                $cmd1 = "( cd $c->{rpmdir} && $RPM_NPRIV$opt --makeproxy $ppkg )";
            } elsif (defined $_->{platform}) {
                $cmd1 = "$CURL -q -s -o $bpkg $spkg";
            } else {
                $cmd1 = "$RPM_NPRIV$opt --rebuild $spkg";
            }
        }

        #
        # if package exist force rpm to copy over new files
        # better than erasing everything and losing configuration
        # files
        #
        $opt = $_->{REBUILD} ? ' --force' : '';
        $cmd2 = "$RPM_PRIV$opt -Uvh $bpkg";

        if ($ignore) {
            $cmd2 = "$cmd1 && \\\n$cmd2" if defined $cmd1;
        } else {
            if (defined $cmd1) {
                $cmd2 = "$cmd1 || exit \$?\n$cmd2 || exit \$?"
            } else {
                $cmd2 = "$cmd2 || exit \$?";
            }
        }
        print "echo $mark $spkg $mark\n$cmd2\necho $mark $spkg = \$? $mark\n";
    }
}

sub print_list2 ($$) {
    my($list,$c) = @_;
    my($pkg);

    foreach (@$list) {
        $pkg = "$_->{name}-$_->{version}-$_->{release}";
        print "$RPM_PRIV -e $pkg\n";
    }
}

sub print_status ($$$$$) {
    my($installed,$repository,$list,$bonly,$clist) = @_;
    my(%bonly) = map { $_ => 1 } @$bonly;
    my(%map,$n,@names,$t);
    my($old,$tag,$new);

    foreach (@$list, @$clist) {
        $map{$_->{name}} = {
            rel    => "$_->{version}-$_->{release}",
            status => $_->{STATUS}
        };
    }
    
    foreach (@$bonly) {
        $map{$_->{name}} = {
            rel    => "$_->{version}-$_->{release}",
            status => 'TEMP'
        };
    }

    @names = keys %map;
    foreach $n (keys %$installed) {
        next if exists $map{$n};
        next unless grep { $_ ne '-' } keys %{$installed->{$n}};
        $map{$n}->{'status'} = 'OK';
        push @names,$n;
    }

    foreach $n (keys %$repository) {
        next if exists $map{$n};
        next unless grep { $_ ne '-' } keys %{$repository->{$n}};
        $t = find_target($n, $repository);
        $map{$n}->{'status'} = 'NEW';
        $map{$n}->{'rel'}    = vs($t);
        push @names,$n;
    }

    foreach $n (sort @names) {
        $old = join ',',
            map { "$n-$_" }
            sort
            grep { $_ ne '-' }
            keys %{$installed->{$n}};
        $old = $n if $old eq '';

        $tag = $map{$n}->{status};
        $new = defined $map{$n}->{rel} ? " $n-$map{$n}->{rel}" : '';

        printf "%-35s %-8s%s\n", $old, $tag, $new;
    }
}

#######################################################################

my($config,$url,$repository,$installed,$env,$list,$bonly,$clist);
my($pattern,%with,%exclude);

if ($opt_a) {
    $pattern = undef;
} else {
    $pattern = join(' ', @ARGV);
}

if ($opt_A) {
    $pattern = '*';
}

%with    = map {
    /([^\s=]+)(?:\=(\S+))?/
    ? ($1 => (defined $2 ? $2 : 'yes'))
    : ()
    } split(/\s+/, $opt_D);
%exclude = map { $_ => 1 } split(/\s+/, $opt_E);

$config         = get_config();

if (defined $opt_p) {
    $config->{platform} = $opt_p;
}

if (defined $opt_r) {
    $url = $opt_r;
    $url .= '/' unless $url =~ /\/$/;
} else {
    $url = get_release();
}

#
# if we read the index from a file we can no longer deduce
# repository paths from index paths. For now lets assume
# that everything is below SRC/ to be compatible with
# existing file indexes.
#
if (defined $opt_f && !defined $opt_r) {
    $url .= 'SRC/';
}

$installed      = $opt_Z ? {} : get_installed();
$repository     = get_index($url.'00INDEX.rdf',$opt_f,\%with);

$env = {
    config     => $config,
    installed  => $installed,
    repository => $repository,
    built      => {},
    revdep     => undef,
    with       => \%with,
    exclude    => \%exclude,
    upgrade    => ($opt_a || $opt_U),
    zero       => ($opt_z || $opt_Z),
    quick      => $opt_q,
    status     => ($opt_s || $opt_S),
    fatal      => [],
    sourceonly => ($opt_u ||
                   $opt_U ||
                   $opt_z ||
                   $opt_Z ||
                   scalar(%with) > 0 )
};

($list,$bonly,$clist) = build_list($pattern, $env);
die "FATAL: cannot find package\n" unless defined $list;

if ($opt_S) {
    print_status($installed,$repository,$list,$bonly,$clist);
} elsif ($opt_s) {
    print_status($installed,{},$list,$bonly,$clist);
} else {
    if (@{$env->{fatal}}) {
        die "FATAL errors occured while building:\n",
            join (',', @{$env->{fatal}}),
            "\n";
    }

    print_list1($list,$config,$opt_a || $opt_u || $opt_U,\%with,$opt_i);
    print_list2($bonly,$config);
}