home *** CD-ROM | disk | FTP | other *** search
/ Inter.Net 55-2 / Inter.Net 55-2.iso / Mandrake / mdkinst / usr / bin / perl-install / common.pm < prev    next >
Encoding:
Perl POD Document  |  2000-01-12  |  11.8 KB  |  473 lines
  1. package common;
  2.  
  3.  
  4.  
  5.  
  6.  
  7. @ISA = qw(Exporter);
  8. %EXPORT_TAGS = (
  9.     common     => [ qw(__ even odd min max sqr sum and_ or_ sign product bool invbool listlength bool2text text2bool to_int to_float ikeys member divide is_empty_array_ref is_empty_hash_ref add2hash add2hash_ set_new set_add round round_up round_down first second top uniq translate untranslate warp_text formatAlaTeX formatLines deref) ],
  10.     functional => [ qw(fold_left compose map_index grep_index map_each grep_each map_tab_hash mapn mapn_ difference2 before_leaving catch_cdie cdie) ],
  11.     file       => [ qw(dirname basename touch all glob_ cat_ output symlinkf chop_ mode typeFromMagic) ],
  12.     system     => [ qw(sync makedev unmakedev psizeof strcpy gettimeofday syscall_ salt getVarsFromSh setVarsInSh setVarsInCsh substInFile availableRam availableMemory removeXiBSuffix template2file formatTime) ],
  13.     constant   => [ qw($printable_chars $sizeof_int $bitof_int $SECTORSIZE) ],
  14. );
  15. @EXPORT_OK = map { @$_ } values %EXPORT_TAGS;
  16.  
  17.  
  18.  
  19.  
  20.  
  21. $printable_chars = "\x20-\x7E";
  22. $sizeof_int      = psizeof("i");
  23. $bitof_int       = $sizeof_int * 8;
  24. $SECTORSIZE      = 512;
  25.  
  26.  
  27.  
  28.  
  29.  
  30. sub fold_left(&@) {
  31.     my $f = shift;
  32.     local $a = shift;
  33.     foreach $b (@_) { $a = &$f() }
  34.     $a
  35. }
  36.  
  37. sub _ {
  38.     my $s = shift @_; my $t = translate($s);
  39.     $t && ref $t or return sprintf $t, @_;
  40.     my ($T, @p) = @$t;
  41.     sprintf $T, @_[@p];
  42. }
  43.  
  44. sub __ { $_[0] }
  45. sub even($) { $_[0] % 2 == 0 }
  46. sub odd($)  { $_[0] % 2 == 1 }
  47. sub min { fold_left { $a < $b ? $a : $b } @_ }
  48. sub max { fold_left { $a > $b ? $a : $b } @_ }
  49. sub sum { fold_left { $a + $b } @_ }
  50. sub and_{ fold_left { $a && $b } @_ }
  51. sub or_ { fold_left { $a || $b } @_ }
  52. sub sqr { $_[0] * $_[0] }
  53. sub sign { $_[0] <=> 0 }
  54. sub product { fold_left { $a * $b } @_ }
  55. sub first { $_[0] }
  56. sub second { $_[1] }
  57. sub top { $_[-1] }
  58. sub uniq { my %l; @l{@_} = (); keys %l }
  59. sub to_int { $_[0] =~ /(\d*)/; $1 }
  60. sub to_float { $_[0] =~ /(\d*(\.\d*)?)/; $1 }
  61. sub ikeys { my %l = @_; sort { $a <=> $b } keys %l }
  62. sub add2hash($$)  { my ($a, $b) = @_; while (my ($k, $v) = each %{$b || {}}) { $a->{$k} ||= $v } }
  63. sub add2hash_($$) { my ($a, $b) = @_; while (my ($k, $v) = each %{$b || {}}) { exists $a->{$k} or $a->{$k} = $v } }
  64. sub member { my $e = shift; foreach (@_) { $e eq $_ and return 1 } 0 }
  65. sub dirname { @_ == 1 or die "usage: dirname <name>\n"; local $_ = shift; s|[^/]*/*\s*$||; s|(.)/*$|$1|; $_ || '.' }
  66. sub basename { @_ == 1 or die "usage: basename <name>\n"; local $_ = shift; s|/*\s*$||; s|.*/||; $_ }
  67. sub bool($) { $_[0] ? 1 : 0 }
  68. sub invbool { my $a = shift; $$a = !$$a; $$a }
  69. sub listlength { scalar @_ }
  70. sub bool2text { $_[0] ? "true" : "false" }
  71. sub text2bool { my $t = lc($_[0]); $t eq "true" || $t eq "yes" ? 1 : 0 }
  72. sub strcpy { substr($_[0], $_[2] || 0, length $_[1]) = $_[1] }
  73. sub cat_ { local *F; open F, $_[0] or $_[1] ? die "cat of file $_[0] failed: $!\n" : return; my @l = <F>; wantarray ? @l : join '', @l }
  74. sub output { my $f = shift; local *F; open F, ">$f" or die "output in file $f failed: $!\n"; print F foreach @_; }
  75. sub deref { ref $_[0] eq "ARRAY" ? @{$_[0]} : ref $_[0] eq "HASH" ? %{$_[0]} : $_[0] }
  76. sub linkf { unlink $_[1]; link $_[0], $_[1] }
  77. sub symlinkf { unlink $_[1]; symlink $_[0], $_[1] }
  78. sub chop_ { map { my $l = $_; chomp $l; $l } @_ }
  79. sub divide { my $d = int $_[0] / $_[1]; wantarray ? ($d, $_[0] % $_[1]) : $d }
  80. sub round { int ($_[0] + 0.5) }
  81. sub round_up { my ($i, $r) = @_; $i += $r - ($i + $r - 1) % $r - 1; }
  82. sub round_down { my ($i, $r) = @_; $i -= $i % $r; }
  83. sub is_empty_array_ref { my $a = shift; !defined $a || @$a == 0 }
  84. sub is_empty_hash_ref { my $a = shift; !defined $a || keys(%$a) == 0 }
  85. sub difference2 { my %l; @l{@{$_[1]}} = (); grep { !exists $l{$_} } @{$_[0]} }
  86. sub intersection { my (%l, @m); @l{@{shift @_}} = (); foreach (@_) { @m = grep { exists $l{$_} } @$_; %l = (); @l{@m} = (); } keys %l }
  87.  
  88. sub set_new(@) { my %l; @l{@_} = undef; { list => [ @_ ], hash => \%l } }
  89. sub set_add($@) { my $o = shift; foreach (@_) { exists $o->{hash}{$_} and next; push @{$o->{list}}, $_; $o->{hash}{$_} = undef } }
  90.  
  91. sub sync { syscall_('sync') }
  92. sub gettimeofday { my $t = pack "LL"; syscall_('gettimeofday', $t, 0) or die "gettimeofday failed: $!\n"; unpack("LL", $t) }
  93.  
  94. sub remove_spaces { local $_ = shift; s/^ +//; s/ +$//; $_ }
  95. sub mode { my @l = stat $_[0] or die "unable to get mode of file $_[0]: $!\n"; $l[2] }
  96. sub psizeof { length pack $_[0] }
  97.  
  98. sub touch {
  99.     my ($f) = @_;
  100.     unless (-e $f) {
  101.     local *F;
  102.     open F, ">$f";
  103.     }
  104.     my $now = time;
  105.     utime $now, $now, $f;
  106. }
  107.  
  108. sub map_index(&@) {
  109.     my $f = shift;
  110.     my $v; local $::i = 0;
  111.     map { $v = &$f($::i); $::i++; $v } @_;
  112. }
  113. sub grep_index(&@) {
  114.     my $f = shift;
  115.     my $v; local $::i = 0;
  116.     grep { $v = &$f($::i); $::i++; $v } @_;
  117. }
  118. sub map_each(&%) {
  119.     my ($f, %h) = @_;
  120.     my @l;
  121.     local ($::a, $::b);
  122.     while (($::a, $::b) = each %h) { push @l, &$f($::a, $::b) }
  123.     @l;
  124. }
  125. sub grep_each(&%) {
  126.     my ($f, %h) = @_;
  127.     my %l;
  128.     local ($::a, $::b);
  129.     while (($::a, $::b) = each %h) { $l{$::a} = $::b if &$f($::a, $::b) }
  130.     %l;
  131. }
  132.  
  133.  
  134. sub map_tab_hash(&$@) {
  135.     my ($f, $fields, @tab_hash) = @_;
  136.     my %hash;
  137.     my $key = { map_index {($_, $::i + 1)} @{$fields} };
  138.  
  139.     for (my $i = 0; $i < @tab_hash; $i += 2) {
  140.     my $h = [$key, @{$tab_hash[$i + 1]}];
  141.     &$f($i, $h) if $f;
  142.     $hash{ $tab_hash[$i] } = $h;
  143.       }
  144.     %hash;
  145. }
  146.  
  147. sub smapn {
  148.     my $f = shift;
  149.     my $n = shift;
  150.     my @r = ();
  151.     for (my $i = 0; $i < $n; $i++) { push @r, &$f(map { $_->[$i] } @_); }
  152.     @r
  153. }
  154. sub mapn(&@) {
  155.     my $f = shift;
  156.     smapn($f, min(map { scalar @$_ } @_), @_);
  157. }
  158. sub mapn_(&@) {
  159.     my $f = shift;
  160.     smapn($f, max(map { scalar @$_ } @_), @_);
  161. }
  162.  
  163.  
  164. sub add_f4before_leaving {
  165.     my ($f, $b, $name) = @_;
  166.  
  167.     unless ($common::before_leaving::{$name}) {
  168.     no strict 'refs';
  169.     ${"common::before_leaving::$name"} = 1;
  170.     ${"common::before_leaving::list"} = 1;
  171.     }
  172.     local *N = *{$common::before_leaving::{$name}};
  173.     my $list = *common::before_leaving::list;
  174.     $list->{$b}{$name} = $f;
  175.     *N = sub {
  176.     my $f = $list->{$_[0]}{$name} or die '';
  177.     $name eq 'DESTROY' and delete $list->{$_[0]};
  178.     goto $f;
  179.     } unless defined &{*N};
  180.  
  181. }
  182.  
  183.  
  184. sub before_leaving(&) {
  185.     my ($f) = @_;
  186.     my $b = bless {}, 'common::before_leaving';
  187.     add_f4before_leaving($f, $b, 'DESTROY');
  188.     $b;
  189. }
  190.  
  191. sub catch_cdie(&&) {
  192.     my ($f, $catch) = @_;
  193.  
  194.     local @common::cdie_catches;
  195.     unshift @common::cdie_catches, $catch;
  196.     &$f();
  197. }
  198.  
  199. sub cdie($;&) {
  200.     my ($err, $f) = @_;
  201.     foreach (@common::cdie_catches) {
  202.     $@ = $err;
  203.     &{$_}(\$err) and return;
  204.     }
  205.     die $err;
  206. }
  207.  
  208. sub all {
  209.     my $d = shift;
  210.  
  211.     local *F;
  212.     opendir F, $d or die "all: can't open dir $d: $!\n";
  213.     my @l = grep { $_ ne '.' && $_ ne '..' } readdir F;
  214.     closedir F;
  215.  
  216.     @l;
  217. }
  218.  
  219. sub glob_ {
  220.     my ($d, $f) = ($_[0] =~ /\*/) ? (dirname($_[0]), basename($_[0])) : ($_[0], '*');
  221.  
  222.     $d =~ /\*/ and die "glob_: wildcard in directory not handled ($_[0])\n";
  223.     ($f = quotemeta $f) =~ s/\\\*/.*/g;
  224.  
  225.     $d =~ m|/$| or $d .= '/';
  226.     map { $d eq './' ? $_ : "$d$_" } grep { /^$f$/ } all($d);
  227. }
  228.  
  229.  
  230. sub syscall_ {
  231.     my $f = shift;
  232.  
  233.     require 'syscall.ph';
  234.     syscall(&{$common::{"SYS_$f"}}, @_) == 0;
  235. }
  236.  
  237. sub salt($) {
  238.     my ($nb) = @_;
  239.     require 'devices.pm';
  240.     open F, devices::make("random") or die "missing random";
  241.     my $s; read F, $s, $nb;
  242.     local $_ = pack "b8" x $nb, unpack "b6" x $nb, $s;
  243.     tr [\0-\x3f] [0-9a-zA-Z./];
  244.     $_;
  245. }
  246.  
  247. sub makedev { ($_[0] << 8) | $_[1] }
  248. sub unmakedev { $_[0] >> 8, $_[0] & 0xff }
  249.  
  250. sub translate {
  251.     my ($s) = @_;
  252.     my ($lang) = $ENV{LANG} || $ENV{LANGUAGE} || $ENV{LC_MESSAGES} || $ENV{LC_ALL} || 'en';
  253.  
  254.     require lang;
  255.     foreach (split ':', $lang) {
  256.     lang::load_po($_) unless defined $po::I18N::{$_};
  257.     return ${$po::I18N::{$_}}{$s} || $s if %{$po::I18N::{$_}};
  258.     }
  259.     $s;
  260. }
  261.  
  262. sub untranslate($@) {
  263.     my $s = shift || return;
  264.     foreach (@_) { translate($_) eq $s and return $_ }
  265.     die "untranslate failed";
  266. }
  267.  
  268. sub warp_text($;$) {
  269.     my ($text, $width) = @_;
  270.     $width ||= 80;
  271.  
  272.     my @l;
  273.     foreach (split "\n", $text) {
  274.     my $t = '';
  275.     foreach (split /\s+/, $_) {
  276.         if (length "$t $_" > $width) {
  277.         push @l, $t;
  278.         $t = $_;
  279.         } else {
  280.         $t = "$t $_";
  281.         }
  282.     }
  283.     push @l, $t;
  284.     }
  285.     @l;
  286. }
  287.  
  288. sub formatAlaTeX($) {
  289.     my ($t, $tmp);
  290.     foreach (split "\n", $_[0]) {
  291.     if (/^$/) {
  292.         $t .= ($t && "\n") . $tmp;
  293.         $tmp = '';
  294.     } else {
  295.         $tmp = ($tmp && "$tmp ") . $_;
  296.     }
  297.     }
  298.     $t . ($t && $tmp && "\n") . $tmp;
  299. }
  300.  
  301. sub formatLines($) {
  302.     my ($t, $tmp);
  303.     foreach (split "\n", $_[0]) {
  304.     if (/^$/) {
  305.         $t .= "$tmp\n";
  306.         $tmp = "";
  307.     } elsif (/^\s/) {
  308.         $t .= "$tmp\n";
  309.         $tmp = $_;
  310.     } else {
  311.         $tmp = ($tmp ? "$tmp " : ($t && "\n") . $tmp) . $_;
  312.     }
  313.     }
  314.     "$t$tmp\n";
  315. }
  316.  
  317. sub getVarsFromSh($) {
  318.     my %l;
  319.     local *F;
  320.     open F, $_[0] or return;
  321.     foreach (<F>) {
  322.     my ($v, $val, $val2) =
  323.       /^\s*            # leading space
  324.        (\w+) =        # variable
  325.        (
  326.               "([^"]*)"    # double-quoted text
  327.             | '([^']*)'    # single-quoted text
  328.             | [^'"\s]+        # normal text
  329.            )
  330.            \s*$            # end of line
  331.           /x or next;
  332.     $l{$v} = $val2 || $val;
  333.     }
  334.     %l;
  335. }
  336.  
  337. sub setVarsInSh {
  338.     my ($file, $l, @fields) = @_;
  339.     @fields = keys %$l unless @fields;
  340.  
  341.  
  342.     local *F;
  343.     open F, "> $_[0]" or die "cannot create config file $file";
  344.     $l->{$_} and print F "$_=$l->{$_}\n" foreach @fields;
  345. }
  346. sub setVarsInCsh {
  347.     my ($file, $l, @fields) = @_;
  348.     @fields = keys %$l unless @fields;
  349.  
  350.  
  351.     local *F;
  352.     open F, "> $_[0]" or die "cannot create config file $file";
  353.     $l->{$_} and print F "setenv $_ $l->{$_}\n" foreach @fields;
  354. }
  355.  
  356. sub template2file($$%) {
  357.     my ($inputfile, $outputfile, %toreplace) = @_;
  358.     local *OUT; local *IN;
  359.  
  360.     open IN, $inputfile  or die "Can't open $inputfile $!";
  361.     if ($::testing) {
  362.     *OUT = *STDOUT;
  363.     } else {
  364.     open OUT, ">$outputfile" or die "Can't open $outputfile $!";
  365.     }
  366.  
  367.     map { s/@@@(.*?)@@@/$toreplace{$1}/g; print OUT; } <IN>;
  368. }
  369.  
  370. sub substInFile(&@) {
  371.     my $f = shift;
  372.     foreach my $file (@_) {
  373.     if (-e $file) {
  374.         local @ARGV = $file;
  375.         local ($^I, $_) = '';
  376.         while (<>) { &$f($_); print }
  377.     } else {
  378.         local *F; my $old = select F; # that way eof return true
  379.         local $_ = '';
  380.         &$f($_);
  381.         select $old;
  382.         eval { output($file, $_) };
  383.     }
  384.     }
  385. }
  386.  
  387. sub best_match {
  388.     my ($str, @lis) = @_;
  389.     my @words = split /\W+/, $str;
  390.     my ($max, $res) = 0;
  391.  
  392.     foreach (@lis) {
  393.     my $count = 0;
  394.     foreach my $i (@words) {
  395.         $count++ if /$i/i;
  396.     }
  397.     $max = $count, $res = $_ if $count >= $max;
  398.     }
  399.     $res;
  400. }
  401.  
  402. sub bestMatchSentence {
  403.  
  404.     my $best = -1;
  405.     my $bestSentence;
  406.     my @s = split /\W+/, shift;
  407.     foreach (@_) {
  408.     my $count = 0;
  409.     foreach my $e (@s) {
  410.         $count++ if /$e/i;
  411.     }
  412.     $best = $count, $bestSentence = $_ if $count > $best;
  413.     }
  414.     $bestSentence;
  415. }
  416.  
  417. # count the number of character that match
  418. sub bestMatchSentence2 {
  419.  
  420.     my $best = -1;
  421.     my $bestSentence;
  422.     my @s = split /\W+/, shift;
  423.     foreach (@_) {
  424.     my $count = 0;
  425.     foreach my $e (@s) {
  426.         $count+= length ($e) if /$e/i;
  427.     }
  428.     $best = $count, $bestSentence = $_ if $count > $best;
  429.     }
  430.     $bestSentence;
  431. }
  432.  
  433. sub typeFromMagic($@) {
  434.     my $f = shift;
  435.     local *F; sysopen F, $f, 0 or return;
  436.  
  437.     my $tmp;
  438.   M: foreach (@_) {
  439.     my ($name, @l) = @$_;
  440.     while (@l) {
  441.         my ($offset, $signature) = splice(@l, 0, 2);
  442.         sysseek(F, $offset, 0) or next M;
  443.         sysread(F, $tmp, length $signature);
  444.         $tmp eq $signature or next M;
  445.     }
  446.     return $name;
  447.     }
  448.     undef;
  449. }
  450.  
  451. sub availableRam()    { sum map { /(\d+)/ } grep { /^(MemTotal):/           } cat_("/proc/meminfo"); }
  452. sub availableMemory() { sum map { /(\d+)/ } grep { /^(MemTotal|SwapTotal):/ } cat_("/proc/meminfo"); }
  453.  
  454. sub removeXiBSuffix($) {
  455.     local $_ = shift;
  456.  
  457.     /(\d+)k$/i and return $1 * 1024;
  458.     /(\d+)M$/i and return $1 * 1024 * 1024;
  459.     /(\d+)G$/i and return $1 * 1024 * 1024 * 1024;
  460.     $_;
  461. }
  462.  
  463. sub formatTime($) {
  464.     my ($s, $m, $h) = gmtime($_[0]);
  465.     sprintf "%02d:%02d:%02d", $h, $m, $s;
  466. }
  467.  
  468.  
  469.  
  470.  
  471.  
  472. 1; #
  473.