summaryrefslogtreecommitdiffstats
path: root/perl-install/pkgs.pm
diff options
context:
space:
mode:
Diffstat (limited to 'perl-install/pkgs.pm')
-rw-r--r--perl-install/pkgs.pm1448
1 files changed, 1301 insertions, 147 deletions
diff --git a/perl-install/pkgs.pm b/perl-install/pkgs.pm
index 1f4764d22..e21e12ccd 100644
--- a/perl-install/pkgs.pm
+++ b/perl-install/pkgs.pm
@@ -1,211 +1,1365 @@
-package pkgs;
+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 common qw(:common :file);
+use common qw(:common :file :functional);
+use install_any;
+use commands;
+use run_program;
use log;
-use smp;
+use pkgs;
use fs;
+use loopback;
+use lang;
+use c;
-my @skipList = qw(XFree86-8514 XFree86-AGX XFree86-Mach32 XFree86-Mach64 XFree86-Mach8 XFree86-Mono
- XFree86-P9000 XFree86-S3 XFree86-S3V XFree86-SVGA XFree86-W32 XFree86-I128
- XFree86-Sun XFree86-SunMono XFree86-Sun24 XFree86-3DLabs kernel-boot
- metroess metrotmpl);
+#- lower bound on the left ( aka 90 means [90-100[ )
+%compssListDesc = (
+ 100 => __("mandatory"), #- do not use it, it's for base packages
+ 90 => __("must have"), #- every install have these packages (unless hand de-selected in expert, or not enough room)
+ 80 => __("important"), #- every beginner/custom install have these packages (unless not enough space)
+ #- has minimum X install (XFree86 + icewm)(normal)
+ 70 => __("very nice"), #- KDE(normal)
+ 60 => __("nice"), #- gnome(normal)
+ 50 => __("interesting"),
+ 40 => __("interesting"),
+ 30 => __("maybe"),
+ 20 => __("maybe"),
+ 10 => __("maybe"),#__("useless"),
+ 0 => __("maybe"),#__("garbage"),
+#- if the package requires locales-LANG and LANG is chosen, rating += 90
+#- if the package is in %by_lang and the corresponding LANG is chosen, rating += 90 (see %by_lang below)
+ -10 => __("i18n (important)"), #- every install in the corresponding lang have these packages
+ -20 => __("i18n (very nice)"), #- every beginner/custom install in the corresponding lang have theses packages
+ -30 => __("i18n (nice)"),
+);
+#- HACK: rating += 50 for some packages (like kapm, cf install_any::setPackages)
-1;
+%by_lang = (
+ 'ar' => [ 'acon' ],
+#'be_BE.CP1251' => [ 'fonts-ttf-cyrillic' ],
+#'bg_BG' => [ 'fonts-ttf-cyrillic' ],
+ 'cs' => [ 'XFree86-ISO8859-2', 'XFree86-ISO8859-2-75dpi-fonts' ],
+# 'cy' => iso8859-14 fonts
+# 'el' => greek fonts
+# 'eo' => iso8859-3 fonts
+ 'fa' => [ 'acon' ],
+ 'he' => [ 'acon' ],
+ 'hr' => [ 'XFree86-ISO8859-2', 'XFree86-ISO8859-2-75dpi-fonts' ],
+ 'hu' => [ 'XFree86-ISO8859-2', 'XFree86-ISO8859-2-75dpi-fonts' ],
+ 'hy' => [ 'fonts-ttf-armenian' ],
+ 'ja' => [ 'rxvt-CLE', 'fonts-ttf-japanese', 'kterm' ],
+# 'ka' => georgian fonts
+ 'ko' => [ 'rxvt-CLE', 'fonts-ttf-korean' ],
+ 'lt' => [ 'fonts-type1-baltic' ],
+ 'lv' => [ 'fonts-type1-baltic' ],
+ 'mi' => [ 'fonts-type1-baltic' ],
+# 'mk' => [ 'fonts-ttf-cyrillic' ],
+ 'pl' => [ 'XFree86-ISO8859-2', 'XFree86-ISO8859-2-75dpi-fonts' ],
+ 'ro' => [ 'XFree86-ISO8859-2', 'XFree86-ISO8859-2-75dpi-fonts' ],
+# 'ru' => [ 'XFree86-cyrillic-fonts', 'fonts-ttf-cyrillic' ],
+ 'ru' => [ 'XFree86-cyrillic-fonts' ],
+ 'ru_RU.KOI8-R' => [ 'XFree86-cyrillic-fonts' ],
+ 'sk' => [ 'XFree86-ISO8859-2', 'XFree86-ISO8859-2-75dpi-fonts' ],
+ 'sl' => [ 'XFree86-ISO8859-2', 'XFree86-ISO8859-2-75dpi-fonts' ],
+# 'sp' => [ 'fonts-ttf-cyrillic' ],
+ 'sr' => [ 'XFree86-ISO8859-2', 'XFree86-ISO8859-2-75dpi-fonts' ],
+# 'th' => thai fonts
+ 'tr' => [ 'XFree86-ISO8859-9', 'XFree86-ISO8859-9-75dpi-fonts' ],
+#'uk_UA' => [ 'fonts-ttf-cyrillic' ],
+# 'vi' => vietnamese fonts
+ 'yi' => [ 'acon' ],
+ 'zh' => [ 'rxvt-CLE', 'taipeifonts', 'fonts-ttf-big5', 'fonts-ttf-gb2312' ],
+ 'zh_CN.GB2312' => [ 'rxvt-CLE', 'fonts-ttf-gb2312' ],
+ 'zh_TW.Big5' => [ 'rxvt-CLE', 'taipeifonts', 'fonts-ttf-big5' ],
+);
+@skip_list = qw(
+XFree86-8514 XFree86-AGX XFree86-Mach32 XFree86-Mach64 XFree86-Mach8 XFree86-Mono
+XFree86-P9000 XFree86-S3 XFree86-S3V XFree86-SVGA XFree86-W32 XFree86-I128
+XFree86-Sun XFree86-SunMono XFree86-Sun24 XFree86-3DLabs
+MySQL MySQL_GPL mod_php3 midgard postfix metroess metrotmpl
+kernel-linus kernel-secure kernel-BOOT
+hackkernel hackkernel-BOOT hackkernel-headers
+hackkernel-pcmcia-cs hackkernel-smp hackkernel-smp-fb
+autoirpm autoirpm-icons numlock
+);
-sub psUsingDirectory {
- my ($dirname) = @_;
- my %packages;
+@preferred = qw(perl-GTK postfix wu-ftpd ghostscript-X vim-minimal kernel ispell-en);
- log::l("scanning $dirname for packages");
- foreach (glob_("$dirname/*.rpm")) {
- my $basename = basename($_);
- local *F;
- open F, $_ or log::l("failed to open package $_: $!");
- my $header = c::rpmReadPackageHeader($_) or log::l("failed to rpmReadPackageHeader $basename: $!");
- my $name = c::headerGetEntry($header, 'name');
-
- $packages{lc $name} = {
- header => $header, selected => 0, manuallySelected => 0, name => $name,
- size => c::headerGetEntry($header, 'size'),
- group => c::headerGetEntry($header, 'group') || "(unknown group)",
- inmenu => skipPackage($name),
- };
+#- constant for small transaction.
+$limitMinTrans = 8;
+
+#- constant for packing flags, see below.
+$PKGS_SELECTED = 0x00ffffff;
+$PKGS_FORCE = 0x01000000;
+$PKGS_INSTALLED = 0x02000000;
+$PKGS_BASE = 0x04000000;
+$PKGS_SKIP = 0x08000000;
+$PKGS_UPGRADE = 0x20000000;
+
+#- package to ignore, typically in Application CD.
+my %ignoreBadPkg = (
+ 'civctp-demo' => 1,
+ 'eus-demo' => 1,
+ 'myth2-demo' => 1,
+ 'heretic2-demo' => 1,
+ 'heroes3-demo' => 1,
+ 'rt2-demo' => 1,
+ );
+
+#- basic methods for extracting informations about packages.
+#- to save memory, (name, version, release) are no more stored, they
+#- are directly generated from (file).
+#- all flags are grouped together into (flags), these includes the
+#- 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 packageSize { my ($pkg) = @_; to_int($pkg->{sizeDeps}) }
+sub packageDepsId { my ($pkg) = @_; split ' ', ($pkg->{sizeDeps} =~ /^\d*\s*(.*)/)[0] }
+
+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 packageSetFlagSelected { my ($pkg, $v) = @_; $pkg->{flags} &= ~$PKGS_SELECTED; $pkg->{flags} |= $v & $PKGS_SELECTED; }
+
+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 packageProvides { my ($pkg) = @_; @{$pkg->{provides} || []} }
+
+sub packageFile {
+ my ($pkg) = @_;
+ $pkg->{header} or die "packageFile: missing header";
+ $pkg->{file} =~ /([^\(]*)(?:\([^\)]*\))?(-[^-]+-[^-]+)/;
+ "$1$2." . c::headerGetEntry($pkg->{header}, 'arch') . ".rpm";
+}
+
+sub packageSelectedOrInstalled { my ($pkg) = @_; packageFlagSelected($pkg) || packageFlagInstalled($pkg) }
+
+sub packageId {
+ my ($packages, $pkg) = @_;
+ my $i = 0;
+ foreach (@{$packages->[1]}) { return $i if $pkg == $packages->[1][$i]; $i++ }
+ return;
+}
+
+sub cleanHeaders {
+ my ($prefix) = @_;
+ commands::rm("-rf", "$prefix/tmp/headers") if -e "$prefix/tmp/headers";
+}
+
+#- get all headers from an hdlist file.
+sub extractHeaders($$$) {
+ my ($prefix, $pkgs, $medium) = @_;
+
+ cleanHeaders($prefix);
+
+ run_program::run("packdrake", "-x",
+ "/tmp/$medium->{hdlist}",
+ "$prefix/tmp/headers",
+ map { packageHeaderFile($_) } @$pkgs);
+
+ foreach (@$pkgs) {
+ my $f = "$prefix/tmp/headers/". packageHeaderFile($_);
+ local *H;
+ open H, $f or log::l("unable to open header file $f: $!"), next;
+ $_->{header} = c::headerRead(fileno H, 1) or log::l("unable to read header of package ". packageHeaderFile($_));
+ }
+ @$pkgs = grep { $_->{header} } @$pkgs;
+}
+
+#- size and correction size functions for packages.
+#- invCorrectSize corrects size in the range 0 to 3Gb approximately, so
+#- it should not be used outside these levels.
+#- but since it is an inverted parabolic curve starting above 0, we can
+#- get a solution where X=Y at approximately 9.3Gb. we use this point as
+#- a limit to change the approximation to use a linear one.
+#- for information above this point, we have the corrected size below the
+#- original size wich is absurd, this point is named D below.
+my $A = -121568/100000000000; # -1.21568e-05; #- because perl does like that on some language (TO BE FIXED QUICKLY)
+my $B = 121561/100000; # 1.21561
+my $C = -239889/10000; # -23.9889 #- doesn't take hdlist's into account as getAvailableSpace will do it.
+my $D = (-sqrt(sqr($B - 1) - 4 * $A * $C) - ($B - 1)) / 2 / $A; #- $A is negative so a positive solution is with - sqrt ...
+sub correctSize {
+ my $csz = ($A * $_[0] + $B) * $_[0] + $C;
+ $csz > $_[0] ? $csz : $_[0]; #- size correction (in MB) should be above input argument (as $A is negative).
+}
+sub invCorrectSize {
+ my $sz = $_[0] < $D ? (sqrt(sqr($B) + 4 * $A * ($_[0] - $C)) - $B) / 2 / $A : $_[0];
+ $sz < $_[0] ? $sz : $_[0];
+}
+
+sub selectedSize {
+ my ($packages) = @_;
+ my $size = 0;
+ foreach (values %{$packages->[0]}) {
+ packageFlagSelected($_) && !packageFlagInstalled($_) and $size += packageSize($_) - ($_->{installedCumulSize} || 0);
+ }
+ $size;
+}
+sub correctedSelectedSize { correctSize(selectedSize($_[0]) / sqr(1024)) }
+
+
+#- searching and grouping methods.
+#- package is a reference to list that contains
+#- a hash to search by name and
+#- a list to search by id.
+sub packageByName {
+ my ($packages, $name) = @_;
+ $packages->[0]{$name} or log::l("unknown package `$name'") && undef;
+}
+sub packageById {
+ my ($packages, $id) = @_;
+ $packages->[1][$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]};
+}
+sub packagesOfMedium {
+ my ($packages, $mediumName) = @_;
+ my $medium = $packages->[2]{$mediumName};
+ grep { $_->{medium} == $medium } @{$packages->[1]};
+}
+sub packagesToInstall {
+ my ($packages) = @_;
+ grep { $_->{medium}{selected} && packageFlagSelected($_) && !packageFlagInstalled($_) } values %{$packages->[0]};
+}
+
+sub allMediums {
+ my ($packages) = @_;
+ keys %{$packages->[2]};
+}
+sub mediumDescr {
+ my ($packages, $medium) = @_;
+ $packages->[2]{$medium}{descr};
+}
+
+#- selection, unselection of package.
+sub selectPackage { #($$;$$$)
+ my ($packages, $pkg, $base, $otherOnly, $check_recursion) = @_;
+
+ #- check if the same or better version is installed,
+ #- do not select in such case.
+ packageFlagInstalled($pkg) and return;
+
+ #- check for medium selection, if the medium has not been
+ #- selected, the package cannot be selected.
+ $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;
+
+ #- make sure base package are set even if already selected.
+ $base and packageSetFlagBase($pkg, 1);
+
+ #- select package and dependancies, otherOnly may be a reference
+ #- to a hash to indicate package that will strictly be selected
+ #- when value is true, may be selected when value is false (this
+ #- is only used for unselection, not selection)
+ unless (packageFlagSelected($pkg)) {
+ foreach (packageDepsId($pkg)) {
+ my $preferred;
+ if (/\|/) {
+ #- choice deps should be reselected recursively as no
+ #- closure on them is computed, this code is exactly the
+ #- same as pixel's one.
+ my %preferred; @preferred{@preferred} = ();
+ foreach (split '\|') {
+ my $dep = packageById($packages, $_) or next;
+ $preferred ||= $dep;
+ packageFlagSelected($dep) and $preferred = $dep, last;
+ exists $preferred{packageName($dep)} and $preferred = $dep;
+ }
+ selectPackage($packages, $preferred, $base, $otherOnly, $check_recursion) if $preferred;
+ } else {
+ #- deps have been closed except for choices, so no need to
+ #- recursively apply selection, expand base on it.
+ my $dep = packageById($packages, $_);
+ $base and packageSetFlagBase($dep, 1);
+ $otherOnly and !packageFlagSelected($dep) and $otherOnly->{packageName($dep)} = 1;
+ $otherOnly or packageSetFlagSelected($dep, 1+packageFlagSelected($dep));
+ }
+ }
+ }
+ $otherOnly and !packageFlagSelected($pkg) and $otherOnly->{packageName($pkg)} = 1;
+ $otherOnly or packageSetFlagSelected($pkg, 1+packageFlagSelected($pkg));
+ 1;
+}
+sub unselectPackage($$;$) {
+ my ($packages, $pkg, $otherOnly) = @_;
+
+ #- base package are not unselectable,
+ #- and already unselected package are no more unselectable.
+ packageFlagBase($pkg) and return;
+ packageFlagSelected($pkg) or return;
+
+ #- dependancies may be used to propose package that may be not
+ #- usefull for the user, since their counter is just one and
+ #- they are not used any more by other packages.
+ #- provides are closed and are taken into account to get possible
+ #- unselection of package (value false on otherOnly) or strict
+ #- unselection (value true on otherOnly).
+ foreach my $provided ($pkg, packageProvides($pkg)) {
+ packageFlagBase($provided) and die "a provided package cannot be a base package";
+ if (packageFlagSelected($provided)) {
+ my $unselect_alone = 0;
+ foreach (packageDepsId($provided)) {
+ if (/\|/) {
+ #- this package use a choice of other package, so we have to check
+ #- if our package is not included in the choice, if this is the
+ #- case, if must be checked one of the other package are selected.
+ foreach (split '\|') {
+ my $dep = packageById($packages, $_);
+ $dep == $pkg and $unselect_alone |= 1;
+ packageFlagBase($dep) || packageFlagSelected($dep) and $unselect_alone |= 2;
+ }
+ }
+ }
+ #- provided will not be unselect here if the two conditions are met.
+ $unselect_alone == 3 and next;
+ #- on the other hand, provided package have to be unselected.
+ $otherOnly or packageSetFlagSelected($provided, 0);
+ $otherOnly and $otherOnly->{packageName($provided)} = 1;
+ }
+ foreach (map { split '\|' } packageDepsId($provided)) {
+ my $dep = packageById($packages, $_);
+ packageFlagBase($dep) and next;
+ packageFlagSelected($dep) or next;
+ for (packageFlagSelected($dep)) {
+ $_ == 1 and do { $otherOnly and $otherOnly->{packageName($dep)} ||= 0; };
+ $_ > 1 and do { $otherOnly or packageSetFlagSelected($dep, $_-1); };
+ last;
+ }
+ }
+ }
+ 1;
+}
+sub togglePackageSelection($$;$) {
+ my ($packages, $pkg, $otherOnly) = @_;
+ packageFlagSelected($pkg) ? unselectPackage($packages, $pkg, $otherOnly) : selectPackage($packages, $pkg, 0, $otherOnly);
+}
+sub setPackageSelection($$$) {
+ my ($packages, $pkg, $value) = @_;
+ $value ? selectPackage($packages, $pkg) : unselectPackage($packages, $pkg);
+}
+
+sub unselectAllPackages($) {
+ my ($packages) = @_;
+ foreach (values %{$packages->[0]}) {
+ unless (packageFlagBase($_) || packageFlagUpgrade($_)) {
+ packageSetFlagSelected($_, 0);
+ }
+ }
+}
+sub unselectAllPackagesIncludingUpgradable($) {
+ my ($packages, $removeUpgradeFlag) = @_;
+ foreach (values %{$packages->[0]}) {
+ unless (packageFlagBase($_)) {
+ packageSetFlagSelected($_, 0);
+ packageSetFlagUpgrade($_, 0);
+ }
}
- \%packages;
}
-sub psReadComponentsFile {
- my ($compsfile, $packages) = @_;
- my (%comps, %current);
+sub skipSetWithProvides {
+ my ($packages, @l) = @_;
+ packageSetFlagSkip($_, 1) foreach grep { $_ } map { $_, packageProvides($_) } @l;
+}
+
+sub psUpdateHdlistsDeps {
+ my ($prefix, $method) = @_;
+ my $listf = install_any::getFile('Mandrake/base/hdlists') or die "no hdlists found";
+
+ #- WARNING: this function should be kept in sync with functions
+ #- psUsingHdlists and psUsingHdlist.
+ #- it purpose it to update hdlist files on system to install.
+
+ #- parse hdlist.list file.
+ my $medium = 1;
+ local $_;
+ while (<$listf>) {
+ chomp;
+ s/\s*#.*$//;
+ /^\s*$/ and next;
+ m/^\s*(hdlist\S*\.cz2?)\s+(\S+)\s*(.*)$/ or die "invalid hdlist description \"$_\" in hdlists file";
+ my ($hdlist, $rpmsdir, $descr) = ($1, $2, $3);
+
+ #- copy hdlist file directly to $prefix/var/lib/urpmi, this will be used
+ #- for getting header of package during installation or after by urpmi.
+ my $fakemedium = $method . $medium;
+ my $newf = "$prefix/var/lib/urpmi/hdlist.$fakemedium.cz" . ($hdlist =~ /\.cz2/ && "2");
+ -e $newf and do { unlink $newf or die "cannot remove $newf: $!"; };
+ install_any::getAndSaveFile("Mandrake/base/$hdlist", $newf) or die "no $hdlist found";
+ symlinkf $newf, "/tmp/$hdlist";
+ ++$medium;
+ }
- local *F;
- open F, $compsfile or die "Cannot open components file: $!";
+ #- this is necessary for urpmi.
+ install_any::getAndSaveFile('Mandrake/base/depslist.ordered', "$prefix/var/lib/urpmi/depslist.ordered");
+ install_any::getAndSaveFile('Mandrake/base/provides', "$prefix/var/lib/urpmi/provides");
+ install_any::getAndSaveFile('Mandrake/base/compss', "$prefix/var/lib/urpmi/compss");
+}
- <F> =~ /^0(\.1)?$/ or die "Comps file is not version 0.1 as expected";
+sub psUsingHdlists {
+ my ($prefix, $method) = @_;
+ my $listf = install_any::getFile('Mandrake/base/hdlists') or die "no hdlists found";
+ my @packages = ({}, [], {});
+ my @hdlists;
- my $inComp = 0;
- my $n = 0;
- foreach (<F>) { $n++;
+ #- parse hdlist.list file.
+ my $medium = 1;
+ local $_;
+ while (<$listf>) {
chomp;
- s/^ +//;
- /^#/ and next;
- /^$/ and next;
+ 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);
+
+ }
+
+ log::l("psUsingHdlists read " . scalar keys(%{$packages[0]}) . " headers on " . scalar keys(%{$packages[2]}) . " hdlists");
- if ($inComp) { if (/^end$/) {
- $inComp = 0;
- $comps{lc $current{name}} = { %current };
+ \@packages;
+}
+
+sub psUsingHdlist {
+ my ($prefix, $method, $packages, $hdlist, $medium, $rpmsdir, $descr, $selected, $fhdlist) = @_;
+
+ #- 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.
+ };
+
+ #- copy hdlist file directly to $prefix/var/lib/urpmi, this will be used
+ #- for getting header of package during installation or after by urpmi.
+ my $newf = "$prefix/var/lib/urpmi/hdlist.$fakemedium.cz" . ($hdlist =~ /\.cz2/ && "2");
+ -e $newf and do { unlink $newf or die "cannot remove $newf: $!"; };
+ install_any::getAndSaveFile($fhdlist || "Mandrake/base/$hdlist", $newf) or die "no $hdlist found";
+ symlinkf $newf, "/tmp/$hdlist";
+
+ #- extract filename from archive, this take advantage of verifying
+ #- the archive too.
+ local *F; open F, "packdrake $newf |";
+ local $_;
+ while (<F>) {
+ 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 $specific_arch = packageSpecificArch($pkg);
+ if (!$specific_arch || compat_arch($specific_arch)) {
+ my $old_pkg = $packages->[0]{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;
+ } else {
+ log::l("keeping old package against package $1 with worse arch");
+ }
+ } else {
+ log::l("ignoring package $1 already present in distribution with different version or release");
+ }
+ } else {
+ $packages->[0]{packageName($pkg)} = $pkg;
+ }
} else {
- push @{$current{packages}}, $packages->{lc $_} || log::w "package $_ does not exist (line $n of comps file)";
+ log::l("ignoring package $1 with incompatible arch: $specific_arch");
}
} else {
- my ($selected, $hidden, $name) = /^([01])\s*(--hide)?\s*(.*)/ or die "bad comps file at line $n";
- %current = (selected => $selected, inmenu => !$hidden, name => $name);
- $inComp = 1;
+ die "bad hdlist file: $newf";
}
}
- log::l("read " . (scalar keys %comps) . " comps");
- \%comps;
+ close F or die "unable to parse $newf";
+
+ #- update maximal index.
+ $m->{max} = scalar(keys %{$packages->[0]}) - 1;
+ $m->{max} >= $m->{min} or die "nothing found while parsing $newf";
+ log::l("read " . ($m->{max} - $m->{min} + 1) . " headers in $hdlist");
+ 1;
}
+sub getOtherDeps($$) {
+ my ($packages, $f) = @_;
+ #- this version of getDeps is customized for handling errors more easily and
+ #- convert reference by name to deps id including closure computation.
+ local $_;
+ while (<$f>) {
+ my ($name, $version, $release, $size, $deps) = /^(\S*)-([^-\s]+)-([^-\s]+)\s+(\d+)\s+(.*)/;
+ my $pkg = $packages->[0]{$name};
-sub psVerifyDependencies {
-# my ($packages, $fixup) = @_;
-#
-# -r "/mnt/var/lib/rpm/packages.rpm" or die "can't find packages.rpm";
-#
-# my $db = rpmdbOpenRWCreate("/mnt");
-# my $rpmdeps = rpmtransCreateSet($db, undef);
-#
-# foreach (values %$packages) {
-# $_->{selected} ?
-# c::rpmtransAddPackage($rpmdeps, $_->{header}, undef, $_, 0, undef) :
-# c::rpmtransAvailablePackage($rpmdeps, $_->{header}, $_);
-# }
-# my @conflicts = c::rpmdepCheck($rpmdeps);
-#
-# rpmtransFree($rpmdeps);
-# rpmdbClose($db);
-#
-# if ($fixup) {
-# foreach (@conflicts) {
-# $_->{suggestedPackage}->{selected} = 1;
-# }
-# rpmdepFreeConflicts(@conflicts);
-# }
-#
-# 1;
+ $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}
+ or log::l("ignoring package $name-$version-$release in depslist outside of hdlist indexation");
+
+ #- here we have to translate referenced deps by name to id.
+ #- this include a closure on deps too.
+ my %closuredeps;
+ @closuredeps{map { packageId($packages, $_), packageDepsId($_) }
+ grep { $_ }
+ map { packageByName($packages, $_) or do { log::l("unknown package $_ in depslist for closure"); undef } }
+ split /\s+/, $deps} = ();
+
+ $pkg->{sizeDeps} = join " ", $size, keys %closuredeps;
+
+ push @{$packages->[1]}, $pkg;
+ }
+
+ #- check for same number of package in depslist and hdlists, avoid being to hard.
+ scalar(keys %{$packages->[0]}) == scalar(@{$packages->[1]})
+ or log::l("other depslist has not same package as hdlist file");
}
-sub selectComponents {
- my ($csp, $psp, $doIndividual) = @_;
+sub getDeps($) {
+ my ($prefix, $packages) = @_;
+
+ #- this is necessary for urpmi.
+ install_any::getAndSaveFile('Mandrake/base/depslist.ordered', "$prefix/var/lib/urpmi/depslist.ordered");
+ install_any::getAndSaveFile('Mandrake/base/provides', "$prefix/var/lib/urpmi/provides");
+
+ #- beware of heavily mismatching depslist.ordered file against hdlist files.
+ my $mismatch = 0;
- return 0;
+ #- update dependencies list, provides attributes are updated later
+ #- cross reference to be resolved on id (think of loop requires)
+ #- provides should be updated after base flag has been set to save
+ #- memory.
+ local *F; open F, "$prefix/var/lib/urpmi/depslist.ordered" or die "can't find dependancies list";
+ local $_;
+ while (<F>) {
+ my ($name, $version, $release, $sizeDeps) = /^(\S*)-([^-\s]+)-([^-\s]+)\s+(.*)/;
+ my $pkg = $packages->[0]{$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;
+
+ #- 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;
+
+ #- package are already sorted in depslist to enable small transaction and multiple medium.
+ push @{$packages->[1]}, $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";
}
-sub psFromHeaderListDesc {
- my ($fd, $noSeek) = @_;
- my %packages;
- my $end;
+sub getProvides($) {
+ my ($packages) = @_;
- unless ($noSeek) {
- my $current = sysseek $fd, 0, 1 or die "seek failed";
- $end = sysseek $fd, 0, 2 or die "seek failed";
- sysseek $fd, $current, 0 or die "seek failed";
+ #- update provides according to dependencies, here are stored
+ #- reference to package directly and choice are included, this
+ #- assume only 1 of the choice is selected, else on unselection
+ #- the provided package will be deleted where other package still
+ #- need it.
+ #- base package are not updated because they cannot be unselected,
+ #- this save certainly a lot of memory since most of them may be
+ #- needed by a large number of package.
+
+ foreach my $pkg (@{$packages->[1]}) {
+ 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);
}
+}
+
+sub readCompss {
+ my ($prefix, $packages) = @_;
+ my ($p, @compss);
+
+ #- this is necessary for urpmi.
+ install_any::getAndSaveFile('Mandrake/base/compss', "$prefix/var/lib/urpmi/compss");
- while (1) {
- my $header = c::headerRead(fileno($fd), 1);
- unless ($header) {
- $noSeek and last;
- die "error reading header at offset ", sysseek($fd, 0, 1);
+ local *F; open F, "$prefix/var/lib/urpmi/compss" or die "can't find compss";
+ local $_;
+ while (<F>) {
+ /^\s*$/ || /^#/ and next;
+ s/#.*//;
+
+ if (/^(\S.*)/) {
+ $p = $1;
+ } else {
+ /(\S+)/;
+ $packages->[0]{$1} or log::l("unknown package $1 in compss"), next;
+ push @compss, "$p/$1";
}
-
- my $name = c::headerGetEntry($header, 'name');
+ }
+ \@compss;
+}
- $packages{lc $name} = {
- header => $header, size => c::headerGetEntry($header, 'size'),
- inmenu => skipPackage($name), name => $name,
- group => c::headerGetEntry($header, 'group') || "(unknown group)",
- };
+sub readCompssList {
+ my ($packages, $langs) = @_;
+ my $f = install_any::getFile('Mandrake/base/compssList') or die "can't find compssList";
+ my @levels = split ' ', <$f>;
- $noSeek or $end <= sysseek($fd, 0, 1) and last;
+ local $_;
+ while (<$f>) {
+ /^\s*$/ || /^#/ and next;
+ my ($name, @values) = split;
+ my $p = packageByName($packages, $name) or log::l("unknown entry $name (in compssList)"), next;
+ $p->{values} = \@values;
}
- log::l("psFromHeaderListDesc read " . scalar keys(%packages) . " headers");
-
- \%packages;
+ my %done;
+ foreach (@$langs) {
+ my $p = packageByName($packages, "locales-$_") or next;
+ foreach ($p, @{$p->{provides} || []}, map { packageByName($packages, $_) } @{$by_lang{$_} || []}) {
+ next if !$_ || $done{$_}; $done{$_} = 1;
+ $_->{values} = [ map { $_ + 90 } @{$_->{values} || [ (0) x @levels ]} ];
+ }
+ }
+ my $l = { map_index { $_ => $::i } @levels };
}
-sub psFromHeaderListFile {
- my ($file) = @_;
- local *F;
- sysopen F, $file, 0 or die "error opening header file: $!";
- psFromHeaderListDesc(\*F, 0);
+sub readCompssUsers {
+ my ($packages, $compss, $meta_class) = @_;
+ my (%compssUsers, %compssUsersIcons, , %compssUsersDescr, @sorted, $l);
+ my (%compss);
+ foreach (@$compss) {
+ local ($_, $a) = m|(.*)/(.*)|;
+ do { push @{$compss{$_}}, $a } while s|/[^/]+||;
+ }
+
+ my $map = sub {
+ $l or return;
+ $_ = $packages->[0]{$_} 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";
+ local $_;
+ while (<$f>) {
+ /^\s*$/ || /^#/ and next;
+ s/#.*//;
+
+ if (/^(\S.*)/) {
+ &$map;
+ my ($icon, $descr);
+ /^(.*?)\s*\[icon=(.*?)\](.*)/ and $_ = "$1$3", $icon = $2;
+ /^(.*?)\s*\[descr=(.*?)\](.*)/ and $_ = "$1$3", $descr = $2;
+ $compssUsersIcons{$_} = $icon;
+ $compssUsersDescr{$_} = $descr;
+ push @sorted, $_;
+ $compssUsers{$_} = $l = [];
+ } elsif (/\s+\+(\S+)/) {
+ push @$l, $1;
+ } elsif (/^\s+(.*?)\s*$/) {
+ push @$l, @{$compss{$1} || log::l("unknown category $1 (in compssUsers)") && []};
+ }
+ }
+ &$map;
+ \%compssUsers, \@sorted, \%compssUsersIcons, \%compssUsersDescr;
}
-sub skipPackage { member($_[0], @skipList) }
+sub setSelectedFromCompssList {
+ my ($compssListLevels, $packages, $min_level, $max_size, $install_class) = @_;
+ my $ind = $compssListLevels->{$install_class}; defined $ind or log::l("unknown install class $install_class in compssList"), return;
+ my $nb = selectedSize($packages);
+ my @packages = allPackages($packages);
+ my @places = do {
+ #- special case for /^k/ aka kde stuff
+ my @values = map { $_->{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;
-sub printSize { }
-sub printGroup { }
-sub printPkg { }
-sub selectPackagesByGroup { }
-sub showPackageInfo { }
-sub queryIndividual { }
+ #- determine the packages that will be selected when
+ #- selecting $p. the packages are not selected.
+ my %newSelection;
+ selectPackage($packages, $p, 0, \%newSelection);
+ #- this enable an incremental total size.
+ my $old_nb = $nb;
+ foreach (grep { $newSelection{$_} } keys %newSelection) {
+ $nb += packageSize($packages->[0]{$_});
+ }
+ if ($max_size && $nb > $max_size) {
+ $nb = $old_nb;
+ $min_level = $p->{values}[$ind];
+ last;
+ }
+
+ #- at this point the package can safely be selected.
+ selectPackage($packages, $p);
+ }
+ log::l("setSelectedFromCompssList: reached size $nb, up to indice $min_level (less than $max_size)");
+ $ind, $min_level;
+}
-sub install {
- my ($rootPath, $method, $packages, $isUpgrade, $force) = @_;
+#- usefull to know the size it would take for a given min_level/max_size
+#- just saves the selected packages, call setSelectedFromCompssList and restores the selected packages
+sub saveSelected {
+ my ($packages) = @_;
+ my @l = values %{$packages->[0]};
+ my @flags = map { pkgs::packageFlagSelected($_) } @l;
+ [ $packages, \@l, \@flags ];
+}
+sub restoreSelected {
+ my ($packages, $l, $flags) = @{$_[0]};
+ mapn { pkgs::packageSetFlagSelected(@_) } $l, $flags;
+}
- my $f = "$rootPath/tmp/" . ($isUpgrade ? "upgrade" : "install") . ".log";
- local *F;
- open(F, "> $f") ? log::l("opened $f") : log::l("Failed to open $f. No upgrade log will be kept.");
- my $fd = fileno(F) || log::fd() || 2;
- c::rpmErrorSetCallback($fd);
-# c::rpmSetVeryVerbose();
-
- # FIXME: we ought to read /mnt/us/lib/rpmrc if we're in the midst of an upgrade, but it's not obvious how to get RPM to do that.
- # if we set netshared path to "" then we get no files installed
- # addMacro(&globalMacroContext, "_netsharedpath", NULL, netSharedPath ? netSharedPath : "" , RMIL_RPMRC);
-
- $isUpgrade ? c::rpmdbRebuild($rootPath) : c::rpmdbInit($rootPath, 0644) or die "creation/rebuilding of rpm database failed: ", c::rpmErrorString();
- my $db = c::rpmdbOpen($rootPath) or die "error opening RPM database: ", c::rpmErrorString();
- log::l("opened rpm database");
+sub init_db {
+ my ($prefix, $isUpgrade) = @_;
- my $trans = c::rpmtransCreateSet($db, $rootPath);
+ 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.");
+ *LOG or *LOG = log::F() or *LOG = *STDERR;
+ CORE::select((CORE::select(LOG), $| = 1)[0]);
+ c::rpmErrorSetCallback(fileno LOG);
+#- c::rpmSetVeryVerbose();
- my ($total, $nb);
+ log::l("reading /usr/lib/rpm/rpmrc");
+ c::rpmReadConfigFiles() or die "can't read rpm config files";
+ log::l("\tdone");
- foreach my $p ($packages->{basesystem},
- grep { $_->{selected} && $_->{name} ne "basesystem" } values %$packages) {
- my $fullname = sprintf "%s-%s-%s.%s.rpm",
- $p->{name},
- map { c::headerGetEntry($p->{header}, $_) } qw(version release arch);
- c::rpmtransAddPackage($trans, $p->{header}, $method->getFile($fullname) , $isUpgrade);
+ if ($isUpgrade) {
+ c::rpmdbRebuild($prefix) or die "rebuilding of rpm database failed: ", c::rpmErrorString();
+ }
+ #- seems no more necessary to rpmdbInit ?
+ #c::rpmdbOpen($prefix) or die "creation of rpm database failed: ", c::rpmErrorString();
+}
+
+sub done_db {
+ log::l("closing install.log file");
+ close LOG;
+}
+
+sub versionCompare($$) {
+ my ($a, $b) = @_;
+ local $_;
+
+ while ($a || $b) {
+ my ($sb, $sa) = map { $1 if $a =~ /^\W*\d/ ? s/^\W*0*(\d+)// : s/^\W*(\D+)// } ($b, $a);
+ $_ = length($sa) cmp length($sb) || $sa cmp $sb and return $_;
+ }
+}
+
+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");
+
+ #- this method has only one objectif, check the presence of packages
+ #- already installed and avoid installing them again. this is to be used
+ #- with oem installation, if the database exists, preselect the packages
+ #- installed WHATEVER their version/release (log if a problem is perceived
+ #- is enough).
+ c::rpmdbTraverse($db, sub {
+ my ($header) = @_;
+ my $p = $packages->[0]{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;
+ $version_rel_test or log::l("keeping an older package, avoiding selecting $p->{file}");
+ packageSetFlagInstalled($p, 1);
+ }
+ });
+
+ log::l("before closing db");
+ #- close db, job finished !
+ c::rpmdbClose($db);
+ log::l("done selecting packages to upgrade");
+
+}
+
+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;
+ if (my $pid = fork()) {
+ close INPUT_CHILD;
+ close OUTPUT_CHILD;
+ select((select(OUTPUT), $| = 1)[0]);
+
+ #- internal reading from the child.
+ my $ask_child = sub {
+ my @list;
+ print OUTPUT $_[0], "\n";
+
+ local $_;
+ while (<INPUT>) {
+ chomp;
+ /^\s*$/ and last;
+ push @list, $_;
+ }
+
+ \@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);
+ }
+ } 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.
+ my @files = c::headerGetEntry($header, 'filenames');
+ @installedFilesForUpgrade{grep { ($_ !~ m|^/etc/rc.d/| &&
+ ! -d "$prefix/$_" && ! -l "$prefix/$_") } @files} = ();
+ });
+
+ my $list = $ask_child->(packageName($p));
+ my @commonparts = map { /^=(.*)/ ? ($1) : () } @$list;
+ map { delete $installedFilesForUpgrade{$_} } grep { $_ !~ m|^/etc/rc.d/| }
+ map { /^(\d)(.*)/ ? ($commonparts[$1] . $2) : /^ (.*)/ ? ($1) : () } @$list;
+
+ #- keep in mind the cumul size of installed package since they will be deleted
+ #- on upgrade.
+ $p->{installedCumulSize} = $cumulSize;
+ }
+ }
+
+ #- 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 = $_;
+
+ if (packageFlagSelected($p)) {
+ my $list = $ask_child->(packageName($p));
+ my @commonparts = map { /^=(.*)/ ? ($1) : () } @$list;
+ map { delete $installedFilesForUpgrade{$_} } grep { $_ !~ m|^/etc/rc.d/| }
+ map { /^(\d)(.*)/ ? ($commonparts[$1] . $2) : /^ (.*)/ ? ($1) : () } @$list;
+ }
+ }
+
+ #- 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 = $_;
+
+ unless (packageFlagSelected($p)) {
+ my $toSelect = 0;
+ my $list = $ask_child->(packageName($p));
+ my @commonparts = map { /^=(.*)/ ? ($1) : () } @$list;
+ map { if (exists $installedFilesForUpgrade{$_}) {
+ ++$toSelect if ! -d "$prefix/$_" && ! -l "$prefix/$_"; delete $installedFilesForUpgrade{$_} }
+ } grep { $_ !~ m|^/etc/rc.d/| } map { /^(\d)(.*)/ ? ($commonparts[$1] . $2) : /^ (.*)/ ? ($1) : () } @$list;
+ 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);
+ } else {
+ log::l("avoid selecting " . packageName($p) . " as its locales language is not already selected");
+ }
+ }
+ }
+ }
+ }
+
+ #- 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]}) {
+ my $p = $_;
+
+ my $list = $ask_child->(packageName($p));
+ my @obsoletes = map { /^\*(\S*)/ ? ($1) : () } @$list;
+ foreach (@obsoletes) {
+ if (c::rpmdbNameTraverse($db, $_) > 0) {
+ log::l("selecting " . packageName($p) . " by selection on obsoletes");
+ selectPackage($packages, $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 {
+ local $_;
+
+ #- child process will hashes filelist and answer its parent
+ #- for each specific informations.
+ close INPUT;
+ close OUTPUT;
+ select((select(OUTPUT_CHILD), $| = 1)[0]);
+
+ #- get filelist of package to avoid getting all header into memory.
+ my %filelist;
+ my $current;
+ my $f = install_any::getFile('Mandrake/base/filelist') or log::l("unable to get filelist of packages");
+ while (<$f>) {
+ if (/^#(\S*)/) {
+ $current = $filelist{$1} = [];
+ } else {
+ push @$current, $_;
+ }
+ }
+
+ #- now respond to its parent wanting some data from filelist ...
+ while (<INPUT_CHILD>) {
+ chomp;
+ foreach (@{$filelist{$_}}) {
+ print OUTPUT_CHILD $_;
+ }
+ print OUTPUT_CHILD "\n";
+ }
+
+ #- the parent has broken the pipe associated with INPUT_CHILD,
+ #- exit now and free all that memory...
+ close OUTPUT_CHILD;
+ close INPUT_CHILD;
+ 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]}) {
+ 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.
+ }
+ }
+ }
+ }
+ });
+ }
+
+ log::l("before closing db");
+ #- 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)$/ }
+
+sub installCallback {
+ my $msg = shift;
+ log::l($msg .": ". join(',', @_));
+}
+
+sub install($$$;$$) {
+ my ($prefix, $isUpgrade, $toInstall, $depOrder, $media) = @_;
+ my %packages;
+
+ return if $::g_auto_install || !scalar(@$toInstall);
+
+ #- for root loopback'ed /boot
+ my $loop_boot = loopback::prepare_boot($prefix);
+
+ #- first stage to extract some important informations
+ #- about the packages selected. this is used to select
+ #- one or many transaction.
+ my ($total, $nb);
+ foreach my $pkg (@$toInstall) {
+ $packages{packageName($pkg)} = $pkg;
$nb++;
- $total += $p->{size};
+ $total += packageSize($pkg);
+ }
+
+ log::l("pkgs::install $prefix");
+ log::l("pkgs::install the following: ", join(" ", keys %packages));
+ eval { fs::mount("/proc", "$prefix/proc", "proc", 0) } unless -e "$prefix/proc/cpuinfo";
+
+ log::l("reading /usr/lib/rpm/rpmrc");
+ c::rpmReadConfigFiles() or die "can't read rpm config files";
+ log::l("\tdone");
+
+ 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});
+ $fd ? fileno $fd : -1;
+ };
+ my $callbackClose = sub { packageSetFlagInstalled(delete $packages{$_[0]}, 1) };
+
+ #- do not modify/translate the message used with installCallback since
+ #- these are keys during progressing installation, or change in other
+ #- place (install_steps_gtk.pm,...).
+ installCallback("Starting installation", $nb, $total);
+
+ my ($i, $min, $medium) = (0, 0, 1);
+ do {
+ my @transToInstall;
+
+ if (!$depOrder || !$media) {
+ @transToInstall = values %packages;
+ $nb = 0;
+ } else {
+ do {
+ #- change current media if needed.
+ if ($i > $media->{$medium}{max}) {
+ #- search for media that contains the desired package to install.
+ foreach (keys %$media) {
+ $i >= $media->{$_}{min} && $i <= $media->{$_}{max} and $medium = $_, last;
+ }
+ }
+ $i >= $media->{$medium}{min} && $i <= $media->{$medium}{max} or die "unable to find right medium";
+ install_any::useMedium($medium);
+
+ while ($i <= $media->{$medium}{max} && ($i < $min || scalar @transToInstall < $limitMinTrans)) {
+ my $dep = $packages{packageName($depOrder->[$i++])} or next;
+ if ($dep->{medium}{selected}) {
+ push @transToInstall, $dep;
+ foreach (map { split '\|' } packageDepsId($dep)) {
+ $min < $_ and $min = $_;
+ }
+ } else {
+ log::l("ignoring package $dep->{file} as its medium is not selected");
+ }
+ --$nb; #- make sure the package is not taken into account as its medium is not selected.
+ }
+ } while ($nb > 0 && scalar(@transToInstall) == 0); #- avoid null transaction, it a nop that cost a bit.
+ }
+
+ #- added to exit typically after last media unselected.
+ if ($nb == 0 && scalar(@transToInstall) == 0) {
+ cleanHeaders($prefix);
+
+ loopback::save_boot($loop_boot);
+ return;
+ }
+
+ #- extract headers for parent as they are used by callback.
+ extractHeaders($prefix, \@transToInstall, $media->{$medium});
+
+ #- 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});
+ #- and make sure there are no staling open file descriptor too!
+ install_any::getFile('XXX');
+
+ #- reset ftp handlers before forking, otherwise well ;-(
+ #require ftp;
+ #ftp::rewindGetFile();
+
+ local (*INPUT, *OUTPUT); pipe INPUT, OUTPUT;
+ if (my $pid = fork()) {
+ close OUTPUT;
+ my $error_msg = '';
+ local $_;
+ while (<INPUT>) {
+ if (/^die:(.*)/) {
+ $error_msg = $1;
+ last;
+ } else {
+ chomp;
+ my @params = split ":";
+ if ($params[0] eq 'close') {
+ &$callbackClose($params[1]);
+ } else {
+ installCallback(@params);
+ }
+ }
+ }
+ $error_msg and $error_msg .= join('', <INPUT>);
+ waitpid $pid, 0;
+ close INPUT;
+ $error_msg and die $error_msg;
+ } else {
+ #- child process will run each transaction.
+ $SIG{SEGV} = sub { log::l("segmentation fault on transactions"); c::_exit(0) };
+ my $db;
+ eval {
+ close INPUT;
+ select((select(OUTPUT), $| = 1)[0]);
+ $db = c::rpmdbOpen($prefix) or die "error opening RPM database: ", c::rpmErrorString();
+ my $trans = c::rpmtransCreateSet($db, $prefix);
+ log::l("opened rpm database for transaction of ". scalar @transToInstall ." new packages, still $nb after that to do");
+
+ c::rpmtransAddPackage($trans, $_->{header}, packageName($_), $isUpgrade && allowedToUpgrade(packageName($_)))
+ foreach @transToInstall;
+
+ c::rpmdepOrder($trans) or
+ die "error ordering package list: " . c::rpmErrorString(),
+ sub { c::rpmdbClose($db) };
+ c::rpmtransSetScriptFd($trans, fileno LOG);
+
+ log::l("rpmRunTransactions start");
+ my @probs = c::rpmRunTransactions($trans, $callbackOpen,
+ sub { #- callbackClose
+ print OUTPUT "close:$_[0]\n"; },
+ sub { #- installCallback
+ print OUTPUT join(":", @_), "\n"; },
+ 1);
+ log::l("rpmRunTransactions done");
+
+ if (@probs) {
+ my %parts;
+ @probs = reverse grep {
+ if (s/(installing package) .* (needs (?:.*) on the (.*) filesystem)/$1 $2/) {
+ $parts{$3} ? 0 : ($parts{$3} = 1);
+ } else { 1; }
+ } reverse map { s|/mnt||; $_ } @probs;
+
+ c::rpmdbClose($db);
+ die "installation of rpms failed:\n ", join("\n ", @probs);
+ }
+ }; $@ and print OUTPUT "die:$@\n";
+
+ c::rpmdbClose($db);
+ log::l("rpm database closed");
+
+ close OUTPUT;
+ c::_exit(0);
+ }
+ c::headerFree(delete $_->{header}) foreach @transToInstall;
+ cleanHeaders($prefix);
+
+ if (my @badpkgs = grep { !packageFlagInstalled($_) && $_->{medium}{selected} && !exists($ignoreBadPkg{packageName($_)}) } @transToInstall) {
+ foreach (@badpkgs) {
+ log::l("bad package $_->{file}");
+ packageSetFlagSelected($_, 0);
+ }
+ cdie ("error installing package list: " . join(", ", map { $_->{file} } @badpkgs));
+ }
+ } while ($nb > 0 && !$pkgs::cancel_install);
+
+ cleanHeaders($prefix);
+
+ loopback::save_boot($loop_boot);
+}
+
+sub remove($$) {
+ my ($prefix, $toRemove) = @_;
+
+ return if $::g_auto_install || !@{$toRemove || []};
+
+ log::l("reading /usr/lib/rpm/rpmrc");
+ c::rpmReadConfigFiles() or die "can't read rpm config files";
+ log::l("\tdone");
+
+ my $db = c::rpmdbOpen($prefix) or die "error opening RPM database: ", c::rpmErrorString();
+ log::l("opened rpm database for removing old packages");
+
+ my $trans = c::rpmtransCreateSet($db, $prefix);
+
+ foreach my $p (@$toRemove) {
+ #- stuff remove all packages that matches $p, not a problem since $p has name-version-release format.
+ c::rpmtransRemovePackages($db, $trans, $p) if allowedToUpgrade($p);
}
- c::rpmdepOrder($trans) or c::rpmdbClose($db), c::rpmtransFree($trans), die "error ordering package list: ", c::rpmErrorString();
- c::rpmtransSetScriptFd($trans, $fd);
+ eval { fs::mount("/proc", "$prefix/proc", "proc", 0) } unless -e "$prefix/proc/cpuinfo";
- eval { fs::mount("/proc", "$rootPath/proc", "proc", 0) };
+ my $callbackOpen = sub { log::l("trying to open file from $_[0] which should not happen"); };
+ my $callbackClose = sub { log::l("trying to close file from $_[0] which should not happen"); };
- log::ld("starting installation: ", $nb, " packages, ", $total, " bytes");
+ #- we are not checking depends since it should come when
+ #- upgrading a system. although we may remove some functionalities ?
- # !! do not translate these messages, they are used when catched (cf install_steps_graphical)
- my $callbackStart = sub { log::ld("starting installing package ", $_[0]) };
- my $callbackProgress = sub { log::ld("progressing installation ", $_[0], "/", $_[1]) };
+ #- do not modify/translate the message used with installCallback since
+ #- these are keys during progressing installation, or change in other
+ #- place (install_steps_gtk.pm,...).
+ installCallback("Starting removing other packages", scalar @$toRemove);
- if (my @probs = c::rpmRunTransactions($trans, $callbackStart, $callbackProgress, $force)) {
- die "installation of rpms failed:\n ", join("\n ", @probs);
+ if (my @probs = c::rpmRunTransactions($trans, $callbackOpen, $callbackClose, \&installCallback, 1)) {
+ die "removing of old rpms failed:\n ", join("\n ", @probs);
}
- c::rpmtransFree($trans);
+ c::rpmtransFree($trans);
c::rpmdbClose($db);
log::l("rpm database closed");
+
+ #- keep in mind removing of these packages by cleaning $toRemove.
+ @{$toRemove || []} = ();
}
+
+1;
generated by cgit v1.2.1 (git 2.21.0) at 2024-05-15 04:52:36 +0000