add start of DB_File -> SQLite changes

diff --git a/perl/SQLHash.pm b/perl/SQLHash.pm
new file mode 100644 (file)
index 0000000..807ea63
--- /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;