+++ /dev/null
-#
-# dbm.pl: Extension on the factoid database.
-# OrigAuthor: Kevin Lenzo (c) 1997
-# CurrAuthor: dms <dms@users.sourceforge.net>
-# Version: v0.6 (20000707)
-# FModified: 19991020
-#
-
-use strict;
-no strict 'refs';
-
-package main;
-
-use vars qw(%factoids %param);
-
-{
- # FIXME we don't handle multiply indexes tables
- # perhaps we should combine the keys with a ':' or something?
- # the spaces below separate the keys from the rest
- # of the fields.
- # Tim Riker thinks that freshmeat below should be a single index
- my %formats = (
- 'factoids', [
- 'factoid_key',
-
- 'requested_by',
- 'requested_time',
- 'requested_count',
- 'created_by',
- 'created_time',
- 'modified_by',
- 'modified_time',
- 'locked_by',
- 'locked_time',
- 'factoid_value'
- ],
- 'freshmeat', [
- 'projectname_short',
- 'latest_version',
-
- 'license',
- 'url_homepage',
- 'desc_short'
- ],
- 'rootwarn', [
- 'nick',
-
- 'attempt',
- 'time',
- 'host',
- 'channel'
- ],
- 'seen', [
- 'nick',
-
- 'time',
- 'channel',
- 'host',
- 'message'
- ],
- 'stats', [
- 'nick',
- 'type',
- 'channel',
-
- 'time',
- 'counter'
- ],
- 'botmail', [
- 'srcwho',
- 'dstwho',
-
- 'srcuh',
- 'time',
- 'msg'
- ]
- );
-
- sub openDB {
- use DB_File;
- foreach my $table (keys %formats) {
- next unless (&IsParam($table));
-
- my $file = "$param{'DBName'}-$table";
-
- if (dbmopen(%{"$table"}, $file, 0666)) {
- &status("Opened DBM $table ($file).");
- } else {
- &ERROR("Failed open to DBM $table ($file).");
- &shutdown();
- exit 1;
- }
- }
- }
-
- sub closeDB {
- foreach my $table (keys %formats) {
- next unless (&IsParam($table));
-
- if (dbmclose(%{ $table })) {
- &status("Closed DBM $table successfully.");
- next;
- }
- &ERROR("Failed closing DBM $table.");
- }
- }
-
- #####
- # Usage: &dbGetColInfo($table);
- sub dbGetColInfo {
- my ($table) = @_;
-
- if (scalar @{$formats{$table}}) {
- return @{$formats{$table}};
- } else {
- &ERROR("dbGCI: no format for table ($table).");
- return;
- }
- }
-}
-
-#####
-# Usage: &dbQuote($str);
-sub dbQuote {
- return $_[0];
-}
-
-#####
-# Usage: &dbGet($table, $select, $where);
-sub dbGet {
- my ($table, $select, $where) = @_;
- my ($key, $val) = split('=',$where) if $where =~ /=/;
- my $found = 0;
- my @retval;
- my $i;
- &DEBUG("dbGet($table, $select, $where);");
- return unless $key;
-
- my @format = &dbGetColInfo($table);
- if (!scalar @format) {
- return;
- }
-
- if (!defined ${ "$table" }{lc $val}) { # dbm hash exception.
- &DEBUG("dbGet: '$val' does not exist in $table.");
- return;
- }
-
- # return the whole row.
- if ($select eq "*") {
- @retval = split $;, ${"$table"}{lc $val};
- unshift(@retval,$key);
- return(@retval);
- }
-
- # FIXME this should be in $select order
- # and it's now in field order
- &DEBUG("dbGet: select=>'$select'.");
- my @array = split "$;", ${"$table"}{lc $val};
- unshift(@array,$val);
- for (0 .. $#format) {
- my $str = $format[$_];
- next unless (grep /^$str$/, split(/\,/, $select));
- $array[$_] ||= '';
- &DEBUG("dG: '$format[$_]'=>'$array[$_]'.");
- push(@retval, $array[$_]);
- }
-
- if (scalar @retval > 1) {
- return @retval;
- } elsif (scalar @retval == 1) {
- return $retval[0];
- } else {
- return;
- }
-}
-
-#####
-# Usage: &dbGetCol();
-# Usage: &dbGetCol($table, $select, $where, [$type]);
-sub dbGetCol {
- my ($table, $select, $where, $type) = @_;
- &FIXME("STUB: &dbGetCol($table, $select, $where, $type);");
-}
-
-#####
-# Usage: &dbGetColNiceHash($table, $select, $where);
-sub dbGetColNiceHash {
- my ($table, $select, $where) = @_;
- &DEBUG("dbGetColNiceHash($table, $select, $where);");
- my ($key, $val) = split('=',$where) if $where =~ /=/;
- return unless ${$table}{lc $val};
- my (%hash) = ();
- $hash{lc $key} = $val;
- my (@format) = &dbGetColInfo($table);
- shift @format;
- @hash{@format} = split $;, ${$table}{lc $val};
- return %hash;
-}
-
-#####
-# Usage: &dbInsert($table, $primkey, %hash);
-# Note: dbInsert should do dbQuote.
-sub dbInsert {
- my ($table, $primkey, %hash) = @_;
- my $found = 0;
- &DEBUG("dbInsert($table, $primkey, ...)");
-
- my $info = ${$table}{lc $primkey} || ''; # primkey or primval?
-
- my @format = &dbGetColInfo($table);
- if (!scalar @format) {
- return 0;
- }
-
- my $i;
- my @array = split $;, $info;
- delete $hash{$format[0]};
- for $i (1 .. $#format) {
- my $col = $format[$i];
- $array[$i - 1]=$hash{$col};
- $array[$i - 1]='' unless $array[$i - 1];
- delete $hash{$col};
- &DEBUG("dbI: '$col'=>'$array[$i - 1]'");
- }
-
- if (scalar keys %hash) {
- &ERROR("dbI: not added...");
- foreach (keys %hash) {
- &ERROR("dbI: '$_'=>'$hash{$_}'");
- }
- return 0;
- }
-
- ${$table}{lc $primkey} = join $;, @array;
-
- return 1;
-}
-
-sub dbUpdate {
- &FIXME("STUB: &dbUpdate(@_);=>somehow use dbInsert!");
-}
-
-#####
-# Usage: &dbSetRow($table, @values);
-sub dbSetRow {
- &FIXME("STUB: &dbSetRow(@_)");
-}
-
-#####
-# Usage: &dbDel($table, $primhash_ref);
-# Note: dbDel does dbQuote
-sub dbDel {
- my ($table, $phref) = @_;
- # FIXME does not really handle more than one key!
- my $primval = join(':', values %{$phref});
-
- if (!defined ${$table}{lc $primval}) {
- &DEBUG("dbDel: lc $primval does not exist in $table.");
- } else {
- delete ${$table}{lc $primval};
- }
-
- return '';
-}
-
-#####
-# Usage: &dbReplace($table, $key, %hash);
-# Note: dbReplace does optional dbQuote.
-sub dbReplace {
- my ($table, $key, %hash) = @_;
- &DEBUG("dbReplace($table, $key, %hash);");
-
- &dbDel($table, {$key=>$hash{$key}});
- &dbInsert($table, $hash{$key}, %hash);
- return 1;
-}
-
-#####
-# Usage: &dbSet($table, $primhash_ref, $hash_ref);
-sub dbSet {
- my ($table, $phref, $href) = @_;
- &DEBUG("dbSet(@_)");
- my ($key) = keys %{$phref};
- my $where = $key . "=" . $phref->{$key};
-
- my %hash = &dbGetColNiceHash($table, "*", $where);
- $hash{$key}=$phref->{$key};
- foreach (keys %{$href}) {
- &DEBUG("dbSet: setting $_=${$href}{$_}");
- $hash{$_} = ${$href}{$_};
- }
- &dbReplace($table, $key, %hash);
- return 1;
-}
-
-sub dbRaw {
- &FIXME("STUB: &dbRaw(@_);");
-}
-
-sub dbRawReturn {
- &FIXME("STUB: &dbRawReturn(@_);");
-}
-
-
-
-####################################################################
-##### Factoid related stuff...
-#####
-
-sub countKeys {
- return scalar keys %{$_[0]};
-}
-
-sub getKeys {
- &FIXME("STUB: &getKeys(@_); -- REDUNDANT");
-}
-
-sub randKey {
- &DEBUG("STUB: &randKey(@_);");
- my ($table, $select) = @_;
- my @format = &dbGetColInfo($table);
- if (!scalar @format) {
- return;
- }
-
- my $rand = int(rand(&countKeys($table) - 1));
- my @keys = keys %{$table};
- &dbGet($table, '$select', "$format[0]=$keys[$rand]");
-}
-
-#####
-# Usage: &deleteTable($table);
-sub deleteTable {
- my ($table) = @_;
- &FIXME("STUB: deleteTable($table)");
-}
-
-##### $select is misleading???
-# Usage: &searchTable($table, $returnkey, $primkey, $str);
-sub searchTable {
- my ($table, $primkey, $key, $str) = @_;
- &FIXME("STUB: searchTable($table, $primkey, $key, $str)");
- return;
- &DEBUG("searchTable($table, $primkey, $key, $str)");
-
- if (!scalar &dbGetColInfo($table)) {
- return;
- }
-
- my @results;
- foreach (keys %{$table}) {
- my $val = &dbGet($table, "NULL", $_, $key) || '';
- next unless ($val =~ /\Q$str\E/);
- push(@results, $_);
- }
-
- &DEBUG("sT: ".scalar(@results) );
-
- @results;
-}
-
-#####
-# Usage: &getFactInfo($faqtoid, $type);
-sub getFactInfo {
- my ($faqtoid, $type) = @_;
-
- my @format = &dbGetColInfo("factoids");
- if (!scalar @format) {
- return;
- }
-
- if (!defined $factoids{$faqtoid}) { # dbm hash exception.
- return;
- }
-
- if ($type eq "*") { # all.
- return split /$;/, $factoids{$faqtoid};
- }
-
- # specific.
- if (!grep /^$type$/, @format) {
- &ERROR("gFI: type '$type' not valid for factoids.");
- return;
- }
-
- my @array = split /$;/, $factoids{$faqtoid};
- for (0 .. $#format) {
- next unless ($type eq $format[$_]);
- return $array[$_];
- }
-
- &ERROR("gFI: should never happen.");
-}
-
-#####
-# Usage: &getFactoid($faqtoid);
-sub getFactoid {
- my ($faqtoid) = @_;
-
- if (!defined $faqtoid or $faqtoid =~ /^\s*$/) {
- &WARN("getF: faqtoid == NULL.");
- return;
- }
-
- if (defined $factoids{$faqtoid}) { # dbm hash exception.
- # we assume 1 unfortunately.
- ### TODO: use &getFactInfo() instead?
- my $retval = (split $;, $factoids{$faqtoid})[1];
-
- if (defined $retval) {
- &DEBUG("getF: returning '$retval' for '$faqtoid'.");
- } else {
- &DEBUG("getF: returning NULL for '$faqtoid'.");
- }
- return $retval;
- } else {
- return;
- }
-}
-
-#####
-# Usage: &delFactoid($faqtoid);
-sub delFactoid {
- my ($faqtoid) = @_;
-
- if (!defined $faqtoid or $faqtoid =~ /^\s*$/) {
- &WARN("delF: faqtoid == NULL.");
- return;
- }
-
- if (defined $factoids{$faqtoid}) { # dbm hash exception.
- delete $factoids{$faqtoid};
- &status("DELETED $faqtoid");
- } else {
- &WARN("delF: nothing to deleted? ($faqtoid)");
- return;
- }
-}
-
-sub checkTables {
-# nothing - DB_FIle will create them on openDB()
-}
-
-1;
projects / infobot.git / commitdiff