diff options
author | Francois Pons <fpons@mandriva.com> | 2000-11-23 10:42:02 +0000 |
---|---|---|
committer | Francois Pons <fpons@mandriva.com> | 2000-11-23 10:42:02 +0000 |
commit | ef3cc024bf209592375b0ff65e616cc8c187c69e (patch) | |
tree | b1682ca66d1dae24b9bd4e272807a47090df3e18 | |
parent | e4ac9bbbd0a936d754c5b3951f9321405e8bbd25 (diff) | |
download | drakx-ef3cc024bf209592375b0ff65e616cc8c187c69e.tar drakx-ef3cc024bf209592375b0ff65e616cc8c187c69e.tar.gz drakx-ef3cc024bf209592375b0ff65e616cc8c187c69e.tar.bz2 drakx-ef3cc024bf209592375b0ff65e616cc8c187c69e.tar.xz drakx-ef3cc024bf209592375b0ff65e616cc8c187c69e.zip |
Memory usage optimization, change structure of storing
package informations. lot of fork to make sure of
freeing memory by perl (no free on used hashes or arrays
usable by other than perl), now upgrade takes as much as
install which takes at least 0.5Mb less than before.
-rw-r--r-- | perl-install/pkgs.pm | 784 |
1 files changed, 427 insertions, 357 deletions
diff --git a/perl-install/pkgs.pm b/perl-install/pkgs.pm index 4ff05f593..af343b281 100644 --- a/perl-install/pkgs.pm +++ b/perl-install/pkgs.pm @@ -2,7 +2,7 @@ package pkgs; # $Id$ use diagnostics; use strict; -use vars qw(*LOG %compssListDesc @skip_list %by_lang @preferred $limitMinTrans $PKGS_SELECTED $PKGS_FORCE $PKGS_INSTALLED $PKGS_BASE $PKGS_SKIP $PKGS_UPGRADE); +use vars qw(*LOG %compssListDesc @skip_list %by_lang @preferred $limitMinTrans); use common qw(:common :file :functional); use install_any; @@ -92,13 +92,23 @@ autoirpm autoirpm-icons numlock #- 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; + #- constant for packing flags, see below. -$PKGS_SELECTED = 0x00ffffff; -$PKGS_FORCE = 0x01000000; -$PKGS_INSTALLED = 0x02000000; -$PKGS_BASE = 0x04000000; -$PKGS_SKIP = 0x08000000; -$PKGS_UPGRADE = 0x20000000; +my $PKGS_SELECTED = 0x00ffffff; +my $PKGS_FORCE = 0x01000000; +my $PKGS_INSTALLED = 0x02000000; +my $PKGS_BASE = 0x04000000; +my $PKGS_SKIP = 0x08000000; +my $PKGS_UPGRADE = 0x20000000; #- package to ignore, typically in Application CD. my %ignoreBadPkg = ( @@ -117,45 +127,52 @@ 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 { my ($pkg) = @_; $pkg->{file} } -sub packageName { my ($pkg) = @_; $pkg->{file} =~ /([^\(]*)(?:\([^\)]*\))?-[^-]+-[^-]+/ ? $1 : die "invalid file `$pkg->{file}'" } -sub packageSpecificArch { my ($pkg) = @_; $pkg->{file} =~ /[^\(]*(?:\(([^\)]*)\))?-[^-]+-[^-]+/ ? $1 : die "invalid file `$pkg->{file}'" } -sub packageVersion { my ($pkg) = @_; $pkg->{file} =~ /.*-([^-]+)-[^-]+/ ? $1 : die "invalid file `$pkg->{file}'" } -sub packageRelease { my ($pkg) = @_; $pkg->{file} =~ /.*-[^-]+-([^-]+)/ ? $1 : die "invalid file `$pkg->{file}'" } +sub packageHeaderFile { $_[0]->[$FILE] } +sub packageName { $_[0]->[$FILE] =~ /([^\(]*)(?:\([^\)]*\))?-[^-]+-[^-]+/ ? $1 : die "invalid file `$_[0]->[$FILE]'" } +sub packageSpecificArch { $_[0]->[$FILE] =~ /[^\(]*(?:\(([^\)]*)\))?-[^-]+-[^-]+/ ? $1 : die "invalid file `$_[0]->[$FILE]'" } +sub packageVersion { $_[0]->[$FILE] =~ /.*-([^-]+)-[^-]+/ ? $1 : die "invalid file `$_[0]->[$FILE]'" } +sub packageRelease { $_[0]->[$FILE] =~ /.*-[^-]+-([^-]+)/ ? $1 : die "invalid file `$_[0]->[$FILE]'" } + +sub packageSize { to_int($_[0]->[$SIZE_DEPS]) } +sub packageDepsId { split ' ', ($_[0]->[$SIZE_DEPS] =~ /^\d*\s*(.*)/)[0] } + +sub packageFlagSelected { $_[0]->[$FLAGS] & $PKGS_SELECTED } +sub packageFlagForce { $_[0]->[$FLAGS] & $PKGS_FORCE } +sub packageFlagInstalled { $_[0]->[$FLAGS] & $PKGS_INSTALLED } +sub packageFlagBase { $_[0]->[$FLAGS] & $PKGS_BASE } +sub packageFlagSkip { $_[0]->[$FLAGS] & $PKGS_SKIP } +sub packageFlagUpgrade { $_[0]->[$FLAGS] & $PKGS_UPGRADE } + +sub packageSetFlagSelected { $_[0]->[$FLAGS] &= ~$PKGS_SELECTED; $_[0]->[$FLAGS] |= $_[1] & $PKGS_SELECTED; } -sub packageSize { my ($pkg) = @_; to_int($pkg->{sizeDeps}) } -sub packageDepsId { my ($pkg) = @_; split ' ', ($pkg->{sizeDeps} =~ /^\d*\s*(.*)/)[0] } +sub packageSetFlagForce { $_[1] ? ($_[0]->[$FLAGS] |= $PKGS_FORCE) : ($_[0]->[$FLAGS] &= ~$PKGS_FORCE); } +sub packageSetFlagInstalled { $_[1] ? ($_[0]->[$FLAGS] |= $PKGS_INSTALLED) : ($_[0]->[$FLAGS] &= ~$PKGS_INSTALLED); } +sub packageSetFlagBase { $_[1] ? ($_[0]->[$FLAGS] |= $PKGS_BASE) : ($_[0]->[$FLAGS] &= ~$PKGS_BASE); } +sub packageSetFlagSkip { $_[1] ? ($_[0]->[$FLAGS] |= $PKGS_SKIP) : ($_[0]->[$FLAGS] &= ~$PKGS_SKIP); } +sub packageSetFlagUpgrade { $_[1] ? ($_[0]->[$FLAGS] |= $PKGS_UPGRADE) : ($_[0]->[$FLAGS] &= ~$PKGS_UPGRADE); } -sub packageFlagSelected { my ($pkg) = @_; $pkg->{flags} & $PKGS_SELECTED } -sub packageFlagForce { my ($pkg) = @_; $pkg->{flags} & $PKGS_FORCE } -sub packageFlagInstalled { my ($pkg) = @_; $pkg->{flags} & $PKGS_INSTALLED } -sub packageFlagBase { my ($pkg) = @_; $pkg->{flags} & $PKGS_BASE } -sub packageFlagSkip { my ($pkg) = @_; $pkg->{flags} & $PKGS_SKIP } -sub packageFlagUpgrade { my ($pkg) = @_; $pkg->{flags} & $PKGS_UPGRADE } +sub packageMedium { $_[0]->[$MEDIUM] } -sub packageSetFlagSelected { my ($pkg, $v) = @_; $pkg->{flags} &= ~$PKGS_SELECTED; $pkg->{flags} |= $v & $PKGS_SELECTED; } +sub packageProvides { map { $_[0]->{depslist}[$_] || die "unkown package id $_" } unpack "s*", $_[1]->[$PROVIDES] } -sub packageSetFlagForce { my ($pkg, $v) = @_; $v ? ($pkg->{flags} |= $PKGS_FORCE) : ($pkg->{flags} &= ~$PKGS_FORCE); } -sub packageSetFlagInstalled { my ($pkg, $v) = @_; $v ? ($pkg->{flags} |= $PKGS_INSTALLED) : ($pkg->{flags} &= ~$PKGS_INSTALLED); } -sub packageSetFlagBase { my ($pkg, $v) = @_; $v ? ($pkg->{flags} |= $PKGS_BASE) : ($pkg->{flags} &= ~$PKGS_BASE); } -sub packageSetFlagSkip { my ($pkg, $v) = @_; $v ? ($pkg->{flags} |= $PKGS_SKIP) : ($pkg->{flags} &= ~$PKGS_SKIP); } -sub packageSetFlagUpgrade { my ($pkg, $v) = @_; $v ? ($pkg->{flags} |= $PKGS_UPGRADE) : ($pkg->{flags} &= ~$PKGS_UPGRADE); } +sub packageValues { [ unpack "s*", $_[0]->[$VALUES] ] } +sub packageSetValues { $_[0]->[$VALUES] = pack "s*", @{$_[1]} } -sub packageProvides { my ($pkg) = @_; @{$pkg->{provides} || []} } +sub packageHeader { $_[0]->[$HEADER] } +sub packageFreeHeader { c::headerFree(delete $_[0]->[$HEADER]) } sub packageFile { - my ($pkg) = @_; - $pkg->{header} or die "packageFile: missing header"; - $pkg->{file} =~ /([^\(]*)(?:\([^\)]*\))?(-[^-]+-[^-]+)/; - "$1$2." . c::headerGetEntry($pkg->{header}, 'arch') . ".rpm"; + $_[0]->[$HEADER] or die "packageFile: missing header"; + $_[0]->[$FILE] =~ /([^\(]*)(?:\([^\)]*\))?(-[^-]+-[^-]+)/; + "$1$2." . c::headerGetEntry($_[0]->[$HEADER], 'arch') . ".rpm"; } -sub packageSelectedOrInstalled { my ($pkg) = @_; packageFlagSelected($pkg) || packageFlagInstalled($pkg) } +sub packageSelectedOrInstalled { packageFlagSelected($_[0]) || packageFlagInstalled($_[0]) } sub packageId { my ($packages, $pkg) = @_; my $i = 0; - foreach (@{$packages->[1]}) { return $i if $pkg == $packages->[1][$i]; $i++ } + foreach (@{$packages->{depslist}}) { return $i if $pkg == $packages->{depslist}[$i]; $i++ } return; } @@ -179,9 +196,9 @@ sub extractHeaders($$$) { 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($_)); + $_->[$HEADER] = c::headerRead(fileno H, 1) or log::l("unable to read header of package ". packageHeaderFile($_)); } - @$pkgs = grep { $_->{header} } @$pkgs; + @$pkgs = grep { $_->[$HEADER] } @$pkgs; } #- size and correction size functions for packages. @@ -208,8 +225,8 @@ sub invCorrectSize { sub selectedSize { my ($packages) = @_; my $size = 0; - foreach (values %{$packages->[0]}) { - packageFlagSelected($_) && !packageFlagInstalled($_) and $size += packageSize($_) - ($_->{installedCumulSize} || 0); + foreach (values %{$packages->{names}}) { + packageFlagSelected($_) && !packageFlagInstalled($_) and $size += packageSize($_) - ($_->[$INSTALLED_CUMUL_SIZE] || 0); } $size; } @@ -222,34 +239,34 @@ sub correctedSelectedSize { correctSize(selectedSize($_[0]) / sqr(1024)) } #- a list to search by id. sub packageByName { my ($packages, $name) = @_; - $packages->[0]{$name} or log::l("unknown package `$name'") && undef; + $packages->{names}{$name} or log::l("unknown package `$name'") && undef; } sub packageById { my ($packages, $id) = @_; - $packages->[1][$id] or log::l("unknown package id $id") && undef; + $packages->{depslist}[$id] or log::l("unknown package id $id") && undef; } sub allPackages { my ($packages) = @_; my %skip_list; @skip_list{@skip_list} = (); - grep { !exists $skip_list{packageName($_)} } values %{$packages->[0]}; + grep { !exists $skip_list{packageName($_)} } values %{$packages->{names}}; } sub packagesOfMedium { my ($packages, $mediumName) = @_; - my $medium = $packages->[2]{$mediumName}; - grep { $_->{medium} == $medium } @{$packages->[1]}; + my $medium = $packages->{mediums}{$mediumName}; + grep { $_->[$MEDIUM] == $medium } @{$packages->{depslist}}; } sub packagesToInstall { my ($packages) = @_; - grep { $_->{medium}{selected} && packageFlagSelected($_) && !packageFlagInstalled($_) } values %{$packages->[0]}; + grep { $_->[$MEDIUM]{selected} && packageFlagSelected($_) && !packageFlagInstalled($_) } values %{$packages->{names}}; } sub allMediums { my ($packages) = @_; - keys %{$packages->[2]}; + keys %{$packages->{mediums}}; } sub mediumDescr { my ($packages, $medium) = @_; - $packages->[2]{$medium}{descr}; + $packages->{mediums}{$medium}{descr}; } #- selection, unselection of package. @@ -262,10 +279,10 @@ sub selectPackage { #($$;$$$) #- check for medium selection, if the medium has not been #- selected, the package cannot be selected. - $pkg->{medium}{selected} or return; + $pkg->[$MEDIUM]{selected} or return; #- avoid infinite recursion (mainly against badly generated depslist.ordered). - $check_recursion ||= {}; exists $check_recursion->{$pkg->{file}} and return; $check_recursion->{$pkg->{file}} = undef; + $check_recursion ||= {}; exists $check_recursion->{$pkg->[$FILE]} and return; $check_recursion->{$pkg->[$FILE]} = undef; #- make sure base package are set even if already selected. $base and packageSetFlagBase($pkg, 1); @@ -317,7 +334,7 @@ sub unselectPackage($$;$) { #- 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($pkg)) { + 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 = 0; @@ -363,7 +380,7 @@ sub setPackageSelection($$$) { sub unselectAllPackages($) { my ($packages) = @_; - foreach (values %{$packages->[0]}) { + foreach (values %{$packages->{names}}) { unless (packageFlagBase($_) || packageFlagUpgrade($_)) { packageSetFlagSelected($_, 0); } @@ -371,7 +388,7 @@ sub unselectAllPackages($) { } sub unselectAllPackagesIncludingUpgradable($) { my ($packages, $removeUpgradeFlag) = @_; - foreach (values %{$packages->[0]}) { + foreach (values %{$packages->{names}}) { unless (packageFlagBase($_)) { packageSetFlagSelected($_, 0); packageSetFlagUpgrade($_, 0); @@ -381,7 +398,7 @@ sub unselectAllPackagesIncludingUpgradable($) { sub skipSetWithProvides { my ($packages, @l) = @_; - packageSetFlagSkip($_, 1) foreach grep { $_ } map { $_, packageProvides($_) } @l; + packageSetFlagSkip($_, 1) foreach grep { $_ } map { $_, packageProvides($packages, $_) } @l; } sub psUpdateHdlistsDeps { @@ -421,51 +438,46 @@ sub psUpdateHdlistsDeps { sub psUsingHdlists { my ($prefix, $method) = @_; my $listf = install_any::getFile('Mandrake/base/hdlists') or die "no hdlists found"; - my @packages = ({}, [], {}); - my @hdlists; + my %packages = ( names => {}, depslist => [], mediums => {}); - #- parse hdlist.list file. + #- parse hdlists file. my $medium = 1; - local $_; - while (<$listf>) { + foreach (<$listf>) { chomp; s/\s*#.*$//; /^\s*$/ and next; m/^\s*(hdlist\S*\.cz2?)\s+(\S+)\s*(.*)$/ or die "invalid hdlist description \"$_\" in hdlists file"; - push @hdlists, [ $1, $medium, $2, $3 ]; - ++$medium; - } - - foreach (@hdlists) { - my ($hdlist, $medium, $rpmsdir, $descr) = @$_; #- make sure the first medium is always selected! #- by default select all image. - psUsingHdlist($prefix, $method, \@packages, $hdlist, $medium, $rpmsdir, $descr, 1); + psUsingHdlist($prefix, $method, \%packages, $1, $medium, $2, $3, 1); + ++$medium; } - log::l("psUsingHdlists read " . scalar keys(%{$packages[0]}) . " headers on " . scalar keys(%{$packages[2]}) . " hdlists"); + log::l("psUsingHdlists read " . scalar keys(%{$packages{names}}) . + " headers on " . scalar keys(%{$packages{mediums}}) . " hdlists"); - \@packages; + \%packages; } sub psUsingHdlist { my ($prefix, $method, $packages, $hdlist, $medium, $rpmsdir, $descr, $selected, $fhdlist) = @_; + my $fakemedium = $method . $medium; + log::l("trying to read $hdlist for medium $medium"); #- if the medium already exist, use it. - $packages->[2]{$medium} and return; - - my $fakemedium = $method . $medium; - my $m = $packages->[2]{$medium} = { hdlist => $hdlist, - medium => $medium, - rpmsdir => $rpmsdir, #- where is RPMS directory. - descr => $descr, - fakemedium => $fakemedium, - min => scalar keys %{$packages->[0]}, - max => -1, #- will be updated after reading current hdlist. - selected => $selected, #- default value is only CD1, it is really the minimal. - }; + $packages->{mediums}{$medium} and return; + + my $m = $packages->{mediums}{$medium} = { hdlist => $hdlist, + medium => $medium, + rpmsdir => $rpmsdir, #- where is RPMS directory. + descr => $descr, + fakemedium => $fakemedium, + min => scalar keys %{$packages->{names}}, + max => -1, #- will be updated after reading current hdlist. + selected => $selected, #- default value is only CD1, it is really the minimal. + }; #- copy hdlist file directly to $prefix/var/lib/urpmi, this will be used #- for getting header of package during installation or after by urpmi. @@ -482,18 +494,15 @@ sub psUsingHdlist { chomp; /^[dlf]\s+/ or next; if (/^f\s+\d+\s+(.*)/) { - my $pkg = { file => $1, #- rebuild filename according to header one - flags => 0, #- flags - medium => $m, - }; + my $pkg = [ (undef) x 8 ]; $pkg->[$FILE] = $1; $pkg->[$MEDIUM] = $m; my $specific_arch = packageSpecificArch($pkg); if (!$specific_arch || compat_arch($specific_arch)) { - my $old_pkg = $packages->[0]{packageName($pkg)}; + my $old_pkg = $packages->{names}{packageName($pkg)}; if ($old_pkg) { if (packageVersion($pkg) eq packageVersion($old_pkg) && packageRelease($pkg) eq packageRelease($old_pkg)) { if (better_arch($specific_arch, packageSpecificArch($old_pkg))) { log::l("replacing old package with package $1 with better arch: $specific_arch"); - $packages->[0]{packageName($pkg)} = $pkg; + $packages->{names}{packageName($pkg)} = $pkg; } else { log::l("keeping old package against package $1 with worse arch"); } @@ -501,7 +510,7 @@ sub psUsingHdlist { log::l("ignoring package $1 already present in distribution with different version or release"); } } else { - $packages->[0]{packageName($pkg)} = $pkg; + $packages->{names}{packageName($pkg)} = $pkg; } } else { log::l("ignoring package $1 with incompatible arch: $specific_arch"); @@ -513,7 +522,7 @@ sub psUsingHdlist { close F or die "unable to parse $newf"; #- update maximal index. - $m->{max} = scalar(keys %{$packages->[0]}) - 1; + $m->{max} = scalar(keys %{$packages->{names}}) - 1; $m->{max} >= $m->{min} or die "nothing found while parsing $newf"; log::l("read " . ($m->{max} - $m->{min} + 1) . " headers in $hdlist"); 1; @@ -527,15 +536,15 @@ sub getOtherDeps($$) { local $_; while (<$f>) { my ($name, $version, $release, $size, $deps) = /^(\S*)-([^-\s]+)-([^-\s]+)\s+(\d+)\s+(.*)/; - my $pkg = $packages->[0]{$name}; + 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->[1]}; - $index >= $pkg->{medium}{min} && $index <= $pkg->{medium}{max} + my $index = scalar @{$packages->{depslist}}; + $index >= $pkg->[$MEDIUM]{min} && $index <= $pkg->[$MEDIUM]{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. @@ -546,13 +555,13 @@ sub getOtherDeps($$) { map { packageByName($packages, $_) or do { log::l("unknown package $_ in depslist for closure"); undef } } split /\s+/, $deps} = (); - $pkg->{sizeDeps} = join " ", $size, keys %closuredeps; + $pkg->[$SIZE_DEPS] = join " ", $size, keys %closuredeps; - push @{$packages->[1]}, $pkg; + push @{$packages->{depslist}}, $pkg; } #- check for same number of package in depslist and hdlists, avoid being to hard. - scalar(keys %{$packages->[0]}) == scalar(@{$packages->[1]}) + scalar(keys %{$packages->{names}}) == scalar(@{$packages->{depslist}}) or log::l("other depslist has not same package as hdlist file"); } @@ -574,31 +583,32 @@ sub getDeps($) { local $_; while (<F>) { my ($name, $version, $release, $sizeDeps) = /^(\S*)-([^-\s]+)-([^-\s]+)\s+(.*)/; - my $pkg = $packages->[0]{$name}; + my $pkg = $packages->{names}{$name}; $pkg or log::l("ignoring $name-$version-$release in depslist is not in hdlist"), $mismatch = 1, next; $version eq packageVersion($pkg) and $release eq packageRelease($pkg) or log::l("ignoring $name-$version-$release in depslist mismatch version or release in hdlist ($version ne ", packageVersion($pkg), " or $release ne ", packageRelease($pkg), ")"), $mismatch = 1, next; - $pkg->{sizeDeps} = $sizeDeps; + $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->[1]}; - $i >= $pkg->{medium}{min} && $i <= $pkg->{medium}{max} or $mismatch = 1; + my $i = scalar @{$packages->{depslist}}; + $i >= $pkg->[$MEDIUM]{min} && $i <= $pkg->[$MEDIUM]{max} or $mismatch = 1; #- package are already sorted in depslist to enable small transaction and multiple medium. - push @{$packages->[1]}, $pkg; + push @{$packages->{depslist}}, $pkg; } #- check for mismatching package, it should breaj 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. - scalar(keys %{$packages->[0]}) == scalar(@{$packages->[1]}) or die "depslist.ordered has not same package as hdlist files"; + scalar(keys %{$packages->{names}}) == scalar(@{$packages->{depslist}}) + or die "depslist.ordered has not same package as hdlist files"; } sub getProvides($) { @@ -612,12 +622,16 @@ sub getProvides($) { #- 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. - - foreach my $pkg (@{$packages->[1]}) { + #- 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}}) { packageFlagBase($pkg) and next; - map { my $provided = $packages->[1][$_] or die "invalid package index $_"; - packageFlagBase($provided) or push @{$provided->{provides} ||= []}, $pkg; - } map { split '\|' } grep { !/^NOTFOUND_/ } packageDepsId($pkg); + foreach (map { split '\|' } grep { !/^NOTFOUND_/ } packageDepsId($pkg)) { + my $provided = $packages->{depslist}[$_] or die "invalid package index $_"; + packageFlagBase($provided) or $provided->[$PROVIDES] = pack "s*", (unpack "s*", $provided->[$PROVIDES]), $i; + } + ++$i; } } @@ -638,7 +652,7 @@ sub readCompss { $p = $1; } else { /(\S+)/; - $packages->[0]{$1} or log::l("unknown package $1 in compss"), next; + $packages->{names}{$1} or log::l("unknown package $1 in compss"), next; push @compss, "$p/$1"; } } @@ -655,15 +669,15 @@ sub readCompssList { /^\s*$/ || /^#/ and next; my ($name, @values) = split; my $p = packageByName($packages, $name) or log::l("unknown entry $name (in compssList)"), next; - $p->{values} = \@values; + $p->[$VALUES] = pack "s*", @values; } my %done; foreach (@$langs) { my $p = packageByName($packages, "locales-$_") or next; - foreach ($p, @{$p->{provides} || []}, map { packageByName($packages, $_) } @{$by_lang{$_} || []}) { + foreach ($p, packageProvides($packages, $p), map { packageByName($packages, $_) } @{$by_lang{$_} || []}) { next if !$_ || $done{$_}; $done{$_} = 1; - $_->{values} = [ map { $_ + 90 } @{$_->{values} || [ (0) x @levels ]} ]; + $_->[$VALUES] = pack "s*", map { $_ + 90 } ($_->[$VALUES] ? (unpack "s*", $_->[$VALUES]) : ((0) x @levels)); } } my $l = { map_index { $_ => $::i } @levels }; @@ -680,7 +694,7 @@ sub readCompssUsers { my $map = sub { $l or return; - $_ = $packages->[0]{$_} or log::l("unknown package $_ (in compssUsers)") foreach @$l; + $_ = $packages->{names}{$_} or log::l("unknown package $_ (in compssUsers)") foreach @$l; }; my $file = 'Mandrake/base/compssUsers'; my $f = $meta_class && install_any::getFile("$file.$meta_class") || install_any::getFile($file) or die "can't find $file"; @@ -715,13 +729,13 @@ sub setSelectedFromCompssList { my @packages = allPackages($packages); my @places = do { #- special case for /^k/ aka kde stuff - my @values = map { $_->{values}[$ind] } @packages; + my @values = map { (unpack "s*", $_->[$VALUES])[$ind] } @packages; sort { $values[$b] <=> $values[$a] } 0 .. $#packages; }; foreach (@places) { my $p = $packages[$_]; next if packageFlagSkip($p); - last if $p->{values}[$ind] < $min_level; + last if (unpack "s*", $p->[$VALUES])[$ind] < $min_level; #- determine the packages that will be selected when #- selecting $p. the packages are not selected. @@ -731,11 +745,11 @@ sub setSelectedFromCompssList { #- this enable an incremental total size. my $old_nb = $nb; foreach (grep { $newSelection{$_} } keys %newSelection) { - $nb += packageSize($packages->[0]{$_}); + $nb += packageSize($packages->{names}{$_}); } if ($max_size && $nb > $max_size) { $nb = $old_nb; - $min_level = $p->{values}[$ind]; + $min_level = (unpack "s*", $p->[$VALUES])[$ind]; last; } @@ -750,7 +764,7 @@ sub setSelectedFromCompssList { #- just saves the selected packages, call setSelectedFromCompssList and restores the selected packages sub saveSelected { my ($packages) = @_; - my @l = values %{$packages->[0]}; + my @l = values %{$packages->{names}}; my @flags = map { pkgs::packageFlagSelected($_) } @l; [ $packages, \@l, \@flags ]; } @@ -761,7 +775,7 @@ sub restoreSelected { sub init_db { - my ($prefix, $isUpgrade) = @_; + my ($prefix) = @_; my $f = "$prefix/root/install.log"; open(LOG, "> $f") ? log::l("opened $f") : log::l("Failed to open $f. No install log will be kept."); @@ -773,13 +787,33 @@ sub init_db { 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; + ($? & 0xff00) and die "rebuilding of rpm database failed"; + } else { + log::l("rebuilding rpm database"); + c::rpmdbRebuild($prefix) and c::_exit(0); - if ($isUpgrade) { - log::l("rebuilding rpm database"); - c::rpmdbRebuild($prefix) or die "rebuilding of rpm database failed: ", c::rpmErrorString(); + log::l("rebuilding of rpm database failed: ". c::rpmErrorString()); + c::_exit(2); + } + $packages->{rebuild_db} = undef; } - #- seems no more necessary to rpmdbInit ? - #c::rpmdbOpen($prefix) or die "creation of rpm database failed: ", c::rpmErrorString(); + + my $db = c::rpmdbOpenForTraversal($prefix) or die "unable to open $prefix/var/lib/rpm/Packages"; + log::l("opened rpm database for examining existing packages"); + + $db; } sub done_db { @@ -799,13 +833,7 @@ sub versionCompare($$) { sub selectPackagesAlreadyInstalled { my ($packages, $prefix) = @_; - - log::l("reading /usr/lib/rpm/rpmrc"); - c::rpmReadConfigFiles() or die "can't read rpm config files"; - log::l("\tdone"); - - my $db = c::rpmdbOpenForTraversal($prefix) or die "unable to open $prefix/var/lib/rpm/packages.rpm"; - log::l("opened rpm database for examining existing packages"); + 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 @@ -814,7 +842,7 @@ sub selectPackagesAlreadyInstalled { #- is enough). c::rpmdbTraverse($db, sub { my ($header) = @_; - my $p = $packages->[0]{c::headerGetEntry($header, 'name')}; + my $p = $packages->{names}{c::headerGetEntry($header, 'name')}; if ($p) { my $version_cmp = versionCompare(c::headerGetEntry($header, 'version'), packageVersion($p)); @@ -832,262 +860,304 @@ sub selectPackagesAlreadyInstalled { sub selectPackagesToUpgrade($$$;$$) { my ($packages, $prefix, $base, $toRemove, $toSave) = @_; - - log::l("reading /usr/lib/rpm/rpmrc"); - c::rpmReadConfigFiles() or die "can't read rpm config files"; - log::l("\tdone"); - - my $db = c::rpmdbOpenForTraversal($prefix) or die "unable to open $prefix/var/lib/rpm/packages.rpm"; - log::l("opened rpm database for examining existing packages"); - local $_; #- else perl complains on the map { ... } grep { ... } @...; - #- 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, - ); - - #- these package are not named as ours, need to be translated before working. - #- a version may follow to setup a constraint 'installed version greater than'. - my %otherPackageToRename = ( - 'qt' => [ 'qt2', '2.0' ], - 'qt1x' => [ 'qt' ], - ); - #- 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; - - #- 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; + local (*UPGRADE_INPUT, *UPGRADE_OUTPUT); pipe UPGRADE_INPUT, UPGRADE_OUTPUT; if (my $pid = fork()) { - close INPUT_CHILD; - close OUTPUT_CHILD; - select((select(OUTPUT), $| = 1)[0]); - - #- internal reading from interactive mode of parsehdlist. - my $ask_child = sub { - my ($name, $tag) = @_; - my @list; - print OUTPUT "$name:$tag\n"; - - local $_; - while (<INPUT>) { - chomp; - /^\s*$/ and last; - push @list, $_; + @{$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, + ); + + #- these package are not named as ours, need to be translated before working. + #- a version may follow to setup a constraint 'installed version greater than'. + my %otherPackageToRename = ( + 'qt' => [ 'qt2', '2.0' ], + 'qt1x' => [ 'qt' ], + ); + #- 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 (values %{$packages->{names}}) { + my $p = $_; + + #- TODO take into account version number and flags (that's why regexp :-) + $ask_child->(packageName($p), "obsoletes", sub { + if ($_[0] =~ /^(\S*)/ && c::rpmdbNameTraverse($db, $1) > 0) { + log::l("selecting " . packageName($p) . " by selection on obsoletes"); + $obsoletedPackages{$1} = undef; + selectPackage($packages, $p); + } + }); } - @list; - }; - - #- 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 $renaming = $otherPackage && $otherPackageToRename{c::headerGetEntry($header, 'name')}; - my $name = $renaming && - (!$renaming->[1] || versionCompare(c::headerGetEntry($header, 'version'), $renaming->[1]) >= 0) && - $renaming->[0]; - $name and $packageNeedUpgrade{$name} = 1; #- keep in mind to force upgrading this package. - my $p = $packages->[0]{$name || c::headerGetEntry($header, 'name')}; - - if ($p) { - my $version_cmp = versionCompare(c::headerGetEntry($header, 'version'), packageVersion($p)); - my $version_rel_test = $version_cmp > 0 || $version_cmp == 0 && - versionCompare(c::headerGetEntry($header, 'release'), packageRelease($p)) >= 0; - if ($version_rel_test) { #- by default, package selecting are upgrade whatever version is ! - if ($otherPackage && $version_cmp <= 0) { - log::l("force upgrading $otherPackage since it will not be updated otherwise"); - } else { - packageSetFlagInstalled($p, 1); + #- 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 $renaming = $otherPackage && $otherPackageToRename{c::headerGetEntry($header, 'name')}; + my $name = $renaming && + (!$renaming->[1] || versionCompare(c::headerGetEntry($header, 'version'), + $renaming->[1]) >= 0) && $renaming->[0]; + $name and $packageNeedUpgrade{$name} = 1; #- keep in mind to force upgrading this package. + my $p = $packages->{names}{$name || c::headerGetEntry($header, 'name')}; + + if ($p) { + my $version_cmp = versionCompare(c::headerGetEntry($header, 'version'), packageVersion($p)); + my $version_rel_test = $version_cmp > 0 || $version_cmp == 0 && + versionCompare(c::headerGetEntry($header, 'release'), packageRelease($p)) >= 0; + if ($version_rel_test) { #- by default, package selecting are upgrade 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. } - } 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 { - my @files = c::headerGetEntry($header, 'filenames'); - @installedFilesForUpgrade{grep { ($_ !~ m|^/etc/rc.d/| && - ! -d "$prefix/$_" && ! -l "$prefix/$_") } @files} = (); - } - }); - - #- find new packages to upgrade. - foreach (values %{$packages->[0]}) { - my $p = $_; - 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'); #- all these will be deleted on upgrade. + } else { + if (! exists $obsoletedPackages{$name || c::headerGetEntry($header, 'name')}) { my @files = c::headerGetEntry($header, 'filenames'); @installedFilesForUpgrade{grep { ($_ !~ m|^/etc/rc.d/| && ! -d "$prefix/$_" && ! -l "$prefix/$_") } @files} = (); - }); + } + } + }); - map { delete $installedFilesForUpgrade{$_} } grep { $_ !~ m|^/etc/rc.d/| } $ask_child->(packageName($p), "files"); + #- find new packages to upgrade. + foreach (values %{$packages->{names}}) { + my $p = $_; + my $skipThis = 0; + my $count = c::rpmdbNameTraverse($db, packageName($p), sub { + my ($header) = @_; + $skipThis ||= packageFlagInstalled($p); + }); - #- keep in mind the cumul size of installed package since they will be deleted - #- on upgrade. - $p->{installedCumulSize} = $cumulSize; - } - } + #- skip if not installed (package not found in current install). + $skipThis ||= ($count == 0); - #- 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 (values %{$packages->[0]}) { - my $p = $_; + #- 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|^/etc/rc.d/| && + ! -d "$prefix/$_" && ! -l "$prefix/$_") } @files} = (); + }); - if (packageFlagSelected($p)) { - map { delete $installedFilesForUpgrade{$_} } grep { $_ !~ m|^/etc/rc.d/| } $ask_child->(packageName($p), "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. + print UPGRADE_OUTPUT "$cumulSize:" . packageName($p) . "\n"; + } } - } - #- 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 (values %{$packages->[0]}) { - my $p = $_; + #- 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 (values %{$packages->{names}}) { + my $p = $_; - unless (packageFlagSelected($p)) { - my $toSelect = 0; - map { if (exists $installedFilesForUpgrade{$_}) { - ++$toSelect if ! -d "$prefix/$_" && ! -l "$prefix/$_"; delete $installedFilesForUpgrade{$_} } - } grep { $_ !~ m|^/etc/rc.d/| } $ask_child->(packageName($p), "files"); - 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 = $packages->[1][$_]; - $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); + 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 (values %{$packages->{names}}) { + my $p = $_; + + unless (packageFlagSelected($p)) { + my $toSelect = 0; + $ask_child->(packageName($p), "files", sub { + if ($_[0] !~ m|^/etc/rc.d/| && 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 { - log::l("avoid selecting " . packageName($p) . " as its locales language is not already selected"); + #- default case is assumed to allow upgrade. + my @deps = map { my $p = $packages->{depslist}[$_]; + $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 = (); + #- clean memory... + %installedFilesForUpgrade = (); - #- select packages which obseletes other package, obselete package are not removed, - #- should we remove them ? this could be dangerous ! - foreach (values %{$packages->[0]}) { + #- 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 "parsehdlist", "--interactive", map { "/tmp/$_->{hdlist}" } values %{$packages->{mediums}}; + c::_exit(1); + } + + #- let the parent known about what we found here! + foreach (values %{$packages->{names}}) { my $p = $_; - #- TODO take into account version number and flags (that's why regexp :-) - foreach (map { /^(\S*)/ ? ($1) : () } $ask_child->(packageName($p), "obsoletes")) { - if (c::rpmdbNameTraverse($db, $_) > 0) { - log::l("selecting " . packageName($p) . " by selection on obsoletes"); - selectPackage($packages, $p); - } - } + print UPGRADE_OUTPUT "select:" . packageName($p) . "\n" if packageFlagSelected($p); } - #- 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 "parsehdlist", "--interactive", map { "/tmp/$_->{hdlist}" } values %{$packages->[2]}; - c::_exit(1); + #- 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. - foreach (values %{$packages->[0]}) { + #- these packages should not be unselected (unless expertise) + foreach (values %{$packages->{names}}) { my $p = $_; packageSetFlagUpgrade($p, 1) 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}) { - if (packageFlagBase($packages->[0]{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()) { - push @$toSave, $files[$i] unless $files[$i] =~ /kdelnk/; #- avoid doublons for KDE. - } - } - } - } - }); - } - - #- close db, job finished ! - c::rpmdbClose($db); - log::l("done selecting packages to upgrade"); - - #- update external copy with local one. - @{$toRemove || []} = keys %toRemove; } sub allowedToUpgrade { $_[0] !~ /^(kernel|kernel-secure|kernel-smp|kernel-linus|hackkernel)$/ } @@ -1127,8 +1197,8 @@ sub install($$$;$$) { my $callbackOpen = sub { my $p = $packages{$_[0]}; my $f = packageFile($p); - print LOG "$f $p->{medium}{descr}\n"; - my $fd = install_any::getFile($f, $p->{medium}{descr}); + print LOG "$f $p->[$MEDIUM]{descr}\n"; + my $fd = install_any::getFile($f, $p->[$MEDIUM]{descr}); $fd ? fileno $fd : -1; }; my $callbackClose = sub { packageSetFlagInstalled(delete $packages{$_[0]}, 1) }; @@ -1159,7 +1229,7 @@ sub install($$$;$$) { while ($i <= $media->{$medium}{max} && ($i < $min || scalar @transToInstall < $limitMinTrans)) { my $dep = $packages{packageName($depOrder->[$i++])} or next; - if ($dep->{medium}{selected}) { + if ($dep->[$MEDIUM]{selected}) { push @transToInstall, $dep; foreach (map { split '\|' } packageDepsId($dep)) { $min < $_ and $min = $_; @@ -1186,7 +1256,7 @@ sub install($$$;$$) { #- 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($transToInstall[0]), $transToInstall[0]{medium}{descr}); + install_any::getFile(packageFile($transToInstall[0]), $transToInstall[0][$MEDIUM]{descr}); #- and make sure there are no staling open file descriptor too! install_any::getFile('XXX'); @@ -1228,7 +1298,7 @@ sub install($$$;$$) { my $trans = c::rpmtransCreateSet($db, $prefix); 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($_))) + c::rpmtransAddPackage($trans, $_->[$HEADER], packageName($_), $isUpgrade && allowedToUpgrade(packageName($_))) foreach @transToInstall; c::rpmdepOrder($trans) or @@ -1264,15 +1334,15 @@ sub install($$$;$$) { close OUTPUT; c::_exit(0); } - c::headerFree(delete $_->{header}) foreach @transToInstall; + packageFreeHeader($_) foreach @transToInstall; cleanHeaders($prefix); - if (my @badpkgs = grep { !packageFlagInstalled($_) && $_->{medium}{selected} && !exists($ignoreBadPkg{packageName($_)}) } @transToInstall) { + if (my @badpkgs = grep { !packageFlagInstalled($_) && $_->[$MEDIUM]{selected} && !exists($ignoreBadPkg{packageName($_)}) } @transToInstall) { foreach (@badpkgs) { - log::l("bad package $_->{file}"); + log::l("bad package $_->[$FILE]"); packageSetFlagSelected($_, 0); } - cdie ("error installing package list: " . join(", ", map { $_->{file} } @badpkgs)); + cdie ("error installing package list: " . join(", ", map { $_->[$FILE] } @badpkgs)); } } while ($nb > 0 && !$pkgs::cancel_install); |