From ddf9f909b9211921da14d8dbcc233a1dc5400524 Mon Sep 17 00:00:00 2001 From: Dirk Koopman 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