old/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
  11 package main;
  12
  13 use vars qw(%factoids %param);
  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         # @array? this is not defined anywhere. please fix, timriker!!!
 247         if (defined $array[$_] and $array[$_] ne "") {
 248             &DEBUG("dbSetRow: array[$_] != NULL($array[$_]).");
 249         }
 250         $array[$_] = $values[$_];
 251     }
 252
 253     ${$table}{$key}     = join $;, @array;
 254 }
 255
 256 #####
 257 # Usage: &dbDel($table, $primkey, $primval, [$key]);
 258 sub dbDel {
 259     my ($table, $primkey, $primval, $key) = @_;
 260     &DEBUG("dbDel($table, $primkey, $primval);");
 261
 262     if (!defined ${$table}{lc $primval}) {
 263         &DEBUG("dbDel: lc $primval does not exist in $table.");
 264     } else {
 265         delete ${$table}{lc $primval};
 266     }
 267
 268     return '';
 269 }
 270
 271 #####
 272 # Usage: &dbReplace($table, $key, %hash);
 273 #  Note: dbReplace does optional dbQuote.
 274 sub dbReplace {
 275     my ($table, $key, %hash) = @_;
 276     &DEBUG("dbReplace($table, $key, %hash);");
 277
 278     &dbDel($table, $key, $hash{$key}, %hash);
 279     &dbInsert($table, $hash{$key}, %hash);
 280     return 1;
 281 }
 282
 283 #####
 284 # Usage: &dbSet($table, $primhash_ref, $hash_ref);
 285 sub dbSet {
 286     my ($table, $phref, $href) = @_;
 287     &DEBUG("dbSet(@_)");
 288     my ($key) = keys %{$phref};
 289     my $where = $key . "=" . $phref->{$key};
 290
 291     my %hash = &dbGetColNiceHash($table, "*", $where);
 292     $hash{$key}=$phref->{$key};
 293     foreach (keys %{$href}) {
 294         &DEBUG("dbSet: setting $_=${$href}{$_}");
 295         $hash{$_} = ${$href}{$_};
 296     }
 297     &dbReplace($table, $key, %hash);
 298     return 1;
 299 }
 300
 301 sub dbRaw {
 302     &FIXME("STUB: &dbRaw(@_);");
 303 }
 304
 305 sub dbRawReturn {
 306     &FIXME("STUB: &dbRawReturn(@_);");
 307 }
 308
 309
 310
 311 ####################################################################
 312 ##### Factoid related stuff...
 313 #####
 314
 315 sub countKeys {
 316     return scalar keys %{$_[0]};
 317 }
 318
 319 sub getKeys {
 320     &FIXME("STUB: &getKeys(@_); -- REDUNDANT");
 321 }
 322
 323 sub randKey {
 324     &DEBUG("STUB: &randKey(@_);");
 325     my ($table, $select) = @_;
 326     my @format = &dbGetColInfo($table);
 327     if (!scalar @format) {
 328         return;
 329     }
 330
 331     my $rand = int(rand(&countKeys($table) - 1));
 332     my @keys = keys %{$table};
 333     &dbGet($table, '$select', "$format[0]=$keys[$rand]");
 334 }
 335
 336 #####
 337 # Usage: &deleteTable($table);
 338 sub deleteTable {
 339     my ($table) = @_;
 340     &FIXME("STUB: deleteTable($table)");
 341 }
 342
 343 ##### $select is misleading???
 344 # Usage: &searchTable($table, $returnkey, $primkey, $str);
 345 sub searchTable {
 346     my ($table, $primkey, $key, $str) = @_;
 347     &FIXME("STUB: searchTable($table, $primkey, $key, $str)");
 348     return;
 349     &DEBUG("searchTable($table, $primkey, $key, $str)");
 350
 351     if (!scalar &dbGetColInfo($table)) {
 352         return;
 353     }
 354
 355     my @results;
 356     foreach (keys %{$table}) {
 357         my $val = &dbGet($table, "NULL", $_, $key) || '';
 358         next unless ($val =~ /\Q$str\E/);
 359         push(@results, $_);
 360     }
 361
 362     &DEBUG("sT: ".scalar(@results) );
 363
 364     @results;
 365 }
 366
 367 #####
 368 # Usage: &getFactInfo($faqtoid, $type);
 369 sub getFactInfo {
 370     my ($faqtoid, $type) = @_;
 371
 372     my @format = &dbGetColInfo("factoids");
 373     if (!scalar @format) {
 374         return;
 375     }
 376
 377     if (!defined $factoids{$faqtoid}) { # dbm hash exception.
 378         return;
 379     }
 380
 381     if ($type eq "*") {         # all.
 382         return split /$;/, $factoids{$faqtoid};
 383     }
 384
 385     # specific.
 386     if (!grep /^$type$/, @format) {
 387         &ERROR("gFI: type '$type' not valid for factoids.");
 388         return;
 389     }
 390
 391     my @array   = split /$;/, $factoids{$faqtoid};
 392     for (0 .. $#format) {
 393         next unless ($type eq $format[$_]);
 394         return $array[$_];
 395     }
 396
 397     &ERROR("gFI: should never happen.");
 398 }
 399
 400 #####
 401 # Usage: &getFactoid($faqtoid);
 402 sub getFactoid {
 403     my ($faqtoid) = @_;
 404
 405     if (!defined $faqtoid or $faqtoid =~ /^\s*$/) {
 406         &WARN("getF: faqtoid == NULL.");
 407         return;
 408     }
 409
 410     if (defined $factoids{$faqtoid}) {  # dbm hash exception.
 411         # we assume 1 unfortunately.
 412         ### TODO: use &getFactInfo() instead?
 413         my $retval = (split $;, $factoids{$faqtoid})[1];
 414
 415         if (defined $retval) {
 416             &DEBUG("getF: returning '$retval' for '$faqtoid'.");
 417         } else {
 418             &DEBUG("getF: returning NULL for '$faqtoid'.");
 419         }
 420         return $retval;
 421     } else {
 422         return;
 423     }
 424 }
 425
 426 #####
 427 # Usage: &delFactoid($faqtoid);
 428 sub delFactoid {
 429     my ($faqtoid) = @_;
 430
 431     if (!defined $faqtoid or $faqtoid =~ /^\s*$/) {
 432         &WARN("delF: faqtoid == NULL.");
 433         return;
 434     }
 435
 436     if (defined $factoids{$faqtoid}) {  # dbm hash exception.
 437         delete $factoids{$faqtoid};
 438         &status("DELETED $faqtoid");
 439     } else {
 440         &WARN("delF: nothing to deleted? ($faqtoid)");
 441         return;
 442     }
 443 }
 444
 445 sub checkTables {
 446 # nothing - DB_FIle will create them on openDB()
 447 }
 448
 449 1;