package common; use diagnostics; use strict; use vars qw(@ISA %EXPORT_TAGS @EXPORT_OK $printable_chars $sizeof_int $bitof_int $cancel $SECTORSIZE); @ISA = qw(Exporter); %EXPORT_TAGS = ( common => [ qw(__ min max sum sign product bool bool2text ikeys member divide is_empty_array_ref add2hash set_new set_add round_up round_down first second top uniq translate untranslate warp_text) ], functional => [ qw(fold_left map_index mapn mapn_ difference2 before_leaving catch_cdie cdie) ], file => [ qw(dirname basename touch all glob_ cat_ chop_ mode) ], system => [ qw(sync makedev unmakedev psizeof strcpy gettimeofday syscall_ crypt_ getVarsFromSh setVarsInSh) ], constant => [ qw($printable_chars $sizeof_int $bitof_int $SECTORSIZE) ], ); @EXPORT_OK = map { @$_ } values %EXPORT_TAGS; $printable_chars = "\x20-\x7E"; $sizeof_int = psizeof("i"); $bitof_int = $sizeof_int * 8; $SECTORSIZE = 512; 1; sub fold_left(&@) { my $f = shift; local $a = shift; foreach $b (@_) { $a = &$f() } $a } sub _ { my $s = shift @_; sprintf translate($s), @_ } #delete $main::{'_'}; sub __ { $_[0] } sub min { fold_left { $a < $b ? $a : $b } @_ } sub max { fold_left { $a > $b ? $a : $b } @_ } sub sum { fold_left { $a + $b } @_ } sub sign { $_[0] <=> 0 } sub product { fold_left { $a * $b } @_ } sub first { $_[0] } sub second { $_[1] } sub top { $_[$#_] } sub uniq { my %l; @l{@_} = (); keys %l } sub ikeys { my %l = @_; sort { $a <=> $b } keys %l } sub add2hash { my ($a, $b) = @_; while (my ($k, $v) = each %{$b || {}}) { $a->{$k} ||= $v } } sub member { my $e = shift; foreach (@_) { $e eq $_ and return 1 } 0 } sub dirname { @_ == 1 or die "usage: dirname \n"; local $_ = shift; s|[^/]*/*\s*$||; s|(.)/*$|$1|; $_ || '.' } sub basename { @_ == 1 or die "usage: basename \n"; local $_ = shift; s|/*\s*$||; s|.*/||; $_ } sub bool { $_[0] ? 1 : 0 } sub bool2text { $_[0] ? "true" : "false" } 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 = ; wantarray ? @l : join '', @l } sub chop_ { map { my $l = $_; chomp $l; $l } @_ } sub divide { my $d = int $_[0] / $_[1]; wantarray ? ($d, $_[0] % $_[1]) : $d } sub round_up { my ($i, $r) = @_; $i += $r - ($i + $r - 1) % $r - 1; } sub round_down { my ($i, $r) = @_; $i -= $i % $r; } sub is_empty_array_ref { my $a = shift; !defined $a || @$a == 0 } sub difference2 { my %l; @l{@{$_[1]}} = (); grep { !exists $l{$_} } @{$_[0]} } sub set_new(@) { my %l; @l{@_} = undef; { list => [ @_ ], hash => \%l } } sub set_add($@) { my $o = shift; foreach (@_) { exists $o->{hash}{$_} and next; push @{$o->{list}}, $_; $o->{hash}{$_} = undef } } sub sync { syscall_('sync') } sub gettimeofday { my $t = pack "LL"; syscall_('gettimeofday', $t, 0) or die "gettimeofday failed: $!\n"; unpack("LL", $t) } sub remove_spaces { local $_ = shift; s/^ +//; s/ +$//; $_ } sub mode { my @l = stat $_[0] or die "unable to get mode of file $_[0]: $!\n"; $l[2] } sub psizeof { length pack $_[0] } sub touch { my $f = shift; unless (-e $f) { local *F; open F, ">$f"; } my $now = time; utime $now, $now, $f; } sub map_index(&@) { my $f = shift; my @l; local $::i = 0; foreach (@_) { push @l, &$f($::i); $::i++; } @l; } 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 { $@ = join '', @_; foreach (@common::cdie_catches) { &{$_}(@_) and return; } die join '', @_; } sub all { my $d = shift; local *F; opendir F, $d or die "all: can't open dir $d: $!\n"; grep { $_ ne '.' && $_ ne '..' } readdir F; } 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 crypt_ { local $_ = (gettimeofday())[1] % 0x40; tr [\0-\x3f] [0-9a-zA-Z./]; crypt($_[0], $_) } sub makedev { ($_[0] << 8) | $_[1] } sub unmakedev { $_[0] >> 8, $_[0] & 0xff } sub translate { my ($s) = @_; my ($lang) = substr($ENV{LC_ALL} || $ENV{LANGUAGE} || $ENV{LC_MESSAGES} || $ENV{LANG} || '', 0, 2); unless (defined $po::I18N::{$lang}) { local $@; local $SIG{__DIE__} = 'none'; eval { require "po/$lang.pm"; }; } $po::I18N::{$lang} or return $s; my $l = *{$po::I18N::{$lang}}; $l->{$s} || $s; } sub untranslate($@) { my $s = shift; foreach (@_) { translate($_) eq $s and return $_ } 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 getVarsFromSh($) { my %l; local *F; open F, $_[0] or return; foreach () { 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} = $val2 || $val; } %l; } sub setVarsInSh { 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 "$_=$l->{$_}\n" foreach @fields; }