From aa560937696c59232dfdf00f3b493b8f85bf412a Mon Sep 17 00:00:00 2001 From: Francois Pons Date: Fri, 4 Jan 2002 16:41:45 +0000 Subject: added update installation support to install (big modifs need testing). --- perl-install/crypto.pm | 78 ++++++++++++++++++++++--------- perl-install/http.pm | 7 +-- perl-install/install2.pm | 5 ++ perl-install/install_any.pm | 18 +++---- perl-install/install_steps.pm | 10 ++++ perl-install/install_steps_gtk.pm | 6 ++- perl-install/install_steps_interactive.pm | 64 ++++++++++++++++++++++--- perl-install/pkgs.pm | 65 ++++++++++++++++++-------- perl-install/steps.pm | 1 + 9 files changed, 194 insertions(+), 60 deletions(-) (limited to 'perl-install') 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_(); @@ -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' ], -- cgit v1.2.1