package DBF;

# Manage key => content in certain path/file
# Rolf Rost, 18.12.2011
###########################################################################
use strict;
use warnings;
use Carp;
use IO::File;
use Fcntl qw(:flock);
use bytes;

sub new{
	my $class = shift;
	my $path  = shift || croak "Missing path/file for DBF";
	my %cfg   = (
		lock => 0,  # LOCK_EX
		auto => 0,  # auto store in cleanup
		@_
	);

	my $self = bless{
		PATH => $path,
		LOCK => $cfg{lock},
		AUTO => $cfg{auto},
		FH => undef,
		DATA => {},     # buffer for _serialize
		SETN => {},     # cache to setting new key/value pairs
		IDX  => {},     # binary index from file, key => offset,length
	}, $class;
	$self->_initfile || croak "error while init path/file, IO: $!";
	
	return $self;
}
############################### PRIVATE METHODS ###########################
# obtain the filehandler
sub _initfile{
	my $self = shift;
	$self->{FH} = IO::File->new;
	$self->{FH}->open($self->{PATH}, O_CREAT|O_BINARY|O_RDWR) or return undef;
	if($self->{LOCK}){
		$self->{LOCK} = flock($self->{FH}, LOCK_EX) || carp "your system does not support flock";
	}
	# read the index from file to IDX
	$self->_index;

	return 1;
}

# build the index from file
sub _index{
	my $self = shift;
	$self->{FH}->seek(0,0);
	my $buffer = '';
	my $key    = '';
	$self->{IDX} = {};
	while( read $self->{FH}, $buffer, 4 ){
		my $len = unpack('N', $buffer);  # length for key
		read $self->{FH}, $key, $len;    # now read the key
		read $self->{FH}, $buffer, 4;    # read length for value
		$len = unpack 'N', $buffer;      # length for value
		my $offs = $self->{FH}->tell;    # get the offset for value
		read $self->{FH}, $buffer, $len; # now read the value
		$self->{IDX}{$key} = pack 'NN', $offs, $len;
	}
}

# returns a hasref for data from file
sub _deserialize{
	my $self = shift;
	$self->{FH}->seek(0,0);
	my $buffer = '';
	my $key    = '';
	my %ret    = (); # return hash, data from file
	while( read $self->{FH}, $buffer, 4 ){
		my $len = unpack('N', $buffer);  # length for key
		read $self->{FH}, $key, $len;    # now read the key
		read $self->{FH}, $buffer, 4;    # read length for value
		$len = unpack 'N', $buffer;      # length for value
		read $self->{FH}, $buffer, $len; # now read the value
		$ret{$key} = $buffer;
	}
	return \%ret;
}

# expects all content in {DATA}
sub _serialize{
	my $self = shift;
	$self->{FH}->truncate(0) || return undef;
	$self->{FH}->seek(0,0) || return undef;
	while( my($k,$v) = each %{$self->{DATA}}){
		$self->{FH}->print(pack('N', length($k)).$k.pack('N', length($v)).$v);
	}
	$self->{DATA} = {};
	return 1;
}

sub DESTROY{
	my $self = shift;
	$self->store if $self->{AUTO};
}

# fetch values for key from {IDX}
sub _xfetch{
	my $self = shift;
	my %fdata = ();
	foreach my $k(keys %{$self->{IDX}}){
		$fdata{$k} = $self->val($k);	
	}
	return \%fdata;
}
################################# PUBLIC METHODS ##########################
# set one or more values in SETN hash (new data), cache
sub set{
	my $self = shift;
	return undef if scalar(@_) %2 != 0;
	%{$self->{SETN}} = (%{$self->{SETN}}, @_);
}
# wrapper for _serialize
sub store{
	my $self = shift;
	
	# expects all Data in {DATA}
	# read data from file at 1st: for  keys from {IDX} only!
	my $fdata = $self->_xfetch;
	# merge...
	%{$self->{DATA}} = (%{$fdata}, %{$self->{SETN}});
	$self->_serialize;
	return 1;
}

# returns one value for a key in file
sub val{
	my $self = shift;
	my $key  = shift || return undef;
	
	# at 1st looking for val in {SETN}
	if(exists $self->{SETN}{$key}){ return $self->{SETN}{$key} }
	elsif(exists $self->{IDX}{$key}){
		# fetch value from file
		my($offs, $len) = unpack 'NN', $self->{IDX}{$key};
		$self->{FH}->seek($offs, 0);
		my $buffer = '';
		read $self->{FH}, $buffer, $len;
		return $buffer;
	}
	else{ return undef }
}

# delete one key => val
sub del{
	my $self = shift;
	my $key  = shift or return undef;
	delete $self->{SETN}{$key};
	delete $self->{IDX}{$key};
}
# delete all content
sub clear{
	my $self = shift;
	$self->{DATA} = {};
	$self->{SETN} = {};
	$self->{IDX}  = {};
	$self->_serialize;
}

# usual for development
sub dump{
	my $self = shift;
	print "============== Cache =================\n";
	foreach my $k(sort keys %{$self->{SETN}}){
		printf "%-13s => %s\n", $k, $self->{SETN}{$k};
	}
	print "============== Index =================\n";
	foreach my $k(sort keys %{$self->{IDX}}){
		printf "%-13s => %s\n", $k, $self->val($k);
	}
#	print "============== Data ==================\n";
#	foreach my $k(sort keys %{$self->{DATA}}){
#		printf "%-13s => %s\n", $k, $self->{DATA}($k);
#	}
}

# add a file
sub addfile{
	my $self = shift;
	my $path = shift || return undef;
	my $name = shift || $path;
	my $fh = IO::File->new || croak "Can't create a filehandler";
	$fh->open($path, O_RDONLY|O_BINARY) || croak "Can't open file $path, IO-Error: $!";
	my $body = '';
	read $fh, $body, -s $fh;
	$fh->close;	
	$self->{SETN}{$name} = $body;
}


1;#########################################################################

use strict;
use warnings;
use Data::Dumper;
use utf8;

my $dbf = DBF->new("/tmp/dbf.bin", auto => 1, lock => 0) or die $!;
#$dbf->set(name => 'Haselhuhn', vname => 'Horst');
#$dbf->clear;
#$dbf->addfile('c:/windows/system32/drivers/etc/services', "s");
#$dbf->dump;
binmode STDOUT, ":raw";
print $dbf->val('s');
#print "\n========= Dumper Object =============================\n", Dumper $dbf;