]> gb7djk.dxcluster.net Git - spider.git/blob - perl/SQLHash.pm
add a 'not found' message if sh/dx shows nothing
[spider.git] / 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         
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;