File Coverage

blib/lib/SimpleCDB.pm

Criterion	Covered	Total	%
statement	196	247	79.3
branch	65	118	55.0
condition	14	32	43.7
subroutine	28	34	82.3
pod	0	4	0.0
total	303	435	69.6

package SimpleCDB;
#
########################################################################
#
# Perl-only Constant Database
#  (c) Benjamin D. Low
#
#  See end of file for pod documentation.
#  See HISTORY file for commentary on major developments.
#
########################################################################
#

use strict;

# prefer 5.004, but can do with 5.003
# - all the comments in this file re. 5.003 are with respect to a
#   Solaris 2.5.1 machine. It may well be the issues are the fault
#   of the o/s, not perl - YMMV.
use 5.003;

use Carp;

use Tie::Hash;

use vars qw/@ISA @EXPORT $VERSION $DEBUG/;

use Exporter ();
@ISA    = qw/Exporter Tie::Hash/;
@EXPORT = @Fcntl::EXPORT;

$VERSION = '1.0';

use vars qw/$NFILES $SEP $METAFILE $LOCKRDTIMEOUT $LOCKWRTIMEOUT $ERROR/;
$NFILES = 16;
$SEP = "\x00";		# default separator
$METAFILE = '_info';	# info about the DB, reqd for reading

$LOCKRDTIMEOUT = 5;		# how long to block for read access
$LOCKWRTIMEOUT = 900;	#           "           write   "

$ERROR = undef;	# error message

BEGIN
{
	my @flock = qw/:DEFAULT/;
	if ($] >= 5.004)	# should have a complete Fcntl
	{
		push @flock, ':flock';
	}
	else				# hope for the best...
	{
		sub LOCK_SH () { 1 };
		sub LOCK_EX () { 2 };
		sub LOCK_NB () { 4 };
		sub LOCK_UN () { 8 };
	}

	use Fcntl @flock;
}

# don't let POSIX's EXPORT list (:flock) clash w/ Fcntl
{ package SimpleDB::POSIX; use POSIX; }

BEGIN
# what to do if EWOULDBLOCK isn't defined...
# - unfortunately different systems have different values for
#   EWOULDBLOCK (11 on Solaris/Linux, 246 on HP/UX). Oh well.
{
	no strict 'subs';

	#print "POSIX::EWOULDBLOCK is " . (eval 'POSIX::EWOULDBLOCK'
	#	eq 'POSIX::EWOULDBLOCK' ? 'not ' : '') . "defined\n";

	# if EWOULDBLOCK is defined (as a sub, string, or whatever),
	# the test eval will pick it up, otherwise it'll just return
	# the string
	eval 'package POSIX; sub EWOULDBLOCK() { 11 } '
		if (eval 'POSIX::EWOULDBLOCK' eq 'POSIX::EWOULDBLOCK');
}

use FileHandle;	# IO::File wasn't around for < 5.004

sub debug ($@) { $^W=0; if ($DEBUG and $_[0]<=$DEBUG) { shift; warn @_,"\n" } }

my $digest;		# sub ref to routine to create a hash of a string
my %_digest = 	# randomly sorted mapping of decimal -> hex numbers
qw/
	  0 fc   1 81   2 ab   3 c8   4 82   5 ad   6 f2   7 ff   8 c2   9 bd
	 10 dd  11 84  12 dc  13 a2  14 db  15 c9  16 a1  17 b5  18 d9  19 b4
	 20 d7  21 ae  22 ce  23 92  24 cd  25 99  26 87  27 c1  28 a7  29 a5
	 30 bf  31 8e  32 e6  33 e7  34 ea  35 98  36 f5  37 f9  38 fb  39 df
	 40 cb  41 d2  42 8f  43 d5  44 b2  45 da  46 b9  47 0d  48 0e  49 11
	 50 12  51 14  52 17  53 19  54 1a  55 1b  56 1c  57 1e  58 1f  59 20
	 60 21  61 22  62 23  63 24  64 25  65 26  66 27  67 28  68 2a  69 2b
	 70 2c  71 2d  72 2f  73 30  74 31  75 32  76 33  77 34  78 35  79 37
	 80 39  81 3a  82 3b  83 3d  84 3e  85 40  86 41  87 42  88 43  89 45
	 90 46  91 48  92 4d  93 4f  94 51  95 52  96 55  97 56  98 57  99 58
	100 59 101 5c 102 5d 103 5f 104 60 105 61 106 62 107 64 108 66 109 67
	110 68 111 6b 112 6c 113 6d 114 6e 115 6f 116 70 117 71 118 72 119 73
	120 74 121 76 122 79 123 7b 124 7c 125 7d 126 7e 127 7f 128 80 129 83
	130 85 131 86 132 88 133 89 134 8a 135 8b 136 8c 137 8d 138 90 139 91
	140 93 141 94 142 95 143 96 144 97 145 9a 146 9b 147 9c 148 9d 149 9e
	150 9f 151 a0 152 a3 153 a4 154 a6 155 a8 156 a9 157 aa 158 ac 159 af
	160 b0 161 b1 162 b3 163 b6 164 b7 165 b8 166 ba 167 bb 168 bc 169 be
	170 c0 171 c3 172 c4 173 c5 174 c6 175 c7 176 ca 177 cc 178 cf 179 d0
	180 d1 181 d3 182 d4 183 d6 184 d8 185 de 186 e0 187 e1 188 e2 189 e3
	190 e4 191 e5 192 00 193 01 194 e8 195 e9 196 02 197 eb 198 ec 199 ed
	200 ee 201 ef 202 f0 203 f1 204 04 205 f3 206 f4 207 05 208 f6 209 f7
	210 f8 211 07 212 fa 213 09 214 0a 215 fd 216 fe 217 0c 218 16 219 1d
	220 5e 221 13 222 2e 223 69 224 15 225 0f 226 10 227 08 228 47 229 03
	230 75 231 44 232 78 233 38 234 50 235 6a 236 4c 237 36 238 7a 239 29
	240 5b 241 18 242 4b 243 5a 244 4a 245 49 246 63 247 54 248 0b 249 77
	250 3f 251 65 252 53 253 06 254 3c 255 4e
/;

BEGIN
{
	if (eval 'use Digest::MD5 (); 1')
	{
		#debug 1, "using Digest::MD5";
		$digest = \&Digest::MD5::md5_hex;
	}
	else

# crypt is waaaayyyyy too slow (which is to be expected I suppose, presumably
# it's purposely designed to be an expensive operation :-)
# 	else
# 	{
# 		# resort to crypt - both much slower and less rigorous than Digest::MD5
# 		# - fudge crypt's output to be a hex string, skipping the salt and
# 		#   omitting the tail fractional-byte
# 		#debug 1, "using crypt";
# 		$digest = sub { unpack('@1H10', pack('H*', crypt ($_[0], 'kylan'))) };
# 	}
	{
		$digest = sub
		{
			# yeah, well, this works but no guarantees
			my $d = $_[0] || 'bcc3b7b7b80';
			my $cs = unpack('%16C*', $d) . length($d);
			join '', map {$_digest{(($_ ^ $cs) + 3) % 256}} unpack('C*', $d);
		};
	}
}

sub digest
# returns a hex-encoded digest of a string, of a given length
{
	local $^W = 0;
	# 5.003 doesn't support the $c->() syntax
	substr (&{$digest}($_[0]), 0, $_[1]) || '0';
}

sub newFileHandle ($;$$)
{
	# 5.003's FileHandle doesn't support 'perm' field
	return ($] >= 5.004) ? new FileHandle (@_) : new FileHandle ($_[0], $_[1]);
}

sub _lock
{
	my ($s, $op) = @_;
	my $l;
	eval
	{
		local $SIG{ALRM} = sub { $! = POSIX::EWOULDBLOCK; die "$!\n" };
		alarm(($op & LOCK_EX) ? $s->{wrt} : $s->{rdt});
		$l = flock($s->{lockfh}, $op);
		alarm(0);
	};
	if ($@) { chomp $@; } elsif (!$l) { $@ = "$!" }
	return $l;
}

sub TIEHASH
# args compatible w/ DB_File:
# dir - where to put files
# flags - file open (DB) flags
# perms - file creation permissions
# plus:
# nfiles - number of files to use when creating the DB (rounded to power of 16)
# sep - character to use as the internal field separator
#
# - to avoid problems with system file decriptor limits, files are opened
#   and closed as-needed in the access routines.
{
	$ERROR = undef;

    my ($class, $dir, $flags, $perms, $nfiles, $sep, $rdt, $wrt) = @_;
	$dir    ||= '.';
	$flags  |= O_CREAT if ($flags & O_WRONLY);
	$perms  ||= 0666;	# don't restrict the user's umask
	$nfiles ||= $NFILES;
	$sep    ||= $SEP;

	$rdt    ||= $LOCKRDTIMEOUT;
	$wrt    ||= $LOCKWRTIMEOUT;

	#debug 2, sprintf 'TIEHASH (%s, %s, 0x%x, %s, %d, \x%x)',
	#	$class, $dir, $flags, $perms, $nfiles, ord($sep);

	$ERROR = 'must specify flags', return undef unless defined $flags;
	$ERROR = 'invalid flag: O_APPEND', return undef if ($flags & O_APPEND);

	# check base directory exists, create if necessary
	unless (-d $dir)
		{ mkdir($dir, $perms|0700) or $ERROR="mkdir failed: $!", return undef; }

	my $s = {};	# object data

	$s->{rdt} = $rdt;
	$s->{wrt} = $wrt;

	# acquire lock (held till object is destroyed)
	if ($flags & (O_WRONLY|O_RDWR))
	{
		$s->{lockfh} = newFileHandle ("$dir/$METAFILE",
			O_WRONLY|O_TRUNC|O_CREAT, $perms)
			or $ERROR="could not write [$dir/$METAFILE]: $!", return undef;

		# there may be current readers, wait my turn
		_lock($s, LOCK_EX) or $ERROR = "lock_ex failed: $@", return undef;

		#debug 1, 'LOCK_EX';
		# nfiles, sep written to info file at end of this sub
	}
	else
	{
		# well, how about that - yet another broken part of 5.003
		# - flock won't give you a shared lock (gives errno = "Bad file
		#   number", as if the file mode was wrong (e.g. EX lock on a
		#   readonly file)). Anyhow, using a O_RDWR file partially works -
		#   you get an exclusive lock (even for LOCK_SH).
		# - want to avoid a reader waiting for a database update (which can
		#   take quite a while), so don't block (for long)
		my $m = ($] < 5.004) ? O_RDWR : O_RDONLY;
		$s->{lockfh} = newFileHandle ("$dir/$METAFILE", $m, $perms)
			or $ERROR="could not read [$dir/$METAFILE]: $!", return undef;

		_lock($s, LOCK_SH) or $ERROR = "lock_sh failed: $@", return undef;

		#debug 1, 'LOCK_SH';
		$nfiles = $s->{lockfh}->getline();
		$sep = $s->{lockfh}->getline();
		$ERROR = "invalid info file [$dir/$METAFILE]", return undef
			unless (defined $nfiles and defined $sep);
		chomp $nfiles;
		chomp $sep;
	}

	$s->{perms} = $perms;
	$s->{nfiles} = $nfiles;
	$s->{sep} = $sep;
	$s->{sep_ord} = ord($sep);

	$ERROR = "invalid number of files [$nfiles]", return undef
		unless $nfiles =~ /^[1-9]\d*$/;

	$s->{dir} = $dir;
	# hang on to open flags, for use in _open
	# - exclude TRUNC and friends (files may be opened multiple times)
	$s->{fflags} = $flags & (O_RDONLY | O_WRONLY | O_RDWR | O_CREAT);

	# create the file/s (round nfiles up to a power of 16)
	# - a digest length of 0 is fine (nfiles == 1)
	$s->{dlen} = POSIX::ceil(log($nfiles)/log(16));	# filename/digest len
	$nfiles =  16 ** $s->{dlen};
	#debug 6, "digest length = [$s->{dlen}], nfiles = [$nfiles]";

	$s->{f} = {};		# digest => filename
	$s->{fh} = {};		# digest => filehandle
	$s->{fpos} = {};	# digest => fileposition
	$s->{dlist} = [];	# list of digest values

	my $i;
	for ($i = 0; $i < $nfiles; $i++)
	{
		# 5.003's printf doesn't support '*'
		#my $d = sprintf ('%0*x', $s->{dlen}, $i);
		my $d = substr(('0' x 16) . sprintf ('%x', $i), -($s->{dlen}||1));
		my $f = "$dir/$d";
		#debug 6, "filename [$f]";

		# hang on to the digest values + filenames for _open
		push (@{$s->{dlist}}, $d);
		$s->{f}{$d} = $f;

		truncate($f, 0) if ($flags & O_TRUNC);	# start afresh if required
	}

	if ($flags & (O_WRONLY|O_RDWR))
	{
		$s->{lockfh}->print($nfiles . "\n");
		$s->{lockfh}->print($sep . "\n");
	}

	bless $s, $class;
}

#my $_opens = 0;

sub _open
# open a DB file, transparently staying within the system file descriptor
# limits
{
	my ($self, $d) = @_;
	my $fh;

	my $n = int rand @{$self->{dlist}};
	my $i = 0;
	while ($i < @{$self->{dlist}})
	{
		$fh = $self->{fh}{$d} =
			newFileHandle ($self->{f}{$d}, $self->{fflags}, $self->{perms});
		last if defined ($fh);	# good, opened the file

		last unless $! == POSIX::EMFILE;	# abort on any other condition

		# if we're out of descriptors, close a random file to free one up
		# - would like to just grab the next one off the fh hash, but can't
		#   efficiently use 'each' over the filehandles hash as there's
		#   no simple way to reset the iterator
		#   - use a separate array containing digest values
		# - remember the file position of closed files, to restore later
		my $t = $self->{dlist}[($n + $i) % @{$self->{dlist}}];	# target
		if (defined $self->{fh}{$t})
		{
			#debug 5, "\$! = EMFILE -> closing [$t] (" .
			#	fileno($self->{fh}{$t}) . ")";
			$self->{fpos}{$t} = $self->{fh}{$t}->tell();
			close($self->{fh}{$t});
			$self->{fh}{$t} = undef;
		}
		$i++;
	}

	$ERROR = "could not open [$self->{f}{$d}]: $!", return undef
		unless defined $fh;

	# reposition the file pointer
	$fh->seek(0, ${$self->{fpos}}{$d}) if defined ${$self->{fpos}}{$d};

	#$_opens++;

	#debug 4, "opened [$d] (" . fileno($fh) . ")";

	return $fh;
}

sub _escape ($;$$)
# 'special' characters (newlines and the field separator) need to be escaped
# when they appear within a hash key or value
# - these special values are replaced with their 'base64' encoding
# - further, special note must be made for undef and empty strings, I use the
#   _ and - characters to do this, and escape them if present in the 'user'
#   string
{
	if    (not defined $_[0]) { $_[0] = '-'   }	# undef
	elsif ($_[0] eq '' ) { $_[0] = '_'   }	# empty string
	elsif ($_[0] eq '_') { $_[0] = '%5F' }
	elsif ($_[0] eq '-') { $_[0] = '%2D' }
	else	# non-empty, incl "false" (e.g. '0')
	{
		$_[0] =~ s/%/%25/sg;				# percents
		$_[0] =~ s/\n/%0a/sg;				# newlines
		$_[0] =~ s/\Q$_[1]\E/\%{$_[2]}/sge if $_[1];	# separator
	}
}

sub _unescape ($)
{
	if    ($_[0] eq '_') { $_[0] = ''    }
	elsif ($_[0] eq '-') { $_[0] = undef }
	else  {$_[0] =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg }
}

sub FETCH
{
	$ERROR = undef;

    my ($self, $key) = @_;

	# is this a call via NEXTKEY?
	if (exists $self->{nextval})
	{
		#debug 6, " record cached via NEXTKEY";
		my $v = $self->{nextval};
		delete $self->{nextval};	# make sure stale results don't arise
		return $v;
	}

	croak("FETCH: DB is WRONLY") if ($self->{fflags} & O_WRONLY);

	my $d = digest($key, $self->{dlen});

	# escape newlines and separators
	# - as per STORE - compare apples with apples
	_escape($key, $self->{sep}, $self->{sep_ord});

	#debug 2, "FETCH ($self, $key [$d])";

	my $fh = defined $self->{fh}{$d} ? $self->{fh}{$d} : _open($self, $d);
	return undef unless defined $fh;
	#debug 4, " fileno: " . fileno($fh);

	$fh->seek(0, 0);	# rewind
	my $l = $self->{cache};	# last line read is cached, presuming multiple reads
	#debug 6, " line cached" if defined $l;
	$l = $fh->getline() unless defined $l;
	while (defined $l)
	{
		#debug 9, " at " . $fh->tell();
		last if $l =~ /^\Q$key$self->{sep}\E/;
		$l = $fh->getline();
	}

	if ($l)
	{
		$self->{cache} = $l;

		#debug 3, " found at " . $fh->tell();
		chomp $l;
		my ($k, $v) = split($self->{sep}, $l, 2);
		_unescape($v);
		return $v;
	}
	else
	{
		#debug 3, "\tkey not found";
		return undef;
	}
}

sub EXISTS
{
	$ERROR = undef;

    my ($self, $key) = @_;

	croak("EXISTS: DB is WRONLY") if ($self->{fflags} & O_WRONLY);

	my $d = digest($key, $self->{dlen});

	# escape newlines and separators
	# - as per STORE - compare apples with apples
	_escape($key, $self->{sep}, $self->{sep_ord});

	#debug 2, "EXISTS ($self, $key [$d])";

	my $fh = defined $self->{fh}{$d} ? $self->{fh}{$d} : _open($self, $d);
	return undef unless defined $fh;
	#debug 4, " fileno: " . fileno($fh);

	$fh->seek(0, 0);	# rewind
	my $l;
	while (defined ($l = $fh->getline()))
	{
		last if $l =~ /^\Q$key$self->{sep}\E/;
	}
	$self->{cache} = $l if defined $l;	# cache for FETCH, if found

	#debug 3, $_ ? " found at " . $fh->tell() : " not found";

	# returning undef seems to cause perl to try to FETCH the key
	# - presumably this is some kind of fall-back if the exists operator
	#  "fails"
	return $l ? 1 : 0;
}

sub _nextfile
# find and open the next non-null file
# - i.e. skip files which don't exist (recall that files are opened (created)
#   on-demand)
# - note that a file may be used (contain data), but not open
{
	my ($self) = @_;
	my $fh;

	$self->{'next'} = 0 unless defined $self->{'next'};

	while (not defined $fh and $self->{'next'} < @{$self->{dlist}})
	{
		# lookup next fh hash key
		my $d = $self->{dlist}->[$self->{'next'}];

		# if fh=defined, file is already open (which also implies it exists :-)
		# - otherwise, open the filename, if it exists
		unless (defined ($fh = $self->{fh}{$d}))
		{
			$fh = _open($self, $d) if -e $self->{f}{$d};
		}
		$self->{'next'}++;	# get ready for next time round
	}
	#warn "_next = " . ($self->{'next'} - 1) . "\n" if $fh;
	return $fh;
}

sub FIRSTKEY
{
	my $self = shift;

	croak("FIRSTKEY: DB is WRONLY") if ($self->{fflags} & O_WRONLY);

	#debug 2, "FIRSTKEY ($self)";

	# find the first file
	$self->{'next'} = undef;	# index into $self->{dlist}
	$self->{NEXTKEYfh} = _nextfile($self);

	NEXTKEY($self);
}

sub NEXTKEY
# return the 'next' key in an iteration sequence started via FIRSTKEY
# - perl will call FETCH on this key to extract the value
#   - kind of wasteful, would end up doing multiple reads for the same
#     piece of data, so cache the result (carefully - the value may well
#     be undef)
{
	$ERROR = undef;

	my $self = shift;	# 'lastkey' is unused

	#debug 2, "NEXTKEY ($self) [$self->{'next'}]";

	# read next record, over all files
	my $l;
	my $fh = $self->{NEXTKEYfh};	# initialised by FIRSTKEY

	while (defined $fh and not defined ($l = $fh->getline()))
	{
		$fh = $self->{NEXTKEYfh} = _nextfile($self);
	}
	return undef unless defined $l;

	chomp $l;
	my ($k, $v) = split($self->{sep}, $l, 2);

	# unescape key and value
	# - value is 'cached' to be returned by the next FETCH
	_unescape($k);
	_unescape($v);

	$self->{nextval} = $v;
	# undef keys will cause perl to stop iterating, thinking NEXTKEY
	# has finished... (need an "undef but true" value :-)
	# - this creates a small discrepancy in that you can directly STORE
	#   and FETCH undef and empty keys, but both return empty strings
	return defined $k ? $k : '';
}

sub STORE
{
	$ERROR = undef;

    my ($self, $key, $value) = @_;

	croak("STORE: DB is RDONLY") unless ($self->{fflags} & (O_WRONLY|O_RDWR));

	my $d = digest($key, $self->{dlen});

	# escape newlines and separators
	_escape($key, $self->{sep}, $self->{sep_ord});

	#debug 2, "STORE ($self, $key [$d])";

	my $fh = defined $self->{fh}{$d} ? $self->{fh}{$d} : _open($self, $d);
	return undef unless defined $fh;
	#debug 4, " fileno: " . fileno($fh);

	# only do newlines for value
	_escape($value);

	my $s = join($self->{sep}, $key, $value);

	$fh->seek(0,2);
	$fh->print($s . "\n");
}


sub DESTROY
{
	$ERROR = undef;

	my ($self) = @_;
	#debug 2, join(', ', 'DESTROY', @_);
	#debug 3, "$_opens opens";
	#debug 4, "currently opened files = " .
	#	scalar map {defined $self->{fh}{$_}} keys %{$self->{fh}};

	map {close $self->{fh}{$_} if defined $self->{fh}{$_}} keys %{$self->{fh}};

	#debug 1, 'LOCK_UN';

	flock($self->{lockfh}, LOCK_UN);
	close($self->{lockfh});
}

sub nop
{
	$ERROR = undef;

    my ($self, $method) = @_;

    croak ref($self) . " does not define the method ${method}";
}

sub CLEAR    { my $self = shift; $self->nop("CLEAR") }
sub DELETE   { my $self = shift; $self->nop("DELETE") }

1;	# return true, as require requires

__END__