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