2 # dbi.pl: DBI (mysql/pgsql/sqlite) database frontend.
4 # Version: v0.9a (20021124)
6 # Notes: based on db_mysql.pl
7 # overhauled to be 31337.
13 use vars qw($dbh $shm $bot_data_dir);
19 # This wrapper's sole purpose in life is to keep the dbh connection open.
22 # These are DBI methods which do not require an active DB
23 # connection. [Eg, don't check to see if the database is working
24 # by pinging it for these methods.]
26 @no_ping{qw(ping err err_str quote disconnect clone)} = (1) x 6;
31 return undef unless $dbh;
32 $class = ref($class) if ref($class);
33 my $self = { dbh => $dbh };
41 my $method = $AUTOLOAD;
43 die "Undefined subroutine $method called" unless defined $self;
44 ($method) = $method =~ /([^\:]+)$/;
45 unshift @_, $self->{dbh};
46 return undef if not defined $self->{dbh};
47 goto &{ $self->{dbh}->can($method) }
48 if exists $no_ping{$method} and $no_ping{$method};
51 while ( ++$ping_count < 10 ) {
52 last if $self->{dbh}->ping;
53 $self->{dbh}->disconnect;
54 $self->{dbh} = $self->{dbh}->clone;
56 if ( $ping_count >= 10 and not $self->{dbh}->ping ) {
57 &ERROR('Tried real hard but was unable to reconnect');
61 my $coderef = $self->{dbh}->can($method);
62 goto &$coderef if defined $coderef;
64 # Dumb DBI doesn't have a can method for some
65 # functions. Like func.
67 return eval "\$self->{dbh}->$method(\@_)" or die $@;
73 # &sqlOpenDB($dbname, $dbtype, $sqluser, $sqlpass, $nofail);
75 my ( $db, $type, $user, $pass, $no_fail ) = @_;
78 # this is a mess. someone fix it, please.
79 if ( $type =~ /^SQLite(2)?$/i ) {
80 $db = "dbname=$db.sqlite";
82 elsif ( $type =~ /^pg/i ) {
86 elsif ($type =~ /mysql/) {
87 $attr->{mysql_enable_utf8mb4} = 1;
90 my $dsn = "DBI:$type:$db";
93 # SQLHost should be unset for SQLite
94 if ( exists $param{'SQLHost'} and $param{'SQLHost'} ) {
96 # PostgreSQL requires ';' and keyword 'host'. See perldoc Pg -- troubled
97 if ( $type eq 'Pg' ) {
98 $dsn .= ";host=$param{SQLHost}";
101 $dsn .= ":$param{SQLHost}";
103 $hoststr = " to $param{'SQLHost'}";
106 # SQLite ignores $user and $pass
107 $dbh = Bloot::DBI->new( DBI->connect( $dsn, $user, $pass, $attr ) );
109 if ( $dbh && !$dbh->err ) {
110 &status("Opened $type connection$hoststr");
113 &ERROR("Cannot connect$hoststr.");
114 &ERROR("Since $type is not available, shutting down bot!");
115 &ERROR( $dbh->errstr ) if ($dbh);
120 return 0 if ($no_fail);
127 return 0 unless ($dbh);
129 my $x = $param{SQLHost};
130 my $hoststr = ($x) ? " to $x" : '';
132 &status("Closed DBI connection$hoststr.");
139 # Usage: &sqlQuote($str);
141 return $dbh->quote( $_[0] );
145 # Usage: &sqlSelectMany($table, $select, [$where_href], [$other]);
146 # Return: $sth (Statement handle object)
148 my ( $table, $select, $where_href, $other ) = @_;
149 my $query = "SELECT $select FROM $table";
152 if ( !defined $select or $select =~ /^\s*$/ ) {
153 &WARN('sqlSelectMany: select == NULL.');
157 if ( !defined $table or $table =~ /^\s*$/ ) {
158 &WARN('sqlSelectMany: table == NULL.');
163 my $where = &hashref2where($where_href);
164 $query .= " WHERE $where" if ($where);
166 $query .= " $other" if ($other);
168 if ( !( $sth = $dbh->prepare($query) ) ) {
169 &ERROR("sqlSelectMany: prepare: $DBI::errstr");
175 return if ( !$sth->execute );
181 # Usage: &sqlSelect($table, $select, [$where_href, [$other]);
182 # Return: scalar if one element, array if list of elements.
183 # Note: Suitable for one column returns, that is, one column in $select.
184 # Todo: Always return array?
186 my $sth = &sqlSelectMany(@_);
187 if ( !defined $sth ) {
188 &WARN('sqlSelect failed.');
191 my @retval = $sth->fetchrow_array;
194 if ( scalar @retval > 1 ) {
197 elsif ( scalar @retval == 1 ) {
206 # Usage: &sqlSelectColArray($table, $select, [$where_href], [$other]);
208 sub sqlSelectColArray {
209 my $sth = &sqlSelectMany(@_);
212 if ( !defined $sth ) {
213 &WARN('sqlSelect failed.');
217 while ( my @row = $sth->fetchrow_array ) {
218 push( @retval, $row[0] );
226 # Usage: &sqlSelectColHash($table, $select, [$where_href], [$other], [$type]);
227 # Return: type = 1: $retval{ col2 }{ col1 } = 1;
228 # Return: no type: $retval{ col1 } = col2;
229 # Note: does not support $other, yet.
230 sub sqlSelectColHash {
231 my ( $table, $select, $where_href, $other, $type ) = @_;
232 my $sth = &sqlSelectMany( $table, $select, $where_href, $other );
233 if ( !defined $sth ) {
234 &WARN('sqlSelectColhash failed.');
239 if ( defined $type and $type == 2 ) {
240 &DEBUG('sqlSelectColHash: type 2!');
241 while ( my @row = $sth->fetchrow_array ) {
242 $retval{ $row[0] } = join( ':', $row[ 1 .. $#row ] );
244 &DEBUG( 'sqlSelectColHash: count => ' . scalar( keys %retval ) );
247 elsif ( defined $type and $type == 1 ) {
248 while ( my @row = $sth->fetchrow_array ) {
250 # reverse it to make it easier to count.
251 if ( scalar @row == 2 ) {
252 $retval{ $row[1] }{ $row[0] } = 1;
254 elsif ( scalar @row == 3 ) {
255 $retval{ $row[1] }{ $row[0] } = 1;
258 # what to do if there's only one or more than 3?
263 while ( my @row = $sth->fetchrow_array ) {
264 $retval{ $row[0] } = $row[1];
274 # Usage: &sqlSelectRowHash($table, $select, [$where_href]);
275 # Return: $hash{ col } = value;
276 # Note: useful for returning only one/first row of data.
277 sub sqlSelectRowHash {
278 my $sth = &sqlSelectMany(@_);
279 if ( !defined $sth ) {
280 &WARN('sqlSelectRowHash failed.');
283 my $retval = $sth->fetchrow_hashref();
295 # End of SELECT functions.
299 # Usage: &sqlSet($table, $where_href, $data_href);
300 # Return: 1 for success, undef for failure.
302 my ( $table, $where_href, $data_href ) = @_;
304 if ( !defined $table or $table =~ /^\s*$/ ) {
305 &WARN('sqlSet: table == NULL.');
309 if ( !defined $data_href or ref($data_href) ne 'HASH' ) {
310 &WARN('sqlSet: data_href == NULL.');
314 # any column can be NULL... so just get them all.
315 my $k = join( ',', keys %{$where_href} );
316 my $result = &sqlSelect( $table, $k, $where_href );
318 # &DEBUG('result is not defined :(') if (!defined $result);
320 # this was hardwired to use sqlUpdate. sqlite does not do inserts on sqlUpdate.
321 if ( defined $result ) {
322 &sqlUpdate( $table, $data_href, $where_href );
327 my %hash = %{$where_href};
329 # add data_href values...
330 foreach ( keys %{$data_href} ) {
331 $hash{$_} = ${$data_href}{$_};
335 &sqlInsert( $table, $data_href );
342 # Usage: &sqlUpdate($table, $data_href, $where_href);
344 my ( $table, $data_href, $where_href ) = @_;
346 if ( !defined $data_href or ref($data_href) ne 'HASH' ) {
347 &WARN('sqlSet: data_href == NULL.');
351 my $where = &hashref2where($where_href) if ($where_href);
352 my $update = &hashref2update($data_href) if ($data_href);
354 &sqlRaw( 'Update', "UPDATE $table SET $update WHERE $where" );
360 # Usage: &sqlInsert($table, $data_href, $other);
362 my ( $table, $data_href, $other ) = @_;
364 # note: if $other == 1, add 'DELAYED' to function instead.
365 # note: ^^^ doesnt actually do anything lol. Need code to s/1/DELAYED/ below -- troubled
367 if ( !defined $data_href or ref($data_href) ne 'HASH' ) {
368 &WARN('sqlInsert: data_href == NULL.');
372 my ( $k_aref, $v_aref ) = &hashref2array($data_href);
377 &WARN('sqlInsert: keys or vals is NULL.');
384 'INSERT %s INTO %s (%s) VALUES (%s)',
396 # Usage: &sqlReplace($table, $data_href, [$pkey]);
398 my ( $table, $data_href, $pkey ) = @_;
400 if ( !defined $data_href or ref($data_href) ne 'HASH' ) {
401 &WARN('sqlReplace: data_href == NULL.');
405 my ( $k_aref, $v_aref ) = &hashref2array($data_href);
410 &WARN('sqlReplace: keys or vals is NULL.');
414 if ( $param{'DBType'} =~ /^pgsql$/i ) {
416 # OK, heres the scoop. There is currently no REPLACE INTO in Pgsql.
417 # However, the bot already seems to search for factoids before insert
418 # anyways. Perhaps we could change this to a generic INSERT INTO so
419 # we can skip the seperate sql? -- troubled to: TimRiker
420 # PGSql syntax: UPDATE table SET key = 'value', key2 = 'value2' WHERE key = 'value'
422 # &sqlRaw("Replace($table)", sprintf(
423 # 'INSERT INTO %s (%s) VALUES (%s)',
424 # $table, join(',',@k), join(',',@v)
429 'REPLACE INTO %s (%s) VALUES (%s)',
441 'REPLACE INTO %s (%s) VALUES (%s)',
453 # Usage: &sqlDelete($table, $where_href);
455 my ( $table, $where_href ) = @_;
457 if ( !defined $where_href or ref($where_href) ne 'HASH' ) {
458 &WARN('sqlDelete: where_href == NULL.');
462 my $where = &hashref2where($where_href);
464 &sqlRaw( 'Delete', "DELETE FROM $table WHERE $where" );
470 # Usage: &sqlRaw($prefix, $query);
471 # Return: 1 for success, 0 for failure.
473 my ( $prefix, $query ) = @_;
476 if ( !defined $query or $query =~ /^\s*$/ ) {
477 &WARN('sqlRaw: query == NULL.');
481 if ( !( $sth = $dbh->prepare($query) ) ) {
482 &ERROR("Raw($prefix): !prepare => '$query'");
487 if ( !$sth->execute ) {
488 &ERROR("Raw($prefix): !execute => '$query'");
499 # Usage: &sqlRawReturn($query);
506 if ( !defined $query or $query =~ /^\s*$/ ) {
507 &WARN('sqlRawReturn: query == NULL.');
511 if ( !( $sth = $dbh->prepare($query) ) ) {
512 &ERROR("RawReturn: !prepare => '$query'");
517 if ( !$sth->execute ) {
518 &ERROR("RawReturn: !execute => '$query'");
523 while ( my @row = $sth->fetchrow_array ) {
524 push( @retval, $row[0] );
532 ####################################################################
533 ##### Misc DBI stuff...
538 if ( !defined $href ) {
539 &WARN('hashref2where: href == NULL.');
543 if ( ref($href) ne 'HASH' ) {
544 &WARN("hashref2where: href is not HASH ref (href => $href)");
549 foreach ( keys %hash ) {
552 if (s/^-//) { # as is.
554 delete $hash{ '-' . $_ };
557 $hash{$_} = &sqlQuote($v);
561 return join( ' AND ', map { $_ . '=' . $hash{$_} } keys %hash );
567 if ( ref($href) ne 'HASH' ) {
568 &WARN('hashref2update: href is not HASH ref.');
573 foreach ( keys %{$href} ) {
575 my $v = ${$href}{$_};
577 # is there a better way to do this?
578 if ( $k =~ s/^-// ) { # as is.
588 return join( ', ', map { $_ . '=' . $hash{$_} } sort keys %hash );
594 if ( ref($href) ne 'HASH' ) {
595 &WARN('hashref2update: href is not HASH ref.');
600 foreach ( keys %{$href} ) {
602 my $v = ${$href}{$_};
604 # is there a better way to do this?
605 if ( $k =~ s/^-// ) { # as is.
620 # Usage: &countKeys($table, [$col]);
622 my ( $table, $col ) = @_;
625 return ( &sqlRawReturn("SELECT count($col) FROM $table") )[0];
629 # Usage: &sumKey($table, $col);
631 my ( $table, $col ) = @_;
633 return ( &sqlRawReturn("SELECT sum($col) FROM $table") )[0];
637 # Usage: &randKey($table, $select);
639 my ( $table, $select ) = @_;
640 my $rand = int( rand( &countKeys($table) ) );
641 my $query = "SELECT $select FROM $table LIMIT 1 OFFSET $rand";
642 if ( $param{DBType} =~ /^mysql$/i ) {
644 # WARN: only newer MySQL supports 'LIMIT limit OFFSET offset'
645 $query = "SELECT $select FROM $table LIMIT $rand,1";
647 my $sth = $dbh->prepare($query);
649 &WARN("randKey($query)") unless $sth->execute;
650 my @retval = $sth->fetchrow_array;
657 # Usage: &deleteTable($table);
659 &sqlRaw( "deleteTable($_[0])", "DELETE FROM $_[0]" );
663 # Usage: &searchTable($table, $select, $key, $str);
664 # Note: searchTable does sqlQuote.
666 my ( $table, $select, $key, $str ) = @_;
670 # allow two types of wildcards.
671 if ( $str =~ /^\^(.*)\$$/ ) {
672 &FIXME("searchTable: can't do \"$str\"");
676 $str .= '%' if ( $str =~ s/^\^// );
677 $str = '%' . $str if ( $str =~ s/\$$// );
678 $str = '%' . $str . '%' if ( $str eq $origStr ); # el-cheapo fix.
682 $str =~ s/\?/_/g; # '.' should be supported, too.
687 my $query = "SELECT $select FROM $table WHERE $key LIKE " . &sqlQuote($str);
688 my $sth = $dbh->prepare($query);
691 if ( !$sth->execute ) {
692 &WARN("Search($query)");
697 while ( my @row = $sth->fetchrow_array ) {
698 push( @results, $row[0] );
706 my ( $table, $dbtype ) = @_;
707 my (@path) = ( $bot_data_dir, '.', '..', '../..' );
710 $dbtype = lc $dbtype;
713 my $file = "$_/setup/$dbtype/$table.sql";
714 next unless ( -f $file );
731 &sqlRaw( "sqlCreateTable($table)", $data );
737 my $database_exists = 0;
740 if ( $param{DBType} =~ /^mysql$/i ) {
741 my $sql = 'SHOW DATABASES';
742 foreach ( &sqlRawReturn($sql) ) {
743 $database_exists++ if ( $_ eq $param{'DBName'} );
746 unless ($database_exists) {
747 &status("Creating database $param{DBName}...");
748 my $query = "CREATE DATABASE $param{DBName}";
749 &sqlRaw( "create(db $param{DBName})", $query );
752 # retrieve a list of db's from the server.
753 my @tables = map { s/^\`//; s/\`$//; $_; } $dbh->func('_ListTables');
754 if ( $#tables == -1 ) {
755 @tables = $dbh->tables;
757 &status( 'Tables: ' . join( ',', @tables ) );
758 @db{@tables} = (1) x @tables;
761 elsif ( $param{DBType} =~ /^SQLite(2)?$/i ) {
763 # retrieve a list of db's from the server.
765 &sqlRawReturn("SELECT name FROM sqlite_master WHERE type='table'") )
770 # create database not needed for SQLite
773 elsif ( $param{DBType} =~ /^pgsql$/i ) {
775 # $sql_showDB = SQL to select the DB list
776 # $sql_showTBL = SQL to select all tables for the current connection
778 my $sql_showDB = 'SELECT datname FROM pg_database';
779 my $sql_showTBL = "SELECT tablename FROM pg_tables \
780 WHERE schemaname = 'public'";
782 foreach ( &sqlRawReturn($sql_showDB) ) {
783 $database_exists++ if ( $_ eq $param{'DBName'} );
786 unless ($database_exists) {
787 &status("Creating PostgreSQL database $param{'DBName'}");
788 &status('(actually, not really, please read the INSTALL file)');
791 # retrieve a list of db's from the server. This code is from mysql above, please check -- troubled
792 my @tables = map { s/^\`//; s/\`$//; $_; } &sqlRawReturn($sql_showTBL);
793 if ( $#tables == -1 ) {
794 @tables = $dbh->tables;
796 &status( 'Tables: ' . join( ',', @tables ) );
797 @db{@tables} = (1) x @tables;
800 foreach (qw(botmail connections factoids rootwarn seen stats onjoin)) {
801 if ( exists $db{$_} ) {
802 $cache{has_table}{$_} = 1;
806 &status("checkTables: creating new table $_...");
808 $cache{create_table}{$_} = 1;
810 &sqlCreateTable( $_, $param{DBType} );
816 # vim:ts=4:sw=4:expandtab:tw=80