summaryrefslogtreecommitdiffstats
path: root/lib
diff options
context:
space:
mode:
Diffstat (limited to 'lib')
-rw-r--r--lib/MDK/Common.pm.pl79
-rw-r--r--lib/MDK/Common/DataStructure.pm178
-rw-r--r--lib/MDK/Common/File.pm332
-rw-r--r--lib/MDK/Common/Func.pm333
-rw-r--r--lib/MDK/Common/Math.pm197
-rw-r--r--lib/MDK/Common/String.pm164
-rw-r--r--lib/MDK/Common/System.pm478
-rw-r--r--lib/MDK/Common/Various.pm140
8 files changed, 1901 insertions, 0 deletions
diff --git a/lib/MDK/Common.pm.pl b/lib/MDK/Common.pm.pl
new file mode 100644
index 0000000..7897e1b
--- /dev/null
+++ b/lib/MDK/Common.pm.pl
@@ -0,0 +1,79 @@
+
+
+print <<'EOF';
+package MDK::Common;
+
+=head1 NAME
+
+MDK::Common - miscellaneous functions
+
+=head1 SYNOPSIS
+
+ use MDK::Common;
+ # exports all functions, equivalent to
+
+ use MDK::Common::DataStructure qw(:all);
+ use MDK::Common::File qw(:all);
+ use MDK::Common::Func qw(:all);
+ use MDK::Common::Math qw(:all);
+ use MDK::Common::String qw(:all);
+ use MDK::Common::System qw(:all);
+ use MDK::Common::Various qw(:all);
+
+=head1 DESCRIPTION
+
+C<MDK::Common> is a collection of packages containing various simple functions:
+L<MDK::Common::DataStructure>,
+L<MDK::Common::File>,
+L<MDK::Common::Func>,
+L<MDK::Common::Math>,
+L<MDK::Common::String>,
+L<MDK::Common::System>,
+L<MDK::Common::Various>.
+
+EOF
+
+foreach my $f (<MDK/Common/*.pm>) {
+ (my $pkg = $f) =~ s|/|::|g;
+ open F, $f or die "can't open file $f";
+ my $line;
+ while (<F>) {
+ $line++;
+ if (/^=head1 (EXPORTS|OTHER)/ .. /^=back/) {
+ s/^=head1 EXPORTS/=head1 EXPORTS from $pkg/;
+ s/^=head1 OTHER/=head1 OTHER in $pkg/;
+ s/^=back/=back\n/;
+ /^\s+\n/ and warn "$f:$line: spaces only line\n";
+ print;
+ }
+ }
+}
+
+
+print <<'EOF';
+=head1 COPYRIGHT
+
+Copyright (c) 2001-2005 Mandriva <pixel@mandriva.com>. All rights reserved.
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=cut
+
+
+use MDK::Common::DataStructure qw(:all);
+use MDK::Common::File qw(:all);
+use MDK::Common::Func qw(:all);
+use MDK::Common::Math qw(:all);
+use MDK::Common::String qw(:all);
+use MDK::Common::System qw(:all);
+use MDK::Common::Various qw(:all);
+
+use Exporter;
+our @ISA = qw(Exporter);
+# perl_checker: RE-EXPORT-ALL
+our @EXPORT = map { @$_ } map { values %{'MDK::Common::' . $_ . 'EXPORT_TAGS'} } grep { /::$/ } keys %MDK::Common::;
+
+our $VERSION = "1.2.4";
+
+1;
+EOF
diff --git a/lib/MDK/Common/DataStructure.pm b/lib/MDK/Common/DataStructure.pm
new file mode 100644
index 0000000..79e4aa0
--- /dev/null
+++ b/lib/MDK/Common/DataStructure.pm
@@ -0,0 +1,178 @@
+package MDK::Common::DataStructure;
+
+=head1 NAME
+
+MDK::Common::DataStructure - miscellaneous list/hash manipulation functions
+
+=head1 SYNOPSIS
+
+ use MDK::Common::DataStructure qw(:all);
+
+=head1 EXPORTS
+
+=over
+
+=item sort_numbers(LIST)
+
+numerical sort (small numbers at beginning)
+
+=item ikeys(HASH)
+
+aka I<sorted integer keys>, as simple as C<sort { $a E<lt>=E<gt> $b } keys>
+
+=item add2hash(HASH REF, HASH REF)
+
+adds to the first hash the second hash if the key/value is not already there
+
+=item add2hash_
+
+adds to the first hash the second hash if the key is not already there
+
+=item put_in_hash
+
+adds to the first hash the second hash, crushing existing key/values
+
+=item member(SCALAR, LIST)
+
+is the value in the list?
+
+=item invbool(SCALAR REF)
+
+toggles the boolean value
+
+=item listlength(LIST)
+
+returns the length of the list. Useful in list (opposed to array) context:
+
+ sub f { "a", "b" }
+ my $l = listlength f();
+
+whereas C<scalar f()> would return "b"
+
+=item deref(REF)
+
+de-reference
+
+=item deref_array(REF)
+
+de-reference arrays:
+
+ deref_array [ "a", "b" ] #=> ("a", "b")
+ deref_array "a" #=> "a"
+
+=item is_empty_array_ref(SCALAR)
+
+is the scalar undefined or is the array empty
+
+=item is_empty_hash_ref(SCALAR)
+
+is the scalar undefined or is the hash empty
+
+=item uniq(LIST)
+
+returns the list with no duplicates (keeping the first elements)
+
+=item uniq_ { CODE } LIST
+
+returns the list with no duplicates according to the scalar results of CODE on each element of LIST (keeping the first elements)
+
+ uniq_ { $_->[1] } [ 1, "fo" ], [ 2, "fob" ], [ 3, "fo" ], [ 4, "bar" ]
+
+gives [ 1, "fo" ], [ 2, "fob" ], [ 4, "bar" ]
+
+=item difference2(ARRAY REF, ARRAY REF)
+
+returns the first list without the element of the second list
+
+=item intersection(ARRAY REF, ARRAY REF, ...)
+
+returns the elements which are in all lists
+
+=item next_val_in_array(SCALAR, ARRAY REF)
+
+finds the value that follow the scalar in the list (circular):
+C<next_val_in_array(3, [1, 2, 3])> gives C<1>
+(do not use a list with duplicates)
+
+=item group_by2(LIST)
+
+interprets the list as an ordered hash, returns a list of [key,value]:
+C<group_by2(1 => 2, 3 => 4, 5 => 6)> gives C<[1,2], [3,4], [5,6]>
+
+=item list2kv(LIST)
+
+interprets the list as an ordered hash, returns the keys and the values:
+C<list2kv(1 => 2, 3 => 4, 5 => 6)> gives C<[1,3,5], [2,4,6]>
+
+=back
+
+=head1 SEE ALSO
+
+L<MDK::Common>
+
+=cut
+
+
+use MDK::Common::Math;
+use MDK::Common::Func;
+
+
+use Exporter;
+our @ISA = qw(Exporter);
+our @EXPORT_OK = qw(sort_numbers ikeys add2hash add2hash_ put_in_hash member invbool listlength deref deref_array is_empty_array_ref is_empty_hash_ref uniq uniq_ difference2 intersection next_val_in_array group_by2 list2kv);
+our %EXPORT_TAGS = (all => [ @EXPORT_OK ]);
+
+
+sub sort_numbers { sort { $a <=> $b } @_ }
+sub ikeys { my %l = @_; sort { $a <=> $b } keys %l }
+sub put_in_hash { my ($a, $b) = @_; while (my ($k, $v) = each %{$b || {}}) { $a->{$k} = $v } $a }
+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 invbool { my $a = shift; $$a = !$$a; $$a }
+sub listlength { scalar @_ }
+sub strcpy { substr($_[0], $_[2] || 0, length $_[1]) = $_[1] }
+sub deref { ref($_[0]) eq "ARRAY" ? @{$_[0]} : ref($_[0]) eq "HASH" ? %{$_[0]} : $_[0] }
+sub deref_array { ref($_[0]) eq "ARRAY" ? @{$_[0]} : $_[0] }
+
+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 uniq { my %l; $l{$_} = 1 foreach @_; grep { delete $l{$_} } @_ }
+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 uniq_(&@) {
+ my $f = shift;
+ my %l;
+ $l{$f->($_)} = 1 foreach @_;
+ grep { delete $l{$f->($_)} } @_;
+}
+
+
+sub next_val_in_array {
+ my ($v, $l) = @_;
+ my %l = MDK::Common::Func::mapn(sub { @_ }, $l, [ @$l[1..$#$l], $l->[0] ]);
+ $l{$v};
+}
+
+
+sub list2kv {
+ my (@k, @v);
+ for (my $i = 0; $i < @_; $i += 2) {
+ push @k, $_[$i + 0];
+ push @v, $_[$i + 1];
+ }
+ \@k, \@v;
+}
+
+sub group_by2 {
+ my @l;
+ for (my $i = 0; $i < @_; $i += 2) {
+ push @l, [ $_[$i], $_[$i+1] ];
+ }
+ @l;
+}
+
+
+1;
diff --git a/lib/MDK/Common/File.pm b/lib/MDK/Common/File.pm
new file mode 100644
index 0000000..effea87
--- /dev/null
+++ b/lib/MDK/Common/File.pm
@@ -0,0 +1,332 @@
+package MDK::Common::File;
+
+=head1 NAME
+
+MDK::Common::File - miscellaneous file/filename manipulation functions
+
+=head1 SYNOPSIS
+
+ use MDK::Common::File qw(:all);
+
+=head1 EXPORTS
+
+=over
+
+=item dirname(FILENAME)
+
+=item basename(FILENAME)
+
+returns the dirname/basename of the file name
+
+=item cat_(FILES)
+
+returns the files contents: in scalar context it returns a single string, in
+array context it returns the lines.
+
+If no file is found, undef is returned
+
+=item cat_or_die(FILENAME)
+
+same as C<cat_> but dies when something goes wrong
+
+=item cat_utf8(FILES)
+
+same as C(<cat_>) but reads utf8 encoded strings
+
+=item cat_utf8_or_die(FILES)
+
+same as C(<cat_or_die>) but reads utf8 encoded strings
+
+=item cat__(FILEHANDLE REF)
+
+returns the file content: in scalar context it returns a single string, in
+array context it returns the lines
+
+=item output(FILENAME, LIST)
+
+creates a file and outputs the list (if the file exists, it is clobbered)
+
+=item output_utf8(FILENAME, LIST)
+
+same as C(<output>) but writes utf8 encoded strings
+
+=item secured_output(FILENAME, LIST)
+
+likes output() but prevents insecured usage (it dies if somebody try
+to exploit the race window between unlink() and creat())
+
+=item append_to_file(FILENAME, LIST)
+
+add the LIST at the end of the file
+
+=item output_p(FILENAME, LIST)
+
+just like C<output> but creates directories if needed
+
+=item output_with_perm(FILENAME, PERMISSION, LIST)
+
+same as C<output_p> but sets FILENAME permission to PERMISSION (using chmod)
+
+=item mkdir_p(DIRNAME)
+
+creates the directory (make parent directories as needed)
+
+=item rm_rf(FILES)
+
+remove the files (including sub-directories)
+
+=item cp_f(FILES, DEST)
+
+just like "cp -f"
+
+=item cp_af(FILES, DEST)
+
+just like "cp -af"
+
+=item linkf(SOURCE, DESTINATION)
+
+=item symlinkf(SOURCE, DESTINATION)
+
+=item renamef(SOURCE, DESTINATION)
+
+same as link/symlink/rename but removes the destination file first
+
+=item touch(FILENAME)
+
+ensure the file exists, set the modification time to current time
+
+=item all(DIRNAME)
+
+returns all the file in directory (except "." and "..")
+
+=item all_files_rec(DIRNAME)
+
+returns all the files in directory and the sub-directories (except "." and "..")
+
+=item glob_(STRING)
+
+simple version of C<glob>: doesn't handle wildcards in directory (eg:
+*/foo.c), nor special constructs (eg: [0-9] or {a,b})
+
+=item substInFile { CODE } FILENAME
+
+executes the code for each line of the file. You can know the end of the file
+is reached using C<eof>
+
+=item expand_symlinks(FILENAME)
+
+expand the symlinks in the absolute filename:
+C<expand_symlinks("/etc/X11/X")> gives "/usr/X11R6/bin/XFree86"
+
+=item openFileMaybeCompressed(FILENAME)
+
+opens the file and returns the file handle. If the file is not found, tries to
+gunzip the file + .gz
+
+=item catMaybeCompressed(FILENAME)
+
+cat_ alike. If the file is not found, tries to gunzip the file + .gz
+
+=back
+
+=head1 SEE ALSO
+
+L<MDK::Common>
+
+=cut
+
+
+use Exporter;
+our @ISA = qw(Exporter);
+our @EXPORT_OK = qw(dirname basename cat_ cat_or_die cat__ output output_p output_with_perm append_to_file linkf symlinkf renamef mkdir_p rm_rf cp_f cp_af touch all all_files_rec glob_ substInFile expand_symlinks openFileMaybeCompressed catMaybeCompressed);
+our %EXPORT_TAGS = (all => [ @EXPORT_OK ]);
+
+sub dirname { local $_ = shift; s|[^/]*/*\s*$||; s|(.)/*$|$1|; $_ || '.' }
+sub basename { local $_ = shift; s|/*\s*$||; s|.*/||; $_ }
+sub cat_ { my @l = map { my $F; open($F, '<', $_) ? <$F> : () } @_; wantarray() ? @l : join '', @l }
+sub cat_utf8 { my @l = map { my $F; open($F, '<:utf8', $_) ? <$F> : () } @_; wantarray() ? @l : join '', @l }
+sub cat_or_die { open(my $F, '<', $_[0]) or die "can't read file $_[0]: $!\n"; my @l = <$F>; wantarray() ? @l : join '', @l }
+sub cat_utf8_or_die { open(my $F, '<:utf8', $_[0]) or die "can't read file $_[0]: $!\n"; my @l = <$F>; wantarray() ? @l : join '', @l }
+sub cat__ { my ($f) = @_; my @l = <$f>; wantarray() ? @l : join '', @l }
+sub output { my $f = shift; open(my $F, ">$f") or die "output in file $f failed: $!\n"; print $F $_ foreach @_; 1 }
+sub output_utf8 { my $f = shift; open(my $F, '>:utf8', $f) or die "output in file $f failed: $!\n"; print $F $_ foreach @_; 1 }
+sub append_to_file { my $f = shift; open(my $F, ">>$f") or die "output in file $f failed: $!\n"; print $F $_ foreach @_; 1 }
+sub output_p { my $f = shift; mkdir_p(dirname($f)); output($f, @_) }
+sub output_with_perm { my ($f, $perm, @l) = @_; mkdir_p(dirname($f)); output($f, @l); chmod $perm, $f }
+sub linkf { unlink $_[1]; link $_[0], $_[1] }
+sub symlinkf { unlink $_[1]; symlink $_[0], $_[1] }
+sub renamef { unlink $_[1]; rename $_[0], $_[1] }
+
+sub secured_output {
+ my ($f, @l) = @_;
+ require POSIX;
+ unlink($f);
+ sysopen(my $F, $f, POSIX::O_CREAT() | POSIX::O_EXCL() | POSIX::O_RDWR()) or die "secure output in file $f failed: $! $@\n";
+ print $F $_ foreach @l;
+ 1;
+}
+
+sub mkdir_p {
+ my ($dir) = @_;
+ if (-d $dir) {
+ # nothing to do
+ } elsif (-e $dir) {
+ die "mkdir: error creating directory $dir: $dir is a file and i won't delete it\n";
+ } else {
+ mkdir_p(dirname($dir));
+ mkdir($dir, 0755) or die "mkdir: error creating directory $dir: $!\n";
+ }
+ 1;
+}
+
+sub rm_rf {
+ foreach (@_) {
+ if (!-l $_ && -d $_) {
+ rm_rf(glob_($_));
+ rmdir($_) or die "can't remove directory $_: $!\n";
+ } else {
+ unlink $_ or die "rm of $_ failed: $!\n";
+ }
+ }
+ 1;
+}
+
+sub cp_with_option {
+ my $option = shift @_;
+ my $keep_special = $option =~ /a/;
+
+ my $dest = pop @_;
+
+ @_ or return;
+ @_ == 1 || -d $dest or die "cp: copying multiple files, but last argument ($dest) is not a directory\n";
+
+ foreach my $src (@_) {
+ my $dest = $dest;
+ -d $dest and $dest .= '/' . basename($src);
+
+ unlink $dest;
+
+ if (-l $src && $keep_special) {
+ unless (symlink(readlink($src) || die("readlink failed: $!"), $dest)) {
+ warn "symlink: can't create symlink $dest: $!\n";
+ }
+ } elsif (-d $src) {
+ -d $dest or mkdir $dest, (stat($src))[2] or die "mkdir: can't create directory $dest: $!\n";
+ cp_with_option($option, glob_($src), $dest);
+ } elsif ((-b $src || -c $src) && $keep_special) {
+ my @stat = stat($src);
+ require MDK::Common::System;
+ MDK::Common::System::syscall_('mknod', $dest, $stat[2], $stat[6]) or die "mknod failed (dev $dest): $!";
+ } else {
+ open(my $F, $src) or die "can't open $src for reading: $!\n";
+ open(my $G, "> $dest") or die "can't cp to file $dest: $!\n";
+ local $_; while (<$F>) { print $G $_ }
+ chmod((stat($src))[2], $dest);
+ }
+ }
+ 1;
+}
+
+sub cp_f { cp_with_option('f', @_) }
+sub cp_af { cp_with_option('af', @_) }
+
+sub touch {
+ my ($f) = @_;
+ unless (-e $f) {
+ my $F;
+ open($F, ">$f");
+ }
+ my $now = time();
+ utime $now, $now, $f;
+}
+
+
+sub all {
+ my $d = shift;
+
+ local *F;
+ opendir F, $d or return;
+ my @l = grep { $_ ne '.' && $_ ne '..' } readdir F;
+ closedir F;
+
+ @l;
+}
+
+sub all_files_rec {
+ my ($d) = @_;
+
+ map { $_, -d $_ ? all_files_rec($_) : () } map { "$d/$_" } all($d);
+}
+
+sub glob_ {
+ my ($d, $f) = $_[0] =~ /\*/ ? (dirname($_[0]), basename($_[0])) : ($_[0], '*');
+
+ $d =~ /\*/ and die "glob_: wildcard in directory not handled ($_[0])\n";
+ ($f = quotemeta $f) =~ s/\\\*/.*/g;
+
+ $d =~ m|/$| or $d .= '/';
+ map { $d eq './' ? $_ : "$d$_" } grep { /^$f$/ } all($d);
+}
+
+
+sub substInFile(&@) {
+ my ($f, $file) = @_;
+ my $linkdest;
+ #- try hard to keep symlinks as they were set
+ if (-l $file) {
+ my $targetfile = readlink $file;
+ unlink $file;
+ $linkdest = $file;
+ $file = $targetfile;
+ }
+ if (-s $file) {
+ local @ARGV = $file;
+ local $^I = '';
+ local $_;
+ while (<>) {
+ $_ .= "\n" if eof && !/\n/;
+ &$f($_);
+ print;
+ }
+ } else {
+ local *F; my $old = select F; # that way eof return true
+ local $_ = '';
+ &$f($_);
+ select $old;
+ eval { output($file, $_) };
+ }
+ $linkdest and symlink $file, $linkdest;
+}
+
+
+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";
+}
+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;
+}
+
+
+sub openFileMaybeCompressed {
+ my ($f) = @_;
+ -e $f || -e "$f.gz" or die "file $f not found";
+ open(my $F, -e $f ? $f : "gzip -dc '$f.gz'|") or die "file $f is not readable";
+ $F;
+}
+sub catMaybeCompressed { cat__(openFileMaybeCompressed($_[0])) }
+
+1;
diff --git a/lib/MDK/Common/Func.pm b/lib/MDK/Common/Func.pm
new file mode 100644
index 0000000..82811bb
--- /dev/null
+++ b/lib/MDK/Common/Func.pm
@@ -0,0 +1,333 @@
+package MDK::Common::Func;
+
+=head1 NAME
+
+MDK::Common::Func - miscellaneous functions
+
+=head1 SYNOPSIS
+
+ use MDK::Common::Func qw(:all);
+
+=head1 EXPORTS
+
+=over
+
+=item may_apply(CODE REF, SCALAR)
+
+C<may_apply($f, $v)> is C<$f ? $f-E<gt>($v) : $v>
+
+=item may_apply(CODE REF, SCALAR, SCALAR)
+
+C<may_apply($f, $v, $otherwise)> is C<$f ? $f-E<gt>($v) : $otherwise>
+
+=item if_(BOOL, LIST)
+
+special constructs to workaround a missing perl feature:
+C<if_($b, "a", "b")> is C<$b ? ("a", "b") : ()>
+
+example of use: C<f("a", if_(arch() =~ /i.86/, "b"), "c")> which is not the
+same as C<f("a", arch()=~ /i.86/ && "b", "c")>
+
+=item if__(SCALAR, LIST)
+
+if_ alike. Test if the value is defined
+
+=item fold_left { CODE } LIST
+
+if you don't know fold_left (aka foldl), don't use it ;p
+
+ fold_left { $::a + $::b } 1, 3, 6
+
+gives 10 (aka 1+3+6)
+
+=item mapn { CODE } ARRAY REF, ARRAY REF, ...
+
+map lists in parallel:
+
+ mapn { $_[0] + $_[1] } [1, 2], [2, 4] # gives 3, 6
+ mapn { $_[0] + $_[1] + $_[2] } [1, 2], [2, 4], [3, 6] gives 6, 12
+
+=item mapn_ { CODE } ARRAY REF, ARRAY REF, ...
+
+mapn alike. The difference is what to do when the lists have not the same
+length: mapn takes the minimum common elements, mapn_ takes the maximum list
+length and extend the lists with undef values
+
+=item find { CODE } LIST
+
+returns the first element where CODE returns true (or returns undef)
+
+ find { /foo/ } "fo", "fob", "foobar", "foobir"
+
+gives "foobar"
+
+=item any { CODE } LIST
+
+returns 1 if CODE returns true for an element in LIST (otherwise returns 0)
+
+ any { /foo/ } "fo", "fob", "foobar", "foobir"
+
+gives 1
+
+=item every { CODE } LIST
+
+returns 1 if CODE returns true for B<every> element in LIST (otherwise returns 0)
+
+ every { /foo/ } "fo", "fob", "foobar", "foobir"
+
+gives 0
+
+=item map_index { CODE } LIST
+
+just like C<map>, but set C<$::i> to the current index in the list:
+
+ map_index { "$::i $_" } "a", "b"
+
+gives "0 a", "1 b"
+
+=item each_index { CODE } LIST
+
+just like C<map_index>, but doesn't return anything
+
+ each_index { print "$::i $_\n" } "a", "b"
+
+prints "0 a", "1 b"
+
+=item grep_index { CODE } LIST
+
+just like C<grep>, but set C<$::i> to the current index in the list:
+
+ grep_index { $::i == $_ } 0, 2, 2, 3
+
+gives (0, 2, 3)
+
+=item find_index { CODE } LIST
+
+returns the index of the first element where CODE returns true (or throws an exception)
+
+ find_index { /foo/ } "fo", "fob", "foobar", "foobir"
+
+gives 2
+
+=item map_each { CODE } HASH
+
+returns the list of results of CODE applied with $::a (key) and $::b (value)
+
+ map_each { "$::a is $::b" } 1=>2, 3=>4
+
+gives "1 is 2", "3 is 4"
+
+=item grep_each { CODE } HASH
+
+returns the hash key/value for which CODE applied with $::a (key) and $::b
+(value) is true:
+
+ grep_each { $::b == 2 } 1=>2, 3=>4, 4=>2
+
+gives 1=>2, 4=>2
+
+=item partition { CODE } LIST
+
+alike C<grep>, but returns both the list of matching elements and non matching elements
+
+ my ($greater, $lower) = partition { $_ > 3 } 4, 2, 8, 0, 1
+
+gives $greater = [ 4, 8 ] and $lower = [ 2, 0, 1 ]
+
+=item before_leaving { CODE }
+
+the code will be executed when the current block is finished
+
+ # create $tmp_file
+ my $b = before_leaving { unlink $tmp_file };
+ # some code that may throw an exception, the "before_leaving" ensures the
+ # $tmp_file will be removed
+
+=item cdie(SCALAR)
+
+aka I<conditional die>. If a C<cdie> is catched, the execution continues
+B<after> the cdie, not where it was catched (as happens with die & eval)
+
+If a C<cdie> is not catched, it mutates in real exception that can be catched
+with C<eval>
+
+cdie is useful when you want to warn about something weird, but when you can
+go on. In that case, you cdie "something weird happened", and the caller
+decide wether to go on or not. Especially nice for libraries.
+
+=item catch_cdie { CODE1 } sub { CODE2 }
+
+If a C<cdie> occurs while executing CODE1, CODE2 is executed. If CODE2
+returns true, the C<cdie> is catched.
+
+=back
+
+=head1 SEE ALSO
+
+L<MDK::Common>
+
+=cut
+
+use MDK::Common::Math;
+
+
+use Exporter;
+our @ISA = qw(Exporter);
+our @EXPORT_OK = qw(may_apply if_ if__ fold_left mapn mapn_ find any every map_index each_index grep_index find_index map_each grep_each partition before_leaving catch_cdie cdie);
+our %EXPORT_TAGS = (all => [ @EXPORT_OK ]);
+
+
+sub may_apply { $_[0] ? $_[0]->($_[1]) : (@_ > 2 ? $_[2] : $_[1]) }
+
+# prototype is needed for things like: if_(/foo/, bar => 'boo')
+sub if_($@) {
+ my $b = shift;
+ $b or return ();
+ wantarray() || @_ <= 1 or die("if_ called in scalar context with more than one argument " . join(":", caller()));
+ wantarray() ? @_ : $_[0];
+}
+sub if__($@) {
+ my $b = shift;
+ defined $b or return ();
+ wantarray() || @_ <= 1 or die("if_ called in scalar context with more than one argument " . join(":", caller()));
+ wantarray() ? @_ : $_[0];
+}
+
+sub fold_left(&@) {
+ my ($f, $initial, @l) = @_;
+ local ($::a, $::b);
+ $::a = $initial;
+ foreach (@l) { $::b = $_; $::a = &$f() }
+ $::a;
+}
+
+sub smapn {
+ my $f = shift;
+ my $n = shift;
+ my @r;
+ for (my $i = 0; $i < $n; $i++) { push @r, &$f(map { $_->[$i] } @_) }
+ @r;
+}
+sub mapn(&@) {
+ my $f = shift;
+ smapn($f, MDK::Common::Math::min(map { scalar @$_ } @_), @_);
+}
+sub mapn_(&@) {
+ my $f = shift;
+ smapn($f, MDK::Common::Math::max(map { scalar @$_ } @_), @_);
+}
+
+sub find(&@) {
+ my $f = shift;
+ $f->($_) and return $_ foreach @_;
+ undef;
+}
+sub any(&@) {
+ my $f = shift;
+ $f->($_) and return 1 foreach @_;
+ 0;
+}
+sub every(&@) {
+ my $f = shift;
+ $f->($_) or return 0 foreach @_;
+ 1;
+}
+
+sub map_index(&@) {
+ my $f = shift;
+ my @v; local $::i = 0;
+ map { @v = $f->(); $::i++; @v } @_;
+}
+sub each_index(&@) {
+ my $f = shift;
+ local $::i = 0;
+ foreach (@_) {
+ $f->();
+ $::i++;
+ }
+}
+sub grep_index(&@) {
+ my $f = shift;
+ my $v; local $::i = 0;
+ grep { $v = $f->(); $::i++; $v } @_;
+}
+sub find_index(&@) {
+ my $f = shift;
+ local $_;
+ for (my $i = 0; $i < @_; $i++) {
+ $_ = $_[$i];
+ &$f and return $i;
+ }
+ die "find_index failed in @_";
+}
+sub map_each(&%) {
+ my ($f, %h) = @_;
+ my @l;
+ local ($::a, $::b);
+ while (($::a, $::b) = each %h) { push @l, &$f($::a, $::b) }
+ @l;
+}
+sub grep_each(&%) {
+ my ($f, %h) = @_;
+ my %l;
+ local ($::a, $::b);
+ while (($::a, $::b) = each %h) { $l{$::a} = $::b if &$f($::a, $::b) }
+ %l;
+}
+sub partition(&@) {
+ my $f = shift;
+ my (@a, @b);
+ foreach (@_) {
+ $f->($_) ? push(@a, $_) : push(@b, $_);
+ }
+ \@a, \@b;
+}
+
+sub add_f4before_leaving {
+ my ($f, $b, $name) = @_;
+
+ unless ($MDK::Common::Func::before_leaving::{$name}) {
+ no strict 'refs';
+ ${"MDK::Common::Func::before_leaving::$name"} = 1;
+ ${"MDK::Common::Func::before_leaving::list"} = 1;
+ }
+ local *N = *{$MDK::Common::Func::before_leaving::{$name}};
+ my $list = *MDK::Common::Func::before_leaving::list;
+ $list->{$b}{$name} = $f;
+ *N = sub {
+ my $f = $list->{$_[0]}{$name} or die '';
+ $name eq 'DESTROY' and delete $list->{$_[0]};
+ &$f;
+ } if !defined &{*N};
+
+}
+
+#- ! the functions are not called in the order wanted, in case of multiple before_leaving :(
+sub before_leaving(&) {
+ my ($f) = @_;
+ my $b = bless {}, 'MDK::Common::Func::before_leaving';
+ add_f4before_leaving($f, $b, 'DESTROY');
+ $b;
+}
+
+sub catch_cdie(&&) {
+ my ($f, $catch) = @_;
+
+ local @MDK::Common::Func::cdie_catches;
+ unshift @MDK::Common::Func::cdie_catches, $catch;
+ &$f();
+}
+
+sub cdie {
+ my ($err) = @_;
+ foreach (@MDK::Common::Func::cdie_catches) {
+ $@ = $err;
+ if (my $v = $_->(\$err)) {
+ return $v;
+ }
+ }
+ die $err;
+}
+
+1;
+
diff --git a/lib/MDK/Common/Math.pm b/lib/MDK/Common/Math.pm
new file mode 100644
index 0000000..5ed9a61
--- /dev/null
+++ b/lib/MDK/Common/Math.pm
@@ -0,0 +1,197 @@
+package MDK::Common::Math;
+
+=head1 NAME
+
+MDK::Common::Math - miscellaneous math functions
+
+=head1 SYNOPSIS
+
+ use MDK::Common::Math qw(:all);
+
+=head1 EXPORTS
+
+=over
+
+=item $PI
+
+the well-known constant
+
+=item even(INT)
+
+=item odd(INT)
+
+is the number even or odd?
+
+=item sqr(FLOAT)
+
+C<sqr(3)> gives C<9>
+
+=item sign(FLOAT)
+
+returns a value in { -1, 0, 1 }
+
+=item round(FLOAT)
+
+C<round(1.2)> gives C<1>, C<round(1.6)> gives C<2>
+
+=item round_up(FLOAT, INT)
+
+returns the number rounded up to the modulo:
+C<round_up(11,10)> gives C<20>
+
+=item round_down(FLOAT, INT)
+
+returns the number rounded down to the modulo:
+C<round_down(11,10)> gives C<10>
+
+=item divide(INT, INT)
+
+integer division (which is lacking in perl). In array context, also returns the remainder:
+C<($a, $b) = divide(10,3)> gives C<$a is 3> and C<$b is 1>
+
+=item min(LIST)
+
+=item max(LIST)
+
+returns the minimum/maximum number in the list
+
+=item or_(LIST)
+
+is there a true value in the list?
+
+=item and_(LIST)
+
+are all values true in the list?
+
+=item sum(LIST)
+
+=item product(LIST)
+
+returns the sum/product of all the element in the list
+
+=item factorial(INT)
+
+C<factorial(4)> gives C<24> (4*3*2)
+
+=back
+
+=head1 OTHER
+
+the following functions are provided, but not exported:
+
+=over
+
+=item factorize(INT)
+
+C<factorize(40)> gives C<([2,3], [5,1])> as S<40 = 2^3 + 5^1>
+
+=item decimal2fraction(FLOAT)
+
+C<decimal2fraction(1.3333333333)> gives C<(4, 3)>
+($PRECISION is used to decide which precision to use)
+
+=item poly2(a,b,c)
+
+Solves the a*x2+b*x+c=0 polynomial:
+C<poly2(1,0,-1)> gives C<(1, -1)>
+
+=item permutations(n,p)
+
+A(n,p)
+
+=item combinaisons(n,p)
+
+C(n,p)
+
+=back
+
+=head1 SEE ALSO
+
+L<MDK::Common>
+
+=cut
+
+
+use Exporter;
+our @ISA = qw(Exporter);
+our @EXPORT_OK = qw($PI even odd sqr sign round round_up round_down divide min max or_ and_ sum product factorial);
+our %EXPORT_TAGS = (all => [ @EXPORT_OK ]);
+
+
+our $PRECISION = 10;
+our $PI = 3.1415926535897932384626433832795028841972;
+
+sub even { $_[0] % 2 == 0 }
+sub odd { $_[0] % 2 == 1 }
+sub sqr { $_[0] * $_[0] }
+sub sign { $_[0] <=> 0 }
+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 divide { my $d = int $_[0] / $_[1]; wantarray() ? ($d, $_[0] % $_[1]) : $d }
+sub min { my $n = shift; $_ < $n and $n = $_ foreach @_; $n }
+sub max { my $n = shift; $_ > $n and $n = $_ foreach @_; $n }
+sub or_ { my $n = 0; $n ||= $_ foreach @_; $n }
+sub and_ { my $n = 1; $n &&= $_ foreach @_; $n }
+sub sum { my $n = 0; $n += $_ foreach @_; $n }
+sub product { my $n = 1; $n *= $_ foreach @_; $n }
+
+
+sub factorize {
+ my ($n) = @_;
+ my @r;
+
+ $n == 1 and return [ 1, 1 ];
+ for (my $k = 2; sqr($k) <= $n; $k++) {
+ my $i = 0;
+ for ($i = 0; $n % $k == 0; $i++) { $n /= $k }
+ $i and push @r, [ $k, $i ];
+ }
+ $n > 1 and push @r, [ $n, 1 ];
+ @r;
+}
+
+sub decimal2fraction { # ex: 1.33333333 -> (4, 3)
+ my $n0 = shift;
+ my $precision = 10 ** -(shift || $PRECISION);
+ my ($a, $b) = (int $n0, 1);
+ my ($c, $d) = (1, 0);
+ my $n = $n0 - int $n0;
+ my $k;
+ until (abs($n0 - $a / $c) < $precision) {
+ $n = 1 / $n;
+ $k = int $n;
+ ($a, $b) = ($a * $k + $b, $a);
+ ($c, $d) = ($c * $k + $d, $c);
+ $n -= $k;
+ }
+ ($a, $c);
+}
+
+sub poly2 {
+ my ($a, $b, $c) = @_;
+ my $d = ($b**2 - 4 * $a * $c) ** 0.5;
+ (-$b + $d) / 2 / $a, (-$b - $d) / 2 / $a;
+}
+
+# A(n,p)
+sub permutations {
+ my ($n, $p) = @_;
+ my ($r, $i);
+ for ($r = 1, $i = 0; $i < $p; $i++) {
+ $r *= $n - $i;
+ }
+ $r;
+}
+
+# C(n,p)
+sub combinaisons {
+ my ($n, $p) = @_;
+
+ permutations($n, $p) / factorial($p);
+}
+
+sub factorial { permutations($_[0], $_[0]) }
+
+
+1;
diff --git a/lib/MDK/Common/String.pm b/lib/MDK/Common/String.pm
new file mode 100644
index 0000000..40eee1d
--- /dev/null
+++ b/lib/MDK/Common/String.pm
@@ -0,0 +1,164 @@
+package MDK::Common::String;
+
+=head1 NAME
+
+MDK::Common::String - formatting functions
+
+=head1 SYNOPSIS
+
+ use MDK::Common::String qw(:all);
+
+=head1 EXPORTS
+
+=over
+
+=item bestMatchSentence(STRING, LIST)
+
+finds in the list the best corresponding string
+
+=item formatList(INT, LIST)
+
+if the list size is bigger than INT, replace the remaining elements with "...".
+
+formatList(3, qw(a b c d e)) # => "a, b, c, ..."
+
+=item formatError(STRING)
+
+the string is something like "error at foo.pl line 2" that you get when
+catching an exception. formatError will remove the "at ..." so that you can
+nicely display the returned string to the user
+
+=item formatTimeRaw(TIME)
+
+the TIME is an epoch as returned by C<time>, the formatted time looks like "23:59:00"
+
+=item formatLines(STRING)
+
+remove "\n"s when the next line doesn't start with a space. Otherwise keep
+"\n"s to keep the indentation.
+
+=item formatAlaTeX(STRING)
+
+handle carriage return just like LaTeX: merge lines that are not separated by
+an empty line
+
+=item begins_with(STRING, STRING)
+
+return true if first argument begins with the second argument. Use this
+instead of regexps if you don't want regexps.
+
+begins_with("hello world", "hello") # => 1
+
+=item warp_text(STRING, INT)
+
+return a list of lines which do not exceed INT characters
+(or a string in scalar context)
+
+=item warp_text(STRING)
+
+warp_text at a default width (80)
+
+=back
+
+=head1 SEE ALSO
+
+L<MDK::Common>
+
+=cut
+
+
+use Exporter;
+our @ISA = qw(Exporter);
+our @EXPORT_OK = qw(bestMatchSentence formatList formatError formatTimeRaw formatLines formatAlaTeX begins_with warp_text);
+our %EXPORT_TAGS = (all => [ @EXPORT_OK ]);
+
+
+# count the number of character that match
+sub bestMatchSentence {
+
+ my $best = -1;
+ my $bestSentence;
+ my @s = split /\W+/, shift;
+ foreach (@_) {
+ my $count = 0;
+ foreach my $e (@s) {
+ $count += length($e) if /^$e$/;
+ $count += length($e) if /^$e$/i;
+ $count += length($e) if /$e/;
+ $count += length($e) if /$e/i;
+ }
+ $best = $count, $bestSentence = $_ if $count > $best;
+ }
+ wantarray() ? ($bestSentence, $best) : $bestSentence;
+}
+
+
+sub formatList {
+ my $nb = shift;
+ join(", ", @_ <= $nb ? @_ : (@_[0..$nb-1], '...'));
+}
+sub formatError {
+ my ($err) = @_;
+ if (!$::testing) {
+ $err =~ s/Uncaught exception from user code:\n\t//s; #- happens with "use diagnostics"
+ $err =~ s/ at .*?$/./s;
+ }
+ $err;
+}
+sub formatTimeRaw {
+ my ($s, $m, $h) = gmtime($_[0]);
+ sprintf "%d:%02d:%02d", $h, $m, $s;
+}
+sub formatLines {
+ my ($t, $tmp);
+ foreach (split "\n", $_[0]) {
+ if (/^\s/) {
+ $t .= "$tmp\n";
+ $tmp = $_;
+ } else {
+ $tmp = ($tmp ? "$tmp " : ($t && "\n") . $tmp) . $_;
+ }
+ }
+ "$t$tmp\n";
+}
+sub formatAlaTeX {
+ my ($t, $tmp) = ('', '');
+ foreach (split "\n", $_[0]) {
+ if (/^$/) {
+ $t .= ($t && "\n") . $tmp;
+ $tmp = '';
+ } else {
+ $tmp = ($tmp && "$tmp ") . (/^\s*(.*?)\s*$/)[0];
+ }
+ }
+ $t . ($t && $tmp && "\n") . $tmp;
+}
+
+
+sub begins_with {
+ my ($s, $prefix) = @_;
+ index($s, $prefix) == 0;
+}
+
+sub warp_text {
+ my ($text, $o_width) = @_;
+
+ my @l;
+ foreach (split "\n", $text) {
+ my ($beg) = /^(\s*)/;
+ my $t = '';
+ foreach (split /\s+/, $_) {
+ if (length "$beg$t $_" > ($o_width || 80)) {
+ push @l, "$beg$t";
+ $beg = '';
+ $t = $_;
+ } else {
+ $t = $t ? "$t $_" : $_;
+ }
+ }
+ push @l, "$beg$t";
+ }
+ wantarray() ? @l : join("\n", @l);
+}
+
+1;
diff --git a/lib/MDK/Common/System.pm b/lib/MDK/Common/System.pm
new file mode 100644
index 0000000..a947523
--- /dev/null
+++ b/lib/MDK/Common/System.pm
@@ -0,0 +1,478 @@
+package MDK::Common::System;
+
+=head1 NAME
+
+MDK::Common::System - system-related useful functions
+
+=head1 SYNOPSIS
+
+ use MDK::Common::System qw(:all);
+
+=head1 EXPORTS
+
+=over
+
+=item %compat_arch
+
+architecture compatibility mapping (eg: k6 => i586, k7 => k6 ...)
+
+=item %printable_chars
+
+7 bit ascii characters
+
+=item $sizeof_int
+
+sizeof(int)
+
+=item $bitof_int
+
+$sizeof_int * 8
+
+=item arch()
+
+return the architecture (eg: i686, ppc, ia64, k7...)
+
+=item typeFromMagic(FILENAME, LIST)
+
+find the first corresponding magic in FILENAME. eg of LIST:
+
+ [ 'empty', 0, "\0\0\0\0" ],
+ [ 'grub', 0, "\xEBG", 0x17d, "stage1 \0" ],
+ [ 'lilo', 0x2, "LILO" ],
+
+where each entry is [ magic_name, offset, string, offset, string, ... ].
+
+=item list_passwd()
+
+return the list of users as given by C<getpwent> (see perlfunc)
+
+=item list_home()
+
+return the list of home (eg: /home/foo, /home/pixel, ...)
+
+=item list_skels()
+
+return the directories where we can find dot files: homes, /root and /etc/skel
+
+=item list_users()
+
+return the list of unprivilegied users (aka those whose uid is greater
+than 500 and who are not "nobody").
+
+=item syscall_(NAME, PARA)
+
+calls the syscall NAME
+
+=item psizeof(STRING)
+
+useful to know the length of a C<pack> format string.
+
+ psizeof("I I I C C S") = 4 + 4 + 4 + 1 + 1 + 2 = 16
+
+=item availableMemory()
+
+size of swap + memory
+
+=item availableRamMB()
+
+size of RAM as reported by the BIOS (it is a round number that can be
+displayed or given as "mem=128M" to the kernel)
+
+!! "mem=..." is dangerous in 2.4 kernels
+
+=item gettimeofday()
+
+returns the epoch in microseconds
+
+=item unix2dos(STRING)
+
+takes care of CR/LF translation
+
+=item whereis_binary(STRING)
+
+return the first absolute file in $PATH (similar to which(1) and whereis(1))
+
+=item getVarsFromSh(FILENAME)
+
+returns a hash associating shell variables to their value. useful for config
+files such as /etc/sysconfig files
+
+=item setVarsInSh(FILENAME, HASH REF)
+
+write file in shell format association a shell variable + value for each
+key/value
+
+=item setVarsInSh(FILENAME, HASH REF, LIST)
+
+restrict the fields that will be printed to LIST
+
+=item setVarsInShMode(FILENAME, INT, HASH REF, LIST)
+
+like setVarsInSh with INT being the chmod value for the config file
+
+=item addVarsInSh(FILENAME, HASH REF)
+
+like setVarsInSh but keeping the entries in the file
+
+=item addVarsInSh(FILENAME, HASH REF, LIST)
+
+like setVarsInSh but keeping the entries in the file
+
+=item addVarsInShMode(FILENAME, INT, HASH REF, LIST)
+
+like addVarsInShMode but keeping the entries in the file
+
+=item setExportedVarsInCsh(FILENAME, HASH REF, LIST)
+
+same as C<setExportedVarsInSh> for csh format
+
+=item template2file(FILENAME_IN, FILENAME_OUT, HASH)
+
+read in a template file, replace keys @@@key@@@ with value, save it in out
+file
+
+=item template2userfile(PREFIX, FILENAME_IN, FILENAME_OUT, BOOL, HASH)
+
+read in a template file, replace keys @@@key@@@ with value, save it in every homes.
+If BOOL is true, overwrite existing files. FILENAME_OUT must be a relative filename
+
+=item read_gnomekderc(FILENAME, STRING)
+
+reads GNOME-like and KDE-like config files (aka windows-like).
+You must give a category. eg:
+
+ read_gnomekderc("/etc/skels/.kderc", 'KDE')
+
+=item update_gnomekderc(FILENAME, STRING, HASH)
+
+modifies GNOME-like and KDE-like config files (aka windows-like).
+If the category doesn't exist, it creates it. eg:
+
+ update_gnomekderc("/etc/skels/.kderc", 'KDE',
+ kfmIconStyle => "Large")
+
+=item fuzzy_pidofs(REGEXP)
+
+return the list of process ids matching the regexp
+
+=back
+
+=head1 OTHER
+
+=over
+
+=item better_arch(ARCH1, ARCH2)
+
+is ARCH1 compatible with ARCH2?
+
+better_arch('i386', 'ia64') and better_arch('ia64', 'i386') are false
+
+better_arch('k7', 'k6') is true and better_arch('k6', 'k7') is false
+
+=item compat_arch(STRING)
+
+test the architecture compatibility. eg:
+
+compat_arch('i386') is false on a ia64
+
+compat_arch('k6') is true on a k6 and k7 but false on a i386 and i686
+
+=back
+
+=head1 SEE ALSO
+
+L<MDK::Common>
+
+=cut
+
+
+use MDK::Common::Math;
+use MDK::Common::File;
+
+use Exporter;
+our @ISA = qw(Exporter);
+our @EXPORT_OK = qw(%compat_arch $printable_chars $sizeof_int $bitof_int arch distrib typeFromMagic list_passwd list_home list_skels list_users syscall_ psizeof availableMemory availableRamMB gettimeofday unix2dos whereis_binary getVarsFromSh setVarsInSh setVarsInShMode addVarsInSh addVarsInShMode setExportedVarsInSh setExportedVarsInCsh template2file template2userfile read_gnomekderc update_gnomekderc fuzzy_pidofs); #);
+our %EXPORT_TAGS = (all => [ @EXPORT_OK ]);
+
+
+our %compat_arch = ( #- compatibilty arch mapping.
+ 'noarch' => undef,
+ 'ia32' => 'noarch',
+ 'i386' => 'ia32',
+ 'i486' => 'i386',
+ 'i586' => 'i486',
+ 'i686' => 'i586',
+ 'i786' => 'i686',
+ 'k6' => 'i586',
+ 'k7' => 'k6',
+ 'k8' => 'k7',
+ 'x86_64' => 'i686',
+ 'amd64' => 'x86_64',
+ 'ia64' => 'noarch',
+ 'ppc' => 'noarch',
+ 'alpha' => 'noarch',
+ 'sparc' => 'noarch',
+ 'sparc32' => 'sparc',
+ 'sparc64' => 'sparc32',
+ 'ia64' => 'noarch',
+ );
+
+our $printable_chars = "\x20-\x7E";
+our $sizeof_int = psizeof("i");
+our $bitof_int = $sizeof_int * 8;
+
+
+sub arch() {
+ my $SYS_NMLN = 65;
+ my $format = "Z$SYS_NMLN" x 6;
+ my $t = pack $format;
+ syscall_('uname', $t);
+ (unpack($format, $t))[4];
+}
+sub better_arch {
+ my ($new, $old) = @_;
+ while ($new && $new ne $old) { $new = $compat_arch{$new} }
+ $new;
+}
+sub compat_arch { better_arch(arch(), $_[0]) }
+
+sub distrib() {
+ my $release = MDK::Common::File::cat_('/etc/release');
+ my ($real_system, $real_product) = $release =~ /(.*) release ([\d.]+)/;
+ my $oem_config = '/etc/sysconfig/oem';
+ my %oem = -f $oem_config && getVarsFromSh($oem_config);
+ my $company = $oem{COMPANY} || 'Mandriva';
+ my $system = $oem{SYSTEM} || $real_system;
+ my $product = $oem{PRODUCT} || $real_product;
+ (company => $company, system => $system, product => $product, real_system => $real_system, real_product => $real_product);
+}
+
+sub typeFromMagic {
+ my $f = shift;
+ sysopen(my $F, $f, 0) or return;
+
+ my $tmp;
+ M: foreach (@_) {
+ if (ref($_) eq 'CODE') {
+ my $name = $_->($F) or next M;
+ return $name;
+ } else {
+ 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 list_passwd() {
+ my (@l, @e);
+ setpwent();
+ while (@e = getpwent()) { push @l, [ @e ] }
+ endpwent();
+ @l;
+}
+sub list_home() {
+ map { $_->[7] } grep { $_->[2] >= 500 } list_passwd();
+}
+sub list_skels {
+ my ($prefix, $suffix) = @_;
+ grep { -d $_ && -w $_ } map { "$prefix$_/$suffix" } '/etc/skel', '/root', list_home();
+}
+
+sub list_users() {
+ map { 500 <= $_->[2] && $_->[0] ne "nobody" ? $_->[0] : () } list_passwd();
+}
+
+
+
+sub syscall_ {
+ my $f = shift;
+
+ #- load syscall.ph in package "main". If every use of syscall.ph do the same, all will be nice
+ package main;
+ require 'syscall.ph';
+
+ syscall(&{"main::SYS_$f"}, @_) == 0;
+}
+
+
+#- 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 "L!6", $buf;
+ map { $_ * ($blocksize / 1024) } $size, $free;
+}
+
+sub sync() { syscall_('sync') }
+sub psizeof { length pack $_[0] }
+sub availableMemory() { MDK::Common::Math::sum(map { /(\d+)/ } grep { /^(MemTotal|SwapTotal):/ } MDK::Common::File::cat_("/proc/meminfo")) }
+sub availableRamMB() { 4 * MDK::Common::Math::round((-s '/proc/kcore') / 1024 / 1024 / 4) }
+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 whereis_binary {
+ my ($prog, $o_prefix) = @_;
+ if ($prog =~ m!/!) {
+ warn qq(don't call whereis_binary with a name containing a "/" (the culprit is: $prog)\n);
+ return;
+ }
+ foreach (split(':', $ENV{PATH})) {
+ my $f = "$_/$prog";
+ -x "$o_prefix$f" and return $f;
+ }
+}
+
+sub getVarsFromSh {
+ my %l;
+ open(my $F, $_[0]) or return;
+ local $_;
+ while (<$F>) {
+ s/#.*//; # remove comments
+ s/^\s*//; # leading space
+ my ($v, $val) = /^(\w+)=(.*)/ or next;
+ $val = $1 if $val =~ /^"(.*)"$/ || $val =~ /^'(.*)'$/;
+ $l{$v} = $val;
+ }
+ %l;
+}
+
+sub addVarsInSh {
+ my ($file, $l, @fields) = @_;
+ addVarsInShMode($file, 0777 ^ umask(), $l, @fields);
+}
+
+sub addVarsInShMode {
+ my ($file, $mod, $l, @fields) = @_;
+ my %l = @fields ? map { $_ => $l->{$_} } @fields : %$l;
+ my %l2 = getVarsFromSh($file);
+
+ # below is add2hash_(\%l, \%l2);
+ exists $l{$_} or $l{$_} = $l2{$_} foreach keys %l2;
+
+ setVarsInShMode($file, $mod, \%l);
+}
+
+sub setVarsInSh {
+ my ($file, $l, @fields) = @_;
+ setVarsInShMode($file, 0777 ^ umask(), $l, @fields);
+}
+
+sub setVarsInShMode {
+ my ($file, $mod, $l, @fields) = @_;
+ @fields = keys %$l unless @fields;
+ my $string = join('',
+ map {
+ my $val = $l->{$_};
+ if ($val =~ /["`\$]/) {
+ $val =~ s/(')/\\$1/g;
+ $val = qq('$val');
+ } elsif ($val =~ /['|\s\\]/) {
+ $val =~ s/(["\\])/\\$1/g;
+ $val = qq("$val");
+ }
+ "$_=$val\n";
+ } grep { $l->{$_} } @fields
+ );
+ if ($file =~ m!^/home/!) {
+ MDK::Common::File::secured_output($file, $string);
+ } else {
+ MDK::Common::File::output($file, $string);
+ }
+
+ chmod $mod, $file;
+}
+
+sub setExportedVarsInSh {
+ my ($file, $l, @fields) = @_;
+ @fields = keys %$l unless @fields;
+
+ MDK::Common::File::output($file,
+ (map { $l->{$_} ? "$_=$l->{$_}\n" : () } @fields),
+ @fields ? "export " . join(" ", @fields) . "\n" : (),
+ );
+}
+
+sub setExportedVarsInCsh {
+ my ($file, $l, @fields) = @_;
+ @fields = keys %$l unless @fields;
+
+ MDK::Common::File::output($file, map { $l->{$_} ? "setenv $_ $l->{$_}\n" : () } @fields);
+}
+
+sub template2file {
+ my ($in, $out, %toreplace) = @_;
+ MDK::Common::File::output($out, map { s/@@@(.*?)@@@/$toreplace{$1}/g; $_ } MDK::Common::File::cat_($in));
+}
+sub template2userfile {
+ my ($prefix, $in, $out_rel, $force, %toreplace) = @_;
+
+ foreach (list_skels($prefix, $out_rel)) {
+ -d MDK::Common::File::dirname($_) or !-e $_ or $force or next;
+
+ template2file($in, $_, %toreplace);
+ m|/home/(.+?)/| and chown(getpwnam($1), getgrnam($1), $_);
+ }
+}
+
+sub read_gnomekderc {
+ my ($file, $category) = @_;
+ my %h;
+ foreach (MDK::Common::File::cat_($file), "[NOCATEGORY]\n") {
+ if (/^\s*\[\Q$category\E\]/i ... /^\[/) {
+ $h{$1} = $2 if /^\s*([^=]*?)=(.*)/;
+ }
+ }
+ %h;
+}
+
+sub update_gnomekderc {
+ my ($file, $category, %subst_) = @_;
+
+ my %subst = map { lc($_) => [ $_, $subst_{$_} ] } keys %subst_;
+
+ my $s;
+ defined($category) or $category = "DEFAULTCATEGORY";
+ foreach ("[DEFAULTCATEGORY]\n", MDK::Common::File::cat_($file), "[NOCATEGORY]\n") {
+ if (my $i = /^\s*\[\Q$category\E\]/i ... /^\[/) {
+ if ($i =~ /E/) { #- for last line of category
+ chomp $s; $s .= "\n";
+ $s .= "$_->[0]=$_->[1]\n" foreach values %subst;
+ %subst = ();
+ } elsif (/^\s*([^=]*?)=/) {
+ if (my $e = delete $subst{lc($1)}) {
+ $_ = "$1=$e->[1]\n";
+ }
+ }
+ }
+ $s .= $_ if !/^\[(NO|DEFAULT)CATEGORY\]/;
+ }
+
+ #- if category has not been found above (DEFAULTCATEGORY is always found).
+ if (keys %subst) {
+ chomp $s;
+ $s .= "\n[$category]\n";
+ $s .= "$_->[0]=$_->[1]\n" foreach values %subst;
+ }
+
+ MDK::Common::File::output_p($file, $s);
+
+}
+
+sub fuzzy_pidofs {
+ my ($regexp) = @_;
+ grep {
+ /^(\d+)$/ && (MDK::Common::File::cat_("/proc/$_/cmdline") || readlink("/proc/$_/exe") || '') =~ /$regexp/;
+ } MDK::Common::File::all('/proc');
+}
+
+1;
diff --git a/lib/MDK/Common/Various.pm b/lib/MDK/Common/Various.pm
new file mode 100644
index 0000000..96e76d3
--- /dev/null
+++ b/lib/MDK/Common/Various.pm
@@ -0,0 +1,140 @@
+package MDK::Common::Various;
+
+=head1 NAME
+
+MDK::Common::Various - miscellaneous functions
+
+=head1 SYNOPSIS
+
+ use MDK::Common::Various qw(:all);
+
+=head1 EXPORTS
+
+=over
+
+=item first(LIST)
+
+returns the first value. C<first(XXX)> is an alternative for C<((XXX)[0])>
+
+=item second(LIST)
+
+returns the second value. C<second(XXX)> is an alternative for C<((XXX)[1])>
+
+=item top(LIST)
+
+returns the last value. C<top(@l)> is an alternative for C<$l[$#l]>
+
+=item to_bool(SCALAR)
+
+returns a value in { 0, 1 }
+
+=item to_int(STRING)
+
+extracts the number from the string. You could use directly C<int "11 foo">, but
+you'll get I<Argument "11 foo" isn't numeric in int>. It also handles returns
+11 for C<"foo 11 bar">
+
+=item to_float(STRING)
+
+extract a decimal number from the string
+
+=item bool2text(SCALAR)
+
+returns a value in { "true", "false" }
+
+=item bool2yesno(SCALAR)
+
+returns a value in { "yes", "no" }
+
+=item text2bool(STRING)
+
+inverse of C<bool2text> and C<bool2yesno>
+
+=item chomp_(STRING)
+
+non-mutable version of chomp: do not modify the argument, returns the chomp'ed
+value. Also works on lists: C<chomp_($a, $b)> is equivalent to
+C<chomp($a) ; chomp($b) ; ($a,$b)>
+
+=item backtrace()
+
+returns a string describing the backtrace. eg:
+
+ sub g { print "oops\n", backtrace() }
+ sub f { &g }
+ f();
+
+gives
+
+ oops
+ main::g() called from /tmp/t.pl:2
+ main::f() called from /tmp/t.pl:4
+
+
+=item internal_error(STRING)
+
+another way to C<die> with a nice error message and a backtrace
+
+=item noreturn()
+
+use this to ensure nobody uses the return value of the function. eg:
+
+ sub g { print "g called\n"; noreturn }
+ sub f { print "g returns ", g() }
+ f();
+
+gives
+
+ test.pl:3: main::f() expects a value from main::g(), but main::g() doesn't return any value
+
+=back
+
+=head1 SEE ALSO
+
+L<MDK::Common>
+
+=cut
+
+
+use Exporter;
+our @ISA = qw(Exporter);
+our @EXPORT_OK = qw(first second top to_bool to_int to_float bool2text bool2yesno text2bool chomp_ backtrace internal_error noreturn);
+our %EXPORT_TAGS = (all => [ @EXPORT_OK ]);
+
+
+sub first { $_[0] }
+sub second { $_[1] }
+sub top { $_[-1] }
+
+sub to_bool { $_[0] ? 1 : 0 }
+sub to_int { $_[0] =~ /\s*(\d*)/ && $1 }
+sub to_float { $_[0] =~ /\s*(\d*(\.\d*)?)/ && $1 }
+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 chomp_ { my @l = @_; chomp @l; wantarray() ? @l : $l[0] }
+
+sub backtrace() {
+ my $s;
+ for (my $i = 1; caller($i); $i++) {
+ my ($_package, $file, $line, $func) = caller($i);
+ $s .= "$func() called from $file:$line\n";
+ }
+ $s;
+}
+
+sub internal_error {
+ die "INTERNAL ERROR: $_[0]\n" . backtrace();
+}
+
+sub noreturn() {
+ if (defined wantarray()) {
+ my ($_package, $file, $line, $func) = caller(1);
+ my (undef, undef, undef, $func2) = caller(2);
+ die "$file:$line: $func2() expects a value from $func(), but $func() doesn't return any value\n";
+ }
+}
+
+1;
+