comparison: openpkg/build.pl
openpkg/build.pl
- changeset 514
- b0b94589986b
equal
deleted
inserted
replaced
| -1:000000000000 | 0:be620b0216d5 |
|---|---|
| 1 ## | |
| 2 ## build.pl -- OpenPKG Package Building and Installing | |
| 3 ## Copyright (c) 2000-2012 OpenPKG GmbH <http://openpkg.com/> | |
| 4 ## | |
| 5 ## This software is property of the OpenPKG GmbH, DE MUC HRB 160208. | |
| 6 ## All rights reserved. Licenses which grant limited permission to use, | |
| 7 ## copy, modify and distribute this software are available from the | |
| 8 ## OpenPKG GmbH. | |
| 9 ## | |
| 10 ## THIS SOFTWARE IS PROVIDED "AS IS" AND ANY EXPRESSED OR IMPLIED | |
| 11 ## WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF | |
| 12 ## MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. | |
| 13 ## IN NO EVENT SHALL THE AUTHORS AND COPYRIGHT HOLDERS AND THEIR | |
| 14 ## CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, | |
| 15 ## SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT | |
| 16 ## LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF | |
| 17 ## USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND | |
| 18 ## ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, | |
| 19 ## OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT | |
| 20 ## OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF | |
| 21 ## SUCH DAMAGE. | |
| 22 ## | |
| 23 | |
| 24 ############################################################################# | |
| 25 ## | |
| 26 ## MAIN PROCEDURE | |
| 27 ## | |
| 28 ############################################################################# | |
| 29 | |
| 30 require 5; | |
| 31 #use strict; | |
| 32 my ( | |
| 33 $opt_h, | |
| 34 $opt_R, $opt_r, $opt_f, $opt_u, $opt_U, $opt_a, $opt_A, | |
| 35 $opt_z, $opt_Z, $opt_P, $opt_N, $opt_E, $opt_H, $opt_i, | |
| 36 $opt_D, $opt_p, $opt_q, $opt_s, $opt_S, $opt_X, $opt_M, | |
| 37 $opt_L, $opt_W, $opt_K, $opt_e, $opt_b, $opt_B, $opt_g, | |
| 38 $opt_k | |
| 39 ); | |
| 40 | |
| 41 # global context variables | |
| 42 my $prg = "openpkg build"; | |
| 43 my %env = ('' => {}); | |
| 44 | |
| 45 ## | |
| 46 ## OPTION PARSING | |
| 47 ## | |
| 48 | |
| 49 # parse command line options | |
| 50 my $getopts = 'hR:r:f:uUaAzZP:N:E:H:iD:p:qsSXMLWKebBgk'; | |
| 51 getopts($getopts); | |
| 52 | |
| 53 # parse configuration script options | |
| 54 if (open(FH, "<$ENV{'HOME'}/.openpkg/build")) { | |
| 55 my ($env) = $env{''}; | |
| 56 my ($go) = $getopts; | |
| 57 $go =~ s/[^a-zA-Z]//g; | |
| 58 while (my $line = <FH>) { | |
| 59 if ($line =~ m/^\s*\[([^\]]*)\]/) { | |
| 60 $env{$1} = {} unless ($env{$1}); | |
| 61 $env = $env{$1}; | |
| 62 } elsif (my ($opt, $val) = ($line =~ m/^\-([$go])\s*(.*?)\s*$/)) { | |
| 63 $val = 1 unless (defined($val)); | |
| 64 if (exists($env->{$opt})) { | |
| 65 $env->{$opt} .= " " . $val; | |
| 66 } else { | |
| 67 $env->{$opt} = $val; | |
| 68 } | |
| 69 } | |
| 70 } | |
| 71 close(FH); | |
| 72 } | |
| 73 | |
| 74 # usage sanity check and usage help | |
| 75 sub usage { | |
| 76 my ($rc) = @_; | |
| 77 my $usage = | |
| 78 "openpkg:build:USAGE: $prg [options] [pattern ...]\n" . | |
| 79 " -a operate on all installed packages\n" . | |
| 80 " -A operate on all repository packages\n" . | |
| 81 " -R <rpm> path to \"openpkg rpm\" command\n" . | |
| 82 " -r <repository> URL to package repository directory\n" . | |
| 83 " -f <index.rdf> URL to package repository index file\n" . | |
| 84 " -u ignore local binary RPMs\n" . | |
| 85 " -U upgrade all selected packages including dependencies\n" . | |
| 86 " -z rebuild from zero all selected installed packages\n" . | |
| 87 " -Z rebuild from zero all selected available packages\n" . | |
| 88 " -i ignore errors in the generated script\n" . | |
| 89 " -q ignore all reverse dependencies\n" . | |
| 90 " -s generate status map instead of shell script\n" . | |
| 91 " -S generate status map instead of shell script (including new)\n" . | |
| 92 " -X use external XML/RDF parser instead of internal one\n" . | |
| 93 " -M generate short dependency map instead of shell script\n" . | |
| 94 " -L generate list of packages in repository depending on target\n" . | |
| 95 " -W include dependencies as if all build options are enabled\n" . | |
| 96 " -K keep temporarily installed packages\n" . | |
| 97 " -k keep temporarily downloaded packages\n" . | |
| 98 " -e rebuild exact version of a package from repository\n" . | |
| 99 " -b build-time check existing binaries for dependencies only\n" . | |
| 100 " -B build-time check existing binaries for dependencies and target\n" . | |
| 101 " -g rebuild packages even when most recent version is installed\n" . | |
| 102 " -P <priv-cmd> command prefix for privileged commands\n" . | |
| 103 " -N <non-priv-cmd> command prefix for non-privileged commands\n" . | |
| 104 " -p <platform> match platform against repository index for binary packages\n" . | |
| 105 " -E <name> exclude package\n" . | |
| 106 " -H <name> hint about packages to resolve ambiquity\n" . | |
| 107 " -D <name>[=<val>] set build option for packages\n"; | |
| 108 if ($rc == 0) { | |
| 109 print STDOUT $usage; | |
| 110 } | |
| 111 else { | |
| 112 print STDERR $usage; | |
| 113 } | |
| 114 exit($rc); | |
| 115 } | |
| 116 if ($opt_h) { | |
| 117 usage(0); | |
| 118 } | |
| 119 if (not ( ($#ARGV >= 0 && !($opt_a || $opt_A)) | |
| 120 || ($#ARGV == -1 && ($opt_a || $opt_A)))) { | |
| 121 usage(1); | |
| 122 }; | |
| 123 | |
| 124 # determine RPM run-time information | |
| 125 my $config = rpm_runtime_info(); | |
| 126 | |
| 127 # override command line options with configuration script options | |
| 128 # now that the effectively used OpenPKG RPM command is known | |
| 129 foreach my $env (sort { $a cmp $b } grep { | |
| 130 $config->{"rpm"} =~ m/^\Q$_\E/ # compatibility | |
| 131 or $config->{"prefix"} =~ m/^\Q$_\E/ # regular | |
| 132 } keys %env) { | |
| 133 while (my ($opt, $val) = each(%{$env{$env}})) { | |
| 134 eval "\$opt_$opt = '$val' unless defined \$opt_$opt;"; | |
| 135 } | |
| 136 } | |
| 137 | |
| 138 ## | |
| 139 ## OPTION POST-PROCESSING | |
| 140 ## | |
| 141 | |
| 142 my ($url, $repository, $installed, $env, $list, $bonly, $clist); | |
| 143 my ($pattern, %with, %exclude, %hint); | |
| 144 | |
| 145 # determine package goal pattern | |
| 146 if ($opt_a) { | |
| 147 $pattern = undef; | |
| 148 } else { | |
| 149 $pattern = join(' ', @ARGV); | |
| 150 } | |
| 151 if ($opt_A) { | |
| 152 $pattern = '*'; | |
| 153 } | |
| 154 | |
| 155 # parse build options | |
| 156 %with = map { | |
| 157 m/([^\s=]+)(?:\=(\S+))?/ | |
| 158 ? ($1 => (defined($2) ? $2 : 'yes')) | |
| 159 : () | |
| 160 } split(/\s+/, $opt_D); | |
| 161 | |
| 162 # split accumulated option values | |
| 163 %exclude = map { $_ => 1 } split(/\s+/, $opt_E); | |
| 164 %hint = map { $_ => 1 } split(/\s+/, $opt_H); | |
| 165 | |
| 166 if (defined($opt_p)) { | |
| 167 $config->{platform} = $opt_p; | |
| 168 } | |
| 169 | |
| 170 # determine RPM package repository information | |
| 171 if (defined $opt_r) { | |
| 172 $url = $opt_r; | |
| 173 $url .= '/' unless $url =~ m/\/$/; | |
| 174 } else { | |
| 175 $url = rpm_release_url(); | |
| 176 } | |
| 177 # if we read the index from a file we can no longer deduce | |
| 178 # repository paths from index paths. For now lets assume | |
| 179 # that everything is below SRC/ to be compatible with | |
| 180 # existing file indexes. | |
| 181 if (defined($opt_f) and not defined($opt_r)) { | |
| 182 $url .= 'SRC/'; | |
| 183 } | |
| 184 | |
| 185 # determine information about INSTALLED packages (virtual and regular), | |
| 186 # including their options, provides and requirements | |
| 187 my $installed = get_installed(); | |
| 188 | |
| 189 # SPECIAL CASE post-processing for | |
| 190 # -Z (ignore installed packages) | |
| 191 # -a (operate for all installed packages) | |
| 192 if ($opt_a and $opt_Z) { | |
| 193 # This allows one to correctly upgrade an existing OpenPKG | |
| 194 # instance to a newer major version by querying all installed | |
| 195 # packages and their options (-a) but then ignore them (-Z) during | |
| 196 # the later processing and instead perform more or less a fresh | |
| 197 # rebuild from scratch. This ensures that during the process the | |
| 198 # installed packages are effectively picked up as dependencies | |
| 199 # only after they in turn were already updated. | |
| 200 foreach my $package (keys(%{$installed})) { | |
| 201 next if ($package =~ m/::/); | |
| 202 if (exists($installed->{$package}->{""})) { | |
| 203 # virtual package | |
| 204 $hint{$installed->{$package}->{""}->[0]->{"name"}} = 1 | |
| 205 if (exists($installed->{$package}->{""}->[0]->{"name"})); | |
| 206 } | |
| 207 else { | |
| 208 # regular package | |
| 209 $pattern .= " $package"; | |
| 210 foreach my $version (keys(%{$installed->{$package}})) { | |
| 211 foreach my $rec (@{$installed->{$package}->{$version}}) { | |
| 212 if (defined($rec->{"OPTIONS"})) { | |
| 213 my $options = $rec->{"OPTIONS"}; | |
| 214 foreach my $option (keys(%{$options})) { | |
| 215 $with{$package."::".$option} = $options->{$option}; | |
| 216 } | |
| 217 } | |
| 218 } | |
| 219 } | |
| 220 } | |
| 221 } | |
| 222 } | |
| 223 if ($opt_Z) { | |
| 224 $installed = {}; | |
| 225 } | |
| 226 | |
| 227 # determine information about AVAILABLE packages | |
| 228 # by fetching and parsing a package repository XML/RDF index | |
| 229 $repository = get_index( | |
| 230 $url . '00INDEX.rdf', | |
| 231 $opt_f, | |
| 232 $opt_X, | |
| 233 $config->{platform}, | |
| 234 $installed | |
| 235 ); | |
| 236 | |
| 237 # assemble together all determined environment information | |
| 238 $env = { | |
| 239 config => $config, | |
| 240 installed => $installed, | |
| 241 repository => $repository, | |
| 242 built => {}, | |
| 243 revdep => undef, | |
| 244 with => \%with, | |
| 245 exclude => \%exclude, | |
| 246 hint => \%hint, | |
| 247 upgrade => ($opt_a || $opt_U), | |
| 248 zero => ($opt_z || $opt_Z), | |
| 249 exact => $opt_e, | |
| 250 quick => ($opt_q || $opt_z || $opt_Z), | |
| 251 status => ($opt_s || $opt_S), | |
| 252 fatal => [], | |
| 253 goals => $opt_g, | |
| 254 sourceonly => ($opt_u || $opt_U || $opt_z || $opt_Z) | |
| 255 }; | |
| 256 | |
| 257 ## | |
| 258 ## PERFORM REQUESTED OPERATION | |
| 259 ## | |
| 260 | |
| 261 if ($opt_L) { | |
| 262 # case 1: calculate dependencies only and | |
| 263 # print packages depending on target | |
| 264 ($list) = build_deps($pattern, $env); | |
| 265 print_deps($list); | |
| 266 } else { | |
| 267 # case 2: calculate build commands and | |
| 268 # print results in different formats | |
| 269 ($list, $bonly, $clist) = build_list($pattern, $env); | |
| 270 die "openpkg:build:FATAL: cannot find package\n" if (not defined($list)); | |
| 271 if ($opt_M) { | |
| 272 print_map($installed, $repository, $list, $bonly, $clist); | |
| 273 } elsif ($opt_S) { | |
| 274 print_status($installed, $repository, $list, $bonly, $clist); | |
| 275 } elsif ($opt_s) { | |
| 276 print_status($installed, {}, $list, $bonly, $clist); | |
| 277 } else { | |
| 278 if (@{$env->{fatal}}) { | |
| 279 die "openpkg:build:FATAL: errors occured while building:\n", @{$env->{fatal}}, "\n"; | |
| 280 } | |
| 281 print_list1($list, $config, $opt_a || $opt_u || $opt_U, $env->{with}, $opt_i, $opt_b, $opt_B); | |
| 282 print_list2($bonly, $config) if (not $opt_K); | |
| 283 } | |
| 284 } | |
| 285 | |
| 286 # die gracefully | |
| 287 exit(0); | |
| 288 | |
| 289 ############################################################################# | |
| 290 ## | |
| 291 ## FUNCTIONS: PARSING & RUN-TIME INFORMATION | |
| 292 ## | |
| 293 ############################################################################# | |
| 294 | |
| 295 # home-brewn getopt(3) style option parser | |
| 296 sub getopts ($) { | |
| 297 my ($opts) = @_; | |
| 298 my (%optf) = map { m/(\w)/; $1 => $_ } $opts =~ m/(\w:|\w)/g; | |
| 299 my (%opts, @argv, $optarg); | |
| 300 | |
| 301 foreach (@ARGV) { | |
| 302 if (@argv) { | |
| 303 push @argv, $_; | |
| 304 } elsif (defined $optarg) { | |
| 305 if (exists $opts{$optarg}) { | |
| 306 $opts{$optarg} .= " $_"; | |
| 307 } else { | |
| 308 $opts{$optarg} = $_; | |
| 309 } | |
| 310 $optarg = undef; | |
| 311 } elsif (!/^[-]/) { | |
| 312 push @argv, $_; | |
| 313 } else { | |
| 314 while (/^\-(\w)(.*)/) { | |
| 315 if (exists $optf{$1}) { | |
| 316 if (length($optf{$1}) > 1) { | |
| 317 if ($2 ne '') { | |
| 318 if (exists $opts{$1}) { | |
| 319 $opts{$1} .= " $2"; | |
| 320 } else { | |
| 321 $opts{$1} = $2; | |
| 322 } | |
| 323 } else { | |
| 324 $optarg = $1; | |
| 325 } | |
| 326 last; | |
| 327 } else { | |
| 328 $opts{$1} = 1; | |
| 329 } | |
| 330 } else { | |
| 331 warn "openpkg:build:WARNING: unknown option $_\n"; | |
| 332 } | |
| 333 $_ = "-$2"; | |
| 334 } | |
| 335 } | |
| 336 } | |
| 337 if (defined $optarg) { | |
| 338 warn "openpkg:build:WARNING: option $optarg requires an argument\n"; | |
| 339 } | |
| 340 foreach (keys %opts) { | |
| 341 eval '$opt_'.$_.' = "'.quotemeta($opts{$_}).'";'; | |
| 342 } | |
| 343 @ARGV = @argv; | |
| 344 } | |
| 345 | |
| 346 # determine RPM run-time information | |
| 347 sub rpm_runtime_info () { | |
| 348 # determine OpenPKG instance prefix via | |
| 349 # 1. the environment of the "openpkg build" framework | |
| 350 # 2. the installation path of the script | |
| 351 # 3. the installation path of the Perl interpreter | |
| 352 # 4. the path of the "openpkg" command in $PATH | |
| 353 my $l_prefix = $ENV{'OPENPKG_PREFIX'}; | |
| 354 if (not $l_prefix) { | |
| 355 ($l_prefix) = ($0 =~ m/^(.+)\/lib(exec)?\/openpkg(-tools)?\/build(\.pl)?$/); | |
| 356 } | |
| 357 if (not $l_prefix) { | |
| 358 ($l_prefix) = ($^X =~ m/^(.+)\/bin\/perl.*$/); | |
| 359 } | |
| 360 if (not $l_prefix) { | |
| 361 $l_prefix = (`(which openpkg) 2>/dev/null` =~ m/^(.+)\/bin\/openpkg$/); | |
| 362 } | |
| 363 if (not -x "$l_prefix/bin/openpkg") { | |
| 364 die "openpkg:build:FATAL: cannot determine OpenPKG instance prefix"; | |
| 365 } | |
| 366 print "# operating with OpenPKG instance $l_prefix\n"; | |
| 367 | |
| 368 # determine OpenPKG RPM command | |
| 369 my $rpm = $opt_R || $env{''}->{'R'} || | |
| 370 ((-f "$l_prefix/bin/openpkg" && -f "$l_prefix/libexec/openpkg/rpm") ? | |
| 371 "$l_prefix/bin/openpkg rpm" : "$l_prefix/bin/rpm"); | |
| 372 $rpm = (`(which $rpm) 2>/dev/null` =~ m{^(/.*)})[0] if ($rpm !~ m|^/|); | |
| 373 die "openpkg:build:FATAL: cannot locate OpenPKG RPM in path" unless ($rpm =~ m{^/}); | |
| 374 print "# operating with OpenPKG RPM $rpm\n"; | |
| 375 | |
| 376 # determine additional tools | |
| 377 my $mkp = "$l_prefix/bin/openpkg makeproxy"; | |
| 378 my $rel = "$l_prefix/bin/openpkg release"; | |
| 379 my $bzip2 = $rpm; | |
| 380 $bzip2 =~ s/\/bin\/openpkg rpm$/\/lib\/openpkg\/bzip2/; | |
| 381 my $curl = $rpm; | |
| 382 $curl =~ s/\/bin\/openpkg rpm$/\/lib\/openpkg\/curl/; | |
| 383 $curl = "$l_prefix/bin/openpkg curl" if (system("$l_prefix/bin/openpkg curl file://$l_prefix/etc/openpkg/platform >/dev/null 2>&1") == 0); | |
| 384 | |
| 385 # expand RPM macros holding information | |
| 386 my $c = run("$rpm --eval '%{_rpmdir} %{_rpmfilename} %{_target_os} %{_target_cpu} %{_srcrpmdir}'"); | |
| 387 | |
| 388 # parse and post-process information | |
| 389 chomp($c); | |
| 390 my (@q) = split(/\s+/, $c); | |
| 391 $q[1] =~ s/%{OS}/$q[2]/; | |
| 392 $q[1] =~ s/%{ARCH}/$q[3]/; | |
| 393 | |
| 394 # expand RPM rc information about tools | |
| 395 $c = run("$rpm --showrc"); | |
| 396 my @g = ($c =~ m/\%\{l_tool_locate\s+([^\s\}]+)/g); | |
| 397 | |
| 398 # return accumulated information | |
| 399 return { | |
| 400 rpm => $rpm, | |
| 401 mkp => $mkp, | |
| 402 rel => $rel, | |
| 403 bzip2 => $bzip2, | |
| 404 curl => $curl, | |
| 405 rpmdir => $q[0], | |
| 406 srcrpmdir=> $q[4], | |
| 407 template => $q[1], | |
| 408 platform => '', | |
| 409 prefix => $l_prefix, | |
| 410 optreg => '(?:'. join('|', map { "\Quse_$_\E" } @g) .')' | |
| 411 }; | |
| 412 } | |
| 413 | |
| 414 # determine RPM release URL | |
| 415 sub rpm_release_url ($$) { | |
| 416 my ($rel, $url); | |
| 417 | |
| 418 # determine the release URL the newer way | |
| 419 $url = run("(".$config->{"rel"}." --fmt='%u') 2>/dev/null || true") || ""; | |
| 420 $url =~ s/^\s+//s; | |
| 421 $url =~ s/\s+$//s; | |
| 422 | |
| 423 # use a local jumpstart RDF | |
| 424 if (-f $config->{"prefix"}."/etc/openpkg/build.rdf") { | |
| 425 $url = "file://".$config->{"prefix"}."/etc/openpkg/build.rdf" | |
| 426 } | |
| 427 | |
| 428 return $url; | |
| 429 } | |
| 430 | |
| 431 ############################################################################# | |
| 432 ## | |
| 433 ## FUNCTIONS: VERSION STRING HANDLING | |
| 434 ## | |
| 435 ############################################################################# | |
| 436 | |
| 437 # compare two package versions | |
| 438 # - "openpkg rpm": | |
| 439 # splits according to !isalnum(3) ([a-zA-Z0-9]) | |
| 440 # and between isdigit(3) ([0-9]) and isalpha(3) ([a-zA-Z]) | |
| 441 # - "openpkg build" (this): | |
| 442 # splits on "." characters | |
| 443 sub vcmp_version ($$) { | |
| 444 my ($a, $b) = @_; | |
| 445 my (@a, @b, $c); | |
| 446 my ($ax, $bx); | |
| 447 | |
| 448 # split according to dots | |
| 449 @a = split(/\./, $a); | |
| 450 @b = split(/\./, $b); | |
| 451 | |
| 452 # compare as long as components exist | |
| 453 while (@a && @b) { | |
| 454 if ($a[0] =~ m/^\d+$/ && $b[0] =~ m/^\d+$/) { | |
| 455 # numerical comparison | |
| 456 $c = $a[0] <=> $b[0]; | |
| 457 } elsif ((($a, $ax) = $a[0] =~ m/^(\d+)(.*)$/) && | |
| 458 (($b, $bx) = $b[0] =~ m/^(\d+)(.*)$/)) { | |
| 459 # numerical comparison for prefix, | |
| 460 # string comparison for remainder | |
| 461 $c = $a <=> $b; | |
| 462 $c = $ax cmp $bx unless ($c); | |
| 463 } else { | |
| 464 # string comparison | |
| 465 $c = $a[0] cmp $b[0]; | |
| 466 } | |
| 467 | |
| 468 # stop comparison if components already mismatched | |
| 469 return $c if ($c != 0); | |
| 470 | |
| 471 # else reduce by one component level | |
| 472 shift(@a); | |
| 473 shift(@b); | |
| 474 } | |
| 475 | |
| 476 # finally compare number of remaining components | |
| 477 # (in case one is more specific) | |
| 478 $c = (scalar(@a) <=> scalar(@b)); | |
| 479 return $c; | |
| 480 } | |
| 481 | |
| 482 # compare two package releases | |
| 483 # - "openpkg rpm": | |
| 484 # uses "vcmp_version" semantics 1:1 again | |
| 485 # - "openpkg build" (this): | |
| 486 # uses "vcmp_version" semantics 1:1 again (>= 20060719) | |
| 487 # trivial string comparison (<= 20060719) | |
| 488 sub vcmp_release ($$) { | |
| 489 my ($a, $b) = @_; | |
| 490 | |
| 491 return vcmp_version($a, $b); | |
| 492 } | |
| 493 | |
| 494 # compare two package "version" or "version-release" strings | |
| 495 # - "openpkg rpm": | |
| 496 # compares "epoch", "version", "release" (in this order) | |
| 497 # - "openpkg build" (this): | |
| 498 # compares "release", "version", (in this order) | |
| 499 sub vcmp ($$) { | |
| 500 my ($a, $b) = @_; | |
| 501 my ($c); | |
| 502 | |
| 503 # short-circuit comparison for simple case | |
| 504 return 0 if ($a eq $b); | |
| 505 | |
| 506 # split into "version" and "release" | |
| 507 my ($av, $ar) = ($a =~ m/^(.*?)(?:\-([\d\.]+))?$/); | |
| 508 my ($bv, $br) = ($b =~ m/^(.*?)(?:\-([\d\.]+))?$/); | |
| 509 | |
| 510 # compare "release" | |
| 511 if (defined($ar) and defined($br)) { | |
| 512 $c = vcmp_release($ar, $br); | |
| 513 return $c if ($c); # short-circuit | |
| 514 } | |
| 515 | |
| 516 # compare "version" | |
| 517 if (defined($av) && defined($bv)) { | |
| 518 $c = vcmp_version($av, $bv); | |
| 519 return $c if ($c); # short-circuit | |
| 520 } | |
| 521 | |
| 522 # equality | |
| 523 return 0; | |
| 524 } | |
| 525 | |
| 526 # create "version" or "version-release" string | |
| 527 # from a provide object (see parse_provides) | |
| 528 sub vs ($) { | |
| 529 my ($t) = @_; | |
| 530 return ( | |
| 531 defined($t->{release}) | |
| 532 ? "$t->{version}-$t->{release}" | |
| 533 : $t->{version} | |
| 534 ); | |
| 535 } | |
| 536 | |
| 537 # create "name-version" or "name-version-release" string | |
| 538 # from a provide object (see parse_provides) | |
| 539 sub vsn ($) { | |
| 540 my ($t) = @_; | |
| 541 return "$t->{name}-".vs($t); | |
| 542 } | |
| 543 | |
| 544 ############################################################################# | |
| 545 ## | |
| 546 ## FUNCTIONS: INSTALLATION INFORMATION | |
| 547 ## | |
| 548 ############################################################################# | |
| 549 | |
| 550 # parse OpenPKG RPM 'provide' string | |
| 551 # "<virtual-name>" (virtual package) | |
| 552 # "<name> = <version>-<release>" (regular package) | |
| 553 # "<name>::<option> = <value>" (regular package build option) | |
| 554 sub parse_provides ($) { | |
| 555 my ($s) = @_; | |
| 556 my ($nam, $val, $pre, $with, $pxy, $ver, $rel); | |
| 557 | |
| 558 ($nam, $val) = ($s =~ m/^([^\s\(]+(?:\([^\)]*\))?)\s*(?:=\s*(\S*?))?$/); | |
| 559 if (($pre, $with) = ($nam =~ m/^(\S+?)::(\S*)$/)) { | |
| 560 # build option | |
| 561 $val =~ s/(?:\%([0-9a-fA-F][0-9a-fA-F]))/chr(hex($1))/eg; # hex decode | |
| 562 ($ver, $rel, $pxy) = ($val, undef, undef); | |
| 563 } else { | |
| 564 # virtual or real package | |
| 565 ($ver, $rel, $pxy) = ($val =~ m/^([^\s\-]+)-([^\s\+]+)(\+PROXY)?$/); | |
| 566 } | |
| 567 | |
| 568 # return accumulated information | |
| 569 return { | |
| 570 name => $nam, # the full name of the resource | |
| 571 version => $ver, # the version (or value) | |
| 572 release => $rel, # and release number (or undef) | |
| 573 proxy => $pxy, # whether the resource is a PROXY resource (or undef) | |
| 574 prefix => $pre, # the packagename (if resource is an option) | |
| 575 with => $with # the buildoption (if resource is an option) | |
| 576 }; | |
| 577 } | |
| 578 | |
| 579 # parse option from RPM 'provides' list | |
| 580 sub parse_provideslist ($) { | |
| 581 my ($l) = @_; | |
| 582 my ($p); | |
| 583 my ($nam, $val, %opts); | |
| 584 | |
| 585 foreach (@$l) { | |
| 586 $p = parse_provides($_); | |
| 587 next if (not (defined $p->{with} && defined $p->{prefix})); | |
| 588 $opts{$p->{with}} = $p->{version}; | |
| 589 } | |
| 590 return \%opts; | |
| 591 } | |
| 592 | |
| 593 # translate dependency object into provides object | |
| 594 sub depends2provides ($) { | |
| 595 my ($dep) = @_; | |
| 596 my ($ver, $rel, $pxy, $pre, $with); | |
| 597 | |
| 598 ($ver, $rel, $pxy) = ($dep->{val} =~ m/^([^\s\-]+)-([^\s\+]+)(\+PROXY)?$/); | |
| 599 ($pre, $with) = ($dep->{name} =~ m/^(\S+?)::(\S*)$/); | |
| 600 | |
| 601 return { | |
| 602 name => $dep->{name}, | |
| 603 version => (defined $ver ? $ver : $dep->{val}), | |
| 604 release => $rel, | |
| 605 proxy => $pxy, | |
| 606 prefix => $pre, | |
| 607 with => $with | |
| 608 } | |
| 609 } | |
| 610 | |
| 611 # parse OpenPKG RPM 'require' string | |
| 612 # "<virtual-name>" (virtual package) | |
| 613 # "<name> =|<|<=|>|>= <version>[-<release>]" (regular package) | |
| 614 # "<name>::<option> =|<|<=|>|>= <value>" (regular package build option) | |
| 615 sub parse_depends ($) { | |
| 616 my ($dep) = @_; | |
| 617 my ($name, $op, $val); | |
| 618 | |
| 619 if (ref($dep)) { | |
| 620 # dependency from new index stored as a node | |
| 621 # - content of the node is the name | |
| 622 # - certain attributes denote the comparison operator | |
| 623 # - the value of such an attribute is the comparison operand | |
| 624 # - the operator (and operand) are optional and there can only be one | |
| 625 $name = $dep->{content}; | |
| 626 $op = undef; | |
| 627 $op = 'equ' if (exists($dep->{equ})); | |
| 628 $op = 'geq' if (exists($dep->{geq})); | |
| 629 $op = 'leq' if (exists($dep->{leq})); | |
| 630 $op = 'gt' if (exists($dep->{gt})); | |
| 631 $op = 'lt' if (exists($dep->{lt})); | |
| 632 if (defined($op)) { | |
| 633 $val = $dep->{$op}; | |
| 634 } | |
| 635 } elsif ($dep =~ m/\S/) { | |
| 636 # dependency from old index stored as text string | |
| 637 # "name operator operand" or "name" | |
| 638 ($name, $op, $val) = ($dep =~ m/(\S+)\s*(?:(\S+)\s*(\S+))?\s*$/); | |
| 639 if (defined($op)) { | |
| 640 $op = { | |
| 641 '==' => 'equ', '=' => 'equ', | |
| 642 '>=' => 'geq', '=>' => 'geq', | |
| 643 '<=' => 'leq', '=<' => 'leq', | |
| 644 '>' => 'gt', '<' => 'lt' | |
| 645 }->{$op}; | |
| 646 if (not defined($op)) { | |
| 647 print "# don't know how to handle dependency: $dep (invalid operator)\n"; | |
| 648 return; | |
| 649 } | |
| 650 } | |
| 651 } | |
| 652 return { | |
| 653 name => $name, | |
| 654 op => $op, | |
| 655 val => $val | |
| 656 }; | |
| 657 } | |
| 658 | |
| 659 # retrieve the local installed package base. | |
| 660 # for packages that provide option resources (packagename::buildoption) | |
| 661 # the options are parsed into the OPTIONS hash. | |
| 662 # other packages will query options on demand. | |
| 663 sub get_installed () { | |
| 664 my (%map); | |
| 665 my (@l, $p); | |
| 666 my ($nam, $val, %options); | |
| 667 my ($vs, $rec, @list); | |
| 668 my ($name, $version, $release); | |
| 669 my ($req); | |
| 670 | |
| 671 # generated total result: | |
| 672 # $map = { | |
| 673 # # regular package | |
| 674 # "<package-name>" <foo> => { | |
| 675 # "<version>-<release>" <1.2.3-20060622> => [ | |
| 676 # <<1>{ | |
| 677 # "name" => $name, | |
| 678 # "version" => $version, | |
| 679 # "release" => $release, | |
| 680 # "PROXY" => $proxy, | |
| 681 # "depends" => [ | |
| 682 # <<3>>{ | |
| 683 # "cond" => '', | |
| 684 # "value" => { | |
| 685 # name => $name, | |
| 686 # op => $op, | |
| 687 # val => $val | |
| 688 # }, | |
| 689 # }, | |
| 690 # ... | |
| 691 # ], | |
| 692 # "keeps" => [ | |
| 693 # \<<3> | |
| 694 # ... | |
| 695 # ], | |
| 696 # "OPTIONS" => { | |
| 697 # "<option>" => "<value>", | |
| 698 # "<option>" => "<value>", | |
| 699 # ... | |
| 700 # }, | |
| 701 # }, | |
| 702 # ... | |
| 703 # ], | |
| 704 # }, | |
| 705 # # build option | |
| 706 # "<package-name>::<option>" <foo::with_baz> => { | |
| 707 # "<value>" <yes> => [ | |
| 708 # \<<1>> | |
| 709 # ... | |
| 710 # ], | |
| 711 # }, | |
| 712 # # virtual package | |
| 713 # "<package-name>" <BAR> => { | |
| 714 # "" => [ | |
| 715 # \<<1>>, | |
| 716 # ... | |
| 717 # ], | |
| 718 # }, | |
| 719 # ... | |
| 720 # }; | |
| 721 | |
| 722 # query and parse all provides of all packages | |
| 723 # HINT: We assume(!) that OpenPKG RPM outputs "provides" in order: | |
| 724 # 1. virtual package & build option | |
| 725 # 2. regular package | |
| 726 # FIXME: The better long-term solution for all this fiddling would be something like: | |
| 727 # "openpkg rpm -qa -qf '%{NAME} %{VERSION} %{RELEASE}[ .%{PROVIDENAME} .%{PROVIDEFLAGS:depflags} .%{PROVIDEVERSION}]\\n'" | |
| 728 @l = run($config->{"rpm"}. " --provides -qa"); | |
| 729 @list = (); | |
| 730 foreach (@l) { | |
| 731 # parse into provide object | |
| 732 $p = parse_provides($_) or next; | |
| 733 | |
| 734 # short-circuit processing for RPM special case | |
| 735 next if ($p->{name} =~ m/^gpg\(/); | |
| 736 | |
| 737 # is this an option? | |
| 738 if (defined($p->{with})) { | |
| 739 $options{$p->{prefix}}->{$p->{with}} = $p->{version}; | |
| 740 push(@list, $p); | |
| 741 next; | |
| 742 } | |
| 743 | |
| 744 # is this a virtual target? | |
| 745 $vs = vs($p); | |
| 746 if ($vs eq '') { | |
| 747 push(@list, $p); | |
| 748 next; | |
| 749 } | |
| 750 | |
| 751 # assemble package details | |
| 752 $name = $p->{name}; | |
| 753 $version = defined($p->{version}) ? $p->{version} : '*'; | |
| 754 $release = defined($p->{release}) ? $p->{release} : '*'; | |
| 755 push(@list, { | |
| 756 name => $name, | |
| 757 version => $version, | |
| 758 release => $release | |
| 759 }); | |
| 760 | |
| 761 # create target record | |
| 762 $rec = { | |
| 763 name => $name, | |
| 764 version => $version, | |
| 765 release => $release, | |
| 766 PROXY => $p->{proxy}, | |
| 767 depends => [], | |
| 768 keeps => [] | |
| 769 }; | |
| 770 foreach (@list) { | |
| 771 push(@{$map{$_->{name}}->{vs($_)}}, $rec); | |
| 772 } | |
| 773 | |
| 774 # remove assembled details | |
| 775 @list = (); | |
| 776 } | |
| 777 if (@list) { | |
| 778 print "# ATTENTION: ", scalar(@list), " froods (unassignable RPM 'provides') left\n"; | |
| 779 } | |
| 780 | |
| 781 # options are provided for a package, | |
| 782 # apply them to all instances of the package | |
| 783 # FIXME: duplicate copying because record exists multiple times (but harmless) | |
| 784 # FIXME: merges all "provides" of all package instances together -- which might be wrong | |
| 785 foreach $nam (keys(%options)) { | |
| 786 foreach $val (keys(%{$map{$nam}})) { | |
| 787 foreach (@{$map{$nam}->{$val}}) { | |
| 788 $_->{OPTIONS} = $options{$nam}; | |
| 789 } | |
| 790 } | |
| 791 } | |
| 792 | |
| 793 # query all 'requires' of all installed packages | |
| 794 # to determine the package dependencies | |
| 795 @l = run($config->{"rpm"} . " --qf '%{NAME}:::%{VERSION}:::%{RELEASE}[ :::%{REQUIRENAME}:::%{REQUIREFLAGS:depflags}:::%{REQUIREVERSION}:::]\\n' -qa"); | |
| 796 @list = (); | |
| 797 foreach (@l) { | |
| 798 ($name, $version, $release, $req) = m/^([^:]+):::([^:]+):::([^:]+)(.*?)$/; | |
| 799 next if ($name eq 'gpg-pubkey'); | |
| 800 $release =~ s/\+PROXY$//; | |
| 801 # for each requirement triple... | |
| 802 while ($req =~ m/\s+:::(.+?):::\s*(.*?)\s*:::(.*?):::/g) { | |
| 803 $p = parse_depends("$1 $2 $3"); | |
| 804 next if ($p->{name} =~ m/^(rpmlib|gpg)\(/); | |
| 805 $vs = vs({ version => $version, release => $release }); | |
| 806 $p = { cond => '', value => $p }; | |
| 807 foreach $rec (@{$map{$name}->{$vs}}) { | |
| 808 push(@{$rec->{depends}}, $p); | |
| 809 push(@{$rec->{keeps}}, $p); | |
| 810 } | |
| 811 } | |
| 812 } | |
| 813 if (@list) { | |
| 814 print "# ATTENTION: ",scalar(@list)," fnords (unassignable RPM 'requires') left\n"; | |
| 815 } | |
| 816 | |
| 817 # return final result | |
| 818 return \%map; | |
| 819 } | |
| 820 | |
| 821 ############################################################################# | |
| 822 ## | |
| 823 ## FUNCTIONS: REPOSITORY INDEX INFORMATION | |
| 824 ## | |
| 825 ############################################################################# | |
| 826 | |
| 827 # fetch XML/RDF index from file or URL | |
| 828 # (recursively fetches sub-indexes, too) | |
| 829 sub get_index ($$$$$) { | |
| 830 my ($url, $fn, $xml, $pfmatch, $installed) = @_; | |
| 831 my (%map, $include); | |
| 832 my ($fetch, $bzip2, $path); | |
| 833 my ($parser); | |
| 834 | |
| 835 # determine command/path to fetch/open index | |
| 836 $bzip2 = $config->{"bzip2"}; | |
| 837 $fetch = defined($fn) ? $fn : $url; | |
| 838 $fetch !~ m/\.bz2$/ || -x $bzip2 | |
| 839 or die "openpkg:build:FATAL: $bzip2 not found\n"; | |
| 840 if ($fetch =~ m/^\w+:/) { | |
| 841 # looks like URL scheme | |
| 842 print "# fetching XML/RDF index from URL $fetch\n"; | |
| 843 $path = $config->{"curl"} . " -s -o - \"$fetch\" |"; | |
| 844 $path .= "$bzip2 -dc |" if ($fetch =~ m/\.bz2$/); | |
| 845 } else { | |
| 846 print "# reading XML/RDF index from file $fetch\n"; | |
| 847 if ($fetch =~ m/\.bz2$/) { | |
| 848 $path = "$bzip2 -dc $fetch |"; | |
| 849 } else { | |
| 850 $path = "<$fetch"; | |
| 851 } | |
| 852 } | |
| 853 | |
| 854 # open index | |
| 855 open(RFH, $path) or | |
| 856 die "openpkg:build:FATAL: cannot open '$fetch' ($!)\n"; | |
| 857 | |
| 858 # if XML parser can be used, try to lazy-load it | |
| 859 if ($xml) { | |
| 860 eval { require XML::Simple; }; | |
| 861 $xml = 0 if ($@); | |
| 862 } | |
| 863 | |
| 864 # determine and run XML parser | |
| 865 # (returns contained index includes) | |
| 866 $parser = ($xml ? \&xml_parser : \&simple_text_parser); | |
| 867 $include = $parser->(\*RFH, $url, \%map, $pfmatch, $installed); | |
| 868 | |
| 869 # close index | |
| 870 close(RFH) | |
| 871 or die "openpkg:build:FATAL: an I/O error occured\n"; | |
| 872 | |
| 873 # cannot do real recursions on file handles, so we simply append | |
| 874 # (instead of inserting at the correct position) all sub-RDFs, as | |
| 875 # the result is flattend into a big hash anyway | |
| 876 foreach (@$include) { | |
| 877 my ($submap); | |
| 878 my ($suburl, $subfn) = relurl($url, $fn, $_); | |
| 879 $submap = get_index($suburl, $subfn, $xml, $pfmatch, $installed); # RECURSION | |
| 880 while (my ($name, $vmap) = each(%$submap)) { | |
| 881 while (my ($vs, $recs) = each(%$vmap)) { | |
| 882 push(@{$map{$name}->{$vs}}, @$recs); | |
| 883 } | |
| 884 } | |
| 885 } | |
| 886 | |
| 887 # return final result | |
| 888 # $map = { | |
| 889 # <package-name> => { | |
| 890 # "<version>-<release>" => { | |
| 891 # href => ..., | |
| 892 # name => ..., | |
| 893 # version => ..., | |
| 894 # release => ..., | |
| 895 # platform => ..., | |
| 896 # prefix => ..., | |
| 897 # depends => [ ... ], | |
| 898 # keeps => [ ... ], | |
| 899 # conflicts => [ ... ], | |
| 900 # source => ..., | |
| 901 # nosource => ..., | |
| 902 # desc => $desc, | |
| 903 # OPTIONS => $options, | |
| 904 # DEFOPTS => { %$options }, | |
| 905 # }; | |
| 906 # }; | |
| 907 # }; | |
| 908 return \%map; | |
| 909 } | |
| 910 | |
| 911 # compute absolute paths | |
| 912 # - (url, fn) point to a base document | |
| 913 # the location is the file path fn if fn is | |
| 914 # defined, otherwise it is url. | |
| 915 # - augment the pointer with suburl | |
| 916 # - suburl can be an absolute url | |
| 917 # then the new pointer is (suburl, undef) | |
| 918 # - suburl can be a absolute file path | |
| 919 # then the new pointer is (suburl, suburl) | |
| 920 # - suburl can be a relative path | |
| 921 # then it augments url or fn accordingly | |
| 922 sub relurl ($$$) { | |
| 923 my ($url, $fn, $suburl) = @_; | |
| 924 my ($subfn); | |
| 925 | |
| 926 if ($suburl =~ m/^\w+:\/\//) { | |
| 927 # NOP | |
| 928 } elsif ($suburl =~ m/^\//) { | |
| 929 $subfn = $suburl; | |
| 930 } else { | |
| 931 if (defined($fn)) { | |
| 932 $subfn = $fn; | |
| 933 $subfn =~ s/(\/)?\/*[^\/]*$/$1$suburl/; | |
| 934 $suburl = $subfn; | |
| 935 } else { | |
| 936 $subfn = $url; | |
| 937 $subfn =~ s/(\/)?\/*[^\/]*$/$1$suburl/; | |
| 938 $suburl = $subfn; | |
| 939 $subfn = undef; | |
| 940 } | |
| 941 } | |
| 942 1 while ($suburl =~ s/\/\.\//\//s); | |
| 943 1 while ($suburl =~ s/\/[^\/]+\/\.\.\//\//s); | |
| 944 return ($suburl, $subfn); | |
| 945 } | |
| 946 | |
| 947 # XML/RDF parser (simple way) | |
| 948 sub simple_text_parser ($$$$$) { | |
| 949 my ($fh, $url, $map, $pfmatch, $installed) = @_; | |
| 950 my (@include); | |
| 951 my ($section); | |
| 952 my ($name, $version); | |
| 953 my ($href, $release, $desc, $bags); | |
| 954 my (%options, @provides); | |
| 955 my ($platform, $prefix); | |
| 956 my ($rec); | |
| 957 my ($tag, $cond, $attrname, $attrval, $body); | |
| 958 my ($usecond); | |
| 959 my ($options); | |
| 960 | |
| 961 print "# using internal XML/RDF parser\n"; | |
| 962 | |
| 963 # read XML/RDF line-wise as we know that our | |
| 964 # OpenPKG XML/RDF indices follow a strict formatting | |
| 965 while (<$fh>) { | |
| 966 # unescape some XML entities | |
| 967 s/>/>/g; | |
| 968 s/</</g; | |
| 969 | |
| 970 if (!(defined($href)) && m/<rdf:Description.*?href="([^"]*)"/) { | |
| 971 # start of new package description | |
| 972 $href = $1; | |
| 973 $section = undef; | |
| 974 $name = undef; | |
| 975 $release = undef; | |
| 976 $desc = ''; | |
| 977 $platform = undef; | |
| 978 $prefix = undef; | |
| 979 $bags = {}; | |
| 980 @provides = (); | |
| 981 } | |
| 982 | |
| 983 if (!(defined($href)) && m/<Repository.*?href="([^"]*)"(?:\s*platform="([^"]*)")?/) { | |
| 984 # external XML/RDF index reference for particular binary platform | |
| 985 if (goodpf($2, $pfmatch)) { | |
| 986 push(@include, $1); | |
| 987 } | |
| 988 next; | |
| 989 } | |
| 990 | |
| 991 # skip content unless referenced piece was found | |
| 992 next if (not defined($href)); | |
| 993 | |
| 994 # parse XML/RDF element into components | |
| 995 ($tag, $cond, $attrname, $attrval, $body) = m{ | |
| 996 < # start delimiter | |
| 997 (\/?[\w:]+) # begin element name | |
| 998 \s* # optional space before attributes | |
| 999 (?:cond="([^"]+)")? # known attribute | |
| 1000 (?:(\w+)="([^"]+)")? # unknown attribute | |
| 1001 > # end delimiter | |
| 1002 (.*?) # optional element body | |
| 1003 (?:<\/\1>)? # optional end tag | |
| 1004 $ # end of string | |
| 1005 }mx; | |
| 1006 | |
| 1007 # recognize the various XML/RDF elements | |
| 1008 if ($tag eq 'Description') { | |
| 1009 $usecond = $cond; | |
| 1010 $section = 'description'; | |
| 1011 } elsif ($tag eq '/Description') { | |
| 1012 $usecond = $cond; | |
| 1013 $section = undef; | |
| 1014 } elsif ($section eq 'description') { | |
| 1015 $desc .= $_; | |
| 1016 } elsif ($tag eq 'PreReq') { | |
| 1017 $usecond = $cond; | |
| 1018 $section = 'prereq'; | |
| 1019 } elsif ($tag eq '/PreReq') { | |
| 1020 $usecond = undef; | |
| 1021 $section = undef; | |
| 1022 } elsif ($tag eq 'BuildPreReq') { | |
| 1023 $usecond = $cond; | |
| 1024 $section = 'bprereq'; | |
| 1025 } elsif ($tag eq '/BuildPreReq') { | |
| 1026 $usecond = undef; | |
| 1027 $section = undef; | |
| 1028 } elsif ($tag eq 'Provides') { | |
| 1029 $usecond = $cond; | |
| 1030 $section = 'provides'; | |
| 1031 } elsif ($tag eq '/Provides') { | |
| 1032 $usecond = undef; | |
| 1033 $section = undef; | |
| 1034 } elsif ($tag eq 'Conflicts') { | |
| 1035 $usecond = $cond; | |
| 1036 $section = 'conflicts'; | |
| 1037 } elsif ($tag eq '/Conflicts') { | |
| 1038 $usecond = undef; | |
| 1039 $section = undef; | |
| 1040 } elsif ($tag eq 'NoSource') { | |
| 1041 $usecond = $cond; | |
| 1042 $section = 'nosource'; | |
| 1043 } elsif ($tag eq '/NoSource') { | |
| 1044 $usecond = undef; | |
| 1045 $section = undef; | |
| 1046 } elsif ($tag eq 'Source') { | |
| 1047 $usecond = $cond; | |
| 1048 $section = 'source'; | |
| 1049 } elsif ($tag eq '/Source') { | |
| 1050 $usecond = undef; | |
| 1051 $section = undef; | |
| 1052 } elsif ($tag eq 'Name') { | |
| 1053 $name = $body; | |
| 1054 } elsif ($tag eq 'Version') { | |
| 1055 $version = $body; | |
| 1056 } elsif ($tag eq 'Release') { | |
| 1057 $release = $body; | |
| 1058 } elsif ($tag eq 'Platform') { | |
| 1059 $platform = $body; | |
| 1060 } elsif ($tag eq 'Prefixes') { | |
| 1061 $prefix = $body; | |
| 1062 } elsif ($tag eq 'rdf:li' || $tag eq 'resource') { | |
| 1063 if (defined($attrname)) { | |
| 1064 $body = { | |
| 1065 $attrname => $attrval, | |
| 1066 content => $body | |
| 1067 }; | |
| 1068 } | |
| 1069 if ($section eq 'provides') { | |
| 1070 push(@provides, $body) if (!defined($usecond)); | |
| 1071 } elsif ($section ne '') { | |
| 1072 push(@{$bags->{"$usecond"}->{$section}}, $body); | |
| 1073 } | |
| 1074 } elsif ($tag eq '/rdf:Description') { | |
| 1075 if ( defined($href) | |
| 1076 && defined($name) | |
| 1077 && defined($version) | |
| 1078 && defined($release)) { | |
| 1079 # process the accumulated package information | |
| 1080 @provides = map { | |
| 1081 depends2provides(parse_depends($_)) | |
| 1082 } @provides; | |
| 1083 %options = map { | |
| 1084 ($_->{with} => $_->{version}) | |
| 1085 } grep { | |
| 1086 defined($_->{with}) | |
| 1087 } @provides; | |
| 1088 push(@provides, { | |
| 1089 name => $name, | |
| 1090 version => $version, | |
| 1091 release => $release | |
| 1092 }); | |
| 1093 $options = | |
| 1094 %options | |
| 1095 ? { %options } | |
| 1096 : parse_options($desc); | |
| 1097 if ($options) { | |
| 1098 my (@t) = get_targets($installed->{$name}, sub { 1; }); | |
| 1099 } | |
| 1100 # store accumulated package information | |
| 1101 eval { | |
| 1102 $rec = { | |
| 1103 href => (relurl($url, undef, $href))[0], | |
| 1104 name => $name, | |
| 1105 version => $version, | |
| 1106 release => $release, | |
| 1107 depends => depend_list(swith($bags, 'bprereq')), | |
| 1108 keeps => depend_list(swith($bags, 'prereq')), | |
| 1109 conflicts => swith($bags, 'conflicts'), | |
| 1110 source => swith($bags, 'source'), | |
| 1111 nosource => swith($bags, 'nosource'), | |
| 1112 desc => $desc, | |
| 1113 platform => $platform, | |
| 1114 prefix => $prefix, | |
| 1115 OPTIONS => $options, | |
| 1116 DEFOPTS => { %$options } | |
| 1117 }; | |
| 1118 }; | |
| 1119 if ($@) { | |
| 1120 die "openpkg:build:FATAL: when reading entry '$name':\n" . $@; | |
| 1121 } | |
| 1122 foreach (@provides) { | |
| 1123 push(@{$map->{$_->{name}}->{vs($_)}}, $rec); | |
| 1124 } | |
| 1125 } | |
| 1126 # prepare to recognize next package | |
| 1127 $href = undef; | |
| 1128 } | |
| 1129 } | |
| 1130 | |
| 1131 # return contained XML/RDF indices | |
| 1132 return \@include; | |
| 1133 } | |
| 1134 | |
| 1135 # XML/RDF parser (usual way) | |
| 1136 sub xml_parser ($$$$$) { | |
| 1137 my ($fh, $url, $map, $pfmatch, $installed) = @_; | |
| 1138 my (@include); | |
| 1139 my ($xml, $rep, $sub); | |
| 1140 my (@provides, %options, $rec); | |
| 1141 my ($href, $name, $version, $release, $desc); | |
| 1142 my ($options); | |
| 1143 | |
| 1144 print "# using external XML/RDF parser\n"; | |
| 1145 | |
| 1146 # parse XML/RDF with XML::Simple parser | |
| 1147 $xml = XML::Simple::XMLin($fh, forcearray => 1); | |
| 1148 $rep = $xml->{'Repository'}->[0]->{'rdf:Description'}; | |
| 1149 $sub = $xml->{'Repository'}->[0]->{'Repository'}; | |
| 1150 | |
| 1151 # iterate over all package descriptions | |
| 1152 foreach (@$rep) { | |
| 1153 # fetch package information | |
| 1154 $href = $_->{'href'}; | |
| 1155 $name = xel($_->{'Name'}); | |
| 1156 $version = xel($_->{'Version'}); | |
| 1157 $release = xel($_->{'Release'}); | |
| 1158 next if (not ( | |
| 1159 defined($href) | |
| 1160 && defined($name) | |
| 1161 && defined($version) | |
| 1162 && defined($release) | |
| 1163 )); | |
| 1164 | |
| 1165 # determine package "provides" | |
| 1166 @provides = (); | |
| 1167 if ($_->{'Provides'}) { | |
| 1168 @provides = map { | |
| 1169 $_ = $_->{'rdf:bag'}->[0]; | |
| 1170 $_ = $_->{'rdf:li'} ? $_->{'rdf:li'} : $_->{'resource'}; | |
| 1171 @$_; | |
| 1172 } grep { | |
| 1173 !exists $_->{'cond'} | |
| 1174 } @{$_->{'Provides'}}; | |
| 1175 } | |
| 1176 @provides = map { | |
| 1177 depends2provides(parse_depends($_)) | |
| 1178 } @provides; | |
| 1179 %options = map { | |
| 1180 ($_->{with} => $_->{version}) | |
| 1181 } grep { | |
| 1182 defined $_->{with} | |
| 1183 } @provides; | |
| 1184 push(@provides, { | |
| 1185 name => $name, | |
| 1186 version => $version, | |
| 1187 release => $release | |
| 1188 }); | |
| 1189 | |
| 1190 # determine targets | |
| 1191 $desc = xel($_->{'Description'}); | |
| 1192 $options = | |
| 1193 %options | |
| 1194 ? { %options } | |
| 1195 : parse_options($desc); | |
| 1196 if ($options) { | |
| 1197 my (@t) = get_targets($installed->{$name}, sub { 1; }); | |
| 1198 } | |
| 1199 | |
| 1200 # store accumulated package information | |
| 1201 eval { | |
| 1202 $rec = { | |
| 1203 href => (relurl($url, undef, $href))[0], | |
| 1204 name => $name, | |
| 1205 version => $version, | |
| 1206 release => $release, | |
| 1207 platform => xel($_->{'Platform'}), | |
| 1208 prefix => xel($_->{'Prefixes'}), | |
| 1209 depends => depend_list(xwith($_->{'BuildPreReq'})), | |
| 1210 keeps => depend_list(xwith($_->{'PreReq'})), | |
| 1211 conflicts => xwith($_->{'Conflicts'}), | |
| 1212 source => xwith($_->{'Source'}), | |
| 1213 nosource => xwith($_->{'NoSource'}), | |
| 1214 desc => $desc, | |
| 1215 OPTIONS => $options, | |
| 1216 DEFOPTS => { %$options } | |
| 1217 }; | |
| 1218 }; | |
| 1219 if ($@) { | |
| 1220 die "openpkg:build:FATAL: when reading entry '$name'\n".$@; | |
| 1221 } | |
| 1222 foreach (@provides) { | |
| 1223 push(@{$map->{$_->{name}}->{vs($_)}}, $rec); | |
| 1224 } | |
| 1225 } | |
| 1226 | |
| 1227 # determine contained XML/RDF indices | |
| 1228 if ($sub) { | |
| 1229 @include = map { | |
| 1230 goodpf($_->{platform}, $pfmatch) | |
| 1231 ? ( $_->{href} ) | |
| 1232 : ( ) | |
| 1233 } @$sub; | |
| 1234 } | |
| 1235 | |
| 1236 # return contained XML/RDF indices | |
| 1237 return \@include; | |
| 1238 } | |
| 1239 | |
| 1240 # convert XML parser output to dependency records | |
| 1241 sub depend_list ($) { | |
| 1242 my ($dl) = @_; | |
| 1243 foreach (@$dl) { | |
| 1244 $_->{value} = parse_depends($_->{value}); | |
| 1245 } | |
| 1246 return $dl; | |
| 1247 } | |
| 1248 | |
| 1249 # convert simple XML parser Bag into flat list | |
| 1250 sub swith ($$) { | |
| 1251 my ($bags,$name) = @_; | |
| 1252 my ($cond); | |
| 1253 my (@out); | |
| 1254 | |
| 1255 foreach $cond (keys %$bags) { | |
| 1256 foreach (@{$bags->{$cond}->{$name}}) { | |
| 1257 push @out, { | |
| 1258 cond => $cond, | |
| 1259 value => $_ | |
| 1260 }; | |
| 1261 } | |
| 1262 } | |
| 1263 return \@out; | |
| 1264 } | |
| 1265 | |
| 1266 # convert (conditional) XML/RDF Bag into flat list | |
| 1267 sub xwith ($) { | |
| 1268 my ($bags) = @_; | |
| 1269 my ($bag, $li, $el); | |
| 1270 my (@out); | |
| 1271 | |
| 1272 foreach $bag (@$bags) { | |
| 1273 foreach $li (@{$bag->{'rdf:bag'}}) { | |
| 1274 $el = $li->{'resource'} || $li->{'rdf:li'}; | |
| 1275 foreach (@$el) { | |
| 1276 push @out, { | |
| 1277 cond => $bag->{'cond'}, | |
| 1278 value => $_ | |
| 1279 }; | |
| 1280 } | |
| 1281 } | |
| 1282 } | |
| 1283 return \@out; | |
| 1284 } | |
| 1285 | |
| 1286 # return node value from XML parser | |
| 1287 sub xel($) { | |
| 1288 my ($a) = @_; | |
| 1289 my ($l) = $a->[0]; | |
| 1290 return '' if ref($l); | |
| 1291 return $l; | |
| 1292 } | |
| 1293 | |
| 1294 # is the platform a good one? | |
| 1295 sub goodpf ($$) { | |
| 1296 my ($l, $p) = @_; | |
| 1297 return 1 if $l eq ''; | |
| 1298 return ($l =~ m/(?:^|\s)\Q$p\E(?:\s|$)/); | |
| 1299 } | |
| 1300 | |
| 1301 | |
| 1302 ############################################################################# | |
| 1303 ## | |
| 1304 ## FUNCTIONS: HELPER FUNCTIONS FOR XML PARSING & DEPENDENCY PROCESSING | |
| 1305 ## | |
| 1306 ############################################################################# | |
| 1307 | |
| 1308 # parse option from RPM output | |
| 1309 # < "%option with_foo bar" | |
| 1310 # > $with{"with_foo"} = "bar" | |
| 1311 sub parse_options ($) { | |
| 1312 my ($l) = @_; | |
| 1313 $l = join("\n", @$l) if (ref($l)); | |
| 1314 return {} if ($l !~ m/(--define|\%option\s+)/s); | |
| 1315 my $with = {}; | |
| 1316 $l =~ s/--define\s*'(\S+)\s+(\S+?)'/$with->{$1} = $2, ''/sge; # before openpkg-20021230 | |
| 1317 $l =~ s/\%option\s+(\S+)\s+(\S+)/$with->{$1} = $2, ''/sge; # after openpkg-20021230 | |
| 1318 return $with; | |
| 1319 } | |
| 1320 | |
| 1321 # fetch targets of a name that satisfy a condition and sort by target | |
| 1322 # version. Input is a hash of versions(?) on which the condition has | |
| 1323 # to be true and which points to an array of records with package | |
| 1324 # version information. Output is the list of version sorted package | |
| 1325 # version information records. | |
| 1326 sub get_targets ($$) { | |
| 1327 my ($relmap, $cond) = @_; | |
| 1328 return ( | |
| 1329 sort { | |
| 1330 vcmp(vs($a), vs($b)); | |
| 1331 } map { | |
| 1332 @{$relmap->{$_}} | |
| 1333 } grep { | |
| 1334 $cond->($_); | |
| 1335 } keys %$relmap | |
| 1336 ); | |
| 1337 } | |
| 1338 | |
| 1339 ############################################################################# | |
| 1340 ## | |
| 1341 ## FUNCTIONS: DEPENDENCY PROCESSING | |
| 1342 ## | |
| 1343 ############################################################################# | |
| 1344 | |
| 1345 # search environment for packages that match a pattern | |
| 1346 sub search_pattern ($$) { | |
| 1347 my ($pattern, $env) = @_; | |
| 1348 my (@todo); | |
| 1349 | |
| 1350 if (defined($pattern)) { | |
| 1351 # explicitly given package pattern | |
| 1352 @todo = map { | |
| 1353 my ($p) = $_; | |
| 1354 my ($s, $iswildcard); | |
| 1355 $s = $1 if ($p =~ s/(,[^\s,]+)$//); | |
| 1356 if ($p =~ s/\*+$//) { | |
| 1357 $p = '^'.quotemeta($p).''; | |
| 1358 $iswildcard = 1; | |
| 1359 } else { | |
| 1360 $p = '^'.quotemeta($p).'$'; | |
| 1361 } | |
| 1362 map { "$_$s" } | |
| 1363 grep { m/$p/ && !($iswildcard && exists($env->{exclude}->{$_})) } | |
| 1364 keys %{$env->{repository}} | |
| 1365 } split(/\s+/, $pattern); | |
| 1366 } else { | |
| 1367 # undefined pattern means "-a" option that selects | |
| 1368 # all packages from repository that are installed | |
| 1369 # and not explicitly excluded on command line | |
| 1370 @todo = grep { | |
| 1371 my ($n) = $_; | |
| 1372 (ref($env->{installed}->{$n})) | |
| 1373 && !exists($env->{exclude}->{$n}) | |
| 1374 && grep { $_ ne '-' } keys %{$env->{installed}->{$n}} | |
| 1375 } keys(%{$env->{repository}}); | |
| 1376 } | |
| 1377 return \@todo; | |
| 1378 } | |
| 1379 | |
| 1380 # pull in OPTIONS for a package or an RPM file | |
| 1381 my $get_with_cache = {}; | |
| 1382 sub get_with ($;$) { | |
| 1383 my ($t, $fn) = @_; | |
| 1384 my (@l, %with); | |
| 1385 my ($optmap, $opt); | |
| 1386 | |
| 1387 if ($t->{OPTIONS}) { | |
| 1388 $opt = $t->{OPTIONS}; | |
| 1389 } else { | |
| 1390 if (defined($fn)) { | |
| 1391 @l = run($config->{"rpm"} . " -q --provides -p $fn"); | |
| 1392 } else { | |
| 1393 if (not exists($get_with_cache->{-provides})) { | |
| 1394 # pre-cache the "provides" query for all(!) packages at once for speedup | |
| 1395 my @c = run($config->{"rpm"} . " -qa --qf " . | |
| 1396 '\'%{NAME}[ :::%{PROVIDENAME}:::%{PROVIDEFLAGS:depflags}:::%{PROVIDEVERSION}:::]\n\''); | |
| 1397 $get_with_cache->{-provides} = {}; | |
| 1398 foreach my $c (@c) { | |
| 1399 if ($c =~ m/^(\S+)(.*)$/s) { | |
| 1400 my ($name, $provides) = ($1, $2); | |
| 1401 while ($provides =~ m/\s+:::(.+?):::\s*(.*?)\s*:::(.*?):::/g) { | |
| 1402 $get_with_cache->{-provides}->{$name} = [] if (not exists($get_with_cache->{-provides}->{$name})); | |
| 1403 push(@{$get_with_cache->{-provides}->{$name}}, "$1 $2 $3"); | |
| 1404 } | |
| 1405 } | |
| 1406 } | |
| 1407 } | |
| 1408 @l = $get_with_cache->{-provides}->{$t->{name}}; | |
| 1409 if (not @l) { | |
| 1410 # (should not happen in practice, but anyway) | |
| 1411 @l = run($config->{"rpm"} . " -q --provides $t->{name}"); | |
| 1412 $get_with_cache->{-provides}->{$t->{name}} = [ @l ]; | |
| 1413 } | |
| 1414 } | |
| 1415 $opt = parse_provideslist(\@l); | |
| 1416 if (scalar(keys(%$opt)) == 0) { | |
| 1417 if (defined($fn)) { | |
| 1418 @l = run($config->{"rpm"} . " -qi -p $fn"); | |
| 1419 } else { | |
| 1420 if (not exists($get_with_cache->{-infos})) { | |
| 1421 # pre-cache the "infos" query for all(!) packages at once for speedup | |
| 1422 my @c = run($config->{"rpm"} . " -qi -a"); | |
| 1423 my $p = ""; | |
| 1424 $get_with_cache->{-infos} = {}; | |
| 1425 foreach my $c (@c) { | |
| 1426 $p = $1 if ($c =~ m/^Name:\s+(\S+)/s); | |
| 1427 $get_with_cache->{-infos}->{$p} = [] if (not exists($get_with_cache->{-infos}->{$p})); | |
| 1428 push(@{$get_with_cache->{-infos}->{$p}}, $c); | |
| 1429 } | |
| 1430 } | |
| 1431 @l = $get_with_cache->{-infos}->{$t->{name}}; | |
| 1432 if (not @l) { | |
| 1433 # (should not happen in practice, but anyway) | |
| 1434 @l = run($config->{"rpm"} . " -qi $t->{name}"); | |
| 1435 $get_with_cache->{-infos}->{$t->{name}} = [ @l ]; | |
| 1436 } | |
| 1437 } | |
| 1438 $opt = parse_options(\@l); | |
| 1439 } | |
| 1440 $t->{OPTIONS} = $opt; | |
| 1441 } | |
| 1442 return $opt; | |
| 1443 } | |
| 1444 | |
| 1445 # copy options from new to old | |
| 1446 # where option already exists in old or option key | |
| 1447 # matches regular expression | |
| 1448 sub override_options ($$$) { | |
| 1449 my ($old, $new, $reg) = @_; | |
| 1450 my ($k); | |
| 1451 | |
| 1452 foreach $k (keys(%$new)) { | |
| 1453 if ((exists($old->{$k}) && $old->{$k} ne $new->{$k}) || $k =~ m/^$reg$/) { | |
| 1454 $old->{$k} = $new->{$k}; | |
| 1455 } | |
| 1456 } | |
| 1457 } | |
| 1458 | |
| 1459 # filter package options | |
| 1460 sub filter_name_with ($$$) { | |
| 1461 my ($name, $with, $global) = @_; | |
| 1462 my (@keys); | |
| 1463 | |
| 1464 if ($global) { | |
| 1465 push(@keys, grep { !/::/ } keys %$with); | |
| 1466 } | |
| 1467 push(@keys, grep { m/::/ } keys %$with); | |
| 1468 return { | |
| 1469 map { | |
| 1470 my ($k) = $_; | |
| 1471 $k !~ m/::/ || $k =~ s/^\Q$name\E::// | |
| 1472 ? ( $k => $with->{$_} ) | |
| 1473 : ( ) | |
| 1474 } @keys | |
| 1475 }; | |
| 1476 } | |
| 1477 | |
| 1478 # filter out package relevant options | |
| 1479 sub name_with ($$) { | |
| 1480 filter_name_with($_[0], $_[1], 1); | |
| 1481 } | |
| 1482 | |
| 1483 # filter out package specific options | |
| 1484 sub name_only_with ($$) { | |
| 1485 filter_name_with($_[0], $_[1], 0); | |
| 1486 } | |
| 1487 | |
| 1488 # evaluate a condition attribute from an option set | |
| 1489 sub conditional ($$) { | |
| 1490 my ($cond, $with) = @_; | |
| 1491 my (@s, $res); | |
| 1492 | |
| 1493 return 1 if ($cond eq '' || !defined($with)); | |
| 1494 foreach (split(/\s+/,$cond)) { | |
| 1495 if ($_ eq '+') { | |
| 1496 die "openpkg:build:FATAL: stack underflow in: $cond\n" if scalar(@s) < 2; | |
| 1497 my ($a) = pop(@s); | |
| 1498 my ($b) = pop(@s); | |
| 1499 push(@s, $a && $b); | |
| 1500 } elsif ($_ eq '|') { | |
| 1501 die "openpkg:build:FATAL: stack underflow in: $cond\n" if scalar(@s) < 2; | |
| 1502 my ($a) = pop(@s); | |
| 1503 my ($b) = pop(@s); | |
| 1504 push(@s, $a || $b); | |
| 1505 } elsif ($_ eq '!') { | |
| 1506 die "openpkg:build:FATAL: stack underflow in: $cond\n" if scalar(@s) < 1; | |
| 1507 my ($a) = pop(@s); | |
| 1508 push(@s, !$a); | |
| 1509 } else { | |
| 1510 push(@s, ($with->{$_} eq 'yes') ? 1 : 0); | |
| 1511 } | |
| 1512 } | |
| 1513 die "openpkg:build:FATAL: stack underflow in: $cond\n" if scalar(@s) < 1; | |
| 1514 $res = pop(@s); | |
| 1515 | |
| 1516 die "openpkg:build:FATAL: stack not empty in: $cond\n" if scalar(@s) > 0; | |
| 1517 return $res; | |
| 1518 } | |
| 1519 | |
| 1520 # retrieve conditional target attributes in map | |
| 1521 sub target_attribute ($$$;$) { | |
| 1522 my ($target, $env, $attr, $with) = @_; | |
| 1523 my ($optreg) = $env->{config}->{optreg}; | |
| 1524 my ($name, @out); | |
| 1525 | |
| 1526 return if (not $target); | |
| 1527 $name = $target->{name}; | |
| 1528 | |
| 1529 my ($mywith) = ($with ? $with : get_with($target)); | |
| 1530 override_options($mywith, name_with($name, $env->{with}), $optreg); | |
| 1531 | |
| 1532 foreach (@{$target->{$attr}}) { | |
| 1533 next if (not conditional($_->{'cond'}, $mywith)); | |
| 1534 push(@out, $_->{'value'}); | |
| 1535 } | |
| 1536 return \@out; | |
| 1537 } | |
| 1538 | |
| 1539 # see whether target is in map | |
| 1540 sub target_exists ($$) { | |
| 1541 my ($target, $map) = @_; | |
| 1542 my ($vmap) = $map->{$target->{name}}; | |
| 1543 return if (not $vmap); | |
| 1544 return ( | |
| 1545 !defined $target->{version} | |
| 1546 || defined $vmap->{vs($target)} | |
| 1547 ); | |
| 1548 } | |
| 1549 | |
| 1550 # see whether target has conflicts | |
| 1551 sub target_conflicts ($$) { | |
| 1552 my ($target, $env) = @_; | |
| 1553 return target_attribute($target, $env, 'conflicts'); | |
| 1554 } | |
| 1555 | |
| 1556 # retrieve build dependencies for target | |
| 1557 sub target_depends ($$) { | |
| 1558 my ($target, $env) = @_; | |
| 1559 return target_attribute($target, $env, 'depends'); | |
| 1560 } | |
| 1561 | |
| 1562 # retrieve runtime dependencies for target | |
| 1563 sub target_keeps ($$) { | |
| 1564 my ($target, $env) = @_; | |
| 1565 return target_attribute($target, $env, 'keeps'); | |
| 1566 } | |
| 1567 | |
| 1568 # retrieve source list for target | |
| 1569 sub target_source ($$) { | |
| 1570 my ($target, $env) = @_; | |
| 1571 return target_attribute($target, $env, 'source'); | |
| 1572 } | |
| 1573 | |
| 1574 # retrieve nosource list for target | |
| 1575 sub target_nosource ($$) { | |
| 1576 my ($target, $env) = @_; | |
| 1577 return target_attribute($target, $env, 'nosource'); | |
| 1578 } | |
| 1579 | |
| 1580 # check whether target conflicts against map | |
| 1581 sub target_has_conflicts ($$$) { | |
| 1582 my ($target, $map, $env) = @_; | |
| 1583 my ($conflicts, $t); | |
| 1584 | |
| 1585 $conflicts = target_conflicts($target, $env); | |
| 1586 foreach (@$conflicts) { | |
| 1587 my ($t) = find_target($_, $map, 0); | |
| 1588 return $t if $t; | |
| 1589 } | |
| 1590 return; | |
| 1591 } | |
| 1592 | |
| 1593 # record target status | |
| 1594 sub target_setstatus ($$$) { | |
| 1595 my ($target, $status, $pri) = @_; | |
| 1596 | |
| 1597 if ($pri > $target->{STATUSPRI}) { | |
| 1598 $target->{STATUSPRI} = $pri; | |
| 1599 $target->{STATUS} = $status; | |
| 1600 } | |
| 1601 } | |
| 1602 | |
| 1603 # strip doubles from depend/keep lists | |
| 1604 # and return a map name => depend/keep | |
| 1605 sub unique_map { | |
| 1606 my (%out); | |
| 1607 foreach (@_) { | |
| 1608 foreach (@$_) { | |
| 1609 $out{$_->{name}} = $_; | |
| 1610 } | |
| 1611 } | |
| 1612 return %out; | |
| 1613 } | |
| 1614 | |
| 1615 # check whether installed package matches build options. If default | |
| 1616 # = 1 then options which are not required must be identical to the | |
| 1617 # DEFOPTS. | |
| 1618 sub target_suitable ($$$) { | |
| 1619 my ($target, $with, $default) = @_; | |
| 1620 my ($iwith, $dwith); | |
| 1621 my ($k, $v); | |
| 1622 | |
| 1623 if ($target->{GOAL}) { | |
| 1624 $with = name_with($target->{name}, $with); | |
| 1625 } else { | |
| 1626 $with = name_only_with($target->{name}, $with); | |
| 1627 } | |
| 1628 $iwith = $target->{OPTIONS}; | |
| 1629 $dwith = $target->{DEFOPTS}; | |
| 1630 while (($k,$v) = each(%$iwith)) { | |
| 1631 if (exists($with->{$k})) { | |
| 1632 return 0 if ($iwith->{$k} ne $with->{$k}); | |
| 1633 } elsif ($default) { | |
| 1634 return 0 if ($iwith->{$k} ne $dwith->{$k}); | |
| 1635 } | |
| 1636 } | |
| 1637 return 1; | |
| 1638 } | |
| 1639 | |
| 1640 # determine whether target should be rebuild | |
| 1641 sub target_better ($$$) { | |
| 1642 my ($env, $target, $map) = @_; | |
| 1643 my ($vs) = vs($target); | |
| 1644 my ($vmap) = $map->{$target->{name}}; | |
| 1645 | |
| 1646 # rebuild if target isn't installed | |
| 1647 return 'new' unless $vmap; | |
| 1648 | |
| 1649 # if "-e" then | |
| 1650 # always update if installed version is different from repository | |
| 1651 if ($env->{exact} && !grep { vcmp($vs, $_) == 0; } keys(%$vmap)) { | |
| 1652 return 'exact'; | |
| 1653 } | |
| 1654 | |
| 1655 # if target is goal | |
| 1656 # always update if installed version is older than repository | |
| 1657 if ($target->{GOAL} && !grep { vcmp($vs, $_) <= 0; } keys(%$vmap)) { | |
| 1658 return 'goal'; | |
| 1659 } | |
| 1660 | |
| 1661 # if -U then | |
| 1662 # always update if installed version is older than repository | |
| 1663 if ($env->{upgrade} && !grep { vcmp($vs, $_) <= 0; } keys(%$vmap)) { | |
| 1664 return 'upgrade'; | |
| 1665 } | |
| 1666 | |
| 1667 # if -z/-Z then | |
| 1668 # always update if installed version is equal or older than repository | |
| 1669 if ($env->{zero} && grep { vcmp($vs, $_) >= 0; } keys(%$vmap)) { | |
| 1670 return 'zero'; | |
| 1671 } | |
| 1672 | |
| 1673 # keep installed target | |
| 1674 return; | |
| 1675 } | |
| 1676 | |
| 1677 # check if target record describes a source package | |
| 1678 sub is_source ($) { | |
| 1679 my ($t) = @_; | |
| 1680 return !(defined $t->{'prefix'}); | |
| 1681 } | |
| 1682 | |
| 1683 # there can be multiple sources for a target release | |
| 1684 sub chose_source ($$$$$) { | |
| 1685 my ($env, $name, $select, $vmap, $cond) = @_; | |
| 1686 my (@targ, @recs, @nrecs, $rec, %nam); | |
| 1687 | |
| 1688 # resolve name into a list of versions | |
| 1689 # for virtual targets this resolves to a list | |
| 1690 # of real targets that provide the virtual target | |
| 1691 @targ = get_targets($vmap, sub { 1; }); | |
| 1692 return unless @targ; | |
| 1693 | |
| 1694 # find usable binary targets add all source targets | |
| 1695 @recs = ( | |
| 1696 ( grep { | |
| 1697 !$env->{sourceonly} | |
| 1698 && !is_source($_) | |
| 1699 && $_->{'platform'} eq $env->{config}->{platform} | |
| 1700 && $_->{'prefix'} eq $env->{config}->{prefix} | |
| 1701 } get_targets($vmap, $cond) ), | |
| 1702 ( grep { | |
| 1703 is_source($_) | |
| 1704 } @targ ) | |
| 1705 ); | |
| 1706 return if (not @recs); | |
| 1707 | |
| 1708 # limit list to exact matches if provided by "-e" | |
| 1709 if (defined($select)) { | |
| 1710 @recs = grep { | |
| 1711 vsn($_) =~ m/^\Q$select\E/ | |
| 1712 } @recs; | |
| 1713 } | |
| 1714 | |
| 1715 # try to resolve ambiguity against installed targets | |
| 1716 # and targets previously selected | |
| 1717 if (scalar(@recs) > 1) { | |
| 1718 @nrecs = grep { | |
| 1719 $env->{built}->{$_->{name}} | |
| 1720 || $env->{installed}->{$_->{name}} | |
| 1721 } @recs; | |
| 1722 @recs = @nrecs if (@nrecs); | |
| 1723 } | |
| 1724 | |
| 1725 # try to resolve ambiguity against hints | |
| 1726 if ($env->{hint}) { | |
| 1727 @nrecs = grep { | |
| 1728 exists($env->{hint}->{$_->{name}}) | |
| 1729 } @recs; | |
| 1730 @recs = @nrecs if (@nrecs); | |
| 1731 } | |
| 1732 | |
| 1733 # try to resolve ambiguity against targets that match | |
| 1734 # the exact name | |
| 1735 if (scalar(@recs) > 1) { | |
| 1736 @nrecs = grep { | |
| 1737 $name eq $_->{name} | |
| 1738 } @recs; | |
| 1739 @recs = @nrecs if (@nrecs); | |
| 1740 } | |
| 1741 | |
| 1742 # try to resolve ambiguity by preferring binaries | |
| 1743 if (scalar(@recs) > 1 && !$env->{sourceonly}) { | |
| 1744 @nrecs = grep { | |
| 1745 defined($_->{'platform'}) | |
| 1746 } @recs; | |
| 1747 @recs = @nrecs if (@nrecs); | |
| 1748 } | |
| 1749 | |
| 1750 # if we still have non-unique targets, complain | |
| 1751 if (scalar(@recs) > 1) { | |
| 1752 %nam = map { $_->{name} => 1 } @recs; | |
| 1753 if (scalar(keys(%nam)) > 1) { | |
| 1754 print "# ambigous sources for $name\n"; | |
| 1755 my ($i) = 0; | |
| 1756 foreach (@recs) { | |
| 1757 print "# $i: ".vsn($_)." = $_->{href}\n"; | |
| 1758 $i++; | |
| 1759 } | |
| 1760 return; | |
| 1761 } | |
| 1762 } | |
| 1763 | |
| 1764 # prefer full-source packages | |
| 1765 if (scalar(@recs) > 1) { | |
| 1766 @nrecs = grep { | |
| 1767 ! $_->{nosource} | |
| 1768 || ! @{$_->{nosource}} | |
| 1769 } @recs; | |
| 1770 unless (@nrecs) { | |
| 1771 @nrecs = grep { | |
| 1772 $_->{href} !~ m/\.nosrc.rpm$/ | |
| 1773 } @recs; | |
| 1774 } | |
| 1775 @recs = @nrecs if (@nrecs); | |
| 1776 } | |
| 1777 | |
| 1778 # nothing left -> exit | |
| 1779 return if (scalar(@recs) == 0); | |
| 1780 | |
| 1781 # chose last (= max version) in list of targets | |
| 1782 $rec = $recs[-1]; | |
| 1783 print "# source for $name is ".vsn($rec)."\n"; | |
| 1784 return $rec; | |
| 1785 } | |
| 1786 | |
| 1787 # locate target for a dependency | |
| 1788 sub dep2target ($$$) { | |
| 1789 my ($dep, $env, $source) = @_; | |
| 1790 my ($name, $op, @targ); | |
| 1791 my ($i, $r, $b, $cond, $version); | |
| 1792 my ($t, $tdef, $why); | |
| 1793 | |
| 1794 ($name, $op, $version) = ($dep->{name}, $dep->{op}, $dep->{val}); | |
| 1795 | |
| 1796 $i = $env->{installed}->{$name}; | |
| 1797 $r = $env->{repository}->{$name}; | |
| 1798 $b = $env->{built}->{$name}; | |
| 1799 | |
| 1800 return if (not ($i || $r || $b)); | |
| 1801 | |
| 1802 if (!defined($op)) { | |
| 1803 $cond = sub { 1; }; | |
| 1804 } elsif ($op eq 'geq') { | |
| 1805 $cond = sub { vcmp($_[0],$version) >= 0; }; | |
| 1806 } elsif ($op eq 'leq') { | |
| 1807 $cond = sub { vcmp($_[0],$version) <= 0; }; | |
| 1808 } elsif ($op eq 'gt') { | |
| 1809 $cond = sub { vcmp($_[0],$version) > 0; }; | |
| 1810 } elsif ($op eq 'lt') { | |
| 1811 $cond = sub { vcmp($_[0],$version) < 0; }; | |
| 1812 } elsif ($op eq 'equ') { | |
| 1813 $cond = sub { vcmp($_[0],$version) == 0; }; | |
| 1814 } else { | |
| 1815 die "openpkg:build:FATAL: internal error in dep2target\n"; | |
| 1816 } | |
| 1817 | |
| 1818 $tdef = undef; | |
| 1819 | |
| 1820 # search installed target that matches requirement | |
| 1821 # use it if we are not upgrading (no -U and no -z/-Z) | |
| 1822 if ($i && (@targ = get_targets($i, $cond))) { | |
| 1823 foreach $t (@targ) { | |
| 1824 get_with($t); | |
| 1825 if (target_suitable($t, $env->{with}, 0)) { | |
| 1826 $tdef = $t; | |
| 1827 if (not ($env->{upgrade} || $env->{zero} || $source)) { | |
| 1828 return ($t, 1); | |
| 1829 } | |
| 1830 } | |
| 1831 } | |
| 1832 } | |
| 1833 | |
| 1834 # search target in current build list that matches requirement | |
| 1835 # use it if it exists | |
| 1836 if ($b && (@targ = get_targets($b, $cond))) { | |
| 1837 $t = $targ[0]; | |
| 1838 return ($t, 1); | |
| 1839 } | |
| 1840 | |
| 1841 # search target in repository and install it, if it is newer than | |
| 1842 # corresponding installed versions avoid repository packages that | |
| 1843 # would install 'new' (i.e. are not an upgrade of an existing | |
| 1844 # package) | |
| 1845 $t = chose_source($env, $name, undef, $r, $cond); | |
| 1846 if ($t) { | |
| 1847 if (!$tdef || ( | |
| 1848 ($why = target_better($env, $t, $env->{installed})) && | |
| 1849 $why ne 'new' | |
| 1850 ) || $source) { | |
| 1851 return ($t, 0); | |
| 1852 } | |
| 1853 } | |
| 1854 | |
| 1855 # if nothing is suitable in repository then fall back to | |
| 1856 # anything we already have installed but that we skipped | |
| 1857 # above to look for upgrades. | |
| 1858 if ($tdef) { | |
| 1859 return ($tdef, 1); | |
| 1860 } | |
| 1861 | |
| 1862 return; | |
| 1863 } | |
| 1864 | |
| 1865 # compute reverse dependency map | |
| 1866 sub get_revdep ($) { | |
| 1867 my ($env) = @_; | |
| 1868 my ($i) = $env->{'installed'}; | |
| 1869 my ($r) = $env->{'repository'}; | |
| 1870 my ($pkg, %dep, %dlist, %rev); | |
| 1871 my (@targ, $t, $t1, $t2, $with, $name, $vmap); | |
| 1872 my ($d, $k, %d, $old, %name, %pkg); | |
| 1873 | |
| 1874 print "# computing reverse dependencies\n"; | |
| 1875 | |
| 1876 # iterate over all installed packages | |
| 1877 foreach $pkg (keys(%$i)) { | |
| 1878 $vmap = $r->{$pkg}; | |
| 1879 if (not $vmap) { | |
| 1880 print "# ATTENTION: $pkg has no upgrade path (installed package not found in repository)\n"; | |
| 1881 next; | |
| 1882 } | |
| 1883 | |
| 1884 # get forward dependencies from installed packages | |
| 1885 # dep{a}{b} is true if b depends directly on a | |
| 1886 # dlist{a} is list of packages that depend on a | |
| 1887 @targ = get_targets($i->{$pkg}, sub { 1; }); | |
| 1888 foreach $t (@targ) { | |
| 1889 $with = get_with($t); | |
| 1890 $d = target_attribute($t, $env, 'depends', $with); | |
| 1891 $k = target_attribute($t, $env, 'keeps', $with); | |
| 1892 next if (not (@$d || @$k)); | |
| 1893 %d = unique_map($d,$k); | |
| 1894 | |
| 1895 # resolve package | |
| 1896 if (not exists($pkg{$pkg})) { | |
| 1897 ($t2, $old) = dep2target({ name => $pkg }, $env, 1); | |
| 1898 $t2 = undef if ($old); | |
| 1899 $pkg{$pkg} = $t2; | |
| 1900 } | |
| 1901 $t2 = $pkg{$pkg}; | |
| 1902 next if (not $t2); | |
| 1903 foreach (keys(%d)) { | |
| 1904 next if ($_ eq 'OpenPKG'); | |
| 1905 # resolve target | |
| 1906 unless (exists($name{$_})) { | |
| 1907 ($t1, $old) = dep2target($d{$_}, $env, 0); | |
| 1908 $name{$_} = ($t1 ? $t1->{name} : $_); | |
| 1909 } | |
| 1910 $name = $name{$_}; | |
| 1911 if (not $dep{$name}{$t->{name}}) { | |
| 1912 $dep{$name}{$t->{name}} = 1; | |
| 1913 push(@{$dlist{$name}}, $t2); | |
| 1914 } | |
| 1915 } | |
| 1916 } | |
| 1917 } | |
| 1918 | |
| 1919 # sort reverse dependencies | |
| 1920 foreach $pkg (keys(%dep)) { | |
| 1921 $rev{$pkg} = [ | |
| 1922 sort { | |
| 1923 $dep{$b->{name}}{$a->{name}} | |
| 1924 || -$dep{$a->{name}}{$b->{name}} | |
| 1925 || $a->{name} cmp $b->{name} | |
| 1926 } @{$dlist{$pkg}} | |
| 1927 ]; | |
| 1928 } | |
| 1929 | |
| 1930 # return hash of package reverse dependencies | |
| 1931 return \%rev; | |
| 1932 } | |
| 1933 | |
| 1934 # build package dependencies | |
| 1935 # (all input and output is passed in 'env' hash) | |
| 1936 sub build_deps ($$) { | |
| 1937 my ($pattern, $env) = @_; | |
| 1938 my ($todo, @list, $list, @out); | |
| 1939 | |
| 1940 # determine all packages which match the pattern | |
| 1941 $todo = search_pattern($pattern, $env); | |
| 1942 | |
| 1943 # unfold target names into all(!) real targets names | |
| 1944 @list = | |
| 1945 map { | |
| 1946 map { | |
| 1947 map { | |
| 1948 $_->{name} | |
| 1949 } @$_ | |
| 1950 } values(%{$env->{repository}->{$_}}) | |
| 1951 } @$todo; | |
| 1952 | |
| 1953 # also add target name | |
| 1954 push @list, @$todo; | |
| 1955 | |
| 1956 # strip duplicate names | |
| 1957 @list = keys %{ { map { $_ => 1 } @list } }; | |
| 1958 | |
| 1959 # cache reverse dependencies | |
| 1960 if (not $env->{revdep}) { | |
| 1961 $env->{revdep} = get_revdep($env); | |
| 1962 } | |
| 1963 | |
| 1964 # map targets into list of dependency names | |
| 1965 @list = map { | |
| 1966 $env->{revdep}->{$_} | |
| 1967 ? (@{$env->{revdep}->{$_}}) | |
| 1968 : () | |
| 1969 } @list; | |
| 1970 | |
| 1971 # iterate over dependencies | |
| 1972 foreach (@list) { | |
| 1973 # avoiding cycles | |
| 1974 next if ($env->{builddeps}->{$_->{name}}); | |
| 1975 $env->{builddeps}->{$_->{name}} = 1; | |
| 1976 | |
| 1977 # generate result | |
| 1978 push(@out, $_); | |
| 1979 | |
| 1980 # generate result recursively | |
| 1981 $list = build_deps($_->{name}, $env); # RECURSION | |
| 1982 push(@out, @$list); | |
| 1983 } | |
| 1984 | |
| 1985 # return final results | |
| 1986 return \@out; | |
| 1987 } | |
| 1988 | |
| 1989 # report options that are not used for | |
| 1990 sub warn_about_options ($$$) { | |
| 1991 my ($target, $with, $c) = @_; | |
| 1992 my ($iwith) = $target->{OPTIONS}; | |
| 1993 my ($k, $v); | |
| 1994 | |
| 1995 return if (not defined($iwith)); | |
| 1996 $with = name_with($target->{name}, $with); | |
| 1997 while (($k,$v) = each %$with) { | |
| 1998 if (not ($k =~ m/^$c->{optreg}$/ || exists $iwith->{$k})) { | |
| 1999 print "# ATTENTION: $target->{name} ignores option '$k'\n"; | |
| 2000 } | |
| 2001 } | |
| 2002 } | |
| 2003 | |
| 2004 # find target in map | |
| 2005 sub find_target ($$$) { | |
| 2006 my ($name, $map, $pos) = @_; | |
| 2007 my ($vmap) = $map->{$name}; | |
| 2008 my (@vs); | |
| 2009 | |
| 2010 return if (not $vmap); | |
| 2011 @vs = sort { vcmp($b,$a) } keys(%$vmap); | |
| 2012 return $vmap->{$vs[$pos]}->[-1]; | |
| 2013 } | |
| 2014 | |
| 2015 # add dependency as build option | |
| 2016 sub depend_option ($$$) { | |
| 2017 my ($target, $dep, $env) = @_; | |
| 2018 my ($with, $opt, $relmap, @t, $t); | |
| 2019 my ($pro) = depends2provides($dep); | |
| 2020 my ($conflict) = 0; | |
| 2021 | |
| 2022 return 1 if (not defined($pro->{with})); | |
| 2023 | |
| 2024 my ($val) = defined($pro->{version}) ? $pro->{version} : 'yes'; | |
| 2025 | |
| 2026 $with = $env->{with}; | |
| 2027 $opt = $pro->{prefix}.'::'.$pro->{with}; | |
| 2028 if (defined($with->{$opt}) && $with->{$opt} ne $val) { | |
| 2029 print "# ", vsn($target), " has conflicting requirement $opt = $with->{$opt} != $val\n"; | |
| 2030 $conflict = 1; | |
| 2031 } | |
| 2032 | |
| 2033 $relmap = $env->{built}->{$pro->{prefix}}; | |
| 2034 @t = get_targets($relmap, sub { 1; }); | |
| 2035 foreach $t (@t) { | |
| 2036 $with = $t->{OPTIONS}; | |
| 2037 $opt = $pro->{with}; | |
| 2038 if (defined($with->{$opt}) && $with->{$opt} ne $val) { | |
| 2039 print "# ", vsn($t), " has conflicting requirement $opt = $with->{$opt} != $val\n"; | |
| 2040 $conflict = 1; | |
| 2041 } | |
| 2042 } | |
| 2043 | |
| 2044 return 0 if ($conflict); | |
| 2045 | |
| 2046 print "# ", vsn($target), " adds option $opt = $val\n"; | |
| 2047 $with->{$opt} = $val; | |
| 2048 return 1; | |
| 2049 } | |
| 2050 | |
| 2051 # remember fatal error | |
| 2052 sub pusherr ($$$) { | |
| 2053 my ($env, $target, $mess) = @_; | |
| 2054 print "# $mess\n"; | |
| 2055 push(@{$env->{fatal}}, vsn($target).": $mess\n"); | |
| 2056 } | |
| 2057 | |
| 2058 # generate dependencies | |
| 2059 sub make_dep ($$$$$$$) { | |
| 2060 my ($who, $target, $depth, $env, $list, $blist, $clist) = @_; | |
| 2061 my ($d, $k, %d, %k, $t, $old); | |
| 2062 my (@deps, $conflict, $why); | |
| 2063 | |
| 2064 # check whether target is already in list of to be build packages | |
| 2065 if (target_exists($target, $env->{built})) { | |
| 2066 print "# $target->{name} is already in list\n"; | |
| 2067 return; | |
| 2068 } | |
| 2069 | |
| 2070 # check whether target is in conflict with already installed package | |
| 2071 if ($t = target_has_conflicts($target, $env->{installed}, $env)) { | |
| 2072 target_setstatus($target, 'CONFLICT', 4); | |
| 2073 push(@$clist, $target); | |
| 2074 pusherr($env, $target, "$target->{name} conflicts with ".vsn($t)); | |
| 2075 return; | |
| 2076 } | |
| 2077 | |
| 2078 # check whether target is in conflict with to be build package | |
| 2079 if ($t = target_has_conflicts($target, $env->{built}, $env)) { | |
| 2080 target_setstatus($target, 'CONFLICT', 4); | |
| 2081 push(@$clist, $target); | |
| 2082 pusherr($env, $target, "$target->{name} conflicts with ".vsn($t)); | |
| 2083 return; | |
| 2084 } | |
| 2085 | |
| 2086 # see if a target is already installed and requires a rebuild | |
| 2087 if ($t = find_target($target->{name}, $env->{installed}, -1)) { | |
| 2088 if (exists($env->{exclude}->{$target->{name}})) { | |
| 2089 print "# excluding $target->{name} (no upgrade allowed)\n"; | |
| 2090 return; | |
| 2091 } | |
| 2092 | |
| 2093 # pull in options (for status report) | |
| 2094 if ($target->{REBUILD}) { | |
| 2095 target_setstatus($target, 'DEPEND', 1); | |
| 2096 print "# rebuilding $target->{name} (dependency)\n"; | |
| 2097 } elsif ($env->{zero}) { | |
| 2098 target_setstatus($target, 'ZERO', 1); | |
| 2099 print "# rebuilding $target->{name} (zero)\n"; | |
| 2100 } elsif (vs($target) ne vs($t)) { | |
| 2101 target_setstatus($target, 'UPDATE', 3); | |
| 2102 print "# rebuilding $target->{name} (update)\n"; | |
| 2103 } elsif (!target_suitable($t, $env->{with}, 0)) { | |
| 2104 target_setstatus($target, 'MISMATCH', 2); | |
| 2105 print "# rebuilding $target->{name} (parameter mismatch)\n"; | |
| 2106 } elsif ($env->{goals} && $target->{GOAL}) { | |
| 2107 target_setstatus($target, 'GOAL', 3); | |
| 2108 print "# rebuilding $target->{name} (goal)\n"; | |
| 2109 } else { | |
| 2110 print "# $target->{name} is already installed\n"; | |
| 2111 return; | |
| 2112 } | |
| 2113 | |
| 2114 # use options from installed base | |
| 2115 override_options(get_with($target), get_with($t), $env->{config}->{optreg}); | |
| 2116 | |
| 2117 # remember this is a rebuild for a proxy package | |
| 2118 $target->{PROXY} = $t->{PROXY}; | |
| 2119 $target->{REBUILD} = 1; | |
| 2120 } else { | |
| 2121 print "# creating $target->{name}\n"; | |
| 2122 target_setstatus($target, 'ADD', 3); | |
| 2123 } | |
| 2124 | |
| 2125 if (exists($env->{exclude}->{$target->{name}})) { | |
| 2126 die "openpkg:build:FATAL: target ".vsn($target)." is forbidden\n"; | |
| 2127 } | |
| 2128 | |
| 2129 # mark this as a target before reverse dependencies trigger it again | |
| 2130 push(@{$env->{built}->{$target->{name}}->{vs($target)}}, $target); | |
| 2131 $target->{LIMBO} = 1; | |
| 2132 | |
| 2133 # recurse over dependencies | |
| 2134 $d = target_depends($target, $env); | |
| 2135 $k = target_keeps($target, $env); | |
| 2136 if (@$d || @$k) { | |
| 2137 %d = unique_map($d, $k); | |
| 2138 %k = unique_map($k); | |
| 2139 @deps = (); | |
| 2140 $conflict = 0; | |
| 2141 foreach (keys %d) { | |
| 2142 # old index misses a OpenPKG provider in the index... skip it | |
| 2143 next if ($_ eq 'OpenPKG'); | |
| 2144 ($t, $old) = dep2target($d{$_}, $env, 0); | |
| 2145 if ($t) { | |
| 2146 if ($old) { | |
| 2147 print "# $target->{name} uses ".vsn($t)." for $_\n"; | |
| 2148 if ($t->{LIMBO}) { | |
| 2149 print "# ATTENTION: ".vsn($t)." is in LIMBO\n"; | |
| 2150 } | |
| 2151 next; | |
| 2152 } | |
| 2153 if (not depend_option($t, $d{$_}, $env)) { | |
| 2154 push(@$clist, $target); | |
| 2155 pusherr($env, $target, "$target->{name} has conflicting requirement"); | |
| 2156 target_setstatus($target, 'UNDEF', 4); | |
| 2157 $conflict = 1; | |
| 2158 next; | |
| 2159 } | |
| 2160 if ($k{$_}) { | |
| 2161 push(@$blist, $t); | |
| 2162 print "# $target->{name} installs ".vsn($t)." for $_\n"; | |
| 2163 } else { | |
| 2164 print "# $target->{name} requires ".vsn($t)." for $_\n"; | |
| 2165 } | |
| 2166 push(@deps, $t); | |
| 2167 } else { | |
| 2168 push(@$clist, $target); | |
| 2169 pusherr($env, $target, "$target->{name} searches a frood called '$_'"); | |
| 2170 target_setstatus($target, 'UNDEF', 4); | |
| 2171 $conflict = 1; | |
| 2172 } | |
| 2173 } | |
| 2174 if (not $conflict) { | |
| 2175 foreach $t (@deps) { | |
| 2176 make_dep($target, $t, $depth+1, $env, $list, $blist, $clist); # RECURSION | |
| 2177 } | |
| 2178 } | |
| 2179 } | |
| 2180 | |
| 2181 print "# adding ".vsn($target)." to list\n"; | |
| 2182 $target->{WHO} = $who; | |
| 2183 $target->{WHY} = $target->{STATUS}; | |
| 2184 push(@$list, $target); | |
| 2185 | |
| 2186 # remember new options | |
| 2187 override_options(get_with($target), name_with($target->{name}, $env->{with}), ''); | |
| 2188 | |
| 2189 # moan about non-source packages | |
| 2190 foreach (@{target_nosource($target, $env)}) { | |
| 2191 my ($p) = target_source($target, $env)->[$_]; | |
| 2192 $p =~ s/.*\///; | |
| 2193 print "# ATTENTION: unpackaged source $_: $p\n"; | |
| 2194 } | |
| 2195 | |
| 2196 # cleanup limbo | |
| 2197 $target->{LIMBO} = 0; | |
| 2198 | |
| 2199 # a dependency could not be resolved, don't bother with reverse | |
| 2200 # dependencies for this target | |
| 2201 return if ($conflict); | |
| 2202 | |
| 2203 if (!$env->{quick} && $target->{name} ne 'openpkg' ) { | |
| 2204 if (not $env->{revdep}) { | |
| 2205 $env->{revdep} = get_revdep($env); | |
| 2206 } | |
| 2207 foreach $t (@{$env->{revdep}->{$target->{name}}}) { | |
| 2208 # this is a rebuild, triggering further revdeps | |
| 2209 $t->{REBUILD} = 1; | |
| 2210 | |
| 2211 # this is a rebuild, keep this installed | |
| 2212 push(@$blist, $t); | |
| 2213 | |
| 2214 print "# rebuilding reverse dependency ".vsn($t)."\n"; | |
| 2215 make_dep($target, $t, $depth+1, $env, $list, $blist, $clist); # RECURSION | |
| 2216 } | |
| 2217 } | |
| 2218 } | |
| 2219 | |
| 2220 # generate build lists for targets matched by pattern | |
| 2221 # (all input and output is passed in 'env' hash) | |
| 2222 sub build_list ($$) { | |
| 2223 my ($pattern, $env) = @_; | |
| 2224 my (@goals, @targets, @keeps, @conflicts, @bonly, $t); | |
| 2225 my ($name, $select, $r, $i); | |
| 2226 my ($todo, %keep); | |
| 2227 | |
| 2228 # determine all packages which match the pattern | |
| 2229 $todo = search_pattern($pattern, $env); | |
| 2230 | |
| 2231 # chose sources for goals from repository | |
| 2232 foreach $name (@$todo) { | |
| 2233 $select = undef; | |
| 2234 $select = $1 if ($name =~ s/,([^\s,]+)$//); | |
| 2235 $t = undef; | |
| 2236 | |
| 2237 # keeping installed packages for goals is ugly | |
| 2238 # - we currently do not support installed source RPMs | |
| 2239 # - source RPMs might already have expired from repository | |
| 2240 # consequence: | |
| 2241 # - goals are always upgraded to repository versions | |
| 2242 #if (not $env->{upgrade}) { | |
| 2243 # $i = $env->{installed}->{$name}; | |
| 2244 # $t = chose_source($env, $name, $select, $i, sub { 1; }); | |
| 2245 #} | |
| 2246 if (not $t) { | |
| 2247 $r = $env->{repository}->{$name}; | |
| 2248 $t = chose_source($env, $name, $select, $r, sub { 1; }); | |
| 2249 } | |
| 2250 | |
| 2251 if ($t) { | |
| 2252 warn_about_options($t, $env->{with}, $env->{config}); | |
| 2253 $t->{GOAL} = 1; | |
| 2254 push @goals, $t; | |
| 2255 } else { | |
| 2256 # error | |
| 2257 if ($env->{status}) { | |
| 2258 print "# dropping goal '$name'\n"; | |
| 2259 } else { | |
| 2260 die "openpkg:build:FATAL: cannot find source for '$name'\n"; | |
| 2261 } | |
| 2262 } | |
| 2263 } | |
| 2264 return if (not @goals); | |
| 2265 | |
| 2266 # recurse over dependencies | |
| 2267 @targets = (); | |
| 2268 @keeps = @goals; | |
| 2269 foreach $t (@goals) { | |
| 2270 print "# recursing over dependencies for ".vsn($t)."\n"; | |
| 2271 make_dep(undef, $t, 0, $env, \@targets, \@keeps, \@conflicts); | |
| 2272 } | |
| 2273 | |
| 2274 # determine "binary only" packages which should be not kept | |
| 2275 # as they were not installed and are used temporarily only. | |
| 2276 %keep = map { $_ => 1 } @keeps; | |
| 2277 @bonly = reverse grep { | |
| 2278 !$keep{$_} && !$env->{installed}->{$_->{name}} | |
| 2279 } @targets; | |
| 2280 | |
| 2281 # return results | |
| 2282 return (\@targets, \@bonly, \@conflicts); | |
| 2283 } | |
| 2284 | |
| 2285 | |
| 2286 ############################################################################# | |
| 2287 ## | |
| 2288 ## FUNCTIONS: RESULT PRINTING | |
| 2289 ## | |
| 2290 ############################################################################# | |
| 2291 | |
| 2292 # determine execution command | |
| 2293 sub cmd ($$) { | |
| 2294 my ($w,$s) = @_; | |
| 2295 if (!defined($w)) { | |
| 2296 return $s; | |
| 2297 } elsif ($w =~ m/^-(.*)/) { | |
| 2298 return "$1 \"$s\""; | |
| 2299 } else { | |
| 2300 return "$w $s"; | |
| 2301 } | |
| 2302 } | |
| 2303 sub priv ($) { cmd($opt_P, $_[0]); } | |
| 2304 sub npriv ($) { cmd($opt_N, $_[0]); } | |
| 2305 | |
| 2306 # execute a command | |
| 2307 my $run_cache = {}; | |
| 2308 sub run ($) { | |
| 2309 my $cmd = cmd($opt_N, $_[0]); | |
| 2310 my $out = $run_cache->{$cmd}; | |
| 2311 if (not defined($out)) { | |
| 2312 my @out = `$cmd`; | |
| 2313 $out = [ @out ]; | |
| 2314 $run_cache->{$cmd} = $out; | |
| 2315 } | |
| 2316 return (wantarray ? @{$out} : join(//, @{$out})); | |
| 2317 } | |
| 2318 | |
| 2319 # print dependency list | |
| 2320 sub print_deps ($) { | |
| 2321 my ($list) = @_; | |
| 2322 | |
| 2323 print join("\n", sort map { vsn($_) } @$list), "\n"; | |
| 2324 } | |
| 2325 | |
| 2326 # print dependency map | |
| 2327 sub print_map ($$$$$) { | |
| 2328 my ($installed, $repository, $list, $bonly, $clist) = @_; | |
| 2329 my (%dep); | |
| 2330 | |
| 2331 foreach (@$bonly) { | |
| 2332 $_->{status} = 'TEMP'; | |
| 2333 } | |
| 2334 foreach (reverse(@$list)) { | |
| 2335 printf("%-35s %-8s %s\n", | |
| 2336 $_->{WHO} ? vsn($_->{WHO}) : "GOAL", | |
| 2337 $_->{WHY} ? $_->{WHY} : '???', | |
| 2338 vsn($_) | |
| 2339 ); | |
| 2340 } | |
| 2341 } | |
| 2342 | |
| 2343 # instead of printing a command list, print a status map | |
| 2344 # that shows all packages and how the build process would | |
| 2345 # change their status | |
| 2346 sub print_status ($$$$$) { | |
| 2347 my ($installed, $repository, $list, $bonly, $clist) = @_; | |
| 2348 my (%bonly) = map { $_ => 1 } @$bonly; | |
| 2349 my (%map, $n, @names, $t); | |
| 2350 my ($old, $tag, $new); | |
| 2351 | |
| 2352 # augment map with additional information | |
| 2353 # about conflicting and binary only (temporary) packages | |
| 2354 foreach (@$list, @$clist) { | |
| 2355 next if (not $_->{release} =~ m/\S/); | |
| 2356 $map{$_->{name}} = { | |
| 2357 rel => "$_->{version}-$_->{release}", | |
| 2358 status => $_->{STATUS} | |
| 2359 }; | |
| 2360 } | |
| 2361 foreach (@$bonly) { | |
| 2362 next if (not $_->{release} =~ m/\S/); | |
| 2363 $map{$_->{name}} = { | |
| 2364 rel => "$_->{version}-$_->{release}", | |
| 2365 status => 'TEMP' | |
| 2366 }; | |
| 2367 } | |
| 2368 | |
| 2369 # augment map with additional information | |
| 2370 # about up-to-date and new packages | |
| 2371 @names = keys(%map); | |
| 2372 foreach $n (keys(%$installed)) { | |
| 2373 next if ($n =~ m/::/); | |
| 2374 next if (exists($map{$n})); | |
| 2375 next if (not (grep { $_ ne '' } keys(%{$installed->{$n}}))); | |
| 2376 $map{$n}->{'status'} = 'OK'; | |
| 2377 push(@names, $n); | |
| 2378 } | |
| 2379 foreach $n (keys(%$repository)) { | |
| 2380 next if ($n =~ m/::/); | |
| 2381 next if (exists($map{$n})); | |
| 2382 next if (not (grep { $_ ne '' } keys(%{$repository->{$n}}))); | |
| 2383 $t = find_target($n, $repository, 0); | |
| 2384 $map{$n}->{'status'} = 'NEW'; | |
| 2385 $map{$n}->{'rel'} = vs($t); | |
| 2386 push(@names, $n); | |
| 2387 } | |
| 2388 | |
| 2389 # generate status output | |
| 2390 foreach $n (sort(@names)) { | |
| 2391 $old = join(',', | |
| 2392 map { "$n-$_" } | |
| 2393 sort | |
| 2394 grep { $_ ne '-' } | |
| 2395 keys(%{$installed->{$n}}) | |
| 2396 ); | |
| 2397 $old = $n if ($old eq ''); | |
| 2398 $tag = $map{$n}->{status}; | |
| 2399 $new = defined($map{$n}->{rel}) ? " $n-$map{$n}->{rel}" : ''; | |
| 2400 printf("%-35s %-8s%s\n", $old, $tag, $new); | |
| 2401 } | |
| 2402 } | |
| 2403 | |
| 2404 # compute path to source RPM from rpm config and target data | |
| 2405 sub target2srcrpm ($$) { | |
| 2406 my ($target, $c) = @_; | |
| 2407 return $c->{srcrpmdir}.'/'.$target->{name}.'-'.$target->{version}.'-'.$target->{release}.'.src.rpm'; | |
| 2408 } | |
| 2409 | |
| 2410 # compute path to binary RPM from rpm config and target data | |
| 2411 sub target2rpm ($$) { | |
| 2412 my ($target, $c) = @_; | |
| 2413 my ($tmpl) = $c->{template}; | |
| 2414 my ($popt) = $target->{PROXY} ? '+PROXY' : ''; | |
| 2415 | |
| 2416 $tmpl =~ s/%{NAME}/$target->{name}/; | |
| 2417 $tmpl =~ s/%{VERSION}/$target->{version}/; | |
| 2418 $tmpl =~ s/%{RELEASE}/$target->{release}$popt/; | |
| 2419 | |
| 2420 return $c->{rpmdir}.'/'.$tmpl; | |
| 2421 } | |
| 2422 | |
| 2423 # merge parameters from installed package | |
| 2424 # with new parameter set and global parameters | |
| 2425 # from configuration | |
| 2426 # then map the result to --define command line arguments | |
| 2427 # suitable for rpm | |
| 2428 sub make_defines ($$$$) { | |
| 2429 my ($old, $new, $def, $c) = @_; | |
| 2430 my ($with); | |
| 2431 | |
| 2432 $old = {} unless $old; | |
| 2433 $def = {} unless $def; | |
| 2434 | |
| 2435 # override old parameters with new parameters | |
| 2436 # drop new parameters that do not exist in old set | |
| 2437 $old = { %$old }; | |
| 2438 override_options($old, $new, $c->{optreg}); | |
| 2439 | |
| 2440 # convert parameters to --define command line options | |
| 2441 # skip parameter templates from index | |
| 2442 # skip parameters that are identical to defaults | |
| 2443 $with = join(' ', | |
| 2444 map { "--define '$_ $old->{$_}'" } | |
| 2445 sort grep { | |
| 2446 $old->{$_} =~ m/\S/ && | |
| 2447 $old->{$_} !~ m/^%/ && | |
| 2448 $old->{$_} ne $def->{$_} | |
| 2449 } keys %$old | |
| 2450 ); | |
| 2451 | |
| 2452 $with = ' '.$with if ($with ne ''); | |
| 2453 | |
| 2454 return $with; | |
| 2455 } | |
| 2456 | |
| 2457 # compute new target based on old target augmented with options from | |
| 2458 # a binary RPM file | |
| 2459 sub binary_target ($$) { | |
| 2460 my ($t, $fn) = @_; | |
| 2461 my (%target) = %$t; | |
| 2462 | |
| 2463 # pull in options from binary RPM file | |
| 2464 delete $target{'OPTIONS'}; | |
| 2465 get_with(\%target, $fn); | |
| 2466 return \%target; | |
| 2467 } | |
| 2468 | |
| 2469 # return path to master package for a proxy package | |
| 2470 sub find_proxy ($$) { | |
| 2471 my ($t, $bpkg) = @_; | |
| 2472 my (@l) = run($config->{"rpm"} . " -ql $t->{name}"); | |
| 2473 my ($link) = (grep { $_ =~ m/\/\.prefix-$t->{name}$/ } @l)[0]; | |
| 2474 return if (not defined($link)); | |
| 2475 chomp $link; | |
| 2476 my ($prefix) = readlink($link); | |
| 2477 return if (not defined($prefix)); | |
| 2478 $bpkg =~ s/.*\///; | |
| 2479 $bpkg =~ s/\+PROXY(\.[^-]+-[^-]+)-[^-]+\.rpm$/$1-*.rpm/; | |
| 2480 return (glob("$prefix/RPM/PKG/$bpkg"))[0]; | |
| 2481 } | |
| 2482 | |
| 2483 # indent text to form a block | |
| 2484 sub indent ($) { | |
| 2485 my ($txt) = @_; | |
| 2486 $txt =~ s/^/ /gm; | |
| 2487 return $txt; | |
| 2488 } | |
| 2489 | |
| 2490 # print commands from package build list | |
| 2491 # c -> configuration to derive paths from | |
| 2492 # uncond -> always do the --rebuild | |
| 2493 # with -> parameter set passed to build tool | |
| 2494 # ignore -> generate script that does not stop on error | |
| 2495 # usebin -> build-time check to skip rebuild when binary exists | |
| 2496 # allbin -> usebin also for goals | |
| 2497 sub print_list1 ($$$$$$$) { | |
| 2498 my ($list, $c, $uncond, $with, $ignore, $usebin, $allbin) = @_; | |
| 2499 my ($pkg, $spkg, $bpkg, $uvhpkg, $ppkg); | |
| 2500 my ($opt); | |
| 2501 my ($cmd1, $cmd2, $mark); | |
| 2502 my ($cmd3, $srcpkg); | |
| 2503 | |
| 2504 $mark = '::::'; | |
| 2505 | |
| 2506 my $err; | |
| 2507 if ($ignore) { $err = "|| true" } else { $err = "|| exit \$?" }; | |
| 2508 foreach (@$list) { | |
| 2509 $pkg = $_->{name}; | |
| 2510 $spkg = $_->{href}; | |
| 2511 unless ($spkg =~ m/\S/) { | |
| 2512 die "openpkg:build:FATAL: internal error, ",vsn($_)," without source URL\n"; | |
| 2513 } | |
| 2514 $bpkg = target2rpm($_, $c); $uvhpkg = $bpkg; | |
| 2515 $srcpkg = target2srcrpm($_, $c); | |
| 2516 $cmd3 = ''; | |
| 2517 | |
| 2518 # rebuild binary package IF | |
| 2519 # 'unconditional' option | |
| 2520 # OR target is tagged as rebuilding | |
| 2521 # OR there is no binary package | |
| 2522 # OR dependency check found that installed package is not suitable | |
| 2523 # OR existing binary package doesn't satisfy wanted options | |
| 2524 $cmd1 = undef; | |
| 2525 if ( $uncond | |
| 2526 || !-f $bpkg | |
| 2527 || !target_suitable(binary_target($_, $bpkg), $with, 1)) { | |
| 2528 | |
| 2529 $opt = make_defines($_->{OPTIONS}, $with, | |
| 2530 $_->{DEFOPTS}, $c); | |
| 2531 | |
| 2532 # proxy packages are rebuilt from their maste | |
| 2533 # hierachy | |
| 2534 # someone preferred a binary from the repository | |
| 2535 # just copy it to the local store | |
| 2536 if ($_->{PROXY}) { | |
| 2537 $ppkg = find_proxy($_,$bpkg) or | |
| 2538 die "openpkg:build:FATAL: proxy package ",vsn($_)," does not exist\n"; | |
| 2539 | |
| 2540 # rpm doesn't support additional parameters to the | |
| 2541 # mkproxy script | |
| 2542 # $cmd1 = npriv($config->{"mkp"} . " $ppkg -- -o $bpkg"); | |
| 2543 $cmd1 = "( cd $c->{rpmdir} && ". | |
| 2544 npriv($config->{"mkp"} . " $ppkg"). | |
| 2545 " )"; | |
| 2546 } elsif (defined $_->{prefix}) { | |
| 2547 $cmd1 = ''; | |
| 2548 if ($spkg =~ m|^\.?/|) { | |
| 2549 $uvhpkg = $spkg; | |
| 2550 } | |
| 2551 else { | |
| 2552 $cmd1 .= npriv($config->{"curl"} . " -# -o $bpkg $spkg $err\n"); | |
| 2553 $cmd3 = npriv("rm -f $bpkg >/dev/null 2>&1 $err\n") unless ($opt_k); | |
| 2554 } | |
| 2555 } else { | |
| 2556 $cmd1 = ''; | |
| 2557 if ($spkg =~ m|^\.?/|) { | |
| 2558 $cmd1 .= npriv($config->{"rpm"} . "$opt --rebuild $spkg $err\n"); | |
| 2559 } | |
| 2560 else { | |
| 2561 $cmd1 .= "if test ! -f $srcpkg; then\n"; | |
| 2562 $cmd1 .= indent(npriv($config->{"curl"} . " -# -o $srcpkg $spkg $err\n")); | |
| 2563 $cmd1 .= "fi\n"; | |
| 2564 $cmd1 .= npriv($config->{"rpm"} . "$opt --rebuild $srcpkg $err\n"); | |
| 2565 $cmd1 .= npriv("rm -f $srcpkg >/dev/null 2>&1 $err\n") unless ($opt_k); | |
| 2566 } | |
| 2567 } | |
| 2568 } | |
| 2569 | |
| 2570 # wrap build command with build-time check for existing | |
| 2571 # binary target | |
| 2572 if (defined($cmd1) && ($allbin || ($usebin && !$_->{GOAL}))) { | |
| 2573 $cmd1 = "if test ! -f $uvhpkg; then\n".indent($cmd1)."fi\n"; | |
| 2574 } | |
| 2575 | |
| 2576 # if package exist force rpm to copy over new files | |
| 2577 # better than erasing everything and losing configuration | |
| 2578 # files | |
| 2579 $opt = ($_->{REBUILD} || ($allbin || ($usebin && !$_->{GOAL}))) ? ' --force' : ''; | |
| 2580 $cmd2 = ''; | |
| 2581 $cmd2 .= priv($config->{"rpm"} . "$opt -Uvh $uvhpkg $err\n"); | |
| 2582 if ($allbin || ($usebin && !$_->{GOAL})) { | |
| 2583 $cmd2 = "if test \".`".$config->{"rpm"}." -q --qf '\%{SIGMD5}' $pkg`\" != \".`".$config->{"rpm"}." -qp --qf '\%{SIGMD5}' $uvhpkg`\"; then\n".indent($cmd2)."fi\n"; | |
| 2584 } | |
| 2585 $cmd2 = $cmd1.$cmd2 if ($cmd1); | |
| 2586 $cmd2 = $cmd2.$cmd3 if ($cmd3); | |
| 2587 print "echo $mark $spkg $mark\n".$cmd2."echo $mark $spkg = \$? $mark\n"; | |
| 2588 } | |
| 2589 } | |
| 2590 | |
| 2591 # print commands for the temporary package list | |
| 2592 # temporary packages are only used for building other packages | |
| 2593 # and are removed when everything is done | |
| 2594 sub print_list2 ($$) { | |
| 2595 my ($list, $c) = @_; | |
| 2596 my ($pkg); | |
| 2597 | |
| 2598 foreach (@$list) { | |
| 2599 $pkg = "$_->{name}-$_->{version}-$_->{release}"; | |
| 2600 print priv($config->{"rpm"} . " -e $pkg\n"); | |
| 2601 } | |
| 2602 } | |
| 2603 |
