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     # 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));
 164         $array[$_] ||= '';
 165         &DEBUG("dG: '$format[$_]'=>'$array[$_]'.");
 166         push(@retval, $array[$_]);
 167     }
 168
 169     if (scalar @retval > 1) {
 170         return @retval;
 171     } elsif (scalar @retval == 1) {
 172         return $retval[0];
 173     } else {
 174         return;
 175     }
 176 }
 177
 178 #####
 179 # Usage: &dbGetCol();
 180 # Usage: &dbGetCol($table, $select, $where, [$type]);
 181 sub dbGetCol {
 182     my ($table, $select, $where, $type) = @_;
 183     &FIXME("STUB: &dbGetCol($table, $select, $where, $type);");
 184 }
 185
 186 #####
 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};
 193     my (%hash) = ();
 194     $hash{lc $key} = $val;
 195     my (@format) = &dbGetColInfo($table);
 196     shift @format;
 197     @hash{@format} = split $;, ${$table}{lc $val};
 198     return %hash;
 199 }
 200
 201 #####
 202 # Usage: &dbInsert($table, $primkey, %hash);
 203 #  Note: dbInsert should do dbQuote.
 204 sub dbInsert {
 205     my ($table, $primkey, %hash) = @_;
 206     my $found = 0;
 207     &DEBUG("dbInsert($table, $primkey, ...)");
 208
 209     my $info = ${$table}{lc $primkey} || '';    # primkey or primval?
 210
 211     my @format = &dbGetColInfo($table);
 212     if (!scalar @format) {
 213         return 0;
 214     }
 215
 216     my $i;
 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];
 223         delete $hash{$col};
 224         &DEBUG("dbI: '$col'=>'$array[$i - 1]'");
 225     }
 226
 227     if (scalar keys %hash) {
 228         &ERROR("dbI: not added...");
 229         foreach (keys %hash) {
 230             &ERROR("dbI: '$_'=>'$hash{$_}'");
 231         }
 232         return 0;
 233     }
 234
 235     ${$table}{lc $primkey}      = join $;, @array;
 236
 237     return 1;
 238 }
 239
 240 sub dbUpdate {
 241     &FIXME("STUB: &dbUpdate(@_);=>somehow use dbInsert!");
 242 }
 243
 244 #####
 245 # Usage: &dbSetRow($table, @values);
 246 sub dbSetRow {
 247     &FIXME("STUB: &dbSetRow(@_)");
 248 }
 249
 250 #####
 251 # Usage: &dbDel($table, $primhash_ref);
 252 #  Note: dbDel does dbQuote
 253 sub dbDel {
 254     my ($table, $phref) = @_;
 255     # FIXME does not really handle more than one key!
 256     my $primval = join(':', values %{$phref});
 257
 258     if (!defined ${$table}{lc $primval}) {
 259         &DEBUG("dbDel: lc $primval does not exist in $table.");
 260     } else {
 261         delete ${$table}{lc $primval};
 262     }
 263
 264     return '';
 265 }
 266
 267 #####
 268 # Usage: &dbReplace($table, $key, %hash);
 269 #  Note: dbReplace does optional dbQuote.
 270 sub dbReplace {
 271     my ($table, $key, %hash) = @_;
 272     &DEBUG("dbReplace($table, $key, %hash);");
 273
 274     &dbDel($table, {$key=>$hash{$key}});
 275     &dbInsert($table, $hash{$key}, %hash);
 276     return 1;
 277 }
 278
 279 #####
 280 # Usage: &dbSet($table, $primhash_ref, $hash_ref);
 281 sub dbSet {
 282     my ($table, $phref, $href) = @_;
 283     &DEBUG("dbSet(@_)");
 284     my ($key) = keys %{$phref};
 285     my $where = $key . "=" . $phref->{$key};
 286
 287     my %hash = &dbGetColNiceHash($table, "*", $where);
 288     $hash{$key}=$phref->{$key};
 289     foreach (keys %{$href}) {
 290         &DEBUG("dbSet: setting $_=${$href}{$_}");
 291         $hash{$_} = ${$href}{$_};
 292     }
 293     &dbReplace($table, $key, %hash);
 294     return 1;
 295 }
 296
 297 sub dbRaw {
 298     &FIXME("STUB: &dbRaw(@_);");
 299 }
 300
 301 sub dbRawReturn {
 302     &FIXME("STUB: &dbRawReturn(@_);");
 303 }
 304
 305
 306
 307 ####################################################################
 308 ##### Factoid related stuff...
 309 #####
 310
 311 sub countKeys {
 312     return scalar keys %{$_[0]};
 313 }
 314
 315 sub getKeys {
 316     &FIXME("STUB: &getKeys(@_); -- REDUNDANT");
 317 }
 318
 319 sub randKey {
 320     &DEBUG("STUB: &randKey(@_);");
 321     my ($table, $select) = @_;
 322     my @format = &dbGetColInfo($table);
 323     if (!scalar @format) {
 324         return;
 325     }
 326
 327     my $rand = int(rand(&countKeys($table) - 1));
 328     my @keys = keys %{$table};
 329     &dbGet($table, '$select', "$format[0]=$keys[$rand]");
 330 }
 331
 332 #####
 333 # Usage: &deleteTable($table);
 334 sub deleteTable {
 335     my ($table) = @_;
 336     &FIXME("STUB: deleteTable($table)");
 337 }
 338
 339 ##### $select is misleading???
 340 # Usage: &searchTable($table, $returnkey, $primkey, $str);
 341 sub searchTable {
 342     my ($table, $primkey, $key, $str) = @_;
 343     &FIXME("STUB: searchTable($table, $primkey, $key, $str)");
 344     return;
 345     &DEBUG("searchTable($table, $primkey, $key, $str)");
 346
 347     if (!scalar &dbGetColInfo($table)) {
 348         return;
 349     }
 350
 351     my @results;
 352     foreach (keys %{$table}) {
 353         my $val = &dbGet($table, "NULL", $_, $key) || '';
 354         next unless ($val =~ /\Q$str\E/);
 355         push(@results, $_);
 356     }
 357
 358     &DEBUG("sT: ".scalar(@results) );
 359
 360     @results;
 361 }
 362
 363 #####
 364 # Usage: &getFactInfo($faqtoid, $type);
 365 sub getFactInfo {
 366     my ($faqtoid, $type) = @_;
 367
 368     my @format = &dbGetColInfo("factoids");
 369     if (!scalar @format) {
 370         return;
 371     }
 372
 373     if (!defined $factoids{$faqtoid}) { # dbm hash exception.
 374         return;
 375     }
 376
 377     if ($type eq "*") {         # all.
 378         return split /$;/, $factoids{$faqtoid};
 379     }
 380
 381     # specific.
 382     if (!grep /^$type$/, @format) {
 383         &ERROR("gFI: type '$type' not valid for factoids.");
 384         return;
 385     }
 386
 387     my @array   = split /$;/, $factoids{$faqtoid};
 388     for (0 .. $#format) {
 389         next unless ($type eq $format[$_]);
 390         return $array[$_];
 391     }
 392
 393     &ERROR("gFI: should never happen.");
 394 }
 395
 396 #####
 397 # Usage: &getFactoid($faqtoid);
 398 sub getFactoid {
 399     my ($faqtoid) = @_;
 400
 401     if (!defined $faqtoid or $faqtoid =~ /^\s*$/) {
 402         &WARN("getF: faqtoid == NULL.");
 403         return;
 404     }
 405
 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];
 410
 411         if (defined $retval) {
 412             &DEBUG("getF: returning '$retval' for '$faqtoid'.");
 413         } else {
 414             &DEBUG("getF: returning NULL for '$faqtoid'.");
 415         }
 416         return $retval;
 417     } else {
 418         return;
 419     }
 420 }
 421
 422 #####
 423 # Usage: &delFactoid($faqtoid);
 424 sub delFactoid {
 425     my ($faqtoid) = @_;
 426
 427     if (!defined $faqtoid or $faqtoid =~ /^\s*$/) {
 428         &WARN("delF: faqtoid == NULL.");
 429         return;
 430     }
 431
 432     if (defined $factoids{$faqtoid}) {  # dbm hash exception.
 433         delete $factoids{$faqtoid};
 434         &status("DELETED $faqtoid");
 435     } else {
 436         &WARN("delF: nothing to deleted? ($faqtoid)");
 437         return;
 438     }
 439 }
 440
 441 sub checkTables {
 442 # nothing - DB_FIle will create them on openDB()
 443 }
 444
 445 1;