#!/usr/bin/perl

# This script is copyright (c) 2019 by WebMO, LLC, all rights reserved.
# Its use is subject to the license agreement that can be found at the following
# URL:  http://www.webmo.net/license

package SimpleDB;

my $LOCK_SH = 1;
my $LOCK_EX = 2;
my $LOCK_NB = 4;
my $LOCK_UN = 8;

my $SEEK_SET = 0;
my $SEEK_CUR = 1;
my $SEEK_END = 2;

###############################
# Constructor / Destructor
###############################

sub new
{
	my $class = shift;
	my $objref = {
		filename	=> $_[0],
		index_filename => $_[1],
		fields		=> $_[2],
		rec_format	=> $_[3],
		index_field	=> $_[4],
		debug		=> $_[5] ? 1 : 0,
		rec_length	=> undef,
		index_rec_format => undef,
		index_rec_length => undef,
		fh		=> undef,
		is_read_locking_disabled	=> 0
	};
	bless $objref, $class;
	$objref->_init();
	return $objref;
}

sub DESTROY
{
	my ($self) = shift;
	close($self->{fh});
}

sub _init
{
	my ($self) = shift;

	my $index_field_format;	
	my @formats = split(/ /, $self->{rec_format});
	foreach my $field (@{$self->{fields}}) { $index_field_format = shift @formats; last if $field eq $self->{index_field}; }
	
	$self->{index_rec_format} = "$index_field_format L";
	$self->{rec_length} = length(pack($self->{rec_format}));
	$self->{index_rec_length} = length(pack($self->{index_rec_format}));
	$self->{fh} = do {local *FH};
	# open the database, creating if necessary
	if (-e $self->{filename})
	{
		open($self->{fh}, "+<$self->{filename}") || die "Cannot open database file";
		binmode($self->{fh});
	}
	else
	{
		open($self->{fh}, "+>$self->{filename}") || die "Cannot open database file";
		binmode($self->{fh});
	}
	# validate the database for at least some semblance of sanity
	if ((-s $self->{filename}) % $self->{rec_length} > 0)
	{
		if (!$self->{debug}) {
			die "Database corruption detected in $self->{filename}; cowardly refusing to proceed";
		}
		else {
			warn "Database corruption detected in $self->{filename}";
		}
	}
	# turn on auto flush for the database
	select((select($self->{fh}), $| = 1)[0]);
	$self->_create_index() if (!(-e "$self->{index_filename}"));
	$self->_read_index();
}

###############################
# Indexing functions
###############################

sub _create_index
{
	my ($self) = shift;
	
	my %db_index;
	$self->_read_lock();
	$self->_seek(0, $SEEK_SET);
	my $record_count = $self->_get_record_count();
	for (my $record = 1; $record <= $record_count; $record++)
	{
		my @buf = unpack($self->{rec_format}, $self->_read($self->{rec_length}));
		foreach my $field (@{$self->{fields}}) { $data_ref->{$field} = shift @buf; }
		$db_index{$data_ref->{$self->{index_field}}} = $record;
	}
	$self->_clear_lock();
	
	my $fh = do {local *FH};
	open($fh, "+>>$self->{index_filename}") || die "Cannot open database index file";
	binmode($fh);
	flock($fh, $LOCK_EX);
	truncate($fh, 0);
	
	foreach my $key (sort keys %db_index)
	{
		my $record = $db_index{$key};
		print $fh pack($self->{index_rec_format}, $key, $record);
	}
	
	close($fh);
}

sub _read_index
{
	my ($self) = shift;
	
	my $fh = do {local *FH};
	open($fh, "<$self->{index_filename}") || die "Cannot open database index file";
	binmode($fh);
	flock($fh, $LOCK_SH);
	
	my $buf;
	%{$self->{db_index}} = ();
	while(read($fh, $buf, $self->{index_rec_length}) != 0)
	{
		my ($key, $value) = unpack($self->{index_rec_format}, $buf);
		$self->{db_index}->{$key} = $value;
	}
	$self->{db_index_cachesize} = -s "$self->{index_filename}";
	
	close($fh);
}

#################################
# Public methods
#################################

sub fetch_record
{
	my ($self, $record, $data_ref) = @_;
	$self->_read_lock() unless($self->{is_read_locking_disabled});
	$self->_seek($self->{rec_length} * ($record - 1), $SEEK_SET) || return 0; 
	my $buf = $self->_read($self->{rec_length}) || return 0;
	$self->_clear_lock() unless($self->{is_read_locking_disabled});
	my @buf = unpack($self->{rec_format}, $buf);
	foreach my $field (@{$self->{fields}}) { $data_ref->{$field} = shift @buf; }
	return 1;
}

sub update_record
{
	my ($self, $record, $data_ref) = @_;
	my @buf;
	foreach my $field (@{$self->{fields}}) { push(@buf, $data_ref->{$field}); }
	$self->_write_lock();
	$self->_seek($self->{rec_length} * ($record - 1), $SEEK_SET) || return 0;
	$self->_write(pack($self->{rec_format}, @buf)) || return 0;
	$self->_clear_lock();
	return 1;
}

sub create_record
{
	my ($self, $data_ref) = @_;
	$self->_write_lock();
	my $record_count = $self->_get_record_count();
	my $index_field = $self->{index_field};
#	automatically assign a key if unassigned
	if ($data_ref->{$index_field} eq "" && $record_count == 0) { $data_ref->{$index_field} = 1; }
	if ($data_ref->{$index_field} eq "")
	{
		$self->_read_index();
		my $last_key = _max(keys %{$self->{db_index}});
		$data_ref->{$index_field} = $last_key + 1;
	}
#	make sure a record with this key does not already exist
	my $key = $data_ref->{$index_field};
	my $key_exists = $self->find_record_by_key($key) == -1 ? 0 : 1;
	die "Attempt to create a record that already exists" if ($key_exists);
#	add the record
	my @buf;
	foreach my $field (@{$self->{fields}}) { push(@buf, $data_ref->{$field}); }
	$self->_seek(0, $SEEK_END) || return 0;
	$self->_write(pack($self->{rec_format}, @buf)) || return 0;
	$record_count++;
#	update the index
	$self->{db_index}->{$key} = $record_count;
	my $fh = do {local *FH};
	open($fh, "+>>$self->{index_filename}") || die "Cannot open database index file";
	binmode($fh);
	flock($fh, $LOCK_EX);
	print $fh pack($self->{index_rec_format}, $key, $record_count);
	close($fh);
#	now clear the lock, to prevent a race condition between the updating of the index
#	and the creation of the record
	$self->_clear_lock();
}

sub purge_records
{
	my ($self, @records) = @_;
	@records = sort { $a <=> $b} @records;

	$self->_write_lock();
	my $record_count = $self->_get_record_count();
	my $read_pos;
	my $write_pos;
	my $records_found = 0;
	for (my ($read_pos, $write_pos) = (1, 1); $read_pos <= $record_count; $read_pos++, $write_pos++)
	{
		while ($records[$records_found] == $read_pos)
		{
			$read_pos++;
			$records_found++;
		}
		if ($read_pos != $write_pos)
		{
			$self->_seek(($read_pos - 1) * $self->{rec_length}, $SEEK_SET);
			my $buf = $self->_read($self->{rec_length});
			$self->_seek(($write_pos - 1) * $self->{rec_length}, $SEEK_SET);
			$self->_write($buf);
		}
	}
	$self->_truncate(($record_count - $records_found)*$self->{rec_length});
	$self->_clear_lock();
	$self->_create_index();
	$self->_read_index();
}

sub find_record_by_key
{
	my ($self, $key) = @_;
	# check for outdated index cache
	$self->_read_index() if (-s "$self->{index_filename}" != $self->{db_index_cachesize});
	my $record = $self->{db_index}->{$key};
	return $record eq "" ? -1 : $record;
}

sub get_record_count
{
	my ($self) = shift;
	$self->_read_lock();
	my $record_count = $self->_get_record_count();
	$self->_clear_lock();
	return $record_count;
}

sub get_keys
{
	my ($self) = shift;
	return keys %{$self->{db_index}}
}

#can be used to temporarily disable read locking on fetch_record for
#cases where rapid locking/unlocking is expensive (e.g. NFSv4)
sub set_read_locking_disabled
{
	my ($self, $disabled) = @_;
	$self->{is_read_locking_disabled} = $disabled;
}

#######################################
# Wrapper functions for IO routines
#######################################

sub _read
{
	my ($self, $length) = @_;
	my $buf;
	read($self->{fh}, $buf, $length);
	return $buf;
}

sub _write
{
	my ($self, $buf) = @_;
	my $fh = $self->{fh};
	print $fh $buf;
}

sub _truncate
{
	my ($self, $length) = @_;
	truncate $self->{fh}, $length;
}

sub _seek
{
	my ($self, $position, $whence) = @_;
	return seek($self->{fh}, $position, $whence);
}

sub _eof
{
	my ($self) = @_;
	return eof($self->{fh});
}

sub _read_lock
{
	my ($self) = @_;
	flock($self->{fh}, $LOCK_SH);
}

sub _write_lock{
	my ($self) = @_;
	flock($self->{fh}, $LOCK_EX);
}

sub _clear_lock
{
	my ($self) = @_;
	flock($self->{fh}, $LOCK_UN);
}

#######################################
# Misc. funtions
#######################################

sub _get_record_count
{
	my ($self) = shift;
	my $record_count = (-s $self->{filename}) / $self->{rec_length};
	return $record_count;
}

sub _max
{
    my($max) = shift(@_);
    foreach $temp (@_)
    {
        $max = $temp if $temp > $max;
    }
    return($max);
}