summaryrefslogtreecommitdiffstats
path: root/perl-install/common.pm
diff options
context:
space:
mode:
Diffstat (limited to 'perl-install/common.pm')
-rw-r--r--perl-install/common.pm740
1 files changed, 629 insertions, 111 deletions
diff --git a/perl-install/common.pm b/perl-install/common.pm
index 546a9f7a2..508e6b31f 100644
--- a/perl-install/common.pm
+++ b/perl-install/common.pm
@@ -1,19 +1,25 @@
-package common; # $Id$
+package common;
use MDK::Common;
-use MDK::Common::System;
use diagnostics;
use strict;
+BEGIN { eval { require Locale::gettext } } #- allow common.pm to be used in drakxtools-backend without perl-Locale-gettext
+
+use log;
use run_program;
-use vars qw(@ISA @EXPORT $SECTORSIZE);
-@ISA = qw(Exporter);
-# no need to export ``_''
-@EXPORT = qw($SECTORSIZE N N_ check_for_xserver files_exist formatTime formatXiB makedev mandrake_release removeXiBSuffix require_root_capability salt setVirtual set_alternative set_permissions translate unmakedev untranslate);
+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
@@ -22,74 +28,155 @@ $::prefix ||= ""; # no warning
#-#####################################################################################
our $SECTORSIZE = 512;
-#-#####################################################################################
-#- Functions
-#-#####################################################################################
+=head1 Functions
+=head2 Translating
-sub sprintf_fixutf8 {
- my $need_upgrade;
- $need_upgrade |= to_bool(c::is_tagged_utf8($_)) + 1 foreach @_;
- if ($need_upgrade == 3) { c::upgrade_utf8($_) foreach @_ };
- sprintf shift, @_;
-}
+=over
+
+=item N($format, ...)
+
+translate a message by calling gettext(). eg:
+
+ 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 {
- $::one_message_has_been_translated ||= join(':', (caller(0))[1,2]); #- see ugtk2.pm
- my $s = shift @_; my $t = translate($s);
- sprintf_fixutf8 $t, @_;
+ my ($s, @para) = @_;
+ sprintf(translate($s), @para);
}
+
+=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)
-sub salt {
- my ($nb) = @_;
- require devices;
- open(my $F, devices::make("random")) or die "missing random";
- my $s; read $F, $s, $nb;
- $s = pack("b8" x $nb, unpack "b6" x $nb, $s);
- $s =~ tr|\0-\x3f|0-9a-zA-Z./|;
- $s;
-}
+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:
-sub makedev { ($_[0] << 8) | $_[1] }
-sub unmakedev { $_[0] >> 8, $_[0] & 0xff }
+ 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 translate_real {
- my ($s) = @_;
+ my ($s, $o_plural, $o_nb) = @_;
$s or return '';
- foreach ('libDrakX', @::textdomains) {
- my $s2 = c::dgettext($_, $s);
- return $s2 if $s ne $s2;
+ 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(@_);
- $::need_utf8_i18n and c::set_tagged_utf8($s);
+ $::one_message_has_been_translated ||= join(':', (caller(1))[1,2]); #- see mygtk3.pm
+ remove_translate_context($s);
+}
- #- translation with context, kde-like
- $s =~ s/^_:.*\n//;
- $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) = @_;
+ Locale::gettext::iconv($s, "utf-8", undef); #- undef = locale charmap = nl_langinfo(CODESET)
}
+=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 untranslate {
- my $s = shift || return;
- foreach (@_) { translate($_) eq $s and return $_ }
- die "untranslate failed";
+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 && any { $_->{driver} eq 'Card:Intel 810' } 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 = '';
@@ -102,9 +189,51 @@ sub setVirtual {
sub nonblock {
my ($F) = @_;
- fcntl($F, c::F_SETFL(), fcntl($F, c::F_GETFL(), 0) | c::O_NONBLOCK());
+ 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;
@@ -114,29 +243,49 @@ 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, $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 ('', N("KB"), N("MB"), N("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) . N("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) {
N("%d minutes", $m);
} elsif ($m == 1) {
@@ -146,7 +295,20 @@ sub formatTime {
}
}
-sub usingRamdisk() { any { /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) = @_;
@@ -156,46 +318,62 @@ 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 }
-# Group the list by n. Returns a reference of lists of length n
-sub group_n_lm {
- my $n = shift;
- my @l;
- push @l, [ splice(@_, 0, $n) ] while @_;
- @l
+BEGIN { undef *formatError }
+sub formatError {
+ my ($err) = @_;
+ ref($err) eq 'SCALAR' and $err = $$err;
+ log::l("error: $err");
+ &MDK::Common::String::formatError($err);
}
-sub screenshot_dir__and_move() {
- my ($dir1, $dir2) = ("$::prefix/root", '/tmp/stage2');
- if (-e $dir1) {
- if (-e "$dir2/DrakX-screenshots") {
- cp_af("$dir2/DrakX-screenshots", $dir1);
- rm_rf("$dir2/DrakX-screenshots");
+=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 = $_;
}
- $dir1;
- } else {
- $dir2;
}
+ @l;
}
-sub take_screenshot() {
- my $dir = screenshot_dir__and_move() . '/DrakX-screenshots';
- my $warn;
- if (!-e $dir) {
- mkdir $dir or $::o->ask_warn('', N("Can't make screenshots before partitioning")), return;
- $warn = 1;
- }
- my $nb = 1;
- $nb++ while -e "$dir/$nb.png";
- system("fb2png /dev/fb0 $dir/$nb.png 0");
+=item group_n_lm($n, @list)
+
+Group the list by n. Returns a reference of lists of length n
- $::o->ask_warn('', N("Screenshots will be available after install in %s", "/root/DrakX-screenshots")) if $warn;
+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;
@@ -211,68 +389,408 @@ sub join_lines {
}
+sub read_alternative {
+ my ($name) = @_;
+ my $alt = readlink("$::prefix/etc/alternatives/$name");
+ $alt && $::prefix . $alt;
+}
+
sub set_alternative {
my ($command, $executable) = @_;
- #- check the existance of $executable as an alternative for $command
+ #- 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 doesn't handle relative symlink, but neither does update-alternatives ;p
+ #- 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) = @_;
- c::is_secure_file($f) or die "can't ensure a safe $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 the devfsd daemon does the business
- # automatically.
+ # print test pages. After installation udev does the business automatically.
return 1 unless $::isInstall;
- if ($o_owner && $o_group) {
- run_program::rooted($::prefix, "/bin/chown", "$o_owner.$o_group", $file)
- or die "Could not start chown!";
- } elsif ($o_owner) {
- run_program::rooted($::prefix, "/bin/chown", $o_owner, $file)
- or die "Could not start chown!";
- } elsif ($o_group) {
- run_program::rooted($::prefix, "/bin/chgrp", $o_group, $file)
- or die "Could not start chgrp!";
+ if ($o_owner || $o_group) {
+ $o_owner ||= (lstat($file))[4];
+ $o_group ||= (lstat($file))[5];
+ chown_(0, $o_owner, $o_group, $file);
}
- run_program::rooted($::prefix, "/bin/chmod", $perms, $file)
- or die "Could not start chmod!";
+ 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 mandrake_release() {
- chomp_(cat_("/etc/mandrake-release"))
+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 unless $>; # we're already root
- if (check_for_xserver()) {
- if (fuzzy_pidofs(qr/\bkwin\b/) > 0) {
- exec("kdesu", "-c", "$0 @ARGV") or die N("kdesu missing");
- }
- }
- exec { 'consolehelper' } $0, @ARGV or die N("consolehelper missing");
+ return if $::testing || !$>; # we're already root
- # still not root ?
- die "you must be root to run this program" if $>;
+ 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 = $ENV{DISPLAY} && system('/usr/X11R6/bin/xtest') == 0;
+ $::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;
generated by cgit v1.2.1 (git 2.21.0) at 2025-10-31 14:40:29 +0000