package urpm::sys; # $Id: sys.pm 271299 2010-11-21 15:54:30Z peroyvind $ use strict; use warnings; use urpm::util; use urpm::msg; use POSIX (); (our $VERSION) = q($Revision: 271299 $) =~ /(\d+)/; =head1 NAME urpm::sys - OS-related routines for urpmi =head1 SYNOPSIS =head1 DESCRIPTION =over =cut =item get_packages_list($file, $o_extra) Get the list of packages that should not be upgraded or installed, typically from the inst.list or skip.list files. =cut sub get_packages_list { my ($file, $o_extra) = @_; my @l = split(/,/, $o_extra || ''); if ($file && open(my $f, '<', $file)) { push @l, <$f>; } [ grep { $_ } map { chomp; s/#.*$//; s/^\s*//; s/\s*$//; $_; } @l ]; } sub _read_fstab_or_mtab { my ($file) = @_; my @l; foreach (cat_($file)) { next if /^\s*#/; my ($device, $mntpoint, $fstype, $_options) = m!^\s*(\S+)\s+(/\S+)\s+(\S+)\s+(\S+)! or next; $mntpoint =~ s,/+,/,g; $mntpoint =~ s,/$,,; push @l, { mntpoint => $mntpoint, device => $device, fs => $fstype }; } @l; } =item find_a_mntpoint($dir) Find used mount point from a pathname =cut sub find_a_mntpoint { my ($dir) = @_; _find_a_mntpoint($dir, {}); } # deprecated sub find_mntpoints { my ($dir, $infos) = @_; if (my $entry = _find_a_mntpoint($dir, $infos)) { $entry->{mntpoint}; } else { (); } } sub read_mtab() { _read_fstab_or_mtab('/etc/mtab') } #- find used mount point from a pathname sub _find_a_mntpoint { my ($dir, $infos) = @_; #- read /etc/fstab and check for existing mount point. foreach (_read_fstab_or_mtab("/etc/fstab")) { $infos->{$_->{mntpoint}} = { mounted => 0, %$_ }; } foreach (read_mtab()) { $infos->{$_->{mntpoint}} = { mounted => 1, %$_ }; } #- try to follow symlink, too complex symlink graph may not be seen. #- check the possible mount point. my @paths = split '/', $dir; my $pdir = ''; while (@paths) { my $path = shift @paths; length($path) or next; $pdir .= "/$path"; $pdir =~ s,/+,/,g; $pdir =~ s,/$,,; if (exists($infos->{$pdir})) { #- following symlinks may be useless or dangerous for supermounted devices. #- this means it is assumed no symlink inside a removable device #- will go outside the device itself (or at least will go into #- regular already mounted device like /). #- for simplification we refuse also any other device and stop here. return $infos->{$pdir}; } elsif (-l $pdir) { unshift @paths, split '/', _expand_symlink($pdir); $pdir = ''; } } undef; } =item df($mntpoint) Return the size of the partition and its free space in KiB =cut sub df { my ($mntpoint) = @_; require Filesys::Df; my $df = Filesys::Df::df($mntpoint || "/", 1024); # ask 1kb values @$df{qw(blocks bfree)}; } sub _expand_symlink { my ($pdir) = @_; while (my $v = readlink $pdir) { if ($pdir =~ m|^/|) { $pdir = $v; } else { while ($v =~ s!^\.\./!!) { $pdir =~ s!/[^/]+/*$!!; } $pdir .= "/$v"; } } $pdir; } sub whereis_binary { my ($prog, $o_prefix) = @_; if ($prog =~ m!/!) { warn qq(don't call whereis_binary with a name containing a "/" (the culprit is: $prog)\n); return; } my $prefix = $o_prefix || ''; foreach (split(':', $ENV{PATH})) { my $f = "$_/$prog"; -x "$prefix$f" and return $f; } } sub may_clean_rpmdb_shared_regions { my ($urpm, $test) = @_; if ($urpm->{root} && !$test || $urpm->{tune_rpm}{private}) { $urpm->{root} && $urpm->{debug} and $urpm->{debug}("workaround bug in rpmlib by removing $urpm->{root}/var/lib/rpm/__db*"); clean_rpmdb_shared_regions($urpm->{root}); } } sub clean_rpmdb_shared_regions { my ($prefix) = @_; unlink glob("$prefix/var/lib/rpm/__db.*"); } sub proc_mounts() { my @l = cat_('/proc/mounts') or warn "Can't read /proc/mounts: $!\n"; @l; } =item first_free_loopdev() Returns the first unused loop device, or an empty string if none is found. =cut sub first_free_loopdev () { my %loopdevs = map { $_ => 1 } grep { ! -d $_ } glob('/dev/loop*'); foreach (proc_mounts()) { (our $dev) = split ' '; delete $loopdevs{$dev} if $dev =~ m!^/dev/loop!; } my @l = keys %loopdevs; @l ? $l[0] : ''; } sub trim_until_d { my ($dir) = @_; foreach (proc_mounts()) { #- fail if an iso is already mounted m!^/dev/loop! and return $dir; } while ($dir && !-d $dir) { $dir =~ s,/[^/]*$,, } $dir; } =item check_fs_writable() Checks if the main filesystems are writeable for urpmi to install files in =cut sub check_fs_writable () { foreach (proc_mounts()) { (undef, our $mountpoint, undef, my $opts) = split ' '; if ($opts =~ /(?:^|,)ro(?:,|$)/ && $mountpoint =~ m!^(/|/usr|/s?bin)\z!) { return 0; } } 1; } sub _launched_time { my ($component) = @_; if ($component eq N_("system")) { my ($uptime) = cat_('/proc/uptime') =~ /(\S+)/; time() - $uptime; } else { 1; # TODO } } sub need_restart { my ($root) = @_; my $rpm_qf = '%{name} %{installtime} [%{provides}:%{Provideversion} ]\n'; my $options = ($root ? "--root $root " : '') . "-q --whatprovides should-restart --qf '$rpm_qf'"; open(my $F, "rpm $options | uniq |"); my (%need_restart, %launched_time); while (my $line = <$F>) { my ($name, $installtime, $s) = $line =~ /(\S+)\s+(\S+)\s+(.*)/; my @should_restart = $s =~ /should-restart:(\S+)/g; foreach my $component (@should_restart) { $launched_time{$component} ||= _launched_time($component); if ($launched_time{$component} < $installtime) { push @{$need_restart{$component}}, $name; } } } %need_restart && \%need_restart; } sub need_restart_formatted { my ($root) = @_; my $need_restart = need_restart($root) or return; foreach (keys %$need_restart) { my $packages = join(', ', sort @{$need_restart->{$_}}); if ($_ eq 'system') { $need_restart->{$_} = N("You should restart your computer for %s", $packages); } elsif ($_ eq 'session') { $need_restart->{$_} = N("You should restart your session for %s", $packages); } else { $need_restart->{$_} = N("You should restart %s for %s", translate($_), $packages); } } $need_restart; } # useful on command-line: perl -Murpm::sys -e 'urpm::sys::print_need_restart' sub print_need_restart() { my $h = need_restart_formatted(''); print "$_\n" foreach values %$h; } sub migrate_back_rpmdb_db_to_hash_8 { my ($urpm, $root) = @_; $urpm->{info}("migrating back the created rpm db from Hash version 9 to Hash version 8"); foreach my $db_file (glob("$root/var/lib/rpm/[A-Z]*")) { rename $db_file, "$db_file."; system("db_dump $db_file. | db42_load $db_file"); if (-e $db_file) { unlink "$db_file."; } else { rename "$db_file.", $db_file; $urpm->{error}("rpm db migration failed on $db_file. You will not be able to run rpm chrooted"); return; } } } sub migrate_back_rpmdb_db_to_4_6 { my ($urpm, $root) = @_; $urpm->{info}("migrating back the created rpm db from rpm-4.9 to rpm-4.6/4.8"); if (system('chroot', $root, 'rpm', '--rebuilddb') == 0) { $urpm->{log}("rpm db downgraded successfully"); } else { $urpm->{error}("rpm db downgrade failed. You will not be able to run rpm chrooted"); } } sub migrate_back_rpmdb_db_version { my ($urpm, $root) = @_; if ($urpm->{need_migrate_rpmdb} eq '4.6') { migrate_back_rpmdb_db_to_hash_8($urpm, $root); } elsif ($urpm->{need_migrate_rpmdb} eq '4.8') { migrate_back_rpmdb_db_to_4_6($urpm, $root); } clean_rpmdb_shared_regions($root); } =item apply_delta_rpm($deltarpm, $o_dir, $o_pkg) Create a plain rpm from an installed rpm and a delta rpm (in the current directory) Returns the new rpm filename in case of success. Params : =over =item * $deltarpm : full pathname of the deltarpm =item * $o_dir : directory where to put the produced rpm (optional) =item * $o_pkg : URPM::Package object corresponding to the deltarpm (optional) =back =cut our $APPLYDELTARPM = '/usr/bin/applydeltarpm'; sub apply_delta_rpm { my ($deltarpm, $o_dir, $o_pkg) = @_; -x $APPLYDELTARPM or return 0; -e $deltarpm or return 0; my $rpm; if ($o_pkg) { require URPM; #- help perl_checker $rpm = $o_pkg->fullname . '.rpm'; } else { $rpm = `rpm -qp --qf '%{name}-%{version}-%{release}.%{arch}.rpm' '$deltarpm'`; } $rpm or return 0; $rpm = $o_dir . '/' . $rpm; unlink $rpm; system($APPLYDELTARPM, $deltarpm, $rpm); -e $rpm ? $rpm : ''; } our $tempdir_template = '/tmp/urpm.XXXXXX'; sub mktempdir() { my $tmpdir; eval { require File::Temp }; if ($@) { #- fall back to external command (File::Temp not in perl-base) $tmpdir = `mktemp -d $tempdir_template`; chomp $tmpdir; } else { $tmpdir = File::Temp::tempdir($tempdir_template); } return $tmpdir; } # temporary hack used by urpmi when restarting itself. sub fix_fd_leak() { opendir my $dirh, "/proc/$$/fd" or return undef; my @fds = grep { /^(\d+)$/ && $1 > 2 } readdir $dirh; closedir $dirh; foreach (@fds) { my $link = readlink("/proc/$$/fd/$_"); $link or next; next if $link =~ m!^/(usr|dev)/! || $link !~ m!^/!; POSIX::close($_); } } sub clean_dir { my ($dir) = @_; require File::Path; File::Path::rmtree([$dir]); } sub empty_dir { my ($dir) = @_; clean_dir($dir); mkdir $dir, 0755; } sub syserror { my ($urpm, $msg, $info) = @_; $urpm->{error}("$msg [$info] [$!]"); } sub open_safe { my ($urpm, $sense, $filename) = @_; open my $f, $sense, $filename or syserror($urpm, $sense eq '>' ? N("Can't write file") : N("Can't open file"), $filename), return undef; return $f; } sub opendir_safe { my ($urpm, $dirname) = @_; opendir my $d, $dirname or syserror($urpm, "Can't open directory", $dirname), return undef; return $d; } sub move_or_die { my ($urpm, $file, $dest) = @_; urpm::util::move($file, $dest) or $urpm->{fatal}(1, N("Can't move file %s to %s", $file, $dest)); } 1; __END__ =back =head1 COPYRIGHT Copyright (C) 2005 MandrakeSoft SA Copyright (C) 2005-2010 Mandriva SA =cut