package DBF;

# Persistent store 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 for setting new key/value pairs
		IDX  => {},     # binary index from file, key => offset,length
	}, $class;
	$self->_initfile;
	
	return $self;
}
############################### PRIVATE METHODS ###########################
# obtain the filehandler
sub _initfile{
	my $self = shift;
	$self->{FH} = IO::File->new || croak "IO::File: Can't obtain a filehandler in initialize";
	$self->{FH}->open($self->{PATH}, O_CREAT|O_BINARY|O_RDWR) || 
		croak "Error during open '$self->{PATH}' in initialize, IO-Error: $!";
	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;
	croak "Lost filehandler" unless defined $self->{FH};
	$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 to store in {DATA}
sub _serialize{
	my $self = shift;
	croak "Lost filehandler in serialize" unless defined $self->{FH};
	$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;
	croak "Lost filehandler" unless defined $self->{FH};
	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}}, @_);
	$self->store if $self->{AUTO};
}
# wrapper for _serialize
sub store{
	my $self = shift;
	croak "Lost filehandler" unless defined $self->{FH};
	
	# 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;
	$self->_index;
	return 1;
}

# returns one value for a key in file
sub val{
	my $self = shift;
	my $key  = shift || return undef;
	croak "Lost filehandler" unless defined $self->{FH};
	
	# 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};
		defined $self->{FH} ? $self->{FH}->seek($offs, 0) : croak "Lost filehandler";
		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;
	croak "Lost filehandler" unless defined $self->{FH};
	$self->{DATA} = {};
	$self->{SETN} = {};
	$self->{IDX}  = {};
	$self->_serialize;
}

# usual for development
sub dump{
	my $self = shift;
	croak "Lost filehandler" if not defined $self->{FH};
	binmode STDOUT;
	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);
	}
}

# 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 in method 'addfile'";
	$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;
}

# all keys from {IDX}
sub index{
	my $self = shift;
	return [keys %{$self->{IDX}}];
}

####################### TIEHASH METHODS ###################################
sub TIEHASH{
	my $class = shift;
	my $self = $class->new(@_);
	return $self;
}
sub CLEAR{
	my $self = shift;
	$self->clear;
}
sub STORE{
	my $self = shift;
	$self->set(@_);
}
sub FETCH{
	my $self = shift;
	my $key  = shift;
	return $self->val($key);
}
sub DELETE{
	my $self = shift;
	my $key = shift;
	$self->del($key);
}
sub EXISTS{
	my $self = shift;
	my $key  = shift;
	return exists $self->{IDX}{$key};
}
sub FIRSTKEY{
	my $self = shift;
	my $x = keys %{$self->{IDX}};
	each %{$self->{IDX}};
}
sub NEXTKEY{
	my $self = shift;
	each %{$self->{IDX}};
}

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

=pod

=head1 NAME

DBF.pm - Hashes persistent in einer linearen Datenbank speichern.

=head1 SYNOPSIS

  use DBF;
  my $dbf = DBF->new('/tmp/dbf.bin');            # Datei anbinden
  my $dbf = DBF->new('/tmp/dbf.bin', auto => 1); # Automatisch Speichern beim Beenden
  
  my $dbf = DBF->new('/tmp/dbf.bin', lock => 1); # Setzt exlisives Lock
  
  $dbf->set(%ENV); # Einen ganzen Hash hinzufügen

  $dbf->store;     # Inhalte auf die Festplatte schreiben
 

=head1 DESCRIPTION

Das Modul erlaubt die Speicherung eines Hashes in einer Datei ähnlich DB_File. Das heißt, die Inhalte werden als Schlüssel-Werte-Paar gehalten wobei Werte zum jeweiligen Key mehrere Megabyte haben können. Dieses Speichern großer Inhalte wird insofern vorangetrieben, als dass beim Einlesen der Datei nicht der gesamte Inhalt in der Hauptspeicher gelesen wird sondern nur der Index, der beim Einlesen (Konstruktor) erstellt wird.

Ein erhöhter Speicherbedarf ergibt sich lediglich beim Zurückschreiben der Inhalte in die Datei, hierzu ist es unumgänglich, den kompletten Inhalt in den Hauptspeicher zu lesen. Der Vorteil eines geringen Speicherbedarfs lässt sich jedoch vorzüglich nutzen, wenn Inhalte nur gelesen werden sollen.

=head1 UTF-8 Unterstützung

Getestet mit Perl v5.6.1 ist die UTF-8-Unterstützung gewährleistet: Hinzuzufügende Werte zu einem Schlüssel dürfen entweder als Oktetten vorliegen oder als utf-8-kodierte Zeichenketten (SvUTF8, ScalarValue UTF8). Beim Speichern der Inhalte schaltet das Modul selbstständig auf Byte-Semantics um, so dass die interne Konsistenz der Binary erhalten bleibt.

Nach dem Lesen der Inhalte liegen die Werte jeweils als Oktetten vor, dies ist bei der Weiterverarbeitung zu beachten.

=head1 METHODS

=item C<new>

Der Konstruktor erstellt das Objekt der Klasse. Erstes Argument ist der vollständige Pfad zur Datei, weitere Argumente sind optional als Hash-Werte:

 auto => 1
 Hiermit werden die Werte in der Datei beim Beenden automatisch gespeichert.
 
 lock => 1
 Es wird ein exclusive Lock gesetzt, womit nur ein einzelner Prozess auf die Datei zugreifen darf, das betrifft Lesen UND Schreiben.

Der effektive Benutzer muss Schreib- und Lesezugriff auf die angegebene Datei haben, ansonsten bricht das Modul mit einer Fehlermeldung ab. Sofern die Datei noch nicht vorhanden ist, wird sie angelegt, dazu ist der Vollzugriff auf das Verzeichnis notwendig.

=item C<set>

Setzt den im Argument notierten Hash zunächst in den internen Cache, dieser wird beim Zurückschreiben in die Datei dann gespeichert. Werte zu gleichnamig vorhandenen Schlüsseln werden überschrieben, alle anderen vorhandenen Schlüsse-Werte-Paare bleiben davon unberührt.

=item C<clear>

Löscht alle Schlüssel-Werte-Paare UND schreibt eine leere Datei zurück auf die Festplatte. D.h., mit dieser Methode wird nicht nur temporär gelöscht sondern persistent, es wird automatisch gespeichert.


=item C<store>

Schreibt alle Inhalte zurück in die Datei auf der Festplatte. Dabei wird über den objektinternen Index der Inhalt der Datei neu eingelesen und etwaig neu hinzugekommene Inhalte übernommen. Gleichzeitig wird der interne Index neu eingelesen.

=item C<val>

Gibt zu dem im Argument angegebenen Schlüssel den zugehörigen Wert zurück. Sofern es den Schlüssel nicht gibt, ist die Rückgabe undef.

=item C<del>

Löscht zum im Argument angegebenen Schlüssel das Schlüssel-Werte-Paar aus dem Index und dem internen Cache.

=item C<index>

Gibt die Schlüssel als Array-Referenz auf den Index zurück. Das Array zum Index beinhaltet NUR die Schlüssel zu Hash-Werten, die in der Datei enthalten sind, also bei der Initialisierung aus der Datei gelesen wurden. Vordem mit C<$dbf-E<gt>set(%data);> hinzugefügte Werte sind im Array nicht enthalten.

=item C<dump>

Zeigt Schlüssel-Werte des internen Cache und des internen Index. Gibt nichts zurück sondern macht die Ausgabe direkt auf STDOUT. Diese Methode ist nur zum Entwickeln gedacht.


=item C<addfile>

Speichert eine Datei in DBF und erwartet ein oder zwei Argumente:
 
 $dbf->addfile('c:/windows/system32/drivers/etc/services');
 $dbf->addfile('c:/windows/system32/drivers/etc/services', 'services');

Das erste Argument ist der vollständige Pfad zur Datei, die gelesen und gespeichert werden soll. Das optionale zweite Argument ist der Name des Schlüssels in DBF, ohne Angabe des zweiten Arguments wird als Schlüsselname der Dateiname (erstes Argument) verwendet.

=head1 TIE HASH

Ergänzend zu den bisher beschriebenen Methoden kann mit DBF auch ein Hash gebunden werden:

 tie my %hash, 'DBF', '/tmp/dbf.bin', auto => 1;

Der gebundene Hash C<%hash> lässt sich wie ein normaler Hash benutzen. Das hinter dem Hash versteckte Objekt kann wie gehabt mit C<my $obj = tied %hash;> aus dem gebundenen Hash extrahiert werden, womit alle zur Verfügung stehenden Methoden aufgerufen werden können.

=head1 Fehlerbehandlung

Beim Lesen und Schreiben von Dateien liegen mögliche IO-Fehler in der Perl-Standardvariablen C<$!> vor. Bereits im Konstruktor wird auf IO-Fehler geprüft und das Modul bricht ggf. ab mit einer aussagekräftigen Fehlermeldung. Weiterhin wird bei jedem Zugriff auf das Filehandle geprüft, ob dieses noch vorhanden ist.

=head1 AUTHOR

Rolf Rost, 20.12.2011

=cut