view release on metacpan or  search on metacpan

perllib/Arch/SharedIndex.pm  view on Meta::CPAN

	$self->query_index_list(sub ($) {
		my $index_list = shift;
		@values = map { $self->fetch_value(@$_) } @$index_list;
	});
	return wantarray? @values: \@values;
}

sub hash ($) {
	my $self = shift;
	my %hash;

	$self->query_index_list(sub ($) {
		my $index_list = shift;
		%hash = map { $_->[0] => $self->fetch_value(@$_) } @$index_list;
	});
	return wantarray? %hash: \%hash;
}

sub list ($) {
	my $self = shift;
	my @list;

	$self->query_index_list(sub ($) {
		my $index_list = shift;
		@list = map { [ $_->[0] => $self->fetch_value(@$_) ] }
			@$index_list;
	});
	return wantarray? @list: \@list;
}

sub grep ($;$) {
	my $self = shift;
	my $code = shift || sub { $_[1] };
	my @keys;

	$self->query_index_list(sub ($) {
		my $index_list = shift;
		@keys = map { $_->[0] }
			grep { &$code($_->[0], $self->fetch_value(@$_)) }
			@$index_list;
	});
	return wantarray? @keys: \@keys;
}

sub filter ($;$) {
	my $self = shift;
	my $code = shift || sub { $_[1] };
	my @keys;

	$self->query_index_list(sub ($) {
		my $index_list = shift;
		@keys = map { $_->[0] }
			grep { &$code($_->[0], $self->fetch_value(@$_)) }
			@$index_list;
		$self->_do_delete($index_list, \@keys);
	});
	return wantarray? @keys: \@keys;
}

sub update ($$;$) {
	my $self = shift;
	my $code = shift;
	my $grep_code = shift;
	die "No code or value given" unless defined $code;
	my $entries_updated;

	$self->query_index_list(sub ($) {
		my $index_list = shift;
		$entries_updated = $self->_do_store($index_list, [
			map { $_->[0] => ref($code) ne 'CODE'? $code:
				&$code($_->[0], $self->fetch_value(@$_)) }
			grep { $grep_code? &$grep_code(
				$_->[0], $self->fetch_value(@$_)): 1 }
			@$index_list
		]);
	});
	return $entries_updated;
}

sub query_index_list ($$) {
	my $self = shift;
	my $code = shift;

	my $file = $self->{file};
	if (!-f $file && $self->{can_create}) {
		open FH, ">$file" or die "Can't create index file ($file)\n";
		close FH;
	}
	-f $file or die "No index file ($file)\n";

	open FH, "+<$file" or die "Can't open $file for updating: $!\n";
	flock FH, 2;         # wait for exclusive lock
	seek FH, 0, 0;       # rewind to beginning
	my @content = <FH>;  # get current content
	chomp @content;

	my $index_list = [ grep { defined } map {
		/^(\d+)\t(.+?)\t(.*)/? [ $2, $3, $1 ]:
			warn("Corrupt line ($_) in $file; ignored\n"), undef
	} @content ];

	if ($self->{expiration}) {
		my $time = time();
		my $diff = $self->{expiration};
		my @expired_keys = map { $_->[0] }
			grep { $time - $_->[2] > $diff } @$index_list;
		$self->_do_delete($index_list, \@expired_keys) if @expired_keys;
	}

	# apply callback filter
	&$code($index_list);

	if ($self->{max_size} && @$index_list > $self->{max_size}) {
		my @excess_nums = (0 .. @$index_list - $self->{max_size} - 1);
		my @excess_keys = map { $_->[0] } (@$index_list)[@excess_nums];
		$self->_do_delete($index_list, \@excess_keys);
	}

	my @new_content = map { "$_->[2]\t$_->[0]\t$_->[1]" } @$index_list;
	my $is_changed = join('', @content) ne join('', @new_content);