added update installation support to install (big modifs need testing).

9 files changed, 194 insertions, 60 deletions

diff --git a/perl-install/crypto.pm b/perl-install/crypto.pm
index 74200ddeb..cb6517536 100644
--- a/perl-install/crypto.pm
+++ b/perl-install/crypto.pm
@@ -3,22 +3,27 @@ package crypto; # $Id$
 use diagnostics;
 use strict;
 
+use MDK::Common::System;
 use common;
 use log;
 use ftp;
 
-my %mirrors = (
- "ftp.ucr.ac.cr" => [ "Costa Rica", "/pub/Unix/linux/mandrake/Mandrake" ],
- "ftp.nectec.or.th" => [ "Thailand", "/pub/mirrors/Mandrake-crypto" ],
- "ftp.tvd.be" => [ "Belgium", "/packages/mandrake-crypto" ],
- "sunsite.mff.cuni.cz" => [ "Czech Republic", "/OS/Linux/Dist/Mandrake-crypto" ],
- "ftp.uni-kl.de" => [ "Germany", "/pub/linux/mandrake/Mandrake-crypto" ],
- "ftp.duth.gr" => [ "Grece", "/pub/mandrake-crypto" ],
- "ftp.leo.org" => [ "Germany", "/pub/comp/os/unix/linux/Mandrake/Mandrake-crypto" ],
- "sunsite.uio.no" => [ "Norway", "/pub/unix/Linux/Mandrake-crypto" ],
- "ftp.sunet.se" => [ "Sweden", "/pub/Linux/distributions/mandrake-crypto" ],
-#- "ackbar" => [ "Ackbar", "/crypto", "a", "a" ],
-);
+my %url2lang = (
+		fr => _("France"),
+		cr => _("Costa Rica"),
+		be => _("Belgium"),
+		cz => _("Czech Republic"),
+		de => _("Germany"),
+		gr => _("Grece"),
+		no => _("Norway"),
+		se => _("Sweden"),
+	       );
+
+my %static_mirrors = (
+#		      "ackbar" => [ "Ackbar", "/updates", "a", "a" ],
+		     );
+
+my %mirrors = ();
 
 my %deps = (
   'libcrypto.so.0' => 'openssl',
@@ -27,16 +32,43 @@ my %deps = (
 );
 
 sub require2package { $deps{$_[0]} || $_[0] }
-sub mirror2text($) { $mirrors{$_[0]} && "$mirrors{$_[0]}[0] ($_[0])" }
-sub mirrors() { keys %mirrors }
-sub dir { $mirrors{$_[0]}[1] . '/' . (arch() !~ /i.86/ && ((arch() =~ /sparc/ ? "sparc" : arch()). '/')) . $::VERSION }
+sub mirror2text { $mirrors{$_[0]} && ($mirrors{$_[0]}[0] . '|' . $_[0]) }
+
+sub mirrors {
+    unless (keys %mirrors) {
+	#- contact the following URL to retrieve list of mirror.
+	#- http://www.linux-mandrake.com/mirrorsfull.list
+	require http;
+	my $f = http::getFile("http://www.linux-mandrake.com/mirrorsfull.list");
+	foreach (<$f>) {
+	    my ($arch, $url, $dir) = m|updates([^:]*):ftp://([^/]*)(/\S*)| or next;
+	    MDK::Common::System::compat_arch($arch) or
+		log::l("ignoring updates from $url because of incompatible arch: $arch"), next;
+	    my $lang = _("United States");
+	    foreach (keys %url2lang) {
+		my $qu = quotemeta $_;
+		$url =~ /\.$qu(?:\..*)?$/ and $lang = $url2lang{$_};
+	    }
+	    $mirrors{$url} = [ $lang, $dir ];
+	}
+	http::getFile('/XXX'); #- close connection.
+
+	#- now add static mirror (in case of something wrong happened above).
+	add2hash(\%mirrors, \%static_mirrors);
+    }
+    keys %mirrors;
+}
+
+#sub dir { $mirrors{$_[0]}[1] . '/' . $::VERSION }
+sub dir { $mirrors{$_[0]}[1] . '/' . '8.1' }
 sub ftp($) { ftp::new($_[0], dir($_[0])) }
 
 sub getFile {
     my ($file, $host) = @_;
     $host ||= $crypto::host;
-    log::l("getting crypto file $file on directory " . dir($host) . " with login $mirrors{$host}[2]");
-    my ($ftp, $retr) = ftp::new($host, dir($host),
+    my $dir = dir($host) . ($file =~ /\.rpm$/ && "/RPMS");
+    log::l("getting crypto file $file on directory $dir with login $mirrors{$host}[2]");
+    my ($ftp, $retr) = ftp::new($host, $dir,
 				$mirrors{$host}[2] ? $mirrors{$host}[2] : (),
 				$mirrors{$host}[3] ? $mirrors{$host}[3] : ()
 			       );
@@ -54,11 +86,15 @@ sub getPackages {
 
     #- extract hdlist of crypto, then depslist.
     require pkgs;
-    pkgs::psUsingHdlist($prefix, '', $packages, "hdlist-crypto.cz2", "crypto.cz2", "Crypto", "Cryptographic site", 1, getFile("hdlist-crypto.cz2", $mirror)) and
-	pkgs::getOtherDeps($packages, getDepslist($mirror));
+    my $update_medium = pkgs::psUsingHdlist($prefix, 'ftp', $packages, "hdlist-updates.cz",
+					    1+scalar(keys %{$packages->{mediums}}), "RPMS",
+					    #"Updates for Mandrake Linux $::VERSION", 1, getFile("base/hdlist.cz", $mirror)) and
+					    "Updates for Mandrake Linux 8.1", 1, getFile("base/hdlist.cz", $mirror)) and
+					      log::l("read updates hdlist");
+    #- keep in mind where is the URL prefix used according to mirror (for install_any::install_urpmi).
+    $update_medium->{prefix} = dir($mirror);
 
-    #- produce an output suitable for visualization.
-    map { pkgs::packageName($_) } pkgs::packagesOfMedium($packages, "Crypto");
+    return $update_medium;
 }
 
 sub get {
diff --git a/perl-install/http.pm b/perl-install/http.pm
index 057764a27..8d1e8d5de 100644
--- a/perl-install/http.pm
+++ b/perl-install/http.pm
@@ -10,15 +10,16 @@ sub getFile {
     local($^W) = 0;
 
     my ($url) = @_;
+    $sock->close if $sock;
+    $url =~ m|/XXX$| and return; #- force closing connection.
+
     my ($host, $port, $path) = $url =~ m,^http://([^/:]+)(?::(\d+))?(/\S*)?$,;
     $host = network::resolv($host);
 
-    $sock->close if $sock;
-    $url =~ m|/XXX$| and return; #- force closing connection.
     $sock = IO::Socket::INET->new(PeerAddr => $host,
 				  PeerPort => $port || 80,
 				  Proto    => 'tcp',
-				  Timeout  => 60) or die "can't connect ";
+				  Timeout  => 60) or die "can't connect $@";
     $sock->autoflush;
     print $sock join("\015\012" =>
 		     "GET $path HTTP/1.0",
diff --git a/perl-install/install2.pm b/perl-install/install2.pm
index 529a3b6ac..f0ec6960d 100644
--- a/perl-install/install2.pm
+++ b/perl-install/install2.pm
@@ -260,6 +260,11 @@ sub installCrypto {
     installStepsCall($o, $auto, 'installCrypto');
 }
 #------------------------------------------------------------------------------
+sub installUpdates {
+    my ($clicked, $ent_number, $auto) = @_;
+    installStepsCall($o, $auto, 'installUpdates');
+}
+#------------------------------------------------------------------------------
 sub configureServices {
     my ($clicked, $ent_number, $auto) = @_;
     installStepsCall($o, $auto, 'configureServices', $clicked);
diff --git a/perl-install/install_any.pm b/perl-install/install_any.pm
index f5fa3ddf9..0821cef2e 100644
--- a/perl-install/install_any.pm
+++ b/perl-install/install_any.pm
@@ -134,7 +134,7 @@ sub getFile {
 	if ($f =~ m|^http://|) {
 	    require http;
 	    http::getFile($f);
-	} elsif ($method =~ /crypto/i) {
+	} elsif ($method =~ /crypto|update/i) {
 	    require crypto;
 	    crypto::getFile($f);
 	} elsif ($::o->{method} eq "ftp") {
@@ -195,7 +195,7 @@ sub setup_postinstall_rpms($$) {
     #- the complete filename of each package.
     #- copy the package files in the postinstall RPMS directory.
     #- last arg is default medium '' known as the CD#1.
-    pkgs::extractHeaders($prefix, \@toCopy, $packages->{mediums}{$boot_medium});
+    pkgs::extractHeaders($prefix, \@toCopy, $packages->{mediums});
     cp_af((map { "/tmp/image/" . relGetFile(pkgs::packageFile($_)) } @toCopy), $postinstall_rpms);
 
     log::l("copying Auto Install Floppy");
@@ -517,7 +517,7 @@ sub install_urpmi {
     #- rare case where urpmi cannot be installed (no hd install path).
     $method eq 'disk' && !hdInstallPath() and return;
 
-    my @cfg = map_index {
+    my @cfg = map {
 	my $name = $_->{fakemedium};
 
 	local *LIST;
@@ -525,11 +525,11 @@ sub install_urpmi {
 	open LIST, ">$prefix/var/lib/urpmi/list.$name" or log::l("failed to write list.$name");
 	umask $mask;
 
-	my $dir = ${{ nfs => "file://mnt/nfs", 
-                      disk => "file:/" . hdInstallPath(),
-		      ftp => $ENV{URLPREFIX},
-		      http => $ENV{URLPREFIX},
-		      cdrom => "removable://mnt/cdrom" }}{$method} . "/$_->{rpmsdir}";
+	my $dir = ($_->{prefix} || ${{ nfs => "file://mnt/nfs", 
+				       disk => "file:/" . hdInstallPath(),
+				       ftp => $ENV{URLPREFIX},
+				       http => $ENV{URLPREFIX},
+				       cdrom => "removable://mnt/cdrom" }}{$method}) . "/$_->{rpmsdir}";
 
 	local *FILES; open FILES, "$ENV{LD_LOADER} parsehdlist /tmp/$_->{hdlist} |";
 	print LIST "$dir/$_\n" foreach chomp_(<FILES>);
@@ -548,7 +548,7 @@ sub install_urpmi {
 }
 
 ";
-    } values %$mediums;
+    } sort { $a->{medium} <=> $b->{medium} } values %$mediums;
     eval { output "$prefix/etc/urpmi/urpmi.cfg", @cfg };
 
     #- automatically build all synthesis files.
diff --git a/perl-install/install_steps.pm b/perl-install/install_steps.pm
index ac7f33e98..ef8235c0b 100644
--- a/perl-install/install_steps.pm
+++ b/perl-install/install_steps.pm
@@ -589,6 +589,16 @@ sub installCrypto {
     $o->pkg_install(@{$u->{packages}});
 }
 
+sub installUpates {
+    my ($o) = @_;
+    my $u = $o->{updates} or return; $u->{updates} && $u->{packages} or return;
+
+    upNetwork($o);
+    require crypto;
+    my @crypto_packages = crypto::getPackages($o->{prefix}, $o->{packages}, $u->{mirror});
+    $o->pkg_install(@{$u->{packages}});
+}
+
 sub summary {
     my ($o) = @_;
     configureTimezone($o);
diff --git a/perl-install/install_steps_gtk.pm b/perl-install/install_steps_gtk.pm
index 5350faf2f..b13a1467d 100644
--- a/perl-install/install_steps_gtk.pm
+++ b/perl-install/install_steps_gtk.pm
@@ -335,7 +335,7 @@ sub reallyChooseGroups {
 
 
 sub choosePackagesTree {
-    my ($o, $packages) = @_;
+    my ($o, $packages, $limit_to_medium) = @_;
 
     my $available = install_any::getAvailableSpace($o);
     my $availableCorrected = pkgs::invCorrectSize($available / sqr(1024)) * sqr(1024);
@@ -356,6 +356,7 @@ sub choosePackagesTree {
 				my ($add_node, $flat) = @_;
 				if ($flat) {
 				    foreach (sort keys %{$packages->{names}}) {
+					!$limit_to_medium || pkgs::packageMedium($packages, $_) == $limit_to_medium or next;
 					$add_node->($_, undef);
 				    }
 				} else {
@@ -364,6 +365,7 @@ sub choosePackagesTree {
 					#$fl{$_} = $o->{compssUsersChoice}{$_} foreach @{$o->{compssUsers}{$root}{flags}}; #- FEATURE:improve choce of packages...
 					$fl{$_} = 1 foreach @{$o->{compssUsers}{$root}{flags}};
 					foreach my $p (values %{$packages->{names}}) {
+					    !$limit_to_medium || pkgs::packageMedium($packages, $p) == $limit_to_medium or next;
 					    my ($rate, @flags) = pkgs::packageRateRFlags($p);
 					    next if !($rate && grep { grep { !/^!/ && $fl{$_} } split('\|\|') } @flags);
 					    $rate >= 3 ?
@@ -378,7 +380,7 @@ sub choosePackagesTree {
 			    },
 			    get_info => sub {
 				my $p = pkgs::packageByName($packages, $_[0]) or return '';
-				pkgs::extractHeaders($o->{prefix}, [$p], pkgs::packageMedium($packages, $p));
+				pkgs::extractHeaders($o->{prefix}, [$p], $packages->{mediums});
 				pkgs::packageHeader($p) or die;
 
 				my $imp = translate($pkgs::compssListDesc{pkgs::packageFlagBase($p) ?
diff --git a/perl-install/install_steps_interactive.pm b/perl-install/install_steps_interactive.pm
index 2ad4cc798..bd1591d39 100644
--- a/perl-install/install_steps_interactive.pm
+++ b/perl-install/install_steps_interactive.pm
@@ -538,13 +538,15 @@ sub chooseSizeToInstall {
     min($def, $availableC * 0.7);
 }
 sub choosePackagesTree {
-    my ($o, $packages) = @_;
+    my ($o, $packages, $limit_to_medium) = @_;
 
     $o->ask_many_from_list('', _("Choose the packages you want to install"),
 			   {
 			    list => [ 
-				      map { pkgs::packageByName($packages, $_) }
-				      keys %{$packages->{names}} ],
+				     map { pkgs::packageByName($packages, $_) }
+				     $limit_to_medium ?
+				     (grep { pkgs::packageMedium($packages, $_) == $limit_to_medium } keys %{$packages->{names}}) :
+				     (keys %{$packages->{names}}) ],
 			    value => \&pkgs::packageFlagSelected,
 			    label => \&pkgs::packageName,
 			    sort => 1,
@@ -866,17 +868,67 @@ USA")) || return;
     #- bring all interface up for installing crypto packages.
     install_interactive::upNetwork($o);
 
-    my @packages = do {
+    my $update_medium = do {
+      my $w = $o->wait_message('', _("Contacting the mirror to get the list of available packages"));
+      crypto::getPackages($o->{prefix}, $o->{packages}, $u->{mirror}); #- make sure $o->{packages} is defined when testing
+    };
+
+    if ($update_medium) {
+	$o->choosePackagesTree($o->{packages}, $update_medium);
+	$o->pkg_install();
+    }
+
+    #- stop interface using ppp only.
+    install_interactive::downNetwork($o, 'pppOnly');
+}
+
+sub installUpdates {
+    my ($o) = @_;
+    my $u = $o->{updates} ||= {};
+    
+    $o->hasNetwork or return;
+
+    is_empty_hash_ref($u) and $o->ask_yesorno('', 
+_("You have now the possibility to download updated packages that have
+been released after the distribution has been made available.
+
+You will get security fixes or bug fixes, but you need to have an
+Internet connection configured to proceed.
+
+Do you want to continue ?")) || return;
+
+    #- bring all interface up for installing crypto packages.
+    install_interactive::upNetwork($o);
+
+    require crypto;
+    eval {
+	my @mirrors = do { my $w = $o->wait_message('',
+						    _("Contacting Mandrake Linux web site to get the list of available mirrors"));
+			   crypto::mirrors() };
+	$u->{mirror} = $o->ask_from_treelistf('', 
+					      _("Choose a mirror from which to get the packages"), 
+					      '|',
+					      \&crypto::mirror2text,
+					      \@mirrors,
+					      $u->{mirror});
+    };
+    return if $@;
+
+    my $update_medium = do {
       my $w = $o->wait_message('', _("Contacting the mirror to get the list of available packages"));
       crypto::getPackages($o->{prefix}, $o->{packages}, $u->{mirror}); #- make sure $o->{packages} is defined when testing
     };
-    $u->{packages} = $o->ask_many_from_list('', _("Please choose the packages you want to install."), { list => \@packages, values => $u->{packages} }) or return;
-    $o->pkg_install(@{$u->{packages}});
 
+    if ($update_medium) {
+	$o->choosePackagesTree($o->{packages}, $update_medium);
+	$o->pkg_install();
+    }
+ 
     #- stop interface using ppp only.
     install_interactive::downNetwork($o, 'pppOnly');
 }
 
+
 #------------------------------------------------------------------------------
 sub configureTimezone {
     my ($o, $clicked) = @_;
diff --git a/perl-install/pkgs.pm b/perl-install/pkgs.pm
index 4ce9c373e..9110d403d 100644
--- a/perl-install/pkgs.pm
+++ b/perl-install/pkgs.pm
@@ -129,16 +129,25 @@ sub cleanHeaders {
 }
 
 #- get all headers from an hdlist file.
-sub extractHeaders($$$) {
-    my ($prefix, $pkgs, $medium) = @_;
+sub extractHeaders {
+    my ($prefix, $pkgs, $media) = @_;
+    my %medium2pkgs;
 
     cleanHeaders($prefix);
 
-    eval {
-	require packdrake;
-	my $packer = new packdrake("/tmp/$medium->{hdlist}", quiet => 1);
-	$packer->extract_archive("$prefix/tmp/headers", map { packageHeaderFile($_) } @$pkgs);
-    };
+    foreach (@$pkgs) {
+	push @{$medium2pkgs{$_->[$MEDIUM]} ||= []}, $_;
+    }
+
+    foreach (values %medium2pkgs) {
+	my $medium = $media->{$_->[0][$MEDIUM]}; #- the first one is a valid package pointing to right medium to use.
+
+	eval {
+	    require packdrake;
+	    my $packer = new packdrake("/tmp/$medium->{hdlist}", quiet => 1);
+	    $packer->extract_archive("$prefix/tmp/headers", map { packageHeaderFile($_) } @$_);
+	};
+    }
 
     foreach (@$pkgs) {
 	my $f = "$prefix/tmp/headers/". packageHeaderFile($_);
@@ -404,6 +413,7 @@ sub psUsingHdlists {
 sub psUsingHdlist {
     my ($prefix, $method, $packages, $hdlist, $medium, $rpmsdir, $descr, $selected, $fhdlist) = @_;
     my $fakemedium = "$descr ($method$medium)";
+    my ($relocated, $ignored) = (0, 0);
     log::l("trying to read $hdlist for medium $medium");
 
     #- if the medium already exist, use it.
@@ -438,27 +448,38 @@ sub psUsingHdlist {
 	my $packer = new packdrake($newf, quiet => 1);
 	foreach (@{$packer->{files}}) {
 	    $packer->{data}{$_}[0] eq 'f' or next;
-	    ++$packages->{count}; #- take care of this one, so that desplist will be clean with index of package.
 	    my $pkg = [ (undef) x 8 ]; $pkg->[$FILE] = $_; $pkg->[$MEDIUM] = $medium;
 	    my $specific_arch = packageArch($pkg);
 	    if (!$specific_arch || MDK::Common::System::compat_arch($specific_arch)) {
 		my $old_pkg = $packages->{names}{packageName($pkg)};
 		if ($old_pkg) {
-		    if (packageVersion($pkg) eq packageVersion($old_pkg) && packageRelease($pkg) eq packageRelease($old_pkg)) {
-			if (MDK::Common::System::better_arch($specific_arch, packageArch($old_pkg))) {
-			    log::l("replacing old package with package $_ with better arch: $specific_arch");
-			    $packages->{names}{packageName($pkg)} = $pkg;
-			} else {
-			    log::l("keeping old package against package $_ with worse arch");
+		    my $epo_compare = 0; #- NO EPOCH AVAILABLE TODO packageEpoch($pkg) <=> packageEpoch($old_pkg);
+		    my $ver_compare = $epo_compare == 0 && versionCompare(packageVersion($pkg), packageVersion($old_pkg));
+		    my $rel_compare = $ver_compare == 0 && versionCompare(packageRelease($pkg), packageRelease($old_pkg));
+		    if ($epo_compare > 0  || $ver_compare > 0 || $rel_compare > 0 ||
+			$epo_compare == 0 && $ver_compare == 0 && $rel_compare == 0 &&
+			MDK::Common::System::better_arch($specific_arch, packageArch($old_pkg))) {
+			log::l("replacing old package $old_pkg->[$FILE] with package $pkg->[$FILE]");
+			foreach ($FILE, $MEDIUM) { #- TODO KEEP OLD PARAMETER
+			    $old_pkg->[$_] = $pkg->[$_];
 			}
+			packageFreeHeader($old_pkg);
+			if (packageFlagInstalled($old_pkg)) {
+			    packageSetFlagInstalled($old_pkg, 0);
+			    selectPackage($packages, $old_pkg);
+			}
+			++$relocated;
 		    } else {
-		        log::l("ignoring package $_ already present in distribution with different version or release");
+			log::l("no need to replace previous package $old_pkg->[$FILE] with newer package $pkg->[$FILE]");
+			++$ignored;
 		    }
 		} else {
 		    $packages->{names}{packageName($pkg)} = $pkg;
+		    ++$packages->{count}; #- take care of this one, so that desplist will be clean with index of package.
 		}
 	    } else {
 	        log::l("ignoring package $_ with incompatible arch: $specific_arch");
+		++$ignored;
 	    }
 	}
     };
@@ -466,8 +487,10 @@ sub psUsingHdlist {
     #- update maximal index.
     $m->{max} = $packages->{count} - 1;
     $m->{max} >= $m->{min} or die "nothing found while parsing $newf";
-    log::l("read " . ($m->{max} - $m->{min} + 1) . " headers in $hdlist");
-    1;
+    $relocated > 0 and log::l("relocated $relocated headers in $hdlist");
+    $ignored > 0 and log::l("ignored $ignored headers in $hdlist");
+    log::l("read " . ($m->{max} - $m->{min} + 1) . " new headers in $hdlist");
+    $m;
 }
 
 sub getOtherDeps($$) {
@@ -1327,13 +1350,17 @@ sub install($$$;$$) {
 	}
 
 	#- extract headers for parent as they are used by callback.
-	extractHeaders($prefix, \@transToInstall, $media->{$medium});
+	extractHeaders($prefix, \@transToInstall, $media);
 
 	if ($media->{$medium}{method} eq 'cdrom') {
+	    #- extract packages to make sure the getFile below to force
+	    #- accessing medium will not be redirected to updates.
+	    my @origin = grep { $_->[$MEDIUM] == $media->{$medium} } @transToInstall;
+
 	    #- 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]), $media->{$transToInstall[0][$MEDIUM]}{descr});
+	    @origin and install_any::getFile(packageFile($origin[0]), $media->{$origin[0][$MEDIUM]}{descr});
 	}
 	#- and make sure there are no staling open file descriptor too (before forking)!
 	install_any::getFile('XXX');
diff --git a/perl-install/steps.pm b/perl-install/steps.pm
index ddfe7b777..c727b33f6 100644
--- a/perl-install/steps.pm
+++ b/perl-install/steps.pm
@@ -24,6 +24,7 @@ use common;
   setRootPassword    => [ __("Set root password"), 1, 1, '', "installPackages", 'rootpasswd' ],
   addUser            => [ __("Add a user"), 1, 1, '', "installPackages", 'user' ],
   configureNetwork   => [ __("Configure networking"), 1, 1, '', "formatPartitions", 'network' ],
+  installUpdates     => [ __("Install system updates"), 1, 1, '',  ["installPackages", "configureNetwork"], '' ],
   summary            => [ __("Summary"), 1, 0, '', "installPackages", 'summary' ],
   configureServices  => [ __("Configure services"), 1, 1, '!$::expert', "installPackages", 'services' ],
   setupBootloader    => [ __("Install bootloader"), 1, 0, '', "installPackages", 'bootloader' ],