2 # dbm.pl: Extension on the factoid database.
3 # OrigAuthor: Kevin Lenzo (c) 1997
4 # CurrAuthor: dms <dms@users.sourceforge.net>
5 # Version: v0.6 (20000707)
14 use vars qw(%factoids %param);
17 # FIXME we don't handle multiply indexes tables
18 # perhaps we should combine the keys with a ':' or something?
19 # the spaces below separate the keys from the rest
21 # Tim Riker thinks that freshmeat below should be a single index
81 foreach my $table (keys %formats) {
82 next unless (&IsParam($table));
84 my $file = "$param{'DBName'}-$table";
86 if (dbmopen(%{"$table"}, $file, 0666)) {
87 &status("Opened DBM $table ($file).");
89 &ERROR("Failed open to DBM $table ($file).");
97 foreach my $table (keys %formats) {
98 next unless (&IsParam($table));
100 if (dbmclose(%{ $table })) {
101 &status("Closed DBM $table successfully.");
104 &ERROR("Failed closing DBM $table.");
109 # Usage: &dbGetColInfo($table);
113 if (scalar @{$formats{$table}}) {
114 return @{$formats{$table}};
116 &ERROR("dbGCI: no format for table ($table).");
123 # Usage: &dbQuote($str);
129 # Usage: &dbGet($table, $select, $where);
131 my ($table, $select, $where) = @_;
132 my ($key, $val) = split('=',$where) if $where =~ /=/;
136 &DEBUG("dbGet($table, $select, $where);");
139 my @format = &dbGetColInfo($table);
140 if (!scalar @format) {
144 if (!defined ${ "$table" }{lc $val}) { # dbm hash exception.
145 &DEBUG("dbGet: '$val' does not exist in $table.");
149 # return the whole row.
150 if ($select eq "*") {
151 @retval = split $;, ${"$table"}{lc $val};
152 unshift(@retval,$key);
156 # FIXME this should be in $select order
157 # and it's now in field order
158 &DEBUG("dbGet: select=>'$select'.");
159 my @array = split "$;", ${"$table"}{lc $val};
160 unshift(@array,$val);
161 for (0 .. $#format) {
162 my $str = $format[$_];
163 next unless (grep /^$str$/, split(/\,/, $select));
165 &DEBUG("dG: '$format[$_]'=>'$array[$_]'.");
166 push(@retval, $array[$_]);
169 if (scalar @retval > 1) {
171 } elsif (scalar @retval == 1) {
179 # Usage: &dbGetCol();
180 # Usage: &dbGetCol($table, $select, $where, [$type]);
182 my ($table, $select, $where, $type) = @_;
183 &FIXME("STUB: &dbGetCol($table, $select, $where, $type);");
187 # Usage: &dbGetColNiceHash($table, $select, $where);
188 sub dbGetColNiceHash {
189 my ($table, $select, $where) = @_;
190 &DEBUG("dbGetColNiceHash($table, $select, $where);");
191 my ($key, $val) = split('=',$where) if $where =~ /=/;
192 return unless ${$table}{lc $val};
194 $hash{lc $key} = $val;
195 my (@format) = &dbGetColInfo($table);
197 @hash{@format} = split $;, ${$table}{lc $val};
202 # Usage: &dbInsert($table, $primkey, %hash);
203 # Note: dbInsert should do dbQuote.
205 my ($table, $primkey, %hash) = @_;
207 &DEBUG("dbInsert($table, $primkey, ...)");
209 my $info = ${$table}{lc $primkey} || ''; # primkey or primval?
211 my @format = &dbGetColInfo($table);
212 if (!scalar @format) {
217 my @array = split $;, $info;
218 delete $hash{$format[0]};
219 for $i (1 .. $#format) {
220 my $col = $format[$i];
221 $array[$i - 1]=$hash{$col};
222 $array[$i - 1]='' unless $array[$i - 1];
224 &DEBUG("dbI: '$col'=>'$array[$i - 1]'");
227 if (scalar keys %hash) {
228 &ERROR("dbI: not added...");
229 foreach (keys %hash) {
230 &ERROR("dbI: '$_'=>'$hash{$_}'");
235 ${$table}{lc $primkey} = join $;, @array;
241 &FIXME("STUB: &dbUpdate(@_);=>somehow use dbInsert!");
245 # Usage: &dbSetRow($table, @values);
247 &FIXME("STUB: &dbSetRow(@_)");
251 # Usage: &dbDel($table, $primhash_ref);
252 # Note: dbDel does dbQuote
254 my ($table, $phref) = @_;
255 # FIXME does not really handle more than one key!
256 my $primval = join(':', values %{$phref});
258 if (!defined ${$table}{lc $primval}) {
259 &DEBUG("dbDel: lc $primval does not exist in $table.");
261 delete ${$table}{lc $primval};
268 # Usage: &dbReplace($table, $key, %hash);
269 # Note: dbReplace does optional dbQuote.
271 my ($table, $key, %hash) = @_;
272 &DEBUG("dbReplace($table, $key, %hash);");
274 &dbDel($table, {$key=>$hash{$key}});
275 &dbInsert($table, $hash{$key}, %hash);
280 # Usage: &dbSet($table, $primhash_ref, $hash_ref);
282 my ($table, $phref, $href) = @_;
284 my ($key) = keys %{$phref};
285 my $where = $key . "=" . $phref->{$key};
287 my %hash = &dbGetColNiceHash($table, "*", $where);
288 $hash{$key}=$phref->{$key};
289 foreach (keys %{$href}) {
290 &DEBUG("dbSet: setting $_=${$href}{$_}");
291 $hash{$_} = ${$href}{$_};
293 &dbReplace($table, $key, %hash);
298 &FIXME("STUB: &dbRaw(@_);");
302 &FIXME("STUB: &dbRawReturn(@_);");
307 ####################################################################
308 ##### Factoid related stuff...
312 return scalar keys %{$_[0]};
316 &FIXME("STUB: &getKeys(@_); -- REDUNDANT");
320 &DEBUG("STUB: &randKey(@_);");
321 my ($table, $select) = @_;
322 my @format = &dbGetColInfo($table);
323 if (!scalar @format) {
327 my $rand = int(rand(&countKeys($table) - 1));
328 my @keys = keys %{$table};
329 &dbGet($table, '$select', "$format[0]=$keys[$rand]");
333 # Usage: &deleteTable($table);
336 &FIXME("STUB: deleteTable($table)");
339 ##### $select is misleading???
340 # Usage: &searchTable($table, $returnkey, $primkey, $str);
342 my ($table, $primkey, $key, $str) = @_;
343 &FIXME("STUB: searchTable($table, $primkey, $key, $str)");
345 &DEBUG("searchTable($table, $primkey, $key, $str)");
347 if (!scalar &dbGetColInfo($table)) {
352 foreach (keys %{$table}) {
353 my $val = &dbGet($table, "NULL", $_, $key) || '';
354 next unless ($val =~ /\Q$str\E/);
358 &DEBUG("sT: ".scalar(@results) );
364 # Usage: &getFactInfo($faqtoid, $type);
366 my ($faqtoid, $type) = @_;
368 my @format = &dbGetColInfo("factoids");
369 if (!scalar @format) {
373 if (!defined $factoids{$faqtoid}) { # dbm hash exception.
377 if ($type eq "*") { # all.
378 return split /$;/, $factoids{$faqtoid};
382 if (!grep /^$type$/, @format) {
383 &ERROR("gFI: type '$type' not valid for factoids.");
387 my @array = split /$;/, $factoids{$faqtoid};
388 for (0 .. $#format) {
389 next unless ($type eq $format[$_]);
393 &ERROR("gFI: should never happen.");
397 # Usage: &getFactoid($faqtoid);
401 if (!defined $faqtoid or $faqtoid =~ /^\s*$/) {
402 &WARN("getF: faqtoid == NULL.");
406 if (defined $factoids{$faqtoid}) { # dbm hash exception.
407 # we assume 1 unfortunately.
408 ### TODO: use &getFactInfo() instead?
409 my $retval = (split $;, $factoids{$faqtoid})[1];
411 if (defined $retval) {
412 &DEBUG("getF: returning '$retval' for '$faqtoid'.");
414 &DEBUG("getF: returning NULL for '$faqtoid'.");
423 # Usage: &delFactoid($faqtoid);
427 if (!defined $faqtoid or $faqtoid =~ /^\s*$/) {
428 &WARN("delF: faqtoid == NULL.");
432 if (defined $factoids{$faqtoid}) { # dbm hash exception.
433 delete $factoids{$faqtoid};
434 &status("DELETED $faqtoid");
436 &WARN("delF: nothing to deleted? ($faqtoid)");
442 # nothing - DB_FIle will create them on openDB()