move to MDK::Common, bool->to_bool

1 files changed, 11 insertions, 502 deletions

diff --git a/perl-install/common.pm b/perl-install/common.pm
index aaf0075a9..c33b59878 100644
--- a/perl-install/common.pm
+++ b/perl-install/common.pm
@@ -1,160 +1,35 @@
 package common; # $Id$
 
+use MDK::Common;
+use MDK::Common::System;
 use diagnostics;
 use strict;
-use vars qw(@ISA %EXPORT_TAGS @EXPORT_OK $printable_chars $sizeof_int $bitof_int $SECTORSIZE %compat_arch);
+use vars qw(@ISA @EXPORT $SECTORSIZE);
 
 @ISA = qw(Exporter);
-%EXPORT_TAGS = (
-    common     => [ qw(__ may_apply even odd arch better_arch compat_arch min max sqr sum and_ or_ if_ if__ chomp_ sign product bool invbool listlength bool2text bool2yesno text2bool to_int to_float ikeys member divide is_empty_array_ref is_empty_hash_ref add2hash add2hash_ put_in_hash set_new set_add round round_up round_down first second top uniq translate untranslate warp_text formatAlaTeX formatLines deref next_val_in_array) ],
-    functional => [ qw(fold_left compose map_index grep_index find_index map_each grep_each list2kv mapn mapn_ difference2 before_leaving catch_cdie cdie) ],
-    file       => [ qw(dirname basename touch all glob_ cat_ cat__ catMaybeCompressed output symlinkf renamef mode typeFromMagic expand_symlinks) ],
-    system     => [ qw(sync makedev unmakedev psizeof strcpy gettimeofday syscall_ salt getVarsFromSh setVarsInSh setVarsInShMode setVarsInCsh substInFile availableMemory availableRamMB removeXiBSuffix formatXiB template2file template2userfile update_userkderc list_skels formatTime formatTimeRaw unix2dos setVirtual isCdNotEjectable) ],
-    constant   => [ qw($printable_chars $sizeof_int $bitof_int $SECTORSIZE %compat_arch) ],
-);
-@EXPORT_OK = map { @$_ } values %EXPORT_TAGS;
+# no need to export ``_''
+@EXPORT = qw(arch sync $SECTORSIZE __ translate untranslate formatXiB removeXiBSuffix formatTime setVirtual makedev unmakedev salt isCdNotEjectable compat_arch better_arch);
+
+# perl_checker: RE-EXPORT-ALL
+push @EXPORT, @MDK::Common::EXPORT;
 
 
 #-#####################################################################################
 #- Globals
 #-#####################################################################################
-$printable_chars = "\x20-\x7E";
-$sizeof_int      = psizeof("i");
-$bitof_int       = $sizeof_int * 8;
 $SECTORSIZE      = 512;
-%compat_arch     = ( #- compatibilty arch mapping.
-		     'noarch'  => undef,
-		     'i386'    => 'noarch',
-		     'i486'    => 'i386',
-		     'i586'    => 'i486',
-		     'i686'    => 'i586',
-		     'i786'    => 'i686',
-		     'k6'      => 'i586',
-		     'k7'      => 'k6',
-		     'k8'      => 'k7',
-		     'ppc'     => 'noarch',
-		     'alpha'   => 'noarch',
-		     'sparc'   => 'noarch',
-		     'sparc32' => 'sparc',
-		     'sparc64' => 'sparc32',
-		     'ia64'    => 'noarch',
-		   );
 
 #-#####################################################################################
 #- Functions
 #-#####################################################################################
 
-sub fold_left(&@) {
-    my $f = shift;
-    local $a = shift;
-    foreach $b (@_) { $a = &$f() }
-    $a
-}
 
 sub _ {
     my $s = shift @_; my $t = translate($s);
     sprintf $t, @_;
 }
-#-delete $main::{'_'};
 sub __ { $_[0] }
-sub even { $_[0] % 2 == 0 }
-sub odd  { $_[0] % 2 == 1 }
-sub min { fold_left { $a < $b ? $a : $b } @_ }
-sub max { fold_left { $a > $b ? $a : $b } @_ }
-sub sum { fold_left { $a + $b } @_ }
-sub and_{ fold_left { $a && $b } @_ }
-sub or_ { fold_left { $a || $b } @_ }
-sub sqr { $_[0] * $_[0] }
-sub sign { $_[0] <=> 0 }
-sub product { fold_left { $a * $b } @_ }
-sub first { $_[0] }
-sub second { $_[1] }
-sub top { $_[-1] }
-sub uniq { my %l; @l{@_} = (); keys %l }
-sub to_int { $_[0] =~ /(\d*)/; $1 }
-sub to_float { $_[0] =~ /(\d*(\.\d*)?)/; $1 }
-sub ikeys { my %l = @_; sort { $a <=> $b } keys %l }
-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 put_in_hash { my ($a, $b) = @_; while (my ($k, $v) = each %{$b || {}}) { $a->{$k} = $v } $a }
-sub member { my $e = shift; foreach (@_) { $e eq $_ and return 1 } 0 }
-sub dirname { @_ == 1 or die "usage: dirname <name>\n" . backtrace(); local $_ = shift; s|[^/]*/*\s*$||; s|(.)/*$|$1|; $_ || '.' }
-sub basename { @_ == 1 or die "usage: basename <name>\n" . backtrace(); local $_ = shift; s|/*\s*$||; s|.*/||; $_ }
-sub bool { @_ == 1 or die "usage: bool(<scalar>)\n" . backtrace(); $_[0] ? 1 : 0 }
-sub invbool { my $a = shift; $$a = !$$a; $$a }
-sub listlength { scalar @_ }
-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 strcpy { substr($_[0], $_[2] || 0, length $_[1]) = $_[1] }
-sub cat_ { local *F; open F, $_[0] or $_[1] ? die "cat of file $_[0] failed: $!\n" : return; my @l = <F>; wantarray ? @l : join '', @l }
-sub cat__ { my ($f) = @_; my @l = <$f>; wantarray ? @l : join '', @l }
-sub output { my $f = shift; local *F; open F, ">$f" or die "output in file $f failed: $!\n"; print F foreach @_; }
-sub deref { ref $_[0] eq "ARRAY" ? @{$_[0]} : ref $_[0] eq "HASH" ? %{$_[0]} : $_[0] }
-sub linkf { unlink $_[1]; link $_[0], $_[1] }
-sub symlinkf { unlink $_[1]; symlink $_[0], $_[1] }
-sub renamef { unlink $_[1]; rename $_[0], $_[1] }
-sub chomp_ { my @l = map { my $l = $_; chomp $l; $l } @_; wantarray ? @l : $l[0] }
-sub divide { my $d = int $_[0] / $_[1]; wantarray ? ($d, $_[0] % $_[1]) : $d }
-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 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 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 sync { syscall_('sync') }
-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 openFileMaybeCompressed { 
-    my ($f) = @_;
-    -e $f || -e "$f.gz" or die "file $f not found";
-    local *F;
-    open F, -e $f ? $f : "gzip -dc $f.gz|" or die "file $f is not readable";
-    *F;
-}
-sub catMaybeCompressed { cat__(openFileMaybeCompressed($_[0])) }
-
-sub psizeof { length pack $_[0] }
 
-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 may_apply { $_[0] ? $_[0]->($_[1]) : (@_ > 2 ? $_[2] : $_[1]) }
-
-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 arch() {
     require c;
     c::kernel_arch();
@@ -166,140 +41,7 @@ sub better_arch {
 }
 sub compat_arch { better_arch(arch(), $_[0]) }
 
-sub touch {
-    my ($f) = @_;
-    unless (-e $f) {
-	local *F;
-	open F, ">$f";
-    }
-    my $now = time;
-    utime $now, $now, $f;
-}
-
-sub map_index(&@) {
-    my $f = shift;
-    my @v; local $::i = 0;
-    map { @v = &$f($::i); $::i++; @v } @_;
-}
-sub grep_index(&@) {
-    my $f = shift;
-    my $v; local $::i = 0;
-    grep { $v = &$f($::i); $::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 list2kv(@) { [ grep_index { even($::i) } @_ ], [ grep_index { odd($::i) } @_ ] }
-
-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, min(map { scalar @$_ } @_), @_);
-}
-sub mapn_(&@) {
-    my $f = shift;
-    smapn($f, max(map { scalar @$_ } @_), @_);
-}
-
-sub add_f4before_leaving {
-    my ($f, $b, $name) = @_;
-
-    unless ($common::before_leaving::{$name}) {
-	no strict 'refs';
-	${"common::before_leaving::$name"} = 1;
-	${"common::before_leaving::list"} = 1;
-    }
-    local *N = *{$common::before_leaving::{$name}};
-    my $list = *common::before_leaving::list;
-    $list->{$b}{$name} = $f;
-    *N = sub {
-	my $f = $list->{$_[0]}{$name} or die '';
-	$name eq 'DESTROY' and delete $list->{$_[0]};
-	goto $f;
-    } unless 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 {}, 'common::before_leaving';
-    add_f4before_leaving($f, $b, 'DESTROY');
-    $b;
-}
-
-sub catch_cdie(&&) {
-    my ($f, $catch) = @_;
-
-    local @common::cdie_catches;
-    unshift @common::cdie_catches, $catch;
-    &$f();
-}
-
-sub cdie {
-    my ($err, $f) = @_;
-    foreach (@common::cdie_catches) {
-	$@ = $err;
-	&{$_}(\$err) and return;
-    }
-    die $err;
-}
-
-sub all {
-    my $d = shift;
 
-    local *F;
-    opendir F, $d or return;
-    my @l = grep { $_ ne '.' && $_ ne '..' } readdir F;
-    closedir F;
-
-    @l;
-}
-
-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 syscall_ {
-    my $f = shift;
-
-    require 'syscall.ph';
-    syscall(&{$common::{"SYS_$f"}}, @_) == 0;
-}
 
 sub salt {
     my ($nb) = @_;
@@ -314,20 +56,6 @@ sub salt {
 sub makedev { ($_[0] << 8) | $_[1] }
 sub unmakedev { $_[0] >> 8, $_[0] & 0xff }
 
-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 translate {
     my ($s) = @_;
     c::dgettext('libDrakX', $s);
@@ -339,190 +67,9 @@ sub untranslate {
     die "untranslate failed";
 }
 
-sub warp_text {
-    my ($text, $width) = @_;
-    $width ||= 80;
-
-    my @l;
-    foreach (split "\n", $text) {
-	my $t = '';
-	foreach (split /\s+/, $_) {
-	    if (length "$t $_" > $width) {
-		push @l, $t;
-		$t = $_;
-	    } else {
-		$t = "$t $_";
-	    }
-	}
-	push @l, $t;
-    }
-    @l;
-}
-
-sub formatAlaTeX {
-    my ($t, $tmp);
-    foreach (split "\n", $_[0]) {
-	if (/^$/) {
-	    $t .= ($t && "\n") . $tmp;
-	    $tmp = '';
-	} else {
-	    $tmp = ($tmp && "$tmp ") . first(/^\s*(.*?)\s*$/);
-	}
-    }
-    $t . ($t && $tmp && "\n") . $tmp;
-}
-
-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 getVarsFromSh {
-    my %l;
-    local *F; open F, $_[0] or return;
-    local $_;
-    while (<F>) {
-	s/#.*//; # remove comments
-	my ($v, $val, $val2) =
-	  /^\s*			# leading space
-	   (\w+) =		# variable
-	   (
-   	       "([^"]*)"	# double-quoted text
-   	     | '([^']*)'	# single-quoted text
-   	     | [^'"\s]+		# normal text
-           )
-           \s*$			# end of line
-          /x or next;
-	$l{$v} = defined $val2 ? $val2 : $val;
-    }
-    %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;
-
-    local *F;
-    open F, "> $file" or die "cannot create config file $file";
-    chmod $mod, $file;
-    $l->{$_} and print F "$_=$l->{$_}\n" foreach @fields;
-}
-
-sub setVarsInCsh {
-    my ($file, $l, @fields) = @_;
-    @fields = keys %$l unless @fields;
-
-    local *F;
-    open F, "> $_[0]" or die "cannot create config file $file";
-    $l->{$_} and print F "setenv $_ $l->{$_}\n" foreach @fields;
-}
-
-sub template2file {
-    my ($in, $out, %toreplace) = @_;
-    output $out, map { s/@@@(.*?)@@@/$toreplace{$1}/g; $_ } cat_($in);
-}
-sub template2userfile {
-    my ($prefix, $in, $out_rel, $force, %toreplace) = @_;
-
-    foreach (list_skels($prefix, $out_rel)) {
-	-d dirname($_) or !-e $_ or $force or next;
-
-	template2file($in, $_, %toreplace);
-	m|/home/(.+?)/| and chown(getpwnam($1), getgrnam($1), $_);
-    }
-}
-sub update_userkderc {
-    my ($file, $category, %subst) = @_;
-
-    output $file,
-      (map {
-	  my $l = $_;
-	  s/^\s*//;
-	  if (my $i = /^\[$category\]/i ... /^\[/) {
-	      if ($i =~ /E/) { #- for last line of category
-		  $l = join('', map_each { "$::a=$::b\n" } %subst) . $l;
-		  %subst = ();
-	      } elsif (/^(\w*?)=/) {
-		  if (my $e = delete $subst{lc($1)}) {
-		      $l = "$1=$e\n";
-		  }
-	      }
-	  }
-	  $l;
-      } cat_($file)),
-	(%subst && "[$category]\n", map_each { "$::a=$::b\n" } %subst); #- if category has not been found above.
-}
-
-sub substInFile(&@) {
-    my $f = shift;
-    foreach my $file (@_) {
-	if (-e $file) {
-	    local @ARGV = $file;
-	    local ($^I, $_) = '';
-	    while (<>) { &$f($_); print }
-	} else {
-	    local *F; my $old = select F; # that way eof return true
-	    local $_ = '';
-	    &$f($_);
-	    select $old;
-	    eval { output($file, $_) };
-	}
-    }
-}
-
-# 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 typeFromMagic {
-    my $f = shift;
-    local *F; sysopen F, $f, 0 or return;
-
-    my $tmp;
-  M: foreach (@_) {
-	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 availableMemory() { sum map { /(\d+)/ } grep { /^(MemTotal|SwapTotal):/ } cat_("/proc/meminfo"); }
+BEGIN { undef *availableRamMB }
 sub availableRamMB()  { 
-    my $s = 4 * round((-s '/proc/kcore') / 1024 / 1024 / 4);
+    my $s = MDK::Common::System::availableRamMB();
     #- HACK HACK: if i810 and memsize
     require detect_devices;
     return $s - 1 if $s == 128 && grep { $_->{driver} =~ /i810/ } detect_devices::probeall();
@@ -566,11 +113,6 @@ sub formatXiB {
     int($newnb * $newbase) . _("TB");
 }
 
-sub formatList {
-    my $nb = shift;
-    join(", ", @_ <= $nb ? @_ : (@_[0..$nb-1], '...'));
-}
-
 sub formatTime {
     my ($s, $m, $h) = gmtime($_[0]);
     if ($h) {
@@ -583,43 +125,10 @@ sub formatTime {
 	_("%d seconds", $s);
     }
 }
-sub formatTimeRaw {
-    my ($s, $m, $h) = gmtime($_[0]);
-    sprintf "%d:%02d:%02d", $h, $m, $s;
-}
-
-#- 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 next_val_in_array {
-    my ($v, $l) = @_;
-    my %l = mapn { @_ } $l, [ @$l[1..$#$l], $l->[0] ];
-    $l{$v};
-}
 
 sub isCdNotEjectable { scalar(grep { /ram3/ } cat_("/proc/mounts")) == 0 }
 
-sub formatError {
-    my ($err) = @_;
-    $err =~ s/ at .*?$/\./ if !$::testing;
-    $err;
-}
-
-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 sync { &MDK::Common::System::sync }
 
 #-######################################################################################
 #- Wonderful perl :(