package common; use MDK::Common; 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 Exporter; our @ISA = qw(Exporter); our @EXPORT = qw($SECTORSIZE N P N_ check_for_xserver files_exist formatTime MB formatXiB get_parent_uid is_mgalive is_running is_uefi makedev mageia_release mageia_release_info removeXiBSuffix require_root_capability setVirtual set_alternative set_l10n_sort set_permissions to_utf8 translate 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 #-##################################################################################### our $SECTORSIZE = 512; =head1 Functions =head2 Translating =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 { 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) 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 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) = @_; 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 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; } =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 = ''; 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; /(\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]) 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); }; 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")); } sub formatTime { my ($s, $m, $h) = gmtime($_[0]); if ($h) { sprintf "%02d:%02d", $h, $m; } elsif ($m > 1) { N("%d minutes", $m); } elsif ($m == 1) { N("1 minute"); } else { N("%d seconds", $s); } } 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) = @_; 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; } $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); } =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 xf86misc::main; $::xtest = xf86misc::main::Xtest($ENV{DISPLAY}); } 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_); } } =item is_mgalive() Checks if we are in mga live mode =cut sub is_mgalive { -e "/run/mgalive" } =item is_uefi() Checks if we are on an uefi system =cut sub is_uefi { -e "/sys/firmware/efi" } =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;