diff options
Diffstat (limited to 'perl-install/common.pm')
| -rw-r--r-- | perl-install/common.pm | 775 |
1 files changed, 718 insertions, 57 deletions
diff --git a/perl-install/common.pm b/perl-install/common.pm index 8d8ab40dd..508e6b31f 100644 --- a/perl-install/common.pm +++ b/perl-install/common.pm @@ -1,78 +1,238 @@ -package common; # $Id$ +package common; use MDK::Common; -use MDK::Common::System; use diagnostics; use strict; -use vars qw(@ISA @EXPORT $SECTORSIZE); +BEGIN { eval { require Locale::gettext } } #- allow common.pm to be used in drakxtools-backend without perl-Locale-gettext -@ISA = qw(Exporter); -# no need to export ``_'' -@EXPORT = qw($SECTORSIZE __ translate untranslate formatXiB removeXiBSuffix formatTime setVirtual makedev unmakedev salt); +use log; +use run_program; + +use Exporter; +our @ISA = qw(Exporter); +our @EXPORT = qw($SECTORSIZE N P N_ check_for_xserver files_exist formatTime MB formatXiB get_libdir get_parent_uid is_running is_uefi kernel_uefi_type makedev mageia_release mageia_release_info mount_efivars removeXiBSuffix require_root_capability setVirtual set_alternative set_l10n_sort set_permissions to_utf8 translate uefi_type unmakedev); # perl_checker: RE-EXPORT-ALL push @EXPORT, @MDK::Common::EXPORT; +=head1 SYNOPSYS + +B<common> re-export L<MDK::Common> and offers a couple widely used functions. + +=cut + +$::prefix ||= ""; # no warning #-##################################################################################### #- Globals #-##################################################################################### -$SECTORSIZE = 512; +our $SECTORSIZE = 512; -#-##################################################################################### -#- Functions -#-##################################################################################### +=head1 Functions + +=head2 Translating + +=over + +=item N($format, ...) +translate a message by calling gettext(). eg: -sub _ { - my $s = shift @_; my $t = translate($s); - sprintf $t, @_; + N("Summary") + N("File %s is on %s", "/etc/passwd", "/dev/sda2") + +It must B<not> be used called before L<ugtk3> is initialized, otherwise the gettext is not forced to UTF-8. + +=cut + +sub N { + my ($s, @para) = @_; + sprintf(translate($s), @para); } -sub __ { $_[0] } -sub salt { - my ($nb) = @_; - require devices; - open F, devices::make("random") or die "missing random"; - my $s; read F, $s, $nb; - local $_ = pack "b8" x $nb, unpack "b6" x $nb, $s; - tr [\0-\x3f] [0-9a-zA-Z./]; - $_; +=item N_($format, @param) + +Similar to C<N()>, but message is not actually translated. +It tags the message as translatable so that it will end in the +translation catalogs. + +In order for the message to be translated, C<translate()> must be called +before using the message. + +=cut + +sub N_ { $_[0] } + +=item P($s_singular, $s_plural, $nb, @extra_para) + +Similar to C<N()>, but two messages are provided: one for the singular case, one for the +plural case. At runtime, a number is provided in order to choose the message to use. +eg: + + P("%d package", "%d packages", $nb, $nb) + +=cut + +sub P { + my ($s_singular, $s_plural, $nb, @para) = @_; + sprintf(translate($s_singular, $s_plural, $nb), @para); } -sub makedev { ($_[0] << 8) | $_[1] } -sub unmakedev { $_[0] >> 8, $_[0] & 0xff } +sub translate_real { + my ($s, $o_plural, $o_nb) = @_; + $s or return ''; + my $s2; + foreach (@::textdomains, 'libDrakX') { + if ($o_plural) { + $s2 = Locale::gettext::dngettext($_, $s, $o_plural, $o_nb); + } else { + $s2 = Locale::gettext::dgettext($_, $s); + } + # when utf8 pragma is in use, Locale::gettext() returns an utf8 string not tagged as such: + c::set_tagged_utf8($s2) if !utf8::is_utf8($s2) && utf8::is_utf8($s); + return $s2 if !member($s2, $s, $o_plural); + } + # didn't lookup anything or locale is "C": + $s2; +} + +=item remove_translate_context($string) + +Remove an ala-KDE context message. eg: + + "_: this is verb\nOpen" + "_: Keep these entry short\nNetworking" + +=cut + +sub remove_translate_context { + my ($s) = @_; + #- translation with context, kde-like + $s =~ s/^_:.*(?:\n)?//g; + $s; +} + +=item translate($string) + +Translate the message according to the current locale. +The string is B<not> tagged as translatable and will B<not> end in +translations catalogs. + +perl_checker only extracts strings tagged by C<N()>, C<N_()> or C<P()>. + +=cut sub translate { + my $s = translate_real(@_); + $::one_message_has_been_translated ||= join(':', (caller(1))[1,2]); #- see mygtk3.pm + remove_translate_context($s); +} + +=back + +=head2 Conversion + +=over + +=item from_utf8($s) + +Convert an UTF-8 string into current locale's encoding. + +=cut + +sub from_utf8 { my ($s) = @_; - $s ? c::dgettext('libDrakX', $s) : ''; + Locale::gettext::iconv($s, "utf-8", undef); #- undef = locale charmap = nl_langinfo(CODESET) } -sub untranslate { - my $s = shift || return; - foreach (@_) { translate($_) eq $s and return $_ } - die "untranslate failed"; +=item to_utf8($s) + +The reverse of C<from_utf8()>: convert a string from current locale's encoding to UTF-8. +Also make sure the string is properly tagged as UTF-8 as concerning Perl + +=cut + +sub to_utf8 { + my ($s) = @_; + my $str = Locale::gettext::iconv($s, undef, "utf-8"); #- undef = locale charmap = nl_langinfo(CODESET) + c::set_tagged_utf8($str); + $str; } -BEGIN { undef *availableRamMB } -sub availableRamMB() { - my $s = MDK::Common::System::availableRamMB(); - #- HACK HACK: if i810 and memsize - require detect_devices; - return $s - 1 if $s == 128 && grep { $_->{driver} =~ /i810/ } detect_devices::probeall(); - $s; +=item set_l10n_sort() + +This is needed because text printed by L<Gtk3> will always be encoded +in UTF-8; +we first check if LC_ALL is defined, because if it is, changing +only LC_COLLATE will have no effect. + +=cut + +sub set_l10n_sort() { + my $collation_locale = $ENV{LC_ALL}; + if (!$collation_locale) { + $collation_locale = c::setlocale(c::LC_COLLATE()); + $collation_locale =~ /UTF-8/ or c::setlocale(c::LC_COLLATE(), "$collation_locale.UTF-8"); + } } + sub setVirtual { + my ($vt_number) = @_; my $vt = ''; - local *C; - sysopen C, "/dev/console", 2 or die "failed to open /dev/console: $!"; - ioctl(C, c::VT_GETSTATE(), $vt) or die "ioctl VT_GETSTATE failed"; - ioctl(C, c::VT_ACTIVATE(), $_[0]) or die "ioctl VT_ACTIVATE failed"; - ioctl(C, c::VT_WAITACTIVE(), $_[0]) or die "ioctl VT_WAITACTIVE failed"; + sysopen(my $C, "/dev/console", 2) or die "failed to open /dev/console: $!"; + ioctl($C, c::VT_GETSTATE(), $vt) && + ioctl($C, c::VT_ACTIVATE(), $vt_number) && + ioctl($C, c::VT_WAITACTIVE(), $vt_number) or die "setVirtual failed"; unpack "S", $vt; } +sub nonblock { + my ($F) = @_; + fcntl($F, c::F_SETFL(), fcntl($F, c::F_GETFL(), 0) | c::O_NONBLOCK()) or die "cannot fcntl F_SETFL: $!"; +} + +=item makedev($major, $minor) + +Given major and minor device IDs, makedev() combines these to return a device ID +(eg for mknod()) + +=cut + +sub makedev { ($_[0] << 8) | $_[1] } + +=item unmakedev($device_id) + +The reverse of C<makedev()>: given a device ID, it will return both major and minor device IDs. + +=cut + +sub unmakedev { $_[0] >> 8, $_[0] & 0xff } + +=item MB($suffixed_number) + +return a size in sector +ie C<MB(1)> is 2048 sectors, which is 1MB + +eg: + + MB("10") => 20480 + +=cut + +sub MB { + my ($nb_MB) = @_; + $nb_MB * 2048; +} + +=item removeXiBSuffix($string) + +Remove the XiB suffix and return the number. eg: + + "10k" => 10240 + "2M" => 2097152 + +=cut sub removeXiBSuffix { local $_ = shift; @@ -83,38 +243,72 @@ sub removeXiBSuffix { /(\d+)\s*TB?$/i and return $1 * 1024 * 1024 * 1024 * 1024; $_; } + +=item formatXiB($number [, $base]) + +The reverse of C<removeXiBSuffix()>, returns a nicely human size. eg: + + 2097152 => "2MB" + +The optional parameter enables to provide the unit size (default is one). +eg for a 2000 512 sized sectors: + + formatXiB(2000, 512) + +=cut + sub formatXiB { - my ($newnb, $newbase) = (@_, 1); + my ($newnb, $o_newbase) = @_; + my $newbase = $o_newbase || 1; + my $sign = $newnb < 0 ? -1 : 1; + $newnb = abs(int($newnb)); my ($nb, $base); my $decr = sub { ($nb, $base) = ($newnb, $newbase); $base >= 1024 ? ($newbase = $base / 1024) : ($newnb = $nb / 1024); }; - foreach ('', _("KB"), _("MB"), _("GB")) { + my $suffix; + foreach (N("B"), N("KB"), N("MB"), N("GB"), N("TB")) { $decr->(); if ($newnb < 1 && $newnb * $newbase < 1) { - my $v = $nb * $base; - my $s = $v < 10 && int(10 * $v - 10 * int($v)); - return int($v) . ($s ? ".$s" : '') . $_; + $suffix = $_; + last; } } - int($newnb * $newbase) . _("TB"); + my $v = $nb * $base; + my $s = $v < 10 && int(10 * $v - 10 * int($v)); + int($v * $sign) . ($s ? "." . abs($s) : '') . ($suffix || N("TB")); } sub formatTime { my ($s, $m, $h) = gmtime($_[0]); if ($h) { - sprintf "%02d:%02d", $h, $m; + sprintf + #-PO: here, "2:30" is remaining installation time (eg: "2:30" == 2 hour & 30 minutes) + N("%02d:%02d", $h, $m); } elsif ($m > 1) { - _("%d minutes", $m); + N("%d minutes", $m); } elsif ($m == 1) { - _("1 minute"); + N("1 minute"); } else { - _("%d seconds", $s); + N("%d seconds", $s); } } -sub usingRamdisk { scalar(grep { /ram3/ } cat_("/proc/mounts")) } +sub expand_symlinks_with_absolute_symlinks_in_prefix { + my ($prefix, $link) = @_; + + my ($first, @l) = split '/', $link; + $first eq '' or die "expand_symlinks: $link is relative\n"; + my ($f, $l); + foreach (@l) { + $f .= "/$_"; + while ($l = readlink "$prefix$f") { + $f = $l =~ m!^/! ? $l : MDK::Common::File::concat_symlink($f, "../$l"); + } + } + "$prefix$f"; +} sub expand_symlinks_but_simple { my ($f) = @_; @@ -124,12 +318,479 @@ sub expand_symlinks_but_simple { # put back the last simple symlink $f2 =~ s|\Q$link\E$|basename($f)|e; } - $f2 + $f2; } sub sync { &MDK::Common::System::sync } -#-###################################################################################### -#- Wonderful perl :( -#-###################################################################################### -1; # +BEGIN { undef *formatError } +sub formatError { + my ($err) = @_; + ref($err) eq 'SCALAR' and $err = $$err; + log::l("error: $err"); + &MDK::Common::String::formatError($err); +} + +=item group_by($f, @list) + +Group the elements of @list in array references according to the $f comparison function. + +=cut + +sub group_by(&@) { + my $f = shift; + @_ or return; + my $e = shift; + my @l = my $last_l = [$e]; + foreach (@_) { + if ($f->($e, $_)) { + push @$last_l, $_; + } else { + push @l, $last_l = [$_]; + $e = $_; + } + } + @l; +} + +=item group_n_lm($n, @list) + +Group the list by n. Returns a reference of lists of length n + +See also C<group_by2(LIST)> from L<MDK::Common::DataStructure> + +=cut + +sub group_n_lm { + my $n = shift; + my @l; + push @l, [ splice(@_, 0, $n) ] while @_; + @l; +} + +=item join_lines(@strings) + +Concatenate adjacent strings if laters begin with spaces. + +=cut + +sub join_lines { + my @l; + my $s; + foreach (@_) { + if (/^\s/) { + $s .= $_; + } else { + push @l, $s if $s; + $s = $_; + } + } + @l, if_($s, $s); +} + + +sub read_alternative { + my ($name) = @_; + my $alt = readlink("$::prefix/etc/alternatives/$name"); + $alt && $::prefix . $alt; +} + +sub set_alternative { + my ($command, $executable) = @_; + + #- check the existence of $executable as an alternative for $command + #- (is this needed???) + run_program::rooted_get_stdout($::prefix, 'update-alternatives', '--display', $command) =~ /^\Q$executable /m or return; + + #- this does not handle relative symlink, but neither does update-alternatives ;p + symlinkf $executable, "$::prefix/etc/alternatives/$command"; +} + +sub files_exist { and_(map { -f "$::prefix$_" } @_) } + +sub open_file { + my ($file) = @_; + my $F; + open($F, $file) ? $F : do { log::l("Cannot open $file: $!"); undef }; +} + +=item secured_file($f) + +A wrapper around c::is_secure_file(). + +Callers should probably just use C<mkstemp()> in /tmp. + +=cut + +# FIXME: callers should just use mkstemp in /tmp instead of relying on $TMPDIR || $ENV{HOME}/tmp +# or we should just move the choice of directory from callers to here: +# my $tmpdir = find { -d $_ } $ENV{TMPDIR}, "$ENV{HOME}/tmp", "$::prefix/tmp"; +sub secured_file { + my ($f) = @_; + my $d = dirname($f); + if (! -d $d) { + mkdir_p($d); + if ($d =~ /^$ENV{HOME}/) { + my ($user) = grep { $_->[7] eq $ENV{HOME} } list_passwd(); + chown($user->[2], $user->[3], $d); + } + } + c::is_secure_file($f) or die "cannot ensure a safe $f"; + $f; +} + +sub unwind_protect { + my ($to_do, $cleanup) = @_; + my @l = eval { $to_do->() }; + my $err = $@; + $cleanup->(); + $err and die $err; + wantarray() ? @l : $l[0]; +} + +sub with_private_tmp_file { + my ($file, $content, $f) = @_; + + my $prev_umask = umask 077; + + unwind_protect(sub { + MDK::Common::File::secured_output($file, $content); + $f->($file); + }, sub { + umask $prev_umask; + unlink $file; + }); +} + +sub chown_ { + my ($b_recursive, $name, $group, @files) = @_; + + my ($uid, $gid) = (getpwnam($name) || $name, getgrnam($group) || $group); + + require POSIX; + my $chown; $chown = sub { + foreach (@_) { + POSIX::lchown($uid, $gid, $_) or die "chown of file $_ failed: $!\n"; + ! -l $_ && -d $_ && $b_recursive and &$chown(glob_($_)); + } + }; + $chown->(@files); +} + + +sub set_permissions { + my ($file, $perms, $o_owner, $o_group) = @_; + # We only need to set the permissions during installation to be able to + # print test pages. After installation udev does the business automatically. + return 1 unless $::isInstall; + if ($o_owner || $o_group) { + $o_owner ||= (lstat($file))[4]; + $o_group ||= (lstat($file))[5]; + chown_(0, $o_owner, $o_group, $file); + } + chmod(oct($perms), $file) or die "chmod of file $file failed: $!\n"; +} + +sub is_running { + my ($name, $o_user) = @_; + my $user = $o_user || $ENV{USER}; + foreach (`ps -o '%P %p %c' -u $user`) { + my ($ppid, $pid, $n) = /^\s*(\d+)\s+(\d+)\s+(.*)/; + return $pid if $ppid != 1 && $pid != $$ && $n eq $name; + } +} + +=back + +=head2 Release files + +=over + +=item parse_release_file($prefix, $f, $part) + +Parses the $f release file in $prefix from the $part device. + +Returns a hash containing C<release>, C<version>, C<release_file>, C<part> & C<arch> fields. + +=cut + +sub parse_release_file { + my ($prefix, $f, $part) = @_; + chomp(my $s = cat_("$prefix$f")); + my $version = $s =~ s/\s+release\s+(\S+)// && $1; + my $arch = $s =~ s/\s+for\s+(\S+)// && $1; + log::l("find_root_parts found $part->{device}: $s for $arch" . ($f !~ m!/etc/! ? " in special release file $f" : '')); + { release => $s, version => $version, + release_file => $f, part => $part, 'arch' => $arch }; +} + +=item release_file($o_dir) + +Returns the release file name. + +=cut + +sub release_file { + my ($o_dir) = @_; + my @names = ('mageia-release', 'mandriva-release', 'mandrakelinux-release', 'mandrake-release', 'conectiva-release', 'release', 'redhat-release', 'fedora-release', 'SuSE-release'); + find { -r "$o_dir$_" } ( + (map { "/root/drakx/$_.upgrading" } @names), + (map { "/etc/$_" } @names), + ); +} + +=item mageia_release_info() + +Parses C</etc/product.id> and returns a hash. + +=cut + +sub mageia_release_info() { + parse_LDAP_namespace_structure(cat_('/etc/product.id')); +} + +sub parse_LDAP_namespace_structure { + my ($s) = @_; + my %h = map { if_(/(.*?)=(.*)/, $1 => $2) } split(',', $s); + \%h; +} + +=item mageia_release($o_dir) + +returns the content of Mageia release file from given directory (optional). + +=cut + +sub mageia_release { + my ($o_dir) = @_; + my $f = release_file($o_dir); + $f && chomp_(cat_("$o_dir$f")); +} + +=back + +=head2 Misc + +=over + + +=item get_parent_uid() + +Returns UID of the parent process. + +=cut + +sub get_parent_uid() { + cat_('/proc/' . getppid() . '/status') =~ /Uid:\s*(\d+)/ ? $1 : undef; +} + +=item require_root_capability() + +Ensure we are running as root. + +=cut + +sub require_root_capability() { + return if $::testing || !$>; # we're already root + + die "you must be root to run this program"; +} + +=item check_for_xserver() + +Test if we have access to X11. +This eg enables interactive to use the proper backend (either text mode or +GUI) + +=cut + +sub check_for_xserver() { + if (!defined $::xtest) { + $::xtest = 0; + eval { + require Gtk3; + Gtk3->import; + $::xtest = Gtk3::init_check(); + } if $ENV{DISPLAY}; + } + return $::xtest; +} + +=item unpack_with_refs($format, $s) + +special unpack: + +=over 4 + +=item * returning an array refs for each element like C<s10> + +=item * handling things like C<s10*> at the end of the format + +=back + +=cut + +sub unpack_with_refs { + my ($format, $s) = @_; + my $initial_format = $format; + my @r; + while ($format =~ s/\s*(\w(\d*))(\*?)\s*//) { + my ($sub_format, $nb, $many) = ($1, $2, $3); + $many && $format and internal_error("bad * in the middle of format in $initial_format"); + + my $done = $many && !length($s); + while (!$done) { + my @l = unpack("$sub_format a*", $s); + $s = pop @l; + push @r, $nb ? \@l : @l; + $done = !$many || !length($s); + } + } + @r; +} + +=item md5file(@files) + +Returns the MD5 signatures of @files in list context or signature of the first one in scalar context. + +=cut + +#- used in userdrake and mdkonline +sub md5file { + require Digest::MD5; + my @md5 = map { + my $sum; + if (open(my $FILE, $_)) { + binmode($FILE); + $sum = Digest::MD5->new->addfile($FILE)->hexdigest; + close($FILE); + } + $sum; + } @_; + return wantarray() ? @md5 : $md5[0]; +} + +sub load_modules_from_base { + my ($base) = @_; + $base =~ s|::|/|g; + my $base_file = $base . ".pm"; + require $base_file; + my ($inc_path) = substr($INC{$base_file}, 0, -length($base_file)); + my @files = map { substr($_, length($inc_path)) } glob_($inc_path . $base . '/*.pm'); + require $_ foreach @files; + #- return the matching modules list + map { local $_ = $_; s|/|::|g; s|\.pm$||g; $_ } @files; +} + +sub get_alternatives { + my ($name) = @_; + + my $dir = $::prefix . '/var/lib/rpm/alternatives'; + my ($state, $main_link, @l) = chomp_(cat_("$dir/$name")) or return; + my @slaves; + while (@l && $l[0] ne '') { + my ($name, $link) = splice(@l, 0, 2); + push @slaves, { name => $name, link => $link }; + } + shift @l; #- empty line + my @alternatives; + while (@l && $l[0] ne '') { + my ($file, $weight, @slave_files) = splice(@l, 0, 2 + @slaves); + + push @alternatives, { file => $file, weight => $weight, slave_files => \@slave_files }; + } + { name => $name, link => $main_link, state => $state, slaves => \@slaves, alternatives => \@alternatives }; +} + +sub symlinkf_update_alternatives { + my ($name, $wanted_file) = @_; + run_program::rooted($::prefix, 'update-alternatives', '--set', $name, $wanted_file); +} + +sub update_gnomekderc_no_create { + my ($file, $category, %subst_) = @_; + if (-e $file) { + update_gnomekderc($file, $category, %subst_); + } +} + +sub get_libdir() { + arch() =~ /x86_64/ ? "lib64" : "lib"; +} + +=item is_uefi() + +Checks if we are on an uefi system + +=cut + +sub is_uefi() { -e "/sys/firmware/efi" } + +=item kernel_uefi_type() + +Returns the short name of the UEFI machine type supported by the kernel stub loader + +=cut + +sub kernel_uefi_type() { + my $arch = arch(); + if ($arch eq 'aarch64') { + return 'aa64'; + } + $arch =~ /i.86/ ? 'ia32' : 'x64'; +} + +=item uefi_type() + +Returns the UEFI machine type short name + +=cut + +sub uefi_type() { + if (arch() eq 'aarch64') { + return 'aa64'; + } + if (-e '/sys/firmware/efi/fw_platform_size') { + cat_('/sys/firmware/efi/fw_platform_size') =~ /32/ ? 'ia32' : 'x64'; + } else { + 'none'; + } +} + +=item mount_efivars() + +Ensures the efivarfs pseudo-filesystem is mounted in the default location +and returns the mount point and whether it was already mounted. + +=cut + +sub mount_efivars { + my $mount_point = "$::prefix/sys/firmware/efi/efivars"; + my $already_mounted = cat_("$::prefix/proc/mounts") =~ /\s$mount_point\s/; + run_program::run('mount', '-t', 'efivarfs', 'none', $mount_point) if !$already_mounted; + ($mount_point, $already_mounted); +} + +=item cmp_kernel_versions($va, $vb) + +Compare two kernel versions + +=cut + +sub cmp_kernel_versions { + my ($va, $vb) = @_; + my $rel_a = $va =~ s/-(.*)$// && $1; + my $rel_b = $vb =~ s/-(.*)$// && $1; + ($va, $vb) = map { [ split /[.-]/ ] } $va, $vb; + my $r = 0; + mapn_ { + $r ||= $_[0] <=> $_[1]; + } $va, $vb; + $r || $rel_a <=> $rel_b || $rel_a cmp $rel_b; +} + +=back + +=cut + +1; |