Initial commit.
This commit is contained in:
440
lib/perl5/Selima/DBI.pm
Normal file
440
lib/perl5/Selima/DBI.pm
Normal file
@@ -0,0 +1,440 @@
|
||||
# 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;
|
||||
Reference in New Issue
Block a user