my $VERSION = '2.15.0';
if ($VERSION =~ /_/) {
- print "WARNING! This is a test version ($VERSION) and should not be used in production!\n";
+ print "WARNING! This is a test version ($VERSION) and should not be used in production!\n";
}
if (grep { /help/ } @ARGV) {
- print qq{
+ print qq{
Usage: perl $0
The usual steps to install check_postgres.pl:
};
- exit 1;
+ exit 1;
}
print "Configuring check_postgres $VERSION\n";
my %opts =
- (
- NAME => 'check_postgres',
- ABSTRACT => 'Postgres monitoring script',
- PREREQ_PM => {
- 'ExtUtils::MakeMaker' => '6.11',
- 'Test::More' => '0.61',
- 'version' => '0',
- },
- NO_META => 1,
- VERSION_FROM => 'check_postgres.pl',
+ (
+ NAME => 'check_postgres',
+ ABSTRACT => 'Postgres monitoring script',
+ PREREQ_PM => {
+ 'ExtUtils::MakeMaker' => '6.11',
+ 'Test::More' => '0.61',
+ 'version' => '0',
+ },
+ NO_META => 1,
+ VERSION_FROM => 'check_postgres.pl',
EXE_FILES => ['check_postgres.pl'],
MAN1PODS => {},
- NEEDS_LINKING => 0,
+ NEEDS_LINKING => 0,
NORECURS => 1,
- clean => { FILES => 'test_database_check_postgres/ test_database_check_postgres2/ /tmp/cptesting_socket' },
+ clean => { FILES => 'test_database_check_postgres/ test_database_check_postgres2/ /tmp/cptesting_socket' },
);
{
- package MY;
- sub clean { ## no critic (RequireArgUnpacking)
- my $string = shift->SUPER::clean(@_);
- $string =~ s{\t}{\tperl t/99_cleanup\.t\n\t};
- $string .= qq{\nsignature_asc : \n};
- $string .= qq{\t@ gpg --yes -ba check_postgres.pl\n};
- $string .= qq{\t@ gpg --verify check_postgres.pl.asc\n};
- $string .= qq{\n\nhtml : \n\t};
- $string .= <<'EOM';
- pod2html check_postgres.pl > check_postgres.pl.html
- @ perl -pi -e "s/<link.*?>//" check_postgres.pl.html
- @ perl -pi -e "s~ git clone.*~ git clone git://bucardo.org/check_postgres.git</pre>~" check_postgres.pl.html
- @ perl -pi -e "s~<title>\S+(.+)~<title>check_postgres.pl\\1</TITLE>~" check_postgres.pl.html
- @ perl -pi -e "s~.*</title>~~" check_postgres.pl.html
- @ perl -pi -e "s~</TITLE>~</title>~" check_postgres.pl.html
- @ perl -pi -e "s~\`\`(.+?)''~"\\1"~g" check_postgres.pl.html
- @ rm -f pod2htmd.tmp pod2htmi.tmp
+ package MY;
+ sub clean { ## no critic (RequireArgUnpacking)
+ my $string = shift->SUPER::clean(@_);
+ $string =~ s{\t}{\tperl t/99_cleanup\.t\n\t};
+ $string .= qq{\nsignature_asc : \n};
+ $string .= qq{\t@ gpg --yes -ba check_postgres.pl\n};
+ $string .= qq{\t@ gpg --verify check_postgres.pl.asc\n};
+ $string .= qq{\n\nhtml : \n\t};
+ $string .= <<'EOM';
+ pod2html check_postgres.pl > check_postgres.pl.html
+ @ perl -pi -e "s/<link.*?>//" check_postgres.pl.html
+ @ perl -pi -e "s~ git clone.*~ git clone git://bucardo.org/check_postgres.git</pre>~" check_postgres.pl.html
+ @ perl -pi -e "s~<title>\S+(.+)~<title>check_postgres.pl\\1</TITLE>~" check_postgres.pl.html
+ @ perl -pi -e "s~.*</title>~~" check_postgres.pl.html
+ @ perl -pi -e "s~</TITLE>~</title>~" check_postgres.pl.html
+ @ perl -pi -e "s~\`\`(.+?)''~"\\1"~g" check_postgres.pl.html
+ @ rm -f pod2htmd.tmp pod2htmi.tmp
EOM
- return $string;
- }
+ return $string;
+ }
}
## Use of skip_item means we may have no matches
if ($maxdb eq '?') {
if ($USERWHERECLAUSE) { ## needed?
- add_unknown msg('tttt-nomatch');
+ add_unknown msg('fixme-nomatch');
}
else {
add_ok msg('txntime-none');
use Test::More tests => 2;
eval {
- require 'check_postgres.pl'; ## no critic (RequireBarewordIncludes)
+ require 'check_postgres.pl'; ## no critic (RequireBarewordIncludes)
};
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"});
+ qq{Found check_postgres version as "$check_postgres::VERSION"});
use lib 't','.';
if (!$ENV{RELEASE_TESTING}) {
- plan (skip_all => 'Test skipped unless environment variable RELEASE_TESTING is set');
+ plan (skip_all => 'Test skipped unless environment variable RELEASE_TESTING is set');
}
plan tests => 2;
my $file = 'META.yml';
open my $fh, '<', $file or die qq{Could not open "$file": $!\n};
while (<$fh>) {
- push @{$v{$file}} => [$1,$.] if /version\s*:\s*$vre/;
+ push @{$v{$file}} => [$1,$.] if /version\s*:\s*$vre/;
}
close $fh or warn qq{Could not close "$file": $!\n};
$file = 'Makefile.PL';
open $fh, '<', $file or die qq{Could not open "$file": $!\n};
while (<$fh>) {
- push @{$v{$file}} => [$1,$.] if /VERSION = '$vre'/;
+ push @{$v{$file}} => [$1,$.] if /VERSION = '$vre'/;
}
close $fh or warn qq{Could not close "$file": $!\n};
open $fh, '<', $file or die qq{Could not open "$file": $!\n};
my $foundchange = 0;
while (<$fh>) {
- push @{$v{$file}} => [$1,$.] if (/VERSION = '$vre'/ or /check_postgres.pl version $vre/);
- if (!$foundchange) {
- if (/item B<Version $vre>/) {
- push @{$v{$file}} => [$1,$.];
- $foundchange=1;
- }
- }
+ push @{$v{$file}} => [$1,$.] if (/VERSION = '$vre'/ or /check_postgres.pl version $vre/);
+ if (!$foundchange) {
+ if (/item B<Version $vre>/) {
+ push @{$v{$file}} => [$1,$.];
+ $foundchange=1;
+ }
+ }
}
close $fh or warn qq{Could not close "$file": $!\n};
$file = 'check_postgres.pl.html';
open $fh, '<', $file or die qq{Could not open "$file": $!\n};
while (<$fh>) {
- push @{$v{$file}} => [$1,$.] if /check_postgres.pl version $vre/;
+ push @{$v{$file}} => [$1,$.] if /check_postgres.pl version $vre/;
}
close $fh or warn qq{Could not close "$file": $!\n};
my $good = 1;
my $lastver;
for my $filename (keys %v) {
- for my $glob (@{$v{$filename}}) {
- my ($ver,$line) = @$glob;
- if (! defined $lastver) {
- $lastver = $ver;
- }
- elsif ($ver ne $lastver) {
- $good = 0;
- }
- }
+ for my $glob (@{$v{$filename}}) {
+ my ($ver,$line) = @$glob;
+ if (! defined $lastver) {
+ $lastver = $ver;
+ }
+ elsif ($ver ne $lastver) {
+ $good = 0;
+ }
+ }
}
if ($good) {
- pass "All version numbers are the same ($lastver)";
- my $taginfo = qx{git tag -v $lastver 2>&1};
- if ($taginfo =~ /not exist/) {
- fail "No such tag: $lastver";
- }
- elsif ($taginfo !~ /Good signature from/) {
- fail "The git tag $lastver does not have a valid signature";
- }
- else {
- pass "The git tag $lastver appears correct";
- }
+ pass "All version numbers are the same ($lastver)";
+ my $taginfo = qx{git tag -v $lastver 2>&1};
+ if ($taginfo =~ /not exist/) {
+ fail "No such tag: $lastver";
+ }
+ elsif ($taginfo !~ /Good signature from/) {
+ fail "The git tag $lastver does not have a valid signature";
+ }
+ else {
+ pass "The git tag $lastver appears correct";
+ }
}
else {
- fail 'All version numbers were not the same!';
- for my $filename (sort keys %v) {
- for my $glob (@{$v{$filename}}) {
- my ($ver,$line) = @$glob;
- diag "File: $filename. Line: $line. Version: $ver\n";
- }
- }
- fail 'Cannot check git tag until we have a single version number!';
+ fail 'All version numbers were not the same!';
+ for my $filename (sort keys %v) {
+ for my $glob (@{$v{$filename}}) {
+ my ($ver,$line) = @$glob;
+ diag "File: $filename. Line: $line. Version: $ver\n";
+ }
+ }
+ fail 'Cannot check git tag until we have a single version number!';
}
exit;
my $sigfile = 'check_postgres.pl.asc';
if (!$ENV{RELEASE_TESTING}) {
- plan (skip_all => 'Test skipped unless environment variable RELEASE_TESTING is set');
+ plan (skip_all => 'Test skipped unless environment variable RELEASE_TESTING is set');
}
plan tests => 2;
SKIP: {
- if ( !-e $sigfile ) {
- fail (qq{File '$sigfile' file was not found});
- }
- elsif ( ! -s $sigfile) {
- fail (qq{File '$sigfile' was empty});
- }
- else {
- my $result = system "gpg --no-options --no-auto-check-trustdb --no-tty --logger-fd 1 --quiet --verify $sigfile >/dev/null";
- if (0 == $result) {
- pass (qq{Valid signature file '$sigfile'});
- }
- else {
- fail (qq{Invalid signature file '$sigfile'});
- }
- }
+ if ( !-e $sigfile ) {
+ fail (qq{File '$sigfile' file was not found});
+ }
+ elsif ( ! -s $sigfile) {
+ fail (qq{File '$sigfile' was empty});
+ }
+ else {
+ my $result = system "gpg --no-options --no-auto-check-trustdb --no-tty --logger-fd 1 --quiet --verify $sigfile >/dev/null";
+ if (0 == $result) {
+ pass (qq{Valid signature file '$sigfile'});
+ }
+ else {
+ fail (qq{Invalid signature file '$sigfile'});
+ }
+ }
}
SKIP: {
- if (!eval { require Module::Signature; 1 }) {
- skip ('Must have Module::Signature to test SIGNATURE file', 1);
- }
- elsif ( !-e 'SIGNATURE' ) {
- fail ('SIGNATURE file was not found');
- }
- elsif ( ! -s 'SIGNATURE') {
- fail ('SIGNATURE file was empty');
- }
- else {
- my $ret = Module::Signature::verify();
- if ($ret eq Module::Signature::SIGNATURE_OK()) {
- pass ('Valid SIGNATURE file');
- }
- else {
- fail ('Invalid SIGNATURE file');
- }
- }
+ if (!eval { require Module::Signature; 1 }) {
+ skip ('Must have Module::Signature to test SIGNATURE file', 1);
+ }
+ elsif ( !-e 'SIGNATURE' ) {
+ fail ('SIGNATURE file was not found');
+ }
+ elsif ( ! -s 'SIGNATURE') {
+ fail ('SIGNATURE file was empty');
+ }
+ else {
+ my $ret = Module::Signature::verify();
+ if ($ret eq Module::Signature::SIGNATURE_OK()) {
+ pass ('Valid SIGNATURE file');
+ }
+ else {
+ fail ('Invalid SIGNATURE file');
+ }
+ }
}
my %action;
for my $line (split /\n/ => $info) {
- next if $line !~ /^ (\w+) +\- [A-Z]/;
- $action{$1}++;
+ next if $line !~ /^ (\w+) +\- [A-Z]/;
+ $action{$1}++;
}
my $ok = 1;
for my $act (sort keys %action) {
- ## Special known exceptions
- next if $act eq 'table_size' or $act eq 'index_size';
- next if $act eq 'last_autoanalyze' or $act eq 'last_autovacuum';
-
- my $file = "t/02_$act.t";
- if (! -e $file) {
- diag qq{No matching test file found for action "$act" (expected $file)\n};
- $ok = 0;
- }
+ ## Special known exceptions
+ next if $act eq 'table_size' or $act eq 'index_size';
+ next if $act eq 'last_autoanalyze' or $act eq 'last_autovacuum';
+
+ my $file = "t/02_$act.t";
+ if (! -e $file) {
+ diag qq{No matching test file found for action "$act" (expected $file)\n};
+ $ok = 0;
+ }
}
if ($ok) {
- pass 'There is a test for every action';
+ pass 'There is a test for every action';
}
else {
- fail 'Did not find a test for every action';
+ fail 'Did not find a test for every action';
}
exit;
SKIP:
{
- $ver < 80200 and skip 'Cannot test autovac_freeze on old Postgres versions', 8;
+ $ver < 80200 and skip 'Cannot test autovac_freeze on old Postgres versions', 8;
$t = qq{$S self-identifies correctly};
$result = $cp->run(q{-w 0%});
$t=qq{$S returned correct connection count};
SKIP: {
- $goodver or skip 'Cannot test backends completely with older versions of Postgres', 3;
+ $goodver or skip 'Cannot test backends completely with older versions of Postgres', 3;
- like ($result, qr{^$label OK: \(host:$host\) 2 of 10 connections}, $t);
+ like ($result, qr{^$label OK: \(host:$host\) 2 of 10 connections}, $t);
- $t=qq{$S returned correct percentage};
- like ($result, qr{^$label OK: \(host:$host\) 2 of 10 connections \(20%\)}, $t);
+ $t=qq{$S returned correct percentage};
+ like ($result, qr{^$label OK: \(host:$host\) 2 of 10 connections \(20%\)}, $t);
- $t=qq{$S returned correct performance data};
- like ($result, qr{ \| time=(\d\.\d\d) 'ardala'=0;9;9;0;10 'beedeebeedee'=0;9;9;0;10 'postgres'=2;9;9;0;10 'template0'=0;9;9;0;10 'template1'=0;9;9;0;10\s$}, $t);
+ $t=qq{$S returned correct performance data};
+ like ($result, qr{ \| time=(\d\.\d\d) 'ardala'=0;9;9;0;10 'beedeebeedee'=0;9;9;0;10 'postgres'=2;9;9;0;10 'template0'=0;9;9;0;10 'template1'=0;9;9;0;10\s$}, $t);
}
$t=qq{$S fails when called with an invalid option};
SKIP: {
- $goodver or skip 'Cannot test backends completely with older versions of Postgres', 2;
+ $goodver or skip 'Cannot test backends completely with older versions of Postgres', 2;
- $t=qq{$S returns correct MRTG output when rows found};
- is ($cp->run('--output=MRTG'), qq{3\n0\n\nDB=postgres Max connections=10\n}, $t);
+ $t=qq{$S returns correct MRTG output when rows found};
+ is ($cp->run('--output=MRTG'), qq{3\n0\n\nDB=postgres Max connections=10\n}, $t);
- $t=qq{$S works when include has valid database};
- like ($cp->run('--include=postgres'), qr{^$label OK: .+3 of 10}, $t);
+ $t=qq{$S works when include has valid database};
+ like ($cp->run('--include=postgres'), qr{^$label OK: .+3 of 10}, $t);
}
$t=qq{$S works when exclude forces no matches};
SKIP: {
- $goodver or skip 'Cannot test backends completely with older versions of Postgres', 4;
+ $goodver or skip 'Cannot test backends completely with older versions of Postgres', 4;
- $t=qq{$S works when exclude excludes nothing};
- like ($cp->run('--exclude=foobar'), qr{^$label OK: .+3 of 10}, $t);
+ $t=qq{$S works when exclude excludes nothing};
+ like ($cp->run('--exclude=foobar'), qr{^$label OK: .+3 of 10}, $t);
- $t=qq{$S works when include and exclude make a match};
- like ($cp->run('--exclude=postgres --include=postgres'), qr{^$label OK: .+3 of 10}, $t);
+ $t=qq{$S works when include and exclude make a match};
+ like ($cp->run('--exclude=postgres --include=postgres'), qr{^$label OK: .+3 of 10}, $t);
- $t=qq{$S works when include and exclude make a match};
- like ($cp->run('--include=postgres --exclude=postgres'), qr{^$label OK: .+3 of 10}, $t);
+ $t=qq{$S works when include and exclude make a match};
+ like ($cp->run('--include=postgres --exclude=postgres'), qr{^$label OK: .+3 of 10}, $t);
- $t=qq{$S returned correct performance data with include};
- like ($cp->run('--include=postgres'), qr{ \| time=(\d\.\d\d) 'ardala'=0;9;9;0;10 'beedeebeedee'=0;9;9;0;10 'postgres'=3;9;9;0;10}, $t);
+ $t=qq{$S returned correct performance data with include};
+ like ($cp->run('--include=postgres'), qr{ \| time=(\d\.\d\d) 'ardala'=0;9;9;0;10 'beedeebeedee'=0;9;9;0;10 'postgres'=3;9;9;0;10}, $t);
}
my %dbh;
for my $num (1..8) {
- $dbh{$num} = $cp->test_database_handle({quickreturn=>1});
+ $dbh{$num} = $cp->test_database_handle({quickreturn=>1});
}
$t=qq{$S returns critical when too many clients to even connect};
like ($cp->run('-w=10MB'), qr{^$label OK: DB "postgres"}, $t);
for my $size (qw/bytes kilobytes megabytes gigabytes terabytes exabytes petabytes zettabytes/) {
- $t=qq{$S returns ok for no bloat with a unit of $size};
- like ($cp->run("-w=1000000$size"), qr{^$label OK: DB "postgres"}, $t);
- my $short = substr($size, 0, 1);
- $t=qq{$S returns ok for no bloat with a unit of $short};
- like ($cp->run("-w=1000000$short"), qr{^$label OK: DB "postgres"}, $t);
+ $t=qq{$S returns ok for no bloat with a unit of $size};
+ like ($cp->run("-w=1000000$size"), qr{^$label OK: DB "postgres"}, $t);
+ my $short = substr($size, 0, 1);
+ $t=qq{$S returns ok for no bloat with a unit of $short};
+ like ($cp->run("-w=1000000$short"), qr{^$label OK: DB "postgres"}, $t);
}
$t=qq{$S returns correct message if no tables due to exclusion};
{
if ($result =~ /Date::Parse/) {
- skip 'Cannot test checkpoint action unless Date::Parse module is installed', 6;
+ skip 'Cannot test checkpoint action unless Date::Parse module is installed', 6;
}
like ($cp->run(qq{-w 30 --datadir="$host"}), qr{^$label OK}, $t);
my $ver = $dbh->{pg_server_version};
if ($ver < 80100) {
- $t=qq{$S gives an error when run against an old Postgres version};
- like ($cp->run('--warning=99'), qr{ERROR.*server version must be >= 8.1}, $t);
+ $t=qq{$S gives an error when run against an old Postgres version};
+ like ($cp->run('--warning=99'), qr{ERROR.*server version must be >= 8.1}, $t);
SKIP: {
- skip 'Cannot test database_size completely on Postgres 8.0 or lower', 47;
- }
+ skip 'Cannot test database_size completely on Postgres 8.0 or lower', 47;
+ }
- exit;
+ exit;
}
$cp->drop_all_tables();
for my $type (qw/b bs k kb kbs m mb mbs g gb gbs t tb tbs p pb pbs e eb ebs z zb zbs/) {
- my $opt = "-w 9999999$type";
- $t=qq{$S returned expected text when warning level is specified in $type};
- like ($cp->run($opt), qr{^$label OK:}, $t);
+ my $opt = "-w 9999999$type";
+ $t=qq{$S returned expected text when warning level is specified in $type};
+ like ($cp->run($opt), qr{^$label OK:}, $t);
}
$t=qq{$S returned expected text when warning level is specified in nothing};
my $ver = $dbh->{pg_server_version};
if ($ver < 80100) {
- $t=qq{$S gives an error when run against an old Postgres version};
- like ($cp->run('--warning=99'), qr{ERROR.*server version must be >= 8.1}, $t);
+ $t=qq{$S gives an error when run against an old Postgres version};
+ like ($cp->run('--warning=99'), qr{ERROR.*server version must be >= 8.1}, $t);
SKIP: {
- skip 'Cannot test disabled_triggers completely on Postgres 8.0 or lower', 12;
- }
+ skip 'Cannot test disabled_triggers completely on Postgres 8.0 or lower', 12;
+ }
- exit;
+ exit;
}
$t = qq{$S self-identifies correctly};
sub cleanup {
$dbh->rollback;
- $cp->drop_table_if_exists($testtbl);
- $cp->drop_function_if_exists($testtrig_prefix.'func','');
+ $cp->drop_table_if_exists($testtbl);
+ $cp->drop_function_if_exists($testtrig_prefix.'func','');
}
END { cleanup(); }
my $ver = $dbh->{pg_server_version};
if ($ver >= 80400) {
SKIP: {
- skip 'Cannot test fsm_pages completely on Postgres 8.4 or higher', 3;
- }
+ skip 'Cannot test fsm_pages completely on Postgres 8.4 or higher', 3;
+ }
- $t=qq{$S gives an unknown when running against a 8.4 or higher version};
- like ($cp->run('--warning=10%'), qr{^$label UNKNOWN.*Cannot check on fsm_pages}, $t);
+ $t=qq{$S gives an unknown when running against a 8.4 or higher version};
+ like ($cp->run('--warning=10%'), qr{^$label UNKNOWN.*Cannot check on fsm_pages}, $t);
- exit;
+ exit;
}
$t=qq{$S gives normal output for empty tables};
my $ver = $dbh->{pg_server_version};
if ($ver >= 80400) {
SKIP: {
- skip 'Cannot test fsm_relations completely on Postgres 8.4 or higher', 3;
- }
+ skip 'Cannot test fsm_relations completely on Postgres 8.4 or higher', 3;
+ }
- $t=qq{$S gives an unknown when running against a 8.4 or higher version};
- like ($cp->run('--warning=10%'), qr{^$label UNKNOWN.*Cannot check on fsm_relations}, $t);
+ $t=qq{$S gives an unknown when running against a 8.4 or higher version};
+ like ($cp->run('--warning=10%'), qr{^$label UNKNOWN.*Cannot check on fsm_relations}, $t);
- exit;
+ exit;
}
$t=qq{$S gives normal output for empty tables};
$dbh->do("INSERT INTO $schema.pg_freespacemap_pages VALUES (1663,16389,16911,34,764)");
my $sth = $dbh->prepare("INSERT INTO $schema.pg_freespacemap_relations VALUES (?,?,?,?,?,?,?)");
for (1..999) {
- $sth->execute(1663,16389,16911,1077,52283,52283,37176);
+ $sth->execute(1663,16389,16911,1077,52283,52283,37176);
}
$dbh->commit();
SKIP:
{
- $ver < 80200 and skip 'Cannot test last_analyze on old Postgres versions', 14;
+ $ver < 80200 and skip 'Cannot test last_analyze on old Postgres versions', 14;
$t = qq{$S self-identifies correctly};
$result = $cp->run(q{-w 0});
'1 minute',
'1 hour',
'1 day',
- ) {
+ ) {
like ($cp->run(qq{-w "$_"}), qr/^$label/, $t . " ($_)");
}
$t = qq{$S rejects invalid -w input};
for ('-1 second',
'abc',
- ) {
+ ) {
like ($cp->run(qq{-w "$_"}), qr/^ERROR:.*?must be a valid time/, $t . " ($_)");
}
$t = qq{$S correctly finds no matching tables};
like ($cp->run("-w 0 --include=$testtbl"),
- qr{No matching tables found due to exclusion}, $t);
+ qr{No matching tables found due to exclusion}, $t);
$t = qq{$S sees a recent ANALYZE};
$dbh->do(q{SET default_statistics_target = 1000});
SKIP:
{
- $ver < 80200 and skip 'Cannot test last_vacuum on old Postgres versions', 14;
+ $ver < 80200 and skip 'Cannot test last_vacuum on old Postgres versions', 14;
$t = qq{$S self-identifies correctly};
$result = $cp->run(q{-w 0});
$dbh->do(qq{CREATE TABLE $testtbl AS SELECT 123::INTEGER AS a FROM generate_series(1,200000)});
like ($cp->run("-w 0 --exclude=~.* --include=$testtbl"),
- qr{No matching tables found due to exclusion}, $t);
+ qr{No matching tables found due to exclusion}, $t);
$t = qq{$S sees a recent VACUUM};
$dbh->do("DELETE FROM $testtbl");
sleep 1;
like ($cp->run("-w 0 --exclude=~.* --include=$testtbl"),
- qr{^$label OK: DB "$dbname" \(host:$host\).*?\(\d+ second(?:s)?\)}, $t);
+ qr{^$label OK: DB "$dbname" \(host:$host\).*?\(\d+ second(?:s)?\)}, $t);
$t = qq{$S returns correct MRTG information (OK case)};
like ($cp->run("--output=mrtg -w 0 --exclude=~.* --include=$testtbl"),
- qr{\d+\n0\n\nDB: $dbname TABLE: public.$testtbl\n}, $t);
+ qr{\d+\n0\n\nDB: $dbname TABLE: public.$testtbl\n}, $t);
$t = qq{$S returns correct MRTG information (fail case)};
like ($cp->run('--output=mrtg -w 0 --exclude=~.* --include=no_such_table'),
- qr{0\n0\n\nDB: $dbname TABLE: \?\n}, $t);
+ qr{0\n0\n\nDB: $dbname TABLE: \?\n}, $t);
}
$t=qq{$S returns correct multiple item output};
like ($cp->run('--warning="waiting=1;exclusive=2"'),
- qr{^$label WARNING.*total "waiting" locks: 1 \* total "exclusive" locks: 2 }, $t);
+ qr{^$label WARNING.*total "waiting" locks: 1 \* total "exclusive" locks: 2 }, $t);
$cp->drop_schema_if_exists();
$t = qq{$S returns correct MRTG (fail)};
is ($cp->run("--output=mrtg --warning=1 --logfile $logfile" . 'x'),
- qq{ERROR: logfile ${logfile}x does not exist!\n}, $t);
+ qq{ERROR: logfile ${logfile}x does not exist!\n}, $t);
exit;
my $ver = $dbh->{pg_server_version};
if ($ver < 80100) {
- $t=qq{$S gives an error when run against an old Postgres version};
- like ($cp->run('--warning=99'), qr{ERROR.*server version must be >= 8.1}, $t);
+ $t=qq{$S gives an error when run against an old Postgres version};
+ like ($cp->run('--warning=99'), qr{ERROR.*server version must be >= 8.1}, $t);
SKIP: {
- skip 'Cannot test prepared_transacions completely on Postgres 8.0 or lower', 8;
- }
+ skip 'Cannot test prepared_transacions completely on Postgres 8.0 or lower', 8;
+ }
- exit;
+ exit;
}
## Clear any outstanding transactions
$info = $dbh->selectall_arrayref('SELECT gid FROM pg_prepared_xacts');
$dbh->{AutoCommit} = 1;
for (@$info) {
- my $gid = $_->[0];
- $dbh->do("ROLLBACK PREPARED '$gid'");
+ my $gid = $_->[0];
+ $dbh->do("ROLLBACK PREPARED '$gid'");
}
$dbh->{AutoCommit} = 0;
$info = $dbh->selectall_arrayref('SELECT gid FROM pg_prepared_xacts');
$dbh->{AutoCommit} = 1;
for (@$info) {
- my $gid = $_->[0];
- $dbh->do("ROLLBACK PREPARED '$gid'");
+ my $gid = $_->[0];
+ $dbh->do("ROLLBACK PREPARED '$gid'");
}
$dbh->{AutoCommit} = 0;
'1 hour',
'1 day',
'1 week',
- ) {
- like ($cp->run(qq{ -w "$_"}), qr/^$label/, $t . " ($_)");
+ ) {
+ like ($cp->run(qq{ -w "$_"}), qr/^$label/, $t . " ($_)");
}
$t = qq{$S rejects invalid -w input};
for ('-1 second',
'-1 week',
'abc',
- '1 fortnight',
- ) {
+ '1 fortnight',
+ ) {
like ($cp->run(qq{-w "$_"}), qr/^ERROR: Value for 'warning' must be a valid time/, $t . " ($_)");
}
if ($ver < 80200) {
SKIP: {
- skip 'Cannot test query_time on Postgres 8.1 or lower', 1;
- }
+ skip 'Cannot test query_time on Postgres 8.1 or lower', 1;
+ }
- exit;
+ exit;
}
my $child = fork();
if ($child == 0) {
my $kiddbh = $cp->test_database_handle();
- $cp->database_sleep($kiddbh, 3);
- $kiddbh->rollback();
+ $cp->database_sleep($kiddbh, 3);
+ $kiddbh->rollback();
$kiddbh->disconnect;
exit;
}
my $ver = $dbh->{pg_server_version};
if ($ver < 80100) {
- $t=qq{$S gives an error when run against an old Postgres version};
- like ($cp->run('--warning=99'), qr{ERROR.*server version must be >= 8.1}, $t);
+ $t=qq{$S gives an error when run against an old Postgres version};
+ like ($cp->run('--warning=99'), qr{ERROR.*server version must be >= 8.1}, $t);
SKIP: {
- skip 'Cannot test relation_size completely on Postgres 8.0 or lower', 19;
- }
+ skip 'Cannot test relation_size completely on Postgres 8.0 or lower', 19;
+ }
- exit;
+ exit;
}
$result = $cp->run(q{-w 1});
$t = qq{$S succeeds when views are the same};
like ($cp1->run($stdargs),
qr{^$label OK},
- $t);
+ $t);
$dbh1->do(q{CREATE VIEW view_both_diff AS SELECT 123});
$dbh2->do(q{CREATE VIEW view_both_diff AS SELECT 456});
$t = qq{$S succeeds when views are the same};
like ($cp1->run($stdargs),
qr{^$label CRITICAL.*Items not matched: 1\b.*is different on 1 and 2},
- $t);
+ $t);
$dbh1->do(q{DROP VIEW view_both_diff});
$dbh2->do(q{DROP VIEW view_both_diff});
my $ver = $dbh->{pg_server_version};
if ($ver < 80100) {
- $t=qq{$S gives an error when run against an old Postgres version};
- like ($cp->run('--warning=1%'), qr{ERROR.*server version must be >= 8.1}, $t);
+ $t=qq{$S gives an error when run against an old Postgres version};
+ like ($cp->run('--warning=1%'), qr{ERROR.*server version must be >= 8.1}, $t);
SKIP: {
- skip 'Cannot test sequence completely on Postgres 8.0 or lower', 7;
- }
+ skip 'Cannot test sequence completely on Postgres 8.0 or lower', 7;
+ }
- exit;
+ exit;
}
sub cleanup_schema {
- $SQL = q{DROP VIEW slony_testing.sl_status};
- eval { $dbh->do($SQL); };
- $dbh->commit();
+ $SQL = q{DROP VIEW slony_testing.sl_status};
+ eval { $dbh->do($SQL); };
+ $dbh->commit();
- $SQL = q{DROP TABLE slony_testing.sl_node};
- eval { $dbh->do($SQL); };
- $dbh->commit();
+ $SQL = q{DROP TABLE slony_testing.sl_node};
+ eval { $dbh->do($SQL); };
+ $dbh->commit();
- $SQL = q{DROP SCHEMA slony_testing};
- eval { $dbh->do($SQL); };
- $dbh->commit();
+ $SQL = q{DROP SCHEMA slony_testing};
+ eval { $dbh->do($SQL); };
+ $dbh->commit();
}
for ('-1 second',
'abc',
'-0',
- ) {
+ ) {
like ($cp->run(qq{-w "$_"}), qr/^ERROR:.*?must be number of seconds/, $t . " ($_)");
}
for ('-1 second',
'abc',
'-0',
- ) {
+ ) {
like ($cp->run(qq{-c "$_"}), qr/^ERROR:.*?must be number of seconds/, $t . " ($_)");
}
my $ver = $dbh->{pg_server_version};
if ($ver < 80300) {
SKIP: {
- skip 'Cannot test txn_time on Postgres 8.2 or older', 14;
- }
- exit;
+ skip 'Cannot test txn_time on Postgres 8.2 or older', 14;
+ }
+ exit;
}
$t = qq{$S self-identifies correctly};
my $ver = $dbh->{pg_server_version};
if ($ver < 80100) {
- $t=qq{$S gives an error when run against an old Postgres version};
- like ($cp->run('--warning=99'), qr{ERROR.*server version must be >= 8.1}, $t);
+ $t=qq{$S gives an error when run against an old Postgres version};
+ like ($cp->run('--warning=99'), qr{ERROR.*server version must be >= 8.1}, $t);
SKIP: {
- skip 'Cannot test wal_files completely on Postgres 8.0 or lower', 7;
- }
+ skip 'Cannot test wal_files completely on Postgres 8.0 or lower', 7;
+ }
- exit;
+ exit;
}
$t=qq{$S works as expected for warnings};
use warnings;
use Data::Dumper;
BEGIN {
- use vars qw/$t %complete_langs/;
- %complete_langs = (
- 'en' => 'English',
- 'fr' => 'French',
- );
+ use vars qw/$t %complete_langs/;
+ %complete_langs = (
+ 'en' => 'English',
+ 'fr' => 'French',
+ );
}
use Test::More;
if (!$ENV{RELEASE_TESTING}) {
- plan (skip_all => 'Test skipped unless environment variable RELEASE_TESTING is set');
+ plan (skip_all => 'Test skipped unless environment variable RELEASE_TESTING is set');
}
else {
- plan tests => 3 + (5 * ((scalar keys %complete_langs)-1));
+ plan tests => 3 + (5 * ((scalar keys %complete_langs)-1));
}
my $file = 'check_postgres.pl';
my ($fh, $slurp);
if (!open $fh, '<', $file) {
- if (!open $fh, '<', "../$file") {
- die "Could not find $file!\n";
- }
+ if (!open $fh, '<', "../$file") {
+ die "Could not find $file!\n";
+ }
}
{
- local $/;
- $slurp = <$fh>;
+ local $/;
+ $slurp = <$fh>;
}
close $fh or warn qq{Could not close "$file": $!\n};
my ($lang,%msg,%call);
my ($start,$linecount) = (0,0);
for my $line (split /\n/ => $slurp) {
- $linecount++;
- if (!$start) {
- if ($line =~ /^our \%msg/) {
- $start = 1;
- }
- next;
- }
-
- while ($line =~ /msgn?\('([\w\-]+)'(.*?)\)/g) {
- my ($msg,$args,$orig) = ($1,$2,$2);
- $args =~ s/substr\(.+?,.+?,/substr\(foo bar/g;
- my $numargs = $args =~ y/,//d;
- push @{$call{$msg}}, { line => $linecount, numargs => $numargs, actual => $orig };
- }
-
- if ($line =~ /^'(\w+)' => \{/) {
- $lang = $1;
- $msg{$lang} = {};
- next;
- }
-
- if ($line =~ /^(\s*)'([\w\-]+)'\s+=> qq?\{(.+?)}[,.]/) {
- my ($space,$msg,$value) = (length $1 ? 1 : 0, $2, $3);
- $msg{$lang}{$msg} = [$space,$value];
- next;
- }
+ $linecount++;
+ if (!$start) {
+ if ($line =~ /^our \%msg/) {
+ $start = 1;
+ }
+ next;
+ }
+
+ while ($line =~ /msgn?\('([\w\-]+)'(.*?)\)/g) {
+ my ($msg,$args,$orig) = ($1,$2,$2);
+ $args =~ s/substr\(.+?,.+?,/substr\(foo bar/g;
+ my $numargs = $args =~ y/,//d;
+ push @{$call{$msg}}, { line => $linecount, numargs => $numargs, actual => $orig };
+ }
+
+ if ($line =~ /^'(\w+)' => \{/) {
+ $lang = $1;
+ $msg{$lang} = {};
+ next;
+ }
+
+ if ($line =~ /^(\s*)'([\w\-]+)'\s+=> qq?\{(.+?)}[,.]/) {
+ my ($space,$msg,$value) = (length $1 ? 1 : 0, $2, $3);
+ $msg{$lang}{$msg} = [$space,$value];
+ next;
+ }
}
$t=q{All msg() function calls are mapped to an 'en' string};
my $ok = 1;
for my $call (sort keys %call) {
- if (!exists $msg{'en'}{$call}) {
- my $lines = join ',' => map { $_->{line} } @{$call{$call}};
- fail qq{Could not find message for "$call" (lines: $lines)};
- $ok = 0;
- }
+ if (!exists $msg{'en'}{$call}) {
+ my $lines = join ',' => map { $_->{line} } @{$call{$call}};
+ fail qq{Could not find message for "$call" (lines: $lines)};
+ $ok = 0;
+ }
}
$ok and pass $t;
$t=q{All msg() function calls are called with correct number of arguments};
$ok = 1;
for my $call (sort keys %call) {
- next if !exists $msg{'en'}{$call};
- my $msg = $msg{'en'}{$call}->[1];
- for my $l (@{$call{$call}}) {
- my $line = $l->{line};
- my $numargs = $l->{numargs};
- for my $x (1..$numargs) {
- if ($msg !~ /\$$x/) {
- fail sprintf q{Message '%s' called with %d %s as line %d, but no %s argument found in msg '%s'},
- $call, $numargs, 1==$numargs ? 'argument' : 'arguments', $line, '$'.$x, $msg;
- $ok = 0;
- }
- }
-
- if (!$numargs and $msg =~ /\$\d/) {
- fail qq{Message '$call' called with no args at line $line, but requires some};
- $ok = 0;
- }
- }
+ next if !exists $msg{'en'}{$call};
+ my $msg = $msg{'en'}{$call}->[1];
+ for my $l (@{$call{$call}}) {
+ my $line = $l->{line};
+ my $numargs = $l->{numargs};
+ for my $x (1..$numargs) {
+ if ($msg !~ /\$$x/) {
+ fail sprintf q{Message '%s' called with %d %s as line %d, but no %s argument found in msg '%s'},
+ $call, $numargs, 1==$numargs ? 'argument' : 'arguments', $line, '$'.$x, $msg;
+ $ok = 0;
+ }
+ }
+
+ if (!$numargs and $msg =~ /\$\d/) {
+ fail qq{Message '$call' called with no args at line $line, but requires some};
+ $ok = 0;
+ }
+ }
}
$ok and pass $t;
my %ok2notuse = map { $_ => 1 }
- qw/time-week time-weeks time-month time-months time-year time-years/;
+ qw/time-week time-weeks time-month time-months time-year time-years/;
my %ok2nottrans;
for my $msg (qw/timesync-diff time-minute time-minutes maxtime version version-ok/) {
- $ok2nottrans{'fr'}{$msg} = 1;
+ $ok2nottrans{'fr'}{$msg} = 1;
}
$t=q{All 'en' message strings are used somewhere in the code};
$ok = 1;
for my $msg (sort keys %{$msg{'en'}}) {
- if (!exists $call{$msg}) {
- ## Known exceptions
- next if exists $ok2notuse{$msg};
- fail qq{Message '$msg' does not appear to be used in the code};
- $ok = 0;
- }
+ if (!exists $call{$msg}) {
+ ## Known exceptions
+ next if exists $ok2notuse{$msg};
+ fail qq{Message '$msg' does not appear to be used in the code};
+ $ok = 0;
+ }
}
$ok and pass $t;
for my $l (sort keys %complete_langs) {
- my $language = $complete_langs{$l};
- next if $language eq 'English';
-
- $ok = 1;
- $t=qq{Language $language contains all valid message strings};
- for my $msg (sort keys %{$msg{'en'}}) {
- if (! exists $msg{$l}{$msg}) {
- fail qq{Message '$msg' does not appear in the $language translations};
- $ok = 0;
- }
- }
- $ok and pass $t;
-
- $ok = 1;
- $t=qq{Language $language contains no extra message strings};
- for my $msg (sort keys %{$msg{$l}}) {
- if (! exists $msg{'en'}{$msg}) {
- fail qq{Message '$msg' does not appear in the 'en' messages!};
- $ok = 0;
- }
- }
- $ok and pass $t;
-
- $ok = 1;
- $t=qq{Language $language messages have same number of args as 'en'};
- for my $msg (sort keys %{$msg{'en'}}) {
- next if ! exists $msg{$l}{$msg};
- my $val = $msg{'en'}{$msg}->[1];
- my $lval = $msg{$l}{$msg}->[1];
- my $x = 1;
- {
- last if $val !~ /\$$x/;
- if ($lval !~ /\$$x/) {
- fail qq{Message '$msg' is missing \$$x argument for language $language};
- $ok = 0;
- }
- $x++;
- redo;
- }
- }
- $ok and pass $t;
-
- $ok = 1;
- $t=qq{Language $language messages appears to not be translated, but is not marked as such};
- for my $msg (sort keys %{$msg{'en'}}) {
- next if ! exists $msg{$l}{$msg};
- next if exists $ok2nottrans{$l}{$msg};
- my $val = $msg{'en'}{$msg}->[1];
- my $lval = $msg{$l}{$msg}->[1];
- my $indent = $msg{$l}{$msg}->[0];
- next if $language eq 'French' and ($msg eq 'PID' or $msg eq 'port');
- if ($val eq $lval and $indent) {
- fail qq{Message '$msg' in language $language appears to not be translated, but it not marked as such};
- $ok = 0;
- }
- }
- $ok and pass $t;
-
- $ok = 1;
- $t=qq{Language $language messages are marked as translated correctly};
- for my $msg (sort keys %{$msg{'en'}}) {
- next if ! exists $msg{$l}{$msg};
- my $val = $msg{'en'}{$msg}->[1];
- my $lval = $msg{$l}{$msg}->[1];
- my $indent = $msg{$l}{$msg}->[0];
- if ($val ne $lval and !$indent) {
- fail qq{Message '$msg' in language $language appears to not be translated, but it not marked as such};
- $ok = 0;
- }
- }
- $ok and pass $t;
+ my $language = $complete_langs{$l};
+ next if $language eq 'English';
+
+ $ok = 1;
+ $t=qq{Language $language contains all valid message strings};
+ for my $msg (sort keys %{$msg{'en'}}) {
+ if (! exists $msg{$l}{$msg}) {
+ fail qq{Message '$msg' does not appear in the $language translations};
+ $ok = 0;
+ }
+ }
+ $ok and pass $t;
+
+ $ok = 1;
+ $t=qq{Language $language contains no extra message strings};
+ for my $msg (sort keys %{$msg{$l}}) {
+ if (! exists $msg{'en'}{$msg}) {
+ fail qq{Message '$msg' does not appear in the 'en' messages!};
+ $ok = 0;
+ }
+ }
+ $ok and pass $t;
+
+ $ok = 1;
+ $t=qq{Language $language messages have same number of args as 'en'};
+ for my $msg (sort keys %{$msg{'en'}}) {
+ next if ! exists $msg{$l}{$msg};
+ my $val = $msg{'en'}{$msg}->[1];
+ my $lval = $msg{$l}{$msg}->[1];
+ my $x = 1;
+ {
+ last if $val !~ /\$$x/;
+ if ($lval !~ /\$$x/) {
+ fail qq{Message '$msg' is missing \$$x argument for language $language};
+ $ok = 0;
+ }
+ $x++;
+ redo;
+ }
+ }
+ $ok and pass $t;
+
+ $ok = 1;
+ $t=qq{Language $language messages appears to not be translated, but is not marked as such};
+ for my $msg (sort keys %{$msg{'en'}}) {
+ next if ! exists $msg{$l}{$msg};
+ next if exists $ok2nottrans{$l}{$msg};
+ my $val = $msg{'en'}{$msg}->[1];
+ my $lval = $msg{$l}{$msg}->[1];
+ my $indent = $msg{$l}{$msg}->[0];
+ next if $language eq 'French' and ($msg eq 'PID' or $msg eq 'port');
+ if ($val eq $lval and $indent) {
+ fail qq{Message '$msg' in language $language appears to not be translated, but it not marked as such};
+ $ok = 0;
+ }
+ }
+ $ok and pass $t;
+
+ $ok = 1;
+ $t=qq{Language $language messages are marked as translated correctly};
+ for my $msg (sort keys %{$msg{'en'}}) {
+ next if ! exists $msg{$l}{$msg};
+ my $val = $msg{'en'}{$msg}->[1];
+ my $lval = $msg{$l}{$msg}->[1];
+ my $indent = $msg{$l}{$msg}->[0];
+ if ($val ne $lval and !$indent) {
+ fail qq{Message '$msg' in language $language appears to not be translated, but it not marked as such};
+ $ok = 0;
+ }
+ }
+ $ok and pass $t;
}
exit;
my @testfiles;
if (!$ENV{RELEASE_TESTING}) {
- plan (skip_all => 'Test skipped unless environment variable RELEASE_TESTING is set');
+ plan (skip_all => 'Test skipped unless environment variable RELEASE_TESTING is set');
}
elsif (!eval { require Perl::Critic; 1 }) {
- plan skip_all => 'Could not find Perl::Critic';
+ 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';
+ 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 => 5+@testfiles;
+ 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 => 5+@testfiles;
}
ok(@testfiles, 'Found files in test directory');
for my $filename (qw{Makefile.PL check_postgres.pl t/CP_Testing.pm}) {
- 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;
+ 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();
-
- if ($filename =~ /test/io) {
- next VIO if $policy =~ /RequireArgUnpacking/o
- or $policy =~ /RequireVersionVar/o;
- }
-
- if ($filename =~ /Makefile/o) {
- next VIO if $policy =~ /RequireVersionVar/o
- or $policy =~ /ProhibitBooleanGrep/o
- or $policy =~ /RequireInterpolationOfMetachars/o;
- }
-
- $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};
- }
+ my $d = $v->description();
+ (my $policy = $v->policy()) =~ s/Perl::Critic::Policy:://;
+ my $source = $v->source();
+
+ if ($filename =~ /test/io) {
+ next VIO if $policy =~ /RequireArgUnpacking/o
+ or $policy =~ /RequireVersionVar/o;
+ }
+
+ if ($filename =~ /Makefile/o) {
+ next VIO if $policy =~ /RequireVersionVar/o
+ or $policy =~ /ProhibitBooleanGrep/o
+ or $policy =~ /RequireInterpolationOfMetachars/o;
+ }
+
+ $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',
- },
+ (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";
- }
- }
+ 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 $count = 1;
for my $filename (sort @testfiles) {
- -e $filename or die qq{Could not find "$filename"!};
+ -e $filename or die qq{Could not find "$filename"!};
- my @vio = $critic->critique($filename);
- my $vios = 0;
+ 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;
-
- ## Specific 'test files' exceptions
- next if $policy =~ /Modules::RequireVersionVar/o;
-
- ## Skip other specific items:
- for my $k (sort keys %ok) {
- next unless $f =~ /$k/;
- for (@{$ok{$k}{OK}}) {
- next VIO if $d =~ $_;
- }
- }
-
- $vios++;
- my $l = $v->location();
- my $line = $l->[0];
- my $pbp = $v->explanation();
- diag "\nFile: $f (line $line)\n";
- diag "Vio: $d\n";
- diag "Policy: $policy\n";
- diag "Source: $source\n";
- diag "PBP says: $pbp\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};
- }
+ 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;
+
+ ## Specific 'test files' exceptions
+ next if $policy =~ /Modules::RequireVersionVar/o;
+
+ ## Skip other specific items:
+ for my $k (sort keys %ok) {
+ next unless $f =~ /$k/;
+ for (@{$ok{$k}{OK}}) {
+ next VIO if $d =~ $_;
+ }
+ }
+
+ $vios++;
+ my $l = $v->location();
+ my $line = $l->[0];
+ my $pbp = $v->explanation();
+ diag "\nFile: $f (line $line)\n";
+ diag "Vio: $d\n";
+ diag "Policy: $policy\n";
+ diag "Source: $source\n";
+ diag "PBP says: $pbp\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');
use Test::More;
if (!$ENV{RELEASE_TESTING}) {
- plan (skip_all => 'Test skipped unless environment variable RELEASE_TESTING is set');
+ plan (skip_all => 'Test skipped unless environment variable RELEASE_TESTING is set');
}
else {
- plan tests => 2;
+ plan tests => 2;
}
my $PODVERSION = '0.95';
eval {
- require Test::Pod;
- Test::Pod->import;
+ 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');
+ 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;
+ 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$}, ## no critic (ProhibitFixedStringMatches)
- qr{^driver$}, ## no critic (ProhibitFixedStringMatches)
- qr{^constant$}, ## no critic (ProhibitFixedStringMatches)
- ];
- pod_coverage_ok('check_postgres', {trustme => $trusted_names}, 'check_postgres.pl pod coverage okay');
+ if ($@ or $Test::Pod::Coverage::VERSION < $PODCOVERVERSION) {
+ skip "Test::Pod::Coverage $PODCOVERVERSION is required", 1;
+ }
+
+ my $trusted_names =
+ [
+ qr{^CLONE$}, ## no critic (ProhibitFixedStringMatches)
+ qr{^driver$}, ## no critic (ProhibitFixedStringMatches)
+ qr{^constant$}, ## no critic (ProhibitFixedStringMatches)
+ ];
+ pod_coverage_ok('check_postgres', {trustme => $trusted_names}, 'check_postgres.pl pod coverage okay');
}
my (@testfiles, $fh);
if (!$ENV{RELEASE_TESTING}) {
- plan (skip_all => 'Test skipped unless environment variable RELEASE_TESTING is set');
+ plan (skip_all => 'Test skipped unless environment variable RELEASE_TESTING is set');
}
elsif (!eval { require Text::SpellChecker; 1 }) {
- plan skip_all => 'Could not find Text::SpellChecker';
+ plan skip_all => 'Could not find Text::SpellChecker';
}
else {
- opendir my $dir, 't' or die qq{Could not open directory 't': $!\n};
- @testfiles = map { "t/$_" } grep { /^.+\.(t|pl|pm)$/ } readdir $dir;
- closedir $dir or die qq{Could not closedir "$dir": $!\n};
- plan tests => 2+@testfiles;
+ opendir my $dir, 't' or die qq{Could not open directory 't': $!\n};
+ @testfiles = map { "t/$_" } grep { /^.+\.(t|pl|pm)$/ } readdir $dir;
+ closedir $dir or die qq{Could not closedir "$dir": $!\n};
+ plan tests => 2+@testfiles;
}
my %okword;
my $filename = 'Common';
while (<DATA>) {
- if (/^## (.+):/) {
- $filename = $1;
- next;
- }
- next if /^#/ or ! /\w/;
- for (split) {
- $okword{$filename}{$_}++;
- }
+ if (/^## (.+):/) {
+ $filename = $1;
+ next;
+ }
+ next if /^#/ or ! /\w/;
+ for (split) {
+ $okword{$filename}{$_}++;
+ }
}
sub spellcheck {
- my ($desc, $text, $file) = @_;
- my $check = Text::SpellChecker->new(text => $text);
- my %badword;
- while (my $word = $check->next_word) {
- next if $okword{Common}{$word} or $okword{$file}{$word};
- $badword{$word}++;
- }
- my $count = keys %badword;
- if (! $count) {
- pass("Spell check passed for $desc");
- return;
- }
- fail ("Spell check failed for $desc. Bad words: $count");
- for (sort keys %badword) {
- diag "$_\n";
- }
- return;
+ my ($desc, $text, $file) = @_;
+ my $check = Text::SpellChecker->new(text => $text);
+ my %badword;
+ while (my $word = $check->next_word) {
+ next if $okword{Common}{$word} or $okword{$file}{$word};
+ $badword{$word}++;
+ }
+ my $count = keys %badword;
+ if (! $count) {
+ pass("Spell check passed for $desc");
+ return;
+ }
+ fail ("Spell check failed for $desc. Bad words: $count");
+ for (sort keys %badword) {
+ diag "$_\n";
+ }
+ return;
}
## The embedded POD
SKIP: {
- if (!eval { require Pod::Spell; 1 }) {
- skip 'Need Pod::Spell to test the spelling of embedded POD', 1;
- }
+ if (!eval { require Pod::Spell; 1 }) {
+ skip 'Need Pod::Spell to test the spelling of embedded POD', 1;
+ }
- for my $file (qw{check_postgres.pl}) {
- if (! -e $file) {
- fail(qq{Could not find the file "$file"!});
- }
- my $string = qx{podspell $file};
- spellcheck("POD from $file" => $string, $file);
- }
+ for my $file (qw{check_postgres.pl}) {
+ if (! -e $file) {
+ fail(qq{Could not find the file "$file"!});
+ }
+ my $string = qx{podspell $file};
+ spellcheck("POD from $file" => $string, $file);
+ }
}
## Now the comments
SKIP: {
- if (!eval { require File::Comments; 1 }) {
- skip 'Need File::Comments to test the spelling inside comments', 1+@testfiles;
- }
- my $fc = File::Comments->new();
+ if (!eval { require File::Comments; 1 }) {
+ skip 'Need File::Comments to test the spelling inside comments', 1+@testfiles;
+ }
+ my $fc = File::Comments->new();
- my @files;
- for (sort @testfiles) {
- push @files, "$_";
- }
+ my @files;
+ for (sort @testfiles) {
+ push @files, "$_";
+ }
- for my $file (@testfiles, qw{check_postgres.pl}) {
- if (! -e $file) {
- fail(qq{Could not find the file "$file"!});
- }
- my $string = $fc->comments($file);
- if (! $string) {
- fail(qq{Could not get comments inside file $file});
- next;
- }
- $string = join "\n" => @$string;
- $string =~ s/=head1.+//sm;
- spellcheck("comments from $file" => $string, $file);
- }
+ for my $file (@testfiles, qw{check_postgres.pl}) {
+ if (! -e $file) {
+ fail(qq{Could not find the file "$file"!});
+ }
+ my $string = $fc->comments($file);
+ if (! $string) {
+ fail(qq{Could not get comments inside file $file});
+ next;
+ }
+ $string = join "\n" => @$string;
+ $string =~ s/=head1.+//sm;
+ spellcheck("comments from $file" => $string, $file);
+ }
}
my $fakeschema = 'cptest';
sub new {
- my $class = shift;
- my $arg = shift || {};
- my $self = {
- started => time(),
- dbdir => $arg->{dbdir} || 'test_database_check_postgres',
- testuser => $arg->{testuser} || 'check_postgres_testing',
- };
- if (exists $arg->{default_action}) {
- $self->{action} = $arg->{default_action};
- }
- if (exists $arg->{dbnum} and $arg->{dbnum}) {
- $self->{dbdir} .= $arg->{dbnum};
- }
- return bless $self => $class;
+ my $class = shift;
+ my $arg = shift || {};
+ my $self = {
+ started => time(),
+ dbdir => $arg->{dbdir} || 'test_database_check_postgres',
+ testuser => $arg->{testuser} || 'check_postgres_testing',
+ };
+ if (exists $arg->{default_action}) {
+ $self->{action} = $arg->{default_action};
+ }
+ if (exists $arg->{dbnum} and $arg->{dbnum}) {
+ $self->{dbdir} .= $arg->{dbnum};
+ }
+ return bless $self => $class;
}
sub cleanup {
- my $self = shift;
- my $dbdir = $self->{dbdir} or die;
- for my $dirnum ('', '2', '3', '4', '5') {
- my $pidfile = "$dbdir$dirnum/data space/postmaster.pid";
- if (-e $pidfile) {
- open my $fh, '<', $pidfile or die qq{Could not open "$pidfile": $!\n};
- <$fh> =~ /^(\d+)/ or die qq{File "$pidfile" did not start with a number!\n};
- my $pid = $1;
- close $fh or die qq{Could not close "$pidfile": $!\n};
- kill 15 => $pid;
- sleep 1;
- if (kill 0 => $pid) {
- kill 9 => $pid;
- }
- }
- my $symlink = "/tmp/cptesting_socket$dirnum";
- if (-l $symlink) {
- unlink $symlink;
- }
- }
-
- return;
+ my $self = shift;
+ my $dbdir = $self->{dbdir} or die;
+ for my $dirnum ('', '2', '3', '4', '5') {
+ my $pidfile = "$dbdir$dirnum/data space/postmaster.pid";
+ if (-e $pidfile) {
+ open my $fh, '<', $pidfile or die qq{Could not open "$pidfile": $!\n};
+ <$fh> =~ /^(\d+)/ or die qq{File "$pidfile" did not start with a number!\n};
+ my $pid = $1;
+ close $fh or die qq{Could not close "$pidfile": $!\n};
+ kill 15 => $pid;
+ sleep 1;
+ if (kill 0 => $pid) {
+ kill 9 => $pid;
+ }
+ }
+ my $symlink = "/tmp/cptesting_socket$dirnum";
+ if (-l $symlink) {
+ unlink $symlink;
+ }
+ }
+
+ return;
}
sub test_database_handle {
- ## Request for a database handle: create and startup DB as needed
-
- my $self = shift;
- my $arg = shift || {};
- $arg->{dbname} ||= $self->{dbname} || 'postgres';
-
- ref $arg eq 'HASH' or die qq{Must pass a hashref (or nothing) to test_database_handle\n};
-
- ## Create the test database directory if it does not exist
- my $dbdir = $arg->{dbdir} || $self->{dbdir};
- if (! -d $dbdir) {
-
- -e $dbdir and die qq{Oops: I cannot create "$dbdir", there is already a file there!\n};
-
- Test::More::diag qq{Creating database in directory "$dbdir"\n};
-
- mkdir $dbdir;
-
- my $initdb
- = $ENV{PGINITDB} ? $ENV{PGINITDB}
- : $ENV{PGBINDIR} ? "$ENV{PGBINDIR}/initdb"
- : 'initdb';
-
- $com = qq{LC_ALL=en LANG=C $initdb --locale=C -E UTF8 -D "$dbdir/data space" 2>&1};
- eval {
- $info = qx{$com};
- };
- if ($@) {
- die qq{Failed to run "$com": error was $@\n};
- }
-
- ## Modify the postgresql.conf
- my $cfile = "$dbdir/data space/postgresql.conf";
- open my $cfh, '>>', $cfile or die qq{Could not open "$cfile": $!\n};
- print $cfh qq{\n\n## check_postgres.pl testing parameters\n};
- print $cfh qq{listen_addresses = ''\n};
- print $cfh qq{max_connections = 10\n};
-
- ## Grab the version for finicky items
- if (qx{$initdb --version} !~ /(\d+)\.(\d+)/) {
- die qq{Could not determine the version of initdb in use!\n};
- }
- my ($imaj,$imin) = ($1,$2);
-
- ## <= 8.0
- if ($imaj < 8 or ($imaj==8 and $imin <= 1)) {
- print $cfh qq{stats_command_string = on\n};
- }
-
- ## >= 8.1
- if ($imaj > 8 or ($imaj==8 and $imin >= 1)) {
- print $cfh qq{autovacuum = off\n};
- print $cfh qq{max_prepared_transactions = 5\n};
- }
-
- ## >= 8.3
- if ($imaj > 8 or ($imaj==8 and $imin >= 3)) {
- print $cfh qq{logging_collector = off\n};
- }
-
- ## <= 8.2
- if ($imaj < 8 or ($imaj==8 and $imin <= 2)) {
- print $cfh qq{redirect_stderr = off\n};
- print $cfh qq{stats_block_level = on\n};
- print $cfh qq{stats_row_level = on\n};
- }
-
- ## <= 8.3
- if ($imaj < 8 or ($imaj==8 and $imin <= 3)) {
- print $cfh qq{max_fsm_pages = 99999\n};
- }
-
- print $cfh "\n";
- close $cfh or die qq{Could not close "$cfile": $!\n};
-
- mkdir "$dbdir/data space/socket";
- }
-
- ## See if the database is already running.
- my $needs_startup = 0;
-
- my $pidfile = "$dbdir/data space/postmaster.pid";
- if (! -e $pidfile) {
- $needs_startup = 1;
- }
- else {
- open my $fh, '<', $pidfile or die qq{Could not open "$pidfile": $!\n};
- <$fh> =~ /^(\d+)/ or die qq{Invalid information in file "$pidfile", expected a PID\n};
- my $pid = $1;
- close $fh or die qq{Could not open "$pidfile": $!\n};
- ## Send a signal to see if this PID is alive
- $count = kill 0 => $pid;
- if ($count == 0) {
- Test::More::diag qq{Found a PID file, but no postmaster. Removing file "$pidfile"\n};
- unlink $pidfile;
- $needs_startup = 1;
- }
- }
-
- my $pg_ctl
- = $ENV{PG_CTL} ? $ENV{PG_CTL}
- : $ENV{PGBINDIR} ? "$ENV{PGBINDIR}/pg_ctl"
- : 'pg_ctl';
-
- if (qx{$pg_ctl --version} !~ /(\d+)\.(\d+)/) {
- die qq{Could not determine the version of pg_ctl in use!\n};
- }
- my ($maj,$min) = ($1,$2);
-
- my $here = cwd();
-
- if ($needs_startup) {
-
- my $logfile = "$dbdir/pg.log";
-
- unlink $logfile;
-
- my $sockdir = 'socket';
- if ($maj < 8 or ($maj==8 and $min < 1)) {
- $sockdir = qq{"$dbdir/data space/socket"};
- }
-
- $com = qq{LC_ALL=en LANG=C $pg_ctl -o '-k $sockdir' -l $logfile -D "$dbdir/data space" start};
- eval {
- $info = qx{$com};
- };
- if ($@) {
- die qq{Failed to run "$com": got $!\n};
- }
-
- my $bail_out = 100;
- my $found = 0;
- open my $logfh, '<', $logfile or die qq{Could not open "$logfile": $!\n};
- SCAN: {
- seek $logfh, 0, 0;
- while (<$logfh>) {
- if (/ready to accept connections/ or /database system is ready/) {
- last SCAN;
- }
- }
- if (!$bail_out--) {
- die qq{Gave up waiting for $logfile to say it was ready\n};
- }
- sleep 0.1;
- redo;
- }
- close $logfh or die qq{Could not close "$logfile": $!\n};
-
- if ($maj < 8 or ($maj==8 and $min < 1)) {
- my $host = "$here/$dbdir/data space/socket";
- my $COM;
-
- $SQL = q{SELECT * FROM pg_database WHERE datname = 'postgres'};
- my $res = qx{psql -Ax -qt -d template1 -q -h "$host" -c "$SQL"};
- if ($res !~ /postgres/) {
- $COM = qq{psql -d template1 -q -h "$host" -c "CREATE DATABASE postgres"};
- system $COM;
- }
-
- my $newuser = $self->{testuser};
- $SQL = qq{SELECT * FROM pg_user WHERE usename = '$newuser'};
- $res = qx{psql -Ax -qt -d template1 -q -h "$host" -c "$SQL"};
- if ($res !~ /$newuser/) {
- $COM = qq{psql -d template1 -q -h "$host" -c "CREATE USER $newuser"};
- system $COM;
- $SQL = q{UPDATE pg_shadow SET usesuper='t' WHERE usename = 'check_postgres_testing'};
- $COM = qq{psql -d postgres -q -h "$host" -c "$SQL"};
- system $COM;
- }
-
- for my $lang (qw/plpgsql plperlu/) {
- $SQL = qq{SELECT * FROM pg_language WHERE lanname = '$lang'};
- $res = qx{psql -Ax -qt -d postgres -q -h "$host" -c "$SQL"};
- if ($res !~ /$lang/) {
- my $createlang = $ENV{PGBINDIR} ? "$ENV{PGBINDIR}/createlang" : 'pg_ctl';
- $COM = qq{$createlang -d postgres -h "$host" $lang};
- system $COM;
- }
- }
- }
-
- } ## end of needs startup
-
- my $dbhost = $self->{dbhost} = "$here/$dbdir/data space/socket";
- $dbhost =~ s/^ /\\ /;
- $dbhost =~ s/([^\\]) /$1\\ /g;
-
- ## Workaround for bug where psql -h /some/long/path fails
- if (length($dbhost) > $MAX_HOST_PATH) {
- my $newname = '/tmp/cptesting_socket';
- if ($self->{dbdir} =~ /(\d+)$/) {
- $newname .= $1;
- }
- if (! -e $newname) {
- warn "Creating new symlink socket at $newname\n";
- (my $oldname = $dbhost) =~ s/\\//g;
- symlink $oldname => $newname;
- }
- $dbhost = $self->{shorthost} = $newname;
- }
-
- $self->{dbname} ||= 'postgres';
- my $dsn = qq{dbi:Pg:host=$dbhost;dbname=$self->{dbname}};
- my $dbuser = $self->{testuser};
- my @superdsn = ($dsn, $dbuser, '', {AutoCommit=>0,RaiseError=>1,PrintError=>0});
- my $dbh;
- eval {
- $dbh = DBI->connect(@superdsn);
- };
- if ($@) {
- if ($@ =~ /role .+ does not exist/) {
- ## We want the current user, not whatever this is set to:
- delete $ENV{PGUSER};
- my @tempdsn = ($dsn, '', '', {AutoCommit=>1,RaiseError=>1,PrintError=>0});
- my $tempdbh = DBI->connect(@tempdsn);
- $tempdbh->do("CREATE USER $dbuser SUPERUSER");
- $tempdbh->disconnect();
- $dbh = DBI->connect(@superdsn);
- }
- elsif ($@ =~ /database "postgres" does not exist/) {
- ## We want the current user, not whatever this is set to:
- (my $tempdsn = $dsn) =~ s/postgres/template1/;
- my @tempdsn = ($tempdsn, '', '', {AutoCommit=>1,RaiseError=>1,PrintError=>0});
- my $tempdbh = DBI->connect(@tempdsn);
- $tempdbh->do('CREATE DATABASE postgres');
- $tempdbh->disconnect();
- $dbh = DBI->connect(@superdsn);
- }
- else {
- die "Could not connect: $@\n";
- }
- }
- $dbh->ping() or die qq{Failed to ping!\n};
-
- return $dbh if $arg->{quickreturn};
-
- $dbh->{AutoCommit} = 1;
- $dbh->{RaiseError} = 0;
- if ($maj > 8 or ($maj==8 and $min >= 1)) {
- $SQL = q{SELECT count(*) FROM pg_user WHERE usename = ?};
- $sth = $dbh->prepare($SQL);
- $sth->execute($dbuser);
- $count = $sth->fetchall_arrayref()->[0][0];
- if (!$count) {
- $dbh->do("CREATE USER $dbuser SUPERUSER");
- }
- }
- $dbh->do('CREATE DATABASE beedeebeedee');
- $dbh->do('CREATE DATABASE ardala');
- $dbh->do('CREATE LANGUAGE plpgsql');
- $dbh->do('CREATE LANGUAGE plperlu');
- $dbh->{AutoCommit} = 0;
- $dbh->{RaiseError} = 1;
-
- if (! exists $self->{keep_old_schema}) {
- $SQL = 'SELECT count(*) FROM pg_namespace WHERE nspname = ' . $dbh->quote($fakeschema);
- my $count = $dbh->selectall_arrayref($SQL)->[0][0];
- if ($count) {
- $dbh->{Warn} = 0;
- $dbh->do("DROP SCHEMA $fakeschema CASCADE");
- $dbh->{Warn} = 1;
- }
- }
-
- if ($arg->{dbname} ne $self->{dbname}) {
- my $tmp_dsn = $dsn;
- $tmp_dsn =~ s/dbname=\w+/dbname=$arg->{dbname}/;
- my $tmp_dbh;
- eval { $tmp_dbh = DBI->connect($tmp_dsn, @superdsn[1..$#superdsn]) };
- if ($@) {
- local($dbh->{AutoCommit}) = 1;
- $dbh->do('CREATE DATABASE ' . $arg->{dbname});
- eval { $tmp_dbh = DBI->connect($tmp_dsn, @superdsn[1..$#superdsn]) };
- die $@ if $@;
- }
- $dbh->disconnect;
- $dbh = $tmp_dbh;
- $self->{dbname} = $arg->{dbname};
- }
-
- $self->{dbh} = $dbh;
- $self->{dsn} = $dsn;
- $self->{superdsn} = \@superdsn;
-
- ## Sanity check
- $dbh->do("ALTER USER $dbuser SET search_path = public");
- $dbh->do('SET search_path = public');
- $dbh->do('COMMIT');
-
- return $dbh;
+ ## Request for a database handle: create and startup DB as needed
+
+ my $self = shift;
+ my $arg = shift || {};
+ $arg->{dbname} ||= $self->{dbname} || 'postgres';
+
+ ref $arg eq 'HASH' or die qq{Must pass a hashref (or nothing) to test_database_handle\n};
+
+ ## Create the test database directory if it does not exist
+ my $dbdir = $arg->{dbdir} || $self->{dbdir};
+ if (! -d $dbdir) {
+
+ -e $dbdir and die qq{Oops: I cannot create "$dbdir", there is already a file there!\n};
+
+ Test::More::diag qq{Creating database in directory "$dbdir"\n};
+
+ mkdir $dbdir;
+
+ my $initdb
+ = $ENV{PGINITDB} ? $ENV{PGINITDB}
+ : $ENV{PGBINDIR} ? "$ENV{PGBINDIR}/initdb"
+ : 'initdb';
+
+ $com = qq{LC_ALL=en LANG=C $initdb --locale=C -E UTF8 -D "$dbdir/data space" 2>&1};
+ eval {
+ $info = qx{$com};
+ };
+ if ($@) {
+ die qq{Failed to run "$com": error was $@\n};
+ }
+
+ ## Modify the postgresql.conf
+ my $cfile = "$dbdir/data space/postgresql.conf";
+ open my $cfh, '>>', $cfile or die qq{Could not open "$cfile": $!\n};
+ print $cfh qq{\n\n## check_postgres.pl testing parameters\n};
+ print $cfh qq{listen_addresses = ''\n};
+ print $cfh qq{max_connections = 10\n};
+
+ ## Grab the version for finicky items
+ if (qx{$initdb --version} !~ /(\d+)\.(\d+)/) {
+ die qq{Could not determine the version of initdb in use!\n};
+ }
+ my ($imaj,$imin) = ($1,$2);
+
+ ## <= 8.0
+ if ($imaj < 8 or ($imaj==8 and $imin <= 1)) {
+ print $cfh qq{stats_command_string = on\n};
+ }
+
+ ## >= 8.1
+ if ($imaj > 8 or ($imaj==8 and $imin >= 1)) {
+ print $cfh qq{autovacuum = off\n};
+ print $cfh qq{max_prepared_transactions = 5\n};
+ }
+
+ ## >= 8.3
+ if ($imaj > 8 or ($imaj==8 and $imin >= 3)) {
+ print $cfh qq{logging_collector = off\n};
+ }
+
+ ## <= 8.2
+ if ($imaj < 8 or ($imaj==8 and $imin <= 2)) {
+ print $cfh qq{redirect_stderr = off\n};
+ print $cfh qq{stats_block_level = on\n};
+ print $cfh qq{stats_row_level = on\n};
+ }
+
+ ## <= 8.3
+ if ($imaj < 8 or ($imaj==8 and $imin <= 3)) {
+ print $cfh qq{max_fsm_pages = 99999\n};
+ }
+
+ print $cfh "\n";
+ close $cfh or die qq{Could not close "$cfile": $!\n};
+
+ mkdir "$dbdir/data space/socket";
+ }
+
+ ## See if the database is already running.
+ my $needs_startup = 0;
+
+ my $pidfile = "$dbdir/data space/postmaster.pid";
+ if (! -e $pidfile) {
+ $needs_startup = 1;
+ }
+ else {
+ open my $fh, '<', $pidfile or die qq{Could not open "$pidfile": $!\n};
+ <$fh> =~ /^(\d+)/ or die qq{Invalid information in file "$pidfile", expected a PID\n};
+ my $pid = $1;
+ close $fh or die qq{Could not open "$pidfile": $!\n};
+ ## Send a signal to see if this PID is alive
+ $count = kill 0 => $pid;
+ if ($count == 0) {
+ Test::More::diag qq{Found a PID file, but no postmaster. Removing file "$pidfile"\n};
+ unlink $pidfile;
+ $needs_startup = 1;
+ }
+ }
+
+ my $pg_ctl
+ = $ENV{PG_CTL} ? $ENV{PG_CTL}
+ : $ENV{PGBINDIR} ? "$ENV{PGBINDIR}/pg_ctl"
+ : 'pg_ctl';
+
+ if (qx{$pg_ctl --version} !~ /(\d+)\.(\d+)/) {
+ die qq{Could not determine the version of pg_ctl in use!\n};
+ }
+ my ($maj,$min) = ($1,$2);
+
+ my $here = cwd();
+
+ if ($needs_startup) {
+
+ my $logfile = "$dbdir/pg.log";
+
+ unlink $logfile;
+
+ my $sockdir = 'socket';
+ if ($maj < 8 or ($maj==8 and $min < 1)) {
+ $sockdir = qq{"$dbdir/data space/socket"};
+ }
+
+ $com = qq{LC_ALL=en LANG=C $pg_ctl -o '-k $sockdir' -l $logfile -D "$dbdir/data space" start};
+ eval {
+ $info = qx{$com};
+ };
+ if ($@) {
+ die qq{Failed to run "$com": got $!\n};
+ }
+
+ my $bail_out = 100;
+ my $found = 0;
+ open my $logfh, '<', $logfile or die qq{Could not open "$logfile": $!\n};
+ SCAN: {
+ seek $logfh, 0, 0;
+ while (<$logfh>) {
+ if (/ready to accept connections/ or /database system is ready/) {
+ last SCAN;
+ }
+ }
+ if (!$bail_out--) {
+ die qq{Gave up waiting for $logfile to say it was ready\n};
+ }
+ sleep 0.1;
+ redo;
+ }
+ close $logfh or die qq{Could not close "$logfile": $!\n};
+
+ if ($maj < 8 or ($maj==8 and $min < 1)) {
+ my $host = "$here/$dbdir/data space/socket";
+ my $COM;
+
+ $SQL = q{SELECT * FROM pg_database WHERE datname = 'postgres'};
+ my $res = qx{psql -Ax -qt -d template1 -q -h "$host" -c "$SQL"};
+ if ($res !~ /postgres/) {
+ $COM = qq{psql -d template1 -q -h "$host" -c "CREATE DATABASE postgres"};
+ system $COM;
+ }
+
+ my $newuser = $self->{testuser};
+ $SQL = qq{SELECT * FROM pg_user WHERE usename = '$newuser'};
+ $res = qx{psql -Ax -qt -d template1 -q -h "$host" -c "$SQL"};
+ if ($res !~ /$newuser/) {
+ $COM = qq{psql -d template1 -q -h "$host" -c "CREATE USER $newuser"};
+ system $COM;
+ $SQL = q{UPDATE pg_shadow SET usesuper='t' WHERE usename = 'check_postgres_testing'};
+ $COM = qq{psql -d postgres -q -h "$host" -c "$SQL"};
+ system $COM;
+ }
+
+ for my $lang (qw/plpgsql plperlu/) {
+ $SQL = qq{SELECT * FROM pg_language WHERE lanname = '$lang'};
+ $res = qx{psql -Ax -qt -d postgres -q -h "$host" -c "$SQL"};
+ if ($res !~ /$lang/) {
+ my $createlang = $ENV{PGBINDIR} ? "$ENV{PGBINDIR}/createlang" : 'pg_ctl';
+ $COM = qq{$createlang -d postgres -h "$host" $lang};
+ system $COM;
+ }
+ }
+ }
+
+ } ## end of needs startup
+
+ my $dbhost = $self->{dbhost} = "$here/$dbdir/data space/socket";
+ $dbhost =~ s/^ /\\ /;
+ $dbhost =~ s/([^\\]) /$1\\ /g;
+
+ ## Workaround for bug where psql -h /some/long/path fails
+ if (length($dbhost) > $MAX_HOST_PATH) {
+ my $newname = '/tmp/cptesting_socket';
+ if ($self->{dbdir} =~ /(\d+)$/) {
+ $newname .= $1;
+ }
+ if (! -e $newname) {
+ warn "Creating new symlink socket at $newname\n";
+ (my $oldname = $dbhost) =~ s/\\//g;
+ symlink $oldname => $newname;
+ }
+ $dbhost = $self->{shorthost} = $newname;
+ }
+
+ $self->{dbname} ||= 'postgres';
+ my $dsn = qq{dbi:Pg:host=$dbhost;dbname=$self->{dbname}};
+ my $dbuser = $self->{testuser};
+ my @superdsn = ($dsn, $dbuser, '', {AutoCommit=>0,RaiseError=>1,PrintError=>0});
+ my $dbh;
+ eval {
+ $dbh = DBI->connect(@superdsn);
+ };
+ if ($@) {
+ if ($@ =~ /role .+ does not exist/) {
+ ## We want the current user, not whatever this is set to:
+ delete $ENV{PGUSER};
+ my @tempdsn = ($dsn, '', '', {AutoCommit=>1,RaiseError=>1,PrintError=>0});
+ my $tempdbh = DBI->connect(@tempdsn);
+ $tempdbh->do("CREATE USER $dbuser SUPERUSER");
+ $tempdbh->disconnect();
+ $dbh = DBI->connect(@superdsn);
+ }
+ elsif ($@ =~ /database "postgres" does not exist/) {
+ ## We want the current user, not whatever this is set to:
+ (my $tempdsn = $dsn) =~ s/postgres/template1/;
+ my @tempdsn = ($tempdsn, '', '', {AutoCommit=>1,RaiseError=>1,PrintError=>0});
+ my $tempdbh = DBI->connect(@tempdsn);
+ $tempdbh->do('CREATE DATABASE postgres');
+ $tempdbh->disconnect();
+ $dbh = DBI->connect(@superdsn);
+ }
+ else {
+ die "Could not connect: $@\n";
+ }
+ }
+ $dbh->ping() or die qq{Failed to ping!\n};
+
+ return $dbh if $arg->{quickreturn};
+
+ $dbh->{AutoCommit} = 1;
+ $dbh->{RaiseError} = 0;
+ if ($maj > 8 or ($maj==8 and $min >= 1)) {
+ $SQL = q{SELECT count(*) FROM pg_user WHERE usename = ?};
+ $sth = $dbh->prepare($SQL);
+ $sth->execute($dbuser);
+ $count = $sth->fetchall_arrayref()->[0][0];
+ if (!$count) {
+ $dbh->do("CREATE USER $dbuser SUPERUSER");
+ }
+ }
+ $dbh->do('CREATE DATABASE beedeebeedee');
+ $dbh->do('CREATE DATABASE ardala');
+ $dbh->do('CREATE LANGUAGE plpgsql');
+ $dbh->do('CREATE LANGUAGE plperlu');
+ $dbh->{AutoCommit} = 0;
+ $dbh->{RaiseError} = 1;
+
+ if (! exists $self->{keep_old_schema}) {
+ $SQL = 'SELECT count(*) FROM pg_namespace WHERE nspname = ' . $dbh->quote($fakeschema);
+ my $count = $dbh->selectall_arrayref($SQL)->[0][0];
+ if ($count) {
+ $dbh->{Warn} = 0;
+ $dbh->do("DROP SCHEMA $fakeschema CASCADE");
+ $dbh->{Warn} = 1;
+ }
+ }
+
+ if ($arg->{dbname} ne $self->{dbname}) {
+ my $tmp_dsn = $dsn;
+ $tmp_dsn =~ s/dbname=\w+/dbname=$arg->{dbname}/;
+ my $tmp_dbh;
+ eval { $tmp_dbh = DBI->connect($tmp_dsn, @superdsn[1..$#superdsn]) };
+ if ($@) {
+ local($dbh->{AutoCommit}) = 1;
+ $dbh->do('CREATE DATABASE ' . $arg->{dbname});
+ eval { $tmp_dbh = DBI->connect($tmp_dsn, @superdsn[1..$#superdsn]) };
+ die $@ if $@;
+ }
+ $dbh->disconnect;
+ $dbh = $tmp_dbh;
+ $self->{dbname} = $arg->{dbname};
+ }
+
+ $self->{dbh} = $dbh;
+ $self->{dsn} = $dsn;
+ $self->{superdsn} = \@superdsn;
+
+ ## Sanity check
+ $dbh->do("ALTER USER $dbuser SET search_path = public");
+ $dbh->do('SET search_path = public');
+ $dbh->do('COMMIT');
+
+ return $dbh;
} ## end of test_database_handle
sub recreate_database {
- ## Given a database handle, comepletely recreate the current database
+ ## Given a database handle, comepletely recreate the current database
- my ($self,$dbh) = @_;
+ my ($self,$dbh) = @_;
- my $dbname = $dbh->{pg_db};
+ my $dbname = $dbh->{pg_db};
- $dbname eq 'template1' and die qq{Cannot recreate from template1!\n};
+ $dbname eq 'template1' and die qq{Cannot recreate from template1!\n};
- my $user = $dbh->{pg_user};
- my $host = $dbh->{pg_host};
- my $port = $dbh->{pg_port};
+ my $user = $dbh->{pg_user};
+ my $host = $dbh->{pg_host};
+ my $port = $dbh->{pg_port};
- $dbh->disconnect();
+ $dbh->disconnect();
- my $dsn = "DBI:Pg:dbname=template1;port=$port;host=$host";
+ my $dsn = "DBI:Pg:dbname=template1;port=$port;host=$host";
- $dbh = DBI->connect($dsn, $user, '', {AutoCommit=>1, RaiseError=>1, PrintError=>0});
+ $dbh = DBI->connect($dsn, $user, '', {AutoCommit=>1, RaiseError=>1, PrintError=>0});
- $dbh->do("DROP DATABASE $dbname");
- $dbh->do("CREATE DATABASE $dbname");
+ $dbh->do("DROP DATABASE $dbname");
+ $dbh->do("CREATE DATABASE $dbname");
- $dbh->disconnect();
+ $dbh->disconnect();
- $dsn = "DBI:Pg:dbname=$dbname;port=$port;host=$host";
+ $dsn = "DBI:Pg:dbname=$dbname;port=$port;host=$host";
- $dbh = DBI->connect($dsn, $user, '', {AutoCommit=>0, RaiseError=>1, PrintError=>0});
+ $dbh = DBI->connect($dsn, $user, '', {AutoCommit=>0, RaiseError=>1, PrintError=>0});
- return $dbh;
+ return $dbh;
} ## end of recreate_database
sub get_command {
- return run('get_command', @_);
+ return run('get_command', @_);
}
sub run {
- my $self = shift;
- my $get;
- if ($self eq 'get_command') {
- $get = $self;
- $self = shift;
- }
- my @arg = @_;
- my $extra = pop @arg || '';
- my $action = @arg ? $arg[0] : $self->{action} || die "First arg must be the command\n";
-
- my $double = $action =~ s/DB2// ? 1 : 0;
-
- my $dbhost = $self->{shorthost} || $self->{dbhost} || die 'No dbhost?';
- my $dbuser = $self->{testuser} || die 'No testuser?';
- my $dbname = $self->{dbname} || die 'No dbname?';
- my $com = qq{perl check_postgres.pl --no-check_postgresrc --action=$action --dbhost="$dbhost" --dbuser=$dbuser};
- if ($extra =~ s/--nodbname//) {
- }
- elsif ($extra !~ /dbname=/) {
- $com .= " --dbname=$dbname";
- }
-
- if ($double) {
- $com .= qq{ --dbhost2="$dbhost" --dbname2=ardala --dbuser2=$dbuser};
- }
-
- $extra and $com .= " $extra";
-
- $DEBUG and warn "DEBUG RUN: $com\n";
-
- return $com if $get;
- my $result;
- eval {
- $result = qx{$com 2>&1};
- };
- if ($@) {
- return "TESTERROR: $@";
- }
-
- return $result;
+ my $self = shift;
+ my $get;
+ if ($self eq 'get_command') {
+ $get = $self;
+ $self = shift;
+ }
+ my @arg = @_;
+ my $extra = pop @arg || '';
+ my $action = @arg ? $arg[0] : $self->{action} || die "First arg must be the command\n";
+
+ my $double = $action =~ s/DB2// ? 1 : 0;
+
+ my $dbhost = $self->{shorthost} || $self->{dbhost} || die 'No dbhost?';
+ my $dbuser = $self->{testuser} || die 'No testuser?';
+ my $dbname = $self->{dbname} || die 'No dbname?';
+ my $com = qq{perl check_postgres.pl --no-check_postgresrc --action=$action --dbhost="$dbhost" --dbuser=$dbuser};
+ if ($extra =~ s/--nodbname//) {
+ }
+ elsif ($extra !~ /dbname=/) {
+ $com .= " --dbname=$dbname";
+ }
+
+ if ($double) {
+ $com .= qq{ --dbhost2="$dbhost" --dbname2=ardala --dbuser2=$dbuser};
+ }
+
+ $extra and $com .= " $extra";
+
+ $DEBUG and warn "DEBUG RUN: $com\n";
+
+ return $com if $get;
+ my $result;
+ eval {
+ $result = qx{$com 2>&1};
+ };
+ if ($@) {
+ return "TESTERROR: $@";
+ }
+
+ return $result;
} ## end of run
sub get_user {
- my $self = shift;
- return $self->{testuser};
+ my $self = shift;
+ return $self->{testuser};
}
sub get_dbhost {
- my $self = shift;
- return $self->{dbhost};
+ my $self = shift;
+ return $self->{dbhost};
}
sub get_host {
- my $self = shift;
- return $self->{shorthost} || $self->{dbhost};
+ my $self = shift;
+ return $self->{shorthost} || $self->{dbhost};
}
sub get_shorthost {
- my $self = shift;
- return $self->{shorthost};
+ my $self = shift;
+ return $self->{shorthost};
}
sub get_dbname {
- my $self = shift;
- return $self->{dbname};
+ my $self = shift;
+ return $self->{dbname};
}
sub get_dbh {
- my $self = shift;
- return $self->{dbh} || die;
+ my $self = shift;
+ return $self->{dbh} || die;
}
sub get_fresh_dbh {
- my $self = shift;
- my $opt = shift || {};
+ my $self = shift;
+ my $opt = shift || {};
- my $superdsn = $self->{superdsn} || die;
+ my $superdsn = $self->{superdsn} || die;
- if ($opt->{dbname}) {
- $superdsn->[0] =~ s/dbname=\w+/dbname=$opt->{dbname}/;
- }
+ if ($opt->{dbname}) {
+ $superdsn->[0] =~ s/dbname=\w+/dbname=$opt->{dbname}/;
+ }
- my $dbh = DBI->connect(@$superdsn);
+ my $dbh = DBI->connect(@$superdsn);
- return $dbh;
+ return $dbh;
}
sub create_fake_pg_table {
- ## Dangerous: do not try this at home!
-
- my $self = shift;
- my $name = shift || die;
- my $args = shift || '';
- my $dbh = $self->{dbh} || die;
- my $dbuser = $self->{testuser} || die;
- if ($self->schema_exists($dbh,$fakeschema)) {
- $self->drop_table_if_exists($fakeschema,$name);
- }
- else {
- $dbh->do("CREATE SCHEMA $fakeschema");
- }
-
- my $funcargs = '';
- if ($args) {
- ($funcargs = $args) =~ s/\w+/NULL/g;
- $funcargs = qq{($funcargs)};
- }
-
- $dbh->do("CREATE TABLE $fakeschema.$name AS SELECT * FROM $name$funcargs LIMIT 0");
-
- if ($args) {
- $self->drop_function_if_exists($fakeschema,$name,$args);
- $dbh->do("CREATE FUNCTION $fakeschema.$name($args) RETURNS SETOF TEXT LANGUAGE SQL AS 'SELECT * FROM $fakeschema.$name; '");
- }
-
- $dbh->do("ALTER USER $dbuser SET search_path = $fakeschema, public, pg_catalog");
- $dbh->commit();
- return;
+ ## Dangerous: do not try this at home!
+
+ my $self = shift;
+ my $name = shift || die;
+ my $args = shift || '';
+ my $dbh = $self->{dbh} || die;
+ my $dbuser = $self->{testuser} || die;
+ if ($self->schema_exists($dbh,$fakeschema)) {
+ $self->drop_table_if_exists($fakeschema,$name);
+ }
+ else {
+ $dbh->do("CREATE SCHEMA $fakeschema");
+ }
+
+ my $funcargs = '';
+ if ($args) {
+ ($funcargs = $args) =~ s/\w+/NULL/g;
+ $funcargs = qq{($funcargs)};
+ }
+
+ $dbh->do("CREATE TABLE $fakeschema.$name AS SELECT * FROM $name$funcargs LIMIT 0");
+
+ if ($args) {
+ $self->drop_function_if_exists($fakeschema,$name,$args);
+ $dbh->do("CREATE FUNCTION $fakeschema.$name($args) RETURNS SETOF TEXT LANGUAGE SQL AS 'SELECT * FROM $fakeschema.$name; '");
+ }
+
+ $dbh->do("ALTER USER $dbuser SET search_path = $fakeschema, public, pg_catalog");
+ $dbh->commit();
+ return;
} ## end of create_fake_pg_table
sub get_fake_schema {
- return $fakeschema;
+ return $fakeschema;
}
sub set_fake_schema {
- my $self = shift;
- my $dbh = $self->{dbh} || die;
- my $dbuser = $self->{testuser} || die;
- if (!$self->schema_exists($dbh,$fakeschema)) {
- $dbh->do("CREATE SCHEMA $fakeschema");
- }
+ my $self = shift;
+ my $dbh = $self->{dbh} || die;
+ my $dbuser = $self->{testuser} || die;
+ if (!$self->schema_exists($dbh,$fakeschema)) {
+ $dbh->do("CREATE SCHEMA $fakeschema");
+ }
- $dbh->do("ALTER USER $dbuser SET search_path = $fakeschema, public, pg_catalog");
- $dbh->commit();
- return;
+ $dbh->do("ALTER USER $dbuser SET search_path = $fakeschema, public, pg_catalog");
+ $dbh->commit();
+ return;
} ## end of set_fake_schema
sub table_exists {
- my ($self,$dbh,$table) = @_;
+ my ($self,$dbh,$table) = @_;
- $SQL = 'SELECT count(1) FROM pg_class WHERE relname = ?';
- $sth = $dbh->prepare($SQL);
- $sth->execute($table);
- my $count = $sth->fetchall_arrayref()->[0][0];
- return $count;
+ $SQL = 'SELECT count(1) FROM pg_class WHERE relname = ?';
+ $sth = $dbh->prepare($SQL);
+ $sth->execute($table);
+ my $count = $sth->fetchall_arrayref()->[0][0];
+ return $count;
} ## end of table_exists
sub schema_exists {
- my ($self,$dbh,$schema) = @_;
+ my ($self,$dbh,$schema) = @_;
- $SQL = 'SELECT count(1) FROM pg_namespace WHERE nspname = ?';
- $sth = $dbh->prepare($SQL);
- $sth->execute($schema);
- my $count = $sth->fetchall_arrayref()->[0][0];
- return $count;
+ $SQL = 'SELECT count(1) FROM pg_namespace WHERE nspname = ?';
+ $sth = $dbh->prepare($SQL);
+ $sth->execute($schema);
+ my $count = $sth->fetchall_arrayref()->[0][0];
+ return $count;
} ## end of schema_exists
sub drop_schema_if_exists {
- my ($self,$name) = @_;
- my $dbh = $self->{dbh} || die;
- $name ||= $fakeschema;
-
- if (! exists $self->{keep_old_schema}) {
- $SQL = 'SELECT count(*) FROM pg_namespace WHERE nspname = ' . $dbh->quote($name);
- my $count = $dbh->selectall_arrayref($SQL)->[0][0];
- if ($count) {
- $dbh->{Warn} = 0;
- $dbh->do("DROP SCHEMA $name CASCADE");
- $dbh->{Warn} = 1;
- $dbh->commit();
- }
- }
- return;
+ my ($self,$name) = @_;
+ my $dbh = $self->{dbh} || die;
+ $name ||= $fakeschema;
+
+ if (! exists $self->{keep_old_schema}) {
+ $SQL = 'SELECT count(*) FROM pg_namespace WHERE nspname = ' . $dbh->quote($name);
+ my $count = $dbh->selectall_arrayref($SQL)->[0][0];
+ if ($count) {
+ $dbh->{Warn} = 0;
+ $dbh->do("DROP SCHEMA $name CASCADE");
+ $dbh->{Warn} = 1;
+ $dbh->commit();
+ }
+ }
+ return;
} ## end of drop_schema_if_exists
sub drop_table_if_exists {
- my ($self,$name,$name2) = @_;
- my $dbh = $self->{dbh} || die;
-
- my $schema = '';
- if ($name2) {
- $schema = $name;
- $name = $name2;
- }
-
- my $safetable = $dbh->quote($name);
- my $safeschema = $dbh->quote($schema);
- $SQL = $schema
- ? q{SELECT count(*) FROM pg_class c JOIN pg_namespace n ON (n.oid = c.relnamespace) }.
- qq{WHERE relkind = 'r' AND nspname = $safeschema AND relname = $safetable}
- : qq{SELECT count(*) FROM pg_class WHERE relkind='r' AND relname = $safetable};
- my $count = $dbh->selectall_arrayref($SQL)->[0][0];
- if ($count) {
- $dbh->{Warn} = 0;
- $dbh->do("DROP TABLE $name CASCADE");
- $dbh->{Warn} = 1;
- $dbh->commit();
- }
- return;
+ my ($self,$name,$name2) = @_;
+ my $dbh = $self->{dbh} || die;
+
+ my $schema = '';
+ if ($name2) {
+ $schema = $name;
+ $name = $name2;
+ }
+
+ my $safetable = $dbh->quote($name);
+ my $safeschema = $dbh->quote($schema);
+ $SQL = $schema
+ ? q{SELECT count(*) FROM pg_class c JOIN pg_namespace n ON (n.oid = c.relnamespace) }.
+ qq{WHERE relkind = 'r' AND nspname = $safeschema AND relname = $safetable}
+ : qq{SELECT count(*) FROM pg_class WHERE relkind='r' AND relname = $safetable};
+ my $count = $dbh->selectall_arrayref($SQL)->[0][0];
+ if ($count) {
+ $dbh->{Warn} = 0;
+ $dbh->do("DROP TABLE $name CASCADE");
+ $dbh->{Warn} = 1;
+ $dbh->commit();
+ }
+ return;
} ## end of drop_table_if_exists
sub drop_view_if_exists {
- my ($self,$name) = @_;
- my $dbh = $self->{dbh} || die;
+ my ($self,$name) = @_;
+ my $dbh = $self->{dbh} || die;
- $SQL = q{SELECT count(*) FROM pg_class WHERE relkind='v' AND relname = } . $dbh->quote($name);
- my $count = $dbh->selectall_arrayref($SQL)->[0][0];
- if ($count) {
- $dbh->{Warn} = 0;
- $dbh->do("DROP VIEW $name");
- $dbh->{Warn} = 1;
- $dbh->commit();
- }
- return;
+ $SQL = q{SELECT count(*) FROM pg_class WHERE relkind='v' AND relname = } . $dbh->quote($name);
+ my $count = $dbh->selectall_arrayref($SQL)->[0][0];
+ if ($count) {
+ $dbh->{Warn} = 0;
+ $dbh->do("DROP VIEW $name");
+ $dbh->{Warn} = 1;
+ $dbh->commit();
+ }
+ return;
} ## end of drop_view_if_exists
sub drop_sequence_if_exists {
- my ($self,$name) = @_;
- my $dbh = $self->{dbh} || die;
+ my ($self,$name) = @_;
+ my $dbh = $self->{dbh} || die;
- $SQL = q{SELECT count(*) FROM pg_class WHERE relkind = 'S' AND relname = } . $dbh->quote($name);
- my $count = $dbh->selectall_arrayref($SQL)->[0][0];
- if ($count) {
- $dbh->do("DROP SEQUENCE $name");
- $dbh->commit();
- }
- return;
+ $SQL = q{SELECT count(*) FROM pg_class WHERE relkind = 'S' AND relname = } . $dbh->quote($name);
+ my $count = $dbh->selectall_arrayref($SQL)->[0][0];
+ if ($count) {
+ $dbh->do("DROP SEQUENCE $name");
+ $dbh->commit();
+ }
+ return;
} ## end of drop_sequence_if_exists
sub drop_function_if_exists {
- my ($self,$name,$args) = @_;
- my $dbh = $self->{dbh} || die;
+ my ($self,$name,$args) = @_;
+ my $dbh = $self->{dbh} || die;
- $SQL = q{SELECT count(*) FROM pg_proc WHERE proname = }. $dbh->quote($name);
- my $count = $dbh->selectall_arrayref($SQL)->[0][0];
- if ($count) {
- $dbh->do("DROP FUNCTION $name($args)");
- $dbh->commit();
- }
- return;
+ $SQL = q{SELECT count(*) FROM pg_proc WHERE proname = }. $dbh->quote($name);
+ my $count = $dbh->selectall_arrayref($SQL)->[0][0];
+ if ($count) {
+ $dbh->do("DROP FUNCTION $name($args)");
+ $dbh->commit();
+ }
+ return;
} ## end of drop_function_if_exists
sub fake_version {
- my $self = shift;
- my $version = shift || '9.9';
- my $dbh = $self->{dbh} || die;
- my $dbuser = $self->{testuser} || die;
+ my $self = shift;
+ my $version = shift || '9.9';
+ my $dbh = $self->{dbh} || die;
+ my $dbuser = $self->{testuser} || die;
- if (! $self->schema_exists($dbh, $fakeschema)) {
- $dbh->do("CREATE SCHEMA $fakeschema");
- }
+ if (! $self->schema_exists($dbh, $fakeschema)) {
+ $dbh->do("CREATE SCHEMA $fakeschema");
+ }
- $dbh->do(qq{
+ $dbh->do(qq{
CREATE OR REPLACE FUNCTION $fakeschema.version()
RETURNS TEXT
LANGUAGE SQL
SELECT 'PostgreSQL $version on fakefunction for check_postgres.pl testing'::text;
\$\$
});
- $dbh->do("ALTER USER $dbuser SET search_path = $fakeschema, public, pg_catalog");
- $dbh->commit();
- return;
+ $dbh->do("ALTER USER $dbuser SET search_path = $fakeschema, public, pg_catalog");
+ $dbh->commit();
+ return;
} ## end of fake version
sub fake_self_version {
- ## Look out...
-
- my $self = shift;
- my $version = shift || '9.9';
- my $file = 'check_postgres.pl';
- open my $fh, '+<', $file or die qq{Could not open "$file": $!\n};
- my $slurp;
- { local $/; $slurp = <$fh> }
- ## Remove any old versions
- $slurp =~ s/^\$VERSION = '\d+\.\d+\.\d+'.+TESTING ONLY\n//gm;
- ## Put in out new version
- $slurp =~ s/(our \$VERSION = '\d+\.\d+\.\d+';)/$1\n\$VERSION = '$version'; ## TESTING ONLY/;
- seek $fh, 0, 0;
- print $fh $slurp;
- truncate $fh, tell($fh);
- close $fh or die qq{Could not close "$file": $!\n};
- return;
+ ## Look out...
+
+ my $self = shift;
+ my $version = shift || '9.9';
+ my $file = 'check_postgres.pl';
+ open my $fh, '+<', $file or die qq{Could not open "$file": $!\n};
+ my $slurp;
+ { local $/; $slurp = <$fh> }
+ ## Remove any old versions
+ $slurp =~ s/^\$VERSION = '\d+\.\d+\.\d+'.+TESTING ONLY\n//gm;
+ ## Put in out new version
+ $slurp =~ s/(our \$VERSION = '\d+\.\d+\.\d+';)/$1\n\$VERSION = '$version'; ## TESTING ONLY/;
+ seek $fh, 0, 0;
+ print $fh $slurp;
+ truncate $fh, tell($fh);
+ close $fh or die qq{Could not close "$file": $!\n};
+ return;
} ## end of fake_self_version
sub restore_self_version {
- my $self = shift;
- my $file = 'check_postgres.pl';
- open my $fh, '+<', $file or die qq{Could not open "$file": $!\n};
- my $slurp;
- { local $/; $slurp = <$fh> }
- $slurp =~ s/^\$VERSION = .+TESTING ONLY.*\n//gm;
- seek $fh, 0, 0;
- print $fh $slurp;
- truncate $fh, tell($fh);
- close $fh or die qq{Could not close "$file": $!\n};
- return;
+ my $self = shift;
+ my $file = 'check_postgres.pl';
+ open my $fh, '+<', $file or die qq{Could not open "$file": $!\n};
+ my $slurp;
+ { local $/; $slurp = <$fh> }
+ $slurp =~ s/^\$VERSION = .+TESTING ONLY.*\n//gm;
+ seek $fh, 0, 0;
+ print $fh $slurp;
+ truncate $fh, tell($fh);
+ close $fh or die qq{Could not close "$file": $!\n};
+ return;
} ## end of restore_self_version
sub reset_path {
- my $self = shift;
- my $dbh = $self->{dbh} || die;
- my $dbuser = $self->{testuser} || die;
- $dbh->do("ALTER USER $dbuser SET search_path = public");
- $dbh->commit();
+ my $self = shift;
+ my $dbh = $self->{dbh} || die;
+ my $dbuser = $self->{testuser} || die;
+ $dbh->do("ALTER USER $dbuser SET search_path = public");
+ $dbh->commit();
} ## end of reset_path
sub drop_all_tables {
- my $self = shift;
- my $dbh = $self->{dbh} || die;
- $dbh->{Warn} = 0;
- my @info = $dbh->tables('','public','','TABLE');
- for my $tab (@info) {
- $dbh->do("DROP TABLE $tab CASCADE");
- }
- $dbh->{Warn} = 1;
- $dbh->commit();
- return;
+ my $self = shift;
+ my $dbh = $self->{dbh} || die;
+ $dbh->{Warn} = 0;
+ my @info = $dbh->tables('','public','','TABLE');
+ for my $tab (@info) {
+ $dbh->do("DROP TABLE $tab CASCADE");
+ }
+ $dbh->{Warn} = 1;
+ $dbh->commit();
+ return;
} ## end of drop_all_tables
sub database_sleep {
- my ($self,$dbh,$time) = @_;
+ my ($self,$dbh,$time) = @_;
- my $ver = $dbh->{pg_server_version};
+ my $ver = $dbh->{pg_server_version};
- if ($ver < 80200) {
- $SQL = q{CREATE OR REPLACE FUNCTION pg_sleep(float) RETURNS VOID LANGUAGE plperlu AS 'select(undef,undef,undef,shift)'};
- $dbh->do($SQL);
- $dbh->commit();
- }
- $dbh->do(qq{SELECT pg_sleep($time)});
- return;
+ if ($ver < 80200) {
+ $SQL = q{CREATE OR REPLACE FUNCTION pg_sleep(float) RETURNS VOID LANGUAGE plperlu AS 'select(undef,undef,undef,shift)'};
+ $dbh->do($SQL);
+ $dbh->commit();
+ }
+ $dbh->do(qq{SELECT pg_sleep($time)});
+ return;
} ## end of database_sleep
projects / check_postgres.git / commitdiff