diff options
Diffstat (limited to 'perl-install/common.pm')
| -rw-r--r-- | perl-install/common.pm | 1180 |
1 files changed, 667 insertions, 513 deletions
diff --git a/perl-install/common.pm b/perl-install/common.pm index 9dcb55300..508e6b31f 100644 --- a/perl-install/common.pm +++ b/perl-install/common.pm @@ -1,642 +1,796 @@ -package common; # $Id$ +package common; +use MDK::Common; use diagnostics; use strict; -use vars qw(@ISA %EXPORT_TAGS @EXPORT_OK $printable_chars $sizeof_int $bitof_int $cancel $SECTORSIZE %compat_arch); +BEGIN { eval { require Locale::gettext } } #- allow common.pm to be used in drakxtools-backend without perl-Locale-gettext -@ISA = qw(Exporter); -%EXPORT_TAGS = ( - common => [ qw(__ even odd arch better_arch compat_arch min max sqr sum and_ or_ sign product bool invbool listlength bool2text bool2yesno text2bool to_int to_float ikeys member divide is_empty_array_ref is_empty_hash_ref add2hash add2hash_ set_new set_add round round_up round_down first second top uniq translate untranslate warp_text formatAlaTeX formatLines deref next_val_in_array) ], - functional => [ qw(fold_left compose mapgrep map_index grep_index find_index map_each grep_each list2kv map_tab_hash mapn mapn_ difference2 before_leaving catch_cdie cdie combine) ], - file => [ qw(dirname basename touch all glob_ cat_ cat__ output symlinkf chop_ mode typeFromMagic expand_symlinks) ], - system => [ qw(sync makedev unmakedev psizeof strcpy gettimeofday syscall_ salt getVarsFromSh setVarsInSh setVarsInShMode setVarsInCsh substInFile availableMemory availableRamMB removeXiBSuffix template2file template2userfile update_userkderc list_skels formatTime formatTimeRaw unix2dos setVirtual) ], - constant => [ qw($printable_chars $sizeof_int $bitof_int $SECTORSIZE %compat_arch) ], -); -@EXPORT_OK = map { @$_ } values %EXPORT_TAGS; +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 #-##################################################################################### -$printable_chars = "\x20-\x7E"; -$sizeof_int = psizeof("i"); -$bitof_int = $sizeof_int * 8; -$SECTORSIZE = 512; -%compat_arch = ( #- compatibilty arch mapping. - 'noarch' => undef, - 'i386' => 'noarch', - 'i486' => 'i386', - 'i586' => 'i486', - 'i686' => 'i586', - 'i786' => 'i686', - 'k6' => 'i586', - 'k7' => 'k6', - 'k8' => 'k7', - 'ppc' => 'noarch', - 'alpha' => 'noarch', - 'sparc' => 'noarch', - 'sparc32' => 'sparc', - 'sparc64' => 'sparc32', - ); +our $SECTORSIZE = 512; -#-##################################################################################### -#- Functions -#-##################################################################################### +=head1 Functions -sub fold_left(&@) { - my $f = shift; - local $a = shift; - foreach $b (@_) { $a = &$f() } - $a -} - -sub _ { - my $s = shift @_; my $t = translate($s); - $t && ref $t or return sprintf $t, @_; - my ($T, @p) = @$t; - sprintf $T, @_[@p]; -} -#-delete $main::{'_'}; -sub __ { $_[0] } -sub even($) { $_[0] % 2 == 0 } -sub odd($) { $_[0] % 2 == 1 } -sub min { fold_left { $a < $b ? $a : $b } @_ } -sub max { fold_left { $a > $b ? $a : $b } @_ } -sub sum { fold_left { $a + $b } @_ } -sub and_{ fold_left { $a && $b } @_ } -sub or_ { fold_left { $a || $b } @_ } -sub sqr { $_[0] * $_[0] } -sub sign { $_[0] <=> 0 } -sub product { fold_left { $a * $b } @_ } -sub first { $_[0] } -sub second { $_[1] } -sub top { $_[-1] } -sub uniq { my %l; @l{@_} = (); keys %l } -sub to_int { $_[0] =~ /(\d*)/; $1 } -sub to_float { $_[0] =~ /(\d*(\.\d*)?)/; $1 } -sub ikeys { my %l = @_; sort { $a <=> $b } keys %l } -sub add2hash($$) { my ($a, $b) = @_; while (my ($k, $v) = each %{$b || {}}) { $a->{$k} ||= $v } $a } -sub add2hash_($$) { my ($a, $b) = @_; while (my ($k, $v) = each %{$b || {}}) { exists $a->{$k} or $a->{$k} = $v } $a } -sub member { my $e = shift; foreach (@_) { $e eq $_ and return 1 } 0 } -sub dirname { @_ == 1 or die "usage: dirname <name>\n"; local $_ = shift; s|[^/]*/*\s*$||; s|(.)/*$|$1|; $_ || '.' } -sub basename { @_ == 1 or die "usage: basename <name>\n"; local $_ = shift; s|/*\s*$||; s|.*/||; $_ } -sub bool($) { $_[0] ? 1 : 0 } -sub invbool { my $a = shift; $$a = !$$a; $$a } -sub listlength { scalar @_ } -sub bool2text { $_[0] ? "true" : "false" } -sub bool2yesno { $_[0] ? "yes" : "no" } -sub text2bool { my $t = lc($_[0]); $t eq "true" || $t eq "yes" ? 1 : 0 } -sub strcpy { substr($_[0], $_[2] || 0, length $_[1]) = $_[1] } -sub cat_ { local *F; open F, $_[0] or $_[1] ? die "cat of file $_[0] failed: $!\n" : return; my @l = <F>; wantarray ? @l : join '', @l } -sub cat__ { my ($f) = @_; my @l = <$f>; wantarray ? @l : join '', @l } -sub output { my $f = shift; local *F; open F, ">$f" or die "output in file $f failed: $!\n"; print F foreach @_; } -sub deref { ref $_[0] eq "ARRAY" ? @{$_[0]} : ref $_[0] eq "HASH" ? %{$_[0]} : $_[0] } -sub linkf { unlink $_[1]; link $_[0], $_[1] } -sub symlinkf { unlink $_[1]; symlink $_[0], $_[1] } -sub chop_ { map { my $l = $_; chomp $l; $l } @_ } -sub divide { my $d = int $_[0] / $_[1]; wantarray ? ($d, $_[0] % $_[1]) : $d } -sub round { int ($_[0] + 0.5) } -sub round_up { my ($i, $r) = @_; $i = int $i; $i += $r - ($i + $r - 1) % $r - 1; } -sub round_down { my ($i, $r) = @_; $i = int $i; $i -= $i % $r; } -sub is_empty_array_ref { my $a = shift; !defined $a || @$a == 0 } -sub is_empty_hash_ref { my $a = shift; !defined $a || keys(%$a) == 0 } -sub difference2 { my %l; @l{@{$_[1]}} = (); grep { !exists $l{$_} } @{$_[0]} } -sub intersection { my (%l, @m); @l{@{shift @_}} = (); foreach (@_) { @m = grep { exists $l{$_} } @$_; %l = (); @l{@m} = (); } keys %l } - -sub set_new(@) { my %l; @l{@_} = undef; { list => [ @_ ], hash => \%l } } -sub set_add($@) { my $o = shift; foreach (@_) { exists $o->{hash}{$_} and next; push @{$o->{list}}, $_; $o->{hash}{$_} = undef } } - -sub sync { syscall_('sync') } -sub gettimeofday { my $t = pack "LL"; syscall_('gettimeofday', $t, 0) or die "gettimeofday failed: $!\n"; unpack("LL", $t) } -sub unix2dos { local $_ = $_[0]; s/\015$//mg; s/$/\015/mg; $_ } - -sub remove_spaces { local $_ = shift; s/^ +//; s/ +$//; $_ } -sub mode { my @l = stat $_[0] or die "unable to get mode of file $_[0]: $!\n"; $l[2] } -sub psizeof { length pack $_[0] } - -sub concat_symlink { - my ($f, $l) = @_; - $l =~ m|^\.\./(/.*)| and return $1; - - $f =~ s|/$||; - while ($l =~ s|^\.\./||) { - $f =~ s|/[^/]+$|| or die "concat_symlink: $f $l\n"; - } - "$f/$l"; -} +=head2 Translating -sub expand_symlinks { - my ($first, @l) = split '/', $_[0]; - $first eq '' or die "expand_symlinks: $_[0] is relative\n"; - my ($f, $l); - foreach (@l) { - $f .= "/$_"; - $f = concat_symlink($f, "../$l") while $l = readlink $f; - } - $f; -} +=over -sub arch() { - require c; - c::kernel_arch(); -} -sub better_arch { - my ($new, $old) = @_; - while ($new && $new ne $old) { $new = $compat_arch{$new} } - $new; +=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 { + my ($s, @para) = @_; + sprintf(translate($s), @para); } -sub compat_arch { better_arch(arch(), $_[0]) } -sub touch { - my ($f) = @_; - unless (-e $f) { - local *F; - open F, ">$f"; - } - my $now = time; - utime $now, $now, $f; +=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 mapgrep(&@) { - my $f = shift; - my @l; - foreach (@_) { - my ($b, $v) = $f->($_); - push @l, $v if $b; +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); } - @l; + # didn't lookup anything or locale is "C": + $s2; } -sub map_index(&@) { - my $f = shift; - my @v; local $::i = 0; - map { @v = &$f($::i); $::i++; @v } @_; -} -sub grep_index(&@) { - my $f = shift; - my $v; local $::i = 0; - grep { $v = &$f($::i); $::i++; $v } @_; +=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; } -sub find_index(&@) { - my $f = shift; - local $_; - for (my $i = 0; $i < @_; $i++) { - $_ = $_[$i]; - &$f and return $i; - } - die "find_index failed in @_"; + +=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); } -sub map_each(&%) { - my ($f, %h) = @_; - my @l; - local ($::a, $::b); - while (($::a, $::b) = each %h) { push @l, &$f($::a, $::b) } - @l; +=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) } -sub grep_each(&%) { - my ($f, %h) = @_; - my %l; - local ($::a, $::b); - while (($::a, $::b) = each %h) { $l{$::a} = $::b if &$f($::a, $::b) } - %l; + +=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; } -sub list2kv(@) { [ grep_index { even($::i) } @_ ], [ grep_index { odd($::i) } @_ ] } -sub combine { - my $nb = shift; - my @l; while (my @m = splice(@_, 0, $nb)) { push @l, \@m } - @l; +=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"); + } } -#- pseudo-array-hash :) -sub map_tab_hash(&$@) { - my ($f, $fields, @tab_hash) = @_; - my %hash; - my $key = { map_index {($_, $::i + 1)} @{$fields} }; - for (my $i = 0; $i < @tab_hash; $i += 2) { - my $h = [$key, @{$tab_hash[$i + 1]}]; - &$f($i, $h) if $f; - $hash{ $tab_hash[$i] } = $h; - } - %hash; +sub setVirtual { + my ($vt_number) = @_; + my $vt = ''; + 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 smapn { - my $f = shift; - my $n = shift; - my @r = (); - for (my $i = 0; $i < $n; $i++) { push @r, &$f(map { $_->[$i] } @_); } - @r +sub nonblock { + my ($F) = @_; + fcntl($F, c::F_SETFL(), fcntl($F, c::F_GETFL(), 0) | c::O_NONBLOCK()) or die "cannot fcntl F_SETFL: $!"; } -sub mapn(&@) { - my $f = shift; - smapn($f, min(map { scalar @$_ } @_), @_); + +=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; } -sub mapn_(&@) { - my $f = shift; - smapn($f, max(map { scalar @$_ } @_), @_); + +=item removeXiBSuffix($string) + +Remove the XiB suffix and return the number. eg: + + "10k" => 10240 + "2M" => 2097152 + +=cut + +sub removeXiBSuffix { + local $_ = shift; + + /(\d+)\s*kB?$/i and return $1 * 1024; + /(\d+)\s*MB?$/i and return $1 * 1024 * 1024; + /(\d+)\s*GB?$/i and return $1 * 1024 * 1024 * 1024; + /(\d+)\s*TB?$/i and return $1 * 1024 * 1024 * 1024 * 1024; + $_; } +=item formatXiB($number [, $base]) -sub add_f4before_leaving { - my ($f, $b, $name) = @_; +The reverse of C<removeXiBSuffix()>, returns a nicely human size. eg: - unless ($common::before_leaving::{$name}) { - no strict 'refs'; - ${"common::before_leaving::$name"} = 1; - ${"common::before_leaving::list"} = 1; - } - local *N = *{$common::before_leaving::{$name}}; - my $list = *common::before_leaving::list; - $list->{$b}{$name} = $f; - *N = sub { - my $f = $list->{$_[0]}{$name} or die ''; - $name eq 'DESTROY' and delete $list->{$_[0]}; - goto $f; - } unless defined &{*N}; + 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); + }; + my $suffix; + foreach (N("B"), N("KB"), N("MB"), N("GB"), N("TB")) { + $decr->(); + if ($newnb < 1 && $newnb * $newbase < 1) { + $suffix = $_; + last; + } + } + my $v = $nb * $base; + my $s = $v < 10 && int(10 * $v - 10 * int($v)); + int($v * $sign) . ($s ? "." . abs($s) : '') . ($suffix || N("TB")); } -#- ! the functions are not called in the order wanted, in case of multiple before_leaving :( -sub before_leaving(&) { - my ($f) = @_; - my $b = bless {}, 'common::before_leaving'; - add_f4before_leaving($f, $b, 'DESTROY'); - $b; +sub formatTime { + my ($s, $m, $h) = gmtime($_[0]); + if ($h) { + 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) { + N("1 minute"); + } else { + N("%d seconds", $s); + } } -sub catch_cdie(&&) { - my ($f, $catch) = @_; +sub expand_symlinks_with_absolute_symlinks_in_prefix { + my ($prefix, $link) = @_; - local @common::cdie_catches; - unshift @common::cdie_catches, $catch; - &$f(); + 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 cdie($;&) { - my ($err, $f) = @_; - foreach (@common::cdie_catches) { - $@ = $err; - &{$_}(\$err) and return; +sub expand_symlinks_but_simple { + my ($f) = @_; + my $link = readlink($f); + my $f2 = expand_symlinks($f); + if ($link && $link !~ m|/|) { + # put back the last simple symlink + $f2 =~ s|\Q$link\E$|basename($f)|e; } - die $err; + $f2; +} + +sub sync { &MDK::Common::System::sync } + +BEGIN { undef *formatError } +sub formatError { + my ($err) = @_; + ref($err) eq 'SCALAR' and $err = $$err; + log::l("error: $err"); + &MDK::Common::String::formatError($err); } -sub all { - my $d = shift; +=item group_by($f, @list) - local *F; - opendir F, $d or return; - my @l = grep { $_ ne '.' && $_ ne '..' } readdir F; - closedir F; +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; } -sub glob_ { - my ($d, $f) = ($_[0] =~ /\*/) ? (dirname($_[0]), basename($_[0])) : ($_[0], '*'); +=item group_n_lm($n, @list) - $d =~ /\*/ and die "glob_: wildcard in directory not handled ($_[0])\n"; - ($f = quotemeta $f) =~ s/\\\*/.*/g; +Group the list by n. Returns a reference of lists of length n - $d =~ m|/$| or $d .= '/'; - map { $d eq './' ? $_ : "$d$_" } grep { /^$f$/ } all($d); +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) -sub syscall_ { - my $f = shift; +Concatenate adjacent strings if laters begin with spaces. - require 'syscall.ph'; - syscall(&{$common::{"SYS_$f"}}, @_) == 0; +=cut + +sub join_lines { + my @l; + my $s; + foreach (@_) { + if (/^\s/) { + $s .= $_; + } else { + push @l, $s if $s; + $s = $_; + } + } + @l, if_($s, $s); } -sub salt($) { - my ($nb) = @_; - require 'devices.pm'; - 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./]; - $_; + +sub read_alternative { + my ($name) = @_; + my $alt = readlink("$::prefix/etc/alternatives/$name"); + $alt && $::prefix . $alt; } -sub makedev { ($_[0] << 8) | $_[1] } -sub unmakedev { $_[0] >> 8, $_[0] & 0xff } +sub set_alternative { + my ($command, $executable) = @_; -sub list_passwd() { - my (@l, @e); - setpwent(); - while (@e = getpwent()) { push @l, [ @e ] } - endpwent(); - @l; + #- 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 list_home() { - map { $_->[7] } grep { $_->[2] >= 500 } list_passwd(); + +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 }; } -sub list_skels { - my ($prefix, $suffix) = @_; - grep { -d $_ && -w $_ } map { "$prefix$_/$suffix" } '/etc/skel', '/root', list_home() } -sub translate { - my ($s) = @_; - my ($lang) = $ENV{LANGUAGE} || $ENV{LC_MESSAGES} || $ENV{LC_ALL} || $ENV{LANG} || 'en'; - - require lang; - foreach (split ':', $lang) { - lang::load_po($_) unless defined $po::I18N::{$_}; - if (%{$po::I18N::{$_}}) { - return if $s eq '_I18N_'; - return ${$po::I18N::{$_}}{$s} || $s +=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); } } - $s; + c::is_secure_file($f) or die "cannot ensure a safe $f"; + $f; } -sub untranslate($@) { - my $s = shift || return; - foreach (@_) { translate($_) eq $s and return $_ } - die "untranslate failed"; +sub unwind_protect { + my ($to_do, $cleanup) = @_; + my @l = eval { $to_do->() }; + my $err = $@; + $cleanup->(); + $err and die $err; + wantarray() ? @l : $l[0]; } -sub warp_text($;$) { - my ($text, $width) = @_; - $width ||= 80; +sub with_private_tmp_file { + my ($file, $content, $f) = @_; - my @l; - foreach (split "\n", $text) { - my $t = ''; - foreach (split /\s+/, $_) { - if (length "$t $_" > $width) { - push @l, $t; - $t = $_; - } else { - $t = "$t $_"; - } - } - push @l, $t; - } - @l; + my $prev_umask = umask 077; + + unwind_protect(sub { + MDK::Common::File::secured_output($file, $content); + $f->($file); + }, sub { + umask $prev_umask; + unlink $file; + }); } -sub formatAlaTeX($) { - my ($t, $tmp); - foreach (split "\n", $_[0]) { - if (/^$/) { - $t .= ($t && "\n") . $tmp; - $tmp = ''; - } else { - $tmp = ($tmp && "$tmp ") . first(/^\s*(.*?)\s*$/); +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_($_)); } - } - $t . ($t && $tmp && "\n") . $tmp; + }; + $chown->(@files); } -sub formatLines($) { - my ($t, $tmp); - foreach (split "\n", $_[0]) { - if (/^\s/) { - $t .= "$tmp\n"; - $tmp = $_; - } else { - $tmp = ($tmp ? "$tmp " : ($t && "\n") . $tmp) . $_; - } + +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); } - "$t$tmp\n"; -} - -sub getVarsFromSh($) { - my %l; - local *F; - open F, $_[0] or return; - foreach (<F>) { - my ($v, $val, $val2) = - /^\s* # leading space - (\w+) = # variable - ( - "([^"]*)" # double-quoted text - | '([^']*)' # single-quoted text - | [^'"\s]+ # normal text - ) - \s*$ # end of line - /x or next; - $l{$v} = $val2 || $val; + 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; } - %l; } -sub setVarsInSh { - my ($file, $l, @fields) = @_; - setVarsInShMode($file, 0777 ^ umask(), $l, @fields); +=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 }; } -sub setVarsInShMode { - my ($file, $mod, $l, @fields) = @_; - @fields = keys %$l unless @fields; +=item release_file($o_dir) + +Returns the release file name. - local *F; - open F, "> $file" or die "cannot create config file $file"; - chmod $mod, $file; - $l->{$_} and print F "$_=$l->{$_}\n" foreach @fields; +=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), + ); } -sub setVarsInCsh { - my ($file, $l, @fields) = @_; - @fields = keys %$l unless @fields; +=item mageia_release_info() + +Parses C</etc/product.id> and returns a hash. - local *F; - open F, "> $_[0]" or die "cannot create config file $file"; - $l->{$_} and print F "setenv $_ $l->{$_}\n" foreach @fields; +=cut + +sub mageia_release_info() { + parse_LDAP_namespace_structure(cat_('/etc/product.id')); } -sub template2file { - my ($in, $out, %toreplace) = @_; - output $out, map { s/@@@(.*?)@@@/$toreplace{$1}/g; $_ } cat_($in); +sub parse_LDAP_namespace_structure { + my ($s) = @_; + my %h = map { if_(/(.*?)=(.*)/, $1 => $2) } split(',', $s); + \%h; } -sub template2userfile { - my ($prefix, $in, $out_rel, $force, %toreplace) = @_; - foreach (list_skels($prefix, $out_rel)) { - -d dirname($_) or !-e $_ or $force or next; +=item mageia_release($o_dir) - template2file($in, $_, %toreplace); - m|/home/(.+?)/| and chown(getpwnam($1), getgrnam($1), $_); - } +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")); } -sub update_userkderc { - my ($file, $category, %subst) = @_; - - output $file, - (map { - my $l = $_; - s/^\s*//; - if (my $i = /^\[$category\]/i ... /^\[/) { - if ($i =~ /E/) { #- for last line of category - $l = join('', map_each { "$::a=$::b\n" } %subst) . $l; - %subst = (); - } elsif (/^(\w*?)=/) { - if (my $e = delete $subst{lc($1)}) { - $l = "$1=$e\n"; - } - } - } - $l; - } cat_($file)), - (%subst && "[$category]\n", map_each { "$::a=$::b\n" } %subst); #- if category has not been found above. -} - -sub substInFile(&@) { - my $f = shift; - foreach my $file (@_) { - if (-e $file) { - local @ARGV = $file; - local ($^I, $_) = ''; - while (<>) { &$f($_); print } - } else { - local *F; my $old = select F; # that way eof return true - local $_ = ''; - &$f($_); - select $old; - eval { output($file, $_) }; - } - } + +=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; } -sub best_match { - my ($str, @lis) = @_; - my @words = split /\W+/, $str; - my ($max, $res) = 0; +=item require_root_capability() - foreach (@lis) { - my $count = 0; - foreach my $i (@words) { - $count++ if /$i/i; - } - $max = $count, $res = $_ if $count >= $max; - } - $res; +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"; } -sub bestMatchSentence { +=item check_for_xserver() - my $best = -1; - my $bestSentence; - my @s = split /\W+/, shift; - foreach (@_) { - my $count = 0; - foreach my $e (@s) { - $count++ if /$e/i; - } - $best = $count, $bestSentence = $_ if $count > $best; +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}; } - $bestSentence; + return $::xtest; } -# count the number of character that match -sub bestMatchSentence2 { +=item unpack_with_refs($format, $s) - my $best = -1; - my $bestSentence; - my @s = split /\W+/, shift; - foreach (@_) { - my $count = 0; - foreach my $e (@s) { - $count+= length ($e) if /$e/i; +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); } - $best = $count, $bestSentence = $_ if $count > $best; } - $bestSentence; + @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 typeFromMagic($@) { - my $f = shift; - local *F; sysopen F, $f, 0 or return; - - my $tmp; - M: foreach (@_) { - my ($name, @l) = @$_; - while (@l) { - my ($offset, $signature) = splice(@l, 0, 2); - sysseek(F, $offset, 0) or next M; - sysread(F, $tmp, length $signature); - $tmp eq $signature or next M; - } - return $name; - } - undef; +sub symlinkf_update_alternatives { + my ($name, $wanted_file) = @_; + run_program::rooted($::prefix, 'update-alternatives', '--set', $name, $wanted_file); } -sub availableMemory() { sum map { /(\d+)/ } grep { /^(MemTotal|SwapTotal):/ } cat_("/proc/meminfo"); } -sub availableRamMB() { - my $s = 4 * int ((stat("/proc/kcore"))[7] / 1024 / 1024 / 4 + 0.5); - #- HACK HACK: if i810 and memsize - require detect_devices; - return $s - 1 if $s == 128 && grep { $_->{driver} =~ /i810/ } detect_devices::probeall(); - $s; +sub update_gnomekderc_no_create { + my ($file, $category, %subst_) = @_; + if (-e $file) { + update_gnomekderc($file, $category, %subst_); + } } -sub setVirtual($) { - 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"; - unpack "S", $vt; +sub get_libdir() { + arch() =~ /x86_64/ ? "lib64" : "lib"; } +=item is_uefi() -sub removeXiBSuffix($) { - local $_ = shift; +Checks if we are on an uefi system - /(\d+)k$/i and return $1 * 1024; - /(\d+)M$/i and return $1 * 1024 * 1024; - /(\d+)G$/i and return $1 * 1024 * 1024 * 1024; - $_; -} +=cut -sub truncate_list { - my $nb = shift; - @_ <= $nb ? @_ : (@_[0..$nb-1], '...'); +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'; } -sub formatTime { - my ($s, $m, $h) = gmtime($_[0]); - if ($h) { - sprintf "%02d:%02d", $h, $m; - } elsif ($m > 1) { - _("%d minutes", $m); - } elsif ($m == 1) { - _("1 minute"); +=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 { - _("%d seconds", $s); + 'none'; } } -sub formatTimeRaw { - my ($s, $m, $h) = gmtime($_[0]); - sprintf "%d:%02d:%02d", $h, $m, $s; -} -#- return the size of the partition and its free space in KiB -sub df { - my ($mntpoint) = @_; - my ($blocksize, $size, $free); - my $buf = ' ' x 20000; - syscall_('statfs', $mntpoint, $buf) or return; - (undef, $blocksize, $size, $free, undef, undef) = unpack "L6", $buf; - map { $_ * ($blocksize / 1024) } $size, $free; +=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); } -sub next_val_in_array { - my ($v, $l) = @_; - my %l = mapn { @_ } $l, [ @$l[1..$#$l], $l->[0] ]; - $l{$v}; +=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 -#-###################################################################################### -#- Wonderful perl :( -#-###################################################################################### -1; # +1; |