File Coverage

blib/lib/Module/Build/Database/PostgreSQL.pm

Criterion	Covered	Total	%
statement	36	300	12.0
branch	0	94	0.0
condition	0	47	0.0
subroutine	12	44	27.2
pod	0	6	0.0
total	48	491	9.7

=head1 NAME

Module::Build::Database::PostgreSQL - PostgreSQL implementation for MBD

=head1 SYNOPSIS

In Build.PL :

 my $builder = Module::Build::Database->new(
     database_type => "PostgreSQL",
     database_options => {
         name   => "my_database_name",
         schema => "my_schema_name",
         # Extra items for scratch databases :
         append_to_conf => "text to add to postgresql.conf",
         after_create => q[create schema audit;],
     },
     database_extensions => {
         postgis     => { schema => "public", },
         # directory with postgis.sql and spatial_ref_sys.sql
         postgis_base => '/usr/local/share/postgresql/contrib'
     },
 );

=head1 DESCRIPTION

Postgres driver for L.

=head1 OPTIONS

All of the options above may be changed via the Module::Build option
handling, e.g.

  perl Build.PL --database_options name=my_name
  perl Build.PL --postgis_base=/usr/local/share/postgresql/contrib

The options are as follows ;

=over 4

=item database_options

=over 4

=item name

the name of the database (i.e. 'create database $name')

=item schema

the name of the schema to be managed by MBD

=item append_to_conf

extra options to append to C before starting test instances of postgres

=item after_create

extra SQL to run after running a 'create database' statement.  Note that this will be run in several
different situations :

=over 4

=item 1.

during a L (creating a test db)

=item 2.

during a L (also creating a test db)

=item 3.

during an initial L; when the target database does not yet exist.

=back

An example of using the after_create statement would be to create a second schema which
will not be managed by MBD, but on which the MBD-managed schema depends.

=back

=item database_extension

To specify a server side procedural language you can use the C -E C
option, like so:

 my $builder = Module::Build::Database->new(
   database_extension => {
     languages => [ 'plperl', 'pltcl' ],
   },
 );

Trying to create languages to a patch will not work because they not stored in the main schema and will
not be included in C when you run C.

This is also similar to

 after_create => 'create extension ...',

except it is executed on B L meaning you can use this to add extensions to
existing database deployments.

=item postgis_base

Specify the directory containing postgis.sql and spatial_ref_sys.sql.  If specified these SQL files will be loaded so that
you can use PostGIS in your database.

=item leave_running

If set to true, and if you are not using a persistent scratch database (see next option), then the scratch database will
not be stopped and torn down after running C or C.

=item scratch_database

You can use this option to specify the connection settings for a persistent scratch or temporary database instance, used by
the C and C to test schema.  B: the C and C
will drop and re-create databases on the scratch instance with the same name as the database on your production instance so
it is I important that if you use a persistent scratch database that it be dedicated to that task.

 my $builder = Module::Build::Database->new(
   scratch_database => {
     PGHOST => 'databasehost',
     PGPORT => '5555',
     PGUSER => 'dbuser',
   },
 );

If you specify any one of these keys for this option (C, C, C) then MBD will use a persistent
scratch database.  Any missing values will use the default.

You can also specify these settings using environment variables:

 % export MBD_SCRATCH_PGHOST=databasehost
 % export MBD_SCRATCH_PGPORT=5555
 % export MBD_SCRATCH_PGUSER=dbuser

By default this module will create its own scratch PostgreSQL instance that uses unix domain sockets for communication
each time it needs one when you use the C or C commands.  Situations where you might
need to use a persistent scratch database:

=over 4

=item 1.

The server and server binaries are hosted on a system different to the one that you are doing development

=item 2.

You are using MBD on Windows where unix domain sockets are not available

=back

=back

=head1 NOTES

The environment variables understood by C:
C, C and C will be used when
connecting to a live database (for L and
L).  C will be ignored;
the name of the database should be specified in
Build.PL instead.

=cut

package Module::Build::Database::PostgreSQL;
use base 'Module::Build::Database';
use File::Temp qw/tempdir/;
use File::Path qw/rmtree/;
use File::Basename qw/dirname/;
use File::Copy::Recursive qw/fcopy dirmove/;
use Path::Class qw/file/;
use IO::File;
use File::Which qw( which );

use Module::Build::Database::PostgreSQL::Templates;
use Module::Build::Database::Helpers qw/do_system verify_bin info debug/;
use strict;
use warnings;
our $VERSION = '0.56';

__PACKAGE__->add_property(database_options    => default => { name => "foo", schema => "bar" });
__PACKAGE__->add_property(database_extensions => default => { postgis => 0 } );
__PACKAGE__->add_property(postgis_base        => default => "/usr/local/share/postgis" );
__PACKAGE__->add_property(_tmp_db_dir         => default => "" );
__PACKAGE__->add_property(leave_running       => default => 0 ); # leave running after dbtest?
__PACKAGE__->add_property(scratch_database    => default => { map {; "PG$_" => $ENV{"MBD_SCRATCH_PG$_"} }
                                                              grep { defined $ENV{"MBD_SCRATCH_PG$_"} }
                                                              qw( HOST PORT USER ) } );

# Binaries used by this module.  They should be in $ENV{PATH}.
our %Bin = (
    Psql       => 'psql',
    Pgctl      => 'pg_ctl',
    Postgres   => 'postgres',
    Initdb     => 'initdb',
    Createdb   => 'createdb',
    Dropdb     => 'dropdb',
    Pgdump     => 'pg_dump',
    Pgdoc      => [ qw/pg_autodoc postgresql_autodoc/ ],
);
my $server_bin_dir;
if(my $pg_config = which 'pg_config')
{
  $pg_config = Win32::GetShortPathName($pg_config) if $^O eq 'MSWin32' && $pg_config =~ /\s/;
  $server_bin_dir = `$pg_config --bindir`;
  chomp $server_bin_dir;
  $server_bin_dir = Win32::GetShortPathName($server_bin_dir) if $^O eq 'MSWin32' && $server_bin_dir =~ /\s/;
  undef $server_bin_dir unless -d $server_bin_dir;
}
verify_bin(\%Bin, $server_bin_dir);

sub _do_psql {
    my $self = shift;
    my $sql = shift;
    my $database_name  = $self->database_options('name');
    my $tmp = File::Temp->new(TEMPLATE => "tmp_db_XXXX", SUFFIX => '.sql');
    print $tmp $sql;
    $tmp->close;
    # -q: quiet, ON_ERROR_STOP: throw exceptions
    local $ENV{PERL5LIB};
    my $ret = do_system( $Bin{Psql}, "-q", "-vON_ERROR_STOP=1", "-f", "$tmp", $database_name );
    $tmp->unlink_on_destroy($ret);
    $ret;
}
sub _do_psql_out {
    my $self = shift;
    my $sql = shift;
    my $database_name  = $self->database_options('name');
    # -F field separator, -x extended output, -A: unaligned
    local $ENV{PERL5LIB};
    do_system( $Bin{Psql}, "-q", "-vON_ERROR_STOP=1", "-A", "-F ' : '", "-x", "-c", qq["$sql"], $database_name );
}
sub _do_psql_file {
    my $self = shift;
    my $filename = shift;
    unless (-e $filename) {
        warn "could not open file $filename";
        return 0;
    }
    unless (-s $filename) {
        warn "file $filename is empty";
        return 0;
    }
    my $database_name  = $self->database_options('name');
    # -q: quiet, ON_ERROR_STOP: throw exceptions
    local $ENV{PERL5LIB};
    do_system($Bin{Psql},"-q","-vON_ERROR_STOP=1","-f",$filename, $database_name);
}
sub _do_psql_into_file {
    my $self = shift;
    my $filename = shift;
    my $sql      = shift;
    my $database_name  = $self->database_options('name');
    # -A: unaligned, -F: field separator, -t: tuples only, ON_ERROR_STOP: throw exceptions
    local $ENV{PERL5LIB};
    my $q = $^O eq 'MSWin32' ? '"' : "'";
    do_system( $Bin{Psql}, "-q", "-vON_ERROR_STOP=1", "-A", "-F $q\t$q", "-t", "-c", qq["$sql"], $database_name, ">", "$filename" );
}
sub _do_psql_capture {
    my $self = shift;
    my $sql = shift;
    my $database_name  = $self->database_options('name');
    local $ENV{PERL5LIB};
    return qx[$Bin{Psql} -c "$sql" $database_name];
}

sub _cleanup_old_dbs {
    my $self = shift;
    my %args = @_; # pass all => 1 to clean up the current one too

    my $glob;
    {
        my $tmpdir = tempdir("mbdtest_XXXXXX", TMPDIR => 1);
        $glob = "$tmpdir";
        rmtree($tmpdir);
    }
    $glob =~ s/mbdtest_.*$/mbdtest_*/;
    for my $thisdir (glob $glob) {
        next unless -d $thisdir && -w $thisdir;
        debug "cleaning up old tmp instance : $thisdir";
        $self->_stop_db("$thisdir/db");
        rmtree($thisdir);
    }
}

sub _start_new_db {
    my $self = shift;
    # Start a new database and return the host on which it was started.

    my $database_name   = $self->database_options('name');
    $ENV{PGDATABASE} = $database_name;

    if(%{ $self->scratch_database }) {
        delete @ENV{qw( PGHOST PGUSER PGPORT )};
        %ENV = (%ENV, %{ $self->scratch_database });
        do_system("_silent", $Bin{Dropdb}, $database_name);

    } else {

        $self->_cleanup_old_dbs();

        my $tmpdir          = tempdir("mbdtest_XXXXXX", TMPDIR => 1);
        my $dbdir           = $tmpdir."/db";
        my $initlog         = "$tmpdir/postgres.log";
        $self->_tmp_db_dir($dbdir);

        $ENV{PGHOST}     = "$dbdir"; # makes psql use a socket, not a tcp port
        delete $ENV{PGUSER};
        delete $ENV{PGPORT};

        debug "initializing database (log: $initlog)";

        do_system($Bin{Initdb}, "-D", "$dbdir", ">>", "$initlog", "2>&1") or die "could not initdb";

        if (my $conf_append = $self->database_options('append_to_conf')) {
            die "cannot find postgresql.conf" unless -e "$dbdir/postgresql.conf";
            open my $fp, ">> $dbdir/postgresql.conf" or die "could not open postgresql.conf : $!";
            print $fp $conf_append;
            close $fp;
        }

        my $pmopts = qq[-k $dbdir -h '' -p 5432];

        debug "# starting postgres in $dbdir";
        do_system($Bin{Pgctl}, qq[-o "$pmopts"], "-w", "-t", 120, "-D", "$dbdir", "-l", "postmaster.log", "start") or die "could not start postgres";

        my $domain = $dbdir.'/.s.PGSQL.5432';
        -e $domain or die "could not find $domain";
    }

    $self->_create_database();

    return $self->_dbhost;
}

sub _remove_db {
    my $self = shift;
    return if $ENV{MBD_DONT_STOP_TEST_DB} || %{ $self->scratch_database };
    my $dbdir = shift || $self->_tmp_db_dir();
    $dbdir =~ s/\/db$//;
    rmtree $dbdir;
}

sub _stop_db {
    my $self = shift;
    return if $ENV{MBD_DONT_STOP_TEST_DB} || %{ $self->scratch_database };
    my $dbdir = shift || $self->_tmp_db_dir();
    my $pid_file = "$dbdir/postmaster.pid";
    unless (-e $pid_file) {
        debug "no pid file ($pid_file), not stopping db";
        return;
    }
    my ($pid) = IO::File->new("<$pid_file")->getlines;
    chomp $pid;
    kill "TERM", $pid;
    sleep 1;
    return unless kill 0, $pid;
    kill 9, $pid or info "could not send signal to $pid";
}

sub _apply_base_sql {
    my $self = shift;
    my $filename = shift || $self->base_dir."/db/dist/base.sql";
    return unless -e $filename;
    info "applying base.sql";
    $self->_do_psql_file($filename);
}

sub _apply_base_data {
    my $self = shift;
    my $filename = shift || $self->base_dir."/db/dist/base_data.sql";
    return 1 unless -e $filename;
    info "applying base_data.sql";
    $self->_do_psql_file($filename);
}

sub _dump_base_sql {
    # Optional parameter "outfile" gives the name of the file into which to dump the schema.
    # If the parameter is omitted, dump and atomically rename to db/dist/base.sql.
    my $self = shift;
    my %args = @_;
    my $outfile = $args{outfile} || $self->base_dir. "/db/dist/base.sql";

    my $tmpfile = file( tempdir( CLEANUP => 1 ), 'dump.sql');

    # -x : no privileges, -O : no owner, -s : schema only, -n : only this schema
    my $database_schema = $self->database_options('schema');
    my $database_name   = $self->database_options('name');
    local $ENV{PERL5LIB};
    do_system( $Bin{Pgdump}, "-xOs", "-E", "utf8", "-n", $database_schema, $database_name, ">", $tmpfile )
    or do {
      info "Error running pgdump";
      die "Error running pgdump : $! ${^CHILD_ERROR_NATIVE}";
      return 0;
    };

    my @lines = $tmpfile->slurp();
    unless (@lines) {
        die "# Could not run pgdump and write to $tmpfile";
    }
    @lines = grep {
        $_ !~ /^--/
        and $_ !~ /^CREATE SCHEMA $database_schema;$/
        and $_ !~ /^SET (search_path|lock_timeout)/
    } @lines;
    for (@lines) {
        /alter table/i and s/$database_schema\.//;
    }
    file($outfile)->spew(join '', @lines);
    if (@lines > 0 && !-s $outfile) {
        die "# Unable to write to $outfile";
    }
    return 1;
}

sub _dump_base_data {
    # Optional parameter "outfile, defaults to db/dist/base_data.sql
    my $self = shift;
    my %args = @_;
    my $outfile = $args{outfile} || $self->base_dir. "/db/dist/base_data.sql";

    my $tmpfile = File::Temp->new(
        TEMPLATE => (dirname $outfile)."/dump_XXXXXX",
        UNLINK   => 0
    );
    $tmpfile->close;

    # -x : no privileges, -O : no owner, -s : schema only, -n : only this schema
    my $database_schema = $self->database_options('schema');
    my $database_name   = $self->database_options('name');
    local $ENV{PERL5LIB};
    do_system( $Bin{Pgdump}, "--data-only", "-xO", "-E", "utf8", "-n", $database_schema, $database_name,
        "|", "egrep -v '^SET (lock_timeout|search_path)'",
        ">", "$tmpfile" )
      or return 0;
    rename "$tmpfile", $outfile or die "rename failed: $!";
}

sub _apply_patch {
    my $self = shift;
    my $patch_file = shift;

    return $self->_do_psql_file($self->base_dir."/db/patches/$patch_file");
}

sub _is_fresh_install {
    my $self = shift;

    my $database_name = $self->database_options('name');
    unless ($self->_database_exists) {
        info "database $database_name does not exist";
        return 1;
    }

    my $file = File::Temp->new(); $file->close;
    my $database_schema = $self->database_options('schema');
    $self->_do_psql_into_file("$file","\\dn $database_schema");
    return !do_system("_silent","grep -q $database_schema $file");
}

sub _show_live_db {
    # Display the connection information
    my $self = shift;

    info "PGUSER : " . ( $ENV{PGUSER}     || "" );
    info "PGHOST : " . ( $ENV{PGHOST}     || "" );
    info "PGPORT : " . ( $ENV{PGPORT}     || "" );

    my $database_name = shift || $self->database_options('name');
    info "database : $database_name";

    return unless $self->_database_exists;
    $self->_do_psql_out("select current_database(),session_user,version();");
}

sub _patch_table_exists {
    # returns true or false
    my $self = shift;
    my $file = File::Temp->new(); $file->close;
    my $database_schema = $self->database_options('schema');
    $self->_do_psql_into_file("$file","select tablename from pg_tables where tablename='patches_applied' and schemaname = '$database_schema'");
    return do_system("_silent","grep -q patches_applied $file");
}

sub _dump_patch_table {
    # Dump the patch table in an existing db into a flat file, that
    # will be in the same format as patches_applied.txt.
    my $self = shift;
    my %args = @_;
    my $filename = $args{outfile} or Carp::confess "need a filename";
    my $database_schema = $self->database_options('schema');
    $self->_do_psql_into_file($filename,"select patch_name,patch_md5 from $database_schema.patches_applied order by patch_name");
}

sub _create_patch_table {
    my $self = shift;
    # create a new patch table
    my $database_schema = $self->database_options('schema');
    my $sql = <
    CREATE TABLE $database_schema.patches_applied (
        patch_name   varchar(255) primary key,
        patch_md5    varchar(255),
        when_applied timestamp );
EOSQL
    $self->_do_psql($sql);
}

sub _insert_patch_record {
    my $self = shift;
    my $record = shift;
    my ($name,$md5) = @$record;
    my $database_schema = $self->database_options('schema');
    $self->_do_psql("insert into $database_schema.patches_applied (patch_name, patch_md5, when_applied) ".
             " values ('$name','$md5',now()) ");
}

sub _database_exists {
    my $self  =  shift;
    my $database_name = shift || $self->database_options('name');
    local $ENV{PERL5LIB};
    scalar grep /^$database_name$/, map { [split /:/]->[0] } `psql -Alt -F:`;
}

sub _create_language_extensions {
    my $self = shift;
    my $list = $self->database_extensions('languages');
    return unless $list;
    foreach my $lang (@$list) {
        $self->_do_psql("create extension if not exists $lang") || die "error creating language: $lang";
    }
}

sub _create_database {
    my $self = shift;

    my $database_name   = $self->database_options('name');
    my $database_schema = $self->database_options('schema');

    # create the database if necessary
    unless ($self->_database_exists($database_name)) {
        local $ENV{PERL5LIB};
        do_system($Bin{Createdb}, $database_name) or die "could not createdb";
    }

    # Create a fresh schema in the database.
    $self->_do_psql("create schema $database_schema") unless $database_schema eq 'public';

    $self->_do_psql("alter database $database_name set client_min_messages to ERROR");

    $self->_do_psql("alter database $database_name set search_path to $database_schema;");

    # stolen from http://wiki.postgresql.org/wiki/CREATE_OR_REPLACE_LANGUAGE
    $self->_do_psql(<<'SAFE_MAKE_PLPGSQL');
CREATE OR REPLACE FUNCTION make_plpgsql()
RETURNS VOID
LANGUAGE SQL
AS $$
CREATE LANGUAGE plpgsql;
$$;

SELECT
    CASE
    WHEN EXISTS(
        SELECT 1
        FROM pg_catalog.pg_language
        WHERE lanname='plpgsql'
    )
    THEN NULL
    ELSE make_plpgsql() END;

DROP FUNCTION make_plpgsql();
SAFE_MAKE_PLPGSQL

    if (my $postgis = $self->database_extensions('postgis')) {
        info "applying postgis extension";
        my $postgis_schema = $postgis->{schema} or die "No schema given for postgis";
        $self->_do_psql("create schema $postgis_schema") unless $postgis_schema eq 'public';
        $self->_do_psql("alter database $database_name set search_path to $postgis_schema;");
        # We need to run "createlang plpgsql" first.
        $self->_do_psql_file($self->postgis_base. "/postgis.sql") or die "could not do postgis.sql";
        $self->_do_psql_file($self->postgis_base. "/spatial_ref_sys.sql") or die "could not do spatial_ref_sys.sql";
        $self->_do_psql("alter database $database_name set search_path to $database_schema, $postgis_schema");
    }

    if (my $sql = $self->database_options('post_initdb')) {
        info "applying post_initdb (nb: this option has been renamed to 'after_create')";
        $self->_do_psql($sql);
    }

    if (my $sql = $self->database_options('after_create')) {
        info "applying after_create";
        $self->_do_psql($sql);
    }

    1;
}

sub _remove_patches_applied_table {
    my $self = shift;
    my $database_schema = $self->database_options('schema');
    $self->_do_psql("drop table if exists $database_schema.patches_applied;");
}

sub _generate_docs {
    my $self            = shift;
    my %args            = @_;
    my $dir             = $args{dir} or die "missing dir";
    my $tmpdir          = tempdir;
    my $tc              = "Module::Build::Database::PostgreSQL::Templates";
    my $database_name   = $self->database_options('name');
    my $database_schema = $self->database_options('schema');

    $self->_start_new_db();
    $self->_apply_base_sql();

    chdir $tmpdir;
    for my $filename ($tc->filenames) {
        open my $fp, ">$filename" or die $!;
        print ${fp} $tc->file_contents($filename);
        close $fp;
    }

    # http://perlmonks.org/?node_id=821413
    do_system( $Bin{Pgdoc}, "-d", $database_name, "-s", $database_schema, "-l .", "-t pod" );
    do_system( $Bin{Pgdoc}, "-d", $database_name, "-s", $database_schema, "-l .", "-t html" );
    do_system( $Bin{Pgdoc}, "-d", $database_name, "-s", $database_schema, "-l .", "-t dot" );

    for my $type (qw(pod html)) {
        my $fp = IO::File->new("<$database_name.$type") or die $!;
        mkdir $type or die $!;
        my $outfp;
        while (<$fp>) {
            s/^_CUT: (.*)$// and do { $outfp = IO::File->new(">$type/$1") or die $!; };
            s/^_DB: (.*)$//  and do { $_ = $self->_do_psql_capture($1);   s/^/ /gm;  };
            print ${outfp} $_ if defined($outfp);
        }
    }
    dirmove "$tmpdir/pod", "$dir/pod";
    info "Generated $dir/pod";
    dirmove "$tmpdir/html", "$dir/html";
    info "Generated $dir/html";
    fcopy "$tmpdir/$database_name.dot", "$dir";
    info "Generated $dir/$database_name.dot";
}

sub ACTION_dbtest        { shift->SUPER::ACTION_dbtest(@_);        }
sub ACTION_dbclean       { shift->SUPER::ACTION_dbclean(@_);       }
sub ACTION_dbdist        { shift->SUPER::ACTION_dbdist(@_);        }
sub ACTION_dbdocs        { shift->SUPER::ACTION_dbdocs(@_);        }
sub ACTION_dbinstall     { shift->SUPER::ACTION_dbinstall(@_);     }
sub ACTION_dbfakeinstall { shift->SUPER::ACTION_dbfakeinstall(@_); }

sub _dbhost {
    return $ENV{PGHOST} || 'localhost';
}

1;