diff options
author | Francois Pons <fpons@mandriva.com> | 2002-07-10 16:25:10 +0000 |
---|---|---|
committer | Francois Pons <fpons@mandriva.com> | 2002-07-10 16:25:10 +0000 |
commit | 1a649e4bd1f0a76ec28fcb851b2f8fe2d6d967e1 (patch) | |
tree | 73c2e8ca7870ef0bb99753a2b1cdf8b16eb7e211 /perl-install/pkgs.pm | |
parent | 52372f1853308aa90b76d4b5cd880c595433fc1d (diff) | |
download | drakx-1a649e4bd1f0a76ec28fcb851b2f8fe2d6d967e1.tar drakx-1a649e4bd1f0a76ec28fcb851b2f8fe2d6d967e1.tar.gz drakx-1a649e4bd1f0a76ec28fcb851b2f8fe2d6d967e1.tar.bz2 drakx-1a649e4bd1f0a76ec28fcb851b2f8fe2d6d967e1.tar.xz drakx-1a649e4bd1f0a76ec28fcb851b2f8fe2d6d967e1.zip |
use perl-URPM instead of rpmtools.
Diffstat (limited to 'perl-install/pkgs.pm')
-rw-r--r-- | perl-install/pkgs.pm | 1717 |
1 files changed, 833 insertions, 884 deletions
diff --git a/perl-install/pkgs.pm b/perl-install/pkgs.pm index e5905940a..932256f19 100644 --- a/perl-install/pkgs.pm +++ b/perl-install/pkgs.pm @@ -5,6 +5,8 @@ use strict; use vars qw(*LOG %preferred $limitMinTrans %compssListDesc); use MDK::Common::System; +use URPM; +use URPM::Resolve; use common; use install_any; use run_program; @@ -16,7 +18,7 @@ use c; -my @preferred = qw(perl-GTK postfix gcc gcc-cpp gcc-c++ proftpd ghostscript-X vim-minimal kernel db1 db2 ispell-en Bastille-Curses-module nautilus libxpm4); +my @preferred = qw(perl-GTK postfix gcc gcc-cpp gcc-c++ proftpd ghostscript-X vim-minimal kernel db1 db2 ispell-en Bastille-Curses-module nautilus libxpm4 zlib1 libncurses5 hardrake); @preferred{@preferred} = (); #- lower bound on the left ( aka 90 means [90-100[ ) @@ -31,23 +33,23 @@ my @preferred = qw(perl-GTK postfix gcc gcc-cpp gcc-c++ proftpd ghostscript-X vi #- constant for small transaction. $limitMinTrans = 8; -#- constant for package accessor (via table). -my $FILE = 0; -my $FLAGS = 1; -my $SIZE_DEPS = 2; -my $MEDIUM = 3; -my $PROVIDES = 4; -my $VALUES = 5; -my $HEADER = 6; -my $INSTALLED_CUMUL_SIZE = 7; -my $EPOCH = 8; - -#- constant for packing flags, see below. -my $PKGS_SELECTED = 0x00ffffff; -my $PKGS_FORCE = 0x01000000; -my $PKGS_INSTALLED = 0x02000000; -my $PKGS_BASE = 0x04000000; -my $PKGS_UPGRADE = 0x20000000; +##- constant for package accessor (via table). +#my $FILE = 0; +#my $FLAGS = 1; +#my $SIZE_DEPS = 2; +#my $MEDIUM = 3; +#my $PROVIDES = 4; +#my $VALUES = 5; +#my $HEADER = 6; +#my $INSTALLED_CUMUL_SIZE = 7; +#my $EPOCH = 8; +# +##- constant for packing flags, see below. +#my $PKGS_SELECTED = 0x00ffffff; +#my $PKGS_FORCE = 0x01000000; +#my $PKGS_INSTALLED = 0x02000000; +#my $PKGS_BASE = 0x04000000; +#my $PKGS_UPGRADE = 0x20000000; #- package to ignore, typically in Application CD. my %ignoreBadPkg = ( @@ -66,62 +68,65 @@ my %ignoreBadPkg = ( #- following flags : selected, force, installed, base, skip. #- size and deps are grouped to save memory too and make a much #- simpler and faster depslist reader, this gets (sizeDeps). -sub packageHeaderFile { $_[0] ? $_[0]->[$FILE] - : die "invalid package from\n" . backtrace() } -sub packageName { $_[0] && $_[0]->[$FILE] =~ /^([^:\s]*)-[^:\-\s]+-[^:\-\s]+\.[^:\.\-\s]*(?::.*)?/ ? $1 - : die "invalid file `" . ($_[0] && $_[0]->[$FILE]) . "'\n" . backtrace() } -sub packageVersion { $_[0] && $_[0]->[$FILE] =~ /^[^:\s]*-([^:\-\s]+)-[^:\-\s]+\.[^:\.\-\s]*(?::.*)?/ ? $1 - : die "invalid file `" . ($_[0] && $_[0]->[$FILE]) . "'\n" . backtrace() } -sub packageRelease { $_[0] && $_[0]->[$FILE] =~ /^[^:\s]*-[^:\-\s]+-([^:\-\s]+)\.[^:\.\-\s]*(?::.*)?/ ? $1 - : die "invalid file `" . ($_[0] && $_[0]->[$FILE]) . "'\n" . backtrace() } -sub packageArch { $_[0] && $_[0]->[$FILE] =~ /^[^:\s]*-[^:\-\s]+-[^:\-\s]+\.([^:\.\-\s]*)(?::.*)?/ ? $1 - : die "invalid file `" . ($_[0] && $_[0]->[$FILE]) . "'\n" . backtrace() } -sub packageFile { $_[0] && $_[0]->[$FILE] =~ /^([^:\s]*-[^:\-\s]+-[^:\-\s]+\.[^:\.\-\s]*)(?::(.*))?/ ? ($2 || $1) . ".rpm" - : die "invalid file `" . ($_[0] && $_[0]->[$FILE]) . "'\n" . backtrace() } -sub packageEpoch { $_[0] && $_[0]->[$EPOCH] || 0 } - -sub packageSize { to_int($_[0] && ($_[0]->[$SIZE_DEPS] - ($_[0]->[$INSTALLED_CUMUL_SIZE] || 0))) } -sub packageDepsId { split ' ', ($_[0] && ($_[0]->[$SIZE_DEPS] =~ /^\d*\s*(.*)/)[0]) } - -sub packageFlagSelected { $_[0] && $_[0]->[$FLAGS] & $PKGS_SELECTED } -sub packageFlagForce { $_[0] && $_[0]->[$FLAGS] & $PKGS_FORCE } -sub packageFlagInstalled { $_[0] && $_[0]->[$FLAGS] & $PKGS_INSTALLED } -sub packageFlagBase { $_[0] && $_[0]->[$FLAGS] & $PKGS_BASE } -sub packageFlagUpgrade { $_[0] && $_[0]->[$FLAGS] & $PKGS_UPGRADE } - -sub packageSetFlagSelected { $_[0]->[$FLAGS] &= ~$PKGS_SELECTED; $_[0]->[$FLAGS] |= $_[1] & $PKGS_SELECTED; } - -sub packageSetFlagForce { $_[0] or die "invalid package from\n" . backtrace(); - $_[1] ? ($_[0]->[$FLAGS] |= $PKGS_FORCE) : ($_[0]->[$FLAGS] &= ~$PKGS_FORCE); } -sub packageSetFlagInstalled { $_[0] or die "invalid package from\n" . backtrace(); - $_[1] ? ($_[0]->[$FLAGS] |= $PKGS_INSTALLED) : ($_[0]->[$FLAGS] &= ~$PKGS_INSTALLED); } -sub packageSetFlagBase { $_[0] or die "invalid package from\n" . backtrace(); - $_[1] ? ($_[0]->[$FLAGS] |= $PKGS_BASE) : ($_[0]->[$FLAGS] &= ~$PKGS_BASE); } -sub packageSetFlagUpgrade { $_[0] or die "invalid package from\n" . backtrace(); - $_[1] ? ($_[0]->[$FLAGS] |= $PKGS_UPGRADE) : ($_[0]->[$FLAGS] &= ~$PKGS_UPGRADE); } - +#sub packageHeaderFile { $_[0] ? $_[0]->[$FILE] +# : die "invalid package from\n" . backtrace() } +#sub packageName { $_[0] && $_[0]->[$FILE] =~ /^([^:\s]*)-[^:\-\s]+-[^:\-\s]+\.[^:\.\-\s]*(?::.*)?/ ? $1 +# : die "invalid file `" . ($_[0] && $_[0]->[$FILE]) . "'\n" . backtrace() } +#sub packageVersion { $_[0] && $_[0]->[$FILE] =~ /^[^:\s]*-([^:\-\s]+)-[^:\-\s]+\.[^:\.\-\s]*(?::.*)?/ ? $1 +# : die "invalid file `" . ($_[0] && $_[0]->[$FILE]) . "'\n" . backtrace() } +#sub packageRelease { $_[0] && $_[0]->[$FILE] =~ /^[^:\s]*-[^:\-\s]+-([^:\-\s]+)\.[^:\.\-\s]*(?::.*)?/ ? $1 +# : die "invalid file `" . ($_[0] && $_[0]->[$FILE]) . "'\n" . backtrace() } +#sub packageArch { $_[0] && $_[0]->[$FILE] =~ /^[^:\s]*-[^:\-\s]+-[^:\-\s]+\.([^:\.\-\s]*)(?::.*)?/ ? $1 +# : die "invalid file `" . ($_[0] && $_[0]->[$FILE]) . "'\n" . backtrace() } +#sub packageFile { $_[0] && $_[0]->[$FILE] =~ /^([^:\s]*-[^:\-\s]+-[^:\-\s]+\.[^:\.\-\s]*)(?::(.*))?/ ? ($2 || $1) . ".rpm" +# : die "invalid file `" . ($_[0] && $_[0]->[$FILE]) . "'\n" . backtrace() } +#sub packageEpoch { $_[0] && $_[0]->[$EPOCH] || 0 } +# +#sub packageSize { to_int($_[0] && ($_[0]->[$SIZE_DEPS] - ($_[0]->[$INSTALLED_CUMUL_SIZE] || 0))) } +#sub packageDepsId { split ' ', ($_[0] && ($_[0]->[$SIZE_DEPS] =~ /^\d*\s*(.*)/)[0]) } +# +#sub packageFlagSelected { $_[0] && $_[0]->[$FLAGS] & $PKGS_SELECTED } +#sub packageFlagForce { $_[0] && $_[0]->[$FLAGS] & $PKGS_FORCE } +#sub packageFlagInstalled { $_[0] && $_[0]->[$FLAGS] & $PKGS_INSTALLED } +#sub packageFlagBase { $_[0] && $_[0]->[$FLAGS] & $PKGS_BASE } +#sub packageFlagUpgrade { $_[0] && $_[0]->[$FLAGS] & $PKGS_UPGRADE } +# +#sub packageSetFlagSelected { $_[0]->[$FLAGS] &= ~$PKGS_SELECTED; $_[0]->[$FLAGS] |= $_[1] & $PKGS_SELECTED; } +# +#sub packageSetFlagForce { $_[0] or die "invalid package from\n" . backtrace(); +# $_[1] ? ($_[0]->[$FLAGS] |= $PKGS_FORCE) : ($_[0]->[$FLAGS] &= ~$PKGS_FORCE); } +#sub packageSetFlagInstalled { $_[0] or die "invalid package from\n" . backtrace(); +# $_[1] ? ($_[0]->[$FLAGS] |= $PKGS_INSTALLED) : ($_[0]->[$FLAGS] &= ~$PKGS_INSTALLED); } +#sub packageSetFlagBase { $_[0] or die "invalid package from\n" . backtrace(); +# $_[1] ? ($_[0]->[$FLAGS] |= $PKGS_BASE) : ($_[0]->[$FLAGS] &= ~$PKGS_BASE); } +#sub packageSetFlagUpgrade { $_[0] or die "invalid package from\n" . backtrace(); +# $_[1] ? ($_[0]->[$FLAGS] |= $PKGS_UPGRADE) : ($_[0]->[$FLAGS] &= ~$PKGS_UPGRADE); } +# sub packageMedium { my ($packages, $p) = @_; $p or die "invalid package from\n" . backtrace(); - $packages->{mediums}{$p->[$MEDIUM]} } - -sub packageProvides { $_[1] or die "invalid package from\n" . backtrace(); - map { $_[0]->{depslist}[$_] || die "unkown package id $_" } unpack "s*", $_[1]->[$PROVIDES] } - -sub packageRate { substr($_[0] && $_[0]->[$VALUES], 0, 1) } -sub packageRateRFlags { my ($rate, @flags) = split "\t", $_[0] && $_[0]->[$VALUES]; ($rate, @flags) } -sub packageSetRateRFlags { my ($pkg, $rate, @flags) = @_; $pkg or die "invalid package from\n" . backtrace(); - $pkg->[$VALUES] = join("\t", $rate, @flags) } - -sub packageHeader { $_[0] && $_[0]->[$HEADER] } -sub packageFreeHeader { $_[0] && c::headerFree(delete $_[0]->[$HEADER]) } - -sub packageSelectedOrInstalled { packageFlagSelected($_[0]) || packageFlagInstalled($_[0]) } - -sub packageId { - my ($packages, $pkg) = @_; - my $i = 0; - foreach (@{$packages->{depslist}}) { return $i if $pkg == $packages->{depslist}[$i]; $i++ } - return; -} + foreach (values %{$packages->{mediums}}) { + $p->id >= $_->{start} && $p->id <= $_->{end} and return $_; + } + return } + +#sub packageProvides { $_[1] or die "invalid package from\n" . backtrace(); +# map { $_[0]->{depslist}[$_] || die "unkown package id $_" } unpack "s*", $_[1]->[$PROVIDES] } +# +#sub packageRate { substr($_[0] && $_[0]->[$VALUES], 0, 1) } +#sub packageRateRFlags { my ($rate, @flags) = split "\t", $_[0] && $_[0]->[$VALUES]; ($rate, @flags) } +#sub packageSetRateRFlags { my ($pkg, $rate, @flags) = @_; $pkg or die "invalid package from\n" . backtrace(); +# $pkg->[$VALUES] = join("\t", $rate, @flags) } +# +#sub packageHeader { $_[0] && $_[0]->[$HEADER] } +#sub packageFreeHeader { $_[0] && c::headerFree(delete $_[0]->[$HEADER]) } + +sub packageSelectedOrInstalled { $_[0] && ($_[0]->flag_selected || $_[0]->flag_installed) } + +#sub packageId { +# my ($packages, $pkg) = @_; +# my $i = 0; +# foreach (@{$packages->{depslist}}) { return $i if $pkg == $packages->{depslist}[$i]; $i++ } +# return; +#} sub cleanHeaders { my ($prefix) = @_; @@ -136,28 +141,29 @@ sub extractHeaders { cleanHeaders($prefix); foreach (@$pkgs) { - push @{$medium2pkgs{$_->[$MEDIUM]} ||= []}, $_; + foreach my $medium (values %$media) { + $_->id >= $medium->{start} && $_->id <= $medium->{end} or next; + push @{$medium2pkgs{$medium->{medium}} ||= []}, $_; + } } - foreach (values %medium2pkgs) { - my $medium = $media->{$_->[0][$MEDIUM]}; #- the first one is a valid package pointing to right medium to use. + foreach (keys %medium2pkgs) { + my $medium = $media->{$_}; eval { require packdrake; my $packer = new packdrake("/tmp/$medium->{hdlist}", quiet => 1); - $packer->extract_archive("$prefix/tmp/headers", map { packageHeaderFile($_) } @$_); + $packer->extract_archive("$prefix/tmp/headers", map { $_->header_filename } @{$medium2pkgs{$_}}); }; } foreach (@$pkgs) { - my $f = "$prefix/tmp/headers/". packageHeaderFile($_); - local *H; - open H, $f or log::l("unable to open header file $f: $!"), next; - $_->[$HEADER] = c::headerRead(fileno H, 1) or log::l("unable to read header of package ". packageHeaderFile($_)); + my $f = "$prefix/tmp/headers/". $_->header_filename; + $_->update_header($f) or log::l("unable to open header file $f"), next; } - @$pkgs = grep { $_->[$HEADER] } @$pkgs; } +#- TODO BEFORE TODO #- size and correction size functions for packages. my $B = 1.20873; my $C = 4.98663; #- doesn't take hdlist's into account as getAvailableSpace will do it. @@ -167,8 +173,8 @@ sub invCorrectSize { ($_[0] - $C) / $B } sub selectedSize { my ($packages) = @_; my $size = 0; - foreach (values %{$packages->{names}}) { - packageFlagSelected($_) && !packageFlagInstalled($_) and $size += packageSize($_); + foreach (@{$packages->{depslist}}) { + $_->flag_selected and $size += $_->size; } $size; } @@ -195,21 +201,44 @@ sub size2time { #- a list to search by id. sub packageByName { my ($packages, $name) = @_; - $packages->{names}{$name} or log::l("unknown package `$name'") && undef; + #- search package with given name and compatible with current architecture. + #- take the best one found (most up-to-date). + my @packages; + foreach (keys %{$packages->{provides}{$name} || {}}) { + my $pkg = $packages->{depslist}[$_]; + $pkg->is_arch_compat or next; + $pkg->name eq $name or next; + push @packages, $pkg; + } + my $best; + foreach (@packages) { + if ($best && $best != $_) { + $_->compare_pkg($best) > 0 and $best = $_; + } else { + $best = $_; + } + } + $best or log::l("unknown package `$name'") && undef; } sub packageById { my ($packages, $id) = @_; - my $l = $packages->{depslist}[$id]; #- do not log as id unsupported are still in depslist. - $l && @$l && $l; + my $pkg = $packages->{depslist}[$id]; #- do not log as id unsupported are still in depslist. + $pkg->is_arch_compat && $pkg; } sub packagesOfMedium { my ($packages, $medium) = @_; - grep { $_ && $_->[$MEDIUM] == $medium } @{$packages->{depslist}}; + $medium->{start} <= $medium->{end} ? @{$packages->{depslist}}[$medium->{start} .. $medium->{end}] : (); } sub packagesToInstall { my ($packages) = @_; - grep { packageFlagSelected($_) && !packageFlagInstalled($_) && - packageMedium($packages, $_)->{selected} } values %{$packages->{names}}; + my @packages; + foreach (values %{$packages->{mediums}}) { + $_->{selected} or next; + log::l("examining packagesToInstall of medium $_->{descr}"); + push @packages, grep { $_->flag_selected } packagesOfMedium($packages, $_); + } + log::l("found " .scalar(@packages). " packages to install"); + @packages; } sub allMediums { @@ -221,113 +250,85 @@ sub mediumDescr { $packages->{mediums}{$medium}{descr}; } -#- selection, unselection of package. -sub selectPackage { #($$;$$$) - my ($packages, $pkg, $base, $otherOnly, $check_recursion) = @_; +sub packageRequest { + my ($packages, $pkg) = @_; - #- check for medium selection, if the medium has not been - #- selected, the package cannot be selected. #- check if the same or better version is installed, #- do not select in such case. - $pkg && packageMedium($packages, $pkg)->{selected} && !packageFlagInstalled($pkg) or return; + $pkg && ($pkg->flag_upgrade || !$pkg->flag_installed) or return; + + #- check for medium selection, if the medium has not been + #- selected, the package cannot be selected. + foreach (values %{$packages->{mediums}}) { + !$_->{selected} && $pkg->id >= $_->{start} && $pkg->id <= $_->{end} and return; + } + + return { $pkg->id => 1 }; +} - #- avoid infinite recursion (mainly against badly generated depslist.ordered). - $check_recursion ||= {}; exists $check_recursion->{$pkg->[$FILE]} and return; $check_recursion->{$pkg->[$FILE]} = undef; +sub packageCallbackChoices { + my ($urpm, $db, $state, $choices) = @_; + my $prefer; + foreach (@$choices) { + exists $preferred{$_->name} and $prefer = $_; + $_->name =~ /kernel-\d/ and $prefer ||= $_; + } + $prefer || $choices->[0]; #- first one (for instance). +} - #- make sure base package are set even if already selected. - $base and packageSetFlagBase($pkg, 1); +#- selection, unselection of package. +sub selectPackage { + my ($packages, $pkg, $base, $otherOnly) = @_; #- select package and dependancies, otherOnly may be a reference #- to a hash to indicate package that will strictly be selected #- when value is true, may be selected when value is false (this #- is only used for unselection, not selection) - unless (packageFlagSelected($pkg)) { - foreach (packageDepsId($pkg)) { - if (/\|/) { - #- choice deps should be reselected recursively as no - #- closure on them is computed, this code is exactly the - #- same as pixel's one. - my $preferred; - foreach (split '\|') { - my $dep = packageById($packages, $_) or next; - $preferred ||= $dep; - packageFlagSelected($dep) and $preferred = $dep, last; - packageName($dep) =~ /kernel-\d/ and $preferred = $dep; #- hard coded preference to simple kernel - exists $preferred{packageName($dep)} and $preferred = $dep; - } - $preferred or die "unable to find a package for choice"; - packageFlagSelected($preferred) or log::l("selecting default package as $preferred->[$FILE]"); - selectPackage($packages, $preferred, $base, $otherOnly, $check_recursion); - } else { - #- deps have been closed except for choices, so no need to - #- recursively apply selection, expand base on it. - my $dep = packageById($packages, $_); - $base and packageSetFlagBase($dep, 1); - $otherOnly and !packageFlagSelected($dep) and $otherOnly->{packageName($dep)} = 1; - $otherOnly or packageSetFlagSelected($dep, 1+packageFlagSelected($dep)); - } + my $state = $packages->{state} ||= {}; + $state->{selected} = {}; + $state->{requested} = packageRequest($packages, $pkg) or return; + $packages->resolve_requested($packages->{rpmdb}, $state, no_flag_update => $otherOnly, clear_state => $otherOnly, + callback_choices => \&packageCallbackChoices); + + if ($base || $otherOnly) { + foreach (keys %{$state->{selected}}) { + my $p = $packages->{depslist}[$_] or next; + #- if base is activated, propagate base flag to all selection. + $base and $p->set_flag_base; + $otherOnly and $otherOnly->{$_} = $state->{selected}{$_}; } } - $otherOnly and !packageFlagSelected($pkg) and $otherOnly->{packageName($pkg)} = 1; - $otherOnly or packageSetFlagSelected($pkg, 1+packageFlagSelected($pkg)); 1; } + sub unselectPackage($$;$) { my ($packages, $pkg, $otherOnly) = @_; #- base package are not unselectable, #- and already unselected package are no more unselectable. - packageFlagBase($pkg) and return; - packageFlagSelected($pkg) or return; - - #- dependancies may be used to propose package that may be not - #- usefull for the user, since their counter is just one and - #- they are not used any more by other packages. - #- provides are closed and are taken into account to get possible - #- unselection of package (value false on otherOnly) or strict - #- unselection (value true on otherOnly). - foreach my $provided ($pkg, packageProvides($packages, $pkg)) { - packageFlagBase($provided) and die "a provided package cannot be a base package"; - if (packageFlagSelected($provided)) { - my $unselect_alone = 1; - foreach (packageDepsId($provided)) { - $unselect_alone = 0; - if (/\|/) { - #- this package use a choice of other package, so we have to check - #- if our package is not included in the choice, if this is the - #- case, if must be checked one of the other package are selected. - foreach (split '\|') { - my $dep = packageById($packages, $_) or next; - $dep == $pkg and $unselect_alone |= 1 and next; - packageFlagBase($dep) || packageFlagSelected($dep) and $unselect_alone |= 2; - } - } else { - packageById($packages, $_) == $pkg and $unselect_alone = 1; - } - $unselect_alone == 1 and last; - } - #- if package has been found and nothing more selected, - #- deselect the provided, or we can ignore it safely. - $provided == $pkg || $unselect_alone == 1 or next; - $otherOnly or packageSetFlagSelected($provided, 0); - $otherOnly and $otherOnly->{packageName($provided)} = 1; - } - foreach (map { split '\|' } packageDepsId($provided)) { - my $dep = packageById($packages, $_) or next; - packageFlagBase($dep) and next; - packageFlagSelected($dep) or next; - for (packageFlagSelected($dep)) { - $_ == 1 and do { $otherOnly and $otherOnly->{packageName($dep)} ||= 0; }; - $_ > 1 and do { $otherOnly or packageSetFlagSelected($dep, $_-1); }; - last; - } - } + $pkg->flag_base and return; + $pkg->flag_selected or return; + + #- try to unwind selection (requested or required) by keeping + #- rpmdb is right place. + #TODO + if ($otherOnly) { + $otherOnly->{$pkg->id} = undef; + } else { + $pkg->set_flag_requested(0); + $pkg->set_flag_required(0); + + #- clear state. + my $state = $packages->{state} ||= {}; + $state->{selected} = { $pkg->id }; + $state->{requested} = {}; + $packages->resolve_requested($packages->{rpmdb}, $state, clear_state => 1); } 1; } sub togglePackageSelection($$;$) { my ($packages, $pkg, $otherOnly) = @_; - packageFlagSelected($pkg) ? unselectPackage($packages, $pkg, $otherOnly) : selectPackage($packages, $pkg, 0, $otherOnly); + $pkg->flag_selected ? unselectPackage($packages, $pkg, $otherOnly) : selectPackage($packages, $pkg, 0, $otherOnly); } sub setPackageSelection($$$) { my ($packages, $pkg, $value) = @_; @@ -336,20 +337,38 @@ sub setPackageSelection($$$) { sub unselectAllPackages($) { my ($packages) = @_; - foreach (values %{$packages->{names}}) { - unless (packageFlagBase($_) || packageFlagUpgrade($_)) { - packageSetFlagSelected($_, 0); + my %selected; + foreach (@{$packages->{depslist}}) { + unless ($_->flag_base || $_->flag_installed && $_->flag_selected) { + #- deselect all packages except base or packages that need to be upgraded. + $_->set_flag_requested(0); + $_->set_flag_required(0); + $selected{$_->id} = undef; } } + if (%selected) { + my $state = $packages->{state} ||= {}; + $state->{selected} = \%selected; + $state->{requested} = {}; + $packages->resolve_requested($packages->{rpmdb}, $state, clear_state => 1); + } } sub unselectAllPackagesIncludingUpgradable($) { my ($packages, $removeUpgradeFlag) = @_; - foreach (values %{$packages->{names}}) { - unless (packageFlagBase($_)) { - packageSetFlagSelected($_, 0); - packageSetFlagUpgrade($_, 0); + my %selected; + foreach (@{$packages->{depslist}}) { + unless ($_->flag_base) { + $_->set_flag_requested(0); + $_->set_flag_required(0); + $selected{$_->id} = undef; } } + if (%selected) { + my $state = $packages->{state} ||= {}; + $state->{selected} = \%selected; + $state->{requested} = {}; + $packages->resolve_requested($packages->{rpmdb}, $state, clear_state => 1); + } } sub psUpdateHdlistsDeps { @@ -396,14 +415,18 @@ sub psUpdateHdlistsDeps { } #- this is necessary for urpmi. - install_any::getAndSaveFile("Mandrake/base/$_", "$prefix/var/lib/urpmi/$_") - foreach qw(depslist.ordered provides rpmsrate); + install_any::getAndSaveFile("Mandrake/base/$_", "$prefix/var/lib/urpmi/$_") foreach qw(rpmsrate); } sub psUsingHdlists { my ($prefix, $method) = @_; my $listf = install_any::getFile('Mandrake/base/hdlists') or die "no hdlists found"; - my %packages = ( names => {}, count => 0, depslist => [], mediums => {}); + my $packages = new URPM; + + #- add additional fields used by DrakX. + @{$packages}{qw(count mediums)} = (0, {}); + $packages->{rpmdb} = URPM::DB::open($prefix); + $packages->{rpmdb} ||= new URPM; #- parse hdlists file. my $medium = 1; @@ -415,15 +438,15 @@ sub psUsingHdlists { #- make sure the first medium is always selected! #- by default select all image. - psUsingHdlist($prefix, $method, \%packages, $1, $medium, $2, $3, 1); + psUsingHdlist($prefix, $method, $packages, $1, $medium, $2, $3, 1); ++$medium; } - log::l("psUsingHdlists read " . scalar keys(%{$packages{names}}) . - " headers on " . scalar keys(%{$packages{mediums}}) . " hdlists"); + log::l("psUsingHdlists read " . scalar @{$packages->{depslist}} . + " headers on " . scalar keys(%{$packages->{mediums}}) . " hdlists"); - \%packages; + $packages; } sub psUsingHdlist { @@ -441,8 +464,8 @@ sub psUsingHdlist { rpmsdir => $rpmsdir, #- where is RPMS directory. descr => $descr, fakemedium => $fakemedium, - min => $packages->{count}, - max => -1, #- will be updated after reading current hdlist. +# min => $packages->{count}, +# max => -1, #- will be updated after reading current hdlist. selected => $selected, #- default value is only CD1, it is really the minimal. }; @@ -455,9 +478,9 @@ sub psUsingHdlist { symlinkf $newf, "/tmp/$hdlist"; #- if $fhdlist is defined, this is preferable not to try to find the associated synthesis. + my $newsf = "$prefix/var/lib/urpmi/synthesis.hdlist.$fakemedium.cz" . ($hdlist =~ /\.cz2/ && "2"); unless ($fhdlist) { #- copy existing synthesis file too. - my $newsf = "$prefix/var/lib/urpmi/synthesis.hdlist.$fakemedium.cz" . ($hdlist =~ /\.cz2/ && "2"); install_any::getAndSaveFile("Mandrake/base/synthesis.$hdlist", $newsf); $m->{synthesis_hdlist_size} = -s $newsf; #- keep track of size for post-check. -s $newsf > 0 or unlink $newsf; @@ -467,181 +490,148 @@ sub psUsingHdlist { #- but keep all medium here so that urpmi has the whole set. $method eq 'cdrom' && $medium > 1 && !common::usingRamdisk() and return; - #- extract filename from archive, this take advantage of verifying - #- the archive too. - eval { - require packdrake; - my $packer = new packdrake($newf, quiet => 1); - foreach (@{$packer->{files}}) { - $packer->{data}{$_}[0] eq 'f' or next; - my $pkg = [ (undef) x 8 ]; $pkg->[$FILE] = $_; $pkg->[$MEDIUM] = $medium; - my $specific_arch = packageArch($pkg); - if (!$specific_arch || MDK::Common::System::compat_arch($specific_arch)) { - my $old_pkg = $packages->{names}{packageName($pkg)}; - if ($old_pkg) { - my $epo_compare = 0; #- NO EPOCH AVAILABLE TODO packageEpoch($pkg) <=> packageEpoch($old_pkg); - my $ver_compare = $epo_compare == 0 && versionCompare(packageVersion($pkg), packageVersion($old_pkg)); - my $rel_compare = $ver_compare == 0 && versionCompare(packageRelease($pkg), packageRelease($old_pkg)); - if ($epo_compare > 0 || $ver_compare > 0 || $rel_compare > 0 || - $epo_compare == 0 && $ver_compare == 0 && $rel_compare == 0 && - MDK::Common::System::better_arch($specific_arch, packageArch($old_pkg))) { - log::l("replacing old package $old_pkg->[$FILE] with package $pkg->[$FILE]"); - foreach ($FILE, $MEDIUM) { #- TODO KEEP OLD PARAMETER - $old_pkg->[$_] = $pkg->[$_]; - } - packageFreeHeader($old_pkg); - if (packageFlagInstalled($old_pkg)) { - packageSetFlagInstalled($old_pkg, 0); - selectPackage($packages, $old_pkg); - } - ++$relocated; - } else { - log::l("no need to replace previous package $old_pkg->[$FILE] with newer package $pkg->[$FILE]"); - ++$ignored; - } - } else { - $packages->{names}{packageName($pkg)} = $pkg; - ++$packages->{count}; #- take care of this one, so that desplist will be clean with index of package. - } - } else { - log::l("ignoring package $_ with incompatible arch: $specific_arch"); - ++$ignored; - } - } - }; - - #- update maximal index. - $m->{max} = $packages->{count} - 1; - $m->{max} >= $m->{min} || $relocated > 0 || $ignored > 0 or die "nothing found while parsing $newf"; - $relocated > 0 and log::l("relocated $relocated headers in $hdlist"); - $ignored > 0 and log::l("ignored $ignored headers in $hdlist"); - log::l("read " . ($m->{max} - $m->{min} + 1) . " new headers in $hdlist"); + #- parse synthesis (if available) of directly hdlist (with packing). + if (-s $newsf) { + ($m->{start}, $m->{end}) = $packages->parse_synthesis($newsf); + } elsif (-s $newf) { + ($m->{start}, $m->{end}) = $packages->parse_hdlist($newf, 1); + } else { + die "fatal: no hdlist nor synthesis to read for $fakemedium"; + } + $m->{start} > $m->{end} and die "fatal: nothing read in hdlist or synthesis for $fakemedium"; + log::l("read " . ($m->{end} - $m->{start} + 1) . " packages in $hdlist"); $m; } +#OBSOLETED TODO sub getOtherDeps($$) { - my ($packages, $f) = @_; - - #- this version of getDeps is customized for handling errors more easily and - #- convert reference by name to deps id including closure computation. - local $_; - while (<$f>) { - my ($name, $version, $release, $size, $deps) = /^(\S*)-([^-\s]+)-([^-\s]+)\s+(\d+)\s+(.*)/; - my $pkg = $packages->{names}{$name}; - - $pkg or log::l("ignoring package $name-$version-$release in depslist is not in hdlist"), next; - $version eq packageVersion($pkg) and $release eq packageRelease($pkg) - or log::l("warning package $name-$version-$release in depslist mismatch version or release in hdlist ($version ne ", - packageVersion($pkg), " or $release ne ", packageRelease($pkg), ")"), next; - - my $index = scalar @{$packages->{depslist}}; - $index >= packageMedium($packages, $pkg)->{min} && $index <= packageMedium($packages, $pkg)->{max} - or log::l("ignoring package $name-$version-$release in depslist outside of hdlist indexation"); - - #- here we have to translate referenced deps by name to id. - #- this include a closure on deps too. - my %closuredeps; - @closuredeps{map { packageId($packages, $_), packageDepsId($_) } - grep { $_ } - map { packageByName($packages, $_) or do { log::l("unknown package $_ in depslist for closure"); undef } } - split /\s+/, $deps} = (); - - $pkg->[$SIZE_DEPS] = join " ", $size, keys %closuredeps; - - push @{$packages->{depslist}}, $pkg; - } - - #- check for same number of package in depslist and hdlists, avoid being to hard. - scalar(keys %{$packages->{names}}) == scalar(@{$packages->{depslist}}) - or log::l("other depslist has not same package as hdlist file"); + return; #TODO +# my ($packages, $f) = @_; +# +# #- this version of getDeps is customized for handling errors more easily and +# #- convert reference by name to deps id including closure computation. +# local $_; +# while (<$f>) { +# my ($name, $version, $release, $size, $deps) = /^(\S*)-([^-\s]+)-([^-\s]+)\s+(\d+)\s+(.*)/; +# my $pkg = $packages->{names}{$name}; +# +# $pkg or log::l("ignoring package $name-$version-$release in depslist is not in hdlist"), next; +# $version eq packageVersion($pkg) and $release eq packageRelease($pkg) +# or log::l("warning package $name-$version-$release in depslist mismatch version or release in hdlist ($version ne ", +# packageVersion($pkg), " or $release ne ", packageRelease($pkg), ")"), next; +# +# my $index = scalar @{$packages->{depslist}}; +# $index >= packageMedium($packages, $pkg)->{min} && $index <= packageMedium($packages, $pkg)->{max} +# or log::l("ignoring package $name-$version-$release in depslist outside of hdlist indexation"); +# +# #- here we have to translate referenced deps by name to id. +# #- this include a closure on deps too. +# my %closuredeps; +# @closuredeps{map { packageId($packages, $_), packageDepsId($_) } +# grep { $_ } +# map { packageByName($packages, $_) or do { log::l("unknown package $_ in depslist for closure"); undef } } +# split /\s+/, $deps} = (); +# +# $pkg->[$SIZE_DEPS] = join " ", $size, keys %closuredeps; +# +# push @{$packages->{depslist}}, $pkg; +# } +# +# #- check for same number of package in depslist and hdlists, avoid being to hard. +# scalar(keys %{$packages->{names}}) == scalar(@{$packages->{depslist}}) +# or log::l("other depslist has not same package as hdlist file"); } +#OBSOLETED TODO sub getDeps { - my ($prefix, $packages) = @_; - - #- this is necessary for urpmi. - install_any::getAndSaveFile('Mandrake/base/depslist.ordered', "$prefix/var/lib/urpmi/depslist.ordered"); - install_any::getAndSaveFile('Mandrake/base/provides', "$prefix/var/lib/urpmi/provides"); - - #- beware of heavily mismatching depslist.ordered file against hdlist files. - my $mismatch = 0; - - #- count the number of packages in deplist that are also in hdlist - my $nb_deplist = 0; - - #- update dependencies list, provides attributes are updated later - #- cross reference to be resolved on id (think of loop requires) - #- provides should be updated after base flag has been set to save - #- memory. - local *F; open F, "$prefix/var/lib/urpmi/depslist.ordered" or die "can't find dependancies list"; - local $_; - while (<F>) { - my ($name, $version, $release, $arch, $epoch, $sizeDeps) = - /^([^:\s]*)-([^:\-\s]+)-([^:\-\s]+)\.([^:\.\-\s]*)(?::(\d+)\S*)?\s+(.*)/; - my $pkg = $packages->{names}{$name}; - - #- these verification are necessary in case of error, but are no more fatal as - #- in case of only one medium taken into account during install, there should be - #- silent warning for package which are unknown at this point. - $pkg or - log::l("ignoring $name-$version-$release.$arch in depslist is not in hdlist"); - $pkg && $version ne packageVersion($pkg) and - log::l("ignoring $name-$version-$release.$arch in depslist mismatch version in hdlist"), $pkg = undef; - $pkg && $release ne packageRelease($pkg) and - log::l("ignoring $name-$version-$release.$arch in depslist mismatch release in hdlist"), $pkg = undef; - $pkg && $arch ne packageArch($pkg) and - log::l("ignoring $name-$version-$release.$arch in depslist mismatch arch in hdlist"), $pkg = undef; - - if ($pkg) { - $nb_deplist++; - $epoch && $epoch > 0 and $pkg->[$EPOCH] = $epoch; #- only 5% of the distribution use epoch (serial). - $pkg->[$SIZE_DEPS] = $sizeDeps; - - #- check position of package in depslist according to precomputed - #- limit by hdlist, very strict :-) - #- above warning have chance to raise an exception here, but may help - #- for debugging. - my $i = scalar @{$packages->{depslist}}; - $i >= packageMedium($packages, $pkg)->{min} && $i <= packageMedium($packages, $pkg)->{max} or - log::l("inconsistency in position for $name-$version-$release.$arch in depslist and hdlist"), $mismatch = 1; - } - - #- package are already sorted in depslist to enable small transaction and multiple medium. - push @{$packages->{depslist}}, $pkg; - } - - #- check for mismatching package, it should break with above die unless depslist has too many errors! - $mismatch and die "depslist.ordered mismatch against hdlist files"; - - #- check for same number of package in depslist and hdlists. - my $nb_hdlist = keys %{$packages->{names}}; - $nb_hdlist == $nb_deplist or die "depslist.ordered has not same package as hdlist files ($nb_deplist != $nb_hdlist)"; + return; #TODO +# my ($prefix, $packages) = @_; +# +# #- this is necessary for urpmi. +# install_any::getAndSaveFile('Mandrake/base/depslist.ordered', "$prefix/var/lib/urpmi/depslist.ordered"); +# install_any::getAndSaveFile('Mandrake/base/provides', "$prefix/var/lib/urpmi/provides"); +# +# #- beware of heavily mismatching depslist.ordered file against hdlist files. +# my $mismatch = 0; +# +# #- count the number of packages in deplist that are also in hdlist +# my $nb_deplist = 0; +# +# #- update dependencies list, provides attributes are updated later +# #- cross reference to be resolved on id (think of loop requires) +# #- provides should be updated after base flag has been set to save +# #- memory. +# local *F; open F, "$prefix/var/lib/urpmi/depslist.ordered" or die "can't find dependancies list"; +# local $_; +# while (<F>) { +# my ($name, $version, $release, $arch, $epoch, $sizeDeps) = +# /^([^:\s]*)-([^:\-\s]+)-([^:\-\s]+)\.([^:\.\-\s]*)(?::(\d+)\S*)?\s+(.*)/; +# my $pkg = $packages->{names}{$name}; +# +# #- these verification are necessary in case of error, but are no more fatal as +# #- in case of only one medium taken into account during install, there should be +# #- silent warning for package which are unknown at this point. +# $pkg or +# log::l("ignoring $name-$version-$release.$arch in depslist is not in hdlist"); +# $pkg && $version ne packageVersion($pkg) and +# log::l("ignoring $name-$version-$release.$arch in depslist mismatch version in hdlist"), $pkg = undef; +# $pkg && $release ne packageRelease($pkg) and +# log::l("ignoring $name-$version-$release.$arch in depslist mismatch release in hdlist"), $pkg = undef; +# $pkg && $arch ne packageArch($pkg) and +# log::l("ignoring $name-$version-$release.$arch in depslist mismatch arch in hdlist"), $pkg = undef; +# +# if ($pkg) { +# $nb_deplist++; +# $epoch && $epoch > 0 and $pkg->[$EPOCH] = $epoch; #- only 5% of the distribution use epoch (serial). +# $pkg->[$SIZE_DEPS] = $sizeDeps; +# +# #- check position of package in depslist according to precomputed +# #- limit by hdlist, very strict :-) +# #- above warning have chance to raise an exception here, but may help +# #- for debugging. +# my $i = scalar @{$packages->{depslist}}; +# $i >= packageMedium($packages, $pkg)->{min} && $i <= packageMedium($packages, $pkg)->{max} or +# log::l("inconsistency in position for $name-$version-$release.$arch in depslist and hdlist"), $mismatch = 1; +# } +# +# #- package are already sorted in depslist to enable small transaction and multiple medium. +# push @{$packages->{depslist}}, $pkg; +# } +# +# #- check for mismatching package, it should break with above die unless depslist has too many errors! +# $mismatch and die "depslist.ordered mismatch against hdlist files"; +# +# #- check for same number of package in depslist and hdlists. +# my $nb_hdlist = keys %{$packages->{names}}; +# $nb_hdlist == $nb_deplist or die "depslist.ordered has not same package as hdlist files ($nb_deplist != $nb_hdlist)"; } +#OBSOLETED TODO sub getProvides($) { - my ($packages) = @_; - - #- update provides according to dependencies, here are stored - #- reference to package directly and choice are included, this - #- assume only 1 of the choice is selected, else on unselection - #- the provided package will be deleted where other package still - #- need it. - #- base package are not updated because they cannot be unselected, - #- this save certainly a lot of memory since most of them may be - #- needed by a large number of package. - #- now using a packed of signed short, this means no more than 32768 - #- packages can be managed by DrakX (currently about 2000). - my $i = 0; - foreach my $pkg (@{$packages->{depslist}}) { - $pkg or next; - unless (packageFlagBase($pkg)) { - foreach (map { split '\|' } grep { !/^NOTFOUND_/ } packageDepsId($pkg)) { - my $provided = packageById($packages, $_) or next; - packageFlagBase($provided) or $provided->[$PROVIDES] = pack "s*", (unpack "s*", $provided->[$PROVIDES]), $i; - } - } - ++$i; - } + return; #TODO +# my ($packages) = @_; +# +# #- update provides according to dependencies, here are stored +# #- reference to package directly and choice are included, this +# #- assume only 1 of the choice is selected, else on unselection +# #- the provided package will be deleted where other package still +# #- need it. +# #- base package are not updated because they cannot be unselected, +# #- this save certainly a lot of memory since most of them may be +# #- needed by a large number of package. +# #- now using a packed of signed short, this means no more than 32768 +# #- packages can be managed by DrakX (currently about 2000). +# my $i = 0; +# foreach my $pkg (@{$packages->{depslist}}) { +# $pkg or next; +# unless (packageFlagBase($pkg)) { +# foreach (map { split '\|' } grep { !/^NOTFOUND_/ } packageDepsId($pkg)) { +# my $provided = packageById($packages, $_) or next; +# packageFlagBase($provided) or $provided->[$PROVIDES] = pack "s*", (unpack "s*", $provided->[$PROVIDES]), $i; +# } +# } +# ++$i; +# } } sub read_rpmsrate { @@ -691,25 +681,24 @@ sub read_rpmsrate { foreach (split ' ', $data) { if ($packages) { my $p = packageByName($packages, $_) or next; - my @m2 = - map { if_($_ && packageName($_) =~ /locales-(.*)/, qq(LOCALES"$1")) } - map { packageById($packages, $_) } packageDepsId($p); - + my @m2 = map { if_(/locales-(.*)/, qq(LOCALES"$1")) } $p->requires_nosense; my @m3 = ((grep { !/^\d$/ } @m), @m2); if (member('INSTALL', @m3)) { member('NOCOPY', @m3) or push @{$packages->{needToCopy} ||= []}, $_; next; #- don't need to put INSTALL flag for a package. } - if (packageRate($p)) { - my ($rate2, @m4) = packageRateRFlags($p); + if ($p->rate) { + my @m4 = $p->rflags; if (@m3 > 1 || @m4 > 1) { log::l("can't handle complicate flags for packages appearing twice ($_)"); $fatal_error++; } - log::l("package $_ appearing twice with different rates ($rate != $rate2)") if $rate != $rate2; - packageSetRateRFlags($p, $rate, "$m3[0]||$m4[0]"); + log::l("package $_ appearing twice with different rates ($rate != ".$p->rate.")") if $rate != $p->rate; + $p->set_rate($rate); + $p->set_rflags("$m3[0]||$m4[0]"); } else { - packageSetRateRFlags($p, $rate, @m3); + $p->set_rate($rate); + $p->set_rflags(@m3); } } else { print "$_ = ", join(" && ", @m), "\n"; @@ -755,10 +744,10 @@ sub saveCompssUsers { my @fl = @{$compssUsers->{$_}{flags}}; my %fl; $fl{$_} = 1 foreach @fl; $flat .= $compssUsers->{$_}{verbatim}; - foreach my $p (values %{$packages->{names}}) { - my ($rate, @flags) = packageRateRFlags($p); - if ($rate && grep { grep { !/^!/ && $fl{$_} } split('\|\|') } @flags) { - $flat .= sprintf "\t%d %s\n", $rate, packageName($p); + foreach my $p (@{$packages->{depslist}}) { + my @flags = $p->rflags; + if ($p->rate && grep { grep { !/^!/ && $fl{$_} } split('\|\|') } @flags) { + $flat .= sprintf "\t%d %s\n", $p->rate, $p->name; } } } @@ -766,42 +755,46 @@ sub saveCompssUsers { } sub setSelectedFromCompssList { - my ($packages, $compssUsersChoice, $min_level, $max_size, $otherOnly) = @_; + my ($packages, $compssUsersChoice, $min_level, $max_size) = @_; $compssUsersChoice->{TRUE} = 1; #- ensure TRUE is set my $nb = selectedSize($packages); - foreach my $p (sort { packageRate($b) <=> packageRate($a) } values %{$packages->{names}}) { - my ($rate, @flags) = packageRateRFlags($p); + foreach my $p (sort { $b->rate <=> $a->rate } @{$packages->{depslist}}) { + my @flags = $p->rflags; next if - !$rate || $rate < $min_level || + !$p->rate || $p->rate < $min_level || grep { !grep { /^!(.*)/ ? !$compssUsersChoice->{$1} : $compssUsersChoice->{$_} } split('\|\|') } @flags; #- determine the packages that will be selected when #- selecting $p. the packages are not selected. - my %newSelection; - selectPackage($packages, $p, 0, \%newSelection); + my $state = $packages->{state} ||= {}; + $state->{selected} = {}; + $state->{requested} = packageRequest($packages, $p) || {}; + + $packages->resolve_requested($packages->{rpmdb}, $state, no_flag_update => 1, + callback_choices => \&packageCallbackChoices); #- this enable an incremental total size. my $old_nb = $nb; - foreach (grep { $newSelection{$_} } keys %newSelection) { - $nb += packageSize($packages->{names}{$_}); + foreach (keys %{$state->{selected}}) { + my $p = $packages->{depslist}[$_] or next; + $nb += $p->size; } if ($max_size && $nb > $max_size) { $nb = $old_nb; - $min_level = packageRate($p); + $min_level = $p->rate; + $state->{requested} = {}; #- ensure no newer package will be selected. + $packages->resolve_requested($packages->{rpmdb}, $state, clear_state => 1); last; } - #- at this point the package can safely be selected. - if ($otherOnly) { - selectPackage($packages, $p, 0, $otherOnly); - } else { - selectPackage($packages, $p); + #- do the effective selection (was not done due to no_flag_update option used. + foreach (keys %{$state->{selected}}) { + my $pkg = $packages->{depslist}[$_]; + $state->{selected}{$_} ? $pkg->set_flag_requested : $pkg->set_flag_required; } } - unless ($otherOnly) { - log::l("setSelectedFromCompssList: reached size ", formatXiB($nb), ", up to indice $min_level (less than ", formatXiB($max_size), ")"); - log::l("setSelectedFromCompssList: ", join(" ", sort map { packageName($_) } grep { packageFlagSelected($_) } @{$packages->{depslist}})); - } + log::l("setSelectedFromCompssList: reached size ", formatXiB($nb), ", up to indice $min_level (less than ", formatXiB($max_size), ")"); + log::l("setSelectedFromCompssList: ", join(" ", sort map { $_->name } grep { $_->flag_selected } @{$packages->{depslist}})); $min_level; } @@ -809,13 +802,17 @@ sub setSelectedFromCompssList { #- just saves the selected packages, call setSelectedFromCompssList and restores the selected packages sub saveSelected { my ($packages) = @_; - my @l = values %{$packages->{names}}; - my @flags = map { packageFlagSelected($_) } @l; + my @l = @{$packages->{depslist}}; + my @flags = map { ($_->flag_requested && 1) + ($_->flag_required && 2) + ($_->flag_upgrade && 4) } @l; [ $packages, \@l, \@flags ]; } sub restoreSelected { my ($packages, $l, $flags) = @{$_[0]}; - mapn { packageSetFlagSelected(@_) } $l, $flags; + mapn { my ($pkg, $flag) = @_; + $pkg->set_flag_requested($flag & 1); + $pkg->set_flag_required($flag & 2); + $pkg->set_flag_upgrade($flag & 4); + } $l, $flags; } sub computeGroupSize { @@ -860,30 +857,31 @@ sub computeGroupSize { } my (%group, %memo); - foreach my $p (values %{$packages->{names}}) { - my ($rate, @flags) = packageRateRFlags($p); - next if !$rate || $rate < $min_level; + foreach my $p (@{$packages->{depslist}}) { + my @flags = $p->rflags; + next if !$p->rate || $p->rate < $min_level; my $flags = join("\t", @flags = or_ify(@flags)); - $group{packageName($p)} = ($memo{$flags} ||= or_clean(@flags)); + $group{$p->name} = ($memo{$flags} ||= or_clean(@flags)); #- determine the packages that will be selected when selecting $p. the packages are not selected. my %newSelection; selectPackage($packages, $p, 0, \%newSelection); - foreach (grep { $newSelection{$_} } keys %newSelection) { - my $s = $group{$_} || do { - $packages->{names}{$_}[$VALUES] =~ /\t(.*)/; - join("\t", or_ify(split("\t", $1))); + foreach (keys %newSelection) { + my $p = $packages->{depslist}[$_] or next; + my $s = $group{$p->name} || do { + join("\t", or_ify($p->rflags)); }; next if length($s) > 80; # HACK, truncated too complicated expressions, too costly my $m = "$flags\t$s"; - $group{$_} = ($memo{$m} ||= or_clean(@flags, split("\t", $s))); + $group{$p->name} = ($memo{$m} ||= or_clean(@flags, split("\t", $s))); } } my (%sizes, %pkgs); while (my ($k, $v) = each %group) { + my $pkg = packageByName($packages, $k) or next; push @{$pkgs{$v}}, $k; - $sizes{$v} += packageSize($packages->{names}{$k}); + $sizes{$v} += $pkg->size; } log::l(sprintf "%s %dMB %s", $_, $sizes{$_} / sqr(1024), join(',', @{$pkgs{$_}})) foreach keys %sizes; \%sizes, \%pkgs; @@ -899,19 +897,11 @@ sub init_db { CORE::select((CORE::select(LOG), $| = 1)[0]); c::rpmErrorSetCallback(fileno LOG); #- c::rpmSetVeryVerbose(); - - log::l("reading /usr/lib/rpm/rpmrc"); - c::rpmReadConfigFiles() or die "can't read rpm config files"; - log::l("\tdone"); } sub rebuild_db_open_for_traversal { my ($packages, $prefix) = @_; - log::l("reading /usr/lib/rpm/rpmrc"); - c::rpmReadConfigFiles() or die "can't read rpm config files"; - log::l("\tdone"); - unless (exists $packages->{rebuild_db}) { if (my $pid = fork()) { waitpid $pid, 0; @@ -921,14 +911,14 @@ sub rebuild_db_open_for_traversal { my $rebuilddb_dir = "$prefix/var/lib/rpmrebuilddb.$$"; -d $rebuilddb_dir and log::l("removing stale directory $rebuilddb_dir"), rm_rf($rebuilddb_dir); - c::rpmdbRebuild($prefix) or log::l("rebuilding of rpm database failed: ". c::rpmErrorString()), c::_exit(2); + URPM::DB::rebuild($prefix) or log::l("rebuilding of rpm database failed: ". c::rpmErrorString()), c::_exit(2); c::_exit(0); } $packages->{rebuild_db} = undef; } - my $db = c::rpmdbOpenForTraversal($prefix) or die "unable to open $prefix/var/lib/rpm/Packages"; + my $db = URPM::DB::open($prefix) or die "unable to open $prefix/var/lib/rpm/Packages"; log::l("opened rpm database for examining existing packages"); $db; @@ -960,19 +950,6 @@ sub done_db { close LOG; } -sub versionCompare($$) { - goto &c::rpmvercmp; -} -#- old code using perl version, still broken on some case. -#- my ($a, $b) = @_; -#- local $_; -#- -#- while ($a || $b) { -#- my ($sb, $sa) = map { $1 if $a =~ /^\W*\d/ ? s/^\W*0*(\d+)// : s/^\W*(\D*)// } ($b, $a); -#- $_ = ($sa =~ /^\d/ || $sb =~ /^\d/) && length($sa) <=> length($sb) || $sa cmp $sb and return $_ || 0; -#- $sa eq '' && $sb eq '' and return $a cmp $b || 0; -#- } - sub selectPackagesAlreadyInstalled { my ($packages, $prefix) = @_; @@ -980,340 +957,349 @@ sub selectPackagesAlreadyInstalled { $packages->{rebuild_db} = "oem does not need rebuilding the rpm db"; my $db = rebuild_db_open_for_traversal($packages, $prefix); - #- this method has only one objectif, check the presence of packages - #- already installed and avoid installing them again. this is to be used - #- with oem installation, if the database exists, preselect the packages - #- installed WHATEVER their version/release (log if a problem is perceived - #- is enough). - c::rpmdbTraverse($db, sub { - my ($header) = @_; - my $p = $packages->{names}{c::headerGetEntry($header, 'name')}; - - if ($p) { - my $epoch_cmp = c::headerGetEntry($header, 'epoch') <=> packageEpoch($p); - my $version_cmp = $epoch_cmp == 0 && versionCompare(c::headerGetEntry($header, 'version'), - packageVersion($p)); - my $version_rel_test = $epoch_cmp > 0 || $epoch_cmp == 0 && - ($version_cmp > 0 || $version_cmp == 0 && - versionCompare(c::headerGetEntry($header, 'release'), packageRelease($p)) >= 0); - $version_rel_test or log::l("keeping an older package, avoiding selecting $p->[$FILE]"); - packageSetFlagInstalled($p, 1); - } - }); - - #- close db, job finished ! - c::rpmdbClose($db); + $packages->compute_installed_flags($db); log::l("done selecting packages to upgrade"); } +#OBSOLETED TODO sub selectPackagesToUpgrade($$$;$$) { - my ($packages, $prefix, $base, $toRemove, $toSave) = @_; - local $_; #- else perl complains on the map { ... } grep { ... } @...; - - local (*UPGRADE_INPUT, *UPGRADE_OUTPUT); pipe UPGRADE_INPUT, UPGRADE_OUTPUT; - if (my $pid = fork()) { - @{$toRemove || []} = (); #- reset this one. - - close UPGRADE_OUTPUT; - while (<UPGRADE_INPUT>) { - chomp; - my ($action, $name) = /^([\w\d]*):(.*)/; - for ($action) { - /remove/ and do { push @$toRemove, $name; next }; - /keepfiles/ and do { push @$toSave, $name; next }; - - my $p = $packages->{names}{$name} or die "unable to find package ($name)"; - /^\d*$/ and do { $p->[$INSTALLED_CUMUL_SIZE] = $action; next }; - /installed/ and do { packageSetFlagInstalled($p, 1); next }; - /select/ and do { selectPackage($packages, $p); next }; - - die "unknown action ($action)"; - } - } - close UPGRADE_INPUT; - waitpid $pid, 0; - } else { - close UPGRADE_INPUT; - - my $db = rebuild_db_open_for_traversal($packages, $prefix); - #- used for package that are not correctly updated. - #- should only be used when nothing else can be done correctly. - my %upgradeNeedRemove = ( -# 'libstdc++' => 1, -# 'compat-glibc' => 1, -# 'compat-libs' => 1, - ); - - #- generel purpose for forcing upgrade of package whatever version is. - my %packageNeedUpgrade = ( - #'lilo' => 1, #- this package has been misnamed in 7.0. - ); - - #- help removing package which may have different release numbering - my %toRemove; map { $toRemove{$_} = 1 } @{$toRemove || []}; - - #- help searching package to upgrade in regard to already installed files. - my %installedFilesForUpgrade; - - #- help keeping memory by this set of package that have been obsoleted. - my %obsoletedPackages; - - #- make a subprocess here for reading filelist, this is important - #- not to waste a lot of memory for the main program which will fork - #- latter for each transaction. - local (*INPUT, *OUTPUT_CHILD); pipe INPUT, OUTPUT_CHILD; - local (*INPUT_CHILD, *OUTPUT); pipe INPUT_CHILD, OUTPUT; - if (my $pid = fork()) { - close INPUT_CHILD; - close OUTPUT_CHILD; - select((select(OUTPUT), $| = 1)[0]); - - #- internal reading from interactive mode of parsehdlist. - #- takes a code to call with the line read, this avoid allocating - #- memory for that. - my $ask_child = sub { - my ($name, $tag, $code) = @_; - $code or die "no callback code for parsehdlist output"; - print OUTPUT "$name:$tag\n"; + return; +# my ($packages, $prefix, $base, $toRemove, $toSave) = @_; +# local $_; #- else perl complains on the map { ... } grep { ... } @...; +# +# local (*UPGRADE_INPUT, *UPGRADE_OUTPUT); pipe UPGRADE_INPUT, UPGRADE_OUTPUT; +# if (my $pid = fork()) { +# @{$toRemove || []} = (); #- reset this one. +# +# close UPGRADE_OUTPUT; +# while (<UPGRADE_INPUT>) { +# chomp; +# my ($action, $name) = /^([\w\d]*):(.*)/; +# for ($action) { +# /remove/ and do { push @$toRemove, $name; next }; +# /keepfiles/ and do { push @$toSave, $name; next }; +# +# my $p = $packages->{names}{$name} or die "unable to find package ($name)"; +# /^\d*$/ and do { $p->[$INSTALLED_CUMUL_SIZE] = $action; next }; +# /installed/ and do { packageSetFlagInstalled($p, 1); next }; +# /select/ and do { selectPackage($packages, $p); next }; +# +# die "unknown action ($action)"; +# } +# } +# close UPGRADE_INPUT; +# waitpid $pid, 0; +# } else { +# close UPGRADE_INPUT; +# +# my $db = rebuild_db_open_for_traversal($packages, $prefix); +# #- used for package that are not correctly updated. +# #- should only be used when nothing else can be done correctly. +# my %upgradeNeedRemove = ( +## 'libstdc++' => 1, +## 'compat-glibc' => 1, +## 'compat-libs' => 1, +# ); +# +# #- generel purpose for forcing upgrade of package whatever version is. +# my %packageNeedUpgrade = ( +# #'lilo' => 1, #- this package has been misnamed in 7.0. +# ); +# +# #- help removing package which may have different release numbering +# my %toRemove; map { $toRemove{$_} = 1 } @{$toRemove || []}; +# +# #- help searching package to upgrade in regard to already installed files. +# my %installedFilesForUpgrade; +# +# #- help keeping memory by this set of package that have been obsoleted. +# my %obsoletedPackages; +# +# #- make a subprocess here for reading filelist, this is important +# #- not to waste a lot of memory for the main program which will fork +# #- latter for each transaction. +# local (*INPUT, *OUTPUT_CHILD); pipe INPUT, OUTPUT_CHILD; +# local (*INPUT_CHILD, *OUTPUT); pipe INPUT_CHILD, OUTPUT; +# if (my $pid = fork()) { +# close INPUT_CHILD; +# close OUTPUT_CHILD; +# select((select(OUTPUT), $| = 1)[0]); +# +# #- internal reading from interactive mode of parsehdlist. +# #- takes a code to call with the line read, this avoid allocating +# #- memory for that. +# my $ask_child = sub { +# my ($name, $tag, $code) = @_; +# $code or die "no callback code for parsehdlist output"; +# print OUTPUT "$name:$tag\n"; +# +# local $_; +# while (<INPUT>) { +# chomp; +# /^\s*$/ and last; +# $code->($_); +# } +# }; +# +# #- select packages which obseletes other package, obselete package are not removed, +# #- should we remove them ? this could be dangerous ! +# foreach my $p (values %{$packages->{names}}) { +# $ask_child->(packageName($p), "obsoletes", sub { +# #- take care of flags and version and release if present +# local ($_) = @_; +# if (my ($n,$o,$v,$r) = /^(\S*)\s*(\S*)\s*([^\s-]*)-?(\S*)/) { +# my $obsoleted = 0; +# my $check_obsoletes = sub { +# my ($header) = @_; +# (!$v || eval(versionCompare(c::headerGetEntry($header, 'version'), $v) . $o . 0)) && +# (!$r || versionCompare(c::headerGetEntry($header, 'version'), $v) != 0 || +# eval(versionCompare(c::headerGetEntry($header, 'release'), $r) . $o . 0)) or return; +# ++$obsoleted; +# }; +# c::rpmdbNameTraverse($db, $n, $check_obsoletes); +# if ($obsoleted > 0) { +# log::l("selecting " . packageName($p) . " by selection on obsoletes"); +# $obsoletedPackages{$1} = undef; +# selectPackage($packages, $p); +# } +# } +# }); +# } +# +# #- mark all files which are not in /etc/rc.d/ for packages which are already installed but which +# #- are not in the packages list to upgrade. +# #- the 'installed' property will make a package unable to be selected, look at select. +# c::rpmdbTraverse($db, sub { +# my ($header) = @_; +# my $otherPackage = (c::headerGetEntry($header, 'release') !~ /mdk\w*$/ && +# (c::headerGetEntry($header, 'name'). '-' . +# c::headerGetEntry($header, 'version'). '-' . +# c::headerGetEntry($header, 'release'))); +# my $p = $packages->{names}{c::headerGetEntry($header, 'name')}; +# +# if ($p) { +# my $epoch_cmp = c::headerGetEntry($header, 'epoch') <=> packageEpoch($p); +# my $version_cmp = $epoch_cmp == 0 && versionCompare(c::headerGetEntry($header, 'version'), +# packageVersion($p)); +# my $version_rel_test = $epoch_cmp > 0 || $epoch_cmp == 0 && +# ($version_cmp > 0 || $version_cmp == 0 && +# versionCompare(c::headerGetEntry($header, 'release'), packageRelease($p)) >= 0); +# if ($packageNeedUpgrade{packageName($p)}) { +# log::l("package ". packageName($p) ." need to be upgraded"); +# } elsif ($version_rel_test) { #- by default, package are upgraded whatever version is ! +# if ($otherPackage && $version_cmp <= 0) { +# log::l("force upgrading $otherPackage since it will not be updated otherwise"); +# } else { +# #- let the parent known this installed package. +# print UPGRADE_OUTPUT "installed:" . packageName($p) . "\n"; +# packageSetFlagInstalled($p, 1); +# } +# } elsif ($upgradeNeedRemove{packageName($p)}) { +# my $otherPackage = (c::headerGetEntry($header, 'name'). '-' . +# c::headerGetEntry($header, 'version'). '-' . +# c::headerGetEntry($header, 'release')); +# log::l("removing $otherPackage since it will not upgrade correctly!"); +# $toRemove{$otherPackage} = 1; #- force removing for theses other packages, select our. +# } +# } else { +# if (exists $obsoletedPackages{c::headerGetEntry($header, 'name')}) { +# my @files = c::headerGetEntry($header, 'filenames'); +# @installedFilesForUpgrade{grep { ($_ !~ m|^/dev/| && $_ !~ m|^/etc/rc.d/| && $_ !~ m|\.la$| && +# ! -d "$prefix/$_" && ! -l "$prefix/$_") } @files} = (); +# } +# } +# }); +# +# #- find new packages to upgrade. +# foreach my $p (values %{$packages->{names}}) { +# my $skipThis = 0; +# my $count = c::rpmdbNameTraverse($db, packageName($p), sub { +# my ($header) = @_; +# $skipThis ||= packageFlagInstalled($p); +# }); +# +# #- skip if not installed (package not found in current install). +# $skipThis ||= ($count == 0); +# +# #- make sure to upgrade package that have to be upgraded. +# $packageNeedUpgrade{packageName($p)} and $skipThis = 0; +# +# #- select the package if it is already installed with a lower version or simply not installed. +# unless ($skipThis) { +# my $cumulSize; +# +# selectPackage($packages, $p); +# +# #- keep in mind installed files which are not being updated. doing this costs in +# #- execution time but use less memory, else hash all installed files and unhash +# #- all file for package marked for upgrade. +# c::rpmdbNameTraverse($db, packageName($p), sub { +# my ($header) = @_; +# $cumulSize += c::headerGetEntry($header, 'size'); +# my @files = c::headerGetEntry($header, 'filenames'); +# @installedFilesForUpgrade{grep { ($_ !~ m|^/dev/| && $_ !~ m|^/etc/rc.d/| && $_ !~ m|\.la$| && +# ! -d "$prefix/$_" && ! -l "$prefix/$_") } @files} = (); +# }); +# +# $ask_child->(packageName($p), "files", sub { +# delete $installedFilesForUpgrade{$_[0]}; +# }); +# +# #- keep in mind the cumul size of installed package since they will be deleted +# #- on upgrade, only for package that are allowed to be upgraded. +# if (allowedToUpgrade(packageName($p))) { +# print UPGRADE_OUTPUT "$cumulSize:" . packageName($p) . "\n"; +# } +# } +# } +# +# #- unmark all files for all packages marked for upgrade. it may not have been done above +# #- since some packages may have been selected by depsList. +# foreach my $p (values %{$packages->{names}}) { +# if (packageFlagSelected($p)) { +# $ask_child->(packageName($p), "files", sub { +# delete $installedFilesForUpgrade{$_[0]}; +# }); +# } +# } +# +# #- select packages which contains marked files, then unmark on selection. +# #- a special case can be made here, the selection is done only for packages +# #- requiring locales if the locales are selected. +# #- another special case are for devel packages where fixes over the time has +# #- made some files moving between the normal package and its devel couterpart. +# #- if only one file is affected, no devel package is selected. +# foreach my $p (values %{$packages->{names}}) { +# unless (packageFlagSelected($p)) { +# my $toSelect = 0; +# $ask_child->(packageName($p), "files", sub { +# if ($_[0] !~ m|^/dev/| && $_[0] !~ m|^/etc/rc.d/| && $_ !~ m|\.la$| && exists $installedFilesForUpgrade{$_[0]}) { +# ++$toSelect if ! -d "$prefix/$_[0]" && ! -l "$prefix/$_[0]"; +# } +# delete $installedFilesForUpgrade{$_[0]}; +# }); +# if ($toSelect) { +# if ($toSelect <= 1 && packageName($p) =~ /-devel/) { +# log::l("avoid selecting " . packageName($p) . " as not enough files will be updated"); +# } else { +# #- default case is assumed to allow upgrade. +# my @deps = map { my $p = packageById($packages, $_); +# if_($p && packageName($p) =~ /locales-/, $p) } packageDepsId($p); +# if (@deps == 0 || @deps > 0 && (grep { !packageFlagSelected($_) } @deps) == 0) { +# log::l("selecting " . packageName($p) . " by selection on files"); +# selectPackage($packages, $p); +# } else { +# log::l("avoid selecting " . packageName($p) . " as its locales language is not already selected"); +# } +# } +# } +# } +# } +# +# #- clean memory... +# %installedFilesForUpgrade = (); +# +# #- no need to still use the child as this point, we can let him to terminate. +# close OUTPUT; +# close INPUT; +# waitpid $pid, 0; +# } else { +# close INPUT; +# close OUTPUT; +# open STDIN, "<&INPUT_CHILD"; +# open STDOUT, ">&OUTPUT_CHILD"; +# exec if_($ENV{LD_LOADER}, $ENV{LD_LOADER}), "parsehdlist", "--interactive", map { "/tmp/$_->{hdlist}" } values %{$packages->{mediums}} +# or c::_exit(1); +# } +# +# #- let the parent known about what we found here! +# foreach my $p (values %{$packages->{names}}) { +# print UPGRADE_OUTPUT "select:" . packageName($p) . "\n" if packageFlagSelected($p); +# } +# +# #- clean false value on toRemove. +# delete $toRemove{''}; +# +# #- get filenames that should be saved for packages to remove. +# #- typically config files, but it may broke for packages that +# #- are very old when compabilty has been broken. +# #- but new version may saved to .rpmnew so it not so hard ! +# if ($toSave && keys %toRemove) { +# c::rpmdbTraverse($db, sub { +# my ($header) = @_; +# my $otherPackage = (c::headerGetEntry($header, 'name'). '-' . +# c::headerGetEntry($header, 'version'). '-' . +# c::headerGetEntry($header, 'release')); +# if ($toRemove{$otherPackage}) { +# print UPGRADE_OUTPUT "remove:$otherPackage\n"; +# if (packageFlagBase($packages->{names}{c::headerGetEntry($header, 'name')})) { +# delete $toRemove{$otherPackage}; #- keep it selected, but force upgrade. +# } else { +# my @files = c::headerGetEntry($header, 'filenames'); +# my @flags = c::headerGetEntry($header, 'fileflags'); +# for my $i (0..$#flags) { +# if ($flags[$i] & c::RPMFILE_CONFIG()) { +# print UPGRADE_OUTPUT "keepfiles:$files[$i]\n" unless $files[$i] =~ /kdelnk/; +# } +# } +# } +# } +# }); +# } +# +# #- close db, job finished ! +# c::rpmdbClose($db); +# log::l("done selecting packages to upgrade"); +# +# close UPGRADE_OUTPUT; +# c::_exit(0); +# } +# +# #- keep a track of packages that are been selected for being upgraded, +# #- these packages should not be unselected (unless expertise) +# foreach my $p (values %{$packages->{names}}) { +# packageSetFlagUpgrade($p, 1) if packageFlagSelected($p); +# } +} - local $_; - while (<INPUT>) { - chomp; - /^\s*$/ and last; - $code->($_); - } - }; +sub allowedToUpgrade { $_[0] !~ /^(kernel|kernel22|kernel2.2|kernel-secure|kernel-smp|kernel-linus|kernel-linus2.2|hackkernel|kernel-enterprise)$/ } - #- select packages which obseletes other package, obselete package are not removed, - #- should we remove them ? this could be dangerous ! - foreach my $p (values %{$packages->{names}}) { - $ask_child->(packageName($p), "obsoletes", sub { - #- take care of flags and version and release if present - local ($_) = @_; - if (my ($n,$o,$v,$r) = /^(\S*)\s*(\S*)\s*([^\s-]*)-?(\S*)/) { - my $obsoleted = 0; - my $check_obsoletes = sub { - my ($header) = @_; - (!$v || eval(versionCompare(c::headerGetEntry($header, 'version'), $v) . $o . 0)) && - (!$r || versionCompare(c::headerGetEntry($header, 'version'), $v) != 0 || - eval(versionCompare(c::headerGetEntry($header, 'release'), $r) . $o . 0)) or return; - ++$obsoleted; - }; - c::rpmdbNameTraverse($db, $n, $check_obsoletes); - if ($obsoleted > 0) { - log::l("selecting " . packageName($p) . " by selection on obsoletes"); - $obsoletedPackages{$1} = undef; - selectPackage($packages, $p); - } - } - }); - } +sub installTransactionClosure { + my ($packages, $id2pkg) = @_; + my ($id, %closure, @l); - #- mark all files which are not in /etc/rc.d/ for packages which are already installed but which - #- are not in the packages list to upgrade. - #- the 'installed' property will make a package unable to be selected, look at select. - c::rpmdbTraverse($db, sub { - my ($header) = @_; - my $otherPackage = (c::headerGetEntry($header, 'release') !~ /mdk\w*$/ && - (c::headerGetEntry($header, 'name'). '-' . - c::headerGetEntry($header, 'version'). '-' . - c::headerGetEntry($header, 'release'))); - my $p = $packages->{names}{c::headerGetEntry($header, 'name')}; - - if ($p) { - my $epoch_cmp = c::headerGetEntry($header, 'epoch') <=> packageEpoch($p); - my $version_cmp = $epoch_cmp == 0 && versionCompare(c::headerGetEntry($header, 'version'), - packageVersion($p)); - my $version_rel_test = $epoch_cmp > 0 || $epoch_cmp == 0 && - ($version_cmp > 0 || $version_cmp == 0 && - versionCompare(c::headerGetEntry($header, 'release'), packageRelease($p)) >= 0); - if ($packageNeedUpgrade{packageName($p)}) { - log::l("package ". packageName($p) ." need to be upgraded"); - } elsif ($version_rel_test) { #- by default, package are upgraded whatever version is ! - if ($otherPackage && $version_cmp <= 0) { - log::l("force upgrading $otherPackage since it will not be updated otherwise"); - } else { - #- let the parent known this installed package. - print UPGRADE_OUTPUT "installed:" . packageName($p) . "\n"; - packageSetFlagInstalled($p, 1); - } - } elsif ($upgradeNeedRemove{packageName($p)}) { - my $otherPackage = (c::headerGetEntry($header, 'name'). '-' . - c::headerGetEntry($header, 'version'). '-' . - c::headerGetEntry($header, 'release')); - log::l("removing $otherPackage since it will not upgrade correctly!"); - $toRemove{$otherPackage} = 1; #- force removing for theses other packages, select our. - } - } else { - if (exists $obsoletedPackages{c::headerGetEntry($header, 'name')}) { - my @files = c::headerGetEntry($header, 'filenames'); - @installedFilesForUpgrade{grep { ($_ !~ m|^/dev/| && $_ !~ m|^/etc/rc.d/| && $_ !~ m|\.la$| && - ! -d "$prefix/$_" && ! -l "$prefix/$_") } @files} = (); - } - } - }); - - #- find new packages to upgrade. - foreach my $p (values %{$packages->{names}}) { - my $skipThis = 0; - my $count = c::rpmdbNameTraverse($db, packageName($p), sub { - my ($header) = @_; - $skipThis ||= packageFlagInstalled($p); - }); - - #- skip if not installed (package not found in current install). - $skipThis ||= ($count == 0); - - #- make sure to upgrade package that have to be upgraded. - $packageNeedUpgrade{packageName($p)} and $skipThis = 0; - - #- select the package if it is already installed with a lower version or simply not installed. - unless ($skipThis) { - my $cumulSize; - - selectPackage($packages, $p); - - #- keep in mind installed files which are not being updated. doing this costs in - #- execution time but use less memory, else hash all installed files and unhash - #- all file for package marked for upgrade. - c::rpmdbNameTraverse($db, packageName($p), sub { - my ($header) = @_; - $cumulSize += c::headerGetEntry($header, 'size'); - my @files = c::headerGetEntry($header, 'filenames'); - @installedFilesForUpgrade{grep { ($_ !~ m|^/dev/| && $_ !~ m|^/etc/rc.d/| && $_ !~ m|\.la$| && - ! -d "$prefix/$_" && ! -l "$prefix/$_") } @files} = (); - }); - - $ask_child->(packageName($p), "files", sub { - delete $installedFilesForUpgrade{$_[0]}; - }); - - #- keep in mind the cumul size of installed package since they will be deleted - #- on upgrade, only for package that are allowed to be upgraded. - if (allowedToUpgrade(packageName($p))) { - print UPGRADE_OUTPUT "$cumulSize:" . packageName($p) . "\n"; - } - } - } + @l = sort { $a <=> $b } keys %$id2pkg; + while (defined($id = shift @l)) { + my @l2 = ($id); - #- unmark all files for all packages marked for upgrade. it may not have been done above - #- since some packages may have been selected by depsList. - foreach my $p (values %{$packages->{names}}) { - if (packageFlagSelected($p)) { - $ask_child->(packageName($p), "files", sub { - delete $installedFilesForUpgrade{$_[0]}; - }); - } - } + while (defined($id = shift @l2)) { + exists $closure{$id} and next; + $closure{$id} = undef; - #- select packages which contains marked files, then unmark on selection. - #- a special case can be made here, the selection is done only for packages - #- requiring locales if the locales are selected. - #- another special case are for devel packages where fixes over the time has - #- made some files moving between the normal package and its devel couterpart. - #- if only one file is affected, no devel package is selected. - foreach my $p (values %{$packages->{names}}) { - unless (packageFlagSelected($p)) { - my $toSelect = 0; - $ask_child->(packageName($p), "files", sub { - if ($_[0] !~ m|^/dev/| && $_[0] !~ m|^/etc/rc.d/| && $_ !~ m|\.la$| && exists $installedFilesForUpgrade{$_[0]}) { - ++$toSelect if ! -d "$prefix/$_[0]" && ! -l "$prefix/$_[0]"; - } - delete $installedFilesForUpgrade{$_[0]}; - }); - if ($toSelect) { - if ($toSelect <= 1 && packageName($p) =~ /-devel/) { - log::l("avoid selecting " . packageName($p) . " as not enough files will be updated"); - } else { - #- default case is assumed to allow upgrade. - my @deps = map { my $p = packageById($packages, $_); - if_($p && packageName($p) =~ /locales-/, $p) } packageDepsId($p); - if (@deps == 0 || @deps > 0 && (grep { !packageFlagSelected($_) } @deps) == 0) { - log::l("selecting " . packageName($p) . " by selection on files"); - selectPackage($packages, $p); - } else { - log::l("avoid selecting " . packageName($p) . " as its locales language is not already selected"); - } - } + my $pkg = $packages->{depslist}[$id]; + foreach ($pkg->requires_nosense) { + foreach (keys %{$packages->{provides}{$_} || {}}) { + if ($id2pkg->{$_}) { + push @l2, $_; + last; } } } - - #- clean memory... - %installedFilesForUpgrade = (); - - #- no need to still use the child as this point, we can let him to terminate. - close OUTPUT; - close INPUT; - waitpid $pid, 0; - } else { - close INPUT; - close OUTPUT; - open STDIN, "<&INPUT_CHILD"; - open STDOUT, ">&OUTPUT_CHILD"; - exec if_($ENV{LD_LOADER}, $ENV{LD_LOADER}), "parsehdlist", "--interactive", map { "/tmp/$_->{hdlist}" } values %{$packages->{mediums}} - or c::_exit(1); - } - - #- let the parent known about what we found here! - foreach my $p (values %{$packages->{names}}) { - print UPGRADE_OUTPUT "select:" . packageName($p) . "\n" if packageFlagSelected($p); } - #- clean false value on toRemove. - delete $toRemove{''}; - - #- get filenames that should be saved for packages to remove. - #- typically config files, but it may broke for packages that - #- are very old when compabilty has been broken. - #- but new version may saved to .rpmnew so it not so hard ! - if ($toSave && keys %toRemove) { - c::rpmdbTraverse($db, sub { - my ($header) = @_; - my $otherPackage = (c::headerGetEntry($header, 'name'). '-' . - c::headerGetEntry($header, 'version'). '-' . - c::headerGetEntry($header, 'release')); - if ($toRemove{$otherPackage}) { - print UPGRADE_OUTPUT "remove:$otherPackage\n"; - if (packageFlagBase($packages->{names}{c::headerGetEntry($header, 'name')})) { - delete $toRemove{$otherPackage}; #- keep it selected, but force upgrade. - } else { - my @files = c::headerGetEntry($header, 'filenames'); - my @flags = c::headerGetEntry($header, 'fileflags'); - for my $i (0..$#flags) { - if ($flags[$i] & c::RPMFILE_CONFIG()) { - print UPGRADE_OUTPUT "keepfiles:$files[$i]\n" unless $files[$i] =~ /kdelnk/; - } - } - } - } - }); - } - - #- close db, job finished ! - c::rpmdbClose($db); - log::l("done selecting packages to upgrade"); - - close UPGRADE_OUTPUT; - c::_exit(0); + keys %closure >= $limitMinTrans and last; } - #- keep a track of packages that are been selected for being upgraded, - #- these packages should not be unselected (unless expertise) - foreach my $p (values %{$packages->{names}}) { - packageSetFlagUpgrade($p, 1) if packageFlagSelected($p); - } + map { delete $id2pkg->{$_} } grep { $id2pkg->{$_} } keys %closure; } -sub allowedToUpgrade { $_[0] !~ /^(kernel|kernel22|kernel2.2|kernel-secure|kernel-smp|kernel-linus|kernel-linus2.2|hackkernel|kernel-enterprise)$/ } - sub installCallback { # my $msg = shift; # log::l($msg .": ". join(',', @_)); } sub install($$$;$$) { - my ($prefix, $isUpgrade, $toInstall, $depOrder, $media) = @_; + my ($prefix, $isUpgrade, $toInstall, $packages) = @_; my %packages; return if $::g_auto_install || !scalar(@$toInstall); @@ -1326,65 +1312,26 @@ sub install($$$;$$) { #- one or many transaction. my ($total, $nb); foreach my $pkg (@$toInstall) { - $packages{packageName($pkg)} = $pkg; + $packages{$pkg->id} = $pkg; $nb++; - $total += to_int($pkg->[$SIZE_DEPS]); #- do not correct for upgrade! + $total += to_int($pkg->size); #- do not correct for upgrade! } log::l("pkgs::install $prefix"); - log::l("pkgs::install the following: ", join(" ", keys %packages)); + log::l("pkgs::install the following: ", join(" ", map { $_->name } values %packages)); eval { fs::mount("/proc", "$prefix/proc", "proc", 0) } unless -e "$prefix/proc/cpuinfo"; init_db($prefix); - my $callbackOpen = sub { - my $p = $packages{$_[0]} or log::l("unable to retrieve package of $_[0]"), return -1; - my $f = packageFile($p); - print LOG "$f $media->{$p->[$MEDIUM]}{descr}\n"; - my $fd = install_any::getFile($f, $media->{$p->[$MEDIUM]}{descr}); - $fd ? fileno $fd : -1; - }; - my $callbackClose = sub { packageSetFlagInstalled($packages{$_[0]}, 1) }; - #- do not modify/translate the message used with installCallback since #- these are keys during progressing installation, or change in other #- place (install_steps_gtk.pm,...). - installCallback("Starting installation", $nb, $total); + installCallback($packages, 'user', undef, 'install', $nb, $total); - my ($i, $min, $medium) = (0, 0, 1); + my $medium = 1; do { - my @transToInstall; - - if (!$depOrder || !$media) { - @transToInstall = values %packages; - $nb = 0; - } else { - do { - #- change current media if needed. - if ($i > $media->{$medium}{max}) { - #- search for media that contains the desired package to install. - foreach (keys %$media) { - $i >= $media->{$_}{min} && $i <= $media->{$_}{max} and $medium = $_, last; - } - } - $i >= $media->{$medium}{min} && $i <= $media->{$medium}{max} or die "unable to find right medium"; - install_any::useMedium($medium); - - while ($i <= $media->{$medium}{max} && ($i < $min || scalar @transToInstall < $limitMinTrans)) { - my $pkg = $depOrder->[$i++] or next; - my $dep = $packages{packageName($pkg)} or next; - if ($media->{$dep->[$MEDIUM]}{selected}) { - push @transToInstall, $dep; - foreach (map { split '\|' } packageDepsId($dep)) { - $min < $_ and $min = $_; - } - } else { - log::l("ignoring package $dep->[$FILE] as its medium is not selected"); - } - --$nb; #- make sure the package is not taken into account as its medium is not selected. - } - } while ($nb > 0 && scalar(@transToInstall) == 0); #- avoid null transaction, it a nop that cost a bit. - } + my @transToInstall = installTransactionClosure($packages, \%packages); + $nb = values %packages; #- added to exit typically after last media unselected. if ($nb == 0 && scalar(@transToInstall) == 0) { @@ -1395,29 +1342,29 @@ sub install($$$;$$) { } #- extract headers for parent as they are used by callback. - extractHeaders($prefix, \@transToInstall, $media); + extractHeaders($prefix, \@transToInstall, $packages->{mediums}); - if ($media->{$medium}{method} eq 'cdrom') { + if ($packages->{mediums}{$medium}{method} eq 'cdrom') { #- extract packages to make sure the getFile below to force #- accessing medium will not be redirected to updates. - my @origin = grep { $_->[$MEDIUM] == $medium } @transToInstall; + my @origin = grep { packageMedium($packages, $_) == $medium } @transToInstall; if (@origin) { #- reset file descriptor open for main process but #- make sure error trying to change from hdlist are #- trown from main process too. - install_any::getFile(packageFile($origin[0]), $media->{$origin[0][$MEDIUM]}{descr}); + install_any::getFile($origin[0]->filename, packageMedium($packages, $origin[0])->{descr}); - #- allow some log here to check selected status. - log::l("status for medium $origin[0][$MEDIUM] ($media->{$origin[0][$MEDIUM]}{descr}) is " . - ($media->{$origin[0][$MEDIUM]}{selected} ? "selected" : "refused")); +# #- allow some log here to check selected status. +# log::l("status for medium $origin[0][$MEDIUM] ($media->{$origin[0][$MEDIUM]}{descr}) is " . +# ($media->{$origin[0][$MEDIUM]}{selected} ? "selected" : "refused")); } } #- and make sure there are no staling open file descriptor too (before forking)! install_any::getFile('XXX'); - my ($retry_package, $retry_count); - while ($retry_package || @transToInstall) { + my ($retry_pkg, $retry_count); + while ($retry_pkg || @transToInstall) { local (*INPUT, *OUTPUT); pipe INPUT, OUTPUT; if (my $pid = fork()) { close OUTPUT; @@ -1431,9 +1378,11 @@ sub install($$$;$$) { chomp; my @params = split ":"; if ($params[0] eq 'close') { - &$callbackClose($params[1]); + my $pkg = $packages->{depslist}[$params[1]]; + $pkg->set_flag_installed(1); + $pkg->set_flag_upgrade(0); } else { - installCallback(@params); + installCallback($packages, @params); } } } @@ -1449,56 +1398,48 @@ sub install($$$;$$) { eval { close INPUT; select((select(OUTPUT), $| = 1)[0]); - $db = c::rpmdbOpen($prefix) or die "error opening RPM database: ", c::rpmErrorString(); - my $trans = c::rpmtransCreateSet($db, $prefix); - if ($retry_package) { + my $db = URPM::DB::open($prefix, 1) or die "error opening RPM database: ", c::rpmErrorString(); + my $trans = $db->create_transaction($prefix); + if ($retry_pkg) { log::l("opened rpm database for retry transaction of 1 package only"); - c::rpmtransAddPackage($trans, $retry_package->[$HEADER], packageName($retry_package), - $isUpgrade && allowedToUpgrade(packageName($retry_package))); + $trans->add($retry_pkg, $isUpgrade && allowedToUpgrade($retry_pkg->name)); } else { - log::l("opened rpm database for transaction of ". scalar @transToInstall ." new packages, still $nb after that to do"); - c::rpmtransAddPackage($trans, $_->[$HEADER], packageName($_), - $isUpgrade && allowedToUpgrade(packageName($_))) - foreach @transToInstall; + log::l("opened rpm database for transaction of ". scalar @transToInstall . + " new packages, still $nb after that to do"); + $trans->add($_, $isUpgrade && allowedToUpgrade($_->name)) + foreach @transToInstall; } - c::rpmdepOrder($trans) or die "error ordering package list: " . c::rpmErrorString(); - c::rpmtransSetScriptFd($trans, fileno LOG); + $trans->order or die "error ordering package list: " . c::rpmErrorString(); + $trans->set_script_fd(fileno LOG); log::l("rpmRunTransactions start"); - my @probs = c::rpmRunTransactions($trans, $callbackOpen, - sub { #- callbackClose - my $p = $packages{$_[0]} or return; - my $check_installed; - c::rpmdbNameTraverse($db, packageName($p), sub { - my ($header) = @_; - $check_installed ||= c::headerGetEntry($header, 'version') eq packageVersion($p) && c::headerGetEntry($header, 'release') eq packageRelease($p); - }); - $check_installed and print OUTPUT "close:$_[0]\n"; }, - sub { #- installCallback - print OUTPUT join(":", @_), "\n"; }, - 1); + my @probs = $trans->run($packages, force => 1, nosize => 1, callback_open => sub { + my ($data, $type, $id) = @_; + my $pkg = defined $id && $data->{depslist}[$id]; + my $f = $pkg && $pkg->filename; + print LOG "$f\n"; + #my $fd = install_any::getFile($f, $media->{$p->[$MEDIUM]}{descr}); + my $fd = install_any::getFile($f); + $fd ? fileno $fd : -1; + }, callback_close => sub { + my ($data, $type, $id) = @_; + my $pkg = defined $id && $data->{depslist}[$id] or return; + my $check_installed; + $db->traverse_tag('name', [ $pkg->name ], sub { + my ($p) = @_; + $check_installed ||= $pkg->compare_pkg($p) == 0; + }); + $check_installed and print OUTPUT "close:$id\n"; + }, callback_inst => sub { + my ($data, $type, $id, $subtype, $amount, $total) = @_; + print OUTPUT "$type:$id:$subtype:$amount:$total\n"; + }); log::l("rpmRunTransactions done, now trying to close still opened fd"); install_any::getFile('XXX'); #- close still opened fd. - if (@probs) { - my %parts; - @probs = reverse grep { - if (s/(installing package) .* (needs (?:.*) on the (.*) filesystem)/$1 $2/) { - $parts{$3} ? 0 : ($parts{$3} = 1); - } else { - 1; - } - } reverse map { s|/mnt||; $_ } @probs; - - c::rpmdbClose($db); - die "installation of rpms failed:\n ", join("\n ", @probs); - } + @probs and die "installation of rpms failed:\n ", join("\n ", @probs); }; $@ and print OUTPUT "die:$@\n"; - - c::rpmdbClose($db); - log::l("rpm database closed"); - close OUTPUT; #- now search for child process which may be locking the cdrom, making it unable to be ejected. @@ -1524,34 +1465,35 @@ sub install($$$;$$) { #- if we are using a retry mode, this means we have to split the transaction with only #- one package for each real transaction. - unless ($retry_package) { + unless ($retry_pkg) { my @badPackages; foreach (@transToInstall) { - if (!packageFlagInstalled($_) && $media->{$_->[$MEDIUM]}{selected} && !exists($ignoreBadPkg{packageName($_)})) { + if (!$_->flag_installed && packageMedium($packages, $_)->{selected} && !exists($ignoreBadPkg{$_->name})) { push @badPackages, $_; - log::l("bad package $_->[$FILE]"); + log::l("bad package ".$_->fullname); } else { - packageFreeHeader($_); + $_->free_header; } } @transToInstall = @badPackages; #- if we are in retry mode, we have to fetch only one package at a time. - $retry_package = shift @transToInstall; + $retry_pkg = shift @transToInstall; $retry_count = 3; } else { - if (!packageFlagInstalled($retry_package) && $media->{$retry_package->[$MEDIUM]}{selected} && !exists($ignoreBadPkg{packageName($retry_package)})) { + if (!$retry_pkg->flag_installed && packageMedium($packages, $retry_pkg)->{selected} && !exists($ignoreBadPkg{$retry_pkg->name})) { if ($retry_count) { - log::l("retrying installing package $retry_package->[$FILE] alone in a transaction"); + log::l("retrying installing package ".$retry_pkg->fullname." alone in a transaction"); --$retry_count; } else { - log::l("bad package $retry_package->[$FILE] unable to be installed"); - packageSetFlagSelected($retry_package, 0); - cdie ("error installing package list: $retry_package->[$FILE]"); + log::l("bad package ". $retry_pkg->fullname ." unable to be installed"); + $retry_pkg->set_flag_requested(0); + $retry_pkg->set_flag_required(0); + cdie ("error installing package list: ". $retry_pkg->fullname); } } - if (packageFlagInstalled($retry_package) || ! packageFlagSelected($retry_package)) { - packageFreeHeader($retry_package); - $retry_package = shift @transToInstall; + if ($retry_pkg->flag_installed || !$retry_pkg->flag_selected) { + $retry_pkg->free_header; + $retry_pkg = shift @transToInstall; $retry_count = 3; } } @@ -1596,8 +1538,9 @@ sub remove($$) { #- do not modify/translate the message used with installCallback since #- these are keys during progressing installation, or change in other #- place (install_steps_gtk.pm,...). - installCallback("Starting removing other packages", scalar @$toRemove); + installCallback($db, 'user', undef, 'remove', scalar @$toRemove); + #- TODO if (my @probs = c::rpmRunTransactions($trans, $callbackOpen, $callbackClose, \&installCallback, 1)) { die "removing of old rpms failed:\n ", join("\n ", @probs); } @@ -1611,48 +1554,54 @@ sub remove($$) { sub selected_leaves { my ($packages) = @_; - my %l; + my @leaves; - #- initialize l with all id, not couting base package. - foreach my $id (0 .. $#{$packages->{depslist}}) { - my $pkg = packageById($packages, $id) or next; - packageSelectedOrInstalled($pkg) && !packageFlagBase($pkg) or next; - $l{$id} = 1; + foreach (@{$packages->{depslist}}) { + $_->flag_requested && !$_->flag_base and push @leaves, $_->name; } - - foreach my $id (keys %l) { - #- when a package is in a choice, increase its value in hash l, because - #- it has to be examined before when we will select them later. - #- NB: this number may be computed before to save time. - my $p = $packages->{depslist}[$id] or next; - foreach (packageDepsId($p)) { - if (/\|/) { - foreach (split '\|') { - exists $l{$_} or next; - $l{$_} > 1 + $l{$id} or $l{$_} = 1 + $l{$id}; - } - } - } - } - - #- at this level, we can remove selected packages that are already - #- required by other, but we have to sort according to choice usage. - foreach my $id (sort { $l{$b} <=> $l{$a} || $b <=> $a } keys %l) { - #- do not count already deleted id, else cycles will be removed. - $l{$id} or next; - - my $p = $packages->{depslist}[$id] or next; - foreach (packageDepsId($p)) { - #- choices need no more to be examined, this has been done above. - /\|/ and next; - #- improve value of this one, so it will be selected before. - $l{$id} < $l{$_} and $l{$id} = $l{$_}; - $l{$_} = 0; - } - } - - #- now sort again according to decrementing value, and gives packages name. - [ map { packageName($packages->{depslist}[$_]) } sort { $l{$b} <=> $l{$a} } grep { $l{$_} > 0 } keys %l ]; +# my %l; +# +# #- initialize l with all id, not couting base package. +# foreach my $id (0 .. $#{$packages->{depslist}}) { +# my $pkg = packageById($packages, $id) or next; +# packageSelectedOrInstalled($pkg) && !$pkg->flag_base or next; +# $l{$id} = 1; +# } +# +# foreach my $id (keys %l) { +# #- when a package is in a choice, increase its value in hash l, because +# #- it has to be examined before when we will select them later. +# #- NB: this number may be computed before to save time. +# my $p = $packages->{depslist}[$id] or next; +# foreach (packageDepsId($p)) { +# if (/\|/) { +# foreach (split '\|') { +# exists $l{$_} or next; +# $l{$_} > 1 + $l{$id} or $l{$_} = 1 + $l{$id}; +# } +# } +# } +# } +# +# #- at this level, we can remove selected packages that are already +# #- required by other, but we have to sort according to choice usage. +# foreach my $id (sort { $l{$b} <=> $l{$a} || $b <=> $a } keys %l) { +# #- do not count already deleted id, else cycles will be removed. +# $l{$id} or next; +# +# my $p = $packages->{depslist}[$id] or next; +# foreach (packageDepsId($p)) { +# #- choices need no more to be examined, this has been done above. +# /\|/ and next; +# #- improve value of this one, so it will be selected before. +# $l{$id} < $l{$_} and $l{$id} = $l{$_}; +# $l{$_} = 0; +# } +# } +# +# #- now sort again according to decrementing value, and gives packages name. +# [ map { packageName($packages->{depslist}[$_]) } sort { $l{$b} <=> $l{$a} } grep { $l{$_} > 0 } keys %l ]; + \@leaves; } @@ -1723,7 +1672,7 @@ ucd-snmp grep { my $p = packageByName($packages, $_); - $p && packageFlagSelected($p); + $p && $p->flag_selected; } @naughtyServers; } |