summaryrefslogtreecommitdiffstats
path: root/perl-install
diff options
context:
space:
mode:
Diffstat (limited to 'perl-install')
-rw-r--r--perl-install/c/stuff.xs.pm11
-rw-r--r--perl-install/devices.pm2
-rw-r--r--perl-install/fs.pm2
-rw-r--r--perl-install/install_any.pm61
-rw-r--r--perl-install/install_steps.pm2
-rw-r--r--perl-install/install_steps_gtk.pm29
-rw-r--r--perl-install/pkgs.pm133
7 files changed, 180 insertions, 60 deletions
diff --git a/perl-install/c/stuff.xs.pm b/perl-install/c/stuff.xs.pm
index bc405af1d..cdaa2d292 100644
--- a/perl-install/c/stuff.xs.pm
+++ b/perl-install/c/stuff.xs.pm
@@ -527,7 +527,16 @@ rpmtransSetScriptFd(trans, fd)
void *trans
int fd
CODE:
- rpmtransSetScriptFd(trans, fdDup(fd));
+ /* this code core dumps on install...
+ static FD_t scriptFd = NULL;
+ if (scriptFd == NULL) scriptFd = fdNew("");
+ fdSetFdno(scriptFd, fd);
+ rpmtransSetScriptFd(trans, scriptFd);
+ */
+ static FD_t scriptFd = NULL;
+ if (scriptFd != NULL) fdClose(scriptFd);
+ scriptFd = fdDup(fd);
+ rpmtransSetScriptFd(trans, scriptFd);
void
rpmRunTransactions(trans, callbackOpen, callbackClose, callbackMessage, force)
diff --git a/perl-install/devices.pm b/perl-install/devices.pm
index 61d6bd4c7..19baec6f7 100644
--- a/perl-install/devices.pm
+++ b/perl-install/devices.pm
@@ -40,7 +40,7 @@ sub set_loop {
foreach (0..9) {
local *F;
- my $dev = devices::make("loop$_");
+ my $dev = make("loop$_");
sysopen F, $dev, 0 or next;
!ioctl(F, c::LOOP_GET_STATUS(), my $tmp) && $! == 6 or next; #- 6 == ENXIO
return c::set_loop(fileno F, $file) && $dev;
diff --git a/perl-install/fs.pm b/perl-install/fs.pm
index b5d80010e..5a506c411 100644
--- a/perl-install/fs.pm
+++ b/perl-install/fs.pm
@@ -137,7 +137,7 @@ sub mount($$$;$) {
} else {
$dev = devices::make($dev) if $fs ne 'proc';
- my $flag = 0;#c::MS_MGC_VAL();
+ my $flag = c::MS_MGC_VAL();
$flag |= c::MS_RDONLY() if $rdonly;
my $mount_opt = "";
diff --git a/perl-install/install_any.pm b/perl-install/install_any.pm
index c11e24be3..5e1232f90 100644
--- a/perl-install/install_any.pm
+++ b/perl-install/install_any.pm
@@ -4,7 +4,7 @@ use diagnostics;
use strict;
use Config;
-use vars qw(@ISA %EXPORT_TAGS @EXPORT_OK);
+use vars qw(@ISA %EXPORT_TAGS @EXPORT_OK $current_medium $asked_medium %refused_media);
@ISA = qw(Exporter);
%EXPORT_TAGS = (
@@ -30,28 +30,70 @@ use log;
#-######################################################################################
-#- Functions
+#- Media change variables&functions
#-######################################################################################
+$current_medium = '';
+$asked_medium = '';
+%refused_media = ();
+sub medium() { $current_medium }
+sub useMedium($) { $asked_medium eq $_[0] or log::l("selecting new medium $_[0]"); $asked_medium = $_[0] }
+sub changeMedium($$) {
+ my ($method, $medium) = @_;
+ log::l("change to medium $medium for method $method (refused by default)");
+ 0;
+}
sub relGetFile($) {
local $_ = $_[0];
/\.img$/ and return "images/$_";
- my $dir = m|/| ? "mdkinst" :
- member($_, qw(compss compssList compssUsers depslist depslist.ordered hdlist hdlist.cz hdlist.cz2)) ? "base/" : "/RPMS/";
+ my $dir = m|/| ? "mdkinst" : /^(?:compss|compssList|compssUsers|depslist.*|hdlist.*)$/ ? "base/": "RPMS$asked_medium/";
$_ = "Mandrake/$dir$_";
s/i386/i586/;
$_;
}
+sub errorOpeningFile($) {
+ my ($file) = @_;
+ $file eq 'XXX' and return; #- special case to force closing file after rpmlib transaction.
+ $current_medium eq $asked_medium and return; #- nothing to do in such case.
+ $refused_media{$asked_medium} and return; #- refused forever...
+
+ my $max = 32; #- always refuse after $max tries.
+ if ($::o->{method} eq "cdrom") {
+ cat_("/proc/mounts") =~ m|/tmp/(\S+)\s+/tmp/rhimage| or return;
+ my $cdrom = $1;
+ ejectCdrom();
+ while ($max > 0 && changeMedium($::o->{method}, $asked_medium)) {
+ $current_medium = $asked_medium;
+ eval { fs::mount($cdrom, "/tmp/rhimage", "iso9660", 'readonly') };
+ my $getFile = getFile($file); $getFile and return $getFile;
+ $current_medium = 'unknown'; #- don't know what CD is inserted now.
+ ejectCdrom();
+ --$max;
+ }
+ } else {
+ while ($max > 0 && changeMedium($::o->{method}, $asked_medium)) {
+ $current_medium = $asked_medium;
+ my $getFile = getFile($file); $getFile and return $getFile;
+ $current_medium = 'unknown'; #- don't know what CD image has been copied.
+ --$max;
+ }
+ }
+
+ #- keep in mind the asked medium has been refused on this way.
+ $refused_media{$asked_medium} = 'refused';
+
+ return;
+}
sub getFile($) {
local $^W = 0;
if ($::o->{method} && $::o->{method} eq "ftp") {
require ftp;
- *install_any::getFile = \&ftp::getFile;
+ *install_any::getFile = sub { ftp::getFile($_[0]) or errorOpeningFile($_[0]) };
} elsif ($::o->{method} && $::o->{method} eq "http") {
require http;
- *install_any::getFile = \&http::getFile;
+ *install_any::getFile = sub { http::getFile($_[0]) or errorOpeningFile($_[0]) };
} else {
*install_any::getFile = sub($) {
- open getFile, "/tmp/rhimage/" . relGetFile($_[0]) or return;
+ open getFile, "/tmp/rhimage/" . relGetFile($_[0]) or return errorOpeningFile($_[0]);
*getFile;
};
}
@@ -64,6 +106,9 @@ sub rewindGetFile() {
}
}
+#-######################################################################################
+#- Functions
+#-######################################################################################
sub kernelVersion {
local $_ = readlink("$::o->{prefix}/boot/vmlinuz") || $::testing && "vmlinuz-2.2.testversion" or die "I couldn't find the kernel package!";
first(/vmlinuz-(.*)/);
@@ -123,7 +168,7 @@ sub setPackages($) {
require pkgs;
if (!$o->{packages} || is_empty_hash_ref($o->{packages}[0])) {
- $o->{packages} = pkgs::psUsingHdlist($o->{prefix});
+ $o->{packages} = pkgs::psUsingHdlists($o->{prefix});
push @{$o->{default_packages}}, "nfs-utils-clients" if $o->{method} eq "nfs";
push @{$o->{default_packages}}, "numlock" if $o->{miscellaneous}{numlock};
diff --git a/perl-install/install_steps.pm b/perl-install/install_steps.pm
index 099f44659..6004096b1 100644
--- a/perl-install/install_steps.pm
+++ b/perl-install/install_steps.pm
@@ -236,7 +236,7 @@ sub installPackages($$) { #- complete REWORK, TODO and TOCHECK!
#- small transaction will be built based on this selection and depslist.
my @toInstall = grep { pkgs::packageFlagSelected($_) && !pkgs::packageFlagInstalled($_) } values %{$packages->[0]};
- pkgs::install($o->{prefix}, $o->{isUpgrade}, \@toInstall, $o->{packages}[1]);
+ pkgs::install($o->{prefix}, $o->{isUpgrade}, \@toInstall, $o->{packages}[1], $o->{packages}[2]);
}
sub afterInstallPackages($) {
diff --git a/perl-install/install_steps_gtk.pm b/perl-install/install_steps_gtk.pm
index 13f2485bc..3533f26da 100644
--- a/perl-install/install_steps_gtk.pm
+++ b/perl-install/install_steps_gtk.pm
@@ -408,7 +408,7 @@ sub choosePackagesTree {
my $display_info = sub {
my $p = $packages->[0]{$curr} or return gtktext_insert($info_widget, '');
- pkgs::extractHeaders($o->{prefix}, [$p]);
+ pkgs::extractHeaders($o->{prefix}, [$p], $p->{medium});
$p->{header} or die;
my $ind = $o->{compssListLevels}{$o->{install_class}};
@@ -498,7 +498,7 @@ sub installPackages {
$msg->set(_("Preparing installation"));
$w->sync;
- my $old = \&pkgs::installCallback;
+ my $oldInstallCallback = \&pkgs::installCallback;
local *pkgs::installCallback = sub {
my $m = shift;
if ($m =~ /^Starting installation/) {
@@ -529,7 +529,30 @@ sub installPackages {
$last_dtime = $dtime;
}
$w->flush;
- } else { unshift @_, $m; goto $old }
+ } else { unshift @_, $m; goto $oldInstallCallback }
+ };
+ my $oldChangeMedium = \&install_any::changeMedium;
+ local *install_any::changeMedium = sub {
+ my ($method, $medium) = @_;
+ my %medium_msg = (
+ '' => _("Installation CD #1"),
+ );
+ $medium_msg{$medium} or $medium_msg{$medium} = _("Installation CD #%s", $medium);
+ my %method_msg = (
+ cdrom =>
+_("Change your Cd-Rom!
+
+Please insert the Cd-Rom labelled \"%s\" in your drive and press Ok when done.
+If you don't have it press Cancel to avoid installation from this Cd-Rom.", $medium_msg{$medium}),
+ );
+ $method_msg{$method} or $method_msg{$method} =
+_("Update installation image!
+
+Ask your system administrator or reboot to update your installation image to include
+the Cd-Rom image labelled \"%s\". Press Ok if image has been updated or press Cancel
+to avoid installation from this Cd-Rom image.", $medium_msg{$medium});
+
+ $o->ask_okcancel('', $method_msg{$method});
};
catch_cdie { $o->install_steps::installPackages($packages); }
sub {
diff --git a/perl-install/pkgs.pm b/perl-install/pkgs.pm
index 8a028b53a..d30d0e408 100644
--- a/perl-install/pkgs.pm
+++ b/perl-install/pkgs.pm
@@ -2,7 +2,7 @@ package pkgs;
use diagnostics;
use strict;
-use vars qw(*LOG %compssListDesc @skip_list %by_lang @preferred $limitMinTrans $limitMaxTrans $PKGS_SELECTED $PKGS_FORCE $PKGS_INSTALLED $PKGS_BASE $PKGS_SKIP $PKGS_UNSKIP);
+use vars qw(*LOG %compssListDesc @skip_list %by_lang @preferred $limitMinTrans $PKGS_SELECTED $PKGS_FORCE $PKGS_INSTALLED $PKGS_BASE $PKGS_SKIP $PKGS_UNSKIP);
use common qw(:common :file :functional);
use install_any;
@@ -69,7 +69,6 @@ autoirpm autoirpm-icons numlock
#- constant for small transaction.
$limitMinTrans = 8;
-$limitMaxTrans = 24;
#- constant for packing flags, see below.
$PKGS_SELECTED = 0x00ffffff;
@@ -118,14 +117,14 @@ sub packageFile {
}
-#- get all headers from hdlist.cz
-sub extractHeaders {
- my ($prefix, $pkgs) = @_;
+#- get all headers from an hdlist file.
+sub extractHeaders($$$) {
+ my ($prefix, $pkgs, $medium) = @_;
commands::rm("-rf", "$prefix/tmp/headers") if -e "$prefix/tmp/headers";
- run_program::run("extract_archive",
- "$prefix/var/lib/urpmi/hdlist.cz2",
+ run_program::run("extract_archive",
+ "$prefix/var/lib/urpmi/$medium->{hdlist}",
"$prefix/tmp/headers",
map { packageHeaderFile($_) } @$pkgs);
@@ -266,40 +265,64 @@ sub skipSetWithProvides {
packageSetFlagSkip($_, 1) foreach grep { $_ } map { $_, packageProvides($_) } map { packageByName($packages, $_) } @l;
}
-sub psUsingHdlist($) {
+sub psUsingHdlists($) {
my ($prefix) = @_;
- my $f = install_any::getFile('hdlist.cz2') or die "no hdlist.cz2 found";
- my @packages;
-
- #- 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.cz2";
- -e $newf and do { unlink $newf or die "cannot remove $newf: $!"; };
- local *F;
- open F, ">$newf" or die "cannot create $newf: $!";
- my ($buf, $sz); while (($sz = sysread($f, $buf, 16384))) { syswrite(F, $buf) }
- close F;
-
- #- extract filename from archive, this take advantage of verifying
- #- the archive too.
- open F, "extract_archive $newf |" or die "unable to parse $newf";
- foreach (<F>) {
+ my $listf = install_any::getFile('hdlists') or die "no hdlists found";
+ my @packages = ({}, [], {});
+ my @hdlists;
+
+ #- parse hdlist.list file.
+ foreach (<$listf>) {
chomp;
- next unless /^[dlf]\s+/;
- if (/^f\s+\d+\s+(.*)/) {
- my $pkg = { file => $1, #- rebuild filename according to header one
- flags => 0, #- flags
- };
- $packages[0]{packageName($pkg)} = $pkg;
- } else {
- die "cannot determine how to handle such file in $newf: $_";
- }
+ s/\s*#.*$//;
+ /^\s*$/ and next;
+ m/^hdlist(.*)\.cz.*$/ or die "invalid hdlist filename $_";
+ push @hdlists, [ $_, $1 ];
}
- close F;
- $packages[1] = [];
+ foreach (@hdlists) {
+ my ($hdlist, $medium) = @$_;
+ my $f = install_any::getFile($hdlist) or die "no $hdlist found";
+
+ $packages[2]{$medium} = { hdlist => $hdlist,
+ medium => $medium, #- default medium is ''.
+ min => scalar keys %{$packages[0]},
+ max => -1, #- will be updated after reading current hdlist.
+ };
+
+ #- 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";
+ -e $newf and do { unlink $newf or die "cannot remove $newf: $!"; };
+ local *F;
+ open F, ">$newf" or die "cannot create $newf: $!";
+ my ($buf, $sz); while (($sz = sysread($f, $buf, 16384))) { syswrite(F, $buf) }
+ close F;
+
+ #- extract filename from archive, this take advantage of verifying
+ #- the archive too.
+ open F, "extract_archive $newf |" or die "unable to parse $newf";
+ foreach (<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 => $packages[2]{$medium},
+ };
+ $packages[0]{packageName($pkg)} = $pkg;
+ } else {
+ die "cannot determine how to handle such file in $newf: $_";
+ }
+ }
+ close F;
+
+ #- update maximal index.
+ $packages[2]{$medium}{max} = scalar(keys %{$packages[0]}) - 1;
+ $packages[2]{$medium}{max} >= $packages[2]{$medium}{min} or die "nothing found while parsing $newf";
+ }
- log::l("psUsingHdlist read " . scalar keys(%{$packages[0]}) . " headers");
+ log::l("psUsingHdlists read " . scalar keys(%{$packages[0]}) . " headers on " . scalar keys(%{$packages[2]}) . " hdlists");
\@packages;
}
@@ -322,15 +345,24 @@ sub getDeps($) {
or log::l("ignoring package $name-$version-$release in depslist mismatch version or release in hdlist"), next;
$pkg->{sizeDeps} = $sizeDeps;
- #- package are already sorted in depslist to enable small transaction.
+ #- 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 die "depslist.ordered mismatch against hdlist files";
+
+ #- package are already sorted in depslist to enable small transaction and multiple medium.
push @{$packages->[1]}, $pkg;
}
-# map { push @{$packages->{$_}{provides}}, $name if $packages->{$_} } @deps;
+
+ #- 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 getProvides($) {
my ($packages) = @_;
-
+
#- 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
@@ -682,8 +714,8 @@ sub installCallback {
log::l($msg .": ". join(',', @_));
}
-sub install($$$;$) {
- my ($prefix, $isUpgrade, $toInstall, $depOrder) = @_;
+sub install($$$;$$) {
+ my ($prefix, $isUpgrade, $toInstall, $depOrder, $media) = @_;
my %packages;
return if $::g_auto_install;
@@ -720,13 +752,24 @@ sub install($$$;$) {
#- place (install_steps_gtk.pm,...).
installCallback("Starting installation", $nb, $total);
- my ($i, $min) = (0, 0);
+ my ($i, $min, $medium) = (0, 0, install_any::medium());
do {
my @transToInstall;
- if ($nb <= $limitMaxTrans || !$depOrder) {
+
+ if (!$depOrder || !$media) {
@transToInstall = values %packages;
} else {
- while ($i < @$depOrder && ($i < $min || scalar @transToInstall < $limitMinTrans)) {
+ #- 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;
push @transToInstall, $dep;
foreach (map { split '\|' } packageDepsId($dep)) {
@@ -739,7 +782,7 @@ sub install($$$;$) {
log::l("starting new transaction of ". scalar @transToInstall ." packages, still $nb after that to do");
my $trans = c::rpmtransCreateSet($db, $prefix);
- extractHeaders($prefix, \@transToInstall);
+ extractHeaders($prefix, \@transToInstall, $media->{$medium});
c::rpmtransAddPackage($trans, $_->{header}, packageName($_), $isUpgrade && packageName($_) !~ /kernel/) #- TODO: replace `named kernel' by `provides kernel'
foreach @transToInstall;
generated by cgit v1.2.1 (git 2.21.0) at 2024-11-01 18:22:28 +0000