src/dbm.pl

   1 #
   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)
   6 #   FModified: 19991020
   7 #
   8
   9 use strict;
  10 no strict 'refs';
  11
  12 package main;
  13
  14 use vars qw(%factoids %param);
  15
  16 {
  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
  20     # of the fields.
  21     # Tim Riker thinks that freshmeat below should be a single index
  22     my %formats = (
  23         'factoids', [
  24             'factoid_key',
  25
  26             'requested_by',
  27             'requested_time',
  28             'requested_count',
  29             'created_by',
  30             'created_time',
  31             'modified_by',
  32             'modified_time',
  33             'locked_by',
  34             'locked_time',
  35             'factoid_value'
  36         ],
  37         'freshmeat', [
  38             'projectname_short',
  39             'latest_version',
  40
  41             'license',
  42             'url_homepage',
  43             'desc_short'
  44         ],
  45         'rootwarn', [
  46             'nick',
  47
  48             'attempt',
  49             'time',
  50             'host',
  51             'channel'
  52         ],
  53         'seen', [
  54             'nick',
  55
  56             'time',
  57             'channel',
  58             'host',
  59             'message'
  60         ],
  61         'stats', [
  62             'nick',
  63             'type',
  64             'channel',
  65
  66             'time',
  67             'counter'
  68         ],
  69         'botmail', [
  70             'srcwho',
  71             'dstwho',
  72
  73             'srcuh',
  74             'time',
  75             'msg'
  76         ]
  77     );
  78
  79     sub openDB {
  80         use DB_File;
  81         foreach my $table (keys %formats) {
  82             next unless (&IsParam($table));
  83
  84             my $file = "$param{'DBName'}-$table";
  85
  86             if (dbmopen(%{"$table"}, $file, 0666)) {
  87                 &status("Opened DBM $table ($file).");
  88             } else {
  89                 &ERROR("Failed open to DBM $table ($file).");
  90                 &shutdown();
  91                 exit 1;
  92             }
  93         }
  94     }
  95
  96     sub closeDB {
  97         foreach my $table (keys %formats) {
  98             next unless (&IsParam($table));
  99
 100             if (dbmclose(%{ $table })) {
 101                 &status("Closed DBM $table successfully.");
 102                 next;
 103             }
 104             &ERROR("Failed closing DBM $table.");
 105         }
 106     }
 107
 108     #####
 109     # Usage: &dbGetColInfo($table);
 110     sub dbGetColInfo {
 111         my ($table) = @_;
 112
 113         if (scalar @{$formats{$table}}) {
 114             return @{$formats{$table}};
 115         } else {
 116             &ERROR("dbGCI: no format for table ($table).");
 117             return;
 118         }
 119     }
 120 }
 121
 122 #####
 123 # Usage: &dbQuote($str);
 124 sub dbQuote {
 125     return $_[0];
 126 }
 127
 128 #####
 129 # Usage: &dbGet($table, $select, $where);
 130 sub dbGet {
 131     my ($table, $select, $where) = @_;
 132     my ($key, $val) = split('=',$where) if $where =~ /=/;
 133     my $found = 0;
 134     my @retval;
 135     my $i;
 136     &DEBUG("dbGet($table, $select, $where);");
 137     return unless $key;
 138
 139     my @format = &dbGetColInfo($table);
 140     if (!scalar @format) {
 141         return;
 142     }
 143
 144     if (!defined ${ "$table" }{lc $val}) {      # dbm hash exception.
 145         &DEBUG("dbGet: '$val' does not exist in $table.");
 146         return;
 147     }
 148
 149     # return the whole row.
 150     if ($select eq "*") {
 151         @retval = split $;, ${"$table"}{lc $val};
 152         unshift(@retval,$key);
 153         return(@retval);
 154     }
 155
 156     &DEBUG("dbGet: select=>'$select'.");
 157     my @array = split "$;", ${"$table"}{lc $val};
 158     unshift(@array,$val);
 159     for (0 .. $#format) {
 160         my $str = $format[$_];
 161         next unless (grep /^$str$/, split(/\,/, $select));
 162         $array[$_] ||= '';
 163         &DEBUG("dG: '$format[$_]'=>'$array[$_]'.");
 164         push(@retval, $array[$_]);
 165     }
 166
 167     if (scalar @retval > 1) {
 168         return @retval;
 169     } elsif (scalar @retval == 1) {
 170         return $retval[0];
 171     } else {
 172         return;
 173     }
 174 }
 175
 176 #####
 177 # Usage: &dbGetCol();
 178 # Usage: &dbGetCol($table, $select, $where, [$type]);
 179 sub dbGetCol {
 180     my ($table, $select, $where, $type) = @_;
 181     &FIXME("STUB: &dbGetCol($table, $select, $where, $type);");
 182 }
 183
 184 #####
 185 # Usage: &dbGetColNiceHash($table, $select, $where);
 186 sub dbGetColNiceHash {
 187     my ($table, $select, $where) = @_;
 188     &DEBUG("dbGetColNiceHash($table, $select, $where);");
 189     my ($key, $val) = split('=',$where) if $where =~ /=/;
 190     return unless ${$table}{lc $val};
 191     my (%hash) = ();
 192     $hash{lc $key} = $val;
 193     my (@format) = &dbGetColInfo($table);
 194     shift @format;
 195     @hash{@format} = split $;, ${$table}{lc $val};
 196     return %hash;
 197 }
 198
 199 #####
 200 # Usage: &dbInsert($table, $primkey, %hash);
 201 #  Note: dbInsert should do dbQuote.
 202 sub dbInsert {
 203     my ($table, $primkey, %hash) = @_;
 204     my $found = 0;
 205     &DEBUG("dbInsert($table, $primkey, ...)");
 206
 207     my $info = ${$table}{lc $primkey} || '';    # primkey or primval?
 208
 209     my @format = &dbGetColInfo($table);
 210     if (!scalar @format) {
 211         return 0;
 212     }
 213
 214     my $i;
 215     my @array = split $;, $info;
 216     delete $hash{$format[0]};
 217     for $i (1 .. $#format) {
 218         my $col = $format[$i];
 219         $array[$i - 1]=$hash{$col};
 220         $array[$i - 1]='' unless $array[$i - 1];
 221         delete $hash{$col};
 222         &DEBUG("dbI: '$col'=>'$array[$i - 1]'");
 223     }
 224
 225     if (scalar keys %hash) {
 226         &ERROR("dbI: not added...");
 227         foreach (keys %hash) {
 228             &ERROR("dbI: '$_'=>'$hash{$_}'");
 229         }
 230         return 0;
 231     }
 232
 233     ${$table}{lc $primkey}      = join $;, @array;
 234
 235     return 1;
 236 }
 237
 238 sub dbUpdate {
 239     &FIXME("STUB: &dbUpdate(@_);=>somehow use dbInsert!");
 240 }
 241
 242 #####
 243 # Usage: &dbSetRow($table, @values);
 244 sub dbSetRow {
 245     &FIXME("STUB: &dbSetRow(@_)");
 246 }
 247
 248 #####
 249 # Usage: &dbDel($table, $primhash_ref);
 250 #  Note: dbDel does dbQuote
 251 sub dbDel {
 252     my ($table, $phref) = @_;
 253     # FIXME does not really handle more than one key!
 254     my $primval = join(':', values %{$phref});
 255
 256     if (!defined ${$table}{lc $primval}) {
 257         &DEBUG("dbDel: lc $primval does not exist in $table.");
 258     } else {
 259         delete ${$table}{lc $primval};
 260     }
 261
 262     return '';
 263 }
 264
 265 #####
 266 # Usage: &dbReplace($table, $key, %hash);
 267 #  Note: dbReplace does optional dbQuote.
 268 sub dbReplace {
 269     my ($table, $key, %hash) = @_;
 270     &DEBUG("dbReplace($table, $key, %hash);");
 271
 272     &dbDel($table, {$key=>$hash{$key}});
 273     &dbInsert($table, $hash{$key}, %hash);
 274     return 1;
 275 }
 276
 277 #####
 278 # Usage: &dbSet($table, $primhash_ref, $hash_ref);
 279 sub dbSet {
 280     my ($table, $phref, $href) = @_;
 281     &DEBUG("dbSet(@_)");
 282     my ($key) = keys %{$phref};
 283     my $where = $key . "=" . $phref->{$key};
 284
 285     my %hash = &dbGetColNiceHash($table, "*", $where);
 286     $hash{$key}=$phref->{$key};
 287     foreach (keys %{$href}) {
 288         &DEBUG("dbSet: setting $_=${$href}{$_}");
 289         $hash{$_} = ${$href}{$_};
 290     }
 291     &dbReplace($table, $key, %hash);
 292     return 1;
 293 }
 294
 295 sub dbRaw {
 296     &FIXME("STUB: &dbRaw(@_);");
 297 }
 298
 299 sub dbRawReturn {
 300     &FIXME("STUB: &dbRawReturn(@_);");
 301 }
 302
 303
 304
 305 ####################################################################
 306 ##### Factoid related stuff...
 307 #####
 308
 309 sub countKeys {
 310     return scalar keys %{$_[0]};
 311 }
 312
 313 sub getKeys {
 314     &FIXME("STUB: &getKeys(@_); -- REDUNDANT");
 315 }
 316
 317 sub randKey {
 318     &DEBUG("STUB: &randKey(@_);");
 319     my ($table, $select) = @_;
 320     my @format = &dbGetColInfo($table);
 321     if (!scalar @format) {
 322         return;
 323     }
 324
 325     my $rand = int(rand(&countKeys($table) - 1));
 326     my @keys = keys %{$table};
 327     &dbGet($table, '$select', "$format[0]=$keys[$rand]");
 328 }
 329
 330 #####
 331 # Usage: &deleteTable($table);
 332 sub deleteTable {
 333     my ($table) = @_;
 334     &FIXME("STUB: deleteTable($table)");
 335 }
 336
 337 ##### $select is misleading???
 338 # Usage: &searchTable($table, $returnkey, $primkey, $str);
 339 sub searchTable {
 340     my ($table, $primkey, $key, $str) = @_;
 341     &FIXME("STUB: searchTable($table, $primkey, $key, $str)");
 342     return;
 343     &DEBUG("searchTable($table, $primkey, $key, $str)");
 344
 345     if (!scalar &dbGetColInfo($table)) {
 346         return;
 347     }
 348
 349     my @results;
 350     foreach (keys %{$table}) {
 351         my $val = &dbGet($table, "NULL", $_, $key) || '';
 352         next unless ($val =~ /\Q$str\E/);
 353         push(@results, $_);
 354     }
 355
 356     &DEBUG("sT: ".scalar(@results) );
 357
 358     @results;
 359 }
 360
 361 #####
 362 # Usage: &getFactInfo($faqtoid, $type);
 363 sub getFactInfo {
 364     my ($faqtoid, $type) = @_;
 365
 366     my @format = &dbGetColInfo("factoids");
 367     if (!scalar @format) {
 368         return;
 369     }
 370
 371     if (!defined $factoids{$faqtoid}) { # dbm hash exception.
 372         return;
 373     }
 374
 375     if ($type eq "*") {         # all.
 376         return split /$;/, $factoids{$faqtoid};
 377     }
 378
 379     # specific.
 380     if (!grep /^$type$/, @format) {
 381         &ERROR("gFI: type '$type' not valid for factoids.");
 382         return;
 383     }
 384
 385     my @array   = split /$;/, $factoids{$faqtoid};
 386     for (0 .. $#format) {
 387         next unless ($type eq $format[$_]);
 388         return $array[$_];
 389     }
 390
 391     &ERROR("gFI: should never happen.");
 392 }
 393
 394 #####
 395 # Usage: &getFactoid($faqtoid);
 396 sub getFactoid {
 397     my ($faqtoid) = @_;
 398
 399     if (!defined $faqtoid or $faqtoid =~ /^\s*$/) {
 400         &WARN("getF: faqtoid == NULL.");
 401         return;
 402     }
 403
 404     if (defined $factoids{$faqtoid}) {  # dbm hash exception.
 405         # we assume 1 unfortunately.
 406         ### TODO: use &getFactInfo() instead?
 407         my $retval = (split $;, $factoids{$faqtoid})[1];
 408
 409         if (defined $retval) {
 410             &DEBUG("getF: returning '$retval' for '$faqtoid'.");
 411         } else {
 412             &DEBUG("getF: returning NULL for '$faqtoid'.");
 413         }
 414         return $retval;
 415     } else {
 416         return;
 417     }
 418 }
 419
 420 #####
 421 # Usage: &delFactoid($faqtoid);
 422 sub delFactoid {
 423     my ($faqtoid) = @_;
 424
 425     if (!defined $faqtoid or $faqtoid =~ /^\s*$/) {
 426         &WARN("delF: faqtoid == NULL.");
 427         return;
 428     }
 429
 430     if (defined $factoids{$faqtoid}) {  # dbm hash exception.
 431         delete $factoids{$faqtoid};
 432         &status("DELETED $faqtoid");
 433     } else {
 434         &WARN("delF: nothing to deleted? ($faqtoid)");
 435         return;
 436     }
 437 }
 438
 439 sub checkTables {
 440 # nothing - DB_FIle will create them on openDB()
 441 }
 442
 443 1;