diff options
| -rw-r--r-- | perl-install/common.pm | 270 |
1 files changed, 256 insertions, 14 deletions
diff --git a/perl-install/common.pm b/perl-install/common.pm index f1b3d3981..3945f54ce 100644 --- a/perl-install/common.pm +++ b/perl-install/common.pm @@ -1,7 +1,7 @@ package common; # $Id: common.pm 245955 2008-09-18 14:19:04Z pixel $ use MDK::Common; -use diagnostics; +se diagnostics; use strict; BEGIN { eval { require Locale::gettext } } #- allow common.pm to be used in drakxtools-backend without perl-Locale-gettext @@ -15,6 +15,11 @@ our @EXPORT = qw($SECTORSIZE N P N_ check_for_xserver files_exist formatTime MB # 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 @@ -23,17 +28,51 @@ $::prefix ||= ""; # no warning #-##################################################################################### our $SECTORSIZE = 512; -#-##################################################################################### -#- Functions -#-##################################################################################### +=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); @@ -57,6 +96,15 @@ sub translate_real { $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 @@ -64,16 +112,46 @@ sub remove_translate_context { $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) @@ -81,10 +159,15 @@ sub to_utf8 { $str; } -#- 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. +=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) { @@ -109,16 +192,48 @@ sub 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 } -#- return a size in sector -#- ie MB(1) is 2048 sectors, which is 1MB +=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; @@ -128,6 +243,20 @@ 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 presize 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; @@ -200,6 +329,12 @@ sub formatError { &MDK::Common::String::formatError($err); } +=item group_by($f, @list) + +Group the elements of @list in array references according to the $f comparaison function. + +=cut + sub group_by(&@) { my $f = shift; @_ or return; @@ -216,7 +351,14 @@ sub group_by(&@) { @l; } -# Group the list by n. Returns a reference of lists of length n +=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; @@ -224,6 +366,12 @@ sub group_n_lm { @l; } +=item join_lines(@strings) + +Concat adjacent strings if laters begin with spaces. + +=cut + sub join_lines { my @l; my $s; @@ -264,6 +412,14 @@ sub open_file { 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"; @@ -342,6 +498,20 @@ sub is_running { } } +=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")); @@ -352,6 +522,12 @@ sub parse_release_file { 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'); @@ -361,6 +537,12 @@ sub release_file { ); } +=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')); } @@ -371,22 +553,55 @@ sub parse_LDAP_namespace_structure { \%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; @@ -398,9 +613,20 @@ sub check_for_xserver() { return $::xtest; } -#- special unpack -#- - returning an array refs for each element like "s10" -#- - handling things like s10* at the end of the format +=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; @@ -420,6 +646,12 @@ sub unpack_with_refs { @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; @@ -479,6 +711,12 @@ sub update_gnomekderc_no_create { } } +=item cmp_kernel_versions($va, $vb) + +Compare two kernel versions + +=cut + sub cmp_kernel_versions { my ($va, $vb) = @_; my $rel_a = $va =~ s/-(.*)$// && $1; @@ -491,4 +729,8 @@ sub cmp_kernel_versions { $r || $rel_a <=> $rel_b || $rel_a cmp $rel_b; } +=back + +=cut + 1; |