| 1 |
package common; # $Id: common.pm 245955 2008-09-18 14:19:04Z pixel $ |
| 2 |
|
| 3 |
use MDK::Common; |
| 4 |
use diagnostics; |
| 5 |
use strict; |
| 6 |
BEGIN { eval { require Locale::gettext } } #- allow common.pm to be used in drakxtools-backend without perl-Locale-gettext |
| 7 |
|
| 8 |
use log; |
| 9 |
use run_program; |
| 10 |
|
| 11 |
use Exporter; |
| 12 |
our @ISA = qw(Exporter); |
| 13 |
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); |
| 14 |
|
| 15 |
# perl_checker: RE-EXPORT-ALL |
| 16 |
push @EXPORT, @MDK::Common::EXPORT; |
| 17 |
|
| 18 |
|
| 19 |
$::prefix ||= ""; # no warning |
| 20 |
|
| 21 |
#-##################################################################################### |
| 22 |
#- Globals |
| 23 |
#-##################################################################################### |
| 24 |
our $SECTORSIZE = 512; |
| 25 |
|
| 26 |
#-##################################################################################### |
| 27 |
#- Functions |
| 28 |
#-##################################################################################### |
| 29 |
|
| 30 |
sub P { |
| 31 |
my ($s_singular, $s_plural, $nb, @para) = @_; |
| 32 |
sprintf(translate($s_singular, $s_plural, $nb), @para); |
| 33 |
} |
| 34 |
|
| 35 |
sub N { |
| 36 |
my ($s, @para) = @_; |
| 37 |
sprintf(translate($s), @para); |
| 38 |
} |
| 39 |
sub N_ { $_[0] } |
| 40 |
|
| 41 |
|
| 42 |
sub makedev { ($_[0] << 8) | $_[1] } |
| 43 |
sub unmakedev { $_[0] >> 8, $_[0] & 0xff } |
| 44 |
|
| 45 |
sub translate_real { |
| 46 |
my ($s, $o_plural, $o_nb) = @_; |
| 47 |
$s or return ''; |
| 48 |
my $s2; |
| 49 |
foreach (@::textdomains, 'libDrakX') { |
| 50 |
if ($o_plural) { |
| 51 |
$s2 = Locale::gettext::dngettext($_, $s, $o_plural, $o_nb); |
| 52 |
} else { |
| 53 |
$s2 = Locale::gettext::dgettext($_, $s); |
| 54 |
} |
| 55 |
# when utf8 pragma is in use, Locale::gettext() returns an utf8 string not tagged as such: |
| 56 |
c::set_tagged_utf8($s2) if !utf8::is_utf8($s2) && utf8::is_utf8($s); |
| 57 |
return $s2 if $s ne $s2 && $s2 ne $o_plural; |
| 58 |
} |
| 59 |
# didn't lookup anything or locale is "C": |
| 60 |
$s2; |
| 61 |
} |
| 62 |
|
| 63 |
sub remove_translate_context { |
| 64 |
my ($s) = @_; |
| 65 |
#- translation with context, kde-like |
| 66 |
$s =~ s/^_:.*\n//; |
| 67 |
$s; |
| 68 |
} |
| 69 |
|
| 70 |
sub translate { |
| 71 |
my $s = translate_real(@_); |
| 72 |
$::one_message_has_been_translated ||= join(':', (caller(1))[1,2]); #- see mygtk2.pm |
| 73 |
remove_translate_context($s); |
| 74 |
} |
| 75 |
|
| 76 |
sub from_utf8 { |
| 77 |
my ($s) = @_; |
| 78 |
Locale::gettext::iconv($s, "utf-8", undef); #- undef = locale charmap = nl_langinfo(CODESET) |
| 79 |
} |
| 80 |
sub to_utf8 { |
| 81 |
my ($s) = @_; |
| 82 |
my $str = Locale::gettext::iconv($s, undef, "utf-8"); #- undef = locale charmap = nl_langinfo(CODESET) |
| 83 |
c::set_tagged_utf8($str); |
| 84 |
$str; |
| 85 |
} |
| 86 |
|
| 87 |
#- This is needed because text printed by Gtk2 will always be encoded |
| 88 |
#- in UTF-8; |
| 89 |
#- we first check if LC_ALL is defined, because if it is, changing |
| 90 |
#- only LC_COLLATE will have no effect. |
| 91 |
sub set_l10n_sort() { |
| 92 |
my $collation_locale = $ENV{LC_ALL}; |
| 93 |
if (!$collation_locale) { |
| 94 |
$collation_locale = c::setlocale(c::LC_COLLATE()); |
| 95 |
$collation_locale =~ /UTF-8/ or c::setlocale(c::LC_COLLATE(), "$collation_locale.UTF-8"); |
| 96 |
} |
| 97 |
} |
| 98 |
|
| 99 |
|
| 100 |
sub setVirtual { |
| 101 |
my ($vt_number) = @_; |
| 102 |
my $vt = ''; |
| 103 |
sysopen(my $C, "/dev/console", 2) or die "failed to open /dev/console: $!"; |
| 104 |
ioctl($C, c::VT_GETSTATE(), $vt) && |
| 105 |
ioctl($C, c::VT_ACTIVATE(), $vt_number) && |
| 106 |
ioctl($C, c::VT_WAITACTIVE(), $vt_number) or die "setVirtual failed"; |
| 107 |
unpack "S", $vt; |
| 108 |
} |
| 109 |
|
| 110 |
sub nonblock { |
| 111 |
my ($F) = @_; |
| 112 |
fcntl($F, c::F_SETFL(), fcntl($F, c::F_GETFL(), 0) | c::O_NONBLOCK()) or die "cannot fcntl F_SETFL: $!"; |
| 113 |
} |
| 114 |
|
| 115 |
#- return a size in sector |
| 116 |
#- ie MB(1) is 2048 sectors, which is 1MB |
| 117 |
sub MB { |
| 118 |
my ($nb_MB) = @_; |
| 119 |
$nb_MB * 2048; |
| 120 |
} |
| 121 |
|
| 122 |
sub removeXiBSuffix { |
| 123 |
local $_ = shift; |
| 124 |
|
| 125 |
/(\d+)\s*kB?$/i and return $1 * 1024; |
| 126 |
/(\d+)\s*MB?$/i and return $1 * 1024 * 1024; |
| 127 |
/(\d+)\s*GB?$/i and return $1 * 1024 * 1024 * 1024; |
| 128 |
/(\d+)\s*TB?$/i and return $1 * 1024 * 1024 * 1024 * 1024; |
| 129 |
$_; |
| 130 |
} |
| 131 |
sub formatXiB { |
| 132 |
my ($newnb, $o_newbase) = @_; |
| 133 |
my $newbase = $o_newbase || 1; |
| 134 |
my $sign = $newnb < 0 ? -1 : 1; |
| 135 |
$newnb = abs(int($newnb)); |
| 136 |
my ($nb, $base); |
| 137 |
my $decr = sub { |
| 138 |
($nb, $base) = ($newnb, $newbase); |
| 139 |
$base >= 1024 ? ($newbase = $base / 1024) : ($newnb = $nb / 1024); |
| 140 |
}; |
| 141 |
my $suffix; |
| 142 |
foreach (N("B"), N("KB"), N("MB"), N("GB"), N("TB")) { |
| 143 |
$decr->(); |
| 144 |
if ($newnb < 1 && $newnb * $newbase < 1) { |
| 145 |
$suffix = $_; |
| 146 |
last; |
| 147 |
} |
| 148 |
} |
| 149 |
my $v = $nb * $base; |
| 150 |
my $s = $v < 10 && int(10 * $v - 10 * int($v)); |
| 151 |
int($v * $sign) . ($s ? "." . abs($s) : '') . ($suffix || N("TB")); |
| 152 |
} |
| 153 |
|
| 154 |
sub formatTime { |
| 155 |
my ($s, $m, $h) = gmtime($_[0]); |
| 156 |
if ($h) { |
| 157 |
sprintf "%02d:%02d", $h, $m; |
| 158 |
} elsif ($m > 1) { |
| 159 |
N("%d minutes", $m); |
| 160 |
} elsif ($m == 1) { |
| 161 |
N("1 minute"); |
| 162 |
} else { |
| 163 |
N("%d seconds", $s); |
| 164 |
} |
| 165 |
} |
| 166 |
|
| 167 |
sub expand_symlinks_with_absolute_symlinks_in_prefix { |
| 168 |
my ($prefix, $link) = @_; |
| 169 |
|
| 170 |
my ($first, @l) = split '/', $link; |
| 171 |
$first eq '' or die "expand_symlinks: $link is relative\n"; |
| 172 |
my ($f, $l); |
| 173 |
foreach (@l) { |
| 174 |
$f .= "/$_"; |
| 175 |
while ($l = readlink "$prefix$f") { |
| 176 |
$f = $l =~ m!^/! ? $l : MDK::Common::File::concat_symlink($f, "../$l"); |
| 177 |
} |
| 178 |
} |
| 179 |
"$prefix$f"; |
| 180 |
} |
| 181 |
|
| 182 |
sub expand_symlinks_but_simple { |
| 183 |
my ($f) = @_; |
| 184 |
my $link = readlink($f); |
| 185 |
my $f2 = expand_symlinks($f); |
| 186 |
if ($link && $link !~ m|/|) { |
| 187 |
# put back the last simple symlink |
| 188 |
$f2 =~ s|\Q$link\E$|basename($f)|e; |
| 189 |
} |
| 190 |
$f2; |
| 191 |
} |
| 192 |
|
| 193 |
sub sync { &MDK::Common::System::sync } |
| 194 |
|
| 195 |
BEGIN { undef *formatError } |
| 196 |
sub formatError { |
| 197 |
my ($err) = @_; |
| 198 |
ref($err) eq 'SCALAR' and $err = $$err; |
| 199 |
log::l("error: $err"); |
| 200 |
&MDK::Common::String::formatError($err); |
| 201 |
} |
| 202 |
|
| 203 |
sub group_by(&@) { |
| 204 |
my $f = shift; |
| 205 |
@_ or return; |
| 206 |
my $e = shift; |
| 207 |
my @l = my $last_l = [$e]; |
| 208 |
foreach (@_) { |
| 209 |
if ($f->($e, $_)) { |
| 210 |
push @$last_l, $_; |
| 211 |
} else { |
| 212 |
push @l, $last_l = [$_]; |
| 213 |
$e = $_; |
| 214 |
} |
| 215 |
} |
| 216 |
@l; |
| 217 |
} |
| 218 |
|
| 219 |
# Group the list by n. Returns a reference of lists of length n |
| 220 |
sub group_n_lm { |
| 221 |
my $n = shift; |
| 222 |
my @l; |
| 223 |
push @l, [ splice(@_, 0, $n) ] while @_; |
| 224 |
@l; |
| 225 |
} |
| 226 |
|
| 227 |
sub join_lines { |
| 228 |
my @l; |
| 229 |
my $s; |
| 230 |
foreach (@_) { |
| 231 |
if (/^\s/) { |
| 232 |
$s .= $_; |
| 233 |
} else { |
| 234 |
push @l, $s if $s; |
| 235 |
$s = $_; |
| 236 |
} |
| 237 |
} |
| 238 |
@l, if_($s, $s); |
| 239 |
} |
| 240 |
|
| 241 |
|
| 242 |
sub read_alternative { |
| 243 |
my ($name) = @_; |
| 244 |
my $alt = readlink("$::prefix/etc/alternatives/$name"); |
| 245 |
$alt && $::prefix . $alt; |
| 246 |
} |
| 247 |
|
| 248 |
sub set_alternative { |
| 249 |
my ($command, $executable) = @_; |
| 250 |
|
| 251 |
#- check the existance of $executable as an alternative for $command |
| 252 |
#- (is this needed???) |
| 253 |
run_program::rooted_get_stdout($::prefix, 'update-alternatives', '--display', $command) =~ /^\Q$executable /m or return; |
| 254 |
|
| 255 |
#- this does not handle relative symlink, but neither does update-alternatives ;p |
| 256 |
symlinkf $executable, "$::prefix/etc/alternatives/$command"; |
| 257 |
} |
| 258 |
|
| 259 |
sub files_exist { and_(map { -f "$::prefix$_" } @_) } |
| 260 |
|
| 261 |
sub open_file { |
| 262 |
my ($file) = @_; |
| 263 |
my $F; |
| 264 |
open($F, $file) ? $F : do { log::l("Cannot open $file: $!"); undef }; |
| 265 |
} |
| 266 |
|
| 267 |
# FIXME: callers should just use mkstemp in /tmp instead of relying on $TMPDIR || $ENV{HOME}/tmp |
| 268 |
# or we should just move the choice of directoyr from callers to here: |
| 269 |
# my $tmpdir = find { -d $_ } $ENV{TMPDIR}, "$ENV{HOME}/tmp", "$::prefix/tmp"; |
| 270 |
sub secured_file { |
| 271 |
my ($f) = @_; |
| 272 |
my $d = dirname($f); |
| 273 |
if (! -d $d) { |
| 274 |
mkdir_p($d); |
| 275 |
if ($d =~ /^$ENV{HOME}/) { |
| 276 |
my ($user) = grep { $_->[7] eq $ENV{HOME} } list_passwd(); |
| 277 |
chown($user->[2], $user->[3], $d); |
| 278 |
} |
| 279 |
} |
| 280 |
c::is_secure_file($f) or die "cannot ensure a safe $f"; |
| 281 |
$f; |
| 282 |
} |
| 283 |
|
| 284 |
sub unwind_protect { |
| 285 |
my ($to_do, $cleanup) = @_; |
| 286 |
my @l = eval { $to_do->() }; |
| 287 |
my $err = $@; |
| 288 |
$cleanup->(); |
| 289 |
$err and die $err; |
| 290 |
wantarray() ? @l : $l[0]; |
| 291 |
} |
| 292 |
|
| 293 |
sub with_private_tmp_file { |
| 294 |
my ($file, $content, $f) = @_; |
| 295 |
|
| 296 |
my $prev_umask = umask 077; |
| 297 |
|
| 298 |
unwind_protect(sub { |
| 299 |
MDK::Common::File::secured_output($file, $content); |
| 300 |
$f->($file); |
| 301 |
}, sub { |
| 302 |
umask $prev_umask; |
| 303 |
unlink $file; |
| 304 |
}); |
| 305 |
} |
| 306 |
|
| 307 |
sub chown_ { |
| 308 |
my ($b_recursive, $name, $group, @files) = @_; |
| 309 |
|
| 310 |
my ($uid, $gid) = (getpwnam($name) || $name, getgrnam($group) || $group); |
| 311 |
|
| 312 |
require POSIX; |
| 313 |
my $chown; $chown = sub { |
| 314 |
foreach (@_) { |
| 315 |
POSIX::lchown($uid, $gid, $_) or die "chown of file $_ failed: $!\n"; |
| 316 |
! -l $_ && -d $_ && $b_recursive and &$chown(glob_($_)); |
| 317 |
} |
| 318 |
}; |
| 319 |
$chown->(@files); |
| 320 |
} |
| 321 |
|
| 322 |
|
| 323 |
sub set_permissions { |
| 324 |
my ($file, $perms, $o_owner, $o_group) = @_; |
| 325 |
# We only need to set the permissions during installation to be able to |
| 326 |
# print test pages. After installation udev does the business automatically. |
| 327 |
return 1 unless $::isInstall; |
| 328 |
if ($o_owner || $o_group) { |
| 329 |
$o_owner ||= (lstat($file))[4]; |
| 330 |
$o_group ||= (lstat($file))[5]; |
| 331 |
chown_(0, $o_owner, $o_group, $file); |
| 332 |
} |
| 333 |
chmod(oct($perms), $file) or die "chmod of file $file failed: $!\n"; |
| 334 |
} |
| 335 |
|
| 336 |
sub is_running { |
| 337 |
my ($name, $o_user) = @_; |
| 338 |
my $user = $o_user || $ENV{USER}; |
| 339 |
foreach (`ps -o '%P %p %c' -u $user`) { |
| 340 |
my ($ppid, $pid, $n) = /^\s*(\d+)\s+(\d+)\s+(.*)/; |
| 341 |
return $pid if $ppid != 1 && $pid != $$ && $n eq $name; |
| 342 |
} |
| 343 |
} |
| 344 |
|
| 345 |
sub parse_release_file { |
| 346 |
my ($prefix, $f, $part) = @_; |
| 347 |
chomp(my $s = cat_("$prefix$f")); |
| 348 |
my $version = $s =~ s/\s+release\s+(\S+)// && $1; |
| 349 |
my $arch = $s =~ s/\s+for\s+(\S+)// && $1; |
| 350 |
log::l("find_root_parts found $part->{device}: $s for $arch" . ($f !~ m!/etc/! ? " in special release file $f" : '')); |
| 351 |
{ release => $s, version => $version, |
| 352 |
release_file => $f, part => $part, 'arch' => $arch }; |
| 353 |
} |
| 354 |
|
| 355 |
sub release_file { |
| 356 |
my ($o_dir) = @_; |
| 357 |
my @names = ('mageia-release', 'mandriva-release', 'mandrakelinux-release', 'mandrake-release', 'conectiva-release', 'release', 'redhat-release', 'fedora-release', 'SuSE-release'); |
| 358 |
find { -r "$o_dir$_" } ( |
| 359 |
(map { "/root/drakx/$_.upgrading" } @names), |
| 360 |
(map { "/etc/$_" } @names), |
| 361 |
); |
| 362 |
} |
| 363 |
|
| 364 |
sub mageia_release_info() { |
| 365 |
parse_LDAP_namespace_structure(cat_('/etc/product.id')); |
| 366 |
} |
| 367 |
|
| 368 |
sub parse_LDAP_namespace_structure { |
| 369 |
my ($s) = @_; |
| 370 |
my %h = map { if_(/(.*?)=(.*)/, $1 => $2) } split(',', $s); |
| 371 |
\%h; |
| 372 |
} |
| 373 |
|
| 374 |
sub mageia_release { |
| 375 |
my ($o_dir) = @_; |
| 376 |
my $f = release_file($o_dir); |
| 377 |
$f && chomp_(cat_("$o_dir$f")); |
| 378 |
} |
| 379 |
|
| 380 |
sub get_parent_uid() { |
| 381 |
cat_('/proc/' . getppid() . '/status') =~ /Uid:\s*(\d+)/ ? $1 : undef; |
| 382 |
} |
| 383 |
|
| 384 |
sub wrap_command_for_root { |
| 385 |
my ($name, @args) = @_; |
| 386 |
([ 'consolehelper', $name ], @args); |
| 387 |
} |
| 388 |
|
| 389 |
sub require_root_capability() { |
| 390 |
return if $::testing || !$>; # we're already root |
| 391 |
|
| 392 |
my ($command, @args) = wrap_command_for_root($0, @ARGV); |
| 393 |
exec { $command->[0] } $command->[1], @args or die N("command %s missing", $command->[0]); |
| 394 |
|
| 395 |
# still not root ? |
| 396 |
die "you must be root to run this program" if $>; |
| 397 |
} |
| 398 |
|
| 399 |
sub check_for_xserver() { |
| 400 |
if (!defined $::xtest) { |
| 401 |
$::xtest = 0; |
| 402 |
eval { |
| 403 |
require xf86misc::main; |
| 404 |
$::xtest = xf86misc::main::Xtest($ENV{DISPLAY}); |
| 405 |
} if $ENV{DISPLAY}; |
| 406 |
} |
| 407 |
return $::xtest; |
| 408 |
} |
| 409 |
|
| 410 |
#- special unpack |
| 411 |
#- - returning an array refs for each element like "s10" |
| 412 |
#- - handling things like s10* at the end of the format |
| 413 |
sub unpack_with_refs { |
| 414 |
my ($format, $s) = @_; |
| 415 |
my $initial_format = $format; |
| 416 |
my @r; |
| 417 |
while ($format =~ s/\s*(\w(\d*))(\*?)\s*//) { |
| 418 |
my ($sub_format, $nb, $many) = ($1, $2, $3); |
| 419 |
$many && $format and internal_error("bad * in the middle of format in $initial_format"); |
| 420 |
|
| 421 |
my $done = $many && !length($s); |
| 422 |
while (!$done) { |
| 423 |
my @l = unpack("$sub_format a*", $s); |
| 424 |
$s = pop @l; |
| 425 |
push @r, $nb ? \@l : @l; |
| 426 |
$done = !$many || !length($s); |
| 427 |
} |
| 428 |
} |
| 429 |
@r; |
| 430 |
} |
| 431 |
|
| 432 |
#- used in userdrake and mdkonline |
| 433 |
sub md5file { |
| 434 |
require Digest::MD5; |
| 435 |
my @md5 = map { |
| 436 |
my $sum; |
| 437 |
if (open(my $FILE, $_)) { |
| 438 |
binmode($FILE); |
| 439 |
$sum = Digest::MD5->new->addfile($FILE)->hexdigest; |
| 440 |
close($FILE); |
| 441 |
} |
| 442 |
$sum; |
| 443 |
} @_; |
| 444 |
return wantarray() ? @md5 : $md5[0]; |
| 445 |
} |
| 446 |
|
| 447 |
sub load_modules_from_base { |
| 448 |
my ($base) = @_; |
| 449 |
$base =~ s|::|/|g; |
| 450 |
my $base_file = $base . ".pm"; |
| 451 |
require $base_file; |
| 452 |
my ($inc_path) = substr($INC{$base_file}, 0, -length($base_file)); |
| 453 |
my @files = map { substr($_, length($inc_path)) } glob_($inc_path . $base . '/*.pm'); |
| 454 |
require $_ foreach @files; |
| 455 |
#- return the matching modules list |
| 456 |
map { local $_ = $_; s|/|::|g; s|\.pm$||g; $_ } @files; |
| 457 |
} |
| 458 |
|
| 459 |
sub get_alternatives { |
| 460 |
my ($name) = @_; |
| 461 |
|
| 462 |
my $dir = $::prefix . '/var/lib/rpm/alternatives'; |
| 463 |
my ($state, $main_link, @l) = chomp_(cat_("$dir/$name")) or return; |
| 464 |
my @slaves; |
| 465 |
while (@l && $l[0] ne '') { |
| 466 |
my ($name, $link) = splice(@l, 0, 2); |
| 467 |
push @slaves, { name => $name, link => $link }; |
| 468 |
} |
| 469 |
shift @l; #- empty line |
| 470 |
my @alternatives; |
| 471 |
while (@l && $l[0] ne '') { |
| 472 |
my ($file, $weight, @slave_files) = splice(@l, 0, 2 + @slaves); |
| 473 |
|
| 474 |
push @alternatives, { file => $file, weight => $weight, slave_files => \@slave_files }; |
| 475 |
} |
| 476 |
{ name => $name, link => $main_link, state => $state, slaves => \@slaves, alternatives => \@alternatives }; |
| 477 |
} |
| 478 |
|
| 479 |
sub symlinkf_update_alternatives { |
| 480 |
my ($name, $wanted_file) = @_; |
| 481 |
run_program::rooted($::prefix, 'update-alternatives', '--set', $name, $wanted_file); |
| 482 |
} |
| 483 |
|
| 484 |
sub update_gnomekderc_no_create { |
| 485 |
my ($file, $category, %subst_) = @_; |
| 486 |
if (-e $file) { |
| 487 |
update_gnomekderc($file, $category, %subst_); |
| 488 |
} |
| 489 |
} |
| 490 |
|
| 491 |
sub cmp_kernel_versions { |
| 492 |
my ($va, $vb) = @_; |
| 493 |
my $rel_a = $va =~ s/-(.*)$// && $1; |
| 494 |
my $rel_b = $vb =~ s/-(.*)$// && $1; |
| 495 |
($va, $vb) = map { [ split /[.-]/ ] } $va, $vb; |
| 496 |
my $r = 0; |
| 497 |
mapn_ { |
| 498 |
$r ||= $_[0] <=> $_[1]; |
| 499 |
} $va, $vb; |
| 500 |
$r || $rel_a <=> $rel_b || $rel_a cmp $rel_b; |
| 501 |
} |
| 502 |
|
| 503 |
1; |
Parent Directory
| 
Revision Log