[devel] repocop 0.07 changes
Alexey Tourbin
=?iso-8859-1?q?at_=CE=C1_altlinux=2Eru?=
Пт Мар 28 23:28:52 MSK 2008
On Mon, Mar 24, 2008 at 09:34:48PM +0200, Igor Vlasenko wrote:
> > Я для этого в свое время в пакете qa-robot сделал cmdcache(1).
> > Но никакой инвалидации кеша там нет, так что это можно использовать
> > только для очень стабильно работающих команд -- например, для file(1)
> > в сочетании c nm(1).
>
> Кстати, куски qa-robot и в состав федоры входят, в пакете
> rpmdevtools. Меня как раз qa-robot и вдохновил. Хотелось
> чего-то этакого, но чтобы легче добавлять тесты.
Сие практически отрадно, но не очень. На самом деле topic
это коллекторы vs мемоизация. Я считаю, что мемоизация для
базовых/стабильных/низкоуровневых данных подходит лучше, чем коллекторы.
Коллекторы -- это избыточная бизнес-логика, а мемоизация может быть
полностью прозрачной.
Я в свое время тоже написал пригорошню перловых модлуей для этого дела,
но они так нигде и не были опубликованы, поелику я счел, что на шелле
и так получается достаточно дёшево и сердино.
Далее приложено несколько файлов где-то конца 2005--начала 2006 года:
qa::cache - суперэффективный кеш на основе BerkeleyDB и Compress::LZO;
qa::memoize -- мемоизация обработки файлов;
qa::rpmsoname -- то что делает rpmsoname(1).
В принципе есть ещё всякий код та эту тему, но скорее недоделанный.
Мое мнение простое -- мемоизация, когда она возможна, лучше специальной
бизнес-логики. Всё где-то хранится, и какая разница, где хранить.
А если взгяд на вещи упрощается, то разница такая, что мне проще об этом
думать. А это может стоить не меньше двадцати долларов!!
----------- следующая часть -----------
package qa::cache;
use strict;
use BerkeleyDB;
our $topdir = "$ENV{HOME}/.qa-cache";
my $topdir_fd;
my $dbenv;
sub init_dbenv () {
use Fcntl qw(:flock O_DIRECTORY);
-d $topdir or mkdir $topdir;
sysopen $topdir_fd, $topdir, O_DIRECTORY or die "$topdir: $!";
if (flock $topdir_fd, LOCK_EX | LOCK_NB) {
$dbenv = BerkeleyDB::Env->new(-Home => $topdir,
-Verbose => 1, -ErrFile => *STDERR,
-Flags => DB_CREATE | DB_INIT_CDB | DB_INIT_MPOOL)
or die $BerkeleyDB::Error;
# TODO: drop all locks
flock $topdir_fd, LOCK_SH;
}
else {
flock $topdir_fd, LOCK_SH;
$dbenv = BerkeleyDB::Env->new(-Home => $topdir,
-Verbose => 1, -ErrFile => *STDERR,
-Flags => DB_JOINENV)
or die $BerkeleyDB::Error;
}
}
my %blessed;
my $pagesize;
sub TIEHASH ($$) {
my ($class, $id) = @_;
return $blessed{$id} if $blessed{$id};
init_dbenv() unless $dbenv;
my $dir = "$topdir/$id";
-d $dir or mkdir $dir;
my $db = BerkeleyDB::Hash->new(-Filename => "$id/cache.db",
-Env => $dbenv, -Flags => DB_CREATE)
or die $BerkeleyDB::Error;
$pagesize ||= $db->db_stat->{hash_pagesize};
my $self = bless [ $dir, $db ] => $class;
$blessed{$id} = $self;
use Scalar::Util qw(weaken);
weaken $blessed{$id};
return $self;
}
use Storable qw(freeze thaw);
use Compress::LZO qw(compress decompress);
use Digest::SHA1 qw(sha1);
use constant {
V_STO => 2**1, # STO is Special Theory of Relativity
V_LZO => 2**2, # LZO is real-time compressor
};
my $today = int($^T / 3600 / 24);
sub STORE ($$$) {
my ($self, $k, $v) = @_;
$k = freeze($k) if ref $k;
$k = sha1($k);
my $vflags = 0;
if (ref $v) {
$v = freeze($v);
$vflags |= V_STO;
}
if (length($v) > 768) {
$v = compress($v);
$vflags |= V_LZO;
}
my ($dir, $db) = @$self;
if (length($v) > $pagesize / 2) {
my ($subdir, $file) = unpack "H2H*", $k;
$subdir = "$dir/$subdir";
$file = "$subdir/$file";
-d $subdir or mkdir $subdir;
open my $fh, ">", "$file.$$" or die $!;
syswrite $fh, pack("S", $vflags);
syswrite $fh, $v;
close $fh;
rename "$file.$$", $file;
}
else { # SSS: mtime, atime, vflags
$db->db_put($k, pack("SSS", $today, 0, $vflags) . $v);
}
}
sub FETCH ($$) {
my ($self, $k) = @_;
$k = freeze($k) if ref $k;
$k = sha1($k);
my ($dir, $db) = @$self;
my ($vflags, $v);
if ($db->db_get($k, $v) == 0) {
(my $m, my $a, $vflags) = unpack "SSS", $v;
substr $v, 0, 6, "";
$db->db_put($k, pack("SSS", $m, $today, $vflags) . $v)
if $a != $today; # XXX not atomic
}
else {
my ($subdir, $file) = unpack "H2H*", $k;
$subdir = "$dir/$subdir";
$file = "$subdir/$file";
open my $fh, "<", $file or return;
local $/;
$v = <$fh>;
$vflags = unpack "S", $v;
substr $v, 0, 2, "";
}
$v = decompress($v) if $vflags & V_LZO;
$v = thaw($v) if $vflags & V_STO;
return $v;
}
sub EXISTS ($$) {
my ($self, $k) = @_;
$k = freeze($k) if ref($k);
$k = sha1($k);
my ($dir, $db) = @$self;
return 1 if $db->db_get($k, my $v) == 0;
my ($subdir, $file) = unpack "H2H*", $k;
$subdir = "$dir/$subdir";
$file = "$subdir/$file";
return -f $file;
}
sub DELETE ($$) {
my ($self, $k) = @_;
$k = freeze($k) if ref($k);
$k = sha1($k);
my ($dir, $db) = @$self;
$db->db_del($k);
my ($subdir, $file) = unpack "H2H*", $k;
$subdir = "$dir/$subdir";
$file = "$subdir/$file";
unlink $file;
}
# BerkeleyDB cleans up at the END, so do I
my $global_destruction;
# execute the END when interrupted by a signal --
# it is VERY important to release all locks and shut down gracefully
use sigtrap qw(die normal-signals);
our $expire = 33;
sub DESTROY ($) {
return if $global_destruction;
my $self = shift;
my ($dir, $db) = @$self;
my $cur = $db->_db_write_cursor() or return;
if ($db->db_get("cleanup", my $cleanup) != 0) {
$db->db_put("cleanup", $today);
return;
}
elsif ($cleanup == $today) {
return;
}
while ($cur->c_get(my $k, my $v, DB_NEXT) == 0) {
next if $k eq "cleanup";
my ($m, $a, $vflags) = unpack "SSS", $v;
next if $a + 33 > $today;
next if $m + 33 > $today;
$cur->c_del();
}
my $wanted = sub {
stat or return;
-f _ and -M _ > $expire and -A _ > $expire and unlink;
-d _ and rmdir;
};
require File::Find;
File::Find::finddepth($wanted, $dir);
}
END {
undef $dbenv;
while (my ($id, $self) = each %blessed) {
next unless $self;
$self->DESTROY();
undef @$self;
}
$global_destruction = 1;
}
1;
----------- следующая часть -----------
package qa::memoize;
use strict;
our $NOCACHE ||= $ENV{QA_NOCACHE};
use qa::cache;
use File::stat qw(stat);
sub memoize_st1 ($) {
return if $NOCACHE;
my $id = shift;
my $pkg = caller;
my $sym = $pkg . '::' . $id;
no strict 'refs';
my $code = *{$sym}{CODE};
my $cache;
no warnings 'redefine';
*$sym = sub ($) {
goto $code if $NOCACHE;
my $f = shift;
$cache ||= qa::cache->TIEHASH($id);
my $st0 = stat($f) or die "$id: $f: $!";
my @ism0 = ($st0->ino, $st0->size, $st0->mtime);
my $v = $cache->FETCH("@ism0");
return $v if defined $v;
$v = $code->($f);
my $st1 = stat($f) or die "$id: $f: $!";
my @ism1 = ($st1->ino, $st1->size, $st1->mtime);
die "$id: $f: file has changed" unless "@ism0" eq "@ism1";
$cache->STORE("@ism0", $v) if defined $v;
return $v;
}
}
require Exporter;
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(memoize_st1);
1;
----------- следующая часть -----------
package qa::rpmsoname;
use strict;
use RPM::Header;
sub rpmsoname ($) {
my $fname = shift;
my $rpm = RPM::Header->new($fname) or die "$fname: $RPM::err";
my %filenames = do { my $i = 0; map { $_, $i++ } @{$rpm->filenames||[]} };
my $rpm_realpath = sub ($) {
my $i = shift;
while (my $link = $$rpm{FILELINKTOS}[$i]) {
my $dir = $$rpm{DIRNAMES}[$$rpm{DIRINDEXES}[$i]];
use File::Spec;
local $_ = File::Spec->rel2abs($link, $dir);
1 while s#/[^/]+/[.][.]/#/#; # XXX
if (exists $filenames{$_}) {
$i = $filenames{$_};
} else {
my $basename = $$rpm{BASENAMES}[$i];
warn "$fname: outer link $dir$basename -> $_\n";
return;
}
}
return $i;
};
my @prov = grep { /^lib[^(\/)\s]+[.]so\b[^(\/)\s]*$/ } @{$$rpm{PROVIDES}};
my @ret;
for my $soname (@prov) {
my @i = map { $$_[0] } grep { $$_[1] eq $soname }
do { my $i = 0; map {[ $i++, $_ ]} @{$$rpm{BASENAMES}}; };
my @j = map { $rpm_realpath->($_) } @i;
@j = do { my %j = map { $_, 1 } @j; keys %j };
if (@j == 0) {
warn "$fname: no file for $soname\n";
next;
}
if (@j > 1) {
warn "$fname: $soname maps to a few files\n";
}
my $i = $j[0];
push @ret, [ $soname, $$rpm{DIRNAMES}[$$rpm{DIRINDEXES}[$i]] . $$rpm{BASENAMES}[$i] ];
}
return \@ret;
}
use qa::memoize qw(memoize_st1);
memoize_st1("rpmsoname");
require Exporter;
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(rpmsoname);
1;
----------- следующая часть -----------
Было удалено вложение не в текстовом формате...
Имя : =?iso-8859-1?q?=CF=D4=D3=D5=D4=D3=D4=D7=D5=C5=D4?=
Тип : application/pgp-signature
Размер : 197 байтов
Описание: =?iso-8859-1?q?=CF=D4=D3=D5=D4=D3=D4=D7=D5=C5=D4?=
Url : <http://lists.altlinux.org/pipermail/devel/attachments/20080328/6aab38fd/attachment-0002.bin>
Подробная информация о списке рассылки Devel