From 1a06fa7e4a300880848047118f0adba68d38348d Mon Sep 17 00:00:00 2001 From: Pascal Rigaux Date: Wed, 25 Apr 2007 15:08:17 +0000 Subject: re-sync after the big svn loss --- lib/MDK/Common.pm.pl | 79 +++++++ lib/MDK/Common/DataStructure.pm | 178 +++++++++++++++ lib/MDK/Common/File.pm | 332 ++++++++++++++++++++++++++++ lib/MDK/Common/Func.pm | 333 ++++++++++++++++++++++++++++ lib/MDK/Common/Math.pm | 197 +++++++++++++++++ lib/MDK/Common/String.pm | 164 ++++++++++++++ lib/MDK/Common/System.pm | 478 ++++++++++++++++++++++++++++++++++++++++ lib/MDK/Common/Various.pm | 140 ++++++++++++ 8 files changed, 1901 insertions(+) create mode 100644 lib/MDK/Common.pm.pl create mode 100644 lib/MDK/Common/DataStructure.pm create mode 100644 lib/MDK/Common/File.pm create mode 100644 lib/MDK/Common/Func.pm create mode 100644 lib/MDK/Common/Math.pm create mode 100644 lib/MDK/Common/String.pm create mode 100644 lib/MDK/Common/System.pm create mode 100644 lib/MDK/Common/Various.pm (limited to 'lib/MDK') 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 is a collection of packages containing various simple functions: +L, +L, +L, +L, +L, +L, +L. + +EOF + +foreach my $f () { + (my $pkg = $f) =~ s|/|::|g; + open F, $f or die "can't open file $f"; + my $line; + while () { + $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 . 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, as simple as C=E $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 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 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 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 2, 3 => 4, 5 => 6)> gives C<[1,3,5], [2,4,6]> + +=back + +=head1 SEE ALSO + +L + +=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 but dies when something goes wrong + +=item cat_utf8(FILES) + +same as C() but reads utf8 encoded strings + +=item cat_utf8_or_die(FILES) + +same as C() 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() 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 but creates directories if needed + +=item output_with_perm(FILENAME, PERMISSION, LIST) + +same as C 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: 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 + +=item expand_symlinks(FILENAME) + +expand the symlinks in the absolute filename: +C 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 + +=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 is C<$f ? $f-E($v) : $v> + +=item may_apply(CODE REF, SCALAR, SCALAR) + +C is C<$f ? $f-E($v) : $otherwise> + +=item if_(BOOL, LIST) + +special constructs to workaround a missing perl feature: +C is C<$b ? ("a", "b") : ()> + +example of use: C which is not the +same as 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 element in LIST (otherwise returns 0) + + every { /foo/ } "fo", "fob", "foobar", "foobir" + +gives 0 + +=item map_index { CODE } LIST + +just like C, 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, 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, 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, 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. If a C is catched, the execution continues +B the cdie, not where it was catched (as happens with die & eval) + +If a C is not catched, it mutates in real exception that can be catched +with C + +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 occurs while executing CODE1, CODE2 is executed. If CODE2 +returns true, the C is catched. + +=back + +=head1 SEE ALSO + +L + +=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 gives C<9> + +=item sign(FLOAT) + +returns a value in { -1, 0, 1 } + +=item round(FLOAT) + +C gives C<1>, C gives C<2> + +=item round_up(FLOAT, INT) + +returns the number rounded up to the modulo: +C gives C<20> + +=item round_down(FLOAT, INT) + +returns the number rounded down to the modulo: +C 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 gives C<24> (4*3*2) + +=back + +=head1 OTHER + +the following functions are provided, but not exported: + +=over + +=item factorize(INT) + +C gives C<([2,3], [5,1])> as S<40 = 2^3 + 5^1> + +=item decimal2fraction(FLOAT) + +C 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 gives C<(1, -1)> + +=item permutations(n,p) + +A(n,p) + +=item combinaisons(n,p) + +C(n,p) + +=back + +=head1 SEE ALSO + +L + +=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