--- /dev/null
+#!perl
+
+## Simply test that the script compiles and gives a good version
+
+use strict;
+use warnings;
+use Test::More tests => 2;
+select(($|=1,select(STDERR),$|=1)[1]);
+
+eval {
+ require 'check_postgres.pl';
+};
+like($@, qr{\-\-help}, 'check_postgres.pl compiles');
+
+$@ =~ /help/ or BAIL_OUT "Script did not compile, cancelling rest of tests.\n";
+
+like( $check_postgres::VERSION, qr/^v?\d+\.\d+\.\d+(?:_\d+)?$/,
+ qq{Found check_postgres version as "$check_postgres::VERSION"});
+
--- /dev/null
+#!perl
+
+## Make sure we can connect and disconnect cleanly
+## All tests are stopped if we cannot make the first connect
+
+use strict;
+use warnings;
+use DBI;
+use DBD::Pg;
+use Test::More;
+use lib 't','.';
+require 'check_postgres_setup.pl';
+select(($|=1,select(STDERR),$|=1)[1]);
+
+## Define this here in case we get to the END block before a connection is made.
+BEGIN {
+ use vars qw/$pgversion $pglibversion $pgvstring $pgdefport $helpconnect $dbh $connerror %set/;
+ ($pgversion,$pglibversion,$pgvstring,$pgdefport) = ('?','?','?','?');
+}
+
+($helpconnect,$connerror,$dbh) = connect_database();
+
+if (! defined $dbh) {
+ plan skip_all => 'Connection to database failed, cannot continue testing';
+}
+plan tests => 1;
+
+# Trapping a connection error can be tricky, but we only have to do it
+# this thoroughly one time. We are trapping two classes of errors:
+# the first is when we truly do not connect, usually a bad DBI_DSN;
+# the second is an invalid login, usually a bad DBI_USER or DBI_PASS
+
+my ($t);
+
+pass('Established a connection to the database');
+
+$pgversion = $dbh->{pg_server_version};
+$pglibversion = $dbh->{pg_lib_version};
+$pgdefport = $dbh->{pg_default_port};
+$pgvstring = $dbh->selectall_arrayref('SELECT VERSION()')->[0][0];
+
+END {
+ my $pv = sprintf('%vd', $^V);
+ my $schema = 'check_postgres_schema';
+ my $dsn = exists $ENV{DBI_DSN} ? $ENV{DBI_DSN} : '?';
+ my $ver = defined $DBD::Pg::VERSION ? $DBD::Pg::VERSION : '?';
+ my $user = exists $ENV{DBI_USER} ? $ENV{DBI_USER} : '<not set>';
+
+ my $extra = '';
+ for (sort qw/HOST HOSTADDR PORT DATABASE USER PASSWORD PASSFILE OPTIONS REALM
+ REQUIRESSL KRBSRVNAME CONNECT_TIMEOUT SERVICE SSLMODE SYSCONFDIR
+ CLIENTENCODING/) {
+ my $name = "PG$_";
+ if (exists $ENV{$name} and defined $ENV{$name}) {
+ $extra .= sprintf "\n%-21s $ENV{$name}", $name;
+ }
+ }
+ for my $name (qw/DBI_DRIVER DBI_AUTOPROXY/) {
+ if (exists $ENV{$name} and defined $ENV{$name}) {
+ $extra .= sprintf "\n%-21s $ENV{$name}", $name;
+ }
+ }
+
+ ## More helpful stuff
+ for (sort keys %set) {
+ $extra .= sprintf "\n%-21s %s", $_, $set{$_};
+ }
+
+ if ($helpconnect) {
+ $extra .= "\nAdjusted: ";
+ if ($helpconnect & 1) {
+ $extra .= 'DBI_DSN ';
+ }
+ if ($helpconnect & 4) {
+ $extra .= 'DBI_USER';
+ }
+ }
+
+ if (defined $connerror) {
+ $connerror =~ s/.+?failed: //;
+ $connerror =~ s{\n at t/check_postgres.*}{}m;
+ $extra .= "\nError was: $connerror";
+ }
+
+ diag
+ "\nDBI Version $DBI::VERSION\n".
+ "DBD::Pg Version $ver\n".
+ "Perl Version $pv\n".
+ "OS $^O\n".
+ "PostgreSQL (compiled) $pglibversion\n".
+ "PostgreSQL (target) $pgversion\n".
+ "PostgreSQL (reported) $pgvstring\n".
+ "Default port $pgdefport\n".
+ "DBI_DSN $dsn\n".
+ "DBI_USER $user\n".
+ "Test schema $schema$extra\n";
+}
--- /dev/null
+#!perl
+
+## Run Perl::Critic against the source code and the tests
+## This is highly customized, so take with a grain of salt
+## Requires TEST_CRITIC to be set
+
+use strict;
+use warnings;
+use Test::More;
+use Data::Dumper;
+select(($|=1,select(STDERR),$|=1)[1]);
+
+my @testfiles;
+
+if (!$ENV{TEST_CRITIC}) {
+ plan skip_all => 'Set the environment variable TEST_CRITIC to enable this test';
+}
+elsif (!eval { require Perl::Critic; 1 }) {
+ plan skip_all => 'Could not find Perl::Critic';
+}
+elsif ($Perl::Critic::VERSION < 0.23) {
+ plan skip_all => 'Perl::Critic must be version 0.23 or higher';
+}
+else {
+ opendir my $dir, 't' or die qq{Could not open directory 't': $!\n};
+ @testfiles = map { "t/$_" } grep { /^.+\.(t|pl)$/ } readdir $dir;
+ closedir $dir;
+ plan tests => 1+@testfiles;
+}
+ok(@testfiles, 'Found files in test directory');
+
+## Check some non-test files
+my $critic = Perl::Critic->new(-severity => 1);
+
+for my $filename (qw{check_postgres.pl }) {
+
+ if ($ENV{TEST_CRITIC_SKIPNONTEST}) {
+ pass qq{Skipping non-test file "$filename"};
+ next;
+ }
+
+ -e $filename or die qq{Could not find "$filename"!};
+ open my $oldstderr, '>&', \*STDERR or die 'Could not dupe STDERR';
+ close STDERR or die qq{Could not close STDERR: $!};
+ my @vio = $critic->critique($filename);
+ open STDERR, '>&', $oldstderr or die 'Could not recreate STDERR'; ## no critic
+ close $oldstderr or die qq{Could not close STDERR copy: $!};
+ my $vios = 0;
+ VIO: for my $v (@vio) {
+ my $d = $v->description();
+ (my $policy = $v->policy()) =~ s/Perl::Critic::Policy:://;
+ my $source = $v->source();
+
+ next if $policy =~ /ProhibitInterpolationOfLiterals/; ## For now
+
+ ## Allow skipping of items:
+ ## next if $d =~ /Subroutine "looks_like_number" not exported/;
+ ## next if $policy =~ /ProhibitCallsToUndeclaredSubs/;
+ ##next if $policy =~ /ProhibitHardTabs/ and ($source =~ /sql = qq/i or $source =~ /qw[\(\/]/);
+
+ $vios++;
+ my $f = $v->filename();
+ my $l = $v->location();
+ my $line = $l->[0];
+ diag "\nFile: $f (line $line)\n";
+ diag "Vio: $d\n";
+ diag "Policy: $policy\n";
+ diag "Source: $source\n\n";
+ }
+ if ($vios) {
+ fail qq{ Failed Perl::Critic tests for file "$filename": $vios};
+ }
+ else {
+ pass qq{ File "$filename" passed all Perl::Critic tests};
+ }
+
+}
+
+## Specific exclusions for test scripts:
+my %ok =
+ (yaml => {
+ sub => 'meta_spec_ok',
+ },
+ pod => {
+ sub => 'pod_file_ok pod_coverage_ok',
+ },
+ signature => {
+ sub => 'verify SIGNATURE_OK',
+ },
+);
+for my $f (keys %ok) {
+ for my $ex (keys %{$ok{$f}}) {
+ if ($ex eq 'sub') {
+ for my $foo (split /\s+/ => $ok{$f}{sub}) {
+ push @{$ok{$f}{OK}} => qr{Subroutine "$foo" (?:is neither|not exported)};
+ }
+ }
+ else {
+ die "Unknown exception '$ex'\n";
+ }
+ }
+}
+
+## Allow Test::More subroutines
+my $tm = join '|' => (qw/skip plan pass fail is ok diag BAIL_OUT/);
+my $testmoreok = qr{Subroutine "$tm" is neither};
+
+## Create a new critic for the tests
+$critic = Perl::Critic->new(-severity => 1);
+
+my $count = 1;
+for my $filename (sort @testfiles) {
+ -e $filename or die qq{Could not find "$filename"!};
+ my @vio = $critic->critique($filename);
+ my $vios = 0;
+ VIO: for my $v (@vio) {
+ my $d = $v->description();
+ (my $policy = $v->policy()) =~ s/Perl::Critic::Policy:://;
+ my $source = $v->source();
+ my $f = $v->filename();
+
+ ## Skip common Test::More subroutines:
+ next if $d =~ $testmoreok;
+
+ ## Skip other specific items:
+ for my $k (sort keys %ok) {
+ next unless $f =~ /$k/;
+ for (@{$ok{$k}{OK}}) {
+ next VIO if $d =~ $_;
+ }
+ }
+
+ ## Skip included file package warning
+ next if $policy =~ /RequireExplicitPackage/ and $filename =~ /setup/;
+
+ $vios++;
+ my $l = $v->location();
+ my $line = $l->[0];
+ diag "\nFile: $f (line $line)\n";
+ diag "Vio: $d\n";
+ diag "Policy: $policy\n";
+ diag "Source: $source\n\n";
+ }
+ my $SPACE = ++$count < 9 ? ' ' : '';
+ if ($vios) {
+ fail qq{${SPACE}Failed Perl::Critic tests for file "$filename": $vios};
+ }
+ else {
+ pass qq{${SPACE}File "$filename" passed all Perl::Critic tests};
+ }
+}
+
+pass('Finished Perl::Critic testing');
+
--- /dev/null
+#!perl
+
+## Check our Pod, requires Test::Pod
+
+use strict;
+use warnings;
+use Test::More;
+select(($|=1,select(STDERR),$|=1)[1]);
+
+plan tests => 2;
+
+my $PODVERSION = '0.95';
+eval {
+ require Test::Pod;
+ Test::Pod->import;
+};
+
+SKIP: {
+ if ($@ or $Test::Pod::VERSION < $PODVERSION) {
+ skip "Test::Pod $PODVERSION is required", 1;
+ }
+ pod_file_ok('check_postgres.pl');
+}
+
+## We won't require everyone to have this, so silently move on if not found
+my $PODCOVERVERSION = '1.04';
+eval {
+ require Test::Pod::Coverage;
+ Test::Pod::Coverage->import;
+};
+SKIP: {
+
+ if ($@ or $Test::Pod::Coverage::VERSION < $PODCOVERVERSION) {
+ skip "Test::Pod::Coverage $PODCOVERVERSION is required", 1;
+ }
+
+ my $trusted_names =
+ [
+ qr{^CLONE$},
+ qr{^driver$},
+ qr{^constant$},
+ ];
+ pod_coverage_ok('check_postgres', {trustme => $trusted_names}, 'check_postgres.pl pod coverage okay');
+}
--- /dev/null
+#!perl
+
+## Cleanup all database objects we may have created
+
+use strict;
+use warnings;
+use Test::More;
+use lib 't','.';
+require 'check_postgres_setup.pl';
+select(($|=1,select(STDERR),$|=1)[1]);
+
+my $dbh = connect_database({nosetup => 1});
+
+if (! defined $dbh) {
+ plan skip_all => 'Connection to database failed, cannot continue testing';
+}
+plan tests => 1;
+
+isnt( $dbh, undef, 'Connect to database for cleanup');
+
+cleanup_database($dbh);
+$dbh->disconnect() if defined $dbh and ref $dbh;
+
--- /dev/null
+
+## Helper file for the check_postgres.pl tests
+
+use strict;
+use warnings;
+use Data::Dumper;
+use DBI;
+select(($|=1,select(STDERR),$|=1)[1]); ## no critic
+
+my @schemas =
+ (
+ 'check_postgres_testschema',
+ 'check_postgres_testschema2',
+ );
+
+my @tables =
+ (
+ 'check_postgres_test',
+ 'check_postgres_test2',
+ 'check_postgres_test3',
+ );
+
+my @sequences =
+ (
+ 'check_postgres_testsequence',
+ );
+
+my $S = 'check_postgres_testschema';
+
+sub connect_database {
+
+ ## Connect to the database (unless 'dbh' is passed in)
+ ## Setup all the tables (unless 'nosetup' is passed in)
+ ## Returns three values:
+ ## 1. helpconnect for use by ??
+ ## 2. Any error generated
+ ## 3. The database handle, or undef
+ ## The returned handle has AutoCommit=0 (unless AutoCommit is passed in)
+
+ my $arg = shift || {};
+ ref $arg and ref $arg eq 'HASH' or die qq{Need a hashref!\n};
+
+ my $dbh = $arg->{dbh} || '';
+
+ my $helpconnect = 0;
+ if (!defined $ENV{DBI_DSN}) {
+ $helpconnect = 1;
+ $ENV{DBI_DSN} = 'dbi:Pg:';
+ }
+
+ if (!$dbh) {
+ eval {
+ $dbh = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS},
+ {RaiseError => 1, PrintError => 0, AutoCommit => 1});
+ };
+ if ($@) {
+ return $helpconnect, $@, undef if $@ !~ /FATAL/ or defined $ENV{DBI_USER};
+ ## Try one more time as postgres user (and possibly database)
+ if ($helpconnect) {
+ $ENV{DBI_DSN} .= 'dbname=postgres';
+ $helpconnect += 2;
+ }
+ $helpconnect += 4;
+ $ENV{DBI_USER} = $^O =~
+ /openbsd/ ? '_postgresql'
+ : $^O =~ /bsd/i ? 'pgsql'
+ : 'postgres';
+ eval {
+ $dbh = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS},
+ {RaiseError => 1, PrintError => 0, AutoCommit => 1});
+ };
+ if ($@) {
+ ## Try one final time for Beastie
+ if ($ENV{DBI_USER} ne 'postgres') {
+ $helpconnect += 8;
+ $ENV{DBI_USER} = 'postgres';
+ eval {
+ $dbh = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS},
+ {RaiseError => 1, PrintError => 0, AutoCommit => 1});
+ };
+ }
+ return $helpconnect, $@, undef if $@;
+ }
+ }
+ }
+ if ($arg->{nosetup}) {
+ return $helpconnect, undef, $dbh unless schema_exists($dbh, $S);
+ $dbh->do("SET search_path TO $S");
+ }
+ else {
+ cleanup_database($dbh);
+
+ eval {
+ $dbh->do("CREATE SCHEMA $S");
+ };
+ $@ and return $helpconnect, $@, undef;
+ $dbh->do("SET search_path TO $S");
+ $dbh->do('CREATE SEQUENCE check_postgres_testsequence');
+ # If you add columns to this, please do not use reserved words!
+ my $SQL = q{
+CREATE TABLE check_postgres_test (
+ id integer not null primary key,
+ val text
+)
+};
+
+ $dbh->{Warn} = 0;
+ $dbh->do($SQL);
+ $dbh->{Warn} = 1;
+
+} ## end setup
+
+$dbh->commit() unless $dbh->{AutoCommit};
+
+if ($arg->{disconnect}) {
+ $dbh->disconnect();
+ return $helpconnect, undef, undef;
+}
+
+$dbh->{AutoCommit} = 0 unless $arg->{AutoCommit};
+return $helpconnect, undef, $dbh;
+
+} ## end of connect_database
+
+
+sub schema_exists {
+
+ my ($dbh,$schema) = @_;
+ my $SQL = 'SELECT 1 FROM pg_catalog.pg_namespace WHERE nspname = ?';
+ my $sth = $dbh->prepare_cached($SQL);
+ my $count = $sth->execute($schema);
+ $sth->finish();
+ return $count < 1 ? 0 : 1;
+
+}
+
+
+sub relation_exists {
+
+ my ($dbh,$schema,$name) = @_;
+ my $SQL = 'SELECT 1 FROM pg_catalog.pg_class c, pg_catalog.pg_namespace n '.
+ 'WHERE n.oid=c.relnamespace AND n.nspname = ? AND c.relname = ?';
+ my $sth = $dbh->prepare_cached($SQL);
+ my $count = $sth->execute($schema,$name);
+ $sth->finish();
+ return $count < 1 ? 0 : 1;
+
+}
+
+
+sub cleanup_database {
+
+ my $dbh = shift;
+ my $type = shift || 0;
+
+ return unless defined $dbh and ref $dbh and $dbh->ping();
+
+ ## For now, we always run and disregard the type
+
+ $dbh->rollback() if ! $dbh->{AutoCommit};
+
+ for my $name (@tables) {
+ my $schema = ($name =~ s/(.+)\.(.+)/$2/) ? $1 : $S;
+ next if ! relation_exists($dbh,$schema,$name);
+ $dbh->do("DROP TABLE $schema.$name");
+ }
+
+ for my $name (@sequences) {
+ my $schema = ($name =~ s/(.+)\.(.+)/$2/) ? $1 : $S;
+ next if ! relation_exists($dbh,$schema,$name);
+ $dbh->do("DROP SEQUENCE $schema.$name");
+ }
+
+ for my $schema (@schemas) {
+ next if ! schema_exists($dbh,$schema);
+ $dbh->do("DROP SCHEMA $schema CASCADE");
+ }
+ $dbh->commit() if ! $dbh->{AutoCommit};
+
+ return;
+
+}
+
+1;
projects / check_postgres.git / commitdiff