package do_pkgs; # $Id: do_pkgs.pm 263860 2009-11-30 15:20:14Z blino $ =head1 SYNOPSYS B enables to install packages (through urpmi) from our tools. It works both during installer and in standalone tools. =head1 Functions =over =cut =item do_pkgs($in) Returns a new B object from a L object. =cut sub do_pkgs { my ($in) = @_; ($::isInstall ? 'do_pkgs_during_install' : 'do_pkgs_standalone')->new($in); } ################################################################################ package do_pkgs_common; use common; =item ensure_is_installed($do, $pkg, $o_file, $b_auto) Makes sure that the $pkg package is installed. If $o_file is provided, the already installed check is I faster. If $b_auto is set, (g)urpmi will not ask any questions. =cut sub ensure_is_installed { my ($do, $pkg, $o_file, $b_auto) = @_; if ($o_file ? -e "$::prefix$o_file" : $do->is_installed($pkg)) { return 1; } $do->in->ask_okcancel(N("Warning"), N("The package %s needs to be installed. Do you want to install it?", $pkg), 1) or return if !$b_auto && $do->in; if (!$do->install($pkg)) { $do->in->ask_warn(N("Error"), N("Could not install the %s package!", $pkg)) if $do->in; return; } if ($o_file && ! -e "$::prefix$o_file") { $do->in->ask_warn(N("Error"), N("Mandatory package %s is missing", $pkg)) if $do->in; return; } 1; } =item ensure_are_installed($do, $pkgs, $b_auto) Makes sure that the packages listed in $pkgs array ref are installed. If $b_auto is set, (g)urpmi will not ask any questions. It's quite costly, so it's better to use the B instead. =cut sub ensure_are_installed { my ($do, $pkgs, $b_auto) = @_; my @not_installed = difference2($pkgs, [ $do->are_installed(@$pkgs) ]) or return 1; $do->in->ask_okcancel(N("Warning"), N("The following packages need to be installed:\n") . join(', ', @not_installed), 1) or return if !$b_auto && $do->in; if (!$do->install(@not_installed)) { if ($do->in) { $do->in->ask_warn(N("Error"), N("Could not install the %s package!", $not_installed[0])); } else { log::l("Could not install packages: " . join(' ', @not_installed)); } return; } 1; } =item ensure_binary_is_installed($do, $pkg, $binary, $b_auto) Makes sure that the $pkg package is installed. $binary is looked for in $PATH. If not found, the package is installed. If $b_auto is set, (g)urpmi will not ask any questions. =cut sub ensure_binary_is_installed { my ($do, $pkg, $binary, $b_auto) = @_; if (!whereis_binary($binary, $::prefix)) { $do->in->ask_okcancel(N("Warning"), N("The package %s needs to be installed. Do you want to install it?", $pkg), 1) or return if !$b_auto && $do->in; if (!$do->install($pkg)) { $do->in->ask_warn(N("Error"), N("Could not install the %s package!", $pkg)) if $do->in; return; } } if (!whereis_binary($binary, $::prefix)) { $do->in->ask_warn(N("Error"), N("Mandatory package %s is missing", $pkg)) if $do->in; return; } 1; } =item ensure_files_are_installed($do, $pkgs, $b_auto) Takes a list of [ "package", "file" ] and installs package if file is not there. If $b_auto is set, (g)urpmi will not ask any questions. =cut sub ensure_files_are_installed { my ($do, $pkgs, $b_auto) = @_; my @not_installed = map { my ($package, $file) = @$_; if_(!whereis_binary($file, $::prefix), $package) } @$pkgs; return 1 if !@not_installed; $do->in->ask_okcancel(N("Warning"), N("The following packages need to be installed:\n") . join(', ', @not_installed), 1) or return if !$b_auto && $do->in; if (!$do->install(@not_installed)) { if ($do->in) { $do->in->ask_warn(N("Error"), N("Could not install the %s package!", $not_installed[0])); } else { log::l("Could not install packages: " . join(' ', @not_installed)); } return; } 1; } =item ensure_is_installed_if_available($do, $pkg, $file) = @_; Install $pkg if $file is not present and if $pkg is actually known to urpmi. =cut sub ensure_is_installed_if_available { my ($do, $pkg, $file) = @_; if (-e "$::prefix$file" || $::testing) { 1; } else { $do->what_provides($pkg) && $do->install($pkg); } } =item is_available($do, $name) =item are_available($do, @names) Returns name(s) of package(s) that are available (aka known to urpmi). This is somewhat costly (needs to parse urpmi synthesis...) =cut sub is_available { my ($do, $name) = @_; $do->are_available($name); } =item is_installed($do, $name) =item are_installed($do, @names) Returns name(s) of package(s) that are already installed on the system. This is less costly (needs to query rpmdb) =cut sub is_installed { my ($do, $name) = @_; $do->are_installed($name); } =item check_kernel_module_packages($do, $base_name) Takes something like "C" and returns: =over 4 =item * the various C available for the installed kernels =item * C if available =back =cut sub check_kernel_module_packages { my ($do, $base_name) = @_; require bootloader; my @test_rpms = ( 'dkms-' . $base_name, map { $base_name . '-kernel-' . bootloader::vmlinuz2version($_) } bootloader::installed_vmlinuz() ); my @rpms = $do->are_available(@test_rpms); @rpms = $do->are_installed(@test_rpms) if !@rpms; @rpms or return; log::l("those kernel module packages can be installed: " . join(' ', @rpms)); \@rpms; } ################################################################################ package do_pkgs_during_install; use run_program; use common; our @ISA = qw(do_pkgs_common); =item new($type, $in) Returns a C object. =cut sub new { my ($type, $in) = @_; $in->isa('interactive') or undef $in; require install::pkgs; bless { in => $in, o => $::o }, $type; } sub in { my ($do) = @_; $do->{in}; } sub install { my ($do, @l) = @_; log::l("do_pkgs_during_install::install"); if ($::testing) { log::l("i would install packages " . join(' ', @l)); 1; } else { $do->{o}->pkg_install(@l); 1; #- HACK, need better fix in install::steps::pkg_install() } } sub what_provides { my ($do, $name) = @_; map { $_->name } install::pkgs::packagesProviding($do->{o}{packages}, $name); } sub are_available { my ($do, @pkgs) = @_; grep { install::pkgs::packageByName($do->{o}{packages}, $_) } @pkgs; } sub are_installed { my ($do, @l) = @_; grep { my $p = install::pkgs::packageByName($do->{o}{packages}, $_); $p && $p->flag_available; } @l; } sub remove { my ($do, @l) = @_; @l = grep { my $p = install::pkgs::packageByName($do->{o}{packages}, $_); install::pkgs::unselectPackage($do->{o}{packages}, $p) if $p; $p; } @l; run_program::rooted($::prefix, 'rpm', '-e', @l); } sub remove_nodeps { my ($do, @l) = @_; @l = grep { my $p = install::pkgs::packageByName($do->{o}{packages}, $_); if ($p) { $p->set_flag_requested(0); $p->set_flag_required(0); } $p; } @l; run_program::rooted($::prefix, 'rpm', '-e', '--nodeps', @l); } ################################################################################ package do_pkgs_standalone; use run_program; use common; use log; use feature qw(state); our @ISA = qw(do_pkgs_common); sub new { my ($type, $o_in) = @_; bless { in => $o_in }, $type; } sub in { my ($do) = @_; $do->{in}; } sub install { my ($do, @l) = @_; return 1 if listlength(are_installed($do, @l)) == @l; if ($::testing) { log::l("i would install packages " . join(' ', @l)); return 1; } my @options = ('--allow-medium-change', '--auto', '--no-verify-rpm', '--expect-install', @l); my $ret; if (check_for_xserver() && -x '/usr/bin/gurpmi') { $ret = system('gurpmi', @options) == 0; } else { my $_wait = $do->in && $do->in->wait_message(N("Please wait"), N("Installing packages...")); $do->in->suspend if $do->in; log::explanations("installing packages @l"); $ret = system('urpmi', @options) == 0; $do->in->resume if $do->in; } $ret; } sub are_available { my ($_do, @pkgs) = @_; my %pkgs = map { $_ => 1 } @pkgs; require urpm::media; state $urpm; eval { if (!$urpm) { $urpm = urpm->new; $urpm->{log} = \&log::l; urpm::media::configure($urpm, nocheck_access => 1, no_skiplist => 1, no_second_pass => 1); } map { $_->name } grep { $pkgs{$_->name} } @{$urpm->{depslist} || []}; }; } sub what_provides { my ($_do, $name) = @_; split('\|', chomp_(run_program::get_stdout('urpmq', $name))); } sub are_installed { my ($_do, @l) = @_; @l or return; my @l2; my $query_all = (any { /\*/ } @l) ? 'a' : ''; run_program::run('/bin/rpm', '>', \@l2, '-q' . $query_all, '--qf', "%{name}\n", @l); #- do not care about the return value $query_all ? chomp_(@l2) : intersection(\@l, [ chomp_(@l2) ]); #- cannot return directly @l2 since it contains things like "package xxx is not installed" } sub remove { my ($do, @l) = @_; my $_wait = $do->in && $do->in->wait_message(N("Please wait"), N("Removing packages...")); $do->in->suspend if $do->in; log::explanations("removing packages @l"); my $ret = system('rpm', '-e', @l) == 0; $do->in->resume if $do->in; $ret; } sub remove_nodeps { my ($do, @l) = @_; remove($do, '--nodeps', @l) == 0; } =back =cut