src/db_dbm.pl

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