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