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