package DBF;

# Lineare Datenbank ähnlich DB_File
# Persistentes Speichern von key => value (hash)
# value darf sehr große Werte annehmen (ganze Dateien)
# Einfache Anwendung als Tie-Klasse
# Subklassen
# DBF::Manager => Speichern, Lesen und Schreiben, Binärdatei anlegen
# DBF::Fetch   => Binärdatei nur Lesen

# Rolf Rost, 18.12.2011
###########################################################################
use strict;
use warnings;
use IO::File;

# Baisklasse Konstruktor
sub new{
	my $class = shift;
	# hier wird lediglich der Dateihandler erstellt und als Attribut in das Objekt geschrieben
	my $self = bless{
		FH => IO::File->new,
	}, $class;
	return $self;
}

1;######################################################################### END DBF (Baseclass)

# Manager Klasse, Read/Write
package DBF::Manager;

use strict;
use warnings;
use IO::File;
use Fcntl qw(:flock :DEFAULT);
use bytes;
use Carp;
@DBF::Manager::ISA = qw(DBF);

# Konstruktor: Objekt der Superklasse erstellen, Datei öffnen und auf {HASH} lesen
sub TIEHASH{
	my $class = shift;
	my $file  = shift || croak("Keine Datei angegeben in tie()");
	my %cfg = (
		auto => 0,
		lock => 0,
		@_
	);
	my $self = $class->new;
	$self->{AUTO} = $cfg{auto};
	$self->{LOCK} = $cfg{lock};
	$self->{HASH} = {};
	eval{
		$self->{FH}->open($file, O_CREAT|O_RDWR|O_BINARY) || die $!;
		if($cfg{lock}){
			$self->{LOCK} = flock($self->{FH}, LOCK_EX) || carp("Your system does not support flock()");
		}
		$self->_deserialize;
	};
	return $@ ? undef : $self;
}
###################### PRIVATE METHODS ####################################
# Lese den Hash aus der Datei
sub _deserialize{
	my $self = shift;
	$self->{FH}->seek(0,0) or die "Dateihandler verloren";
	my $buffer = '';
	my $key    = '';
	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
		$self->{HASH}{$key} = $buffer;
	}
}
############### PUBLIC METHODS ############################################
# Schreibe den Hash in die Datei
sub write{
	my $self = shift;
	warn "Lost FH" unless defined $self->{FH};
	$self->{FH}->truncate(0);
	$self->{FH}->seek(0,0);
	while( my($k,$v) = each %{$self->{HASH}}){
		$self->{FH}->print(pack('N', length($k)).$k.pack('N', length($v)).$v);
	}
	return $@ ? undef : 1;
}
# Lese eine Datei auf einen Hashkey
sub addfile{
	my $self = shift;
	my $path = shift;
	my $name = shift || $path;
	my $fh = IO::File->new;
	eval{
		$fh->open($path, O_RDONLY|O_BINARY) or die $!;
		my $content = '';
		read $fh, $content, -s $fh;
		$self->{HASH}{$name} = $content;
		$fh->close;
	};
	return $@ ? undef : 1;
}

############## OVERLOAD TIE METHODS #######################################
sub CLEAR{
	my $self = shift;
	$self->{HASH} = {};
}
sub STORE{
	my $self = shift;
	my $key  = shift || croak "Missing key in STORE";
	my $val  = shift || croak "Missung value for STORE";
	$self->{HASH}{$key} = $val;
}
sub FETCH{
	my $self = shift;
	my $key  = shift || croak "Missing key in FETCH";
	return defined $self->{HASH}{$key} ? $self->{HASH}{$key} : undef;
}
sub FIRSTKEY{
	my $self = shift;
	my $i = keys %{$self->{HASH}};
	each %{$self->{HASH}}
}
sub NEXTKEY{
	my $self = shift;
	return each %{ $self->{HASH} }
}
sub DESTROY{
	my $self = shift;
	$self->write if $self->{AUTO};
}
sub UNTIE{
	my $self = shift;
	$self->write;
	carp $@ if $@;
}
sub DELETE{
	my $self = shift;
	my $key  = shift || croak "Kein Key angegeben zum Loeschen";
	delete $self->{HASH}{$key};
}
sub EXISTS{
	my $self = shift;
	my $key  = shift || croak "Kein Key angegeben zur Abfrage";
	return exists $self->{HASH}{$key};
}
1;######################################################################### End DBF::Manager

package DBF::Fetch;

use strict;
use warnings;
use bytes;
use Fcntl qw(:DEFAULT);
use Carp;
@DBF::Fetch::ISA = qw(DBF);

sub TIEHASH{
	my $class = shift;
	my $file  = shift || croak "Keine Datei angegeben in tie()";
	my $self = $class->new;
	$self->{IDX} = {};
	eval{
		$self->{FH}->open($file, O_RDONLY|O_BINARY) || die $!;
		$self->_index;
	};
	return $@ ? undef : $self;
}
####################### PRIVATE METHODS ###################################
sub _index{
	my $self = shift;
	$self->{FH}->seek(0,0) || die "Dateihandler verloren";
	my $buffer = '';
	my $key    = '';
	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;
	}
}
###################### OVERLOAD TIEHASH METHODS ###########################
sub FETCH{
	my $self = shift;
	my $key  = shift || croak "Kein Key angegeben in FETCH";
	return unless defined $self->{IDX}{$key};
	my($offs, $len) = unpack 'NN', $self->{IDX}{$key} or return undef;
	$self->{FH}->seek($offs, 0) || carp "Dateihandler verloren";
	my $val = '';
	read $self->{FH}, $val, $len;
	return $val;
}
sub EXISTS{
	my $self = shift;
	my $key  = shift || croak "Kein Key angegeben in FETCH";
	return exists $self->{IDX}{$key};
}
sub FIRSTKEY{
	my $self = shift;
	my $i = keys %{$self->{IDX}};
	each %{$self->{IDX}}
}
sub NEXTKEY{
	my $self = shift;
	return each %{ $self->{IDX} }
}

sub CLEAR{ carp "Nicht verfuegbar, nur Lesemodus" }
sub STORE{ carp "Nicht verfuegbar, nur Lesemodus" }
sub DELETE{ carp "Nicht verfuegbar, nur Lesemodus" }
1;######################################################################### End DBF::Fetch


package main;

use strict;
use warnings;
use Data::Dumper;
use File::Find;

tie my %h, 'DBF::Manager', '/tmp/dbf.bin', auto => 1 or die $@;
my $ho = tied %h;


find(\&cb, '/home/dev');
sub cb{
	return unless defined $File::Find::name;
	return if -d $File::Find::name;
	return unless -f $File::Find::name;
	$ho->addfile($File::Find::name) or die $@;
}