perl/SQLHash.pm

   1 #
   2 # General purpose file bashed key/value hash table system
   3 # based on SQLite3 and storing one hash table per database
   4 #
   5 # Copyright (c) 2010 Dirk Koopman G1TLH
   6 #
   7
   8 use strict;
   9
  10 use DXDebug;
  11
  12 my $done_require = 0;
  13 my $avail = 0;
  14
  15 sub avail
  16 {
  17         unless ($done_require) {
  18                 $done_require = 1;
  19
  20                 eval {require DBI;};
  21
  22                 if ($@) {
  23                         dbg("SQLHash: no DBI available '$@'");
  24                         return 0;
  25                 }
  26
  27                 eval {require DBD::SQLite;};
  28                 if ($@) {
  29                         dbg("SQLHash: no DBD::SQLite available '$@'");
  30                         return 0;
  31                 }
  32
  33                 import DBI;
  34                 $avail = 1;
  35         }
  36 }
  37
  38 sub file_exists
  39 {
  40         my $pkg = shift;
  41         my $fn = ref $pkg ? shift : $pkg;
  42         return -e $fn;
  43 }
  44
  45 sub del_file
  46 {
  47         m
  48 }
  49
  50 sub new
  51 {
  52         my $pkg = shift;
  53         my $table = shift;
  54         my $dsnfn = $fn;
  55         if ($dsnfn =~ /\.sqlite$/) {
  56                 $table =~ s/\.sqlite$//;
  57         } else {
  58                 $dsnfn .= ".sqlite";
  59         }
  60         my %flags = @_;
  61         my $blob = delete $flags{blob} ? 'blob' : 'text';
  62         $flags{RaiseError} = 0 unless exists $flags{RaiseError};
  63         my $exists = file_exists($dsnfn);
  64
  65         my $dsn = "dbi:SQLite:dbname=$fn";
  66         my $dbh = DBI->connect($dsn, "", "", \%flags);
  67
  68         unless ($exists) {
  69                 my $r = _sql_do($dbh, qq{create table $table (k text unique key not null, v $blob not null)});
  70                 dbg("SQLHash: created $table with data as $blob") if $r;
  71         }
  72         return bless {dbh => $dbh, table => $table}, $pkg;
  73 }
  74
  75 sub get
  76 {
  77         my $self = shift;
  78         return _sql_get_single($self->{dbh}, qq{select v from $self->{table} where k = ?}, @_);
  79 }
  80
  81 sub put
  82 {
  83         my $self = shift;
  84         _sql_do($self->{dbh}, qq{replace in $self->{table} (k,v) values(?,?)}, @_);
  85         return @r ?  $r[0]->[0] : undef;
  86 }
  87
  88 sub delete
  89 {
  90         my $self = shift;
  91         _sql_do($self->{dbh}, qq{delete from $self->{table} where k = ?}, @_);
  92 }
  93
  94 sub keys
  95 {
  96         my $self = shift;
  97         return _sql_get_simple_array($self->{dbh}, qq{select k from $self->{table}});
  98 }
  99
 100 sub values
 101 {
 102         my $self = shift;
 103         return _sql_get_simple_array($self->{dbh}, qq{select v from $self->{table}});
 104 }
 105
 106 sub begin_work
 107 {
 108         $_[0]->{dbh}->begin_work;
 109 }
 110
 111 sub commit
 112 {
 113         $_[0]->{dbh}->commit;
 114 }
 115
 116 sub rollback
 117 {
 118         $_[0]->{dbh}->rollback;
 119 }
 120
 121 sub _error
 122 {
 123         my $dbh = $shift;
 124     my $s = shift;
 125     dbg("SQL Error: '" . $dbh->errstr . "' on statement '$s', disconnecting");
 126 }
 127
 128 sub _sql_pre_exe
 129 {
 130         my $dbh = $shift;
 131     my $s = shift;
 132     dbg("sql => $s") if isdbg('sql');
 133     my $sth = $dbh->prepare($s);
 134         _error($dbh, $s), $return 0 unless $sth;
 135         my $rv  = $sth->execute(@_);
 136         _error($dbh, $s) unless $rv;
 137         return ($rv, $sth);
 138 }
 139
 140 sub _sql_get_single
 141 {
 142         my $dbh = shift;
 143         my $s = shift;
 144         my $out;
 145         my ($rv, $sth) = _sql_pre_exe($dbh, $s);
 146         return $out unless $rv && $sth;
 147         my $ref = $sth->fetch;
 148         if ($sth->err) {
 149                 dbg("SQL Error: '" . $sth->errstr . "' on statement '$s'") if $sth->err;
 150         } else {
 151                 dbg("sql <= " . join(',', @$ref)) if isdbg('sql');
 152                 $out = $ref->[0];
 153         }
 154         $sth->finish;
 155         return $out;
 156 }
 157
 158 sub _sql_get_simple_array
 159 {
 160         my $dbh = shift;
 161         my $s = shift;
 162         my @out;
 163         my ($rv, $sth) = _sql_pre_exe($dbh, $s);
 164         return @out unless $rv && $sth;
 165         while (my $ref = $sth->fetch) {
 166                 if ($sth->err) {
 167                         dbg("SQL Error: '" . $sth->errstr . "' on statement '$s'") if $sth->err;
 168                         last;
 169                 } else {
 170                         dbg("sql <= " . join(',', @$ref)) if isdbg('sql');
 171                         push @out, $ref->[0];
 172                 }
 173         }
 174         $sth->finish;
 175         return @out;
 176 }
 177
 178 sub _sql_get
 179 {
 180         my $dbh = shift;
 181         my $s = shift;
 182         my @out;
 183         my ($rv, $sth) = _sql_pre_exe($dbh, $s);
 184         return @out unless $rv && $sth;
 185         while (my $ref = $sth->fetch) {
 186                 if ($sth->err) {
 187                         dbg("SQL Error: '" . $sth->errstr . "' on statement '$s'") if $sth->err;
 188                         last;
 189                 } else {
 190                         dbg("sql <= " . join(',', @$ref)) if isdbg('sql');
 191                         push @out, [@$ref];
 192                 }
 193         }
 194         $sth->finish;
 195         return @out;
 196 }
 197
 198 sub _sql_do
 199 {
 200         my $dbh = $shift;
 201     my $s = shift;
 202     dbg("sql => $s") if isdbg('sql');
 203     my $rv = $dbh->do($s, @_);
 204     _error($dbh, $s) unless $rv;
 205 }
 206
 207 1;