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.pm362
1 files changed, 275 insertions, 87 deletions
diff --git a/perl-install/common.pm b/perl-install/common.pm
index 1abba61e4..f0dcacff3 100644
--- a/perl-install/common.pm
+++ b/perl-install/common.pm
@@ -1,15 +1,16 @@
-package common; # $Id$
+package common; # $Id: common.pm 245955 2008-09-18 14:19:04Z pixel $
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 is_xbox makedev mandrake_release removeXiBSuffix require_root_capability salt setVirtual set_alternative set_l10n_sort 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_parent_uid is_running 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;
@@ -26,84 +27,76 @@ our $SECTORSIZE = 512;
#- Functions
#-#####################################################################################
-
-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, @_;
+sub P {
+ my ($s_singular, $s_plural, $nb, @para) = @_;
+ sprintf(translate($s_singular, $s_plural, $nb), @para);
}
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);
}
sub N_ { $_[0] }
-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;
-}
-
sub makedev { ($_[0] << 8) | $_[1] }
sub unmakedev { $_[0] >> 8, $_[0] & 0xff }
sub translate_real {
- my ($s) = @_;
+ my ($s, $o_plural, $o_nb) = @_;
$s or return '';
+ my $s2;
foreach (@::textdomains, 'libDrakX') {
- my $s2 = c::dgettext($_, $s);
- return $s2 if $s ne $s2;
+ 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 $s ne $s2 && $s2 ne $o_plural;
}
- $s;
+ # didn't lookup anything or locale is "C":
+ $s2;
}
-sub translate {
- my $s = translate_real(@_);
- $::need_utf8_i18n and c::set_tagged_utf8($s);
-
+sub remove_translate_context {
+ my ($s) = @_;
#- translation with context, kde-like
- $s =~ s/^_:.*\n//;
+ $s =~ s/^_:.*(?:\n)?//g;
$s;
}
+sub translate {
+ my $s = translate_real(@_);
+ $::one_message_has_been_translated ||= join(':', (caller(1))[1,2]); #- see mygtk3.pm
+ remove_translate_context($s);
+}
-sub untranslate {
- my $s = shift || return;
- foreach (@_) { translate($_) eq $s and return $_ }
- die "untranslate failed";
+sub from_utf8 {
+ my ($s) = @_;
+ Locale::gettext::iconv($s, "utf-8", undef); #- undef = locale charmap = nl_langinfo(CODESET)
+}
+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;
}
-#- This is needed because text printed by Gtk2 will always be encoded
+#- This is needed because text printed by 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.
sub set_l10n_sort() {
my $collation_locale = $ENV{LC_ALL};
if (!$collation_locale) {
- require POSIX;
- $collation_locale = POSIX::setlocale(POSIX::LC_COLLATE());
- $collation_locale =~ /UTF-8/ or POSIX::setlocale(POSIX::LC_COLLATE(), "$collation_locale.UTF-8");
+ $collation_locale = c::setlocale(c::LC_COLLATE());
+ $collation_locale =~ /UTF-8/ or c::setlocale(c::LC_COLLATE(), "$collation_locale.UTF-8");
}
}
-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 && detect_devices::matching_driver__regexp('^Card:Intel 810$');
- $s;
-}
-
sub setVirtual {
my ($vt_number) = @_;
my $vt = '';
@@ -116,7 +109,14 @@ 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: $!";
+}
+
+#- return a size in sector
+#- ie MB(1) is 2048 sectors, which is 1MB
+sub MB {
+ my ($nb_MB) = @_;
+ $nb_MB * 2048;
}
sub removeXiBSuffix {
@@ -131,20 +131,24 @@ sub removeXiBSuffix {
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 {
@@ -160,6 +164,21 @@ sub formatTime {
}
}
+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);
@@ -181,6 +200,22 @@ sub formatError {
&MDK::Common::String::formatError($err);
}
+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;
+}
+
# Group the list by n. Returns a reference of lists of length n
sub group_n_lm {
my $n = shift;
@@ -204,6 +239,12 @@ sub join_lines {
}
+sub read_alternative {
+ my ($name) = @_;
+ my $alt = readlink("$::prefix/etc/alternatives/$name");
+ $alt && $::prefix . $alt;
+}
+
sub set_alternative {
my ($command, $executable) = @_;
@@ -217,52 +258,133 @@ sub set_alternative {
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 };
+}
+
+# FIXME: callers should just use mkstemp in /tmp instead of relying on $TMPDIR || $ENV{HOME}/tmp
+# or we should just move the choice of directoyr 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 not 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;
+ }
+}
+
+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 release_file {
my ($o_dir) = @_;
- find { -r "$o_dir$_" } map { "/etc/$_" } 'mandrakelinux-release', 'mandrake-release', 'release', 'redhat-release';
+ 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 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;
+}
+
+sub mageia_release {
+ my ($o_dir) = @_;
+ my $f = release_file($o_dir);
+ $f && chomp_(cat_("$o_dir$f"));
}
-sub mandrake_release() {
- chomp_(cat_(release_file()));
+sub get_parent_uid() {
+ cat_('/proc/' . getppid() . '/status') =~ /Uid:\s*(\d+)/ ? $1 : undef;
}
sub require_root_capability() {
return if $::testing || !$>; # we're already root
- if (check_for_xserver()) {
- if (fuzzy_pidofs(qr/\bkwin\b/) > 0) {
- exec("kdesu", "--ignorebutton", "-c", "$0 @ARGV") or die N("kdesu missing");
- }
- }
- exec { 'consolehelper' } $0, @ARGV or die N("consolehelper missing");
- # still not root ?
- die "you must be root to run this program" if $>;
+ die "you must be root to run this program";
}
sub check_for_xserver() {
@@ -276,11 +398,6 @@ sub check_for_xserver() {
return $::xtest;
}
-sub is_xbox() {
- require detect_devices;
- any { $_->{vendor} == 0x10de && $_->{id} == 0x02a5 } detect_devices::pci_probe();
-}
-
#- special unpack
#- - returning an array refs for each element like "s10"
#- - handling things like s10* at the end of the format
@@ -303,4 +420,75 @@ sub unpack_with_refs {
@r;
}
+#- 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 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;
+}
+
1;
generated by cgit v1.2.1 (git 2.21.0) at 2025-10-26 17:35:41 +0000