selima-perl/lib/perl5/Selima/DBD/mysql.pm

# 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;