selima-perl/lib/perl5/Selima/DBI.pm

# Selima Website Content Management System
# DBI.pm: The extended DBI (database interface).

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

package Selima::DBI;
use 5.008;
use strict;
use warnings;
use base qw(DBI);

use Selima::DataVars qw(:db);

# new: Connect and establish a new database source
sub new : method {
    local ($_, %_);
    my ($type, $dbh, $class, $methods);
    $type = $_[1];
    
    # PostgreSQL
    if ($type eq DBI_POSTGRESQL) {
        require Selima::DBD::Pg;
        $dbh = Selima::DBD::Pg->new;
    # MySQL
    } elsif ($type eq DBI_MYSQL) {
        require Selima::DBD::mysql;
        $dbh = Selima::DBD::mysql->new;
    }
    
    # Keep the imported methods for cached DBH (mod_perl)
    undef $methods;
    $methods = ${$dbh->{"private_selima"}}{"methods"}
        if  exists $dbh->{"private_selima"}
            && exists ${$dbh->{"private_selima"}}{"methods"};
    # Initialize the private attributes
    $dbh->{"private_selima"} = {};
    # Import the methods
    if (defined $methods) {
        ${$dbh->{"private_selima"}}{"methods"} = $methods ;
    } else {
        $dbh->import_methods;
    }
    
    return $dbh;
}


# Selima::DBI::db: The database-handler class
package Selima::DBI::db;

use 5.008;
use strict;
use warnings;
use base qw(DBI::db);
use vars qw($METHODS_DEFINED @IMPORT_METHODS);
$METHODS_DEFINED = 0;
@IMPORT_METHODS = qw(support lock tables cols col_lens quote_blob
    strcat lastupd current_schema);

use Encode qw(encode);

use Selima::DataVars qw(:env :lninfo);
use Selima::HTTP;
use Selima::GetLang;
use Selima::Guest;

# import_methods: Import our own methods
sub import_methods : method {
    local ($_, %_);
    my ($self, $methods, $class, $driver);
    $self = $_[0];
    
    # Initialize the methods pool and the class and driver name
    ${$self->{"private_selima"}}{"methods"} = {};
    $class = ref($self);
    $driver = $class;
    $driver =~ s/::DBI::db$//;
    $driver .= "::DBD::" . $self->{"Driver"}->{"Name"} . "::db";
    
    # Define the methods once
    if (!$METHODS_DEFINED) {
        # Short-cut to the methods pool
        $methods = "\${\$_[0]->{\"private_selima\"}}{\"methods\"}";
        foreach (@IMPORT_METHODS) {
            eval << "EOT";
*$_ = sub { return \&{\${$methods}{"$_"}}(\@_); }
EOT
        }
        $METHODS_DEFINED = 1;
    }
    
    # Short-cut to the methods pool
    $methods = ${$self->{"private_selima"}}{"methods"};
    # Import each method
    foreach my $func (@IMPORT_METHODS) {
        if (defined($_ = $driver->can($func))) {
            ${$methods}{$func} = $_;
        } elsif (defined($_ = $class->can("SUPER::$func"))) {
            ${$methods}{$func} = $_;
        } else {
            ${$methods}{$func} = sub {};
        }
    }
    return;
}

# do: run SUPER::do() and handle errors
sub do : method {
    local ($_, %_);
    my ($self, $sql, $rv);
    ($self, $sql, @_) = @_;
    # $sql should always be a decoded text
    $sql = encode("UTF-8", $sql);
    # Run and handle errors
    $rv = $self->SUPER::do($sql, @_)
        or http_500 $sql . $self->errstr;
    # Update the mtime
    if ($sql =~ /^(?:INSERT\s+INTO|UPDATE|DELETE\s+FROM)\s+(\S+)/i) {
        my ($table, $sql, $sth);
        $table = $1;
        $table =~ s/^"(.+?)"$/$1/;
        $table = $self->quote($table);
        $sql = "SELECT * FROM mtime WHERE tabname=$table;\n";
        $sth = $self->prepare($sql);
        $sth->execute;
        # Found
        if ($sth->rows == 1) {
            # Update the mtime
            $sql = "UPDATE mtime SET mtime=now() WHERE tabname=$table;\n";
            $self->SUPER::do($sql);
        # Not found
        } else {
            # Set the mtime
            $sql = "INSERT INTO mtime (tabname, mtime) VALUES ($table, now());\n";
            $self->SUPER::do($sql);
        }
    }
    return $rv;
}

# gdo: only run do() when user is not a guest
sub gdo : method {
    local ($_, %_);
    my $self;
    ($self, @_) = @_;
    # Skip for guests
    return 1 if is_guest;
    return $self->do(@_);
}

# prepare: run SUPER::prepare, handle errors and import our extension methods
sub prepare : method {
    local ($_, %_);
    my ($self, $sql, $sth);
    ($self, $sql, @_) = @_;
    # Run and handle errors
    $sth = $self->SUPER::prepare($sql, @_)
        or http_500 $sql . $self->errstr;
    # Import our extension methods
    $sth->{"private_selima"} = {};
    $sth->import_methods;
    return $sth;
}

# begin_work, commit, rollback do not need to handle their errors.
# errors can be silently ignored.  See DBI(3) for more details.

#
# Methods below are driver-indepedent.  Override is not required.
#
# cols_ml: Return the multi-lingual columns list of a table (or view)
sub cols_ml : method {
    local ($_, %_);
    my ($self, $table, $sth, @cols, @cols_ml, $suf);
    ($self, $table) = @_;
    
    $self->{"private_cols_ml"} = {}
        if !exists $self->{"private_cols_ml"};
    # Return the cache
    return @{${$self->{"private_cols_ml"}}{$table}}
        if exists ${$self->{"private_cols_ml"}}{$table};
    
    @cols = $self->cols($table);
    @cols_ml = qw();
    $suf = "_" . getlang LN_DATABASE;
    foreach (@cols) {
        push @cols_ml, $_ if $_ =~ s/$suf$//;
    }
    
    # Cache it
    ${$self->{"private_cols_ml"}}{$table} = [@cols_ml];
    
    return @cols_ml;
}

# is_ml_table: Check if a table is multi-lingual
sub is_ml_table : method {
    local ($_, %_);
    my ($self, $table);
    ($self, $table) = @_;
    return scalar($self->cols_ml($table)) > 0;
}

# esclike: Escape a phrase by the LIKE matching rule
#   Double quote should never be used, according to
#   the column name rules in the SQL standard.
sub esclike : method {
    local ($_, %_);
    my $self;
    ($self, $_) = @_;
    s/\\/\\\\\\\\/g;
    s/%/\\\\%/g;
    s/_/\\\\_/g;
    # By the SQL standard
    s/'/''/g;           # ' gettext
    # Non-standard, but this also works for most SQL DBMS
    #s/'/\\\\\\'/g;
    return $_;
}

# disconnect: Disconnect from the database server
sub disconnect : method {
    local ($_, %_);
    my ($self, $class);
    $self = $_[0];
    $class = ref($self);
    $class =~ s/::DBI::db$//;
    $class .= "::DBD::" . $self->{"Driver"}->{"Name"};
    
    # Rollback the changes that are not committed and unlock the tables
    $self->rollback if !$self->{"AutoCommit"};
    
    # mod_perl: Suspend the database handle for further use, but not
    #   really disconnect it.
    # Disabled.  Save system from server load too high.
    #if ($IS_MODPERL) {
    #    return $class->park_handle($self);
    #} else {
        $_ = $self->SUPER::disconnect       or http_500 $self->errstr;
        return $_;
    #}
}


# Selima::DBI::st: The statement-handler class
package Selima::DBI::st;

use 5.008;
use strict;
use warnings;
use base qw(DBI::st);
use vars qw($METHODS_DEFINED @IMPORT_METHODS);
$METHODS_DEFINED = 0;
@IMPORT_METHODS = qw(typecols);

use DBI qw(:sql_types);
use Encode qw(decode_utf8 FB_CROAK is_utf8);
use Date::Parse qw(str2time);

use Selima::HTTP;

# import_methods: Import our own methods
sub import_methods : method {
    local ($_, %_);
    my ($self, $methods, $class, $driver);
    $self = $_[0];
    
    # Initialize the methods pool and the class and driver name
    ${$self->{"private_selima"}}{"methods"} = {};
    $class = ref($self);
    $driver = $class;
    $driver =~ s/::DBI::st$//;
    $driver .= "::DBD::" . $self->{"Database"}->{"Driver"}->{"Name"} . "::st";
    
    # Define the methods once
    if (!$METHODS_DEFINED) {
        # Short-cut to the methods pool
        $methods = "\${\$_[0]->{\"private_selima\"}}{\"methods\"}";
        foreach (@IMPORT_METHODS) {
            eval << "EOT";
*$_ = sub { return \&{\${$methods}{"$_"}}(\@_); }
EOT
        }
        $METHODS_DEFINED = 1;
    }
    
    # Short-cut to the methods pool
    $methods = ${$self->{"private_selima"}}{"methods"};
    # Import each method
    foreach my $func (@IMPORT_METHODS) {
        if (defined($_ = $driver->can($func))) {
            ${$methods}{$func} = $_;
        } elsif (defined($_ = $class->can("SUPER::$func"))) {
            ${$methods}{$func} = $_;
        } else {
            ${$methods}{$func} = sub {};
        }
    }
    return;
}

# execute: run SUPER::execute and handle errors
sub execute : method {
    local ($_, %_);
    my $self;
    ($self, @_) = @_;
    # Run and handle errors
    $_ = $self->SUPER::execute(@_)
        or http_500 $self->{"Statement"} . $self->errstr;
    return $_;
}

# fetch: fetch and decode from UTF-8
# DBI::st returns a same array reference each time, with
#   only the values changed.  Then, after the first fetch,
#   the values returned are all tagged as "wide characters"
#   (decoded) and cannot be decode()ed again.  To avoid this
#   problem, we make a different copy of the returned values
#   and decode that copy, instead of decoding those in the
#   original array reference returned.
sub fetch : method {
    local ($_, %_);
    my ($self, @args, $row, $types);
    ($self, @args) = @_;
    # Fetch the row first
    $row = $self->SUPER::fetch(@args);
    # No record found or some error occurs
    return undef if !defined $row;
    
    # Not called from within fetchrow_hashref()
    if (exists $self->{"TYPE"}) {
        # Make a copy of the record
        $row = [@$row];
        # Obtain the type classes
        ${$self->{"private_selima"}}{"types"} = $self->typecols
            if !exists ${$self->{"private_selima"}}{"types"};
        $types = ${$self->{"private_selima"}}{"types"};
        # Convert the date/datetime columns
        foreach (@{$$types{"date"}}) {
            $$row[$_] = str2time $$row[$_]
                if defined $$row[$_];
        }
        # Convert the numeric columns
        foreach (@{$$types{"num"}}) {
            $$row[$_] = $$row[$_] + 0
                if defined $$row[$_];
        }
        # Decode the text columns
        foreach (@{$$types{"text"}}) {
            $$row[$_] = decode_utf8($$row[$_], FB_CROAK)
                if defined $$row[$_] && !is_utf8($$row[$_]);
        }
    }
    return $row;
}

# fetchrow_hashref: fetch and read some fields
sub fetchrow_hashref : method {
    local ($_, %_);
    my ($self, @args, $row, $types);
    ($self, @args) = @_;
    # Fetch the row first
    $row = $self->SUPER::fetchrow_hashref(@args);
    # No record found or some error occurs
    return undef if !defined $row;
    
    # Make a copy of the record
    $row = {%$row};
    # Obtain the type classes
    ${$self->{"private_selima"}}{"types"} = $self->typecols
        if !exists ${$self->{"private_selima"}}{"types"};
    $types = ${$self->{"private_selima"}}{"types"};
    # Convert the date/datetime columns
    foreach (@{$$types{"date"}}) {
        $$row{${$self->{"NAME"}}[$_]} = str2time $$row{${$self->{"NAME"}}[$_]}
            if defined $$row{${$self->{"NAME"}}[$_]};
    }
    # Convert the numeric columns
    foreach (@{$$types{"num"}}) {
        $$row{${$self->{"NAME"}}[$_]} = $$row{${$self->{"NAME"}}[$_]} + 0
            if defined $$row{${$self->{"NAME"}}[$_]};
    }
    # Decode the text columns
    foreach (@{$$types{"text"}}) {
        $$row{${$self->{"NAME"}}[$_]} = decode_utf8($$row{${$self->{"NAME"}}[$_]}, FB_CROAK)
            if defined $$row{${$self->{"NAME"}}[$_]} && !is_utf8($$row{${$self->{"NAME"}}[$_]});
    }
    return $row;
}

# fetchrow_arrayref: fetch and read some fields
sub fetchrow_arrayref : method {
    local ($_, %_);
    my ($self, @args, $row, $types);
    ($self, @args) = @_;
    # Fetch the row first
    $row = $self->SUPER::fetchrow_arrayref(@args);
    # No record found or some error occurs
    return undef if !defined $row;
    
    # Make a copy of the record
    $row = [@$row];
    # Obtain the type classes
    ${$self->{"private_selima"}}{"types"} = $self->typecols
        if !exists ${$self->{"private_selima"}}{"types"};
    $types = ${$self->{"private_selima"}}{"types"};
    # Convert the date/datetime columns
    foreach (@{$$types{"date"}}) {
        $$row[$_] = str2time $$row[$_]
            if defined $$row[$_];
    }
    # Convert the numeric columns
    foreach (@{$$types{"num"}}) {
        $$row[$_] = $$row[$_] + 0
            if defined $$row[$_];
    }
    # Decode the text columns
    foreach (@{$$types{"text"}}) {
        $$row[$_] = decode_utf8($$row[$_], FB_CROAK)
            if defined $$row[$_];
    }
    return $row;
}

return 1;