eekboek-db-postgresql 2.02.04-1 / usr / share / perl5 / EB / DB / Postgres.pm

#! perl

# Postgres.pm -- EekBoek driver for PostgreSQL database
# Author          : Johan Vromans
# Created On      : Tue Jan 24 10:43:00 2006
# Last Modified By: Johan Vromans
# Last Modified On: Tue Sep 18 13:42:09 2012
# Update Count    : 194
# Status          : Unknown, Use with caution!

package main;

our $cfg;

package EB::DB::Postgres;

use strict;
use warnings;

use EB;
use DBI;
use DBD::Pg;

my $dbh;			# singleton
my $dataset;

my $trace = $cfg->val(__PACKAGE__, "trace", 0) if $cfg;

# API: type  type of driver
sub type { "PostgreSQL" }

sub _dsn {
    my $dsn = "dbi:Pg:dbname=" . shift;
    my $t;
    $dsn .= ";host=" . $t if $t = $cfg->val(qw(database host), undef);
    $dsn .= ";port=" . $t if $t = $cfg->val(qw(database port), undef);
    wantarray
      ? ( $dsn,
	  $cfg->val("database", "user", undef),
	  $cfg->val("database", "password", undef))
      : $dsn;
}

# API: create a new database, reuse an existing one if possible.
sub create {
    my ($self, $dbname) = @_;

    if ( $dbh && !$dbname ) {	# use current DB.
	$dbh->{RaiseError} = 0;
	$dbh->{PrintError} = 0;
	$dbh->{AutoCommit} = 1;
	$self->clear;
	$dbh->{RaiseError} = 1;
	$dbh->{PrintError} = 1;
#	$dbh->{AutoCommit} = 0;
	return;
    }

    croak("?INTERNAL ERROR: create db while connected") if $dbh;
    eval {
	{
	    local($SIG{__WARN__}) = sub {};
	    $self->connect($dbname);
	}
	$dbh->{RaiseError} = 0;
	$dbh->{PrintError} = 0;
	$dbh->{AutoCommit} = 1;
	$self->clear;
	$self->disconnect;
    };
    return unless $@;
    die($@) if $@ =~ /UNICODE/;

    $dbname =~ s/^(?!=eekboek_)/eekboek_/;

    # Normally, sql treats names as lowcased. By using " " we can
    # maintain the case of the database name.
    my $sql = "CREATE DATABASE \"$dbname\"";
    $sql .= " ENCODING 'UNICODE'";
    for ( $cfg->val("database", "user", undef) ) {
	next unless $_;
	$sql .= " OWNER $_";
    }
    my $dbh = DBI->connect(_dsn("template1"));
    my $errstr = $DBI::errstr;
    if ( $dbh ) {
	warn("+ $sql\n") if $trace;
	$dbh->do($sql);
	$errstr = $DBI::errstr;
	$dbh->disconnect;
	return unless $errstr;
    }
    die("?".__x("Database probleem: {err}",
		err => $errstr)."\n");
}

# API: connect to an existing database.
sub connect {
    my ($self, $dbname) = @_;
    croak("?INTERNAL ERROR: connect db without dataset name") unless $dbname;

    if ( $dataset && $dbh && $dbname eq $dataset ) {
	return $dbh;
    }

    $self->disconnect;

    $dbname = "eekboek_".$dbname unless $dbname =~ /^eekboek_/;
    $cfg->newval(qw(database fullname), $dbname);
    $dbh = DBI::->connect(_dsn($dbname))
      or die("?".__x("Database verbindingsprobleem: {err}",
		     err => $DBI::errstr)."\n");
    $dataset = $dbname;
    my $enc = $dbh->selectall_arrayref("SHOW CLIENT_ENCODING")->[0]->[0];
    if ( $enc !~ /^unicode|utf8$/i ) {
	warn("!".__x("Database {name} is niet in UTF-8 maar {enc}",
		     name => $_[1], enc => $enc)."\n");
    }
    $dbh->do("SET CLIENT_ENCODING TO 'UNICODE'");
    $dbh->{pg_enable_utf8} = 1;
    return $dbh;
}

# API: Disconnect from a database.
sub disconnect {
    my ($self) = @_;
    return unless $dbh;
    $dbh->disconnect;
    undef $dbh;
    undef $dataset;
}

# API: Setup whatever is needed.
sub setup {
}

sub clear {
    my ($self) = @_;
    croak("?INTERNAL ERROR: clear db while not connected") unless $dbh;

    for my $tbl ( qw(Boekstukregels Journal Boekjaarbalans
		     Metadata Standaardrekeningen Relaties
		     Boekstukken Dagboeken Boekjaren Constants
		     Accounts Btwtabel Verdichtingen Taccounts) ) {
	warn("+ DROP TABLE $tbl\n") if $trace;
	eval { $dbh->do("DROP TABLE $tbl") };
    }

    eval {
	my $rr = $dbh->selectall_arrayref("SELECT relname".
					  " FROM pg_class".
					  " WHERE relkind = 'S'".
					  ' AND relname LIKE \'%bsk_%_seq\'');
	foreach my $seq ( @$rr ) {
	    warn("+ DROP SEQUENCE $seq->[0]\n") if $trace;
	    eval { $dbh->do("DROP SEQUENCE $seq->[0]") };
	}
    };
    $dbh->commit unless $dbh->{AutoCommit};

}

# API: Test db connection.
sub test {
    my $self = shift;
    my $db = shift;
    $db = $db ? "eekboek_$db" : "template1";
    my $opts = shift || {};
    my $d;
    my $dsn = "dbi:Pg:dbname=$db";
    my $t;
    $dsn .= ";host=" . $t if $t = $opts->{host};
    $dsn .= ";port=" . $t if $t = $opts->{port};
    eval {
	$d = DBI->connect( $dsn,
			   $opts->{user} || undef,
			   $opts->{password} || undef,
			 );
    };
    return $@ if $@;
    return DBI->errstr unless $d;
    $d->{RaiseError} = 1;

    unless ( $db eq "template1" ) {
	# Check if we really can access the db.
	eval {
	    $d->do("SELECT * FROM Metadata");
	};
	return $@ if $@;
	return DBI->errstr unless $d;
    }

    eval {
	$d->disconnect;
    };
    return;
}

# API: List available data sources.
sub list {
    my @ds;

    my $t;
    local $ENV{PGHOST}   = $t if $t = $cfg->val(qw(database host), undef);
    local $ENV{PGPORT}   = $t if $t = $cfg->val(qw(database port), undef);
    local $ENV{DBI_USER} = $t if $t = $cfg->val("database", "user", undef);
    local $ENV{DBI_PASS} = $t if $t = $cfg->val("database", "password", undef);
    eval {
	@ds = DBI->data_sources("Pg");
    };
    # If the list cannot be established, @ds will be (undef).
    return [] unless defined($ds[0]);
    my $d = [];
    foreach ( @ds ) {
	next unless s/^.*?dbname=eekboek_(.+)//;
	push( @$d, $1 );
    }
    return $d;
}

# API: Get a array ref with table names (lowcased).
sub get_tables {
    my $self = shift;
    my @t;
    foreach ( $dbh->tables ) {
	next unless /^public\.(.+)/i;
	push(@t, lc($1));
    }
    \@t;
}

################ Sequences ################

# API: Get the next value for a sequence, incrementing it.
sub get_sequence {
    my ($self, $seq) = @_;
    croak("?INTERNAL ERROR: get sequence while not connected") unless $dbh;

    my $rr = $dbh->selectall_arrayref("SELECT nextval('$seq')");
    return ($rr && defined($rr->[0]) && defined($rr->[0]->[0])? $rr->[0]->[0] : undef);
}

# API: Set the next value for a sequence.
sub set_sequence {
    my ($self, $seq, $value) = @_;
    croak("?INTERNAL ERROR: set sequence while not connected") unless $dbh;

    # Init a sequence to value.
    # The next call to get_sequence will return this value.
    $dbh->do("SELECT setval('$seq', $value, false)");
    $value;
}

################ Interactive SQL ################

# API: Interactive SQL.
sub isql {
    my ($self, @args) = @_;

    my $dbname = $cfg->val(qw(database fullname));
    my $cmd = "psql";
    my @cmd = ( $cmd );

    for ( $cfg->val("database", "user", undef) ) {
	next unless $_;
	push(@cmd, "-U", $_);
    }
    for ( $cfg->val("database", "host", undef) ) {
	next unless $_;
	push(@cmd, "-h", $_);
    }
    for ( $cfg->val("database", "port", undef) ) {
	next unless $_;
	push(@cmd, "-p", $_);
    }
    push(@cmd, "-d", $dbname);

    if ( @args ) {
	push(@cmd, "-c", "@args");
    }

    my $res = system { $cmd } @cmd;
    # warn(sprintf("=> ret = %02x", $res)."\n") if $res;

}

################ PostgreSQL Compatibility ################

# API: feature  Can we?
sub feature {
    my $self = shift;
    my $feat = lc(shift);

    # Known features:
    #
    # pgcopy	F PostgreSQL fast input copying
    # prepcache T Statement handles may be cached
    # filter    C SQL filter routine
    #
    # Unknown/unsupported features may be ignored.

    if ( $feat eq "pgcopy" ) {
	return 1 if ($DBD::Pg::VERSION||"0") ge "1.41";
	warn("%"."Not using PostgreSQL fast load. DBD::Pg::VERSION = ",
	     ($DBD::Pg::VERSION||"0"), ", needs 1.41 or later\n");
	return;
    }

    return 1 if $feat eq "prepcache";

    return 1 if $feat eq "import";

    return 1 if $feat eq "test";

    # Return false for all others.
    return;
}

################ End PostgreSQL Compatibility ################

1;