diff options
Diffstat (limited to 'perl-install/install/pkgs.pm')
| -rw-r--r-- | perl-install/install/pkgs.pm | 893 |
1 files changed, 419 insertions, 474 deletions
diff --git a/perl-install/install/pkgs.pm b/perl-install/install/pkgs.pm index 98e7c73c4..a9692e225 100644 --- a/perl-install/install/pkgs.pm +++ b/perl-install/install/pkgs.pm @@ -1,6 +1,7 @@ -package install::pkgs; # $Id$ +package install::pkgs; use strict; +use feature 'state'; BEGIN { # needed before "use URPM" @@ -11,6 +12,9 @@ BEGIN { use URPM; use URPM::Resolve; use URPM::Signature; +use urpm; +use urpm::args; +use urpm::main_loop; use urpm::select; use common; use install::any; @@ -23,7 +27,6 @@ use fs::any; use fs::loopback; use c; - #- lower bound on the left ( aka 90 means [90-100[ ) our %compssListDesc = ( 5 => N_("must have"), @@ -33,43 +36,13 @@ our %compssListDesc = ( 1 => N_("maybe"), ); -#- constant for small transaction. -our $limitMinTrans = 13; - - -sub cleanHeaders() { - rm_rf("$::prefix/tmp/headers") if -e "$::prefix/tmp/headers"; -} - -#- get all headers from an hdlist file. -sub extractHeaders { - my ($pkgs, $media) = @_; - cleanHeaders(); - - foreach my $medium (@$media) { - $medium->{selected} or next; - - my @l = grep { $_->id >= $medium->{start} && $_->id <= $medium->{end} } @$pkgs or next; - eval { - require packdrake; - my $packer = new packdrake(install::media::hdlist_on_disk($medium), quiet => 1); - $packer->extract_archive("$::prefix/tmp/headers", map { $_->header_filename } @l); - }; - $@ and log::l("packdrake failed: $@"); - } - - foreach (@$pkgs) { - my $f = "$::prefix/tmp/headers/" . $_->header_filename; - $_->update_header($f) or log::l("unable to open header file $f"), next; - } -} - #- TODO BEFORE TODO #- size and correction size functions for packages. -my $B = 1.20873; -my $C = 4.98663; #- does not take hdlist's into account as getAvailableSpace will do it. -sub correctSize { $B * $_[0] + $C } -sub invCorrectSize { ($_[0] - $C) / $B } +my $B = 120873; +my $C = 498663; #- does not take hdlist's into account as getAvailableSpace will do it. +my $D = 100000; +sub correctSize { ($B * $_[0] + $C) / $D } +sub invCorrectSize { ($_[0] * $D - $C) / $B } sub selectedSize { my ($packages) = @_; @@ -97,29 +70,78 @@ sub selectedSize { sub size2time { my ($x, $max) = @_; - my $A = 7e-07; + my $A = 7e9; my $limit = min($max * 3 / 4, 9e8); if ($x < $limit) { $A * $x; } else { $x -= $limit; - my $B = 6e-16; - my $C = 15e-07; + my $B = 6; + my $C = 15e9; $B * $x ** 2 + $C * $x + $A * $limit; } } -#- search package with given name and compatible with current architecture. +# Based on Rpmdrake::pkg::extract_header(): +sub get_pkg_info { + my ($p) = @_; + + my $urpm = $::o->{packages}; + my $name = $p->fullname; + + my $medium = URPM::pkg2media($urpm->{media}, $p); + my ($local_source, %xml_info_pkgs, $description); + my $dir = urpm::file_from_local_url($medium->{url}); + $local_source = "$dir/" . $p->filename if $dir; + + if (-s $local_source) { + log::l("getting information from $dir..."); + $p->update_header($local_source) and $description = $p->description; + log::l("Warning, could not extract header for $name from $medium!") if !$description; + } + if (!$description) { + my $_w = $::o->wait_message(undef, N("Getting package information from XML meta-data...")); + if (my $xml_info_file = eval { urpm::media::any_xml_info($urpm, $medium, 'info', undef, urpm::download::sync_logger) }) { + require urpm::xml_info; + require urpm::xml_info_pkg; + log::l("getting information from $xml_info_file"); + my %nodes = eval { urpm::xml_info::get_nodes('info', $xml_info_file, [ $name ]) }; + goto header_non_available if $@; + put_in_hash($xml_info_pkgs{$name} ||= {}, $nodes{$name}); + } else { + $urpm->{info}(N("No xml info for medium \"%s\", only partial result for package %s", $medium->{name}, $name)); + } + } + + if (!$description && $xml_info_pkgs{$name}) { + $description = $xml_info_pkgs{$name}{description}; + } + header_non_available: + $description || N("No description"); +} + +sub packagesProviding { + my ($packages, $name) = @_; + grep { $_->is_arch_compat } URPM::packages_providing($packages, $name); +} + +#- search package with given name (and optional ISA) and compatible with current architecture. #- take the best one found (most up-to-date). +# FIXME: reuse urpmi higher level code instead! sub packageByName { my ($packages, $name) = @_; - my @l = grep { $_->is_arch_compat && $_->name eq $name } URPM::packages_providing($packages, $name); + my $basename = $name =~ s/\(x86-..\)$//r; + my @l = sort { $b->id <=> $a->id } grep { $_->name eq $basename } packagesProviding($packages, $name); my $best; foreach (@l) { if ($best && $best != $_) { - $_->compare_pkg($best) > 0 and $best = $_; + if ($best->fullname eq $_->fullname) { + $best = $_ if $_->flag_installed; + } else { + $_->compare_pkg($best) > 0 and $best = $_; + } } else { $best = $_; } @@ -128,22 +150,32 @@ sub packageByName { $best; } -sub bestKernel_extensions { +sub _is_kernelServer_needed() { + # forbid selecting kernel-server if not having PAE since PAE support is mandatory for kernel-server: + return if !detect_devices::has_cpu_flag('pae'); + arch() =~ /i.86/ && detect_devices::isServer(); +} + +sub _bestKernel_extensions { my ($o_match_all_hardware) = @_; - $o_match_all_hardware ? (arch() =~ /i.86/ ? '-desktop586' : '-desktop') : - detect_devices::is_xbox() ? '-xbox' : - detect_devices::is_i586() ? '-desktop586' : - arch() =~ /i.86/ && detect_devices::dmi_detect_memory() > 3.8 * 1024 ? '-server' : + $::o->{kernel_extension} ? $::o->{kernel_extension} : + _is_kernelServer_needed() ? '-server' : '-desktop'; } sub bestKernelPackage { my ($packages, $o_match_all_hardware) = @_; - my @preferred_exts = bestKernel_extensions($o_match_all_hardware); + my @preferred_exts = _bestKernel_extensions($o_match_all_hardware); my @kernels = grep { $_ } map { packageByName($packages, "kernel$_-latest") } @preferred_exts; + if (!@kernels) { + #- fallback on most generic kernel if the suitable one is not available + my @fallback_exts = _bestKernel_extensions('force'); + @kernels = grep { $_ } map { packageByName($packages, "kernel$_-latest") } @fallback_exts; + } + log::l("bestKernelPackage (" . join(':', @preferred_exts) . "): " . join(' ', map { $_->name } @kernels) . (@kernels > 1 ? ' (choosing the first)' : '')); $kernels[0]; @@ -153,15 +185,16 @@ sub packagesToInstall { my ($packages) = @_; my @packages; foreach (@{$packages->{media}}) { - $_->{selected} or next; + !$_->{ignore} or next; log::l("examining packagesToInstall of medium $_->{name}"); push @packages, grep { $_->flag_selected } install::media::packagesOfMedium($packages, $_); } - log::l("found " . scalar(@packages) . " packages to install"); + log::l("found " . scalar(@packages) . " packages to install: " . formatList(5, map { scalar $_->fullname } @packages)); + @packages; } -sub packageRequest { +sub _packageRequest { my ($packages, $pkg) = @_; #- check if the same or better version is installed, @@ -170,7 +203,8 @@ sub packageRequest { #- check for medium selection, if the medium has not been #- selected, the package cannot be selected. - packageMedium($packages, $pkg)->{selected} or return; + my $medium = packageMedium($packages, $pkg); + $medium && !$medium->{ignore} or return; +{ $pkg->id => 1 }; } @@ -180,22 +214,22 @@ sub packageCallbackChoices { if ($prefered && @$prefered) { @$prefered; - } elsif (my @l = packageCallbackChoices_($urpm, $choices, $virtual_pkg_name)) { + } elsif (my @l = _packageCallbackChoices_($urpm, $choices, $virtual_pkg_name)) { @l; } else { - log::l("packageCallbackChoices: default choice from " . join(",", map { $_->name } @$choices) . " for $virtual_pkg_name"); + log::l("packageCallbackChoices: default choice ('" . $choices->[0]->name . "') from " . join(",", map { $_->name } @$choices) . " for $virtual_pkg_name"); $choices->[0]; } } -sub packageCallbackChoices_ { +sub _packageCallbackChoices_ { my ($urpm, $choices, $virtual_pkg_name) = @_; - my ($prefer, $_other) = urpm::select::get_preferred($urpm, $choices, ''); + my ($prefer, $_other) = urpm::select::get_preferred($urpm, $choices, $::o->{preferred_packages}); if (@$prefer) { @$prefer; } elsif ($virtual_pkg_name eq 'kernel') { - my $re = join('|', map { "kernel\Q$_-2" } bestKernel_extensions()); + my $re = join('|', map { "kernel\Q$_-2" } _bestKernel_extensions()); my @l = grep { $_->name =~ $re } @$choices; log::l("packageCallbackChoices: kernel chosen ", join(",", map { $_->name } @l), " in ", join(",", map { $_->name } @$choices)); @l; @@ -249,20 +283,27 @@ sub select_by_package_names_or_die { foreach (@$names) { my $p = packageByName($packages, $_) or die "package $_ not found"; !$p->flag_installed && !$p->flag_selected or next; - my ($_pkgs, $error) = selectPackage_with_error($packages, $p, $b_base); + my ($_pkgs, $error) = _selectPackage_with_error($packages, $p, $b_base); $error and die N("Some packages requested by %s cannot be installed:\n%s", $_, $error); } } -sub resolve_requested_and_check { +my @recommended_package_ids; +sub _resolve_requested_and_check { my ($packages, $state, $requested) = @_; my @l = $packages->resolve_requested($packages->{rpmdb}, $state, $requested, - callback_choices => \&packageCallbackChoices); + callback_choices => \&packageCallbackChoices, no_recommends => $::o->{no_recommends}); + + #- keep track of recommended packages so that theys could be unselected if the "no recommends" option is choosen later: + if (!is_empty_hash_ref($state->{selected})) { + my @new_ids = map { $packages->{depslist}[$_]->id } grep { $state->{selected}{$_}{recommended} } keys %{$state->{selected}}; + @recommended_package_ids = uniq(@recommended_package_ids, @new_ids); + } my $error; if (find { !exists $state->{selected}{$_} } keys %$requested) { - my @rejected = urpm::select::unselected_packages($packages, $state); + my @rejected = urpm::select::unselected_packages($state); $error = urpm::select::translate_why_unselected($packages, $state, @rejected); log::l("ERROR: selection failed: $error"); } @@ -272,18 +313,18 @@ sub resolve_requested_and_check { sub selectPackage { my ($packages, $pkg, $b_base) = @_; - my ($pkgs, $_error) = selectPackage_with_error($packages, $pkg, $b_base); + my ($pkgs, $_error) = _selectPackage_with_error($packages, $pkg, $b_base); @$pkgs; } -sub selectPackage_with_error { +sub _selectPackage_with_error { my ($packages, $pkg, $b_base) = @_; my $state = $packages->{state} ||= {}; $packages->{rpmdb} ||= rpmDbOpen(); - my ($pkgs, $error) = resolve_requested_and_check($packages, $state, packageRequest($packages, $pkg) || {}); + my ($pkgs, $error) = _resolve_requested_and_check($packages, $state, _packageRequest($packages, $pkg) || {}); if ($b_base) { $_->set_flag_base foreach @$pkgs; @@ -310,7 +351,13 @@ sub unselectAllPackages { my %keep_selected; log::l("unselecting all packages..."); foreach (@{$packages->{depslist}}) { - if ($_->flag_base || $_->flag_installed && $_->flag_selected) { + my $to_select = $_->flag_base || $_->flag_installed && $_->flag_selected; + # unselect recommended packages if minimal install: + if ($::o->{no_recommends} && member($_->id, @recommended_package_ids)) { + log::l("unselecting recommended package " . $_->name); + undef $to_select; + } + if ($to_select) { #- keep track of packages that should be kept selected. $keep_selected{$_->id} = $_; } else { @@ -321,20 +368,63 @@ sub unselectAllPackages { } #- clean state, in order to start with a brand new set... $packages->{state} = {}; - resolve_requested_and_check($packages, $packages->{state}, \%keep_selected); + _resolve_requested_and_check($packages, $packages->{state}, \%keep_selected); +} + + +my (@errors, $push_errors); +sub start_pushing_error() { + $push_errors = 1; + undef @errors; +} + +sub popup_errors() { + if (@errors) { + $::o->ask_warn(undef, N("An error occurred:") . "\n\n" . join("\n", @errors)); + } + undef $push_errors; } sub empty_packages { my ($o_keep_unrequested_dependencies) = @_; - my $packages = new URPM; + my $packages = urpm->new; + urpm::get_global_options($packages); + urpm::set_files($packages, '/mnt'); #- add additional fields used by DrakX. - @$packages{qw(count media)} = (0, []); + $packages->{media} = []; + urpm::args::set_debug($packages) if $::o->{debug_urpmi}; $packages->{log} = \&log::l; + $packages->{info} = \&log::l; + $packages->{fatal} = sub { + log::l("urpmi error: $_[1] ($_[0])\n" . common::backtrace()); + $::o->ask_warn(undef, N("A fatal error occurred: %s.", "$_[1] ($_[0])")); + }; + $packages->{error} = sub { + log::l("urpmi error: $_[0]"); + if ($push_errors) { + push @errors, @_; + return; + } + $::o->ask_warn(undef, N("An error occurred:") . "\n\n" . $_[0]); + }; + $packages->{root} = $::prefix; $packages->{prefer_vendor_list} = '/etc/urpmi/prefer.vendor.list'; $packages->{keep_unrequested_dependencies} = defined($o_keep_unrequested_dependencies) ? $o_keep_unrequested_dependencies : 1; + $urpm::args::options{justdb} = $::o->{justdb}; + urpm::set_tune_rpm($packages, $::o->{'tune-rpm'}) if $::o->{'tune-rpm'}; + $::force = 1; + $packages->{options}{ignoresize} = 1; + $packages->{options}{retry} = 3; + $packages->{options}{downloader} = $::o->{options}{downloader}; + # prevent priority upgrade (redundant for now as $urpm->{root} implies disabling it: + $packages->{options}{'priority-upgrade'} = undef; + # log $trans->add() faillure; FIXME: should we override *urpm::msg::sys_log? + $packages->{debug} = $packages->{debug_URPM} = \&log::l; + $urpm::args::options{deploops} = $::o->{deploops}; + $packages->{options}{'curl-options'} = $::o->{curl_options} if $::o->{curl_options}; $packages; } @@ -342,7 +432,7 @@ sub empty_packages { sub readCompssUsers { my ($file) = @_; - my $f = common::open_file($file) or log::l("can not find $file: $!"), return; + my $f = common::open_file($file) or log::l("cannot find $file: $!"), return; my ($compssUsers, $gtk_display_compssUsers) = eval join('', <$f>); if ($@) { log::l("ERROR: bad $file: $@"); @@ -373,32 +463,41 @@ sub setSelectedFromCompssList { my ($packages, $rpmsrate_flags_chosen, $min_level, $max_size) = @_; $rpmsrate_flags_chosen->{TRUE} = 1; #- ensure TRUE is set my $nb = selectedSize($packages); - foreach my $p (sort { $b->rate <=> $a->rate } @{$packages->{depslist}}) { + + my %pkgs; + foreach my $p (@{$packages->{depslist}}) { my @flags = $p->rflags; - next if + next if !$p->rate || $p->rate < $min_level || - any { !any { /^!(.*)/ ? !$rpmsrate_flags_chosen->{$1} : $rpmsrate_flags_chosen->{$_} } split('\|\|') } @flags; - - #- determine the packages that will be selected when - #- selecting $p. the packages are not selected. + any { !any { /^!(.*)/ ? !$rpmsrate_flags_chosen->{$1} : $rpmsrate_flags_chosen->{$_} } split('\|\|') } @flags; + $pkgs{$p->rate} ||= {}; + $pkgs{$p->rate}{$p->id} = 1 if _packageRequest($packages, $p); + } + my %pkgswanted; + foreach my $level (sort { $b <=> $a } keys %pkgs) { + #- determine the packages that will be selected + #- the packages are not selected. my $state = $packages->{state} ||= {}; - - my ($l, $_error) = resolve_requested_and_check($packages, $state, packageRequest($packages, $p) || {}); - + foreach my $p (keys %{$pkgs{$level}}) { + $pkgswanted{$p} = 1; + } + my ($l, $_error) = _resolve_requested_and_check($packages, $state, \%pkgswanted); + #- this enable an incremental total size. my $old_nb = $nb; foreach (@$l) { $nb += $_->size; } if ($max_size && $nb > $max_size) { + log::l("disabling selected packages because too big for level $level: $nb > $max_size"); $nb = $old_nb; - $min_level = $p->rate; + $min_level = $level; $packages->disable_selected($packages->{rpmdb}, $state, @$l); last; } } my @flags = map_each { if_($::b, $::a) } %$rpmsrate_flags_chosen; - log::l("setSelectedFromCompssList: reached size ", int($nb /1024/1024), "MB, up to indice $min_level (less than ", formatXiB($max_size), ") for flags ", join(' ', sort @flags)); + log::l("setSelectedFromCompssList: reached size ", int($nb / 1024/1024), "MB, up to indice $min_level (less than ", formatXiB($max_size), ") for flags ", join(' ', sort @flags)); log::l("setSelectedFromCompssList: ", join(" ", sort map { $_->name } grep { $_->flag_selected } @{$packages->{depslist}})); $min_level; } @@ -408,7 +507,7 @@ sub setSelectedFromCompssList { sub saveSelected { my ($packages) = @_; my $state = delete $packages->{state}; - my @l = @{$packages->{depslist}}; + my @l = @{$packages->{depslist} || []}; my @flags = map { ($_->flag_requested && 1) + ($_->flag_required && 2) + ($_->flag_upgrade && 4) } @l; [ $packages, $state, \@l, \@flags ]; } @@ -422,52 +521,54 @@ sub restoreSelected { } $l, $flags; } -sub computeGroupSize { - my ($packages, $min_level) = @_; - - sub inside { - my ($l1, $l2) = @_; - my $i = 0; - return if @$l1 > @$l2; - foreach (@$l1) { - my $c; - while ($c = $l2->[$i++] cmp $_) { - return if $c == 1 || $i > @$l2; - } - } - 1; +sub _inside { + my ($l1, $l2) = @_; + my $i = 0; + return if @$l1 > @$l2; + foreach (@$l1) { + my $c; + while ($c = $l2->[$i++] cmp $_) { + return if $c == 1 || $i > @$l2; + } } + 1; +} - sub or_ify { - my ($first, @other) = @_; - my @l = split('\|\|', $first); - foreach (@other) { - @l = map { - my $n = $_; - map { "$_&&$n" } @l; - } split('\|\|'); - } - @l; +sub _or_ify { + my ($first, @other) = @_; + my @l = split('\|\|', $first); + foreach (@other) { + @l = map { + my $n = $_; + map { "$_&&$n" } @l; + } split('\|\|'); + } + @l; +} +sub _or_clean { + my ($flags) = @_; + my @l = split("\t", $flags); + @l = map { [ sort split('&&') ] } @l; + my @r; + B: while (@l) { + my $e = shift @l; + foreach (@r, @l) { + _inside($_, $e) and next B; + } + push @r, $e; } + join("\t", map { join('&&', @$_) } @r); +} + + +sub computeGroupSize { + my ($packages, $min_level) = @_; + my (%group, %memo); + my %or_ify_cache; my $or_ify_cached = sub { - $or_ify_cache{$_[0]} ||= join("\t", or_ify(split("\t", $_[0]))); + $or_ify_cache{$_[0]} ||= join("\t", _or_ify(split("\t", $_[0]))); }; - sub or_clean { - my ($flags) = @_; - my @l = split("\t", $flags); - @l = map { [ sort split('&&') ] } @l; - my @r; - B: while (@l) { - my $e = shift @l; - foreach (@r, @l) { - inside($_, $e) and next B; - } - push @r, $e; - } - join("\t", map { join('&&', @$_) } @r); - } - my (%group, %memo); log::l("install::pkgs::computeGroupSize"); my $time = time(); @@ -497,7 +598,7 @@ sub computeGroupSize { $newSelection{$id} = undef; my $pkg = $packages->{depslist}[$id]; - my @deps = map { [ $_, keys %{$packages->{provides}{$_} || {}} ] } $pkg->requires_nosense, $pkg->suggests; + my @deps = map { [ $_, keys %{$packages->{provides}{$_} || {}} ] } $pkg->requires_nosense, $pkg->recommends_nosense; foreach (sort { @$a <=> @$b } @deps) { #- sort on number of provides (it helps choosing "b" in: "a" requires both "b" and virtual={"b","c"}) my ($virtual, @choices) = @$_; if (@choices <= 1) { @@ -509,7 +610,7 @@ sub computeGroupSize { if (find { $_->flag_available } @choices_pkgs) { @choices = (); #- one package is already selected (?) } else { - @choices = map { $_->id } packageCallbackChoices($packages, undef, undef, \@choices_pkgs, $virtual); + @choices = map { $_->id } packageCallbackChoices($packages, undef, undef, \@choices_pkgs, $virtual, undef); } } push @l2, @choices; @@ -521,7 +622,7 @@ sub computeGroupSize { next if $p->flag_selected; #- always installed (accounted in system_size) my $s = $group{$p->name} || $or_ify_cached->(join("\t", $p->rflags)); my $m = "$flags\t$s"; - $group{$p->name} = ($memo{$m} ||= or_clean($m)); + $group{$p->name} = ($memo{$m} ||= _or_clean($m)); } } my (%sizes, %pkgs); @@ -536,7 +637,7 @@ sub computeGroupSize { } -sub openInstallLog() { +sub _openInstallLog() { my $f = "$::prefix/root/drakx/install.log"; open(my $LOG, ">> $f") ? log::l("opened $f") : log::l("Failed to open $f. No install log will be kept."); #-# CORE::select((CORE::select($LOG), $| = 1)[0]); @@ -544,33 +645,35 @@ sub openInstallLog() { $LOG; } -sub rpmDbOpen { - my ($b_rebuild_if_needed, $o_rpm_dbapi) = @_; +sub _rebuild_RPM_DB() { + if (my $pid = fork()) { + waitpid $pid, 0; + $? & 0xff00 and die "rebuilding of rpm database failed"; + } else { + log::l("rebuilding rpm database"); + my $rebuilddb_dir = "$::prefix/var/lib/rpmrebuilddb.$$"; + if (-d $rebuilddb_dir) { + log::l("removing stale directory $rebuilddb_dir"); + rm_rf($rebuilddb_dir); + } - clean_rpmdb_shared_regions(); - - if (my $wanted_dbapi = $o_rpm_dbapi) { - log::l("setting %_dbapi to $wanted_dbapi"); - substInFile { s/%_dbapi.*//; $_ .= "%_dbapi $wanted_dbapi\n" if eof } "$::prefix/etc/rpm/macros"; - URPM::add_macro("_dbapi $wanted_dbapi"); + if (!URPM::DB::rebuild($::prefix)) { + log::l("rebuilding of rpm database failed: " . URPM::rpmErrorString()); + c::_exit(2); + } + + c::_exit(0); } +} - my $need_rebuild = $b_rebuild_if_needed && !URPM::DB::verify($::prefix); +sub rpmDbOpen { + my ($b_rebuild_if_needed) = @_; - if ($need_rebuild && !$o_rpm_dbapi) { - if (my $pid = fork()) { - waitpid $pid, 0; - $? & 0xff00 and die "rebuilding of rpm database failed"; - } else { - log::l("rebuilding rpm database"); - my $rebuilddb_dir = "$::prefix/var/lib/rpmrebuilddb.$$"; - -d $rebuilddb_dir and log::l("removing stale directory $rebuilddb_dir"), rm_rf($rebuilddb_dir); + clean_rpmdb_shared_regions(); - URPM::DB::rebuild($::prefix) or log::l("rebuilding of rpm database failed: " . URPM::rpmErrorString()), c::_exit(2); + my $need_rebuild = $b_rebuild_if_needed && !URPM::DB::verify($::prefix); - c::_exit(0); - } - } + _rebuild_RPM_DB() if $need_rebuild; my $db; if ($db = URPM::DB::open($::prefix)) { @@ -624,6 +727,7 @@ sub selectPackagesAlreadyInstalled { my %sizes; $packages->{rpmdb}->traverse(sub { my ($p) = @_; + $sizes{$p->name} ||= 0; $sizes{$p->name} += $p->size; }); $packages->{sizes} = \%sizes; @@ -645,89 +749,25 @@ sub selectPackagesToUpgrade { log::l("selected pkgs to upgrade: " . join(' ', map { $packages->{depslist}[$_]->name } keys %selection)); log::l("resolving dependencies..."); - resolve_requested_and_check($packages, $state, \%selection); + _resolve_requested_and_check($packages, $state, \%selection); log::l("...done"); log::l("finally selected pkgs: ", join(" ", sort map { $_->name } grep { $_->flag_selected } @{$packages->{depslist}})); } -sub installTransactionClosure { - my ($packages, $id2pkg, $isUpgrade) = @_; - - foreach (grep { !$_->{selected} } @{$packages->{media}}) { - foreach ($_->{start} .. $_->{end}) { - delete $id2pkg->{$_}; - } - } - - my @l = ikeys %$id2pkg; - my $medium; - - #- search first usable medium (media are sorted). - foreach (@{$packages->{media}}) { - if ($l[0] <= $_->{end}) { - #- we have a candidate medium, it could be the right one containing - #- the first package of @l... - $l[0] >= $_->{start} and $medium = $_, last; - #- ... but it could be necessary to find the first - #- medium containing package of @l. - foreach my $id (@l) { - $id >= $_->{start} && $id <= $_->{end} and $medium = $_, last; - } - $medium and last; - } - } - $medium or return (); #- no more medium usable -> end of installation by returning empty list. - - #- it is sure at least one package will be installed according to medium chosen. - { - my $pkg = $packages->{depslist}[$l[0]]; - my $rpm = install::media::rel_rpm_file($medium, $pkg->filename); - if ($install::media::postinstall_rpms && -e "$install::media::postinstall_rpms/$rpm") { - #- very special case where the rpm has been copied on disk - } elsif (!install::media::change_phys_medium($medium->{phys_medium}, $rpm, $packages)) { - #- keep in mind the asked medium has been refused. - #- this means it is no longer selected. - #- (but do not unselect supplementary CDs.) - $medium->{selected} = 0; - } - } - - if (my $p = packageByName($packages, 'mdv-rpm-summary')) { - #- if it is selected, make it the first package - exists $id2pkg->{$p->id} and unshift @l, $p->id; - } - - my %closure; - foreach my $id (@l) { - my @l2 = $id; - - if ($isUpgrade && $id < 20) { - #- HACK for upgrading to 2006.0: for the 20 first main packages, upgrade one by one - #- why? well: - #- * librpm is fucked up when ordering pkgs, pkg "setup" is removed before being installed. - #- the result is /etc/group.rpmsave and no /etc/group - #- * pkg locales requires basesystem, this is stupid, the result is a huge first transaction - #- and it doesn't even help /usr/bin/locale_install.sh since it's not a requires(post) - $closure{$id} = undef; - last; - } - - while (defined($id = shift @l2)) { - exists $closure{$id} and next; - $closure{$id} = undef; - - my $pkg = $packages->{depslist}[$id]; - foreach ($pkg->requires_nosense) { - if (my $dep_id = find { $id2pkg->{$_} } keys %{$packages->{provides}{$_} || {}}) { - push @l2, $dep_id; - } - } - } - - keys %closure >= $limitMinTrans and last; - } - - map { delete $id2pkg->{$_} } grep { $id2pkg->{$_} } ikeys %closure; +sub _filter_packages { + my ($retry, $packages, @packages) = @_; + grep { + if ($_->flag_installed || packageMedium($packages, $_)->{ignore}) { + if ($_->name eq 'mga-rpm-summary' && $_->flag_installed) { + install::pkgs::setup_rpm_summary_translations(); + } + $_->free_header; + 0; + } else { + log::l("failed to install " . $_->fullname . " (will retry)") if !$retry; + 1; + } + } @packages; } sub install { @@ -744,168 +784,180 @@ sub install { my $loop_boot = fs::loopback::prepare_boot(); #- first stage to extract some important information - #- about the selected packages. This is used to select - #- one or many transactions. - my ($total, $nb); + #- about the selected packages. + my ($total, $nb) = (0, 0); foreach my $pkg (@$toInstall) { $packages{$pkg->id} = $pkg; $nb++; - $total += to_int($pkg->size); #- do not correct for upgrade! + $total += $pkg->size; #- do not correct for upgrade! } log::l("install::pkgs::install $::prefix"); log::l("install::pkgs::install the following: ", join(" ", map { $_->name } values %packages)); URPM::read_config_files(); - URPM::add_macro(join(' ', '__dbi_cdb', URPM::expand('%__dbi_cdb'), 'nofsync')); - my $LOG = openInstallLog(); + # force loading libnss* + getgrent(); + URPM::add_macro(join(' ', '__dbi_other', URPM::expand('%__dbi_other'), 'nofsync')); + my $LOG = _openInstallLog(); + + $packages->{log} = $packages->{info} = $packages->{print} = sub { + print $LOG "$_[0]\n"; + }; #- 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,...). $callback->($packages, user => undef, install => $nb, $total); - do { - my @transToInstall = installTransactionClosure($packages, \%packages, $isUpgrade); - $nb = values %packages; - - #- added to exit typically after last media unselected. - if ($nb == 0 && scalar(@transToInstall) == 0) { - cleanHeaders(); - - fs::loopback::save_boot($loop_boot); - return; - } - - #- extract headers for parent as they are used by callback. - extractHeaders(\@transToInstall, $packages->{media}); - - my ($retry, $retry_count); - while (@transToInstall) { - my $retry_pkg = $retry && $transToInstall[0]; - - if ($retry) { - log::l("retrying installing package " . $retry_pkg->fullname . " alone in a transaction ($retry_count)"); - } - _install_raw($packages, [ $retry ? $retry_pkg : @transToInstall ], - $isUpgrade, $callback, $LOG, $retry_pkg); - - @transToInstall = grep { - if ($_->flag_installed || !packageMedium($packages, $_)->{selected}) { - if ($_->name eq 'mdv-rpm-summary' && $_->flag_installed) { - install::pkgs::setup_rpm_summary_translations(); - } - $_->free_header; - 0; - } else { - log::l("failed to install " . $_->fullname . " (will retry)") if !$retry; - 1; - } - } @transToInstall; - - if (@transToInstall) { - if (!$retry || $retry_pkg != $transToInstall[0]) { - #- go to next - $retry_count = 1; - } elsif ($retry_pkg == $transToInstall[0] && $retry_count < 3) { - $retry_count++; - } else { - log::l("failed to install " . $retry_pkg->fullname); - - my $medium = packageMedium($packages, $retry_pkg); - my $name = $retry_pkg->fullname; - my $rc = cdie("error installing package list: $name $medium->{name}"); - if ($rc eq 'retry') { - $retry_count = 1; - } else { - if ($rc eq 'disable_media') { - $medium->{selected} = 0; - } - $retry_pkg->set_flag_requested(0); - $retry_pkg->set_flag_required(0); - - #- dropping it - $retry_pkg->free_header; - shift @transToInstall; - $retry_count = 1; - } - } - $retry = 1; - } - } - log::l("progression: $nb remaining packages to install"); - cleanHeaders(); - } while $nb > 0 && !$install::pkgs::cancel_install; + my $exit_code = _install_raw($packages, $isUpgrade, $callback, $LOG, 0); log::l("closing install.log file"); close $LOG; - cleanHeaders(); + # prevent urpmi from trying to install them again (CHECKME: maybe uneeded): + $packages->{state} = {}; + clean_rpmdb_shared_regions(); #- workaround librpm which is buggy when using librpm rooted and the just installed rooted library fs::loopback::save_boot($loop_boot); + + $exit_code; +} + +sub _unselect_package { + my ($packages, $pkg) = @_; + #- update flag associated to package. + $pkg->set_flag_installed(1); + $pkg->set_flag_upgrade(0); + #- update obsoleted entry. + my $rejected = $packages->{state}{rejected}; + foreach (keys %$rejected) { + if (delete $rejected->{$_}{closure}{$pkg->fullname}) { + %{$rejected->{$_}{closure}} or delete $rejected->{$_}; + } + } +} + +sub is_package_installed { + my ($db, $pkg) = @_; + my $check_installed; + $db->traverse_tag('name', [ $pkg->name ], sub { + my ($p) = @_; + $check_installed ||= $pkg->compare_pkg($p) == 0; + }); + return $check_installed; } sub _install_raw { - my ($packages, $transToInstall, $isUpgrade, $callback, $LOG, $noscripts) = @_; - - my $close = sub { - my ($pkg) = @_; - #- update flag associated to package. - $pkg->set_flag_installed(1); - $pkg->set_flag_upgrade(0); - #- update obsoleted entry. - my $rejected = $packages->{state}{rejected}; - foreach (keys %$rejected) { - if (delete $rejected->{$_}{closure}{$pkg->fullname}) { - %{$rejected->{$_}{closure}} or delete $rejected->{$_}; - } - } - }; + my ($packages, $_isUpgrade, $callback, $LOG, $noscripts) = @_; - my $db = open_rpm_db_rw() or die "error opening RPM database: ", URPM::rpmErrorString(); - my $trans = $db->create_transaction($::prefix); + # prevent warnings in install's logs: + local $ENV{LC_ALL} = 'C'; - log::l("opened rpm database for transaction of " . int(@$transToInstall) . " packages (isUpgrade=$isUpgrade)"); - foreach (@$transToInstall) { - $trans->add($_, update => $isUpgrade ? 1 : 0) - or log::l("add failed for " . $_->fullname); - } + # let's be urpmi's compatible: + local $packages->{options}{noscripts} = $noscripts; + # leaks a fd per transaction (around ~100 for a typically gnome install, see #49097): + # bug present in 2009.0, 2008.1, 2008.0, ... (probably since r11141 aka when switching to rpm-4.2 in URPM-0.83) + local $packages->{options}{script_fd} = fileno $LOG; - my @checks = $trans->check; @checks and log::l("check failed : " . join("\n ", @checks)); - $trans->order or die "error ordering package list: " . URPM::rpmErrorString(); - $trans->set_script_fd(fileno $LOG); + start_pushing_error(); log::l("rpm transactions start"); - my $fd; #- since we return the "fileno", perl does not know we're still using it, and so closes it, and :-( - my @probs = $trans->run($packages, force => 1, nosize => 1, - if_($noscripts, noscripts => 1), - callback_open => sub { - my ($packages, $_type, $id) = @_; - &$callback; - my $pkg = defined $id && $packages->{depslist}[$id]; - my $medium = packageMedium($packages, $pkg); - my $f = $pkg && install::media::rel_rpm_file($medium, $pkg->filename); - print $LOG "$f\n"; - undef $fd; - $fd = getFile_($medium->{phys_medium}, $f); - $fd ? fileno $fd : -1; - }, callback_close => sub { - my ($packages, $_type, $id) = @_; + + my ($is_installing, $verify_just_closed); + my $exit_code = urpm::main_loop::run($packages, $packages->{state}, undef, undef, { + open_helper => sub { + &$callback; + $is_installing = 0; + }, + verify => $callback, + close_helper => sub { + my ($db, $packages, $_type, $id) = @_; &$callback; + return if !$is_installing; # don't check if it's installed if it's being verified my $pkg = defined $id && $packages->{depslist}[$id] or return; - my $check_installed; - $db->traverse_tag('name', [ $pkg->name ], sub { - my ($p) = @_; - $check_installed ||= $pkg->compare_pkg($p) == 0; - }); - $check_installed or log::l($pkg->name . " not installed, " . URPM::rpmErrorString()); - $check_installed and $close->($pkg); - }, callback_inst => $callback, - ); - log::l("transactions done, now trying to close still opened fd"); - - @probs and die "installation of rpms failed:\n ", join("\n ", @probs); + print $LOG $pkg->fullname . "\n"; + my $check_installed = is_package_installed($db, $pkg); + if ($pkg->name eq 'mga-rpm-summary' && $check_installed) { + install::pkgs::setup_rpm_summary_translations(); + } + + if ($check_installed) { + _unselect_package($packages, $pkg); + } else { + log::l($pkg->name . " not installed, " . URPM::rpmErrorString()); + } + }, + inst => sub { + &$callback; + $is_installing = 1; + }, + trans => $callback, + # FIXME: implement already_installed_or_not_installable + bad_signature => sub { + my ($msg, $msg2) = @_; + $msg =~ s/:$/\n\n/m; # FIXME: to be fixed in urpmi after 2008.0 (sic!) + log::l($msg); + log::l($msg2); + return 0 if $packages->{options}{auto}; + state $do_not_ask; + state $answer; + return $answer if $do_not_ask; + $answer = $::o->ask_from_({ messages => "$msg\n\n$msg2" }, [ + { val => \$do_not_ask, + type => 'bool', text => N("Do not ask again"), + }, + ]); + }, + copy_removable => sub { + my ($medium) = @_; + $::o->ask_change_cd($medium); + }, + is_canceled => sub { + return $install::pkgs::cancel_install; + }, + trans_error_summary => sub { + my ($nok, $errors) = @_; + log::l($nok . " installation transactions failed"); + log::l(join("\n", @$errors)); + if (!$packages->{options}{auto}) { + $::o->ask_warn(N("Error"), N("%d installation transactions failed", $nok) . "\n\n" . + N("Installation of packages failed:") . "\n\n" . join("\n", @$errors)); + } + }, + completed => sub { + if (!$packages->{options}{auto}) { + popup_errors(); + } + }, + message => sub { + my ($title, $message) = @_; + log::l($message); + $::o->ask_warn($title, $message); + }, + ask_yes_or_no => sub { + my ($title, $msg) = @_; + log::l($msg); + $::o->ask_yesorno($title, $msg); + }, + ask_for_bad_or_missing => sub { + my ($_title, $msg) = @_; + log::l($msg); + state $do_not_ask; + state $answer; + return $answer if $do_not_ask; + $answer = $::o->ask_from_({ messages => $msg }, [ + { val => \$do_not_ask, type => 'bool', text => N("Do not ask again"), + }, + ]); + }, + # Uneeded callbacks: success_summary + }); + + log::l("transactions done, now trying to close still opened fd; exit code=$exit_code"); + + $exit_code; } sub upgrade_by_removing_pkgs { @@ -938,7 +990,7 @@ sub upgrade_by_removing_pkgs { } } - my @was_installed = remove_pkgs_to_upgrade($packages, $callback, $extension); + my @was_installed = _remove_pkgs_to_upgrade($packages, $callback, $extension); { my @restore_files = qw(/etc/passwd /etc/group /etc/ld.so.conf); @@ -970,7 +1022,7 @@ sub upgrade_by_removing_pkgs { sub removed_pkgs_to_upgrade_file() { "$::prefix/root/drakx/removed_pkgs_to_upgrade" } -sub remove_pkgs_to_upgrade { +sub _remove_pkgs_to_upgrade { my ($packages, $callback, $extension) = @_; my @to_remove; @@ -995,7 +1047,7 @@ sub remove_pkgs_to_upgrade { delete $packages->{rpmdb}; #- make sure rpmdb is closed before. - remove(\@to_remove, $callback, noscripts => 1); + _remove(\@to_remove, $callback, noscripts => 1); @was_installed; } @@ -1010,21 +1062,21 @@ sub remove_marked_ask_remove { #- we are not checking depends since it should come when #- upgrading a system. although we may remove some functionalities ? - remove(\@to_remove, $callback, force => 1); + _remove(\@to_remove, $callback, force => 1); delete $packages->{state}{ask_remove}{$_} foreach @to_remove; } -sub remove_raw { +sub _remove_raw { my ($to_remove, $callback, %run_transaction_options) = @_; log::l("removing: " . join(' ', @$to_remove)); URPM::read_config_files(); - URPM::add_macro(URPM::expand('__dbi_cdb %__dbi_cdb nofsync')); + URPM::add_macro(URPM::expand('__dbi_other %__dbi_other nofsync')); my $db = open_rpm_db_rw() or die "error opening RPM database: ", URPM::rpmErrorString(); - my $trans = $db->create_transaction($::prefix); + my $trans = $db->create_transaction; #- stuff remove all packages that matches $p, not a problem since $p has name-version-release format. $trans->remove($_) foreach @$to_remove; @@ -1033,20 +1085,20 @@ sub remove_raw { $trans->run(undef, %run_transaction_options, callback_uninst => $callback); } -sub remove { +sub _remove { my ($_to_remove, $_callback, %run_transaction_options) = @_; - my @pbs = &remove_raw; + my @pbs = &_remove_raw; if (@pbs && !$run_transaction_options{noscripts}) { $run_transaction_options{noscripts} = 1; - @pbs = &remove_raw; + @pbs = &_remove_raw; } if (@pbs) { die "removing of old rpms failed:\n ", join("\n ", @pbs); } } -sub setup_rpm_summary_translations { +sub setup_rpm_summary_translations() { my @domains = qw(rpm-summary-contrib rpm-summary-devel rpm-summary-main); push @::textdomains, @domains; foreach (@domains) { @@ -1077,111 +1129,4 @@ sub selected_leaves { [ map { $_->name } grep { ! exists $required_ids{$_->id} } @l ]; } -sub naughtyServers_list { - my ($quiet) = @_; - - my @_old_81 = qw( -freeswan -); - my @_old_82 = qw( -vnc-server -postgresql-server -); - - my @_old_92 = qw( -postfix ypbind bind ibod -); - - my @_removed_92 = qw( -mcserv -samba -lpr -); - - my @_moved_to_contrib_92 = qw( -boa -LPRng -wu-ftpd -am-utils -); - - my @new_80 = qw( -jabber -am-utils -boa -cups -drakxtools-http -finger-server -imap -leafnode -ntp -openssh-server -pidentd -proftpd -rwall -squid -webmin -wu-ftpd -); - - my @new_81 = qw( -ftp-server-krb5 -telnet-server-krb5 -ypserv -); - - my @new_82 = qw( -LPRng -inn -netatalk -nfs-utils -rusers-server -samba-swat -tftp-server -ucd-snmp -); - - my @new_92 = qw( -clusternfs -gkrellm-server -mon -net-snmp -openldap-servers -samba-server -saned -vsftpd -); - - my @new_2006 = qw( -apache-conf -bpalogin -cfengine-cfservd -freeradius -mDNSResponder -openslp -pxe -routed -sendmail -spamassassin-spamd -); - - my @not_warned = qw( -lisa -nfs-utils-clients -portmap -howl -); # X server - - (@new_80, @new_81, @new_82, @new_92, @new_2006, if_(!$quiet, @not_warned)); -} - -sub naughtyServers { - my ($packages) = @_; - - grep { - my $p = packageByName($packages, $_); - $p && $p->flag_selected; - } naughtyServers_list('quiet'); -} - 1; |