diff options
Diffstat (limited to 'perl-install')
| -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); |