455 lines
14 KiB
Perl
455 lines
14 KiB
Perl
# Selima Website Content Management System
|
|
# Pg.pm: The extended PostgreSQL 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-08
|
|
|
|
package Selima::DBD::Pg;
|
|
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($DBHC $PGDATABASE $PGHOST $PGPORT $PGUSER $PGPASSWORD);
|
|
use vars qw($DBHC);
|
|
|
|
# new: Connect and establish a new PostgreSQL database source
|
|
sub new : method {
|
|
local ($_, %_);
|
|
my ($class, $dbiclass, $dbh);
|
|
$class = ref($_[0]) || $_[0];
|
|
$dbiclass = (caller)[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_POSTGRESQL;
|
|
|
|
# Return the available cached handle and clear the cache
|
|
if (defined $DBHC && $DBHC->{"Name"} eq $r{"PGDATABASE"} && $DBHC->ping) {
|
|
$dbh = $DBHC;
|
|
# Clear the cache to remove static reference to the database handle,
|
|
# to avoid leaving dead handles that owns table locks
|
|
undef $DBHC;
|
|
return $dbh;
|
|
}
|
|
# Clear the cache
|
|
undef $DBHC if defined $DBHC;
|
|
|
|
# Compose the DSN
|
|
@_ = qw();
|
|
push @_, "host=" . $r{"PGHOST"} . ";" if defined $r{"PGHOST"};
|
|
push @_, "dbname=" . $r{"PGDATABASE"} . ";" if defined $r{"PGDATABASE"};
|
|
$dsn = "dbi:Pg:" . join "", @_;
|
|
|
|
# Try to log in, handling the failure later
|
|
%_ = ( "PrintError" => 0 );
|
|
$dbh = $dbiclass->connect($dsn, $r{"PGUSER"}, $r{"PGPASSWORD"}, {%_});
|
|
|
|
# Login failed
|
|
http_500 $dbiclass->errstr if !defined $dbh;
|
|
|
|
# Ask the password from the console
|
|
} else {
|
|
my ($dsn, $subseq, $user, $passwd);
|
|
$dsn = "dbi:Pg:dbname=$PACKAGE;";
|
|
$subseq = 0;
|
|
# Try to log in
|
|
while (!defined($dbh = $dbiclass->connect($dsn, $user, $passwd, { PrintError => 0 }))) {
|
|
$_ = DBI->errstr;
|
|
if ($subseq) {
|
|
print STDERR $_;
|
|
sleep 5;
|
|
}
|
|
$subseq = 1;
|
|
# Obtain the current login user
|
|
$user = $1 if !defined $user && / failed for user "(.+?)"/;
|
|
# Disable console echo
|
|
ReadMode 2;
|
|
print STDERR defined $user? "PostgreSQL password for $user: ":
|
|
"PostgreSQL password: ";
|
|
$passwd = <STDIN>;
|
|
print STDERR "\n";
|
|
die "$THIS_FILE: Failed connecting to the PostgreSQL server\n"
|
|
if !defined $passwd;
|
|
chomp $passwd;
|
|
# Restore console echo status
|
|
ReadMode 0;
|
|
}
|
|
}
|
|
|
|
# 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($_);
|
|
|
|
return $dbh;
|
|
}
|
|
|
|
# park_handle: Suspend the database handle for further use (mod_perl)
|
|
sub park_handle : method { $DBHC = $_[1]; }
|
|
|
|
|
|
# Selima::DBD::Pg::db: The database-handler driver class
|
|
package Selima::DBD::Pg::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) = @_;
|
|
|
|
# PostgreSQL has VIEWs.
|
|
return 1 if $feature eq DBI_FEATHER_VIEW;
|
|
|
|
# Default to yes. We assume everyone is a good guy.
|
|
return 1;
|
|
}
|
|
|
|
# lock: PostgreSQL table-locking handler
|
|
# PostgreSQL has no unlock
|
|
# Input:
|
|
# %locks: A hash table, where its keys are the tables to lock,
|
|
# and its values can be one of the following:
|
|
# LOCK_SH: Request a read lock
|
|
# LOCK_EX: Request a write lock
|
|
# LOCK_UN: No effect
|
|
# Return: None. Errors are directed to error handlers
|
|
sub lock : method {
|
|
local ($_, %_);
|
|
my ($self, %locks, @reads, @writes, $sth);
|
|
($self, %locks) = @_;
|
|
|
|
# Bounce for nothing
|
|
return if scalar(keys %locks) == 0;
|
|
|
|
# Remove the table aliases -- compatibility with stupid MySQL
|
|
%_ = qw();
|
|
foreach my $table (keys %locks) {
|
|
# Remove the table aliases
|
|
$_ = $table;
|
|
s/\s+AS\s+.+?$//i;
|
|
# No override previous write lock
|
|
next if exists $_{$_} && $_{$_} == LOCK_EX;
|
|
# Set the lock
|
|
$_{$_} = $locks{$table};
|
|
}
|
|
%locks = %_;
|
|
|
|
# Split into different lock modes
|
|
@reads = qw();
|
|
@writes = qw();
|
|
foreach (keys %locks) {
|
|
if ($locks{$_} == LOCK_SH) {
|
|
push @reads, $_;
|
|
} elsif ($locks{$_} == LOCK_EX) {
|
|
push @writes, $_;
|
|
} else {
|
|
http_500 "Bad SQL lock request: \"" . $locks{$_} . "\""
|
|
. " on table \"$_\".";
|
|
}
|
|
}
|
|
|
|
# Start the transaction
|
|
$self->begin_work if $self->{"AutoCommit"};
|
|
|
|
# Request the locks
|
|
if (@reads > 0) {
|
|
$_ = "LOCK TABLE " . join(", ", @reads)
|
|
. " IN SHARE MODE;\n";
|
|
$self->do($_);
|
|
}
|
|
if (@writes > 0) {
|
|
$_ = "LOCK TABLE " . join(", ", @writes)
|
|
. " IN ACCESS EXCLUSIVE MODE;\n";
|
|
$self->do($_);
|
|
}
|
|
|
|
return;
|
|
}
|
|
|
|
# tables: Return the tables and views
|
|
sub tables : method {
|
|
local ($_, %_);
|
|
my ($self, $schema, $cache, $sth, @tables);
|
|
($self, $schema) = @_;
|
|
|
|
# Default schema
|
|
$schema = $self->current_schema if !defined $schema;
|
|
|
|
# Initialize the cache
|
|
${$self->{"private_selima"}}{"tables"} = {}
|
|
if !exists ${$self->{"private_selima"}}{"tables"};
|
|
$cache = ${$self->{"private_selima"}}{"tables"};
|
|
# Return the cache
|
|
return @{${$cache}{$schema}} if exists ${$cache}{$schema};
|
|
|
|
# Get the tables list
|
|
$sth = $self->table_info(undef, $schema, "%", "%")
|
|
or http_500 $self->errstr;
|
|
@tables = qw();
|
|
push @tables, ${$_}{"TABLE_NAME"}
|
|
while defined($_ = $sth->fetchrow_hashref);
|
|
|
|
# Cache it
|
|
${$cache}{$schema} = [@tables];
|
|
|
|
return @tables;
|
|
}
|
|
|
|
# cols: Return the columns of a table (or view)
|
|
sub cols : method {
|
|
local ($_, %_);
|
|
my ($self, $table, $schema, $cache, $sth, @cols);
|
|
($self, $table, $schema) = @_;
|
|
|
|
# Default schema
|
|
$schema = $self->current_schema if !defined $schema;
|
|
|
|
# Initialize the cache
|
|
${$self->{"private_selima"}}{"cols"} = {}
|
|
if !exists ${$self->{"private_selima"}}{"cols"};
|
|
${${$self->{"private_selima"}}{"cols"}}{$schema} = {}
|
|
if !exists ${${$self->{"private_selima"}}{"cols"}}{$schema};
|
|
$cache = ${${$self->{"private_selima"}}{"cols"}}{$schema};
|
|
# Return the cache
|
|
return @{${$cache}{$table}} if exists ${$cache}{$table};
|
|
|
|
# Get the columns list
|
|
$sth = $self->column_info(undef, $schema, $table, "%")
|
|
or http_500 $self->errstr;
|
|
@cols = qw();
|
|
push @cols, ${$_}{"COLUMN_NAME"}
|
|
while defined($_ = $sth->fetchrow_hashref);
|
|
s/^"(.+)"/$1/ foreach @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, $schema, $cache, $sth, $sql, $count, %lens, $lndb);
|
|
($self, $table, $schema) = @_;
|
|
|
|
# Default schema
|
|
$schema = $self->current_schema if !defined $schema;
|
|
|
|
# Initialize the cache
|
|
${$self->{"private_selima"}}{"col_lens"} = {}
|
|
if !exists ${$self->{"private_selima"}}{"col_lens"};
|
|
${${$self->{"private_selima"}}{"col_lens"}}{$schema} = {}
|
|
if !exists ${${$self->{"private_selima"}}{"col_lens"}}{$schema};
|
|
$cache = ${${$self->{"private_selima"}}{"col_lens"}}{$schema};
|
|
# Return the cache
|
|
return %{${$cache}{$table}} if exists ${$cache}{$table};
|
|
|
|
# Query
|
|
$sql = "SELECT pg_attribute.attname AS col,"
|
|
. " pg_type.typname AS type,"
|
|
. " pg_attribute.attlen AS len,"
|
|
. " pg_attribute.atttypmod AS typmod"
|
|
. " FROM pg_attribute"
|
|
. " INNER JOIN pg_class ON pg_attribute.attrelid=pg_class.oid"
|
|
. " INNER JOIN pg_type ON pg_attribute.atttypid=pg_type.oid"
|
|
. " INNER JOIN pg_namespace ON pg_class.relnamespace=pg_namespace.oid"
|
|
. " WHERE pg_namespace.nspname=" . $self->quote($schema)
|
|
. " AND pg_class.relname=" . $self->quote($table)
|
|
. " AND pg_class.relkind='r'"
|
|
. " AND pg_attribute.attnum>0"
|
|
. " ORDER BY pg_attribute.attnum;\n";
|
|
$sth = $self->prepare($sql);
|
|
$sth->execute;
|
|
$count = $sth->rows;
|
|
for (my $i = 0, %lens = qw(); $i < $count; $i++) {
|
|
%_ = %{$sth->fetchrow_hashref};
|
|
# Integer -- Digits of the largest number - 1
|
|
if ($_{"type"} =~ /^int[248]$/) {
|
|
$lens{$_{"col"}} = int(log(256**$_{"len"})/log 10);
|
|
# Refer to typmod for char and varchar
|
|
} elsif ($_{"type"} =~ /^(?:var|bp)char$/) {
|
|
$lens{$_{"col"}} = $_{"typmod"} - 4;
|
|
# Set text and bytea to 4294967296 (2^32) (infinite actually)
|
|
} elsif ($_{"type"} =~ /^(?:text|bytea)$/) {
|
|
$lens{$_{"col"}} = 4294967296;
|
|
# Set timestamp to 19
|
|
} elsif ($_{"type"} eq "timestamp" || $_{"type"} eq "timestamptz") {
|
|
$lens{$_{"col"}} = 19;
|
|
# Set date to 10
|
|
} elsif ($_{"type"} eq "date") {
|
|
$lens{$_{"col"}} = 10;
|
|
# Set time to 8
|
|
} elsif ($_{"type"} eq "time") {
|
|
$lens{$_{"col"}} = 8;
|
|
# Set numeric to precision + 1 decimal point
|
|
# Refer to http://archives.postgresql.org/pgsql-hackers/1999-01/msg00127.php
|
|
} elsif ($_{"type"} eq "numeric") {
|
|
my ($typmod, $scale, $precision);
|
|
$typmod = $_{"typmod"} - 4;
|
|
$scale = $typmod & 0xFFFF;
|
|
$precision = $typmod >> 16;
|
|
$lens{$_{"col"}} = $precision + 1;
|
|
# Set boolean to 1
|
|
} elsif ($_{"type"} eq "bool") {
|
|
$lens{$_{"col"}} = 1;
|
|
# Set inet to 18 (nnn.nnn.nnn.nnn/nn)
|
|
} elsif ($_{"type"} eq "inet") {
|
|
$lens{$_{"col"}} = 18;
|
|
# Bounce for unknown columns
|
|
} else {
|
|
http_500 "Unknown column type " . $_{"type"}
|
|
. " for table $table.\n";
|
|
}
|
|
}
|
|
|
|
# Hash the multi-lingual columns
|
|
$lndb = getlang(LN_DATABASE);
|
|
$lens{$_} = $lens{$_ . "_$lndb"} foreach $self->cols_ml($table);
|
|
|
|
# Cache it
|
|
${$cache}{$table} = {%lens};
|
|
|
|
return %lens;
|
|
}
|
|
|
|
# quote_blob: Quote a piece of BLOB octet
|
|
sub quote_blob : method {
|
|
local ($_, %_);
|
|
my ($self, $octet, $sth, $sql);
|
|
($self, $octet) = @_;
|
|
$sql = "SELECT ?;\n";
|
|
$sth = $self->prepare($sql);
|
|
$sth->bind_param(1, $octet, { pg_type => DBD::Pg::PG_BYTEA() })
|
|
or http_500 $sql . $sth->errstr;
|
|
$sth->execute;
|
|
return "'" . ${$sth->fetch}[0] . "'";
|
|
}
|
|
|
|
# strcat: Concatenate strings
|
|
sub strcat : method {
|
|
local ($_, %_);
|
|
my ($self, @strings);
|
|
($self, @strings) = @_;
|
|
return 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 table aliases
|
|
s/^(\S+) AS \S+$/$1/ foreach @tables;
|
|
# 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"};
|
|
}
|
|
|
|
# current_schema: Obtain the current schema
|
|
sub current_schema : method {
|
|
local ($_, %_);
|
|
my ($self, $sth, $sql);
|
|
$self = $_[0];
|
|
|
|
# Return the cache
|
|
return ${$self->{"private_selima"}}{"current_schema"}
|
|
if exists ${$self->{"private_selima"}}{"current_schema"};
|
|
|
|
$sql = "SELECT current_schema();\n";
|
|
$sth = $self->prepare($sql);
|
|
$sth->execute;
|
|
$_ = ${$sth->fetch}[0];
|
|
|
|
# Cache it
|
|
${$self->{"private_selima"}}{"current_schema"} = $_;
|
|
|
|
return $_;
|
|
}
|
|
|
|
|
|
# Selima::DBD::Pg::st: The statement-handler driver class
|
|
package Selima::DBD::Pg::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->{"pg_type"};
|
|
%cols = (
|
|
"date" => [],
|
|
"num" => [],
|
|
"bigint" => [],
|
|
"numeric" => [],
|
|
"text" => [],
|
|
);
|
|
for ($_ = 0; $_ < @$types; $_++) {
|
|
if ($$types[$_] =~ /^(?:date|timestamp)$/) {
|
|
push @{$cols{"date"}}, $_;
|
|
} elsif ($$types[$_] =~ /^(?:int2|int4|float4|float8)$/) {
|
|
push @{$cols{"num"}}, $_;
|
|
} elsif ($$types[$_] eq "int8") {
|
|
push @{$cols{"bigint"}}, $_;
|
|
} elsif ($$types[$_] eq "numeric") {
|
|
push @{$cols{"numeric"}}, $_;
|
|
} elsif ($$types[$_] =~ /^(?:varchar|text)$/) {
|
|
push @{$cols{"text"}}, $_;
|
|
}
|
|
}
|
|
return \%cols;
|
|
}
|
|
|
|
return 1;
|