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