You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
1291 lines
34 KiB
1291 lines
34 KiB
## |
|
## openpkg-build -- 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/; |
|
getopts('R:r:f:uUaAzZP:N:E:iD:p:q'); |
|
|
|
########################################################################## |
|
|
|
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] [-uUzZiq] [-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'; |
|
} |
|
} |
|
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'} || '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); |
|
|
|
$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]/; |
|
|
|
return { |
|
rpmdir => $q[0], |
|
template => $q[1], |
|
platform => $q[4], |
|
prefix => $q[5] |
|
}; |
|
} |
|
|
|
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+))?$/; |
|
push(@{$map{$1}->{"$2-$3"}}, { |
|
name => $1, |
|
version => (defined $2 ? $2 : '*'), |
|
release => (defined $3 ? $3 : '*') |
|
}); |
|
} |
|
|
|
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 = [ split(/\n+/, $l) ] unless ref $l; |
|
my(%with) = map { /--define\s*'(\S+)\s+(\S+?)'/ } @$l; |
|
return unless %with; |
|
return \%with; |
|
} |
|
|
|
sub override_options ($$) { |
|
my($old, $new) = @_; |
|
while (my ($k,$v) = each %$new) { |
|
$old->{$k} = $v if exists $old->{$k}; |
|
} |
|
} |
|
|
|
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/>/>/g; |
|
s/</</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 => |
|
( $_->{'BuildPreReq'}->[0]->{'rdf:bag'}->[0]->{'rdf:li'} |
|
|| [] ), |
|
keeps => |
|
( $_->{'PreReq'}->[0]->{'rdf:bag'}->[0]->{'rdf:li'} |
|
|| [] ), |
|
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++; |
|
} |
|
die "ERROR: ambigous dependency\n"; |
|
|
|
} 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; |
|
} |
|
|
|
# |
|
# report options that are not used for |
|
# |
|
sub warn_about_options ($$) { |
|
my($target, $with) = @_; |
|
my($iwith) = $target->{OPTIONS}; |
|
my($k,$v); |
|
|
|
return unless defined $iwith; |
|
while (($k,$v) = each %$with) { |
|
if (!exists $iwith->{$k}) { |
|
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); |
|
|
|
$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 { |
|
die "FATAL: don't know how to handle PreReq: $name $dep\n"; |
|
} |
|
|
|
if ($i && (@vers = get_versions($i, $cond))) { |
|
foreach (@vers) { |
|
$t = $i->{$_}->[0]; |
|
if (get_with($t), target_suitable($t, $env->{with})) { |
|
if (!$env->{upgrade}) { |
|
return ($t, 1); |
|
} |
|
} |
|
} |
|
} |
|
if ($b && (@vers = get_versions($b, $cond))) { |
|
return ($b->{$vers[0]}->[0], 1); |
|
} |
|
|
|
return (chose_source($env, $name, $r, get_versions($r, $cond)), 0); |
|
} |
|
|
|
|
|
sub make_dep ($$$$$) { |
|
my($target,$depth,$env,$list,$blist) = @_; |
|
my($d,$k,%d,%k,$t,$old); |
|
|
|
if (target_exists($target, $env->{built})) { |
|
print "# $target->{name} is already in list\n"; |
|
return; |
|
} |
|
|
|
if ($t = target_conflicts($target, $env->{installed})) { |
|
print "# $target->{name} conflicts with ",vsn($t),"\n"; |
|
return; |
|
} |
|
|
|
if ($t = target_conflicts($target, $env->{built})) { |
|
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}) { |
|
print "# rebuilding $target->{name} (dependency)\n"; |
|
} elsif ($env->{zero}) { |
|
print "# rebuilding $target->{name} (zero)\n"; |
|
} elsif ($env->{upgrade} && target_newer($target, $env->{installed})) { |
|
print "# rebuilding $target->{name} (upgrade)\n"; |
|
} elsif (!target_suitable($t, $env->{with})) { |
|
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}); |
|
$target->{REBUILD} = 1; |
|
} |
|
|
|
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; |
|
|
|
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"; |
|
} |
|
make_dep($t,$depth+1,$env,$list,$blist); |
|
} else { |
|
die "FATAL: $target->{name} searches for a frood called '$_'\n"; |
|
} |
|
} |
|
} |
|
|
|
print "# adding ".vsn($target)." to list\n"; |
|
push(@$list, $target); |
|
|
|
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); |
|
} |
|
} |
|
} |
|
|
|
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,$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($_).'$'; |
|
} |
|
} |
|
$pattern = join('|',@todo); |
|
@todo = grep(/$pattern/, keys %{$env->{repository}}); |
|
} 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); |
|
} |
|
} |
|
|
|
die "FATAL: no known source found for '$name'\n" unless $t; |
|
|
|
warn_about_options($t, $env->{with}); |
|
push(@goals, $t); |
|
} |
|
return unless @goals; |
|
|
|
@targets = (); |
|
@keeps = @goals; |
|
foreach $t (@goals) { |
|
print "# recursing over dependencies for ".vsn($t)."\n"; |
|
make_dep($t,0,$env,\@targets,\@keeps); |
|
} |
|
|
|
$bonly = remove_list(\@targets, \@keeps, $env->{installed}); |
|
|
|
return (\@targets, $bonly); |
|
} |
|
|
|
####################################################################### |
|
|
|
sub target2rpm ($$) { |
|
my($target,$c) = @_; |
|
my($tmpl) = $c->{template}; |
|
|
|
$tmpl =~ s/%{NAME}/$target->{name}/; |
|
$tmpl =~ s/%{VERSION}/$target->{version}/; |
|
$tmpl =~ s/%{RELEASE}/$target->{release}/; |
|
|
|
return $c->{rpmdir}.'/'.$tmpl; |
|
} |
|
|
|
####################################################################### |
|
|
|
sub binary_target ($$) { |
|
my($t, $fn) = @_; |
|
my(%target) = %$t; |
|
|
|
get_with(\%target, $fn); |
|
|
|
return \%target; |
|
} |
|
|
|
sub make_defines ($$) { |
|
my($old, $new) = @_; |
|
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); |
|
} 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); |
|
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); |
|
|
|
# |
|
# someone preferred a binary from the repository |
|
# just copy it to the local store |
|
# |
|
if (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"; |
|
} |
|
} |
|
|
|
####################################################################### |
|
|
|
my($config,$url,$repository,$installed,$list,$bonly); |
|
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); |
|
|
|
($list,$bonly) = build_list($pattern, { |
|
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, |
|
sourceonly => ( |
|
$opt_u || |
|
$opt_U || |
|
$opt_z || |
|
$opt_Z || |
|
scalar(%with) > 0 ) |
|
}); |
|
|
|
die "FATAL: cannot find package\n" unless defined $list; |
|
|
|
print_list1($list,$config,$opt_a || $opt_u || $opt_U,\%with,$opt_i); |
|
print_list2($bonly,$config); |
|
|
|
|