diff options
author | damien <damien@mandriva.com> | 2000-11-28 16:56:52 +0000 |
---|---|---|
committer | damien <damien@mandriva.com> | 2000-11-28 16:56:52 +0000 |
commit | 0880c7ba8ce88e87fa600aeb367a8f88a3ae71e7 (patch) | |
tree | 33f7ac905998f9ad6d85090f777ee4c0d0c67032 /perl-install/pkgs.pm | |
parent | d5c526273db473a7d87a26000585900fc10dda7d (diff) | |
download | drakx-topic/unlabeled-1.1.1.tar drakx-topic/unlabeled-1.1.1.tar.gz drakx-topic/unlabeled-1.1.1.tar.bz2 drakx-topic/unlabeled-1.1.1.tar.xz drakx-topic/unlabeled-1.1.1.zip |
branch to build the firewall install.topic/unlabeled-1.1.1
Diffstat (limited to 'perl-install/pkgs.pm')
-rw-r--r-- | perl-install/pkgs.pm | 1448 |
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; |