# By S.W.Ellacott@brighton.ac.uk
# This is version 3: Mon 14th July 1997
# Requires gdbm module version 0.03 or later

package RDBM_File;
$debug = 0;

use RiscosLib;
require Exporter;
@ISA = Exporter;
@EXPORT = qw(O_RDONLY  O_RDWR O_CREAT);

printf "RDBM Loading\n" if $debug;

%lastkey = ();
$buffer = ' 'x255;
$buflen = length($buffer);

system('rmensure gdbm 0.03 rmload system:modules.gdbm');
die("You need gdbm 0.03 or later") if `rmensure gdbm 0.03 echo too old`;

# Get the SWI numbers
$str="Gdbm_Open"; $Gdbm_Open = SWINumberFromString($str);
$str="Gdbm_Store";$Gdbm_Store = SWINumberFromString($str);
$str="Gdbm_Fetch";$Gdbm_Fetch = SWINumberFromString($str);
$str="Gdbm_Exists";$Gdbm_Exists = SWINumberFromString($str);
$str="Gdbm_Delete";$Gdbm_Delete = SWINumberFromString($str);
$str="Gdbm_FirstKey";$Gdbm_FirstKey = SWINumberFromString($str);
$str="Gdbm_NextKey";$Gdbm_NextKey = SWINumberFromString($str);
$str="Gdbm_Clear";$Gdbm_Clear = SWINumberFromString($str);
$str="Gdbm_Close";$Gdbm_Close = SWINumberFromString($str);
$str="Gdbm_OpenIn";$Gdbm_OpenIn = SWINumberFromString($str);

# Define some fcntrl 'constants'
sub O_RDONLY {0}
sub O_RDWR {2}
sub O_CREAT {8}


#Set up some register masks
@in = (0);@out = ();$ocmask = &regmask(\@in,\@out);
@in = (0..4);@out = ();$sfmask = &regmask(\@in,\@out);
@in = (0..2);@out = ();$edmask = &regmask(\@in,\@out);

#Set up a default work directory
$workdir = '<PerlArchLib$Dir>.work.rdbm.'; # Directory used if no pathname for the database

print "RDBM initialisation completed\n" if $debug;

sub TIEHASH  {
	print "In TIEHASH, package is $_[0], database is $_[1], flags is $_[2], mode is $_[3],\n" if $debug;
	my ($pkg,$file,$flags) = @_; # Any mode parameter is ignored
	my $OpenSWI = ( $flags ) ? $Gdbm_Open : $Gdbm_OpenIn; # If $flags is 0, open for read only
	my ($pathname, $handle);
	my @path = split( m@\.@, $file);
	$file = pop(@path);
	if ( @path ) {
		$pathname = join('.', @path ).'.';
	} else {
		$pathname = $workdir;
	}
	$file = $pathname.$file;
        $handle = syscall($OpenSWI,$ocmask,$file) if ( ( -e $file ) || ( $flags&O_CREAT ) );
	print "Handle is $handle\n" if $debug;
	return undef unless $handle;
	my $self = \$handle;
	bless $self;
}

sub STORE    {
	print "In STORE, storing in database ${$_[0]}:\-   $_[1] : $_[2]\n" if $debug;
	my $handle = ${$_[0]};
	my $key = $_[1]; my $keylen = length($key);
	my $value = $_[2];
	$value = "$value"; # Force it to be a string
	my $vallen = length($value);
	syscall($Gdbm_Store,$sfmask,$handle,$key,$keylen,$value,$vallen);
}

sub FETCH    {
	print "In FETCH, finding value for $_[1] in database ${$_[0]}\n " if $debug;
	my $handle = ${$_[0]};
	my $key = $_[1]; my $keylen = length($key);
	my $itemlen = syscall($Gdbm_Fetch,$sfmask,$handle,$key,$keylen,$buffer,$buflen);
	return 0 if ($itemlen == -1);
	if ( $itemlen > $buflen ) {
		warn "Buffer extended" if $debug;
		$buffer = ' ' x $itemlen;
		$buflen = $itemlen;
		$itemlen = syscall($Gdbm_Fetch,$sfmask,$handle,$key,$keylen,$buffer,$buflen);
	}
	substr($buffer, 0, $itemlen);
}

sub EXISTS   {
	print "In EXISTS, finding value for $_[1] in database ${$_[0]}\n " if $debug;
	my $handle = ${$_[0]};
	my $key = $_[1]; my $keylen = length($key);
	syscall($Gdbm_Exists,$edmask,$handle,$key,$keylen);
}

sub DELETE   {
	print "In DELETE, deleting value for $_[1] in database ${$_[0]}\n " if $debug;
	my $handle = ${$_[0]};
	my $key = $_[1]; my $keylen = length($key);
	# DELETE should return deleted value, so we have to fetch it
	my $itemlen = syscall($Gdbm_Fetch,$sfmask,$handle,$key,$keylen,$buffer,$buflen);
	if ( $itemlen > $buflen ) {
		warn "Buffer extended" if $debug;
		$buffer = ' ' x $itemlen;
		$buflen = $itemlen;
		$itemlen = syscall($Gdbm_Fetch,$sfmask,$handle,$key,$keylen,$buffer,$buflen);
	}
	syscall($Gdbm_Delete,$edmask,$handle,$key,$keylen);
	return undef if ($itemlen == -1);
	substr($buffer, 0, $itemlen);
}

sub FIRSTKEY {
	print "In FIRSTKEY, database ${$_[0]}\n " if $debug;
	my $handle = ${$_[0]};
	$itemlen = syscall($Gdbm_FirstKey,$edmask,$handle,$buffer,$buflen);
	return undef if ($itemlen == -1);
	if ( $itemlen > $buflen ) {
		warn "Buffer extended" if $debug;
		$buffer = ' ' x $itemlen;
		$buflen = $itemlen;
		$itemlen = syscall($Gdbm_FirstKey,$edmask,$handle,$buffer,$buflen);
	}
	$lastkey{$handle} = substr($buffer, 0, $itemlen);
}

sub NEXTKEY  {
	print "In NEXTTKEY, database ${$_[0]}\n " if $debug;
	my $handle = ${$_[0]};
	my $key = $lastkey{$handle}; my $keylen = length($key);
	$itemlen = syscall($Gdbm_NextKey,$sfmask,$handle,$key,$keylen,$buffer,$buflen);
	return undef if ($itemlen == -1);
	if ( $itemlen > $buflen ) {
		warn "Buffer extended" if $debug;
		$buffer = ' ' x $itemlen;
		$buflen = $itemlen;
		$itemlen = syscall($Gdbm_NextKey,$sfmask,$handle,$key,$keylen,$buffer,$buflen);
	}
	$lastkey{$handle} = substr($buffer, 0, $itemlen);
}

sub CLEAR    {
	print "In CLEAR, database ${$_[0]}\n " if $debug;
	my $handle = ${$_[0]};
	syscall($Gdbm_Clear,$ocmask,$handle);
}

sub DESTROY	{
	print "DESTROY called for ${$_[0]}\n" if $debug;
	my $handle = ${$_[0]};
	# I don't think we want actually to delete the database, just close it
	syscall($Gdbm_Close,$ocmask,$handle);
}

1;

__END__

