fork install on upgrade for searching trhough filelist, this saves

about 20Mb of memory before rpmlib transaction are started so its is
more than 2 times faster for upgrading a system, sorry it was effectively
a machine two overloaded that makes the upgrade slower.

make rpmlib not to check size as DrakX should do it.

added special cases for selection of packages according to files, avoid
all kde-i18n packages if their locales-$lang is not selected, avoid
a -devel package if only one files is updated (typical for fixes on
package by moving files around).

deactivated rpmdepOrder as it should be done directly in depslist.ordered
file.

fixed obsoletes which never run correctly, even if almost no package are
selected explicitely this way.

added log during selection of packages to upgrade to keep a track of
what DrakX is doing.

1 files changed, 195 insertions, 116 deletions

diff --git a/perl-install/pkgs.pm b/perl-install/pkgs.pm
index 26f68d2f7..bc6abcef0 100644
--- a/perl-install/pkgs.pm
+++ b/perl-install/pkgs.pm
@@ -835,21 +835,7 @@ sub selectPackagesToUpgrade($$$;$$) {
     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");
 
-    #- 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");
-    foreach (<$f>) {
-	chomp;
-	if (/^#(.*)/) {
-	    $current = $filelist{$1} = [];
-	} else {
-	    push @$current, $_;
-	}
-    }
-
     local $_; #- else perl complains on the map { ... } grep { ... } @...;
-    my %installedFilesForUpgrade; #- help searching package to upgrade in regard to already installed files.
 
     #- used for package that are not correctly updated.
     #- should only be used when nothing else can be done correctly.
@@ -873,128 +859,221 @@ sub selectPackagesToUpgrade($$$;$$) {
     #- help removing package which may have different release numbering
     my %toRemove; map { $toRemove{$_} = 1 } @{$toRemove || []};
 
-    #- 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')};
+    #- help searching package to upgrade in regard to already installed files.
+    my %installedFilesForUpgrade;
 
-			 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);
+    #- 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.
 				 }
-			     } 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} = ();
 			     }
-			 } 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} = ();
-				 });
-	    if (my $list = $filelist{packageName($p)}) {
+	#- 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;
+		#- 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 = $_;
+	#- 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)) {
-	    if (my $list = $filelist{packageName($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.
-    foreach (values %{$packages->[0]}) {
-	my $p = $_;
 
-	unless (packageFlagSelected($p)) {
-	    my $toSelect = 0;
-	    if (my $list = $filelist{packageName($p)}) {
+	#- 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 ||= ! -d "$prefix/$_" && ! -l "$prefix/$_"; delete $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");
+			}
+		    }
+		}
 	    }
-	    selectPackage($packages, $p) if ($toSelect);
 	}
-    }
 
-    #- 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 = $_;
+	#- 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);
+		}
+	    }
+	}
 
-	if (my $list = $filelist{packageName($p)}) {
-	    my @obsoletes = map { /^\*(.*)/ ? ($1) : () } @$list;
-	    map { selectPackage($packages, $p) if c::rpmdbNameTraverse($db, $_) > 0 } @obsoletes;
+	#- 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,
@@ -1184,9 +1263,9 @@ sub install($$$;$$) {
 		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::rpmdepOrder($trans) or
+		 #   die "error ordering package list: " . c::rpmErrorString(), 
+		  #    sub { c::rpmdbClose($db) };
 		c::rpmtransSetScriptFd($trans, fileno LOG);
 
 		log::l("rpmRunTransactions start");
@@ -1195,7 +1274,7 @@ sub install($$$;$$) {
 						      print OUTPUT "close:$_[0]\n"; },
 						  sub { #- installCallback
 						      print OUTPUT join(":", @_), "\n"; },
-						  0);
+						  1);
 		log::l("rpmRunTransactions done");
 
 		if (@probs) {
@@ -1266,7 +1345,7 @@ sub remove($$) {
     #- place (install_steps_gtk.pm,...).
     installCallback("Starting removing other packages", scalar @$toRemove);
 
-    if (my @probs = c::rpmRunTransactions($trans, $callbackOpen, $callbackClose, \&installCallback, 0)) {
+    if (my @probs = c::rpmRunTransactions($trans, $callbackOpen, $callbackClose, \&installCallback, 1)) {
 	die "removing of old rpms failed:\n  ", join("\n  ", @probs);
     }
     c::rpmtransFree($trans);