src/dbi.pl

   1 #
   2 #   dbi.pl: DBI (mysql/pgsql/sqlite) database frontend.
   3 #   Author: dms
   4 #  Version: v0.9a (20021124)
   5 #  Created: 19991203
   6 #    Notes: based on db_mysql.pl
   7 #           overhauled to be 31337.
   8 #
   9
  10 use strict;
  11
  12 use vars qw(%param);
  13 use vars qw($dbh $shm $bot_data_dir);
  14
  15 package main;
  16
  17 eval {
  18      # This wrapper's sole purpose in life is to keep the dbh connection open.
  19      package Bloot::DBI;
  20
  21      # These are DBI methods which do not require an active DB
  22      # connection. [Eg, don't check to see if the database is working
  23      # by pinging it for these methods.]
  24      my %no_ping;
  25      @no_ping{qw(ping err err_str quote disconnect clone)} = (1) x 6;
  26      sub new {
  27           my $class = shift;
  28           my $dbh = shift;
  29           return undef unless $dbh;
  30           $class = ref($class) if ref($class);
  31           my $self = {dbh=>$dbh};
  32           bless $self, $class;
  33           return $self;
  34      }
  35
  36      our $AUTOLOAD;
  37      sub AUTOLOAD {
  38           my $method = $AUTOLOAD;
  39           my $self = shift;
  40           die "Undefined subroutine $method called" unless defined $self;
  41           ($method) = $method =~ /([^\:]+)$/;
  42           unshift @_, $self->{dbh};
  43           return undef if not defined $self->{dbh};
  44           goto &{$self->{dbh}->can($method)} if exists $no_ping{$method} and $no_ping{$method};
  45           my $ping_count = 0;
  46           while (++$ping_count < 10){
  47                last if $self->{dbh}->ping;
  48                $self->{dbh}->disconnect;
  49                $self->{dbh} = $self->{dbh}->clone;
  50           }
  51           if ($ping_count >=10 and not $self->{dbh}->ping){
  52                &ERROR("Tried real hard but was unable to reconnect");
  53                return undef;
  54           }
  55           $_[0] = $self->{dbh};
  56           my $coderef = $self->{dbh}->can($method);
  57           goto &$coderef if defined $coderef;
  58           # Dumb DBI doesn't have a can method for some
  59           # functions. Like func.
  60           shift;
  61           return eval "\$self->{dbh}->$method(\@_)" or die $@;
  62      }
  63      1;
  64 };
  65
  66 #####
  67 # &sqlOpenDB($dbname, $dbtype, $sqluser, $sqlpass, $nofail);
  68 sub sqlOpenDB {
  69     my ($db, $type, $user, $pass, $no_fail) = @_;
  70     # this is a mess. someone fix it, please.
  71     if ($type =~ /^SQLite(2)?$/i) {
  72         $db = "dbname=$db.sqlite";
  73     } elsif ($type =~ /^pg/i) {
  74         $db = "dbname=$db";
  75         $type = "Pg";
  76     }
  77
  78     my $dsn = "DBI:$type:$db";
  79     my $hoststr = "";
  80     # SQLHost should be unset for SQLite
  81     if (exists $param{'SQLHost'} and $param{'SQLHost'}) {
  82         $dsn    .= ":$param{SQLHost}";
  83         $hoststr = " to $param{'SQLHost'}";
  84     }
  85     # SQLite ignores $user and $pass
  86     $dbh    = Bloot::DBI->new(DBI->connect($dsn, $user, $pass));
  87
  88     if ($dbh && !$dbh->err) {
  89         &status("Opened $type connection$hoststr");
  90     } else {
  91         &ERROR("Cannot connect$hoststr.");
  92         &ERROR("Since $type is not available, shutting down bot!");
  93         &ERROR( $dbh->errstr ) if ($dbh);
  94         &closePID();
  95         &closeSHM($shm);
  96         &closeLog();
  97
  98         return 0 if ($no_fail);
  99
 100         exit 1;
 101     }
 102 }
 103
 104 sub sqlCloseDB {
 105     return 0 unless ($dbh);
 106
 107     my $x = $param{SQLHost};
 108     my $hoststr = ($x) ? " to $x" : "";
 109
 110     &status("Closed DBI connection$hoststr.");
 111     $dbh->disconnect();
 112
 113     return 1;
 114 }
 115
 116 #####
 117 # Usage: &sqlQuote($str);
 118 sub sqlQuote {
 119     return $dbh->quote($_[0]);
 120 }
 121
 122 #####
 123 #  Usage: &sqlSelectMany($table, $select, [$where_href], [$other]);
 124 # Return: $sth (Statement handle object)
 125 sub sqlSelectMany {
 126     my($table, $select, $where_href, $other) = @_;
 127     my $query = "SELECT $select FROM $table";
 128     my $sth;
 129
 130     if (!defined $select or $select =~ /^\s*$/) {
 131         &WARN("sqlSelectMany: select == NULL.");
 132         return;
 133     }
 134
 135     if (!defined $table or $table =~ /^\s*$/) {
 136         &WARN("sqlSelectMany: table == NULL.");
 137         return;
 138     }
 139
 140     if ($where_href) {
 141         my $where = &hashref2where($where_href);
 142         $query .= " WHERE $where" if ($where);
 143     }
 144     $query .= " $other" if ($other);
 145
 146     if (!($sth = $dbh->prepare($query))) {
 147         &ERROR("sqlSelectMany: prepare: $DBI::errstr");
 148         return;
 149     }
 150
 151     &SQLDebug($query);
 152
 153     return if (!$sth->execute);
 154
 155     return $sth;
 156 }
 157
 158 #####
 159 #  Usage: &sqlSelect($table, $select, [$where_href, [$other]);
 160 # Return: scalar if one element, array if list of elements.
 161 #   Note: Suitable for one column returns, that is, one column in $select.
 162 #   Todo: Always return array?
 163 sub sqlSelect {
 164     my $sth     = &sqlSelectMany(@_);
 165     if (!defined $sth) {
 166         &WARN("sqlSelect failed.");
 167         return;
 168     }
 169     my @retval  = $sth->fetchrow_array;
 170     $sth->finish;
 171
 172     if (scalar @retval > 1) {
 173         return @retval;
 174     } elsif (scalar @retval == 1) {
 175         return $retval[0];
 176     } else {
 177         return;
 178     }
 179 }
 180
 181 #####
 182 #  Usage: &sqlSelectColArray($table, $select, [$where_href], [$other]);
 183 # Return: array.
 184 sub sqlSelectColArray {
 185     my $sth     = &sqlSelectMany(@_);
 186     my @retval;
 187
 188     if (!defined $sth) {
 189         &WARN("sqlSelect failed.");
 190         return;
 191     }
 192
 193     while (my @row = $sth->fetchrow_array) {
 194         push(@retval, $row[0]);
 195     }
 196     $sth->finish;
 197
 198     return @retval;
 199 }
 200
 201 #####
 202 #  Usage: &sqlSelectColHash($table, $select, [$where_href], [$other], [$type]);
 203 # Return: type = 1: $retval{ col2 }{ col1 } = 1;
 204 # Return: no  type: $retval{ col1 } = col2;
 205 #   Note: does not support $other, yet.
 206 sub sqlSelectColHash {
 207     my ($table, $select, $where_href, $other, $type) = @_;
 208     my $sth     = &sqlSelectMany($table, $select, $where_href, $other);
 209     if (!defined $sth) {
 210         &WARN("sqlSelectColhash failed.");
 211         return;
 212     }
 213     my %retval;
 214
 215     if (defined $type and $type == 2) {
 216         &DEBUG("sqlSelectColHash: type 2!");
 217         while (my @row = $sth->fetchrow_array) {
 218             $retval{$row[0]} = join(':', $row[1..$#row]);
 219         }
 220         &DEBUG("sqlSelectColHash: count => ".scalar(keys %retval) );
 221
 222     } elsif (defined $type and $type == 1) {
 223         while (my @row = $sth->fetchrow_array) {
 224             # reverse it to make it easier to count.
 225             if (scalar @row == 2) {
 226                 $retval{$row[1]}{$row[0]} = 1;
 227             } elsif (scalar @row == 3) {
 228                 $retval{$row[1]}{$row[0]} = 1;
 229             }
 230             # what to do if there's only one or more than 3?
 231         }
 232
 233     } else {
 234         while (my @row = $sth->fetchrow_array) {
 235             $retval{$row[0]} = $row[1];
 236         }
 237     }
 238
 239     $sth->finish;
 240
 241     return %retval;
 242 }
 243
 244 #####
 245 #  Usage: &sqlSelectRowHash($table, $select, [$where_href]);
 246 # Return: $hash{ col } = value;
 247 #   Note: useful for returning only one/first row of data.
 248 sub sqlSelectRowHash {
 249     my $sth     = &sqlSelectMany(@_);
 250     if (!defined $sth) {
 251         &WARN("sqlSelectRowHash failed.");
 252         return;
 253     }
 254     my $retval  = $sth->fetchrow_hashref();
 255     $sth->finish;
 256
 257     if ($retval) {
 258         return %{ $retval };
 259     } else {
 260         return;
 261     }
 262 }
 263
 264 #
 265 # End of SELECT functions.
 266 #
 267
 268 #####
 269 #  Usage: &sqlSet($table, $where_href, $data_href);
 270 # Return: 1 for success, undef for failure.
 271 sub sqlSet {
 272     my ($table, $where_href, $data_href) = @_;
 273
 274     if (!defined $table or $table =~ /^\s*$/) {
 275         &WARN("sqlSet: table == NULL.");
 276         return;
 277     }
 278
 279     if (!defined $data_href or ref($data_href) ne "HASH") {
 280         &WARN("sqlSet: data_href == NULL.");
 281         return;
 282     }
 283
 284     # any column can be NULL... so just get them all.
 285     my $k = join(',', keys %{ $where_href } );
 286     my $result = &sqlSelect($table, $k, $where_href);
 287 #    &DEBUG("result is not defined :(") if (!defined $result);
 288
 289     # this was hardwired to use sqlUpdate. sqlite does not do inserts on sqlUpdate.
 290     if (defined $result) {
 291         &sqlUpdate($table, $data_href, $where_href);
 292     } else {
 293         # hack.
 294         my %hash = %{ $where_href };
 295         # add data_href values...
 296         foreach (keys %{ $data_href }) {
 297             $hash{ $_ } = ${ $data_href }{$_};
 298         }
 299
 300         $data_href = \%hash;
 301         &sqlInsert($table, $data_href);
 302     }
 303
 304     return 1;
 305 }
 306
 307 #####
 308 # Usage: &sqlUpdate($table, $data_href, $where_href);
 309 sub sqlUpdate {
 310     my ($table, $data_href, $where_href) = @_;
 311
 312     if (!defined $data_href or ref($data_href) ne "HASH") {
 313         &WARN("sqlSet: data_href == NULL.");
 314         return 0;
 315     }
 316
 317     my $where  = &hashref2where($where_href) if ($where_href);
 318     my $update = &hashref2update($data_href) if ($data_href);
 319
 320     &sqlRaw("Update", "UPDATE $table SET $update WHERE $where");
 321
 322     return 1;
 323 }
 324
 325 #####
 326 # Usage: &sqlInsert($table, $data_href, $other);
 327 sub sqlInsert {
 328     my ($table, $data_href, $other) = @_;
 329     # note: if $other == 1, add "DELAYED" to function instead.
 330
 331     if (!defined $data_href or ref($data_href) ne "HASH") {
 332         &WARN("sqlInsert: data_href == NULL.");
 333         return;
 334     }
 335
 336     my ($k_aref, $v_aref) = &hashref2array($data_href);
 337     my @k = @{ $k_aref };
 338     my @v = @{ $v_aref };
 339
 340     if (!@k or !@v) {
 341         &WARN("sqlInsert: keys or vals is NULL.");
 342         return;
 343     }
 344
 345     &sqlRaw("Insert($table)", sprintf(
 346         "INSERT %s INTO %s (%s) VALUES (%s)",
 347         ($other || ""), $table, join(',',@k), join(',',@v)
 348     ) );
 349
 350     return 1;
 351 }
 352
 353 #####
 354 # Usage: &sqlReplace($table, $data_href);
 355 sub sqlReplace {
 356     my ($table, $data_href) = @_;
 357
 358     if (!defined $data_href or ref($data_href) ne "HASH") {
 359         &WARN("sqlReplace: data_href == NULL.");
 360         return;
 361     }
 362
 363     my ($k_aref, $v_aref) = &hashref2array($data_href);
 364     my @k = @{ $k_aref };
 365     my @v = @{ $v_aref };
 366
 367     if (!@k or !@v) {
 368         &WARN("sqlReplace: keys or vals is NULL.");
 369         return;
 370     }
 371
 372     &sqlRaw("Replace($table)", sprintf(
 373         "REPLACE INTO %s (%s) VALUES (%s)",
 374         $table, join(',',@k), join(',',@v)
 375     ) );
 376
 377     return 1;
 378 }
 379
 380 #####
 381 # Usage: &sqlDelete($table, $where_href);
 382 sub sqlDelete {
 383     my ($table, $where_href) = @_;
 384
 385     if (!defined $where_href or ref($where_href) ne "HASH") {
 386         &WARN("sqlDelete: where_href == NULL.");
 387         return;
 388     }
 389
 390     my $where   = &hashref2where($where_href);
 391
 392     &sqlRaw("Delete", "DELETE FROM $table WHERE $where");
 393
 394     return 1;
 395 }
 396
 397 #####
 398 #  Usage: &sqlRaw($prefix, $query);
 399 # Return: 1 for success, 0 for failure.
 400 sub sqlRaw {
 401     my ($prefix, $query) = @_;
 402     my $sth;
 403
 404     if (!defined $query or $query =~ /^\s*$/) {
 405         &WARN("sqlRaw: query == NULL.");
 406         return 0;
 407     }
 408
 409     if (!($sth = $dbh->prepare($query))) {
 410         &ERROR("Raw($prefix): !prepare => '$query'");
 411         return 0;
 412     }
 413
 414     &SQLDebug($query);
 415     if (!$sth->execute) {
 416         &ERROR("Raw($prefix): !execute => '$query'");
 417         $sth->finish;
 418         return 0;
 419     }
 420
 421     $sth->finish;
 422
 423     return 1;
 424 }
 425
 426 #####
 427 #  Usage: &sqlRawReturn($query);
 428 # Return: array.
 429 sub sqlRawReturn {
 430     my ($query) = @_;
 431     my @retval;
 432     my $sth;
 433
 434     if (!defined $query or $query =~ /^\s*$/) {
 435         &WARN("sqlRawReturn: query == NULL.");
 436         return 0;
 437     }
 438
 439     if (!($sth = $dbh->prepare($query))) {
 440         &ERROR("RawReturn: !prepare => '$query'");
 441         return 0;
 442     }
 443
 444     &SQLDebug($query);
 445     if (!$sth->execute) {
 446         &ERROR("RawReturn: !execute => '$query'");
 447         $sth->finish;
 448         return 0;
 449     }
 450
 451     while (my @row = $sth->fetchrow_array) {
 452         push(@retval, $row[0]);
 453     }
 454
 455     $sth->finish;
 456
 457     return @retval;
 458 }
 459
 460 ####################################################################
 461 ##### Misc DBI stuff...
 462 #####
 463
 464 sub hashref2where {
 465     my ($href) = @_;
 466
 467     if (!defined $href) {
 468         &WARN("hashref2where: href == NULL.");
 469         return;
 470     }
 471
 472     if (ref($href) ne "HASH") {
 473         &WARN("hashref2where: href is not HASH ref (href => $href)");
 474         return;
 475     }
 476
 477     my %hash = %{ $href };
 478     foreach (keys %hash) {
 479         my $v = $hash{$_};
 480
 481         if (s/^-//) {   # as is.
 482             $hash{$_} = $v;
 483             delete $hash{'-'.$_};
 484         } else {
 485             $hash{$_} = &sqlQuote($v);
 486         }
 487     }
 488
 489     return join(' AND ', map { $_."=".$hash{$_} } keys %hash );
 490 }
 491
 492 sub hashref2update {
 493     my ($href) = @_;
 494
 495     if (ref($href) ne "HASH") {
 496         &WARN("hashref2update: href is not HASH ref.");
 497         return;
 498     }
 499
 500     my %hash;
 501     foreach (keys %{ $href }) {
 502         my $k = $_;
 503         my $v = ${ $href }{$_};
 504
 505         # is there a better way to do this?
 506         if ($k =~ s/^-//) {   # as is.
 507             1;
 508         } else {
 509             $v = &sqlQuote($v);
 510         }
 511
 512         $hash{$k} = $v;
 513     }
 514
 515     return join(', ', map { $_."=".$hash{$_} } sort keys %hash);
 516 }
 517
 518 sub hashref2array {
 519     my ($href) = @_;
 520
 521     if (ref($href) ne "HASH") {
 522         &WARN("hashref2update: href is not HASH ref.");
 523         return;
 524     }
 525
 526     my(@k, @v);
 527     foreach (keys %{ $href }) {
 528         my $k = $_;
 529         my $v = ${ $href }{$_};
 530
 531         # is there a better way to do this?
 532         if ($k =~ s/^-//) {   # as is.
 533             1;
 534         } else {
 535             $v = &sqlQuote($v);
 536         }
 537
 538         push(@k, $k);
 539         push(@v, $v);
 540     }
 541
 542     return (\@k, \@v);
 543 }
 544
 545 #####
 546 # Usage: &countKeys($table, [$col]);
 547 sub countKeys {
 548     my ($table, $col) = @_;
 549     $col ||= "*";
 550
 551     return (&sqlRawReturn("SELECT count($col) FROM $table"))[0];
 552 }
 553
 554 #####
 555 # Usage: &sumKey($table, $col);
 556 sub sumKey {
 557     my ($table, $col) = @_;
 558
 559     return (&sqlRawReturn("SELECT sum($col) FROM $table"))[0];
 560 }
 561
 562 #####
 563 # Usage: &randKey($table, $select);
 564 sub randKey {
 565     my ($table, $select) = @_;
 566     my $rand    = int(rand(&countKeys($table)));
 567     my $query   = "SELECT $select FROM $table LIMIT 1 OFFSET $rand";
 568     if ($param{DBType} =~ /^mysql$/i) {
 569         # WARN: only newer MySQL supports "LIMIT limit OFFSET offset"
 570         $query = "SELECT $select FROM $table LIMIT $rand,1";
 571     }
 572     my $sth     = $dbh->prepare($query);
 573     &SQLDebug($query);
 574     &WARN("randKey($query)") unless $sth->execute;
 575     my @retval  = $sth->fetchrow_array;
 576     $sth->finish;
 577
 578     return @retval;
 579 }
 580
 581 #####
 582 # Usage: &deleteTable($table);
 583 sub deleteTable {
 584     &sqlRaw("deleteTable($_[0])", "DELETE FROM $_[0]");
 585 }
 586
 587 #####
 588 # Usage: &searchTable($table, $select, $key, $str);
 589 #  Note: searchTable does sqlQuote.
 590 sub searchTable {
 591     my($table, $select, $key, $str) = @_;
 592     my $origStr = $str;
 593     my @results;
 594
 595     # allow two types of wildcards.
 596     if ($str =~ /^\^(.*)\$$/) {
 597         &FIXME("searchTable: can't do \"$str\"");
 598         $str = $1;
 599     } else {
 600         $str .= "%"     if ($str =~ s/^\^//);
 601         $str = "%".$str if ($str =~ s/\$$//);
 602         $str = "%".$str."%" if ($str eq $origStr);      # el-cheapo fix.
 603     }
 604
 605     $str =~ s/\_/\\_/g;
 606     $str =~ s/\?/_/g;   # '.' should be supported, too.
 607     $str =~ s/\*/%/g;
 608     # end of string fix.
 609
 610     my $query = "SELECT $select FROM $table WHERE $key LIKE ".
 611                 &sqlQuote($str);
 612     my $sth = $dbh->prepare($query);
 613
 614     &SQLDebug($query);
 615     if (!$sth->execute) {
 616         &WARN("Search($query)");
 617         $sth->finish;
 618         return;
 619     }
 620
 621     while (my @row = $sth->fetchrow_array) {
 622         push(@results, $row[0]);
 623     }
 624     $sth->finish;
 625
 626     return @results;
 627 }
 628
 629 sub sqlCreateTable {
 630     my($table)  = @_;
 631     my(@path)   = ($bot_data_dir, ".","..","../..");
 632     my $found   = 0;
 633     my $data;
 634
 635     foreach (@path) {
 636         my $file = "$_/setup/$table.sql";
 637         next unless ( -f $file );
 638
 639         open(IN, $file);
 640         while (<IN>) {
 641             chop;
 642             $data .= $_;
 643         }
 644
 645         $found++;
 646         last;
 647     }
 648
 649     if (!$found) {
 650         return 0;
 651     } else {
 652         &sqlRaw("sqlCreateTable($table)", $data);
 653         return 1;
 654     }
 655 }
 656
 657 sub checkTables {
 658     my $database_exists = 0;
 659     my %db;
 660
 661     if ($param{DBType} =~ /^mysql$/i) {
 662         my $sql = "SHOW DATABASES";
 663         foreach ( &sqlRawReturn($sql) ) {
 664             $database_exists++ if ($_ eq $param{'DBName'});
 665         }
 666
 667         unless ($database_exists) {
 668             &status("Creating database $param{DBName}...");
 669             my $query = "CREATE DATABASE $param{DBName}";
 670             &sqlRaw("create(db $param{DBName})", $query);
 671         }
 672
 673         # retrieve a list of db's from the server.
 674         my @tables = map {s/^\`//; s/\`$//; $_;} $dbh->func('_ListTables');
 675         if ($#tables == -1){
 676             @tables = $dbh->tables;
 677         }
 678         &status("Tables: ".join(',',@tables));
 679         @db{@tables} = (1) x @tables;
 680
 681     } elsif ($param{DBType} =~ /^SQLite(2)?$/i) {
 682
 683         # retrieve a list of db's from the server.
 684         foreach ( &sqlRawReturn("SELECT name FROM sqlite_master WHERE type='table'") ) {
 685             $db{$_} = 1;
 686         }
 687
 688         # create database not needed for SQLite
 689     }
 690
 691     foreach ( qw(botmail connections factoids rootwarn seen stats onjoin) ) {
 692         if (exists $db{$_}) {
 693             $cache{has_table}{$_} = 1;
 694             next;
 695         }
 696
 697         &status("checkTables: creating new table $_...");
 698
 699         $cache{create_table}{$_} = 1;
 700
 701         &sqlCreateTable($_);
 702     }
 703 }
 704
 705 1;