# Arch Perl library, Copyright (C) 2004 Mikhael Goikhman
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
use 5.005;
use strict;
package Arch::SharedIndex;
sub new ($%) {
my $class = shift;
my %init = @_;
my $file = $init{file} or die "No index file given\n";
my $can_create = exists $init{can_create}? $init{can_create}: 1;
my $time_renewal = exists $init{time_renewal}? $init{time_renewal}:
$init{max_size}? 1: 0;
my $self = {
file => $file,
can_create => $can_create,
max_size => int($init{max_size} || 0),
expiration => int($init{expiration} || 0),
time_renewal => $time_renewal,
perl_data => $init{perl_data} || 0,
perl_data_indent => $init{perl_data_indent} || 0,
perl_data_pair => $init{perl_data_pair} || "=>",
};
bless $self, $class;
return $self;
}
sub encode_value ($$) {
my $self = shift;
return unless $self->{perl_data};
my $value = shift;
# Data::Dumper is one of the silly-API modules; configure every time.
# Object oriented API is a bit slower and less backward compatible.
# Avoid unused variable warnings by separate declaration/assignment.
require Data::Dumper;
local $Data::Dumper::Indent;
local $Data::Dumper::Pair;
local $Data::Dumper::Quotekeys;
local $Data::Dumper::Terse;
$Data::Dumper::Indent = $self->{perl_data_indent};
$Data::Dumper::Pair = $self->{perl_data_pair};
$Data::Dumper::Quotekeys = 0;
$Data::Dumper::Terse = 1;
$$value = Data::Dumper->Dump([$$value]);
}
sub decode_value ($$) {
my $self = shift;
return unless $self->{perl_data};
my $value = shift;
$$value = eval $$value;
}
sub delete_value ($$$) {
my $self = shift;
my ($key, $token) = @_;
# super class implementation
}
sub fetch_value ($$$) {
my $self = shift;
my ($key, $token) = @_;
# super class implementation
my $value = $token;
$self->decode_value(\$value);
return $value;
}
sub store_value ($$$) {
my $self = shift;
my ($key, $token, $value) = @_;
# super class implementation
$self->encode_value(\$value);
$token = $value;
return $token;
}
sub index_list_to_hash ($$) {
my $self = shift;
my $index_list = shift;
my $index_hash = {};
foreach my $entry (@$index_list) {
$index_hash->{$entry->[0]} = $entry;
}
return $index_hash;
}
sub _do_delete ($$$) {
my $self = shift;
my $index_list = shift;
my $keys = shift;
my %keys = map { $_ => 1 } @$keys;
for (my $num = @$index_list - 1; %keys && $num >= 0; $num--) {
my $index_entry = $index_list->[$num];
my ($key, $token) = @$index_entry;
next unless $keys{$key};
$self->delete_value($key, $token);
splice(@$index_list, $num, 1);
delete $keys{$key};
}
return @$keys - keys %keys;
}
sub _do_fetch ($$$) {
my $self = shift;
my $index_list = shift;
my $keys = shift;
my @values = ();
my $index_hash = $self->index_list_to_hash($index_list);
my $time;
foreach my $key (@$keys) {
my $index_entry = $index_hash->{$key};
my $value = $index_entry?
$self->fetch_value(@$index_entry): undef;
if (defined $value && $self->{time_renewal}) {
$time ||= time();
$index_entry->[2] = $time;
}
push @values, $value;
}
return \@values;
}
sub _do_store ($$$) {
my $self = shift;
my $index_list = shift;
my @new_key_values = @{shift()};
my $entries_stored = 0;
my $index_hash = $self->index_list_to_hash($index_list);
my $time = time;
my %seen = ();
while (my ($key, $value) = splice(@new_key_values, 0, 2)) {
next if $seen{$key}; $seen{$key} = 1;
my $old_entry = $index_hash->{$key};
my $old_token = $old_entry? $old_entry->[1]: undef;
my $new_token = $self->store_value($key, $old_token, $value);
next unless defined $new_token;
my $new_entry = [ $key, $new_token, $time ];
if (defined $old_entry) {
@$old_entry = @$new_entry;
} else {
push @$index_list, $new_entry;
}
$entries_stored++;
}
return $entries_stored;
}
sub delete ($@) {
my $self = shift;
my $keys = ref($_[0]) eq 'ARRAY'? shift: [ @_ ];
my $entries_deleted;
$self->query_index_list(sub ($) {
my $index_list = shift;
$entries_deleted = $self->_do_delete($index_list, $keys);
});
return $entries_deleted;
}
sub fetch ($@) {
my $self = shift;
my $single_ref = ref($_[0]) eq 'ARRAY';
my $keys = $single_ref? shift: [ @_ ];
my $values = [];
$self->query_index_list(sub ($) {
my $index_list = shift;
$values = $self->_do_fetch($index_list, $keys);
});
return $single_ref? $values: wantarray? @$values: $values->[0];
}
sub store ($%) {
my $self = shift;
my $new_key_values =
ref($_[0]) eq 'HASH'? [ %{shift()} ]: # unordered
ref($_[0]) eq 'ARRAY'? shift: [ @_ ]; # ordered
my $entries_stored;
$self->query_index_list(sub ($) {
my $index_list = shift;
$entries_stored = $self->_do_store($index_list, $new_key_values);
});
return $entries_stored;
}
sub fetch_store ($$@) {
my $self = shift;
my $code = shift || die "No code given";
my $single_ref = ref($_[0]) eq 'ARRAY';
my $keys = $single_ref? shift: [ @_ ];
my $values;
$self->query_index_list(sub ($) {
my $index_list = shift;
$values = $self->_do_fetch($index_list, $keys);
my (@new_keys, @missing_idxs);
my $run_idx = 0;
@new_keys = grep { (defined $values->[$run_idx]? 0:
push @missing_idxs, $run_idx) * ++$run_idx } @$keys;
if ($ENV{DEBUG} && ("$ENV{DEBUG}" & "\2") ne "\0") {
my $status = @new_keys? @new_keys == @$keys? "miss":
"partial hit-miss": "hit";
my $keystr = join(', ', @$keys);
substr($keystr, 57) = "..." if length($keystr) > 60;
print STDERR "Shared fetch_store ($keystr): $status\n";
}
return unless @new_keys;
my @new_key_values = map { $_ => ref($code) ne 'CODE'?
$code: &$code($_) } @new_keys;
my $num_stored = $self->_do_store($index_list, \@new_key_values);
warn "fetch_store: not all new values are actually stored\n"
if $num_stored < @new_keys;
@$values[@missing_idxs] =
@new_key_values[map { $_ * 2 + 1 } 0 .. @new_keys - 1];
});
return $single_ref? $values: wantarray? @$values: $values->[0];
}
sub keys ($) {
my $self = shift;
my @keys;
$self->query_index_list(sub ($) {
my $index_list = shift;
@keys = map { $_->[0] } @$index_list;
});
return wantarray? @keys: \@keys;
}
sub values ($) {
my $self = shift;
my @values;
$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);
if ($is_changed) {
seek FH, 0, 0; # rewind again
truncate FH, 0; # empty the file
print FH map { "$_$/" } @new_content;
}
close FH; # release file
}
1;
__END__
=head1 NAME
Arch::SharedIndex - a synchronized data structure (map) for IPC
=head1 SYNOPSIS
use Arch::SharedIndex;
my $map = Arch::SharedIndex->new(file => "/tmp/logintimes.idx");
my $time = time;
$map->store(migo => $time - 75, bob => $time - 5, enno => $time);
printf "All users: %s, %s, %s\n", $map->keys;
printf "New users: %s\n", $map->grep(sub { $_[1] == $time });
printf "Login time of migo: %s\n", $map->fetch('migo');
$map->update(sub { $_[1] + 10 }, sub { $_[1] == $time });
$map->store(migo => $time);
$map->delete('bob');
printf "Logged users with times: (%s)\n", join(", ", $map->hash);
=head1 DESCRIPTION
Arch::SharedIndex provides a key-value map that can be shared and
accessed safely by multiple processes.
=head1 METHODS
The following methods are available:
B<new>,
B<encode_value>,
B<decode_value>,
B<store_value>,
B<fetch_value>,
B<delete_value>,
B<store>,
B<fetch>,
B<delete>,
B<fetch_store>,
B<keys>,
B<values>,
B<hash>,
B<list>,
B<grep>,
B<filter>,
B<update>,
B<query_index_list>.
=over 4
=item B<new> I<options>
Create a new index object. I<option> is a hash of parameters.
=over 4
=item B<file>
The path of the index file, used to store data. Must not be omitted.
=item B<can_create>
Whether the index file is automatically created. Defaults to 1.
=item B<max_size>
Maximum number of entries in the index. Defaults to 0 (no limit).
=item B<expiration>
Timeout in seconds after which unused entries are removed. Defaults
to 0 (don't expire entries)
=item B<time_renewal>
Whether fetching values resets the entry expiration timeout. Defaults
to 1 if B<max_size> is set, 0 otherwise.
=item B<perl_data>
Whether non-scalar perl data can be stored. If true, values are
encoded using Data::Dumper.
=item B<perl_data_indent>
Indent value for Data::Dumper when B<perl_data> is set. Defaults to
0.
=item B<perl_data_pair>
Pair value for Data::Dumper when B<perl_data> is set. Defaults to
C<=E<gt>>.
=back
=item B<encode_value> I<ref>
Encode the value referenced by I<ref> in a string representation.
The encoding is done in place.
=item B<decode_value> I<ref>
Decode a value encoded with B<encode_value> from its string
representation. The decoding is done in place.
=item B<store_value> I<key> I<token> I<value>
Store a value for the given I<key> and I<token>. Create a new token
if none is given. Returns the (new) token. Sub-classes should
implement this method.
=item B<fetch_value> I<key> I<token>
Fetch the value stored for the given I<key> and I<token>. Sub-classes
should implement this method.
=item B<delete_value> I<key> I<token>
Delete a value stored for the given I<key> and I<value>. Sub-classes
should implement this method.
=item B<store> I<kvp>
Store a set of key-value pairs. I<kvp> may either be a reference to a
hash or array, or list of keys and values.
=item B<fetch> I<keys>
Fetch values stored for a list of keys. I<keys> may either be an array
reference, or a list of keys.
=item B<delete> I<keys>
Delete values stored for a list of keys. I<keys> may either be an
array reference, or a list of keys.
=item B<fetch_store> I<mapfunc> I<keys>
This is an optimized (B<fetch> or B<store>) in a single step. Fetch
values stored for keys, just like B<fetch>, but store values for the
missing keys in the process. I<keys> may be an array reference or a list
of keys. I<mapfunc> will be called once for every key in I<keys> that
has no associated value, with the key as its only argument. Its return
value will be stored for that key.
=item B<keys>
Returns a list of all valid keys. In scalar context, returns an array
reference.
Keys are returned in no particular order, but B<values> will return
values in matching order if the index has not been changed between
calls.
=item B<values>
Returns a list of all stored values. In scalar context, returns an
array reference.
Values are returned in no particular order, but B<keys> will return
values in matching order if the index has not been changed between
calls.
=item B<hash>
Returns the stored keys and values as a perl hash. In scalar context,
returns hash reference.
=item B<list>
Returns the stored keys and values as a list of pairs (array
references with two elements each). In scalar context, returns an
array reference.
=item B<grep> I<predicate>
Returns a list of keys for which I<predicate> returns a true value.
I<predicate> is called once for every key, with the key and the stored
value as its first and second argument.
=item B<filter> I<predicate>
Deletes every entry for which I<predicate> returns a true value.
I<predicate> is called once for every key, with the key and the stored
value asi its first and second argument.
=item B<update> I<mapfunc> I<predicate>
Updates the value for every key for which I<predicate> returns a true
value with the return value from I<mapfunc>. Both I<predicate> and
I<mapfunc> are called with the key and the stored values as their
first and second argument.
=item B<update_index_list> I<code>
Synchronize access and call I<code> with a reference to a list of
pairs, each containing the key and token, for every stored value.
Used internally by B<store>, B<fetch>, B<delete>, B<fetch_store>,
B<keys>, B<values>, B<hash>, B<list>, B<grep>, B<filter> and B<update>.
=back
=head1 BUGS
Awaiting for your reports.
=head1 AUTHORS
Mikhael Goikhman (migo@homemail.com--Perl-GPL/arch-perl--devel).
Enno Cramer (uebergeek@web.de--2003/arch-perl--devel).
=head1 SEE ALSO
For more information, see L<Arch::SharedCache>.
=cut