[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