From 39b16a6249eb865a2319a8e3cb1e4270e6fec539 Mon Sep 17 00:00:00 2001 From: Francois Pons Date: Fri, 10 Mar 2000 19:56:05 +0000 Subject: *** empty log message *** --- perl-install/c/stuff.xs.pm | 11 +++- perl-install/devices.pm | 2 +- perl-install/fs.pm | 2 +- perl-install/install_any.pm | 61 ++++++++++++++--- perl-install/install_steps.pm | 2 +- perl-install/install_steps_gtk.pm | 29 ++++++++- perl-install/pkgs.pm | 133 +++++++++++++++++++++++++------------- 7 files changed, 180 insertions(+), 60 deletions(-) (limited to 'perl-install') 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 () { + 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 () { + 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; -- cgit v1.2.1