diff options
Diffstat (limited to 'lib')
| -rw-r--r-- | lib/MDK/Common.pm.pl | 79 | ||||
| -rw-r--r-- | lib/MDK/Common/DataStructure.pm | 178 | ||||
| -rw-r--r-- | lib/MDK/Common/File.pm | 332 | ||||
| -rw-r--r-- | lib/MDK/Common/Func.pm | 333 | ||||
| -rw-r--r-- | lib/MDK/Common/Math.pm | 197 | ||||
| -rw-r--r-- | lib/MDK/Common/String.pm | 164 | ||||
| -rw-r--r-- | lib/MDK/Common/System.pm | 478 | ||||
| -rw-r--r-- | lib/MDK/Common/Various.pm | 140 |
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; + |