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 --- .cvsignore | 5 - MDK/.cvsignore | 1 - MDK/Common.pm.pl | 79 - MDK/Common/DataStructure.pm | 178 -- MDK/Common/File.pm | 318 --- MDK/Common/Func.pm | 333 --- MDK/Common/Math.pm | 197 -- MDK/Common/String.pm | 164 -- MDK/Common/System.pm | 478 ---- MDK/Common/Various.pm | 140 - Makefile | 69 - Makefile.PL | 8 +- README.emacs | 21 - 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 + misc/Makefile | 7 - misc/perl_checker-vim | 3 - misc/perl_checker.el | 10 - misc/perl_checker.vim | 1 - perl-MDK-Common.spec | 491 ---- perl_checker.spec | 318 --- perl_checker.src/.cvsignore | 15 - perl_checker.src/Makefile | 34 - perl_checker.src/OCamlMakefile | 912 ------ perl_checker.src/build.mli | 3 - perl_checker.src/common.ml | 1005 ------- perl_checker.src/common.mli | 276 -- perl_checker.src/config_file.ml | 40 - perl_checker.src/config_file.mli | 6 - perl_checker.src/flags.ml | 43 - perl_checker.src/flags.mli | 22 - perl_checker.src/global_checks.ml | 639 ----- perl_checker.src/global_checks.mli | 26 - perl_checker.src/info.ml | 76 - perl_checker.src/info.mli | 17 - perl_checker.src/lexer.mll | 1057 ------- perl_checker.src/parser.mly | 500 ---- perl_checker.src/parser_helper.ml | 1409 ---------- perl_checker.src/parser_helper.mli | 314 --- perl_checker.src/perl_checker.html.pl | 168 -- perl_checker.src/perl_checker.ml | 183 -- perl_checker.src/perl_checker.mli | 1 - perl_checker.src/print.ml | 0 perl_checker.src/print.mli | 1 - perl_checker.src/test/.cvsignore | 2 - perl_checker.src/test/Makefile | 3 - perl_checker.src/test/context.t | 41 - perl_checker.src/test/force_layout.t | 23 - perl_checker.src/test/method.t | 11 - perl_checker.src/test/prototype.t | 23 - perl_checker.src/test/read_t.pm | 28 - perl_checker.src/test/return_value.t | 23 - perl_checker.src/test/suggest_better.t | 112 - perl_checker.src/test/syntax_restrictions.t | 70 - perl_checker.src/test/test_it | 113 - perl_checker.src/test/various_errors.t | 61 - perl_checker.src/tree.ml | 443 --- perl_checker.src/tree.mli | 57 - perl_checker.src/types.mli | 125 - perl_checker_fake_packages/CGI.pm | 22 - perl_checker_fake_packages/Getopt/Long.pm | 6 - perl_checker_fake_packages/Glib.pm | 315 --- perl_checker_fake_packages/Gnome2.pm | 641 ----- perl_checker_fake_packages/Gnome2/Vte.pm | 72 - perl_checker_fake_packages/Gtk2.pm | 3742 ------------------------- perl_checker_fake_packages/MDV/Distribconf.pm | 17 - perl_checker_fake_packages/Net/DNS.pm | 7 - perl_checker_fake_packages/Net/FTP.pm | 9 - perl_checker_fake_packages/Net/Ping.pm | 9 - perl_checker_fake_packages/URPM/Resolve.pm | 17 - perl_checker_fake_packages/gen.pl | 108 - perl_checker_fake_packages/packdrake.pm | 25 - perl_checker_fake_packages/urpm.pm | 9 - 79 files changed, 1903 insertions(+), 15700 deletions(-) delete mode 100644 .cvsignore delete mode 100644 MDK/.cvsignore delete mode 100644 MDK/Common.pm.pl delete mode 100644 MDK/Common/DataStructure.pm delete mode 100644 MDK/Common/File.pm delete mode 100644 MDK/Common/Func.pm delete mode 100644 MDK/Common/Math.pm delete mode 100644 MDK/Common/String.pm delete mode 100644 MDK/Common/System.pm delete mode 100644 MDK/Common/Various.pm delete mode 100644 Makefile delete mode 100644 README.emacs 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 delete mode 100644 misc/Makefile delete mode 100755 misc/perl_checker-vim delete mode 100644 misc/perl_checker.el delete mode 100644 misc/perl_checker.vim delete mode 100644 perl-MDK-Common.spec delete mode 100644 perl_checker.spec delete mode 100644 perl_checker.src/.cvsignore delete mode 100644 perl_checker.src/Makefile delete mode 100644 perl_checker.src/OCamlMakefile delete mode 100644 perl_checker.src/build.mli delete mode 100644 perl_checker.src/common.ml delete mode 100644 perl_checker.src/common.mli delete mode 100644 perl_checker.src/config_file.ml delete mode 100644 perl_checker.src/config_file.mli delete mode 100644 perl_checker.src/flags.ml delete mode 100644 perl_checker.src/flags.mli delete mode 100644 perl_checker.src/global_checks.ml delete mode 100644 perl_checker.src/global_checks.mli delete mode 100644 perl_checker.src/info.ml delete mode 100644 perl_checker.src/info.mli delete mode 100644 perl_checker.src/lexer.mll delete mode 100644 perl_checker.src/parser.mly delete mode 100644 perl_checker.src/parser_helper.ml delete mode 100644 perl_checker.src/parser_helper.mli delete mode 100644 perl_checker.src/perl_checker.html.pl delete mode 100644 perl_checker.src/perl_checker.ml delete mode 100644 perl_checker.src/perl_checker.mli delete mode 100644 perl_checker.src/print.ml delete mode 100644 perl_checker.src/print.mli delete mode 100644 perl_checker.src/test/.cvsignore delete mode 100644 perl_checker.src/test/Makefile delete mode 100644 perl_checker.src/test/context.t delete mode 100644 perl_checker.src/test/force_layout.t delete mode 100644 perl_checker.src/test/method.t delete mode 100644 perl_checker.src/test/prototype.t delete mode 100644 perl_checker.src/test/read_t.pm delete mode 100644 perl_checker.src/test/return_value.t delete mode 100644 perl_checker.src/test/suggest_better.t delete mode 100644 perl_checker.src/test/syntax_restrictions.t delete mode 100755 perl_checker.src/test/test_it delete mode 100644 perl_checker.src/test/various_errors.t delete mode 100644 perl_checker.src/tree.ml delete mode 100644 perl_checker.src/tree.mli delete mode 100644 perl_checker.src/types.mli delete mode 100644 perl_checker_fake_packages/CGI.pm delete mode 100644 perl_checker_fake_packages/Getopt/Long.pm delete mode 100644 perl_checker_fake_packages/Glib.pm delete mode 100644 perl_checker_fake_packages/Gnome2.pm delete mode 100644 perl_checker_fake_packages/Gnome2/Vte.pm delete mode 100644 perl_checker_fake_packages/Gtk2.pm delete mode 100644 perl_checker_fake_packages/MDV/Distribconf.pm delete mode 100644 perl_checker_fake_packages/Net/DNS.pm delete mode 100644 perl_checker_fake_packages/Net/FTP.pm delete mode 100644 perl_checker_fake_packages/Net/Ping.pm delete mode 100644 perl_checker_fake_packages/URPM/Resolve.pm delete mode 100755 perl_checker_fake_packages/gen.pl delete mode 100644 perl_checker_fake_packages/packdrake.pm delete mode 100644 perl_checker_fake_packages/urpm.pm diff --git a/.cvsignore b/.cvsignore deleted file mode 100644 index aa0948d..0000000 --- a/.cvsignore +++ /dev/null @@ -1,5 +0,0 @@ -META.yml -.perl_checker.cache -Makefile-MDK-Common -MDK-Common-*.tar.* -perl_checker-*.tar.* diff --git a/MDK/.cvsignore b/MDK/.cvsignore deleted file mode 100644 index d74cfd1..0000000 --- a/MDK/.cvsignore +++ /dev/null @@ -1 +0,0 @@ -Common.pm diff --git a/MDK/Common.pm.pl b/MDK/Common.pm.pl deleted file mode 100644 index 2a4e5ea..0000000 --- a/MDK/Common.pm.pl +++ /dev/null @@ -1,79 +0,0 @@ - - -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.3"; - -1; -EOF diff --git a/MDK/Common/DataStructure.pm b/MDK/Common/DataStructure.pm deleted file mode 100644 index 79e4aa0..0000000 --- a/MDK/Common/DataStructure.pm +++ /dev/null @@ -1,178 +0,0 @@ -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/MDK/Common/File.pm b/MDK/Common/File.pm deleted file mode 100644 index 1924931..0000000 --- a/MDK/Common/File.pm +++ /dev/null @@ -1,318 +0,0 @@ -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__(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 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_or_die { open(my $F, '<', $_[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 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/MDK/Common/Func.pm b/MDK/Common/Func.pm deleted file mode 100644 index 82811bb..0000000 --- a/MDK/Common/Func.pm +++ /dev/null @@ -1,333 +0,0 @@ -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/MDK/Common/Math.pm b/MDK/Common/Math.pm deleted file mode 100644 index 5ed9a61..0000000 --- a/MDK/Common/Math.pm +++ /dev/null @@ -1,197 +0,0 @@ -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/MDK/Common/String.pm b/MDK/Common/String.pm deleted file mode 100644 index 40eee1d..0000000 --- a/MDK/Common/String.pm +++ /dev/null @@ -1,164 +0,0 @@ -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