# -*- Perl -*-
#
# interface to database
#
# class methods:
#  - $dbobj = new MyDB $file;
#       Creates an object for MyDB manipulation, via $file
#
# object methods:
#  - $result = $dbobj->lock($flag);
#       locks the db obj. flag can be flock flags: LOCK_SH, LOCK_EX, LOCK_UN,
#       LOCK_NB. Returns true or false.
#  - $href = $dbobj->get($key);
#       gets the corresponding record (returned as a hash reference).
#       returns undef on error.
#  - $result = $dbobj->create($key, \%record);
#       creates $key with contents of %record. key should not exist,
#       otherwise gives an error (returns false)
#  - $result = $dbobj->set($key, \%record);
#       sets a record to a certain value, indifferent if it exists or not.
#       returns true/false to indicate success.
#  - $result = $dbobj->rlock($key, $reason);
#       sets a record lock for $key, to $reason, or if $reason is false,
#       releases the record lock.
#       returns true/false to indicate success. Record lock means it can't
#       be locked by someone else, and someone else can't set it. Anyone can
#       still get the record.
#  - $key = $dbobj->each;
#       returns each key in random order, returns undef on end. must be locked
#       first. Creating new records while iterating is undefined. Please be
#       careful not to lock the DB for too long while doing this.
#       Not recommended, might disappear. Use $dbobj->iterate instead.
#  - @keys = $dbobj->all;
#       returns all keys in the database.
#  - $result = $dbobj->iterate(\&func);
#       iterates over all items, without placing too much of a burden on
#       the database lock. First fetches all keys, then calls
#       &func($key, \%record) for each $key, %record combination.
#       When called without locks set, this doesn't place such a high
#       demand on the overall database, regarding locks. Locks are released
#       once every second to allow other processes to continue.
#       func should return false to abort iteration, true to continue.
#       iterate returns 1 on successfully iterating everything, 0 on
#       error or abort.
#  - $result = $dbobj->fastiterate(\&func);
#       same interface as iterate, but this one doesn't bother to lock at
#       all, and goes through the database quite quickly. Not guaranteed
#       to produce the correct answer.
#  - $result = $dbobj->delete($key);
#       deletes record $key
#  - $err = $dbobj->err;
#       returns most recent error condition
#
# odd method:
#  - $dbobj->MakeBackup;
#       makes a backup of the .db if it's successfully closed
#
# keys starting with \0\0 are reserved. Record key "\001LOCK" is used for
# record locking
# locks are automatic.

package MyDB;

use DB_File;
use Fcntl;
use FileHandle;
use Exporter;
use File::Copy;
use strict;

use vars qw($VERSION);

@MyDB::ISA = qw(Exporter);
@MyDB::EXPORT_OK = qw(LOCK_SH LOCK_EX LOCK_UN LOCK_NB);
%MyDB::EXPORT_TAGS = ( locks => [qw(LOCK_SH LOCK_EX LOCK_UN LOCK_NB)] );
$MyDB::VERSION = 0.95;

my $hdr = "\0\0HEADER";
my $lck = "\001LOCK";

sub LOCK_SH () { 1 }
sub LOCK_EX () { 2 }
sub LOCK_NB () { 4 }
sub LOCK_UN () { 8 }

sub new {
    my($package, $file) = @_;

    # no control whatsoever, just provide a stub with enough data
    bless {'File' => $file, 'Lock' => LOCK_UN}, $package;
}

sub _open {
    my($self, $rdonly) = @_;
    my($dbref, $href, $fh, $omode);

    undef $self->{Err};
    return 1 if exists $self->{Db}; # already open
    $href = {};
    $omode = $rdonly ? O_RDONLY : (O_CREAT|O_RDWR);
    unless ( $dbref = tie(%$href, 'DB_File', $self->{File}, $omode, 0644) ) {
	$self->{Err} = "dbcreate $self->{File}: $!";
	return 0;
    }
    $self->{Db} = $href;
    $self->{Dbref} = $dbref;
    1;
}

sub _close {
    my($self) = @_;

    delete $self->{Err};
    return unless exists $self->{Db};
    # untie the database
    untie %{$self->{Db}};
    # remove last reference to db, this will close files, etc
    delete $self->{Dbref};
    # successful close. copy file to backup if requested
    delete $self->{Db};
}

sub MakeBackup {
    my($self) = @_;

    $self->{Makebackup} = 1;
}

sub DESTROY {
    my($self) = @_;

    # unlock if necessary. this does most of the cleanup
    $self->lock(LOCK_UN) unless $self->{Lock} == LOCK_UN;
    # now clean up some slack.
    delete $self->{LockFh};
}

sub lock {
    my($self, $flags) = @_;

    delete $self->{Err};
    # open/create lockfile if necessary
    if ( !exists $self->{LockFh} ) {
	$self->{LockFh} = new FileHandle ">$self->{File}.lock";
    }
    # if we're going to unlock, we need to close first.
    # if we're going to get a lock, and it's still open for whatever
    # reason, we need to close first as well.
    # if we're trying to get a lock but can't, we definately need to
    # have the database closed already.
    # so we'll always close, since close is a no-op when it isn't opened.
    $self->_close;
    if ( ($flags & ~LOCK_NB) == LOCK_UN ) {
	# in case we have an exclusive lock, and a backup is requested,
	# make one.
	if ( $self->{Lock} == LOCK_EX && $self->{Makebackup} ) {
	    copy $self->{File}, $self->{File} . ".bak";
	    delete $self->{Makebackup};
	}
	# unlock, should always succeed
	flock($self->{LockFh}, $flags) or die("cannot flock LOCK_UN: $!\n");
	$self->{Lock} = LOCK_UN;
	return 1;
    }
    # test for LOCK_SH or LOCK_EX, possibly combined with LOCK_NB
    if ( ($flags & ~LOCK_NB) == LOCK_SH || ($flags & ~LOCK_NB) == LOCK_EX ) {
	# try to lock
	if ( flock($self->{LockFh}, $flags) ) {
	    # lock successful, open database, rdonly if shared lock.
	    return 0 unless ( $self->_open($flags & LOCK_SH) );
	    # remember lock state
	    $self->{Lock} = $flags & ~LOCK_NB;
	    return 1;
	}
	else {
	    $self->{Err} = "flock failed: $!";
	    return 0;
	}
    }
    # any other lock flags and we don't know what to do
    die "Invalid lock flag $flags\n";
}

sub get {
    my($self, $key) = @_;
    my($lockstate, $ret, $tmperr);

    delete $self->{Err};
    if ( $self->{Lock} == LOCK_UN ) {
	$lockstate = $self->{Lock};
	$self->lock(LOCK_SH) or return undef;
    }
    $ret = $self->_get($key, 0);
    $tmperr = $self->{Err};
    $self->lock($lockstate) if defined $lockstate;
    $self->{Err} = $tmperr;
    delete $ret->{$lck} if defined $ret;
    $ret;
}

sub _get {
    my($self, $key, $norlock) = @_;
    my(@header, @values, %retval);
    
    # not in database?
    if ( !defined $self->{Db}{$hdr} || !defined $self->{Db}{$key} ) {
	# not really an error, but provide feedback anyway.
	$self->{Err} = "no such key: $key";
	return {};
    }
    # get header
    @header = split(/\0/, $self->{Db}{$hdr});
    @values = split(/\0/, $self->{Db}{$key});
    # build record
    @retval{@header} = @values;
    # return
    \%retval;
}

sub _set {
    my($self, $key, $recref, $uniq) = @_;
    my($lockstate, $ret, $tmperr);

    delete $self->{Err};
    unless ( ref $recref eq "HASH" ) {
	$self->{Err} = "Not a hash reference: $recref";
	return 0;
    }
    if ( $self->{Lock} != LOCK_EX ) {
	$lockstate = $self->{Lock};
	return 0 unless $self->lock(LOCK_EX);
    }
    $ret = $self->_set2($key, $recref, $uniq);
    $tmperr = $self->{Err};
    $self->lock($lockstate) if defined $lockstate;
    $self->{Err} = $tmperr;
    $ret;
}

sub _set2 {
    my($self, $key, $recref, $uniq) = @_;
    my(@header, @values, $reckey, %record);

    # check uniqueness
    if ( $uniq && defined $self->{Db}{$key} ) {
	$self->{Err} = "key exists: $key";
	return 0;
    }
    # get header, or default header
    @header = split(/\0/, $self->{Db}{$hdr} || $lck);
    # get old values, if existent
    @values = split(/\0/, $self->{Db}{$key} || "");
    # build record
    @record{@header} = @values;
    # check record lock. allow override if $lck is present on input.
    if ( $record{$lck} && 
	$record{$lck} =~ /^(\d+) .*/ && $1 != $$ && !exists $recref->{$lck} ) {
	# record lock is set by other process, and not overridden
	$self->{Err} = "record locked: $2";
	return 0;
    }
    # build new record
    %record = %$recref;
    @values = ();
    # put all header fields in proper order
    foreach $reckey ( @header ) {
	push(@values, $record{$reckey} || "");
	delete $record{$reckey};
    }
    # process any additional record fields +  create new header, if necessary
    if ( %record ) {
	foreach $reckey ( keys %record ) {
	    push(@header, $reckey);
	    push(@values, $record{$reckey} || "");
	}
	$self->{Db}{$hdr} = join("\0", @header);
    }
    # write out contents
    $self->{Db}{$key} = join("\0", @values);
    # success
    1;
}

sub set {
    my($self, $key, $recref) = @_;

    $self->_set($key, $recref, 0);
}

sub create {
    my($self, $key, $recref) = @_;

    $self->_set($key, $recref, 1);
}

sub rlock {
    my($self, $key, $reason) = @_;
    my($lockstate, $ret, $tmperr);

    delete $self->{Err};
    if ( $self->{Lock} != LOCK_EX ) {
	$lockstate = $self->{Lock};
	return 0 unless $self->lock(LOCK_EX);
    }

    $ret = $self->_rlock($key, $reason);
    $tmperr = $self->{Err};
    $self->lock($lockstate) if defined $lockstate;
    $self->{Err} = $tmperr;
    $ret;
}

sub _rlock {
    my($self, $key, $reason) = @_;
    my($recref);

    return 0 unless $recref = $self->_get($key, !$reason);
    # check record lock, but always allow releasing record locks. Allow
    # overwriting your own record locks
    if ( $reason && $recref->{$lck} =~ /^(\d+) (.*)/ && $1 != $$ ) {
	$self->{Err} = "record locked: $2";
	return 0;
    }
    $recref->{$lck} = $reason ? "$$ $reason" : "";
    return 0 unless $self->_set2($key, $recref, 0);
    1;
}

sub each {
    my($self) = @_;
    my($key);

    delete $self->{Err};
    if ( $self->{Lock} == LOCK_UN ) {
	$self->{Err} = "must be locked";
	return ();
    }
    do {
	($key) = each %{$self->{Db}};
    }
    while ( defined $key && $key eq $hdr );
    $key;
}

sub all {
    my($self) = @_;
    my(@ret, $lockstate);
 
    delete $self->{Err};
    if ( $self->{Lock} == LOCK_UN ) {
	$lockstate = $self->{Lock};
	return () unless $self->lock(LOCK_SH);
    }
    @ret = keys %{$self->{Db}};
    $self->lock($lockstate) if defined $lockstate;
    @ret;
}

sub delete {
    my($self, $key) = @_;
    my($tmperr, $ret, $lockstate);
    
    delete $self->{Err};
    if ( $self->{Lock} != LOCK_EX ) {
	$lockstate = $self->{Lock};
	return 0 unless $self->lock(LOCK_EX);
    }
    $ret = $self->_delete($key);
    $tmperr = $self->{Err};
    $self->lock($lockstate) if defined $lockstate;
    $self->{Err} = $tmperr;
    $ret;
}

sub _delete {
    my($self, $key) = @_;
    my(@header, @values, %record);

    # not in database?
    if ( !defined $self->{Db}{$hdr} || !defined $self->{Db}{$key} ) {
	$self->{Err} = "no such key: $key";
	return 0;
    }
    # get header
    @header = split(/\0/, $self->{Db}{$hdr});
    @values = split(/\0/, $self->{Db}{$key});
    @record{@header} = @values;
    # check record lock
    if ( $record{$lck} && 
	$record{$lck} =~ /^(\d+) (.*)/ && $1 != $$ ) {
	# record lock is set by other process
	$self->{Err} = "record locked: $2";
	return 0;
    }

    delete $self->{Db}{$key};
    1;
}

sub iterate {
    my($self, $funcref) = @_;
    my(@keys, $key, $t, $rec);

    if ( $self->{Lock} == LOCK_UN ) {
	$self->lock(LOCK_SH);
	$t = time + 4;
    }
    @keys = keys %{$self->{Db}};
    foreach $key ( @keys ) {
	if ( defined $t && time >= $t ) {
	    # allow other processes
	    return 0 unless $self->lock(LOCK_UN);
	    return 0 unless $self->lock(LOCK_SH);
	    $t = time + 4;
	}
	next if $key eq $hdr;
	return 0 unless $rec = $self->_get($key);
	return 0 unless &$funcref($key, $rec);
    }
    if ( defined $t ) {
	return 0 unless $self->lock(LOCK_UN);
    }
    1;
}

# this is somewhat dirty since it bypasses all locks. Not guaranteed
# to be correct. You cannot go and change the database while doing this.
sub fastiterate {
    my($self, $funcref) = @_;
    my(%sneaky, @header, $key, $val, @values, %record);

    unless ( tie(%sneaky, 'DB_File', $self->{File}, O_RDONLY) ) {
	$self->{Err} = "cannot tie $self->{File}: $!";
	return 0;
    }
    return 1 if !defined $sneaky{$hdr}; # no elements at all
    @header = split(/\0/, $sneaky{$hdr});
    while ( ($key, $val) = each %sneaky ) {
	next if $key eq $hdr;
	@values = split(/\0/, $val);
	@record{@header} = @values;
	return 0 unless &$funcref($key, \%record);
    }
    untie(%sneaky);
}
    
sub err {
    my($self) = @_;

    $self->{Err};
}

1;