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

##
##  openpkg-build.pl -- create build scripts from package index
##
##  Copyright (c) 2000-2003 Cable & Wireless Deutschland GmbH
##  Copyright (c) 2000-2003 The OpenPKG Project <http://www.openpkg.org/>
##  Copyright (c) 2000-2003 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 $opt_X/;
my $getopts = 'R:r:f:uUaAzZP:N:E:iD:p:qsSX';
getopts($getopts);

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

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{''};
    my($go) = $getopts;
    $go =~ s/[^a-zA-Z]//g;
    while (<FH>) {
        if (/^\s*\[([^\]]*)\]/) {
            $env{$1} = { } unless $env{$1};
            $env = $env{$1};
        } elsif (my($opt,$val) = /^\-([$go])\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));

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

#
# evaluate a condition attribute from an option set
#
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;
}

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

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) = @_;

    return 0 if $a eq $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 parse_provides ($) {
    my($s) = @_;
    my($nam,$val,$pre,$with,$pxy,$ver,$rel);

    ($nam,$val) = $s =~ /^(\S+)\s*(?:=\s*(\S*?))?$/;

    #
    # build options are encoded as a Requirement
    # <packagename>::<buildoption> = <value>
    #
    # since the value is interpreted as a version number
    # you can only do equality tests
    #
    if (($pre,$with) = $nam =~ /^(\S+?)::(\S*)$/) {
        $val =~ s/(?:\%([0-9a-fA-F][0-9a-fA-F]))/chr(hex($1))/eg;
        ($ver,$rel,$pxy) = ($val, '', undef);
    } else {
        ($ver,$rel,$pxy) = $val =~ /^([^\s\-]+)-([^\s\+]+)(\+PROXY)?$/;
    }

    return {
        name    => $nam,     # the full name of the resource
        version => $ver,     # the version (or value)
        release => $rel,     # and release number
        proxy   => $pxy,     # wether the resource is a PROXY resource
        prefix  => $pre,     # the packagename (if resource is an option)
        with    => $with     # the buildoption (if resource is an option)
    };
}

sub parse_depends ($) {
    my($dep) = @_;
    my($name, $op, $val);

    if (ref $dep) {
        #
        # dependency from new index stored as a node
        #
        # content of the node is the name
        # certain attributes denote the comparison operator
        # the value of such an attribute is the comparison operand
        #
        # the operator (and operand) are optional and there can
        # only be one
        #
        $name    = $dep->{content};
        $op = undef;
        $op = 'equ' if exists $dep->{equ};
        $op = 'geq' if exists $dep->{geq};
        $op = 'leq' if exists $dep->{leq};
        $op = 'gt'  if exists $dep->{gt};
        $op = 'lt'  if exists $dep->{lt};
        if (defined $op) {
            $val = $dep->{$op};
        }
    } elsif ($dep =~ /\S/) {
        #
        # dependency from old index stored as text string
        #
        # "name operator operand"
        # or
        # "name"
        #
        ($name,$op,$val) = $dep =~ /(\S+)\s*(?:(\S+)\s*(\S+))?\s*$/;
        if (defined $op) {
            $op = {
                '=='  => 'equ', '='   => 'equ',
                '>='  => 'geq', '=>'  => 'geq',
                '<='  => 'leq', '=<'  => 'leq',
                '>'   => 'gt',  '<'   => 'lt'
            }->{$op};
            unless (defined $op) {
                print "# don't know how to handle dependency: $dep\n";
                return;
            }
        }
    }

    return {
        name => $name,
        op   => $op,
        val  => $val
    };
}

sub depends2provides ($) {
    my($dep) = @_;
    my($ver,$rel,$pxy,$pre,$with);

    ($ver,$rel,$pxy) = $dep->{val} =~ /^([^\s\-]+)-([^\s\+]+)(\+PROXY)?$/;
    ($pre,$with) = $dep->{name} =~ /^(\S+?)::(\S*)$/;

    return {
        name    => $dep->{name},
        version => (defined $ver ? $ver : $dep->{val}),
        release => $rel,
        proxy   => $pxy,
        prefix  => $pre,
        with    => $with
    }
}

#
# convert parser output to dependency records
#
sub depend_list ($) {
    my($deps) = @_;
    foreach (@$deps) {
        $_ = parse_depends($_);
    }
    return $deps;
}

#
# compute list of package names from dependency list
#
sub depends2pkglist ($) {
    my($deps) = @_;
    return map { $_->{name} } @$deps;
}

#
# retrieve the local installed base
#
# for packages that provide option resources (packagename::buildoption)
# the options are parsed into the OPTIONS hash
#
# other packages will query options on demand
#
sub get_installed () {
    my(%map);
    my(@l) = `$RPM_NPRIV --provides -qa`;
    my($p);
    my($nam,$val,%options);

    foreach (@l) {
        $p = parse_provides($_);

        if (defined $p->{with}) {
            $options{$p->{prefix}}->{$p->{with}} = $p->{version}
        }

        push @{$map{$p->{name}}->{"$p->{version}-$p->{release}"}}, {
            name       => $p->{name},
            version    => (defined $p->{version} ? $p->{version} : '*'),
            release    => (defined $p->{release} ? $p->{release} : '*'),
            PROXY      => $p->{proxy}
        };
    }

    #
    # options are provided for a package
    # apply them to all instances of the package
    #
    foreach $nam (keys %options) {
        foreach $val (keys %{$map{$nam}}) {
            foreach (@{$map{$nam}->{$val}}) {
                $_->{OPTIONS} = $options{$nam};
            }
        }
    }

    return \%map;
}

#
# compute reverse dependency map
#
#
sub get_revdep ($) {
    my($env) = @_;
    my($i) = $env->{'installed'};
    my($r) = $env->{'repository'};
    my($pkg, %dep, %dlist, %rev);
    my(@vers,$t);

    print "# computing reverse dependencies\n";

    foreach $pkg (keys %$i) {

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

        #
        # get list of package versions from repository
        #
        @vers = get_versions($r->{$pkg}, sub { 1; });

        #
        # get forward dependencies from repository packages
        #
        # dep{a}{b} is true if b depends directly on a
        # dlist{a}  is list of packages that depend on a
        #
        foreach (@vers) {
            foreach $t (@{$r->{$pkg}->{$_}}) {
                next unless $i->{$t->{name}};
                next unless $t->{depends};
                foreach (depends2pkglist($t->{depends})) {
                    $dep{$_}{$t->{name}} = 1;
                    push @{$dlist{$_}}, $t;
                }
            }
        }
    }

    #
    # sort reverse dependencies
    #
    foreach $pkg (keys %dep) {
        $rev{$pkg} = [
            sort {
                $dep{$a->{name}}{$b->{name}} ||
                -$dep{$b->{name}}{$a->{name}} ||
                $a->{name} cmp $b->{name}
            } @{$dlist{$pkg}}
        ];
    }

    return \%rev;
}

#
# parse option from rpm output
#
sub parse_options ($) {
    my($l) = @_;
    $l = join("\n", @$l) if ref $l;
    return if ($l !~ m/(--define|\%option\s+)/s);
    my $with = {};
    $l =~ s/--define\s*'(\S+)\s+(\S+?)'/$with->{$1} = $2, ''/sge; # before openpkg-20021230
    $l =~ s/\%option\s+(\S+)\s+(\S+)/$with->{$1} = $2, ''/sge;     # after  openpkg-20021230
    return $with;
}

#
# copy options from new to old
# where option already exists in old or option key
# matches regular expression
#
sub override_options ($$$) {
    my($old, $new, $reg) = @_;

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

#
# pull in OPTIONS for a package or an RPM file
#
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};
}

#
# compute absolute paths
#
# (url, fn) point to a base document
# the location is the file path fn if fn is
# defined, otherwise it is url.
#
# augment the pointer with suburl
#
# suburl can be an absolute url
# then the new pointer is (suburl, undef)
#
# suburl can be a absolute file path
# then the new pointer is (suburl, suburl)
#
# suburl can be a relative path
# then it augments url or fn accordingly
#
sub relurl ($$$) {
    my($url,$fn,$suburl) = @_;
    my($subfn);

    if ($suburl =~ /^\w+:\/\//) {
        # NOP
    } elsif ($suburl =~ /^\//) {
        $subfn = $suburl;
    } else {
        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);
}

#
# return node value from XML parser
#
sub xel($) {
    my($a) = @_;
    my($l) = $a->[0];
    return '' if ref $l;
    return $l;
}

#
# grep XML Bag against condition
# return as flat list
#
sub with_list ($$) {
    my($bags,$with) = @_;
    my($bag,$li,$el);
    my(@out);

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

    return \@out;
}

sub simple_text_parser ($$$$) {
    my($fh,$url,$with,$map) = @_;
    my(@include);

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

    print "# using simple text parser\n";

    while (<$fh>) {

        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 = ();
            @source    = ();
            @nosource  = ();
        }

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

        next unless defined $href;

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

        $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 'NoSource') {
            $section = 'nosource' if $useit;
        } elsif ($tag eq '/NoSource') {
            $section = undef;
        } elsif ($tag eq 'Source') {
            $section = 'source' if $useit;
        } elsif ($tag eq '/Source') {
            $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' || $tag eq 'resource') {
            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 ($section eq 'source') {
                push(@source, $body);
            } elsif ($section eq 'nosource') {
                push(@nosource, $body);
            }
        } elsif ($tag eq '/rdf:Description') {

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

                @provides = map {
                    depends2provides(parse_depends($_))
                } @provides;

                %options = map {
                    ( $_->{with} => $_->{version} )
                } grep {
                    defined $_->{with}
                } @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   => depend_list([ @bprereq ]),
                    keeps     => depend_list([ @prereq ]),
                    conflicts => [ @conflicts ],
                    source    => [ @source ],
                    nosource  => [ @nosource ],
                    desc      => $desc,
                    platform  => $platform,
                    prefix    => $prefix
                };

                $rec->{OPTIONS} =
                    %options
                    ? { %options }
                    : parse_options($rec->{desc});

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

            $href = undef;
        }
    }

    return \@include;
}

sub xml_parser ($$$$) {
    my($fh, $url, $with, $map) = @_;
    my(@include);

    my($xml,$desc,$sub);
    my($provides,@provides,%options,$rec);
    my($href,$name,$version,$release);

    print "# using XML parser\n";

    $xml  = XML::Simple::XMLin($fh, forcearray => 1);
    $desc = $xml->{'Repository'}->[0]->{'rdf:Description'};
    $sub  = $xml->{'Repository'}->[0]->{'Repository'};

    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];
        if ($provides->{'rdf:li'}) {
            $provides = $provides->{'rdf:li'};
        } else {
            $provides = $provides->{'resource'};
        }
        @provides = map {
            depends2provides(parse_depends($_))
        } @$provides;

        %options = map {
            ( $_->{with} => $_->{version} )
        } grep {
            defined $_->{with}
        } @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   => depend_list(with_list($_->{'BuildPreReq'}, $with)),
            keeps     => depend_list(with_list($_->{'PreReq'}, $with)),
            conflicts => with_list($_->{'Conflicts'}, $with),
            source    => with_list($_->{'Source'}, $with),
            nosource  => with_list($_->{'NoSource'}, $with),
            desc      => xel($_->{'Description'})
        };

        $rec->{OPTIONS} =
            %options
            ? { %options }
            : parse_options($rec->{desc});

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

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

    return \@include;
}

sub open_index ($$) {
    my($url, $fn) = @_;
    my($fetch,$bzip2,$path);

    $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";
}

#
# fetch index from file or URL
# recursively fetch sub-indexes
#
sub get_index ($$$$) {
    my($url,$fn,$with,$noxml) = @_;
    my(%map,$include);

    open_index($url,$fn);

    unless ($noxml) {
        eval {
            require XML::Simple;
        };
        $noxml = 1 if $@;
    }

    if ($noxml) {
        $include = simple_text_parser(\*RFH, $url, $with, \%map);
    } else {
        $include = xml_parser(\*RFH, $url, $with, \%map);
    }

    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,$noxml);
        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 $_->{'prefix'})
                ) : (
                    !(defined $_->{'prefix'}) || (
                       defined $_->{'platform'} &&
                       $_->{'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};
}

#
# strip doubles from depend/keep lists
# and a return a map name => depend/keep
#
sub unique_map {
    my(%out);
    foreach (@_) {
        foreach (@$_) {
            $out{$_->{name}} = $_;
        }
    }
    return %out;
}

#
# 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";
        }
    }
}

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

#
# LOGIC
#

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

    ($name, $op, $version) = ($dep->{name}, $dep->{op}, $dep->{val});

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

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

    if (!defined $op) {
        $cond = sub { 1; };
    } elsif ($op eq 'geq') {
        $cond = sub { vcmp($_[0],$version) >= 0; };
    } elsif ($op eq 'leq') {
        $cond = sub { vcmp($_[0],$version) <= 0; };
    } elsif ($op eq 'gt') {
        $cond = sub { vcmp($_[0],$version) > 0; };
    } elsif ($op eq 'lt') {
        $cond = sub { vcmp($_[0],$version) < 0; };
    } elsif ($op eq 'equ') {
        $cond = sub { vcmp($_[0],$version) == 0; };
    } else {
        die "FATAL: internal error in dep2target\n";
    }

    $tdef = undef;

    if ($i && (@vers = get_versions($i, $cond))) {
        foreach (@vers) {
            $t = $i->{$_}->[0];
            get_with($t);
            if (target_suitable($t, $env->{with})) {
                $tdef = $t;
                unless ($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) {
        if (!$tdef ||
            ($env->{upgrade} && target_newer($t, $env->{installed}))) {
            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;
        }
        # pull in options
        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(get_with($target), get_with($t),
                         $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 = unique_map($d, $k);
        %k = unique_map($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($d{$_}, $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);

    foreach (@{$target->{nosource}}) {
        print "# ATTENTION: unpackaged source $_: $target->{source}->[$_]\n";
    }

    #
    # a dependency could not be resolved, don't bother with reverse
    # dependencies for this 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);
        }
    }
}

#
# generate build lists for targets matched by pattern
#
# all input and output is passed in 'env' hash
#
sub build_list ($$) {
    my($pattern, $env) = @_;
    my(@goals,@targets,@keeps,@conflicts,@bonly,$t);
    my($name,$r,$i,@vers);
    my(@todo,%keep);

    #
    # handle various patterns
    #
    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 {
        #
        # undefined pattern means -a option that selects
        # all packages from repository that are installed
        #
        @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);
    }

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

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

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

#
# OUTPUT
#

#
# compute path to binary RPM from rpm config and target data
#
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;
}

#
# compute new target based on old target augmented with options from
# a binary RPM file
#
sub binary_target ($$) {
    my($t, $fn) = @_;
    my(%target) = %$t;

    # pull in options from binary RPM file
    get_with(\%target, $fn);

    return \%target;
}

#
# return path to master package for a proxy package
#
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];
}

#
# merge parameters from installed package
# with new parameter set and global parameters
# from configuration
#
# then map the result to --define command line arguments
# suitable for rpm
#
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->{$_}'" }
                     sort grep { $old->{$_} !~ /^%/ } keys %$old);

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

    return $with;
}

#
# print commands from package build list
#
# c      -> configuration to derive paths from
# uncond -> always do the --rebuild
# with   -> parameter set passed to build tool
# ignore -> generate script that does not stop on error
#
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 $_->{prefix}) {
                $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";
    }
}

#
# print commands for the temporary package list
#
# temporary packages are only used for building other packages
# and are removed when everything is done
#
sub print_list2 ($$) {
    my($list,$c) = @_;
    my($pkg);

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

#
# instead of printing a command list, print a status map
# that shows all packages and how the build process would
# change their status
#
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) {
        next unless defined $_->{release};
        $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 $n =~ /::/;
        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 $n =~ /::/;
        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,$opt_X);

$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);
}