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