Initial commit.
This commit is contained in:
301
lib/perl5/Selima/DBD/mysql.pm
Normal file
301
lib/perl5/Selima/DBD/mysql.pm
Normal file
@@ -0,0 +1,301 @@
|
||||
# Selima Website Content Management System
|
||||
# mysql.pm: The extended MySQL database driver.
|
||||
|
||||
# Copyright (c) 2004-2018 imacat.
|
||||
#
|
||||
# Licensed under the Apache License, Version 2.0 (the "License");
|
||||
# you may not use this file except in compliance with the License.
|
||||
# You may obtain a copy of the License at
|
||||
#
|
||||
# http://www.apache.org/licenses/LICENSE-2.0
|
||||
#
|
||||
# Unless required by applicable law or agreed to in writing, software
|
||||
# distributed under the License is distributed on an "AS IS" BASIS,
|
||||
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
# See the License for the specific language governing permissions and
|
||||
# limitations under the License.
|
||||
|
||||
# Author: imacat <imacat@mail.imacat.idv.tw>
|
||||
# First written: 2004-09-23
|
||||
|
||||
package Selima::DBD::mysql;
|
||||
use 5.008;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use MIME::Base64 qw(decode_base64);
|
||||
use Term::ReadKey qw(ReadMode);
|
||||
|
||||
use Selima::DataVars qw(:db :env :siteconf :scptconf);
|
||||
use Selima::DBILogin;
|
||||
use Selima::HTTP;
|
||||
|
||||
#use vars qw(%DBH $MYSQL_HOST $MYSQL_TCP_PORT $MYSQL_UNIX_PORT $MYSQL_DB $MYSQL_USER $MYSQL_PWD);
|
||||
use vars qw(%DBH);
|
||||
|
||||
# new: Connect and establish a new MySQL database source
|
||||
sub new : method {
|
||||
local ($_, %_);
|
||||
my ($class, $dbiclass, $dbh);
|
||||
$class = ref($_[0]) || $_[0];
|
||||
|
||||
# Login with from SQLLOGIN environment variable as a web application
|
||||
if ($IS_CGI) {
|
||||
my ($dsn, %r);
|
||||
# Prepare the connection information
|
||||
%r = get_dbi_login_info DBI_MYSQL;
|
||||
|
||||
# Compose the DSN
|
||||
@_ = qw();
|
||||
push @_, "host=" . $r{"MYSQL_HOST"} . ";" if defined $r{"MYSQL_HOST"};
|
||||
$dsn = "dbi:mysql:" . join "", @_;
|
||||
|
||||
# Return the available cached handle and clear the cache
|
||||
if (exists $DBH{$dsn} && $DBH{$dsn}->ping) {
|
||||
# Obtain the cached database handle
|
||||
$dbh = $DBH{$dsn};
|
||||
# Clear the cache to remove static reference to the database handle,
|
||||
# to avoid leaving dead handles that owns table locks
|
||||
delete $DBH{$dsn};
|
||||
|
||||
# New connection
|
||||
} else {
|
||||
$dbiclass = (caller)[0];
|
||||
|
||||
# Try to log in, handling the failure later
|
||||
%_ = ( "PrintError" => 0 );
|
||||
$dbh = $dbiclass->connect($dsn, $r{"MYSQL_USER"}, $r{"MYSQL_PWD"}, {%_});
|
||||
|
||||
# Login failed
|
||||
http_500 $dbiclass->errstr if !defined $dbh;
|
||||
|
||||
# Bless the object, name it as the current class
|
||||
$dbh = bless $dbh, $dbiclass . "::db";
|
||||
|
||||
# Set the client encoding to UTF-8
|
||||
$_ = "SET NAMES 'utf8';\n";
|
||||
$dbh->do($_);
|
||||
}
|
||||
|
||||
# Set the database
|
||||
$_ = "USE " . $r{"MYSQL_DB"} . ";\n";
|
||||
$dbh->do($_);
|
||||
|
||||
# Ask the password from the console
|
||||
} else {
|
||||
my ($dsn, $subseq, $user, $passwd);
|
||||
$dsn = "dbi:mysql:database=$PACKAGE;";
|
||||
$subseq = 0;
|
||||
# Try to log in
|
||||
while (!defined($dbh = DBI->connect($dsn, $user, $passwd, { PrintError => 0 }))) {
|
||||
$_ = DBI->errstr;
|
||||
if ($subseq) {
|
||||
print STDERR "$_\n";
|
||||
sleep 5;
|
||||
}
|
||||
$subseq = 1;
|
||||
# Obtain the current login user
|
||||
$user = $1 if !defined $user && / denied for user: '(.+?)\@.+?'/;
|
||||
# Disable console echo
|
||||
ReadMode 2;
|
||||
print STDERR defined $user? "MySQL password for $user: ":
|
||||
"MySQL password: ";
|
||||
$passwd = <STDIN>;
|
||||
print STDERR "\n";
|
||||
die "$THIS_FILE: Failed connecting to the MySQL server\n"
|
||||
if !defined $passwd;
|
||||
chomp $passwd;
|
||||
# Restore console echo status
|
||||
ReadMode 0;
|
||||
}
|
||||
}
|
||||
|
||||
return $dbh;
|
||||
}
|
||||
|
||||
# park_handle: Suspend the database handle for further use (mod_perl)
|
||||
sub park_handle : method { $DBH{"dbi:mysql:" . $_[1]->{"Name"}} = $_[1]; }
|
||||
|
||||
|
||||
# Selima::DBD::mysql::db: The database-handler driver class
|
||||
package Selima::DBD::mysql::db;
|
||||
|
||||
use 5.008;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Fcntl qw(:flock);
|
||||
|
||||
use Selima::GetLang;
|
||||
use Selima::HTTP;
|
||||
use Selima::DataVars qw(:db :lninfo);
|
||||
|
||||
# support: Return if a DBI feature is supported
|
||||
sub support : method {
|
||||
local ($_, %_);
|
||||
my ($self, $feature);
|
||||
($self, $feature) = @_;
|
||||
|
||||
# MySQL has VIEW since 5.0
|
||||
return 1 if $feature eq DBI_FEATHER_VIEW;
|
||||
|
||||
# Default to yes. We assume everyone is a good guy.
|
||||
return 1;
|
||||
}
|
||||
|
||||
# tables: Return the tables
|
||||
sub tables : method {
|
||||
local ($_, %_);
|
||||
my ($self, $sth, $cache, @tables);
|
||||
$self = $_[0];
|
||||
|
||||
# Initialize the cache
|
||||
$cache = $self->{"private_selima"};
|
||||
# Return the cache
|
||||
return @{${$cache}{"tables"}} if exists ${$cache}{"tables"};
|
||||
|
||||
# Get the tables list
|
||||
$sth = $self->table_info(undef, undef, "%", undef)
|
||||
or http_500 $self->errstr;
|
||||
@tables = qw();
|
||||
push @tables, $$_{"TABLE_NAME"}
|
||||
while defined($_ = $sth->fetchrow_hashref);
|
||||
|
||||
# Cache it
|
||||
${$cache}{"tables"} = [@tables];
|
||||
|
||||
return @tables;
|
||||
}
|
||||
|
||||
# cols: Return the columns of a table
|
||||
sub cols : method {
|
||||
local ($_, %_);
|
||||
my ($self, $table, $cache, $sth, @cols);
|
||||
($self, $table) = @_;
|
||||
|
||||
# Initialize the cache
|
||||
${$self->{"private_selima"}}{"cols"} = {}
|
||||
if !exists ${$self->{"private_selima"}}{"cols"};
|
||||
$cache = ${$self->{"private_selima"}}{"cols"};
|
||||
# Return the cache
|
||||
return @{${$cache}{$table}} if exists ${$cache}{$table};
|
||||
|
||||
# Get the columns list
|
||||
$sth = $self->column_info(undef, undef, $table, "%")
|
||||
or http_500 $self->errstr;
|
||||
@cols = qw();
|
||||
push @cols, $_ while defined($_ = $sth->fetchrow_hashref);
|
||||
@cols = map $$_{"COLUMN_NAME"},
|
||||
sort { ${$a}{"ORDINAL_POSITION"} <=> ${$b}{"ORDINAL_POSITION"} } @cols;
|
||||
|
||||
# Cache it
|
||||
${$cache}{$table} = [@cols];
|
||||
|
||||
return @cols;
|
||||
}
|
||||
|
||||
# col_lens: Obtain the column lengths of a table
|
||||
sub col_lens : method {
|
||||
local ($_, %_);
|
||||
my ($self, $table, $cache, $sth, $sql, $count, %lens, $lndb);
|
||||
($self, $table) = @_;
|
||||
|
||||
# Initialize the cache
|
||||
${$self->{"private_selima"}}{"col_lens"} = {}
|
||||
if !exists ${$self->{"private_selima"}}{"col_lens"};
|
||||
$cache = ${$self->{"private_selima"}}{"col_lens"};
|
||||
# Return the cache
|
||||
return %{${$cache}{$table}} if exists ${$cache}{$table};
|
||||
|
||||
# Use column_info here
|
||||
$sth = $self->column_info(undef, undef, $table, "%")
|
||||
or http_500 $self->errstr;
|
||||
%_ = qw();
|
||||
$_{$$_{"COLUMN_NAME"}} = $$_{"COLUMN_SIZE"}
|
||||
while defined($_ = $sth->fetchrow_hashref);
|
||||
|
||||
# Hash the multi-lingual columns
|
||||
$lndb = getlang(LN_DATABASE);
|
||||
$lens{$_} = $lens{$_ . "_$lndb"} foreach $self->cols_ml($table);
|
||||
|
||||
# Cache it
|
||||
${$cache}{"tables"} = {%_};
|
||||
|
||||
return %_;
|
||||
}
|
||||
|
||||
# quote_blob: Quote a piece of BLOB octet
|
||||
sub quote_blob : method {
|
||||
local ($_, %_);
|
||||
my ($self, $octet);
|
||||
($self, $octet) = @_;
|
||||
return $self->quote($octet);
|
||||
}
|
||||
|
||||
# strcat: Concatenate strings
|
||||
sub strcat : method {
|
||||
local ($_, %_);
|
||||
my ($self, @strings);
|
||||
($self, @strings) = @_;
|
||||
return "CONCAT(" . join(", ", @strings) . ")";
|
||||
}
|
||||
|
||||
# lastupd: Obtain the last updated time of a list of tables
|
||||
sub lastupd : method {
|
||||
local ($_, %_);
|
||||
my ($self, @tables, $sql, $sth);
|
||||
($self, @tables) = @_;
|
||||
# Bounce if no tables supplied
|
||||
return if scalar(@tables) == 0;
|
||||
# Remove duplicates
|
||||
%_ = map { $_ => 1 } @tables;
|
||||
@tables = keys %_;
|
||||
# Query
|
||||
$sql = "SELECT mtime FROM mtime"
|
||||
. " WHERE " . join(" OR ", map "tabname=" . $self->quote($_), @tables)
|
||||
. " ORDER BY mtime DESC LIMIT 1;\n";
|
||||
$sth = $self->prepare($sql);
|
||||
$sth->execute;
|
||||
# Bounce if no data found
|
||||
return if $sth->rows != 1;
|
||||
# Return the result
|
||||
return ${$sth->fetchrow_hashref}{"mtime"};
|
||||
}
|
||||
|
||||
# Selima::DBD::mysql::st: The statement-handler driver class
|
||||
package Selima::DBD::mysql::st;
|
||||
|
||||
use 5.008;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
# typecols: Return the list of columns in specific types
|
||||
sub typecols : method {
|
||||
local ($_, %_);
|
||||
my ($self, $types, %cols);
|
||||
$self = $_[0];
|
||||
$types = $self->{"mysql_type_name"};
|
||||
%cols = (
|
||||
"date" => [],
|
||||
"num" => [],
|
||||
"bigint" => [],
|
||||
"numeric" => [],
|
||||
"text" => [],
|
||||
);
|
||||
for ($_ = 0; $_ < @$types; $_++) {
|
||||
if ($$types[$_] =~ /^(?:date|datetime|timestamp)$/) {
|
||||
push @{$cols{"date"}}, $_;
|
||||
} elsif ($$types[$_] =~ /^(?:tinyint|smallint|middleint|integer|float|double)$/) {
|
||||
push @{$cols{"num"}}, $_;
|
||||
} elsif ($$types[$_] eq "bigint") {
|
||||
push @{$cols{"bigint"}}, $_;
|
||||
} elsif ($$types[$_] eq "decimal") {
|
||||
push @{$cols{"numeric"}}, $_;
|
||||
} elsif ($$types[$_] =~ /^(?:varchar|blob)$/) {
|
||||
push @{$cols{"text"}}, $_;
|
||||
}
|
||||
}
|
||||
return \%cols;
|
||||
}
|
||||
|
||||
return 1;
|
||||
Reference in New Issue
Block a user