From 26a387d5919bba9ccdb8a8447daa114204a997c4 Mon Sep 17 00:00:00 2001 From: Pascal Rigaux Date: Sun, 5 Mar 2000 22:43:46 +0000 Subject: no_comment --- perl-install/c/Makefile.PL | 2 +- perl-install/c/stuff.pm | 2 +- perl-install/c/stuff.xs.pm | 72 +++++++++- perl-install/commands.pm | 12 +- perl-install/common.pm | 3 +- perl-install/install2.pm | 7 +- perl-install/install_any.pm | 24 +--- perl-install/install_steps.pm | 17 +-- perl-install/install_steps_gtk.pm | 2 +- perl-install/install_steps_interactive.pm | 2 +- perl-install/modules.pm | 8 +- perl-install/mouse.pm | 2 +- perl-install/network.pm | 2 +- perl-install/pkgs.pm | 227 +++++++++++++----------------- perl-install/services.pm | 2 +- 15 files changed, 202 insertions(+), 182 deletions(-) (limited to 'perl-install') diff --git a/perl-install/c/Makefile.PL b/perl-install/c/Makefile.PL index aa4032bb3..4e76dea67 100644 --- a/perl-install/c/Makefile.PL +++ b/perl-install/c/Makefile.PL @@ -2,7 +2,7 @@ use ExtUtils::MakeMaker; # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. -my $libs = '-L/usr/X11R6/lib -lX11 -lgdk'; +my $libs = '-L/usr/X11R6/lib -lX11 -lgdk -lXxf86misc'; $libs .= ' -lrpm -ldb1 -lz' if $ENV{C_RPM}; diff --git a/perl-install/c/stuff.pm b/perl-install/c/stuff.pm index 2cea57d2c..ab6fc4669 100644 --- a/perl-install/c/stuff.pm +++ b/perl-install/c/stuff.pm @@ -21,10 +21,10 @@ sub headerGetEntry { $q eq 'description' and return headerGetEntry_string($h, RPMTAG_DESCRIPTION()); $q eq 'arch' and return headerGetEntry_string($h, RPMTAG_ARCH()); $q eq 'size' and return headerGetEntry_int($h, RPMTAG_SIZE()); - $q eq 'filenames' and return headerGetEntry_string_list($h, RPMTAG_FILENAMES()); $q eq 'obsoletes' and return headerGetEntry_string_list($h, RPMTAG_OBSOLETES()); $q eq 'requires' and return headerGetEntry_string_list($h, RPMTAG_REQUIRENAME()); $q eq 'fileflags' and return headerGetEntry_int_list($h, RPMTAG_FILEFLAGS()); + $q eq 'filenames' and return headerGetEntry_filenames($h); } 1; diff --git a/perl-install/c/stuff.xs.pm b/perl-install/c/stuff.xs.pm index d4a272a53..5aaef8605 100644 --- a/perl-install/c/stuff.xs.pm +++ b/perl-install/c/stuff.xs.pm @@ -24,11 +24,15 @@ print ' #include #include +#include #define SECTORSIZE 512 '; $ENV{C_RPM} and print ' +#undef Fflush +#undef Mkdir +#undef Stat #include void rpmError_callback_empty(void) {} @@ -42,9 +46,11 @@ void rpmError_callback(void) { } FD_t fd2FD_t(int fd) { - static struct _FD f = { -1, NULL, NULL, NULL }; - f.fd_fd = fd; - return fd == -1 ? NULL : &f; + static FD_t f = NULL; + if (fd == -1) return NULL; + if (f == NULL) f = fdNew(""); + fdSetFdno(f, fd); + return f; } '; @@ -72,6 +78,24 @@ Xtest(display) OUTPUT: RETVAL +void +setMouse(display, type) + char *display + int type + CODE: + { + XF86MiscMouseSettings mseinfo; + Display *d = XOpenDisplay(display); + if (d) { + if (XF86MiscGetMouseSettings(d, &mseinfo) == True) { + mseinfo.type = type; + mseinfo.flags = 128; + XF86MiscSetMouseSettings(d, &mseinfo); + XFlush(d); + } + } + } + void XSetInputFocus(window) int window @@ -655,7 +679,7 @@ headerGetEntry_int_list(h, query) int query PPCODE: int i, type, count = 0; - int_32 *intlist = (void **) NULL; + int_32 *intlist = (int_32 *) NULL; if (headerGetEntry((Header) h, query, &type, (void**) &intlist, &count)) { if (count > 0) { EXTEND(SP, count); @@ -681,6 +705,44 @@ headerGetEntry_string_list(h, query) } free(strlist); } + +void +headerGetEntry_filenames(h) + void *h + PPCODE: + int i, type, count = 0; + char ** baseNames, ** dirNames; + int_32 * dirIndexes; + char **strlist = (char **) NULL; + + if (headerGetEntry((Header) h, RPMTAG_OLDFILENAMES, &type, (void**) &strlist, &count)) { + if (count > 0) { + EXTEND(SP, count); + for (i = 0; i < count; i++) { + PUSHs(sv_2mortal(newSVpv(strlist[i], 0))); + } + } + free(strlist); + } else { + + headerGetEntry(h, RPMTAG_BASENAMES, &type, (void **) &baseNames, &count); + headerGetEntry(h, RPMTAG_DIRINDEXES, &type, (void **) &dirIndexes, NULL); + headerGetEntry(h, RPMTAG_DIRNAMES, &type, (void **) &dirNames, NULL); + + if (baseNames && dirNames && dirIndexes) { + EXTEND(SP, count); + for(i = 0; i < count; i++) { + char *p = malloc(strlen(dirNames[dirIndexes[i]]) + strlen(baseNames[i]) + 1); + if (p == NULL) croak("malloc failed"); + strcpy(p, dirNames[dirIndexes[i]]); + strcat(p, baseNames[i]); + PUSHs(sv_2mortal(newSVpv(p, 0))); + free(p); + } + free(baseNames); + free(dirNames); + } + } '; @macros = ( @@ -690,7 +752,7 @@ headerGetEntry_string_list(h, query) VT_ACTIVATE VT_WAITACTIVE VT_GETSTATE CDROM_LOCKDOOR CDROMEJECT ) ], ); -push @macros, [ qw(int RPMTAG_NAME RPMTAG_GROUP RPMTAG_SIZE RPMTAG_VERSION RPMTAG_SUMMARY RPMTAG_DESCRIPTION RPMTAG_RELEASE RPMTAG_ARCH RPMTAG_FILENAMES RPMTAG_OBSOLETES RPMTAG_REQUIRENAME RPMTAG_FILEFLAGS RPMFILE_CONFIG) ] +push @macros, [ qw(int RPMTAG_NAME RPMTAG_GROUP RPMTAG_SIZE RPMTAG_VERSION RPMTAG_SUMMARY RPMTAG_DESCRIPTION RPMTAG_RELEASE RPMTAG_ARCH RPMTAG_OBSOLETES RPMTAG_REQUIRENAME RPMTAG_FILEFLAGS RPMFILE_CONFIG) ] if $ENV{C_RPM}; $\= "\n"; diff --git a/perl-install/commands.pm b/perl-install/commands.pm index ea09c200a..ace3cb395 100644 --- a/perl-install/commands.pm +++ b/perl-install/commands.pm @@ -271,21 +271,25 @@ sub cp { sub ps { @_ and die "usage: ps\n"; - my ($pid, $cpu, $cmd); + my ($pid, $rss, $cpu, $cmd); my ($uptime) = split ' ', first(cat_("/proc/uptime")); my $hertz = 100; + require c; + my $page = c::getpagesize() / 1024; + open PS, ">&STDOUT"; format PS_TOP = - PID %CPU CMD + PID RSS %CPU CMD . format PS = -@>>>> @>>> @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< -$pid, $cpu, $cmd +@>>>> @>>>> @>>> @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< +$pid, $rss, $cpu, $cmd . foreach $pid (sort {$a <=> $b} grep { /\d+/ } all('/proc')) { my @l = split(' ', cat_("/proc/$pid/stat")); $cpu = sprintf "%2.1f", max(0, min(99, ($l[13] + $l[14]) * 100 / $hertz / ($uptime - $l[21] / $hertz))); + $rss = (split ' ', cat_("/proc/$pid/stat"))[23] * $page; (($cmd) = cat_("/proc/$pid/cmdline")) =~ s/\0/ /g; $cmd ||= (split ' ', (cat_("/proc/$pid/stat"))[0])[1]; write PS; diff --git a/perl-install/common.pm b/perl-install/common.pm index 9f4716b8c..bd8413788 100644 --- a/perl-install/common.pm +++ b/perl-install/common.pm @@ -6,7 +6,7 @@ use vars qw(@ISA %EXPORT_TAGS @EXPORT_OK $printable_chars $sizeof_int $bitof_int @ISA = qw(Exporter); %EXPORT_TAGS = ( - common => [ qw(__ even odd arch min max sqr sum and_ or_ sign product bool invbool listlength bool2text text2bool to_int to_float ikeys member divide is_empty_array_ref is_empty_hash_ref add2hash add2hash_ set_new set_add round round_up round_down first second top uniq translate untranslate warp_text formatAlaTeX formatLines deref) ], + common => [ qw(__ even odd arch min max sqr sum and_ or_ sign product bool invbool listlength bool2text bool2yesno text2bool to_int to_float ikeys member divide is_empty_array_ref is_empty_hash_ref add2hash add2hash_ set_new set_add round round_up round_down first second top uniq translate untranslate warp_text formatAlaTeX formatLines deref) ], functional => [ qw(fold_left compose map_index grep_index map_each grep_each list2kv map_tab_hash mapn mapn_ difference2 before_leaving catch_cdie cdie) ], file => [ qw(dirname basename touch all glob_ cat_ output symlinkf chop_ mode typeFromMagic) ], system => [ qw(sync makedev unmakedev psizeof strcpy gettimeofday syscall_ salt getVarsFromSh setVarsInSh setVarsInCsh substInFile availableRam availableMemory removeXiBSuffix template2file formatTime) ], @@ -68,6 +68,7 @@ sub bool($) { $_[0] ? 1 : 0 } sub invbool { my $a = shift; $$a = !$$a; $$a } sub listlength { scalar @_ } sub bool2text { $_[0] ? "true" : "false" } +sub bool2yesno { $_[0] ? "yes" : "no" } sub text2bool { my $t = lc($_[0]); $t eq "true" || $t eq "yes" ? 1 : 0 } sub strcpy { substr($_[0], $_[2] || 0, length $_[1]) = $_[1] } sub cat_ { local *F; open F, $_[0] or $_[1] ? die "cat of file $_[0] failed: $!\n" : return; my @l = ; wantarray ? @l : join '', @l } diff --git a/perl-install/install2.pm b/perl-install/install2.pm index ed08b72a3..6be64eb59 100644 --- a/perl-install/install2.pm +++ b/perl-install/install2.pm @@ -192,8 +192,8 @@ $o = $::o = { #- display => "192.168.1.19:1", steps => \%installSteps, orderedSteps => \@orderedInstallSteps, - base => [ qw(basesystem sed initscripts console-tools utempter ldconfig chkconfig ntsysv setup filesystem SysVinit bdflush crontabs dev e2fsprogs etcskel fileutils findutils getty_ps grep gzip hdparm info initscripts kernel less ldconfig logrotate losetup man mingetty modutils mount net-tools passwd procmail procps psmisc mandrake-release rootfiles rpm sash ash setserial shadow-utils sh-utils stat sysklogd tar termcap textutils time tmpwatch util-linux vim-minimal vixie-cron which perl-base msec) ], - base_i386 => [ "lilo", "mkbootdisk", "isapnptools" ], + base => [ qw(basesystem sed initscripts console-tools utempter ldconfig chkconfig ntsysv setup filesystem SysVinit bdflush crontabs dev e2fsprogs etcskel fileutils findutils getty_ps grep gzip hdparm info kernel less ldconfig logrotate losetup man mingetty modutils mount net-tools passwd procmail procps psmisc mandrake-release rootfiles rpm sash ash setserial shadow-utils sh-utils stat sysklogd tar termcap textutils time tmpwatch util-linux vim-minimal vixie-cron which perl-base msec) ], + base_i386 => [ "lilo", "grub", "mkbootdisk", "isapnptools" ], base_alpha => [ "aboot", "isapnptools" ], base_sparc => [ "silo", "mkbootdisk" ], base_ppc => [ "kernel-pmac", "pdisk", "hfsutils" ], @@ -424,7 +424,8 @@ sub configureNetwork { $o->configureNetwork($_[1] == 1); } #------------------------------------------------------------------------------ -sub installCrypto { $o->installCrypto } +sub installCrypto { return; #TODO broken + $o->installCrypto } #------------------------------------------------------------------------------ sub configureTimezone { diff --git a/perl-install/install_any.pm b/perl-install/install_any.pm index b7a4f0e09..332dbed3e 100644 --- a/perl-install/install_any.pm +++ b/perl-install/install_any.pm @@ -123,9 +123,7 @@ sub setPackages($) { require pkgs; if (is_empty_hash_ref($o->{packages})) { - my $useHdlist = 1; #$o->{method} !~ /nfs|hd/ || $o->{isUpgrade}; - eval { $o->{packages} = pkgs::psUsingHdlist($o->{prefix}) } if $useHdlist; - $o->{packages} = pkgs::psUsingDirectory() if !$useHdlist || $@; + $o->{packages} = pkgs::psUsingHdlist($o->{prefix}); push @{$o->{default_packages}}, "nfs-utils-clients" if $o->{method} eq "nfs"; push @{$o->{default_packages}}, "numlock" if $o->{miscellaneous}{numlock}; @@ -503,18 +501,6 @@ sub install_urpmi { (my $name = _("installation")) =~ s/\s/_/g; #- in case translators are too good :-/ - my $f = "$prefix/var/lib/urpmi/hdlist.$name"; - { - my $fd = getFile("hdlist") or return; - local *OUT; - open OUT, ">$f" or log::l("failed to write $f"), return; - local $/ = \ (16 * 1024); - print OUT foreach <$fd>; - } - { - local *F = getFile("depslist"); - output("$prefix/var/lib/urpmi/depslist", ); - } { local *LIST; open LIST, ">$prefix/var/lib/urpmi/list.$name" or log::l("failed to write list.$name"), return; @@ -524,13 +510,9 @@ sub install_urpmi { ftp => $ENV{URLPREFIX}, http => $ENV{URLPREFIX}, cdrom => "removable_cdrom_1://mnt/cdrom" }}{$method}; - local *FILES; open FILES, "hdlist2names $f|"; - chop, print LIST "$dir/Mandrake/RPMS/$_\n" foreach ; - close FILES or log::l("hdlist2names failed"), return; - - run_program::run("gzip", "-9", $f); + print LIST "$dir/Mandrake/RPMS/", /(\S+)/, "\n" foreach cat_("$prefix/var/lib/urpmi/depslist"); - $dir .= "/Mandrake/RPMS with ../base/hdlist" if $method =~ /ftp|http/; + $dir .= "/Mandrake/RPMS with ../base/hdlist.cz2" if $method =~ /ftp|http/; eval { output "$prefix/etc/urpmi/urpmi.cfg", "$name $dir\n" }; } } diff --git a/perl-install/install_steps.pm b/perl-install/install_steps.pm index 3cd7b5149..b1c842e16 100644 --- a/perl-install/install_steps.pm +++ b/perl-install/install_steps.pm @@ -406,6 +406,7 @@ sub pppConfig { #------------------------------------------------------------------------------ sub installCrypto { my ($o) = @_; + return; #TODO broken for now my $u = $o->{crypto} or return; $u->{mirror} or return; my ($packages, %done); my $dir = "$o->{prefix}/tmp"; @@ -421,13 +422,13 @@ sub installCrypto { require pkgs; while (crypto::get($u->{mirror}, $dir, grep { !$done{$_} && ($done{$_} = $u->{packages}{$_}) } %{$u->{packages}})) { - $packages = pkgs::psUsingDirectory($dir); - foreach (values %$packages) { - foreach (c::headerGetEntry(pkgs::getHeader($_), 'requires')) { - my $r = quotemeta crypto::require2package($_); - /^$r-\d/ and $u->{packages}{$_} = 1 foreach keys %{$u->{packages}}; - } - } +# $packages = pkgs::psUsingDirectory($dir); +# foreach (values %$packages) { +# foreach (c::headerGetEntry(pkgs::getHeader($_), 'requires')) { +# my $r = quotemeta crypto::require2package($_); +# /^$r-\d/ and $u->{packages}{$_} = 1 foreach keys %{$u->{packages}}; +# } +# } } pkgs::install($o->{prefix}, $o->{isUpgrade}, [ values %$packages ]); } @@ -642,7 +643,7 @@ sub setupBootloader($) { } elsif (arch() =~ /^sparc/) { silo::install($o->{prefix}, $o->{bootloader}); } else { - lilo::install($o->{prefix}, $o->{bootloader}); + lilo::install_grub($o->{prefix}, $o->{bootloader}, $o->{fstab}); } } diff --git a/perl-install/install_steps_gtk.pm b/perl-install/install_steps_gtk.pm index 62b2c3762..5f1839c62 100644 --- a/perl-install/install_steps_gtk.pm +++ b/perl-install/install_steps_gtk.pm @@ -387,7 +387,7 @@ sub choosePackagesTree { $w->show; $w->set_sensitive(!pkgs::packageFlagBase($p) && !pkgs::packageFlagInstalled($p)); $w->signal_connect(focus_in_event => sub { - my $p = eval { pkgs::getHeader($p) }; #- TODO + my $p = eval { pkgs::getHeader ($p) }; #- TODO gtktext_insert($info_widget, $@ ? _("Bad package") : _("Version: %s\n", c::headerGetEntry($p, 'version') . '-' . c::headerGetEntry($p, 'release')) . _("Size: %d KB\n", c::headerGetEntry($p, 'size') / 1024) . diff --git a/perl-install/install_steps_interactive.pm b/perl-install/install_steps_interactive.pm index b5575330c..53665bec3 100644 --- a/perl-install/install_steps_interactive.pm +++ b/perl-install/install_steps_interactive.pm @@ -1154,7 +1154,7 @@ sub load_thiskind { install_any::ultra66($o); if (my ($c) = pci_probing::main::probe('AUDIO')) { - modules::add_alias("sound", $c); + modules::add_alias("sound", $c->[1]); } } modules::load_thiskind($type, sub { $w = wait_load_module($o, $type, @_) }, $pcmcia); diff --git a/perl-install/modules.pm b/perl-install/modules.pm index d66b3172b..2727706e5 100644 --- a/perl-install/modules.pm +++ b/perl-install/modules.pm @@ -471,10 +471,10 @@ sub write_conf { my %net = detect_devices::net2module(); while (my ($k, $v) = each %net) { add_alias($k, $v) } - if (my @scsis = sort grep { $conf{$_}{alias} && /scsi_hostadapter/ } keys %conf) { - log::l("has scsis ", join " ; ", map { "modprobe $_" } @scsis); - $conf{supermount}{"post-install"} = join " ; ", map { "modprobe $_" } @scsis; - } + my @l = sort grep { $conf{$_}{alias} && /scsi_hostadapter/ } keys %conf; + add_alias('block-major-11', 'scsi_hostadapter'); + push @l, "ide-floppy" if detect_devices::zips(); + $conf{supermount}{"post-install"} = join " ; ", map { "modprobe $_" } @l if @l; local *F; open F, ">> $file" or die("cannot write module config file $file: $!\n"); diff --git a/perl-install/mouse.pm b/perl-install/mouse.pm index 8bf898d5a..fcbf1e25f 100644 --- a/perl-install/mouse.pm +++ b/perl-install/mouse.pm @@ -122,7 +122,7 @@ sub mouseconfig { sub detect() { return name2mouse("Sun - Mouse") if arch() =~ /^sparc/; - if (arch() eq"ppc") { + if (arch() eq "ppc") { return name2mouse("Apple USB Mouse") if detect_devices::hasMouseMacUSB; # No need to search for an ADB mouse. If I did, the PPC kernel would # find one whether or not I had one installed! So.. default to it. diff --git a/perl-install/network.pm b/perl-install/network.pm index 3422eee4c..deb092992 100644 --- a/perl-install/network.pm +++ b/perl-install/network.pm @@ -98,7 +98,7 @@ sub write_interface_conf { add2hash($intf, { BROADCAST => join('.', mapn { int $_[0] | ~int $_[1] & 255 } \@ip, \@mask), NETWORK => join('.', mapn { int $_[0] & $_[1] } \@ip, \@mask), - ONBOOT => "yes", + ONBOOT => bool2yesno(!$::o->{pcmcia}), }); setVarsInSh($file, $intf, qw(DEVICE BOOTPROTO IPADDR NETMASK NETWORK BROADCAST ONBOOT)); } diff --git a/perl-install/pkgs.pm b/perl-install/pkgs.pm index f67d2dfae..d2cbc116e 100644 --- a/perl-install/pkgs.pm +++ b/perl-install/pkgs.pm @@ -85,14 +85,12 @@ $PKGS_UNSKIP = 0x10000000; #- following flags : selected, force, installed, base, skip. #- size and deps are grouped to save memory too and make a much #- simpler and faster depslist reader, this gets (sizeDeps). -sub packageFile { my ($pkg) = @_; $pkg->{file} } -sub packageHeaderFile { my ($pkg) = @_; $pkg->{file} =~ /(.*-[^-]+-[^-]+\.[^.]+)\.rpm/ && $1 or die "invalid file `$pkg->{file}'" } -sub packageName { my ($pkg) = @_; $pkg->{file} =~ /(.*)-[^-]+-[^-]+\.[^.]+\.rpm/ && $1 or die "invalid file `$pkg->{file}'" } -sub packageVersion { my ($pkg) = @_; $pkg->{file} =~ /.*-([^-]+)-[^-]+\.[^.]+\.rpm/ && $1 or die "invalid file `$pkg->{file}'" } -sub packageRelease { my ($pkg) = @_; $pkg->{file} =~ /.*-[^-]+-([^-]+)\.[^.]+\.rpm/ && $1 or die "invalid file `$pkg->{file}'" } -sub packageArch { my ($pkg) = @_; $pkg->{file} =~ /.*-[^-]+-[^-]+\.([^.]+)\.rpm/ && $1 or die "invalid file `$pkg->{file}'" } - -sub packageSize { my ($pkg) = @_; int $pkg->{sizeDeps} } +sub packageHeaderFile { my ($pkg) = @_; $pkg->{file} } +sub packageName { my ($pkg) = @_; $pkg->{file} =~ /(.*)-[^-]+-[^-]+/ && $1 or die "invalid file `$pkg->{file}'" } +sub packageVersion { my ($pkg) = @_; $pkg->{file} =~ /.*-([^-]+)-[^-]+/ && $1 or die "invalid file `$pkg->{file}'" } +sub packageRelease { my ($pkg) = @_; $pkg->{file} =~ /.*-[^-]+-([^-]+)/ && $1 or die "invalid file `$pkg->{file}'" } + +sub packageSize { my ($pkg) = @_; to_int($pkg->{sizeDeps}) } sub packageDepsId { my ($pkg) = @_; split ' ', ($pkg->{sizeDeps} =~ /^\d*\s+(.*)/)[0] } sub packageFlagSelected { my ($pkg) = @_; $pkg->{flags} & $PKGS_SELECTED } @@ -102,33 +100,40 @@ sub packageFlagBase { my ($pkg) = @_; $pkg->{flags} & $PKGS_BASE } sub packageFlagSkip { my ($pkg) = @_; $pkg->{flags} & $PKGS_SKIP } sub packageFlagUnskip { my ($pkg) = @_; $pkg->{flags} & $PKGS_UNSKIP } -sub packageSetFlagSelected { my ($pkg, $v) = @_; $pkg->{flags} &= ~$PKGS_SELECTED; $pkg->{flags} |= $v & $PKGS_SELECTED; } -sub packageSetFlagForce { my ($pkg, $v) = @_; $v ? $pkg->{flags} |= $PKGS_FORCE : $pkg->{flags} &= ~$PKGS_FORCE; } -sub packageSetFlagInstalled { my ($pkg, $v) = @_; $v ? $pkg->{flags} |= $PKGS_INSTALLED : $pkg->{flags} &= ~$PKGS_INSTALLED; } -sub packageSetFlagBase { my ($pkg, $v) = @_; $v ? $pkg->{flags} |= $PKGS_BASE : $pkg->{flags} &= ~$PKGS_BASE; } -sub packageSetFlagSkip { my ($pkg, $v) = @_; $v ? $pkg->{flags} |= $PKGS_SKIP : $pkg->{flags} &= ~$PKGS_SKIP; } -sub packageSetFlagUnskip { my ($pkg, $v) = @_; $v ? $pkg->{flags} |= $PKGS_UNSKIP : $pkg->{flags} &= ~$PKGS_UNSKIP; } +sub packageSetFlagSelected { my ($pkg, $v) = @_; $v ? ($pkg->{flags} |= $PKGS_SELECTED) : ($pkg->{flags} &= ~$PKGS_SELECTED); } +sub packageSetFlagForce { my ($pkg, $v) = @_; $v ? ($pkg->{flags} |= $PKGS_FORCE) : ($pkg->{flags} &= ~$PKGS_FORCE); } +sub packageSetFlagInstalled { my ($pkg, $v) = @_; $v ? ($pkg->{flags} |= $PKGS_INSTALLED) : ($pkg->{flags} &= ~$PKGS_INSTALLED); } +sub packageSetFlagBase { my ($pkg, $v) = @_; $v ? ($pkg->{flags} |= $PKGS_BASE) : ($pkg->{flags} &= ~$PKGS_BASE); } +sub packageSetFlagSkip { my ($pkg, $v) = @_; $v ? ($pkg->{flags} |= $PKGS_SKIP) : ($pkg->{flags} &= ~$PKGS_SKIP); } +sub packageSetFlagUnskip { my ($pkg, $v) = @_; $v ? ($pkg->{flags} |= $PKGS_UNSKIP) : ($pkg->{flags} &= ~$PKGS_UNSKIP); } sub packageProvides { my ($pkg) = @_; @{$pkg->{provides} || []} } -#- get all headers from hdlist.cz, remove any older headers in memory. -sub extractHeaders($@) { - my $prefix = shift; - my @pkgs = grep { !$_->{header} } @_; +sub packageFile { + my ($pkg) = @_; + $pkg->{header} or die "packageFile: missing header"; + $pkg->{file} . "." . c::headerGetEntry($pkg->{header}, 'arch') . ".rpm"; +} + + +#- get all headers from hdlist.cz +sub extractHeaders { + my ($prefix, $pkgs) = @_; + + commands::rm("-rf", "$prefix/tmp/headers") if -e "$prefix/tmp/headers"; - eval { commands::rm("-rf", "$prefix/tmp/headers") }; - run_program::run("extract_archive", "$prefix/var/lib/urpmi/hdlist.cz2", "$prefix/tmp/headers", - map { packageHeaderFile($_) } @pkgs); + run_program::run("extract_archive", + "$prefix/var/lib/urpmi/hdlist.cz2", + "$prefix/tmp/headers", + map { packageHeaderFile($_) } @$pkgs); - foreach (@pkgs) { + foreach (@$pkgs) { my $f = "$prefix/tmp/headers/". packageHeaderFile($_); local *H; open H, $f or die "unable to open header file $f: $!"; $_->{header} = c::headerRead(fileno H, 1) or log::l("unable to read header of package ". packageHeaderFile($_)); - close H; } - - grep { $_->{header} } @pkgs; + @$pkgs = grep { $_->{header} } @$pkgs; } #- size and correction size functions for packages. @@ -165,7 +170,6 @@ sub allPackages { #- selection, unselection of package. sub selectPackage($$;$$) { my ($packages, $pkg, $base, $otherOnly) = @_; - my %preferred; @preferred{@preferred} = (); #- check if the same or better version is installed, #- do not select in such case. @@ -177,27 +181,26 @@ sub selectPackage($$;$$) { #- is only used for unselection, not selection) unless (packageFlagSelected($pkg)) { foreach (packageDepsId($pkg)) { + my $preferred; if (/\|/) { #- choice deps should be reselected recursively as no #- closure on them is computed, this code is exactly the #- same as pixel's one. - my ($choiceDepsPkg, $preferredDepsPkg); - foreach (split '\|', $_) { - $choiceDepsPkg = packageById($packages, $_); - $preferredDepsPkg ||= $choiceDepsPkg; - $choiceDepsPkg && packageFlagSelected($choiceDepsPkg) and - $preferredDepsPkg = $choiceDepsPkg, last; - $choiceDepsPkg && exists $preferred{packageName($choiceDepsPkg)} and - $preferredDepsPkg = $choiceDepsPkg; + my %preferred; @preferred{@preferred} = (); + foreach (split '\|') { + my $dep = packageById($packages, $_) or next; + $preferred ||= $dep; + packageFlagSelected($dep) and $preferred = $dep, last; + exists $preferred{packageName($dep)} and $preferred = $dep; } - $preferredDepsPkg and selectPackage($packages, $preferredDepsPkg, $base, $otherOnly); + selectPackage($packages, $preferred, $base, $otherOnly) if $preferred; } else { #- deps have been closed except for choices, so no need to #- recursively apply selection, expand base on it. - my $depsPkg = packageById($packages, $_); - $base and packageSetFlagBase($depsPkg, 1); - $otherOnly and !packageFlagSelected($depsPkg) and $otherOnly->{packageName($depsPkg)} = 1; - $otherOnly or packageSetFlagSelected($depsPkg, 1+packageFlagSelected($depsPkg)); + my $dep = packageById($packages, $_); + $base and packageSetFlagBase($dep, 1); + $otherOnly and !packageFlagSelected($dep) and $otherOnly->{packageName($dep)} = 1; + $otherOnly or packageSetFlagSelected($dep, 1+packageFlagSelected($dep)); } } } @@ -225,12 +228,12 @@ sub unselectPackage($$;$) { $otherOnly or packageSetFlagSelected($providedPkg, 0); $otherOnly and $otherOnly->{packageName{$providedPkg}} = 1; foreach (map { split '\|' } packageDepsId($providedPkg)) { - my $depsPkg = packageById($packages, $_); - packageFlagBase($depsPkg) and next; - packageFlagSelected($depsPkg) or next; - for (packageFlagSelected($depsPkg)) { - $_ == 1 and do { $otherOnly and $otherOnly->{packageName($depsPkg)} ||= 0; }; - $_ > 1 and do { $otherOnly or packageSetFlagSelected($depsPkg, $_-1); }; + my $dep = packageById($packages, $_); + packageFlagBase($dep) and next; + packageFlagSelected($dep) or next; + for (packageFlagSelected($dep)) { + $_ == 1 and do { $otherOnly and $otherOnly->{packageName($dep)} ||= 0; }; + $_ > 1 and do { $otherOnly or packageSetFlagSelected($dep, $_-1); }; last; } } @@ -256,26 +259,6 @@ sub skipSetWithProvides { packageSetFlagSkip($_, 1) foreach grep { $_ } map { $_, packageProvides($_) } map { packageByName($packages, $_) } @l; } -sub psUsingDirectory(;$) { #- obseleted... - my $dirname = $_[0] || "/tmp/rhimage/Mandrake/RPMS"; - my @packages; - - log::l("scanning $dirname for packages"); - $packages[0] = {}; - foreach (all("$dirname")) { - my $pkg = { file => $_, #- filename - flags => 0, #- flags - }; - $packages[0]{packageName($pkg)} = $pkg; - } - - $packages[1] = []; - - log::l("psUsingDirectory read " . scalar keys(%{$packages[0]}) . " filenames"); - - \@packages; -} - sub psUsingHdlist($) { my ($prefix) = @_; my $f = install_any::getFile('hdlist.cz2') or die "no hdlist.cz2 found"; @@ -297,7 +280,7 @@ sub psUsingHdlist($) { chomp; next unless /^[dlf]\s+/; if (/^f\s+\d+\s+(.*)/) { - my $pkg = { file => "$1.rpm", #- rebuild filename according to header one + my $pkg = { file => $1, #- rebuild filename according to header one flags => 0, #- flags }; $packages[0]{packageName($pkg)} = $pkg; @@ -315,10 +298,6 @@ sub psUsingHdlist($) { \@packages; } -sub chopVersionRelease($) { - first($_[0] =~ /(.*)-[^-]+-[^-]+/) || $_[0]; -} - sub getDeps($) { my ($packages) = @_; @@ -333,7 +312,7 @@ sub getDeps($) { my $pkg = $packages->[0]{$name}; $pkg or log::l("ignoring package $name-$version-$release in depslist is not in hdlist"), next; - $version == packageVersion($pkg) and $release == packageRelease($pkg) + $version eq packageVersion($pkg) and $release eq packageRelease($pkg) or log::l("ignoring package $name-$version-$release in depslist mismatch version or release in hdlist"), next; $pkg->{sizeDeps} = $sizeDeps; @@ -345,18 +324,17 @@ sub getDeps($) { sub getProvides($) { my ($packages) = @_; - - foreach (@{$packages->[1]}) { - my $pkg = $_; - - #- 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 - #- the provided package will be deleted where other package still - #- need it. - #- base package are not updated because they cannot be unselected, - #- this save certainly a lot of memory since most of them may be - #- needed by a large number of package. + + #- 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 + #- the provided package will be deleted where other package still + #- need it. + #- base package are not updated because they cannot be unselected, + #- this save certainly a lot of memory since most of them may be + #- needed by a large number of package. + + foreach my $pkg (@{$packages->[1]}) { map { my $providedPkg = $packages->[1][$_] or die "invalid package index $_"; packageFlagBase($providedPkg) or push @{$providedPkg->{provides} ||= []}, $pkg; } map { split '\|' } packageDepsId($pkg); @@ -508,9 +486,7 @@ sub init_db { if ($isUpgrade) { c::rpmdbRebuild($prefix) or die "rebuilding of rpm database failed: ", c::rpmErrorString(); } - c::rpmdbInit($prefix, 0644) or die "creation of rpm database failed: ", c::rpmErrorString(); -#- $isUpgrade ? c::rpmdbRebuild($prefix) : c::rpmdbInit($prefix, 0644) or die "creation/rebuilding of rpm database failed: ", c::rpmErrorString(); } sub done_db { @@ -518,16 +494,6 @@ sub done_db { close LOG; } -sub getHeader($) { - my ($p) = @_; - - unless ($p->{header}) { - my $f = install_any::getFile($p->{file}) or die "error opening package $p->{name} (file $p->{file})"; - $p->{header} = c::rpmReadPackageHeader(fileno $f) or die "bad package $p->{name}"; - } - $p->{header}; -} - sub versionCompare($$) { my ($a, $b) = @_; local $_; @@ -571,7 +537,7 @@ sub selectPackagesToUpgrade($$$;$$) { c::headerGetEntry($header, 'version'). '-' . c::headerGetEntry($header, 'release'))); if ($p) { - eval { getHeader($p) }; $@ && log::l("cannot get the header for package $p->{name}"); + eval { getHeader ($p) }; $@ && log::l("cannot get the header for package $p->{name}"); my $version_cmp = versionCompare(c::headerGetEntry($header, 'version'), $p->{version}); my $version_rel_test = $p->{header} ? c::rpmVersionCompare($header, $p->{header}) >= 0 : ($version_cmp > 0 || @@ -630,7 +596,7 @@ sub selectPackagesToUpgrade($$$;$$) { @installedFilesForUpgrade{grep { ($_ !~ m|^/etc/rc.d/| && ! -d "$prefix/$_" && ! -l "$prefix/$_") } @files} = (); }); - eval { getHeader($p) }; + eval { getHeader ($p) }; my @availFiles = $p->{header} ? c::headerGetEntry($p->{header}, 'filenames') : (); map { delete $installedFilesForUpgrade{$_} } grep { $_ !~ m|^/etc/rc.d/| } @availFiles; @@ -646,7 +612,7 @@ sub selectPackagesToUpgrade($$$;$$) { my $p = $_; if ($p->{selected}) { - eval { getHeader($p) }; + eval { getHeader ($p) }; my @availFiles = $p->{header} ? c::headerGetEntry($p->{header}, 'filenames') : (); map { delete $installedFilesForUpgrade{$_} } grep { $_ !~ m|^/etc/rc.d/| } @availFiles; } @@ -657,7 +623,7 @@ sub selectPackagesToUpgrade($$$;$$) { my $p = $_; unless ($p->{selected}) { - eval { getHeader($p) }; + eval { getHeader ($p) }; my @availFiles = $p->{header} ? c::headerGetEntry($p->{header}, 'filenames') : (); my $toSelect = 0; map { if (exists $installedFilesForUpgrade{$_}) { @@ -672,8 +638,8 @@ sub selectPackagesToUpgrade($$$;$$) { foreach (values %$packages) { my $p = $_; - eval { getHeader($p) }; - my @obsoletes = $p->{header} ? c::headerGetEntry(getHeader($p), 'obsoletes'): (); + eval { getHeader ($p) }; + my @obsoletes = $p->{header} ? c::headerGetEntry(getHeader ($p), 'obsoletes'): (); map { selectPackage($packages, $p) if c::rpmdbNameTraverse($db, $_) > 0 } @obsoletes; } @@ -724,7 +690,6 @@ sub selectPackagesToUpgrade($$$;$$) { sub installCallback { my $msg = shift; - log::l($msg .": ". join(',', @_)); } @@ -754,18 +719,17 @@ sub install($$$;$) { log::l("opened rpm database for installing ". scalar @$toInstall ." new packages"); my $callbackOpen = sub { - my $f = packageFile(my $pkg = delete $packages{$_[0]}); + my $f = packageFile($packages{$_[0]}); print LOG "$f\n"; my $fd = install_any::getFile($f) or log::l("ERROR: bad file $f"); $fd ? fileno $fd : -1; }; - my $callbackClose = sub { packageSetFlagInstalled($packages{$_[0]}, 1); }; - my $callbackMessage = \&pkgs::installCallback; + my $callbackClose = sub { packageSetFlagInstalled(delete $packages{$_[0]}, 1) }; #- do not modify/translate the message used with installCallback since #- these are keys during progressing installation, or change in other #- place (install_steps_gtk.pm,...). - &$callbackMessage("Starting installation", $nb, $total); + installCallback("Starting installation", $nb, $total); my ($i, $min) = (0, 0); do { @@ -774,12 +738,10 @@ sub install($$$;$) { @transToInstall = values %packages; } else { while ($i < @$depOrder && ($i < $min || scalar @transToInstall < $limitMinTrans)) { - my $depsPkg = $packages{packageName($depOrder->[$i++])}; - if ($depsPkg) { - push @transToInstall, $depsPkg; - foreach (map { split '\|' } packageDepsId($depsPkg)) { - $min < $_ and $min = $_; - } + my $dep = $packages{packageName($depOrder->[$i++])} or next; + push @transToInstall, $dep; + foreach (map { split '\|' } packageDepsId($dep)) { + $min < $_ and $min = $_; } } } @@ -788,20 +750,30 @@ sub install($$$;$) { log::l("starting new transaction of ". scalar @transToInstall ." packages, still $nb after that to do"); my $trans = c::rpmtransCreateSet($db, $prefix); - foreach (extractHeaders($prefix, @transToInstall)) { - my $p = $_; - eval { getHeader($p) }; $@ and next; - c::rpmtransAddPackage($trans, getHeader($p), packageName($p), $isUpgrade && packageName($p) !~ /kernel/); #- TODO: replace `named kernel' by `provides kernel' - } - c::rpmdepOrder($trans) or - cdie "error ordering package list: " . c::rpmErrorString(), - sub { - c::rpmtransFree($trans); - c::rpmdbClose($db); - }; + extractHeaders($prefix, \@transToInstall); + + c::rpmtransAddPackage($trans, $_->{header}, packageName($_), $isUpgrade && packageName($_) !~ /kernel/) #- TODO: replace `named kernel' by `provides kernel' + foreach @transToInstall; + + my $close = sub { +# c::headerFree(delete $_->{header}) foreach @transToInstall; + c::rpmtransFree($trans); + }; + + c::rpmdepOrder($trans) or + cdie "error ordering package list: " . c::rpmErrorString(), sub { + &$close(); + c::rpmdbClose($db); + }; c::rpmtransSetScriptFd($trans, fileno LOG); - if (my @probs = c::rpmRunTransactions($trans, $callbackOpen, $callbackClose, $callbackMessage, 0)) { + log::l("rpmRunTransactions start"); + + my @probs = c::rpmRunTransactions($trans, $callbackOpen, $callbackClose, \&installCallback, 0); + log::l("rpmRunTransactions done"); + &$close(); + log::l("after close"); + if (@probs) { my %parts; @probs = reverse grep { if (s/(installing package) .* (needs (?:.*) on the (.*) filesystem)/$1 $2/) { @@ -809,11 +781,9 @@ sub install($$$;$) { } else { 1; } } reverse @probs; - c::rpmtransFree($trans); c::rpmdbClose($db); die "installation of rpms failed:\n ", join("\n ", @probs); } - c::rpmtransFree($trans); } while ($nb > 0); c::rpmdbClose($db); @@ -845,7 +815,6 @@ sub remove($$) { my $callbackOpen = sub { log::l("trying to open file from $_[0] which should not happen"); }; my $callbackClose = sub { log::l("trying to close file from $_[0] which should not happen"); }; - my $callbackMessage = \&pkgs::installCallback; #- we are not checking depends since it should come when #- upgrading a system. although we may remove some functionalities ? @@ -853,9 +822,9 @@ sub remove($$) { #- do not modify/translate the message used with installCallback since #- these are keys during progressing installation, or change in other #- place (install_steps_gtk.pm,...). - &$callbackMessage("Starting removing other packages", scalar @$toRemove); + installCallback("Starting removing other packages", scalar @$toRemove); - if (my @probs = c::rpmRunTransactions($trans, $callbackOpen, $callbackClose, $callbackMessage, 0)) { + if (my @probs = c::rpmRunTransactions($trans, $callbackOpen, $callbackClose, \&installCallback, 0)) { die "removing of old rpms failed:\n ", join("\n ", @probs); } c::rpmtransFree($trans); diff --git a/perl-install/services.pm b/perl-install/services.pm index 819528033..d43867268 100644 --- a/perl-install/services.pm +++ b/perl-install/services.pm @@ -72,7 +72,7 @@ xfs => __("Starts and stops the X Font Server at boot time and shutdown."), sub drakxservices { my ($in, $prefix) = @_; my $cmd = $prefix ? "chroot $prefix" : ""; - my @services = map { log::l ("services: $_"); [/(\S+)/, /:on/ ] } sort `LANGUAGE=C $cmd chkconfig --list`; + my @services = map { [/(\S+)/, /:on/ ] } sort `LANGUAGE=C $cmd chkconfig --list`; my @l = map { $_->[0] } @services; my @before = map { $_->[1] } @services; my @descr = map { -- cgit v1.2.1