From ddf9f909b9211921da14d8dbcc233a1dc5400524 Mon Sep 17 00:00:00 2001
From: Dirk Koopman <djk@tobit.co.uk>
Date: Sat, 15 May 2010 00:15:25 +0100
Subject: [PATCH] add start of DB_File -> SQLite changes

---
 perl/SQLHash.pm | 207 ++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 207 insertions(+)
 create mode 100644 perl/SQLHash.pm

diff --git a/perl/SQLHash.pm b/perl/SQLHash.pm
new file mode 100644
index 00000000..807ea635
--- /dev/null
+++ b/perl/SQLHash.pm
@@ -0,0 +1,207 @@
+#
+# General purpose file bashed key/value hash table system
+# based on SQLite3 and storing one hash table per database
+#
+# Copyright (c) 2010 Dirk Koopman G1TLH
+#
+
+use strict;
+
+use DXDebug;
+
+my $done_require = 0;
+my $avail = 0;
+
+sub avail
+{
+	unless ($done_require) {
+		$done_require = 1;
+
+		eval {require DBI;};
+
+		if ($@) {
+			dbg("SQLHash: no DBI available '$@'");
+			return 0;
+		}
+
+		eval {require DBD::SQLite;};
+		if ($@) {
+			dbg("SQLHash: no DBD::SQLite available '$@'");
+			return 0;
+		}
+
+		import DBI;
+		$avail = 1;
+	}
+}
+
+sub file_exists
+{
+	my $pkg = shift;
+	my $fn = ref $pkg ? shift : $pkg;
+	return -e $fn;
+}
+
+sub del_file
+{
+	m
+}
+
+sub new
+{
+	my $pkg = shift;
+	my $table = shift;
+	my $dsnfn = $fn;
+	if ($dsnfn =~ /\.sqlite$/) {
+		$table =~ s/\.sqlite$//;
+	} else {
+		$dsnfn .= ".sqlite";
+	}
+	my %flags = @_;
+	my $blob = delete $flags{blob} ? 'blob' : 'text';
+	$flags{RaiseError} = 0 unless exists $flags{RaiseError};
+	my $exists = file_exists($dsnfn);
+
+	my $dsn = "dbi:SQLite:dbname=$fn";
+	my $dbh = DBI->connect($dsn, "", "", \%flags);
+
+	unless ($exists) {
+		my $r = _sql_do($dbh, qq{create table $table (k text unique key not null, v $blob not null)});
+		dbg("SQLHash: created $table with data as $blob") if $r;
+	}
+	return bless {dbh => $dbh, table => $table}, $pkg;
+}
+
+sub get
+{
+	my $self = shift;
+	return _sql_get_single($self->{dbh}, qq{select v from $self->{table} where k = ?}, @_);
+}
+
+sub put
+{
+	my $self = shift;
+	_sql_do($self->{dbh}, qq{replace in $self->{table} (k,v) values(?,?)}, @_);
+	return @r ?  $r[0]->[0] : undef;
+}
+
+sub delete
+{
+	my $self = shift;
+	_sql_do($self->{dbh}, qq{delete from $self->{table} where k = ?}, @_);
+}
+
+sub keys
+{
+	my $self = shift;
+	return _sql_get_simple_array($self->{dbh}, qq{select k from $self->{table}});
+}
+
+sub values
+{
+	my $self = shift;
+	return _sql_get_simple_array($self->{dbh}, qq{select v from $self->{table}});
+}
+
+sub begin_work
+{
+	$_[0]->{dbh}->begin_work;
+}
+
+sub commit
+{
+	$_[0]->{dbh}->commit;
+}
+
+sub rollback
+{
+	$_[0]->{dbh}->rollback;
+}
+
+sub _error
+{
+	my $dbh = $shift;
+    my $s = shift;
+    dbg("SQL Error: '" . $dbh->errstr . "' on statement '$s', disconnecting");
+}
+
+sub _sql_pre_exe
+{
+	my $dbh = $shift;
+    my $s = shift;
+    dbg("sql => $s") if isdbg('sql');
+    my $sth = $dbh->prepare($s);
+	_error($dbh, $s), $return 0 unless $sth;
+	my $rv  = $sth->execute(@_);
+	_error($dbh, $s) unless $rv;
+	return ($rv, $sth);
+}
+
+sub _sql_get_single
+{
+	my $dbh = shift;
+	my $s = shift;
+	my $out;
+	my ($rv, $sth) = _sql_pre_exe($dbh, $s);
+	return $out unless $rv && $sth;
+	my $ref = $sth->fetch;
+	if ($sth->err) {
+		dbg("SQL Error: '" . $sth->errstr . "' on statement '$s'") if $sth->err;
+	} else {
+		dbg("sql <= " . join(',', @$ref)) if isdbg('sql');
+		$out = $ref->[0];
+	}
+	$sth->finish;
+	return $out;
+}
+
+sub _sql_get_simple_array
+{
+	my $dbh = shift;
+	my $s = shift;
+	my @out;
+	my ($rv, $sth) = _sql_pre_exe($dbh, $s);
+	return @out unless $rv && $sth;
+	while (my $ref = $sth->fetch) {
+		if ($sth->err) {
+			dbg("SQL Error: '" . $sth->errstr . "' on statement '$s'") if $sth->err;
+			last;
+		} else {
+			dbg("sql <= " . join(',', @$ref)) if isdbg('sql');
+			push @out, $ref->[0];
+		}
+	}
+	$sth->finish;
+	return @out;
+}
+
+sub _sql_get
+{
+	my $dbh = shift;
+	my $s = shift;
+	my @out;
+	my ($rv, $sth) = _sql_pre_exe($dbh, $s);
+	return @out unless $rv && $sth;
+	while (my $ref = $sth->fetch) {
+		if ($sth->err) {
+			dbg("SQL Error: '" . $sth->errstr . "' on statement '$s'") if $sth->err;
+			last;
+		} else {
+			dbg("sql <= " . join(',', @$ref)) if isdbg('sql');
+			push @out, [@$ref];
+		}
+	}
+	$sth->finish;
+	return @out;
+}
+
+sub _sql_do
+{
+	my $dbh = $shift;
+    my $s = shift;
+    dbg("sql => $s") if isdbg('sql');
+    my $rv = $dbh->do($s, @_);
+    _error($dbh, $s) unless $rv;
+}
+
+1;
-- 
2.43.0