aboutsummaryrefslogtreecommitdiff
path: root/src/test/perl/PostgreSQL
diff options
context:
space:
mode:
authorAndrew Dunstan <andrew@dunslane.net>2021-10-24 10:28:19 -0400
committerAndrew Dunstan <andrew@dunslane.net>2021-10-24 10:28:19 -0400
commitb3b4d8e68ae83f432f43f035c7eb481ef93e1583 (patch)
treeff4e73500b61f2235bd4e3822d8e1a1af3a37523 /src/test/perl/PostgreSQL
parent3cd9c3b921977272e6650a5efbeade4203c4bca2 (diff)
downloadpostgresql-b3b4d8e68ae83f432f43f035c7eb481ef93e1583.tar.gz
postgresql-b3b4d8e68ae83f432f43f035c7eb481ef93e1583.zip
Move Perl test modules to a better namespace
The five modules in our TAP test framework all had names in the top level namespace. This is unwise because, even though we're not exporting them to CPAN, the names can leak, for example if they are exported by the RPM build process. We therefore move the modules to the PostgreSQL::Test namespace. In the process PostgresNode is renamed to Cluster, and TestLib is renamed to Utils. PostgresVersion becomes simply PostgreSQL::Version, to avoid possible confusion about what it's the version of. Discussion: https://postgr.es/m/aede93a4-7d92-ef26-398f-5094944c2504@dunslane.net Reviewed by Erik Rijkers and Michael Paquier
Diffstat (limited to 'src/test/perl/PostgreSQL')
-rw-r--r--src/test/perl/PostgreSQL/Test/Cluster.pm2811
-rw-r--r--src/test/perl/PostgreSQL/Test/RecursiveCopy.pm157
-rw-r--r--src/test/perl/PostgreSQL/Test/SimpleTee.pm35
-rw-r--r--src/test/perl/PostgreSQL/Test/Utils.pm1007
-rw-r--r--src/test/perl/PostgreSQL/Version.pm164
5 files changed, 4174 insertions, 0 deletions
diff --git a/src/test/perl/PostgreSQL/Test/Cluster.pm b/src/test/perl/PostgreSQL/Test/Cluster.pm
new file mode 100644
index 00000000000..86eb920ea10
--- /dev/null
+++ b/src/test/perl/PostgreSQL/Test/Cluster.pm
@@ -0,0 +1,2811 @@
+
+# Copyright (c) 2021, PostgreSQL Global Development Group
+
+=pod
+
+=head1 NAME
+
+PostgreSQL::Test::Cluster - class representing PostgreSQL server instance
+
+=head1 SYNOPSIS
+
+ use PostgreSQL::Test::Cluster;
+
+ my $node = PostgreSQL::Test::Cluster->new('mynode');
+
+ # Create a data directory with initdb
+ $node->init();
+
+ # Start the PostgreSQL server
+ $node->start();
+
+ # Add a setting and restart
+ $node->append_conf('postgresql.conf', 'hot_standby = on');
+ $node->restart();
+
+ # Modify or delete an existing setting
+ $node->adjust_conf('postgresql.conf', 'max_wal_senders', '10');
+
+ # run a query with psql, like:
+ # echo 'SELECT 1' | psql -qAXt postgres -v ON_ERROR_STOP=1
+ $psql_stdout = $node->safe_psql('postgres', 'SELECT 1');
+
+ # Run psql with a timeout, capturing stdout and stderr
+ # as well as the psql exit code. Pass some extra psql
+ # options. If there's an error from psql raise an exception.
+ my ($stdout, $stderr, $timed_out);
+ my $cmdret = $node->psql('postgres', 'SELECT pg_sleep(600)',
+ stdout => \$stdout, stderr => \$stderr,
+ timeout => 180, timed_out => \$timed_out,
+ extra_params => ['--single-transaction'],
+ on_error_die => 1)
+ print "Sleep timed out" if $timed_out;
+
+ # Similar thing, more convenient in common cases
+ my ($cmdret, $stdout, $stderr) =
+ $node->psql('postgres', 'SELECT 1');
+
+ # run query every second until it returns 't'
+ # or times out
+ $node->poll_query_until('postgres', q|SELECT random() < 0.1;|')
+ or die "timed out";
+
+ # Do an online pg_basebackup
+ my $ret = $node->backup('testbackup1');
+
+ # Take a backup of a running server
+ my $ret = $node->backup_fs_hot('testbackup2');
+
+ # Take a backup of a stopped server
+ $node->stop;
+ my $ret = $node->backup_fs_cold('testbackup3')
+
+ # Restore it to create a new independent node (not a replica)
+ my $other_node = PostgreSQL::Test::Cluster->new('mycopy');
+ $other_node->init_from_backup($node, 'testbackup');
+ $other_node->start;
+
+ # Stop the server
+ $node->stop('fast');
+
+ # Find a free, unprivileged TCP port to bind some other service to
+ my $port = PostgreSQL::Test::Cluster::get_free_port();
+
+=head1 DESCRIPTION
+
+PostgreSQL::Test::Cluster contains a set of routines able to work on a PostgreSQL node,
+allowing to start, stop, backup and initialize it with various options.
+The set of nodes managed by a given test is also managed by this module.
+
+In addition to node management, PostgreSQL::Test::Cluster instances have some wrappers
+around Test::More functions to run commands with an environment set up to
+point to the instance.
+
+The IPC::Run module is required.
+
+=cut
+
+package PostgreSQL::Test::Cluster;
+
+use strict;
+use warnings;
+
+use Carp;
+use Config;
+use Cwd;
+use Fcntl qw(:mode);
+use File::Basename;
+use File::Path qw(rmtree);
+use File::Spec;
+use File::stat qw(stat);
+use File::Temp ();
+use IPC::Run;
+use PostgreSQL::Version;
+use PostgreSQL::Test::RecursiveCopy;
+use Socket;
+use Test::More;
+use PostgreSQL::Test::Utils ();
+use Time::HiRes qw(usleep);
+use Scalar::Util qw(blessed);
+
+our ($use_tcp, $test_localhost, $test_pghost, $last_host_assigned,
+ $last_port_assigned, @all_nodes, $died);
+
+INIT
+{
+
+ # Set PGHOST for backward compatibility. This doesn't work for own_host
+ # nodes, so prefer to not rely on this when writing new tests.
+ $use_tcp = !$PostgreSQL::Test::Utils::use_unix_sockets;
+ $test_localhost = "127.0.0.1";
+ $last_host_assigned = 1;
+ $test_pghost = $use_tcp ? $test_localhost : PostgreSQL::Test::Utils::tempdir_short;
+ $ENV{PGHOST} = $test_pghost;
+ $ENV{PGDATABASE} = 'postgres';
+
+ # Tracking of last port value assigned to accelerate free port lookup.
+ $last_port_assigned = int(rand() * 16384) + 49152;
+}
+
+=pod
+
+=head1 METHODS
+
+=over
+
+=item $node->port()
+
+Get the port number assigned to the host. This won't necessarily be a TCP port
+open on the local host since we prefer to use unix sockets if possible.
+
+Use $node->connstr() if you want a connection string.
+
+=cut
+
+sub port
+{
+ my ($self) = @_;
+ return $self->{_port};
+}
+
+=pod
+
+=item $node->host()
+
+Return the host (like PGHOST) for this instance. May be a UNIX socket path.
+
+Use $node->connstr() if you want a connection string.
+
+=cut
+
+sub host
+{
+ my ($self) = @_;
+ return $self->{_host};
+}
+
+=pod
+
+=item $node->basedir()
+
+The directory all the node's files will be within - datadir, archive directory,
+backups, etc.
+
+=cut
+
+sub basedir
+{
+ my ($self) = @_;
+ return $self->{_basedir};
+}
+
+=pod
+
+=item $node->name()
+
+The name assigned to the node at creation time.
+
+=cut
+
+sub name
+{
+ my ($self) = @_;
+ return $self->{_name};
+}
+
+=pod
+
+=item $node->logfile()
+
+Path to the PostgreSQL log file for this instance.
+
+=cut
+
+sub logfile
+{
+ my ($self) = @_;
+ return $self->{_logfile};
+}
+
+=pod
+
+=item $node->connstr()
+
+Get a libpq connection string that will establish a connection to
+this node. Suitable for passing to psql, DBD::Pg, etc.
+
+=cut
+
+sub connstr
+{
+ my ($self, $dbname) = @_;
+ my $pgport = $self->port;
+ my $pghost = $self->host;
+ if (!defined($dbname))
+ {
+ return "port=$pgport host=$pghost";
+ }
+
+ # Escape properly the database string before using it, only
+ # single quotes and backslashes need to be treated this way.
+ $dbname =~ s#\\#\\\\#g;
+ $dbname =~ s#\'#\\\'#g;
+
+ return "port=$pgport host=$pghost dbname='$dbname'";
+}
+
+=pod
+
+=item $node->group_access()
+
+Does the data dir allow group access?
+
+=cut
+
+sub group_access
+{
+ my ($self) = @_;
+
+ my $dir_stat = stat($self->data_dir);
+
+ defined($dir_stat)
+ or die('unable to stat ' . $self->data_dir);
+
+ return (S_IMODE($dir_stat->mode) == 0750);
+}
+
+=pod
+
+=item $node->data_dir()
+
+Returns the path to the data directory. postgresql.conf and pg_hba.conf are
+always here.
+
+=cut
+
+sub data_dir
+{
+ my ($self) = @_;
+ my $res = $self->basedir;
+ return "$res/pgdata";
+}
+
+=pod
+
+=item $node->archive_dir()
+
+If archiving is enabled, WAL files go here.
+
+=cut
+
+sub archive_dir
+{
+ my ($self) = @_;
+ my $basedir = $self->basedir;
+ return "$basedir/archives";
+}
+
+=pod
+
+=item $node->backup_dir()
+
+The output path for backups taken with $node->backup()
+
+=cut
+
+sub backup_dir
+{
+ my ($self) = @_;
+ my $basedir = $self->basedir;
+ return "$basedir/backup";
+}
+
+=pod
+
+=item $node->install_path()
+
+The configured install path (if any) for the node.
+
+=cut
+
+sub install_path
+{
+ my ($self) = @_;
+ return $self->{_install_path};
+}
+
+=pod
+
+=item $node->info()
+
+Return a string containing human-readable diagnostic information (paths, etc)
+about this node.
+
+=cut
+
+sub info
+{
+ my ($self) = @_;
+ my $_info = '';
+ open my $fh, '>', \$_info or die;
+ print $fh "Name: " . $self->name . "\n";
+ print $fh "Version: " . $self->{_pg_version} . "\n"
+ if $self->{_pg_version};
+ print $fh "Data directory: " . $self->data_dir . "\n";
+ print $fh "Backup directory: " . $self->backup_dir . "\n";
+ print $fh "Archive directory: " . $self->archive_dir . "\n";
+ print $fh "Connection string: " . $self->connstr . "\n";
+ print $fh "Log file: " . $self->logfile . "\n";
+ print $fh "Install Path: ", $self->{_install_path} . "\n"
+ if $self->{_install_path};
+ close $fh or die;
+ return $_info;
+}
+
+=pod
+
+=item $node->dump_info()
+
+Print $node->info()
+
+=cut
+
+sub dump_info
+{
+ my ($self) = @_;
+ print $self->info;
+ return;
+}
+
+
+# Internal method to set up trusted pg_hba.conf for replication. Not
+# documented because you shouldn't use it, it's called automatically if needed.
+sub set_replication_conf
+{
+ my ($self) = @_;
+ my $pgdata = $self->data_dir;
+
+ $self->host eq $test_pghost
+ or croak "set_replication_conf only works with the default host";
+
+ open my $hba, '>>', "$pgdata/pg_hba.conf";
+ print $hba "\n# Allow replication (set up by PostgreSQL::Test::Cluster.pm)\n";
+ if ($PostgreSQL::Test::Utils::windows_os && !$PostgreSQL::Test::Utils::use_unix_sockets)
+ {
+ print $hba
+ "host replication all $test_localhost/32 sspi include_realm=1 map=regress\n";
+ }
+ close $hba;
+ return;
+}
+
+=pod
+
+=item $node->init(...)
+
+Initialize a new cluster for testing.
+
+Authentication is set up so that only the current OS user can access the
+cluster. On Unix, we use Unix domain socket connections, with the socket in
+a directory that's only accessible to the current user to ensure that.
+On Windows, we use SSPI authentication to ensure the same (by pg_regress
+--config-auth).
+
+WAL archiving can be enabled on this node by passing the keyword parameter
+has_archiving => 1. This is disabled by default.
+
+postgresql.conf can be set up for replication by passing the keyword
+parameter allows_streaming => 'logical' or 'physical' (passing 1 will also
+suffice for physical replication) depending on type of replication that
+should be enabled. This is disabled by default.
+
+The new node is set up in a fast but unsafe configuration where fsync is
+disabled.
+
+=cut
+
+sub init
+{
+ my ($self, %params) = @_;
+ my $port = $self->port;
+ my $pgdata = $self->data_dir;
+ my $host = $self->host;
+
+ local %ENV = $self->_get_env();
+
+ $params{allows_streaming} = 0 unless defined $params{allows_streaming};
+ $params{has_archiving} = 0 unless defined $params{has_archiving};
+
+ mkdir $self->backup_dir;
+ mkdir $self->archive_dir;
+
+ PostgreSQL::Test::Utils::system_or_bail('initdb', '-D', $pgdata, '-A', 'trust', '-N',
+ @{ $params{extra} });
+ PostgreSQL::Test::Utils::system_or_bail($ENV{PG_REGRESS}, '--config-auth', $pgdata,
+ @{ $params{auth_extra} });
+
+ open my $conf, '>>', "$pgdata/postgresql.conf";
+ print $conf "\n# Added by PostgreSQL::Test::Cluster.pm\n";
+ print $conf "fsync = off\n";
+ print $conf "restart_after_crash = off\n";
+ print $conf "log_line_prefix = '%m [%p] %q%a '\n";
+ print $conf "log_statement = all\n";
+ print $conf "log_replication_commands = on\n";
+ print $conf "wal_retrieve_retry_interval = '500ms'\n";
+
+ # If a setting tends to affect whether tests pass or fail, print it after
+ # TEMP_CONFIG. Otherwise, print it before TEMP_CONFIG, thereby permitting
+ # overrides. Settings that merely improve performance or ease debugging
+ # belong before TEMP_CONFIG.
+ print $conf PostgreSQL::Test::Utils::slurp_file($ENV{TEMP_CONFIG})
+ if defined $ENV{TEMP_CONFIG};
+
+ # XXX Neutralize any stats_temp_directory in TEMP_CONFIG. Nodes running
+ # concurrently must not share a stats_temp_directory.
+ print $conf "stats_temp_directory = 'pg_stat_tmp'\n";
+
+ if ($params{allows_streaming})
+ {
+ if ($params{allows_streaming} eq "logical")
+ {
+ print $conf "wal_level = logical\n";
+ }
+ else
+ {
+ print $conf "wal_level = replica\n";
+ }
+ print $conf "max_wal_senders = 10\n";
+ print $conf "max_replication_slots = 10\n";
+ print $conf "wal_log_hints = on\n";
+ print $conf "hot_standby = on\n";
+ # conservative settings to ensure we can run multiple postmasters:
+ print $conf "shared_buffers = 1MB\n";
+ print $conf "max_connections = 10\n";
+ # limit disk space consumption, too:
+ print $conf "max_wal_size = 128MB\n";
+ }
+ else
+ {
+ print $conf "wal_level = minimal\n";
+ print $conf "max_wal_senders = 0\n";
+ }
+
+ print $conf "port = $port\n";
+ if ($use_tcp)
+ {
+ print $conf "unix_socket_directories = ''\n";
+ print $conf "listen_addresses = '$host'\n";
+ }
+ else
+ {
+ print $conf "unix_socket_directories = '$host'\n";
+ print $conf "listen_addresses = ''\n";
+ }
+ close $conf;
+
+ chmod($self->group_access ? 0640 : 0600, "$pgdata/postgresql.conf")
+ or die("unable to set permissions for $pgdata/postgresql.conf");
+
+ $self->set_replication_conf if $params{allows_streaming};
+ $self->enable_archiving if $params{has_archiving};
+ return;
+}
+
+=pod
+
+=item $node->append_conf(filename, str)
+
+A shortcut method to append to files like pg_hba.conf and postgresql.conf.
+
+Does no validation or sanity checking. Does not reload the configuration
+after writing.
+
+A newline is automatically appended to the string.
+
+=cut
+
+sub append_conf
+{
+ my ($self, $filename, $str) = @_;
+
+ my $conffile = $self->data_dir . '/' . $filename;
+
+ PostgreSQL::Test::Utils::append_to_file($conffile, $str . "\n");
+
+ chmod($self->group_access() ? 0640 : 0600, $conffile)
+ or die("unable to set permissions for $conffile");
+
+ return;
+}
+
+=pod
+
+=item $node->adjust_conf(filename, setting, value, skip_equals)
+
+Modify the named config file setting with the value. If the value is undefined,
+instead delete the setting. If the setting is not present no action is taken.
+
+This will write "$setting = $value\n" in place of the existing line,
+unless skip_equals is true, in which case it will write
+"$setting $value\n". If the value needs to be quoted it is the caller's
+responsibility to do that.
+
+=cut
+
+sub adjust_conf
+{
+ my ($self, $filename, $setting, $value, $skip_equals) = @_;
+
+ my $conffile = $self->data_dir . '/' . $filename;
+
+ my $contents = PostgreSQL::Test::Utils::slurp_file($conffile);
+ my @lines = split(/\n/, $contents);
+ my @result;
+ my $eq = $skip_equals ? '' : '= ';
+ foreach my $line (@lines)
+ {
+ if ($line !~ /^$setting\W/)
+ {
+ push(@result, "$line\n");
+ }
+ elsif (defined $value)
+ {
+ push(@result, "$setting $eq$value\n");
+ }
+ }
+ open my $fh, ">", $conffile
+ or croak "could not write \"$conffile\": $!";
+ print $fh @result;
+ close $fh;
+
+ chmod($self->group_access() ? 0640 : 0600, $conffile)
+ or die("unable to set permissions for $conffile");
+}
+
+=pod
+
+=item $node->backup(backup_name)
+
+Create a hot backup with B<pg_basebackup> in subdirectory B<backup_name> of
+B<< $node->backup_dir >>, including the WAL.
+
+By default, WAL files are fetched at the end of the backup, not streamed.
+You can adjust that and other things by passing an array of additional
+B<pg_basebackup> command line options in the keyword parameter backup_options.
+
+You'll have to configure a suitable B<max_wal_senders> on the
+target server since it isn't done by default.
+
+=cut
+
+sub backup
+{
+ my ($self, $backup_name, %params) = @_;
+ my $backup_path = $self->backup_dir . '/' . $backup_name;
+ my $name = $self->name;
+
+ local %ENV = $self->_get_env();
+
+ print "# Taking pg_basebackup $backup_name from node \"$name\"\n";
+ PostgreSQL::Test::Utils::system_or_bail(
+ 'pg_basebackup', '-D',
+ $backup_path, '-h',
+ $self->host, '-p',
+ $self->port, '--checkpoint',
+ 'fast', '--no-sync',
+ @{ $params{backup_options} });
+ print "# Backup finished\n";
+ return;
+}
+
+=item $node->backup_fs_hot(backup_name)
+
+Create a backup with a filesystem level copy in subdirectory B<backup_name> of
+B<< $node->backup_dir >>, including WAL.
+
+Archiving must be enabled, as B<pg_start_backup()> and B<pg_stop_backup()> are
+used. This is not checked or enforced.
+
+The backup name is passed as the backup label to B<pg_start_backup()>.
+
+=cut
+
+sub backup_fs_hot
+{
+ my ($self, $backup_name) = @_;
+ $self->_backup_fs($backup_name, 1);
+ return;
+}
+
+=item $node->backup_fs_cold(backup_name)
+
+Create a backup with a filesystem level copy in subdirectory B<backup_name> of
+B<< $node->backup_dir >>, including WAL. The server must be
+stopped as no attempt to handle concurrent writes is made.
+
+Use B<backup> or B<backup_fs_hot> if you want to back up a running server.
+
+=cut
+
+sub backup_fs_cold
+{
+ my ($self, $backup_name) = @_;
+ $self->_backup_fs($backup_name, 0);
+ return;
+}
+
+
+# Common sub of backup_fs_hot and backup_fs_cold
+sub _backup_fs
+{
+ my ($self, $backup_name, $hot) = @_;
+ my $backup_path = $self->backup_dir . '/' . $backup_name;
+ my $port = $self->port;
+ my $name = $self->name;
+
+ print "# Taking filesystem backup $backup_name from node \"$name\"\n";
+
+ if ($hot)
+ {
+ my $stdout = $self->safe_psql('postgres',
+ "SELECT * FROM pg_start_backup('$backup_name');");
+ print "# pg_start_backup: $stdout\n";
+ }
+
+ PostgreSQL::Test::RecursiveCopy::copypath(
+ $self->data_dir,
+ $backup_path,
+ filterfn => sub {
+ my $src = shift;
+ return ($src ne 'log' and $src ne 'postmaster.pid');
+ });
+
+ if ($hot)
+ {
+
+ # We ignore pg_stop_backup's return value. We also assume archiving
+ # is enabled; otherwise the caller will have to copy the remaining
+ # segments.
+ my $stdout =
+ $self->safe_psql('postgres', 'SELECT * FROM pg_stop_backup();');
+ print "# pg_stop_backup: $stdout\n";
+ }
+
+ print "# Backup finished\n";
+ return;
+}
+
+
+
+=pod
+
+=item $node->init_from_backup(root_node, backup_name)
+
+Initialize a node from a backup, which may come from this node or a different
+node. root_node must be a PostgreSQL::Test::Cluster reference, backup_name the string name
+of a backup previously created on that node with $node->backup.
+
+Does not start the node after initializing it.
+
+By default, the backup is assumed to be plain format. To restore from
+a tar-format backup, pass the name of the tar program to use in the
+keyword parameter tar_program. Note that tablespace tar files aren't
+handled here.
+
+Streaming replication can be enabled on this node by passing the keyword
+parameter has_streaming => 1. This is disabled by default.
+
+Restoring WAL segments from archives using restore_command can be enabled
+by passing the keyword parameter has_restoring => 1. This is disabled by
+default.
+
+If has_restoring is used, standby mode is used by default. To use
+recovery mode instead, pass the keyword parameter standby => 0.
+
+The backup is copied, leaving the original unmodified. pg_hba.conf is
+unconditionally set to enable replication connections.
+
+=cut
+
+sub init_from_backup
+{
+ my ($self, $root_node, $backup_name, %params) = @_;
+ my $backup_path = $root_node->backup_dir . '/' . $backup_name;
+ my $host = $self->host;
+ my $port = $self->port;
+ my $node_name = $self->name;
+ my $root_name = $root_node->name;
+
+ $params{has_streaming} = 0 unless defined $params{has_streaming};
+ $params{has_restoring} = 0 unless defined $params{has_restoring};
+ $params{standby} = 1 unless defined $params{standby};
+
+ print
+ "# Initializing node \"$node_name\" from backup \"$backup_name\" of node \"$root_name\"\n";
+ croak "Backup \"$backup_name\" does not exist at $backup_path"
+ unless -d $backup_path;
+
+ mkdir $self->backup_dir;
+ mkdir $self->archive_dir;
+
+ my $data_path = $self->data_dir;
+ if (defined $params{tar_program})
+ {
+ mkdir($data_path);
+ PostgreSQL::Test::Utils::system_or_bail($params{tar_program}, 'xf',
+ $backup_path . '/base.tar',
+ '-C', $data_path);
+ PostgreSQL::Test::Utils::system_or_bail(
+ $params{tar_program}, 'xf',
+ $backup_path . '/pg_wal.tar', '-C',
+ $data_path . '/pg_wal');
+ }
+ else
+ {
+ rmdir($data_path);
+ PostgreSQL::Test::RecursiveCopy::copypath($backup_path, $data_path);
+ }
+ chmod(0700, $data_path);
+
+ # Base configuration for this node
+ $self->append_conf(
+ 'postgresql.conf',
+ qq(
+port = $port
+));
+ if ($use_tcp)
+ {
+ $self->append_conf('postgresql.conf', "listen_addresses = '$host'");
+ }
+ else
+ {
+ $self->append_conf('postgresql.conf',
+ "unix_socket_directories = '$host'");
+ }
+ $self->enable_streaming($root_node) if $params{has_streaming};
+ $self->enable_restoring($root_node, $params{standby})
+ if $params{has_restoring};
+ return;
+}
+
+=pod
+
+=item $node->rotate_logfile()
+
+Switch to a new PostgreSQL log file. This does not alter any running
+PostgreSQL process. Subsequent method calls, including pg_ctl invocations,
+will use the new name. Return the new name.
+
+=cut
+
+sub rotate_logfile
+{
+ my ($self) = @_;
+ $self->{_logfile} = sprintf('%s_%d.log',
+ $self->{_logfile_base},
+ ++$self->{_logfile_generation});
+ return $self->{_logfile};
+}
+
+=pod
+
+=item $node->start(%params) => success_or_failure
+
+Wrapper for pg_ctl start
+
+Start the node and wait until it is ready to accept connections.
+
+=over
+
+=item fail_ok => 1
+
+By default, failure terminates the entire F<prove> invocation. If given,
+instead return a true or false value to indicate success or failure.
+
+=back
+
+=cut
+
+sub start
+{
+ my ($self, %params) = @_;
+ my $port = $self->port;
+ my $pgdata = $self->data_dir;
+ my $name = $self->name;
+ my $ret;
+
+ BAIL_OUT("node \"$name\" is already running") if defined $self->{_pid};
+
+ print("### Starting node \"$name\"\n");
+
+ # Temporarily unset PGAPPNAME so that the server doesn't
+ # inherit it. Otherwise this could affect libpqwalreceiver
+ # connections in confusing ways.
+ local %ENV = $self->_get_env(PGAPPNAME => undef);
+
+ # Note: We set the cluster_name here, not in postgresql.conf (in
+ # sub init) so that it does not get copied to standbys.
+ # -w is now the default but having it here does no harm and helps
+ # compatibility with older versions.
+ $ret = PostgreSQL::Test::Utils::system_log('pg_ctl', '-w', '-D', $self->data_dir, '-l',
+ $self->logfile, '-o', "--cluster-name=$name", 'start');
+
+ if ($ret != 0)
+ {
+ print "# pg_ctl start failed; logfile:\n";
+ print PostgreSQL::Test::Utils::slurp_file($self->logfile);
+ BAIL_OUT("pg_ctl start failed") unless $params{fail_ok};
+ return 0;
+ }
+
+ $self->_update_pid(1);
+ return 1;
+}
+
+=pod
+
+=item $node->kill9()
+
+Send SIGKILL (signal 9) to the postmaster.
+
+Note: if the node is already known stopped, this does nothing.
+However, if we think it's running and it's not, it's important for
+this to fail. Otherwise, tests might fail to detect server crashes.
+
+=cut
+
+sub kill9
+{
+ my ($self) = @_;
+ my $name = $self->name;
+ return unless defined $self->{_pid};
+
+ local %ENV = $self->_get_env();
+
+ print "### Killing node \"$name\" using signal 9\n";
+ # kill(9, ...) fails under msys Perl 5.8.8, so fall back on pg_ctl.
+ kill(9, $self->{_pid})
+ or PostgreSQL::Test::Utils::system_or_bail('pg_ctl', 'kill', 'KILL', $self->{_pid});
+ $self->{_pid} = undef;
+ return;
+}
+
+=pod
+
+=item $node->stop(mode)
+
+Stop the node using pg_ctl -m $mode and wait for it to stop.
+
+Note: if the node is already known stopped, this does nothing.
+However, if we think it's running and it's not, it's important for
+this to fail. Otherwise, tests might fail to detect server crashes.
+
+=cut
+
+sub stop
+{
+ my ($self, $mode) = @_;
+ my $port = $self->port;
+ my $pgdata = $self->data_dir;
+ my $name = $self->name;
+
+ local %ENV = $self->_get_env();
+
+ $mode = 'fast' unless defined $mode;
+ return unless defined $self->{_pid};
+ print "### Stopping node \"$name\" using mode $mode\n";
+ PostgreSQL::Test::Utils::system_or_bail('pg_ctl', '-D', $pgdata, '-m', $mode, 'stop');
+ $self->_update_pid(0);
+ return;
+}
+
+=pod
+
+=item $node->reload()
+
+Reload configuration parameters on the node.
+
+=cut
+
+sub reload
+{
+ my ($self) = @_;
+ my $port = $self->port;
+ my $pgdata = $self->data_dir;
+ my $name = $self->name;
+
+ local %ENV = $self->_get_env();
+
+ print "### Reloading node \"$name\"\n";
+ PostgreSQL::Test::Utils::system_or_bail('pg_ctl', '-D', $pgdata, 'reload');
+ return;
+}
+
+=pod
+
+=item $node->restart()
+
+Wrapper for pg_ctl restart
+
+=cut
+
+sub restart
+{
+ my ($self) = @_;
+ my $port = $self->port;
+ my $pgdata = $self->data_dir;
+ my $logfile = $self->logfile;
+ my $name = $self->name;
+
+ local %ENV = $self->_get_env(PGAPPNAME => undef);
+
+ print "### Restarting node \"$name\"\n";
+
+ # -w is now the default but having it here does no harm and helps
+ # compatibility with older versions.
+ PostgreSQL::Test::Utils::system_or_bail('pg_ctl', '-w', '-D', $pgdata, '-l', $logfile,
+ 'restart');
+
+ $self->_update_pid(1);
+ return;
+}
+
+=pod
+
+=item $node->promote()
+
+Wrapper for pg_ctl promote
+
+=cut
+
+sub promote
+{
+ my ($self) = @_;
+ my $port = $self->port;
+ my $pgdata = $self->data_dir;
+ my $logfile = $self->logfile;
+ my $name = $self->name;
+
+ local %ENV = $self->_get_env();
+
+ print "### Promoting node \"$name\"\n";
+ PostgreSQL::Test::Utils::system_or_bail('pg_ctl', '-D', $pgdata, '-l', $logfile,
+ 'promote');
+ return;
+}
+
+=pod
+
+=item $node->logrotate()
+
+Wrapper for pg_ctl logrotate
+
+=cut
+
+sub logrotate
+{
+ my ($self) = @_;
+ my $port = $self->port;
+ my $pgdata = $self->data_dir;
+ my $logfile = $self->logfile;
+ my $name = $self->name;
+
+ local %ENV = $self->_get_env();
+
+ print "### Rotating log in node \"$name\"\n";
+ PostgreSQL::Test::Utils::system_or_bail('pg_ctl', '-D', $pgdata, '-l', $logfile,
+ 'logrotate');
+ return;
+}
+
+# Internal routine to enable streaming replication on a standby node.
+sub enable_streaming
+{
+ my ($self, $root_node) = @_;
+ my $root_connstr = $root_node->connstr;
+ my $name = $self->name;
+
+ print "### Enabling streaming replication for node \"$name\"\n";
+ $self->append_conf(
+ 'postgresql.conf', qq(
+primary_conninfo='$root_connstr'
+));
+ $self->set_standby_mode();
+ return;
+}
+
+# Internal routine to enable archive recovery command on a standby node
+sub enable_restoring
+{
+ my ($self, $root_node, $standby) = @_;
+ my $path = PostgreSQL::Test::Utils::perl2host($root_node->archive_dir);
+ my $name = $self->name;
+
+ print "### Enabling WAL restore for node \"$name\"\n";
+
+ # On Windows, the path specified in the restore command needs to use
+ # double back-slashes to work properly and to be able to detect properly
+ # the file targeted by the copy command, so the directory value used
+ # in this routine, using only one back-slash, need to be properly changed
+ # first. Paths also need to be double-quoted to prevent failures where
+ # the path contains spaces.
+ $path =~ s{\\}{\\\\}g if ($PostgreSQL::Test::Utils::windows_os);
+ my $copy_command =
+ $PostgreSQL::Test::Utils::windows_os
+ ? qq{copy "$path\\\\%f" "%p"}
+ : qq{cp "$path/%f" "%p"};
+
+ $self->append_conf(
+ 'postgresql.conf', qq(
+restore_command = '$copy_command'
+));
+ if ($standby)
+ {
+ $self->set_standby_mode();
+ }
+ else
+ {
+ $self->set_recovery_mode();
+ }
+ return;
+}
+
+=pod
+
+=item $node->set_recovery_mode()
+
+Place recovery.signal file.
+
+=cut
+
+sub set_recovery_mode
+{
+ my ($self) = @_;
+
+ $self->append_conf('recovery.signal', '');
+ return;
+}
+
+=pod
+
+=item $node->set_standby_mode()
+
+Place standby.signal file.
+
+=cut
+
+sub set_standby_mode
+{
+ my ($self) = @_;
+
+ $self->append_conf('standby.signal', '');
+ return;
+}
+
+# Internal routine to enable archiving
+sub enable_archiving
+{
+ my ($self) = @_;
+ my $path = PostgreSQL::Test::Utils::perl2host($self->archive_dir);
+ my $name = $self->name;
+
+ print "### Enabling WAL archiving for node \"$name\"\n";
+
+ # On Windows, the path specified in the restore command needs to use
+ # double back-slashes to work properly and to be able to detect properly
+ # the file targeted by the copy command, so the directory value used
+ # in this routine, using only one back-slash, need to be properly changed
+ # first. Paths also need to be double-quoted to prevent failures where
+ # the path contains spaces.
+ $path =~ s{\\}{\\\\}g if ($PostgreSQL::Test::Utils::windows_os);
+ my $copy_command =
+ $PostgreSQL::Test::Utils::windows_os
+ ? qq{copy "%p" "$path\\\\%f"}
+ : qq{cp "%p" "$path/%f"};
+
+ # Enable archive_mode and archive_command on node
+ $self->append_conf(
+ 'postgresql.conf', qq(
+archive_mode = on
+archive_command = '$copy_command'
+));
+ return;
+}
+
+# Internal method
+sub _update_pid
+{
+ my ($self, $is_running) = @_;
+ my $name = $self->name;
+
+ # If we can open the PID file, read its first line and that's the PID we
+ # want.
+ if (open my $pidfile, '<', $self->data_dir . "/postmaster.pid")
+ {
+ chomp($self->{_pid} = <$pidfile>);
+ print "# Postmaster PID for node \"$name\" is $self->{_pid}\n";
+ close $pidfile;
+
+ # If we found a pidfile when there shouldn't be one, complain.
+ BAIL_OUT("postmaster.pid unexpectedly present") unless $is_running;
+ return;
+ }
+
+ $self->{_pid} = undef;
+ print "# No postmaster PID for node \"$name\"\n";
+
+ # Complain if we expected to find a pidfile.
+ BAIL_OUT("postmaster.pid unexpectedly not present") if $is_running;
+ return;
+}
+
+=pod
+
+=item PostgreSQL::Test::Cluster->new(node_name, %params)
+
+Build a new object of class C<PostgreSQL::Test::Cluster> (or of a subclass, if you have
+one), assigning a free port number. Remembers the node, to prevent its port
+number from being reused for another node, and to ensure that it gets
+shut down when the test script exits.
+
+=over
+
+=item port => [1,65535]
+
+By default, this function assigns a port number to each node. Specify this to
+force a particular port number. The caller is responsible for evaluating
+potential conflicts and privilege requirements.
+
+=item own_host => 1
+
+By default, all nodes use the same PGHOST value. If specified, generate a
+PGHOST specific to this node. This allows multiple nodes to use the same
+port.
+
+=item install_path => '/path/to/postgres/installation'
+
+Using this parameter is it possible to have nodes pointing to different
+installations, for testing different versions together or the same version
+with different build parameters. The provided path must be the parent of the
+installation's 'bin' and 'lib' directories. In the common case where this is
+not provided, Postgres binaries will be found in the caller's PATH.
+
+=back
+
+=cut
+
+sub new
+{
+ my $class = shift;
+ my ($name, %params) = @_;
+
+ # Select a port.
+ my $port;
+ if (defined $params{port})
+ {
+ $port = $params{port};
+ }
+ else
+ {
+ # When selecting a port, we look for an unassigned TCP port number,
+ # even if we intend to use only Unix-domain sockets. This is clearly
+ # necessary on $use_tcp (Windows) configurations, and it seems like a
+ # good idea on Unixen as well.
+ $port = get_free_port();
+ }
+
+ # Select a host.
+ my $host = $test_pghost;
+ if ($params{own_host})
+ {
+ if ($use_tcp)
+ {
+ $last_host_assigned++;
+ $last_host_assigned > 254 and BAIL_OUT("too many own_host nodes");
+ $host = '127.0.0.' . $last_host_assigned;
+ }
+ else
+ {
+ $host = "$test_pghost/$name"; # Assume $name =~ /^[-_a-zA-Z0-9]+$/
+ mkdir $host;
+ }
+ }
+
+ my $testname = basename($0);
+ $testname =~ s/\.[^.]+$//;
+ my $node = {
+ _port => $port,
+ _host => $host,
+ _basedir => "$PostgreSQL::Test::Utils::tmp_check/t_${testname}_${name}_data",
+ _name => $name,
+ _logfile_generation => 0,
+ _logfile_base => "$PostgreSQL::Test::Utils::log_path/${testname}_${name}",
+ _logfile => "$PostgreSQL::Test::Utils::log_path/${testname}_${name}.log"
+ };
+
+ if ($params{install_path})
+ {
+ $node->{_install_path} = $params{install_path};
+ }
+
+ bless $node, $class;
+ mkdir $node->{_basedir}
+ or
+ BAIL_OUT("could not create data directory \"$node->{_basedir}\": $!");
+
+ $node->dump_info;
+
+ # Add node to list of nodes
+ push(@all_nodes, $node);
+
+ $node->_set_pg_version;
+
+ my $v = $node->{_pg_version};
+
+ carp("PostgreSQL::Test::Cluster isn't fully compatible with version " . $v)
+ if $v < 12;
+
+ return $node;
+}
+
+# Private routine to run the pg_config binary found in our environment (or in
+# our install_path, if we have one), and set the version from it
+#
+sub _set_pg_version
+{
+ my ($self) = @_;
+ my $inst = $self->{_install_path};
+ my $pg_config = "pg_config";
+
+ if (defined $inst)
+ {
+ # If the _install_path is invalid, our PATH variables might find an
+ # unrelated pg_config executable elsewhere. Sanity check the
+ # directory.
+ BAIL_OUT("directory not found: $inst")
+ unless -d $inst;
+
+ # If the directory exists but is not the root of a postgresql
+ # installation, or if the user configured using
+ # --bindir=$SOMEWHERE_ELSE, we're not going to find pg_config, so
+ # complain about that, too.
+ $pg_config = "$inst/bin/pg_config";
+ BAIL_OUT("pg_config not found: $pg_config")
+ unless -e $pg_config
+ or ($PostgreSQL::Test::Utils::windows_os and -e "$pg_config.exe");
+ BAIL_OUT("pg_config not executable: $pg_config")
+ unless $PostgreSQL::Test::Utils::windows_os or -x $pg_config;
+
+ # Leave $pg_config install_path qualified, to be sure we get the right
+ # version information, below, or die trying
+ }
+
+ local %ENV = $self->_get_env();
+
+ # We only want the version field
+ my $version_line = qx{$pg_config --version};
+ BAIL_OUT("$pg_config failed: $!") if $?;
+
+ $self->{_pg_version} = PostgreSQL::Version->new($version_line);
+
+ BAIL_OUT("could not parse pg_config --version output: $version_line")
+ unless defined $self->{_pg_version};
+}
+
+# Private routine to return a copy of the environment with the PATH and
+# (DY)LD_LIBRARY_PATH correctly set when there is an install path set for
+# the node.
+#
+# Routines that call Postgres binaries need to call this routine like this:
+#
+# local %ENV = $self->_get_env{[%extra_settings]);
+#
+# A copy of the environment is taken and node's host and port settings are
+# added as PGHOST and PGPORT, Then the extra settings (if any) are applied.
+# Any setting in %extra_settings with a value that is undefined is deleted
+# the remainder are# set. Then the PATH and (DY)LD_LIBRARY_PATH are adjusted
+# if the node's install path is set, and the copy environment is returned.
+#
+# The install path set in new() needs to be a directory containing
+# bin and lib subdirectories as in a standard PostgreSQL installation, so this
+# can't be used with installations where the bin and lib directories don't have
+# a common parent directory.
+sub _get_env
+{
+ my $self = shift;
+ my %inst_env = (%ENV, PGHOST => $self->{_host}, PGPORT => $self->{_port});
+ # the remaining arguments are modifications to make to the environment
+ my %mods = (@_);
+ while (my ($k, $v) = each %mods)
+ {
+ if (defined $v)
+ {
+ $inst_env{$k} = "$v";
+ }
+ else
+ {
+ delete $inst_env{$k};
+ }
+ }
+ # now fix up the new environment for the install path
+ my $inst = $self->{_install_path};
+ if ($inst)
+ {
+ if ($PostgreSQL::Test::Utils::windows_os)
+ {
+ # Windows picks up DLLs from the PATH rather than *LD_LIBRARY_PATH
+ # choose the right path separator
+ if ($Config{osname} eq 'MSWin32')
+ {
+ $inst_env{PATH} = "$inst/bin;$inst/lib;$ENV{PATH}";
+ }
+ else
+ {
+ $inst_env{PATH} = "$inst/bin:$inst/lib:$ENV{PATH}";
+ }
+ }
+ else
+ {
+ my $dylib_name =
+ $Config{osname} eq 'darwin'
+ ? "DYLD_LIBRARY_PATH"
+ : "LD_LIBRARY_PATH";
+ $inst_env{PATH} = "$inst/bin:$ENV{PATH}";
+ if (exists $ENV{$dylib_name})
+ {
+ $inst_env{$dylib_name} = "$inst/lib:$ENV{$dylib_name}";
+ }
+ else
+ {
+ $inst_env{$dylib_name} = "$inst/lib";
+ }
+ }
+ }
+ return (%inst_env);
+}
+
+# Private routine to get an installation path qualified command.
+#
+# IPC::Run maintains a cache, %cmd_cache, mapping commands to paths. Tests
+# which use nodes spanning more than one postgres installation path need to
+# avoid confusing which installation's binaries get run. Setting $ENV{PATH} is
+# insufficient, as IPC::Run does not check to see if the path has changed since
+# caching a command.
+sub installed_command
+{
+ my ($self, $cmd) = @_;
+
+ # Nodes using alternate installation locations use their installation's
+ # bin/ directory explicitly
+ return join('/', $self->{_install_path}, 'bin', $cmd)
+ if defined $self->{_install_path};
+
+ # Nodes implicitly using the default installation location rely on IPC::Run
+ # to find the right binary, which should not cause %cmd_cache confusion,
+ # because no nodes with other installation paths do it that way.
+ return $cmd;
+}
+
+=pod
+
+=item get_free_port()
+
+Locate an unprivileged (high) TCP port that's not currently bound to
+anything. This is used by C<new()>, and also by some test cases that need to
+start other, non-Postgres servers.
+
+Ports assigned to existing PostgreSQL::Test::Cluster objects are automatically
+excluded, even if those servers are not currently running.
+
+XXX A port available now may become unavailable by the time we start
+the desired service.
+
+Note: this is not an instance method. As it's not exported it should be
+called from outside the module as C<PostgreSQL::Test::Cluster::get_free_port()>.
+
+=cut
+
+sub get_free_port
+{
+ my $found = 0;
+ my $port = $last_port_assigned;
+
+ while ($found == 0)
+ {
+
+ # advance $port, wrapping correctly around range end
+ $port = 49152 if ++$port >= 65536;
+ print "# Checking port $port\n";
+
+ # Check first that candidate port number is not included in
+ # the list of already-registered nodes.
+ $found = 1;
+ foreach my $node (@all_nodes)
+ {
+ $found = 0 if ($node->port == $port);
+ }
+
+ # Check to see if anything else is listening on this TCP port.
+ # Seek a port available for all possible listen_addresses values,
+ # so callers can harness this port for the widest range of purposes.
+ # The 0.0.0.0 test achieves that for MSYS, which automatically sets
+ # SO_EXCLUSIVEADDRUSE. Testing 0.0.0.0 is insufficient for Windows
+ # native Perl (https://stackoverflow.com/a/14388707), so we also
+ # have to test individual addresses. Doing that for 127.0.0/24
+ # addresses other than 127.0.0.1 might fail with EADDRNOTAVAIL on
+ # non-Linux, non-Windows kernels.
+ #
+ # Thus, 0.0.0.0 and individual 127.0.0/24 addresses are tested
+ # only on Windows and only when TCP usage is requested.
+ if ($found == 1)
+ {
+ foreach my $addr (qw(127.0.0.1),
+ ($use_tcp && $PostgreSQL::Test::Utils::windows_os)
+ ? qw(127.0.0.2 127.0.0.3 0.0.0.0)
+ : ())
+ {
+ if (!can_bind($addr, $port))
+ {
+ $found = 0;
+ last;
+ }
+ }
+ }
+ }
+
+ print "# Found port $port\n";
+
+ # Update port for next time
+ $last_port_assigned = $port;
+
+ return $port;
+}
+
+# Internal routine to check whether a host:port is available to bind
+sub can_bind
+{
+ my ($host, $port) = @_;
+ my $iaddr = inet_aton($host);
+ my $paddr = sockaddr_in($port, $iaddr);
+ my $proto = getprotobyname("tcp");
+
+ socket(SOCK, PF_INET, SOCK_STREAM, $proto)
+ or die "socket failed: $!";
+
+ # As in postmaster, don't use SO_REUSEADDR on Windows
+ setsockopt(SOCK, SOL_SOCKET, SO_REUSEADDR, pack("l", 1))
+ unless $PostgreSQL::Test::Utils::windows_os;
+ my $ret = bind(SOCK, $paddr) && listen(SOCK, SOMAXCONN);
+ close(SOCK);
+ return $ret;
+}
+
+# Automatically shut down any still-running nodes (in the same order the nodes
+# were created in) when the test script exits.
+END
+{
+
+ # take care not to change the script's exit value
+ my $exit_code = $?;
+
+ foreach my $node (@all_nodes)
+ {
+ $node->teardown_node;
+
+ # skip clean if we are requested to retain the basedir
+ next if defined $ENV{'PG_TEST_NOCLEAN'};
+
+ # clean basedir on clean test invocation
+ $node->clean_node if $exit_code == 0 && PostgreSQL::Test::Utils::all_tests_passing();
+ }
+
+ $? = $exit_code;
+}
+
+=pod
+
+=item $node->teardown_node()
+
+Do an immediate stop of the node
+
+=cut
+
+sub teardown_node
+{
+ my $self = shift;
+
+ $self->stop('immediate');
+ return;
+}
+
+=pod
+
+=item $node->clean_node()
+
+Remove the base directory of the node if the node has been stopped.
+
+=cut
+
+sub clean_node
+{
+ my $self = shift;
+
+ rmtree $self->{_basedir} unless defined $self->{_pid};
+ return;
+}
+
+=pod
+
+=item $node->safe_psql($dbname, $sql) => stdout
+
+Invoke B<psql> to run B<sql> on B<dbname> and return its stdout on success.
+Die if the SQL produces an error. Runs with B<ON_ERROR_STOP> set.
+
+Takes optional extra params like timeout and timed_out parameters with the same
+options as psql.
+
+=cut
+
+sub safe_psql
+{
+ my ($self, $dbname, $sql, %params) = @_;
+
+ local %ENV = $self->_get_env();
+
+ my ($stdout, $stderr);
+
+ my $ret = $self->psql(
+ $dbname, $sql,
+ %params,
+ stdout => \$stdout,
+ stderr => \$stderr,
+ on_error_die => 1,
+ on_error_stop => 1);
+
+ # psql can emit stderr from NOTICEs etc
+ if ($stderr ne "")
+ {
+ print "#### Begin standard error\n";
+ print $stderr;
+ print "\n#### End standard error\n";
+ }
+
+ return $stdout;
+}
+
+=pod
+
+=item $node->psql($dbname, $sql, %params) => psql_retval
+
+Invoke B<psql> to execute B<$sql> on B<$dbname> and return the return value
+from B<psql>, which is run with on_error_stop by default so that it will
+stop running sql and return 3 if the passed SQL results in an error.
+
+As a convenience, if B<psql> is called in array context it returns an
+array containing ($retval, $stdout, $stderr).
+
+psql is invoked in tuples-only unaligned mode with reading of B<.psqlrc>
+disabled. That may be overridden by passing extra psql parameters.
+
+stdout and stderr are transformed to UNIX line endings if on Windows. Any
+trailing newline is removed.
+
+Dies on failure to invoke psql but not if psql exits with a nonzero
+return code (unless on_error_die specified).
+
+If psql exits because of a signal, an exception is raised.
+
+=over
+
+=item stdout => \$stdout
+
+B<stdout>, if given, must be a scalar reference to which standard output is
+written. If not given, standard output is not redirected and will be printed
+unless B<psql> is called in array context, in which case it's captured and
+returned.
+
+=item stderr => \$stderr
+
+Same as B<stdout> but gets standard error. If the same scalar is passed for
+both B<stdout> and B<stderr> the results may be interleaved unpredictably.
+
+=item on_error_stop => 1
+
+By default, the B<psql> method invokes the B<psql> program with ON_ERROR_STOP=1
+set, so SQL execution is stopped at the first error and exit code 3 is
+returned. Set B<on_error_stop> to 0 to ignore errors instead.
+
+=item on_error_die => 0
+
+By default, this method returns psql's result code. Pass on_error_die to
+instead die with an informative message.
+
+=item timeout => 'interval'
+
+Set a timeout for the psql call as an interval accepted by B<IPC::Run::timer>
+(integer seconds is fine). This method raises an exception on timeout, unless
+the B<timed_out> parameter is also given.
+
+=item timed_out => \$timed_out
+
+If B<timeout> is set and this parameter is given, the scalar it references
+is set to true if the psql call times out.
+
+=item connstr => B<value>
+
+If set, use this as the connection string for the connection to the
+backend.
+
+=item replication => B<value>
+
+If set, add B<replication=value> to the conninfo string.
+Passing the literal value C<database> results in a logical replication
+connection.
+
+=item extra_params => ['--single-transaction']
+
+If given, it must be an array reference containing additional parameters to B<psql>.
+
+=back
+
+e.g.
+
+ my ($stdout, $stderr, $timed_out);
+ my $cmdret = $node->psql('postgres', 'SELECT pg_sleep(600)',
+ stdout => \$stdout, stderr => \$stderr,
+ timeout => 180, timed_out => \$timed_out,
+ extra_params => ['--single-transaction'])
+
+will set $cmdret to undef and $timed_out to a true value.
+
+ $node->psql('postgres', $sql, on_error_die => 1);
+
+dies with an informative message if $sql fails.
+
+=cut
+
+sub psql
+{
+ my ($self, $dbname, $sql, %params) = @_;
+
+ local %ENV = $self->_get_env();
+
+ my $stdout = $params{stdout};
+ my $stderr = $params{stderr};
+ my $replication = $params{replication};
+ my $timeout = undef;
+ my $timeout_exception = 'psql timed out';
+
+ # Build the connection string.
+ my $psql_connstr;
+ if (defined $params{connstr})
+ {
+ $psql_connstr = $params{connstr};
+ }
+ else
+ {
+ $psql_connstr = $self->connstr($dbname);
+ }
+ $psql_connstr .= defined $replication ? " replication=$replication" : "";
+
+ my @psql_params = (
+ $self->installed_command('psql'),
+ '-XAtq', '-d', $psql_connstr, '-f', '-');
+
+ # If the caller wants an array and hasn't passed stdout/stderr
+ # references, allocate temporary ones to capture them so we
+ # can return them. Otherwise we won't redirect them at all.
+ if (wantarray)
+ {
+ if (!defined($stdout))
+ {
+ my $temp_stdout = "";
+ $stdout = \$temp_stdout;
+ }
+ if (!defined($stderr))
+ {
+ my $temp_stderr = "";
+ $stderr = \$temp_stderr;
+ }
+ }
+
+ $params{on_error_stop} = 1 unless defined $params{on_error_stop};
+ $params{on_error_die} = 0 unless defined $params{on_error_die};
+
+ push @psql_params, '-v', 'ON_ERROR_STOP=1' if $params{on_error_stop};
+ push @psql_params, @{ $params{extra_params} }
+ if defined $params{extra_params};
+
+ $timeout =
+ IPC::Run::timeout($params{timeout}, exception => $timeout_exception)
+ if (defined($params{timeout}));
+
+ ${ $params{timed_out} } = 0 if defined $params{timed_out};
+
+ # IPC::Run would otherwise append to existing contents:
+ $$stdout = "" if ref($stdout);
+ $$stderr = "" if ref($stderr);
+
+ my $ret;
+
+ # Run psql and capture any possible exceptions. If the exception is
+ # because of a timeout and the caller requested to handle that, just return
+ # and set the flag. Otherwise, and for any other exception, rethrow.
+ #
+ # For background, see
+ # https://metacpan.org/pod/release/ETHER/Try-Tiny-0.24/lib/Try/Tiny.pm
+ do
+ {
+ local $@;
+ eval {
+ my @ipcrun_opts = (\@psql_params, '<', \$sql);
+ push @ipcrun_opts, '>', $stdout if defined $stdout;
+ push @ipcrun_opts, '2>', $stderr if defined $stderr;
+ push @ipcrun_opts, $timeout if defined $timeout;
+
+ IPC::Run::run @ipcrun_opts;
+ $ret = $?;
+ };
+ my $exc_save = $@;
+ if ($exc_save)
+ {
+
+ # IPC::Run::run threw an exception. re-throw unless it's a
+ # timeout, which we'll handle by testing is_expired
+ die $exc_save
+ if (blessed($exc_save)
+ || $exc_save !~ /^\Q$timeout_exception\E/);
+
+ $ret = undef;
+
+ die "Got timeout exception '$exc_save' but timer not expired?!"
+ unless $timeout->is_expired;
+
+ if (defined($params{timed_out}))
+ {
+ ${ $params{timed_out} } = 1;
+ }
+ else
+ {
+ die "psql timed out: stderr: '$$stderr'\n"
+ . "while running '@psql_params'";
+ }
+ }
+ };
+
+ # Note: on Windows, IPC::Run seems to convert \r\n to \n in program output
+ # if we're using native Perl, but not if we're using MSys Perl. So do it
+ # by hand in the latter case, here and elsewhere.
+
+ if (defined $$stdout)
+ {
+ $$stdout =~ s/\r\n/\n/g if $Config{osname} eq 'msys';
+ chomp $$stdout;
+ }
+
+ if (defined $$stderr)
+ {
+ $$stderr =~ s/\r\n/\n/g if $Config{osname} eq 'msys';
+ chomp $$stderr;
+ }
+
+ # See http://perldoc.perl.org/perlvar.html#%24CHILD_ERROR
+ # We don't use IPC::Run::Simple to limit dependencies.
+ #
+ # We always die on signal.
+ my $core = $ret & 128 ? " (core dumped)" : "";
+ die "psql exited with signal "
+ . ($ret & 127)
+ . "$core: '$$stderr' while running '@psql_params'"
+ if $ret & 127;
+ $ret = $ret >> 8;
+
+ if ($ret && $params{on_error_die})
+ {
+ die "psql error: stderr: '$$stderr'\nwhile running '@psql_params'"
+ if $ret == 1;
+ die "connection error: '$$stderr'\nwhile running '@psql_params'"
+ if $ret == 2;
+ die
+ "error running SQL: '$$stderr'\nwhile running '@psql_params' with sql '$sql'"
+ if $ret == 3;
+ die "psql returns $ret: '$$stderr'\nwhile running '@psql_params'";
+ }
+
+ if (wantarray)
+ {
+ return ($ret, $$stdout, $$stderr);
+ }
+ else
+ {
+ return $ret;
+ }
+}
+
+=pod
+
+=item $node->background_psql($dbname, \$stdin, \$stdout, $timer, %params) => harness
+
+Invoke B<psql> on B<$dbname> and return an IPC::Run harness object, which the
+caller may use to send input to B<psql>. The process's stdin is sourced from
+the $stdin scalar reference, and its stdout and stderr go to the $stdout
+scalar reference. This allows the caller to act on other parts of the system
+while idling this backend.
+
+The specified timer object is attached to the harness, as well. It's caller's
+responsibility to select the timeout length, and to restart the timer after
+each command if the timeout is per-command.
+
+psql is invoked in tuples-only unaligned mode with reading of B<.psqlrc>
+disabled. That may be overridden by passing extra psql parameters.
+
+Dies on failure to invoke psql, or if psql fails to connect. Errors occurring
+later are the caller's problem. psql runs with on_error_stop by default so
+that it will stop running sql and return 3 if passed SQL results in an error.
+
+Be sure to "finish" the harness when done with it.
+
+=over
+
+=item on_error_stop => 1
+
+By default, the B<psql> method invokes the B<psql> program with ON_ERROR_STOP=1
+set, so SQL execution is stopped at the first error and exit code 3 is
+returned. Set B<on_error_stop> to 0 to ignore errors instead.
+
+=item replication => B<value>
+
+If set, add B<replication=value> to the conninfo string.
+Passing the literal value C<database> results in a logical replication
+connection.
+
+=item extra_params => ['--single-transaction']
+
+If given, it must be an array reference containing additional parameters to B<psql>.
+
+=back
+
+=cut
+
+sub background_psql
+{
+ my ($self, $dbname, $stdin, $stdout, $timer, %params) = @_;
+
+ local %ENV = $self->_get_env();
+
+ my $replication = $params{replication};
+
+ my @psql_params = (
+ $self->installed_command('psql'),
+ '-XAtq',
+ '-d',
+ $self->connstr($dbname)
+ . (defined $replication ? " replication=$replication" : ""),
+ '-f',
+ '-');
+
+ $params{on_error_stop} = 1 unless defined $params{on_error_stop};
+
+ push @psql_params, '-v', 'ON_ERROR_STOP=1' if $params{on_error_stop};
+ push @psql_params, @{ $params{extra_params} }
+ if defined $params{extra_params};
+
+ # Ensure there is no data waiting to be sent:
+ $$stdin = "" if ref($stdin);
+ # IPC::Run would otherwise append to existing contents:
+ $$stdout = "" if ref($stdout);
+
+ my $harness = IPC::Run::start \@psql_params,
+ '<', $stdin, '>', $stdout, $timer;
+
+ # Request some output, and pump until we see it. This means that psql
+ # connection failures are caught here, relieving callers of the need to
+ # handle those. (Right now, we have no particularly good handling for
+ # errors anyway, but that might be added later.)
+ my $banner = "background_psql: ready";
+ $$stdin = "\\echo $banner\n";
+ pump $harness until $$stdout =~ /$banner/ || $timer->is_expired;
+
+ die "psql startup timed out" if $timer->is_expired;
+
+ return $harness;
+}
+
+=pod
+
+=item $node->interactive_psql($dbname, \$stdin, \$stdout, $timer, %params) => harness
+
+Invoke B<psql> on B<$dbname> and return an IPC::Run harness object,
+which the caller may use to send interactive input to B<psql>.
+The process's stdin is sourced from the $stdin scalar reference,
+and its stdout and stderr go to the $stdout scalar reference.
+ptys are used so that psql thinks it's being called interactively.
+
+The specified timer object is attached to the harness, as well.
+It's caller's responsibility to select the timeout length, and to
+restart the timer after each command if the timeout is per-command.
+
+psql is invoked in tuples-only unaligned mode with reading of B<.psqlrc>
+disabled. That may be overridden by passing extra psql parameters.
+
+Dies on failure to invoke psql, or if psql fails to connect.
+Errors occurring later are the caller's problem.
+
+Be sure to "finish" the harness when done with it.
+
+The only extra parameter currently accepted is
+
+=over
+
+=item extra_params => ['--single-transaction']
+
+If given, it must be an array reference containing additional parameters to B<psql>.
+
+=back
+
+This requires IO::Pty in addition to IPC::Run.
+
+=cut
+
+sub interactive_psql
+{
+ my ($self, $dbname, $stdin, $stdout, $timer, %params) = @_;
+
+ local %ENV = $self->_get_env();
+
+ my @psql_params = (
+ $self->installed_command('psql'),
+ '-XAt', '-d', $self->connstr($dbname));
+
+ push @psql_params, @{ $params{extra_params} }
+ if defined $params{extra_params};
+
+ # Ensure there is no data waiting to be sent:
+ $$stdin = "" if ref($stdin);
+ # IPC::Run would otherwise append to existing contents:
+ $$stdout = "" if ref($stdout);
+
+ my $harness = IPC::Run::start \@psql_params,
+ '<pty<', $stdin, '>pty>', $stdout, $timer;
+
+ # Pump until we see psql's help banner. This ensures that callers
+ # won't write anything to the pty before it's ready, avoiding an
+ # implementation issue in IPC::Run. Also, it means that psql
+ # connection failures are caught here, relieving callers of
+ # the need to handle those. (Right now, we have no particularly
+ # good handling for errors anyway, but that might be added later.)
+ pump $harness
+ until $$stdout =~ /Type "help" for help/ || $timer->is_expired;
+
+ die "psql startup timed out" if $timer->is_expired;
+
+ return $harness;
+}
+
+# Common sub of pgbench-invoking interfaces. Makes any requested script files
+# and returns pgbench command-line options causing use of those files.
+sub _pgbench_make_files
+{
+ my ($self, $files) = @_;
+ my @file_opts;
+
+ if (defined $files)
+ {
+
+ # note: files are ordered for determinism
+ for my $fn (sort keys %$files)
+ {
+ my $filename = $self->basedir . '/' . $fn;
+ push @file_opts, '-f', $filename;
+
+ # cleanup file weight
+ $filename =~ s/\@\d+$//;
+
+ #push @filenames, $filename;
+ # filenames are expected to be unique on a test
+ if (-e $filename)
+ {
+ ok(0, "$filename must not already exist");
+ unlink $filename or die "cannot unlink $filename: $!";
+ }
+ PostgreSQL::Test::Utils::append_to_file($filename, $$files{$fn});
+ }
+ }
+
+ return @file_opts;
+}
+
+=pod
+
+=item $node->pgbench($opts, $stat, $out, $err, $name, $files, @args)
+
+Invoke B<pgbench>, with parameters and files.
+
+=over
+
+=item $opts
+
+Options as a string to be split on spaces.
+
+=item $stat
+
+Expected exit status.
+
+=item $out
+
+Reference to a regexp list that must match stdout.
+
+=item $err
+
+Reference to a regexp list that must match stderr.
+
+=item $name
+
+Name of test for error messages.
+
+=item $files
+
+Reference to filename/contents dictionary.
+
+=item @args
+
+Further raw options or arguments.
+
+=back
+
+=cut
+
+sub pgbench
+{
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+
+ my ($self, $opts, $stat, $out, $err, $name, $files, @args) = @_;
+ my @cmd = (
+ 'pgbench',
+ split(/\s+/, $opts),
+ $self->_pgbench_make_files($files), @args);
+
+ $self->command_checks_all(\@cmd, $stat, $out, $err, $name);
+}
+
+=pod
+
+=item $node->background_pgbench($opts, $files, \$stdout, $timer) => harness
+
+Invoke B<pgbench> and return an IPC::Run harness object. The process's stdin
+is empty, and its stdout and stderr go to the $stdout scalar reference. This
+allows the caller to act on other parts of the system while B<pgbench> is
+running. Errors from B<pgbench> are the caller's problem.
+
+The specified timer object is attached to the harness, as well. It's caller's
+responsibility to select the timeout length, and to restart the timer after
+each command if the timeout is per-command.
+
+Be sure to "finish" the harness when done with it.
+
+=over
+
+=item $opts
+
+Options as a string to be split on spaces.
+
+=item $files
+
+Reference to filename/contents dictionary.
+
+=back
+
+=cut
+
+sub background_pgbench
+{
+ my ($self, $opts, $files, $stdout, $timer) = @_;
+
+ my @cmd =
+ ('pgbench', split(/\s+/, $opts), $self->_pgbench_make_files($files));
+
+ local %ENV = $self->_get_env();
+
+ my $stdin = "";
+ # IPC::Run would otherwise append to existing contents:
+ $$stdout = "" if ref($stdout);
+
+ my $harness = IPC::Run::start \@cmd, '<', \$stdin, '>', $stdout, '2>&1',
+ $timer;
+
+ return $harness;
+}
+
+=pod
+
+=item $node->connect_ok($connstr, $test_name, %params)
+
+Attempt a connection with a custom connection string. This is expected
+to succeed.
+
+=over
+
+=item sql => B<value>
+
+If this parameter is set, this query is used for the connection attempt
+instead of the default.
+
+=item expected_stdout => B<value>
+
+If this regular expression is set, matches it with the output generated.
+
+=item log_like => [ qr/required message/ ]
+
+If given, it must be an array reference containing a list of regular
+expressions that must match against the server log, using
+C<Test::More::like()>.
+
+=item log_unlike => [ qr/prohibited message/ ]
+
+If given, it must be an array reference containing a list of regular
+expressions that must NOT match against the server log. They will be
+passed to C<Test::More::unlike()>.
+
+=back
+
+=cut
+
+sub connect_ok
+{
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ my ($self, $connstr, $test_name, %params) = @_;
+
+ my $sql;
+ if (defined($params{sql}))
+ {
+ $sql = $params{sql};
+ }
+ else
+ {
+ $sql = "SELECT \$\$connected with $connstr\$\$";
+ }
+
+ my (@log_like, @log_unlike);
+ if (defined($params{log_like}))
+ {
+ @log_like = @{ $params{log_like} };
+ }
+ if (defined($params{log_unlike}))
+ {
+ @log_unlike = @{ $params{log_unlike} };
+ }
+
+ my $log_location = -s $self->logfile;
+
+ # Never prompt for a password, any callers of this routine should
+ # have set up things properly, and this should not block.
+ my ($ret, $stdout, $stderr) = $self->psql(
+ 'postgres',
+ $sql,
+ extra_params => ['-w'],
+ connstr => "$connstr",
+ on_error_stop => 0);
+
+ is($ret, 0, $test_name);
+
+ if (defined($params{expected_stdout}))
+ {
+ like($stdout, $params{expected_stdout}, "$test_name: matches");
+ }
+ if (@log_like or @log_unlike)
+ {
+ my $log_contents = PostgreSQL::Test::Utils::slurp_file($self->logfile, $log_location);
+
+ while (my $regex = shift @log_like)
+ {
+ like($log_contents, $regex, "$test_name: log matches");
+ }
+ while (my $regex = shift @log_unlike)
+ {
+ unlike($log_contents, $regex, "$test_name: log does not match");
+ }
+ }
+}
+
+=pod
+
+=item $node->connect_fails($connstr, $test_name, %params)
+
+Attempt a connection with a custom connection string. This is expected
+to fail.
+
+=over
+
+=item expected_stderr => B<value>
+
+If this regular expression is set, matches it with the output generated.
+
+=item log_like => [ qr/required message/ ]
+
+=item log_unlike => [ qr/prohibited message/ ]
+
+See C<connect_ok(...)>, above.
+
+=back
+
+=cut
+
+sub connect_fails
+{
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ my ($self, $connstr, $test_name, %params) = @_;
+
+ my (@log_like, @log_unlike);
+ if (defined($params{log_like}))
+ {
+ @log_like = @{ $params{log_like} };
+ }
+ if (defined($params{log_unlike}))
+ {
+ @log_unlike = @{ $params{log_unlike} };
+ }
+
+ my $log_location = -s $self->logfile;
+
+ # Never prompt for a password, any callers of this routine should
+ # have set up things properly, and this should not block.
+ my ($ret, $stdout, $stderr) = $self->psql(
+ 'postgres',
+ undef,
+ extra_params => ['-w'],
+ connstr => "$connstr");
+
+ isnt($ret, 0, $test_name);
+
+ if (defined($params{expected_stderr}))
+ {
+ like($stderr, $params{expected_stderr}, "$test_name: matches");
+ }
+
+ if (@log_like or @log_unlike)
+ {
+ my $log_contents = PostgreSQL::Test::Utils::slurp_file($self->logfile, $log_location);
+
+ while (my $regex = shift @log_like)
+ {
+ like($log_contents, $regex, "$test_name: log matches");
+ }
+ while (my $regex = shift @log_unlike)
+ {
+ unlike($log_contents, $regex, "$test_name: log does not match");
+ }
+ }
+}
+
+=pod
+
+=item $node->poll_query_until($dbname, $query [, $expected ])
+
+Run B<$query> repeatedly, until it returns the B<$expected> result
+('t', or SQL boolean true, by default).
+Continues polling if B<psql> returns an error result.
+Times out after 180 seconds.
+Returns 1 if successful, 0 if timed out.
+
+=cut
+
+sub poll_query_until
+{
+ my ($self, $dbname, $query, $expected) = @_;
+
+ local %ENV = $self->_get_env();
+
+ $expected = 't' unless defined($expected); # default value
+
+ my $cmd = [
+ $self->installed_command('psql'), '-XAt',
+ '-d', $self->connstr($dbname)
+ ];
+ my ($stdout, $stderr);
+ my $max_attempts = 180 * 10;
+ my $attempts = 0;
+
+ while ($attempts < $max_attempts)
+ {
+ my $result = IPC::Run::run $cmd, '<', \$query,
+ '>', \$stdout, '2>', \$stderr;
+
+ $stdout =~ s/\r\n/\n/g if $Config{osname} eq 'msys';
+ chomp($stdout);
+ $stderr =~ s/\r\n/\n/g if $Config{osname} eq 'msys';
+ chomp($stderr);
+
+ if ($stdout eq $expected && $stderr eq '')
+ {
+ return 1;
+ }
+
+ # Wait 0.1 second before retrying.
+ usleep(100_000);
+
+ $attempts++;
+ }
+
+ # The query result didn't change in 180 seconds. Give up. Print the
+ # output from the last attempt, hopefully that's useful for debugging.
+ diag qq(poll_query_until timed out executing this query:
+$query
+expecting this output:
+$expected
+last actual query output:
+$stdout
+with stderr:
+$stderr);
+ return 0;
+}
+
+=pod
+
+=item $node->command_ok(...)
+
+Runs a shell command like PostgreSQL::Test::Utils::command_ok, but with PGHOST and PGPORT set
+so that the command will default to connecting to this PostgreSQL::Test::Cluster.
+
+=cut
+
+sub command_ok
+{
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+
+ my $self = shift;
+
+ local %ENV = $self->_get_env();
+
+ PostgreSQL::Test::Utils::command_ok(@_);
+ return;
+}
+
+=pod
+
+=item $node->command_fails(...)
+
+PostgreSQL::Test::Utils::command_fails with our connection parameters. See command_ok(...)
+
+=cut
+
+sub command_fails
+{
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+
+ my $self = shift;
+
+ local %ENV = $self->_get_env();
+
+ PostgreSQL::Test::Utils::command_fails(@_);
+ return;
+}
+
+=pod
+
+=item $node->command_like(...)
+
+PostgreSQL::Test::Utils::command_like with our connection parameters. See command_ok(...)
+
+=cut
+
+sub command_like
+{
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+
+ my $self = shift;
+
+ local %ENV = $self->_get_env();
+
+ PostgreSQL::Test::Utils::command_like(@_);
+ return;
+}
+
+=pod
+
+=item $node->command_fails_like(...)
+
+PostgreSQL::Test::Utils::command_fails_like with our connection parameters. See command_ok(...)
+
+=cut
+
+sub command_fails_like
+{
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+
+ my $self = shift;
+
+ local %ENV = $self->_get_env();
+
+ PostgreSQL::Test::Utils::command_fails_like(@_);
+ return;
+}
+
+=pod
+
+=item $node->command_checks_all(...)
+
+PostgreSQL::Test::Utils::command_checks_all with our connection parameters. See
+command_ok(...)
+
+=cut
+
+sub command_checks_all
+{
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+
+ my $self = shift;
+
+ local %ENV = $self->_get_env();
+
+ PostgreSQL::Test::Utils::command_checks_all(@_);
+ return;
+}
+
+=pod
+
+=item $node->issues_sql_like(cmd, expected_sql, test_name)
+
+Run a command on the node, then verify that $expected_sql appears in the
+server log file.
+
+=cut
+
+sub issues_sql_like
+{
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+
+ my ($self, $cmd, $expected_sql, $test_name) = @_;
+
+ local %ENV = $self->_get_env();
+
+ my $log_location = -s $self->logfile;
+
+ my $result = PostgreSQL::Test::Utils::run_log($cmd);
+ ok($result, "@$cmd exit code 0");
+ my $log = PostgreSQL::Test::Utils::slurp_file($self->logfile, $log_location);
+ like($log, $expected_sql, "$test_name: SQL found in server log");
+ return;
+}
+
+=pod
+
+=item $node->run_log(...)
+
+Runs a shell command like PostgreSQL::Test::Utils::run_log, but with connection parameters set
+so that the command will default to connecting to this PostgreSQL::Test::Cluster.
+
+=cut
+
+sub run_log
+{
+ my $self = shift;
+
+ local %ENV = $self->_get_env();
+
+ PostgreSQL::Test::Utils::run_log(@_);
+ return;
+}
+
+=pod
+
+=item $node->lsn(mode)
+
+Look up WAL locations on the server:
+
+ * insert location (primary only, error on replica)
+ * write location (primary only, error on replica)
+ * flush location (primary only, error on replica)
+ * receive location (always undef on primary)
+ * replay location (always undef on primary)
+
+mode must be specified.
+
+=cut
+
+sub lsn
+{
+ my ($self, $mode) = @_;
+ my %modes = (
+ 'insert' => 'pg_current_wal_insert_lsn()',
+ 'flush' => 'pg_current_wal_flush_lsn()',
+ 'write' => 'pg_current_wal_lsn()',
+ 'receive' => 'pg_last_wal_receive_lsn()',
+ 'replay' => 'pg_last_wal_replay_lsn()');
+
+ $mode = '<undef>' if !defined($mode);
+ croak "unknown mode for 'lsn': '$mode', valid modes are "
+ . join(', ', keys %modes)
+ if !defined($modes{$mode});
+
+ my $result = $self->safe_psql('postgres', "SELECT $modes{$mode}");
+ chomp($result);
+ if ($result eq '')
+ {
+ return;
+ }
+ else
+ {
+ return $result;
+ }
+}
+
+=pod
+
+=item $node->wait_for_catchup(standby_name, mode, target_lsn)
+
+Wait for the node with application_name standby_name (usually from node->name,
+also works for logical subscriptions)
+until its replication location in pg_stat_replication equals or passes the
+upstream's WAL insert point at the time this function is called. By default
+the replay_lsn is waited for, but 'mode' may be specified to wait for any of
+sent|write|flush|replay. The connection catching up must be in a streaming
+state.
+
+If there is no active replication connection from this peer, waits until
+poll_query_until timeout.
+
+Requires that the 'postgres' db exists and is accessible.
+
+target_lsn may be any arbitrary lsn, but is typically $primary_node->lsn('insert').
+If omitted, pg_current_wal_lsn() is used.
+
+This is not a test. It die()s on failure.
+
+=cut
+
+sub wait_for_catchup
+{
+ my ($self, $standby_name, $mode, $target_lsn) = @_;
+ $mode = defined($mode) ? $mode : 'replay';
+ my %valid_modes =
+ ('sent' => 1, 'write' => 1, 'flush' => 1, 'replay' => 1);
+ croak "unknown mode $mode for 'wait_for_catchup', valid modes are "
+ . join(', ', keys(%valid_modes))
+ unless exists($valid_modes{$mode});
+
+ # Allow passing of a PostgreSQL::Test::Cluster instance as shorthand
+ if (blessed($standby_name) && $standby_name->isa("PostgreSQL::Test::Cluster"))
+ {
+ $standby_name = $standby_name->name;
+ }
+ my $lsn_expr;
+ if (defined($target_lsn))
+ {
+ $lsn_expr = "'$target_lsn'";
+ }
+ else
+ {
+ $lsn_expr = 'pg_current_wal_lsn()';
+ }
+ print "Waiting for replication conn "
+ . $standby_name . "'s "
+ . $mode
+ . "_lsn to pass "
+ . $lsn_expr . " on "
+ . $self->name . "\n";
+ my $query =
+ qq[SELECT $lsn_expr <= ${mode}_lsn AND state = 'streaming' FROM pg_catalog.pg_stat_replication WHERE application_name = '$standby_name';];
+ $self->poll_query_until('postgres', $query)
+ or croak "timed out waiting for catchup";
+ print "done\n";
+ return;
+}
+
+=pod
+
+=item $node->wait_for_slot_catchup(slot_name, mode, target_lsn)
+
+Wait for the named replication slot to equal or pass the supplied target_lsn.
+The location used is the restart_lsn unless mode is given, in which case it may
+be 'restart' or 'confirmed_flush'.
+
+Requires that the 'postgres' db exists and is accessible.
+
+This is not a test. It die()s on failure.
+
+If the slot is not active, will time out after poll_query_until's timeout.
+
+target_lsn may be any arbitrary lsn, but is typically $primary_node->lsn('insert').
+
+Note that for logical slots, restart_lsn is held down by the oldest in-progress tx.
+
+=cut
+
+sub wait_for_slot_catchup
+{
+ my ($self, $slot_name, $mode, $target_lsn) = @_;
+ $mode = defined($mode) ? $mode : 'restart';
+ if (!($mode eq 'restart' || $mode eq 'confirmed_flush'))
+ {
+ croak "valid modes are restart, confirmed_flush";
+ }
+ croak 'target lsn must be specified' unless defined($target_lsn);
+ print "Waiting for replication slot "
+ . $slot_name . "'s "
+ . $mode
+ . "_lsn to pass "
+ . $target_lsn . " on "
+ . $self->name . "\n";
+ my $query =
+ qq[SELECT '$target_lsn' <= ${mode}_lsn FROM pg_catalog.pg_replication_slots WHERE slot_name = '$slot_name';];
+ $self->poll_query_until('postgres', $query)
+ or croak "timed out waiting for catchup";
+ print "done\n";
+ return;
+}
+
+=pod
+
+=item $node->query_hash($dbname, $query, @columns)
+
+Execute $query on $dbname, replacing any appearance of the string __COLUMNS__
+within the query with a comma-separated list of @columns.
+
+If __COLUMNS__ does not appear in the query, its result columns must EXACTLY
+match the order and number (but not necessarily alias) of supplied @columns.
+
+The query must return zero or one rows.
+
+Return a hash-ref representation of the results of the query, with any empty
+or null results as defined keys with an empty-string value. There is no way
+to differentiate between null and empty-string result fields.
+
+If the query returns zero rows, return a hash with all columns empty. There
+is no way to differentiate between zero rows returned and a row with only
+null columns.
+
+=cut
+
+sub query_hash
+{
+ my ($self, $dbname, $query, @columns) = @_;
+ croak 'calls in array context for multi-row results not supported yet'
+ if (wantarray);
+
+ # Replace __COLUMNS__ if found
+ substr($query, index($query, '__COLUMNS__'), length('__COLUMNS__')) =
+ join(', ', @columns)
+ if index($query, '__COLUMNS__') >= 0;
+ my $result = $self->safe_psql($dbname, $query);
+
+ # hash slice, see http://stackoverflow.com/a/16755894/398670 .
+ #
+ # Fills the hash with empty strings produced by x-operator element
+ # duplication if result is an empty row
+ #
+ my %val;
+ @val{@columns} =
+ $result ne '' ? split(qr/\|/, $result, -1) : ('',) x scalar(@columns);
+ return \%val;
+}
+
+=pod
+
+=item $node->slot(slot_name)
+
+Return hash-ref of replication slot data for the named slot, or a hash-ref with
+all values '' if not found. Does not differentiate between null and empty string
+for fields, no field is ever undef.
+
+The restart_lsn and confirmed_flush_lsn fields are returned verbatim, and also
+as a 2-list of [highword, lowword] integer. Since we rely on Perl 5.8.8 we can't
+"use bigint", it's from 5.20, and we can't assume we have Math::Bigint from CPAN
+either.
+
+=cut
+
+sub slot
+{
+ my ($self, $slot_name) = @_;
+ my @columns = (
+ 'plugin', 'slot_type', 'datoid', 'database',
+ 'active', 'active_pid', 'xmin', 'catalog_xmin',
+ 'restart_lsn');
+ return $self->query_hash(
+ 'postgres',
+ "SELECT __COLUMNS__ FROM pg_catalog.pg_replication_slots WHERE slot_name = '$slot_name'",
+ @columns);
+}
+
+=pod
+
+=item $node->pg_recvlogical_upto(self, dbname, slot_name, endpos, timeout_secs, ...)
+
+Invoke pg_recvlogical to read from slot_name on dbname until LSN endpos, which
+corresponds to pg_recvlogical --endpos. Gives up after timeout (if nonzero).
+
+Disallows pg_recvlogical from internally retrying on error by passing --no-loop.
+
+Plugin options are passed as additional keyword arguments.
+
+If called in scalar context, returns stdout, and die()s on timeout or nonzero return.
+
+If called in array context, returns a tuple of (retval, stdout, stderr, timeout).
+timeout is the IPC::Run::Timeout object whose is_expired method can be tested
+to check for timeout. retval is undef on timeout.
+
+=cut
+
+sub pg_recvlogical_upto
+{
+ my ($self, $dbname, $slot_name, $endpos, $timeout_secs, %plugin_options)
+ = @_;
+
+ local %ENV = $self->_get_env();
+
+ my ($stdout, $stderr);
+
+ my $timeout_exception = 'pg_recvlogical timed out';
+
+ croak 'slot name must be specified' unless defined($slot_name);
+ croak 'endpos must be specified' unless defined($endpos);
+
+ my @cmd = (
+ $self->installed_command('pg_recvlogical'),
+ '-S', $slot_name, '--dbname', $self->connstr($dbname));
+ push @cmd, '--endpos', $endpos;
+ push @cmd, '-f', '-', '--no-loop', '--start';
+
+ while (my ($k, $v) = each %plugin_options)
+ {
+ croak "= is not permitted to appear in replication option name"
+ if ($k =~ qr/=/);
+ push @cmd, "-o", "$k=$v";
+ }
+
+ my $timeout;
+ $timeout =
+ IPC::Run::timeout($timeout_secs, exception => $timeout_exception)
+ if $timeout_secs;
+ my $ret = 0;
+
+ do
+ {
+ local $@;
+ eval {
+ IPC::Run::run(\@cmd, ">", \$stdout, "2>", \$stderr, $timeout);
+ $ret = $?;
+ };
+ my $exc_save = $@;
+ if ($exc_save)
+ {
+
+ # IPC::Run::run threw an exception. re-throw unless it's a
+ # timeout, which we'll handle by testing is_expired
+ die $exc_save
+ if (blessed($exc_save) || $exc_save !~ qr/$timeout_exception/);
+
+ $ret = undef;
+
+ die "Got timeout exception '$exc_save' but timer not expired?!"
+ unless $timeout->is_expired;
+
+ die
+ "$exc_save waiting for endpos $endpos with stdout '$stdout', stderr '$stderr'"
+ unless wantarray;
+ }
+ };
+
+ $stdout =~ s/\r\n/\n/g if $Config{osname} eq 'msys';
+ $stderr =~ s/\r\n/\n/g if $Config{osname} eq 'msys';
+
+ if (wantarray)
+ {
+ return ($ret, $stdout, $stderr, $timeout);
+ }
+ else
+ {
+ die
+ "pg_recvlogical exited with code '$ret', stdout '$stdout' and stderr '$stderr'"
+ if $ret;
+ return $stdout;
+ }
+}
+
+=pod
+
+=back
+
+=cut
+
+1;
diff --git a/src/test/perl/PostgreSQL/Test/RecursiveCopy.pm b/src/test/perl/PostgreSQL/Test/RecursiveCopy.pm
new file mode 100644
index 00000000000..dd320a605e3
--- /dev/null
+++ b/src/test/perl/PostgreSQL/Test/RecursiveCopy.pm
@@ -0,0 +1,157 @@
+
+# Copyright (c) 2021, PostgreSQL Global Development Group
+
+=pod
+
+=head1 NAME
+
+PostgreSQL::Test::RecursiveCopy - simple recursive copy implementation
+
+=head1 SYNOPSIS
+
+use PostgreSQL::Test::RecursiveCopy;
+
+PostgreSQL::Test::RecursiveCopy::copypath($from, $to, filterfn => sub { return 1; });
+PostgreSQL::Test::RecursiveCopy::copypath($from, $to);
+
+=cut
+
+package PostgreSQL::Test::RecursiveCopy;
+
+use strict;
+use warnings;
+
+use Carp;
+use File::Basename;
+use File::Copy;
+
+=pod
+
+=head1 DESCRIPTION
+
+=head2 copypath($from, $to, %params)
+
+Recursively copy all files and directories from $from to $to.
+Does not preserve file metadata (e.g., permissions).
+
+Only regular files and subdirectories are copied. Trying to copy other types
+of directory entries raises an exception.
+
+Raises an exception if a file would be overwritten, the source directory can't
+be read, or any I/O operation fails. However, we silently ignore ENOENT on
+open, because when copying from a live database it's possible for a file/dir
+to be deleted after we see its directory entry but before we can open it.
+
+Always returns true.
+
+If the B<filterfn> parameter is given, it must be a subroutine reference.
+This subroutine will be called for each entry in the source directory with its
+relative path as only parameter; if the subroutine returns true the entry is
+copied, otherwise the file is skipped.
+
+On failure the target directory may be in some incomplete state; no cleanup is
+attempted.
+
+=head1 EXAMPLES
+
+ PostgreSQL::Test::RecursiveCopy::copypath('/some/path', '/empty/dir',
+ filterfn => sub {
+ # omit log/ and contents
+ my $src = shift;
+ return $src ne 'log';
+ }
+ );
+
+=cut
+
+sub copypath
+{
+ my ($base_src_dir, $base_dest_dir, %params) = @_;
+ my $filterfn;
+
+ if (defined $params{filterfn})
+ {
+ croak "if specified, filterfn must be a subroutine reference"
+ unless defined(ref $params{filterfn})
+ and (ref $params{filterfn} eq 'CODE');
+
+ $filterfn = $params{filterfn};
+ }
+ else
+ {
+ $filterfn = sub { return 1; };
+ }
+
+ # Complain if original path is bogus, because _copypath_recurse won't.
+ croak "\"$base_src_dir\" does not exist" if !-e $base_src_dir;
+
+ # Start recursive copy from current directory
+ return _copypath_recurse($base_src_dir, $base_dest_dir, "", $filterfn);
+}
+
+# Recursive private guts of copypath
+sub _copypath_recurse
+{
+ my ($base_src_dir, $base_dest_dir, $curr_path, $filterfn) = @_;
+ my $srcpath = "$base_src_dir/$curr_path";
+ my $destpath = "$base_dest_dir/$curr_path";
+
+ # invoke the filter and skip all further operation if it returns false
+ return 1 unless &$filterfn($curr_path);
+
+ # Check for symlink -- needed only on source dir
+ # (note: this will fall through quietly if file is already gone)
+ croak "Cannot operate on symlink \"$srcpath\"" if -l $srcpath;
+
+ # Abort if destination path already exists. Should we allow directories
+ # to exist already?
+ croak "Destination path \"$destpath\" already exists" if -e $destpath;
+
+ # If this source path is a file, simply copy it to destination with the
+ # same name and we're done.
+ if (-f $srcpath)
+ {
+ my $fh;
+ unless (open($fh, '<', $srcpath))
+ {
+ return 1 if ($!{ENOENT});
+ die "open($srcpath) failed: $!";
+ }
+ copy($fh, $destpath)
+ or die "copy $srcpath -> $destpath failed: $!";
+ close $fh;
+ return 1;
+ }
+
+ # If it's a directory, create it on dest and recurse into it.
+ if (-d $srcpath)
+ {
+ my $directory;
+ unless (opendir($directory, $srcpath))
+ {
+ return 1 if ($!{ENOENT});
+ die "opendir($srcpath) failed: $!";
+ }
+
+ mkdir($destpath) or die "mkdir($destpath) failed: $!";
+
+ while (my $entry = readdir($directory))
+ {
+ next if ($entry eq '.' or $entry eq '..');
+ _copypath_recurse($base_src_dir, $base_dest_dir,
+ $curr_path eq '' ? $entry : "$curr_path/$entry", $filterfn)
+ or die "copypath $srcpath/$entry -> $destpath/$entry failed";
+ }
+
+ closedir($directory);
+ return 1;
+ }
+
+ # If it disappeared from sight, that's OK.
+ return 1 if !-e $srcpath;
+
+ # Else it's some weird file type; complain.
+ croak "Source path \"$srcpath\" is not a regular file or directory";
+}
+
+1;
diff --git a/src/test/perl/PostgreSQL/Test/SimpleTee.pm b/src/test/perl/PostgreSQL/Test/SimpleTee.pm
new file mode 100644
index 00000000000..80a56fc0ea8
--- /dev/null
+++ b/src/test/perl/PostgreSQL/Test/SimpleTee.pm
@@ -0,0 +1,35 @@
+
+# Copyright (c) 2021, PostgreSQL Global Development Group
+
+# A simple 'tee' implementation, using perl tie.
+#
+# Whenever you print to the handle, it gets forwarded to a list of
+# handles. The list of output filehandles is passed to the constructor.
+#
+# This is similar to IO::Tee, but only used for output. Only the PRINT
+# method is currently implemented; that's all we need. We don't want to
+# depend on IO::Tee just for this.
+
+package PostgreSQL::Test::SimpleTee;
+use strict;
+use warnings;
+
+sub TIEHANDLE
+{
+ my $self = shift;
+ return bless \@_, $self;
+}
+
+sub PRINT
+{
+ my $self = shift;
+ my $ok = 1;
+ for my $fh (@$self)
+ {
+ print $fh @_ or $ok = 0;
+ $fh->flush or $ok = 0;
+ }
+ return $ok;
+}
+
+1;
diff --git a/src/test/perl/PostgreSQL/Test/Utils.pm b/src/test/perl/PostgreSQL/Test/Utils.pm
new file mode 100644
index 00000000000..f29d43f1f32
--- /dev/null
+++ b/src/test/perl/PostgreSQL/Test/Utils.pm
@@ -0,0 +1,1007 @@
+
+# Copyright (c) 2021, PostgreSQL Global Development Group
+
+=pod
+
+=head1 NAME
+
+PostgreSQL::Test::Utils - helper module for writing PostgreSQL's C<prove> tests.
+
+=head1 SYNOPSIS
+
+ use PostgreSQL::Test::Utils;
+
+ # Test basic output of a command
+ program_help_ok('initdb');
+ program_version_ok('initdb');
+ program_options_handling_ok('initdb');
+
+ # Test option combinations
+ command_fails(['initdb', '--invalid-option'],
+ 'command fails with invalid option');
+ my $tempdir = PostgreSQL::Test::Utils::tempdir;
+ command_ok('initdb', '-D', $tempdir);
+
+ # Miscellanea
+ print "on Windows" if $PostgreSQL::Test::Utils::windows_os;
+ my $path = PostgreSQL::Test::Utils::perl2host($backup_dir);
+ ok(check_mode_recursive($stream_dir, 0700, 0600),
+ "check stream dir permissions");
+ PostgreSQL::Test::Utils::system_log('pg_ctl', 'kill', 'QUIT', $slow_pid);
+
+=head1 DESCRIPTION
+
+C<PostgreSQL::Test::Utils> contains a set of routines dedicated to environment setup for
+a PostgreSQL regression test run and includes some low-level routines
+aimed at controlling command execution, logging and test functions.
+
+=cut
+
+# This module should never depend on any other PostgreSQL regression test
+# modules.
+
+package PostgreSQL::Test::Utils;
+
+use strict;
+use warnings;
+
+use Carp;
+use Config;
+use Cwd;
+use Exporter 'import';
+use Fcntl qw(:mode :seek);
+use File::Basename;
+use File::Find;
+use File::Spec;
+use File::stat qw(stat);
+use File::Temp ();
+use IPC::Run;
+use PostgreSQL::Test::SimpleTee;
+
+# specify a recent enough version of Test::More to support the
+# done_testing() function
+use Test::More 0.87;
+
+our @EXPORT = qw(
+ generate_ascii_string
+ slurp_dir
+ slurp_file
+ append_to_file
+ check_mode_recursive
+ chmod_recursive
+ check_pg_config
+ dir_symlink
+ system_or_bail
+ system_log
+ run_log
+ run_command
+
+ command_ok
+ command_fails
+ command_exit_is
+ program_help_ok
+ program_version_ok
+ program_options_handling_ok
+ command_like
+ command_like_safe
+ command_fails_like
+ command_checks_all
+
+ $windows_os
+ $is_msys2
+ $use_unix_sockets
+);
+
+our ($windows_os, $is_msys2, $use_unix_sockets, $tmp_check, $log_path,
+ $test_logfile);
+
+BEGIN
+{
+
+ # Set to untranslated messages, to be able to compare program output
+ # with expected strings.
+ delete $ENV{LANGUAGE};
+ delete $ENV{LC_ALL};
+ $ENV{LC_MESSAGES} = 'C';
+
+ # This list should be kept in sync with pg_regress.c.
+ my @envkeys = qw (
+ PGCHANNELBINDING
+ PGCLIENTENCODING
+ PGCONNECT_TIMEOUT
+ PGDATA
+ PGDATABASE
+ PGGSSENCMODE
+ PGGSSLIB
+ PGHOSTADDR
+ PGKRBSRVNAME
+ PGPASSFILE
+ PGPASSWORD
+ PGREQUIREPEER
+ PGREQUIRESSL
+ PGSERVICE
+ PGSERVICEFILE
+ PGSSLCERT
+ PGSSLCRL
+ PGSSLCRLDIR
+ PGSSLKEY
+ PGSSLMAXPROTOCOLVERSION
+ PGSSLMINPROTOCOLVERSION
+ PGSSLMODE
+ PGSSLROOTCERT
+ PGSSLSNI
+ PGTARGETSESSIONATTRS
+ PGUSER
+ PGPORT
+ PGHOST
+ PG_COLOR
+ );
+ delete @ENV{@envkeys};
+
+ $ENV{PGAPPNAME} = basename($0);
+
+ # Must be set early
+ $windows_os = $Config{osname} eq 'MSWin32' || $Config{osname} eq 'msys';
+ # Check if this environment is MSYS2.
+ $is_msys2 = $^O eq 'msys' && `uname -or` =~ /^[2-9].*Msys/;
+
+ if ($windows_os)
+ {
+ require Win32API::File;
+ Win32API::File->import(
+ qw(createFile OsFHandleOpen CloseHandle));
+ }
+
+ # Specifies whether to use Unix sockets for test setups. On
+ # Windows we don't use them by default since it's not universally
+ # supported, but it can be overridden if desired.
+ $use_unix_sockets =
+ (!$windows_os || defined $ENV{PG_TEST_USE_UNIX_SOCKETS});
+}
+
+=pod
+
+=head1 EXPORTED VARIABLES
+
+=over
+
+=item C<$windows_os>
+
+Set to true when running under Windows, except on Cygwin.
+
+=item C<$is_msys2>
+
+Set to true when running under MSYS2.
+
+=back
+
+=cut
+
+INIT
+{
+
+ # Return EPIPE instead of killing the process with SIGPIPE. An affected
+ # test may still fail, but it's more likely to report useful facts.
+ $SIG{PIPE} = 'IGNORE';
+
+ # Determine output directories, and create them. The base path is the
+ # TESTDIR environment variable, which is normally set by the invoking
+ # Makefile.
+ $tmp_check = $ENV{TESTDIR} ? "$ENV{TESTDIR}/tmp_check" : "tmp_check";
+ $log_path = "$tmp_check/log";
+
+ mkdir $tmp_check;
+ mkdir $log_path;
+
+ # Open the test log file, whose name depends on the test name.
+ $test_logfile = basename($0);
+ $test_logfile =~ s/\.[^.]+$//;
+ $test_logfile = "$log_path/regress_log_$test_logfile";
+ open my $testlog, '>', $test_logfile
+ or die "could not open STDOUT to logfile \"$test_logfile\": $!";
+
+ # Hijack STDOUT and STDERR to the log file
+ open(my $orig_stdout, '>&', \*STDOUT);
+ open(my $orig_stderr, '>&', \*STDERR);
+ open(STDOUT, '>&', $testlog);
+ open(STDERR, '>&', $testlog);
+
+ # The test output (ok ...) needs to be printed to the original STDOUT so
+ # that the 'prove' program can parse it, and display it to the user in
+ # real time. But also copy it to the log file, to provide more context
+ # in the log.
+ my $builder = Test::More->builder;
+ my $fh = $builder->output;
+ tie *$fh, "PostgreSQL::Test::SimpleTee", $orig_stdout, $testlog;
+ $fh = $builder->failure_output;
+ tie *$fh, "PostgreSQL::Test::SimpleTee", $orig_stderr, $testlog;
+
+ # Enable auto-flushing for all the file handles. Stderr and stdout are
+ # redirected to the same file, and buffering causes the lines to appear
+ # in the log in confusing order.
+ autoflush STDOUT 1;
+ autoflush STDERR 1;
+ autoflush $testlog 1;
+}
+
+END
+{
+
+ # Test files have several ways of causing prove_check to fail:
+ # 1. Exit with a non-zero status.
+ # 2. Call ok(0) or similar, indicating that a constituent test failed.
+ # 3. Deviate from the planned number of tests.
+ #
+ # Preserve temporary directories after (1) and after (2).
+ $File::Temp::KEEP_ALL = 1 unless $? == 0 && all_tests_passing();
+}
+
+=pod
+
+=head1 ROUTINES
+
+=over
+
+=item all_tests_passing()
+
+Return 1 if all the tests run so far have passed. Otherwise, return 0.
+
+=cut
+
+sub all_tests_passing
+{
+ foreach my $status (Test::More->builder->summary)
+ {
+ return 0 unless $status;
+ }
+ return 1;
+}
+
+=pod
+
+=item tempdir(prefix)
+
+Securely create a temporary directory inside C<$tmp_check>, like C<mkdtemp>,
+and return its name. The directory will be removed automatically at the
+end of the tests.
+
+If C<prefix> is given, the new directory is templated as C<${prefix}_XXXX>.
+Otherwise the template is C<tmp_test_XXXX>.
+
+=cut
+
+sub tempdir
+{
+ my ($prefix) = @_;
+ $prefix = "tmp_test" unless defined $prefix;
+ return File::Temp::tempdir(
+ $prefix . '_XXXX',
+ DIR => $tmp_check,
+ CLEANUP => 1);
+}
+
+=pod
+
+=item tempdir_short()
+
+As above, but the directory is outside the build tree so that it has a short
+name, to avoid path length issues.
+
+=cut
+
+sub tempdir_short
+{
+
+ return File::Temp::tempdir(CLEANUP => 1);
+}
+
+=pod
+
+=item perl2host()
+
+Translate a virtual file name to a host file name. Currently, this is a no-op
+except for the case of Perl=msys and host=mingw32. The subject need not
+exist, but its parent or grandparent directory must exist unless cygpath is
+available.
+
+The returned path uses forward slashes but has no trailing slash.
+
+=cut
+
+sub perl2host
+{
+ my ($subject) = @_;
+ return $subject unless $Config{osname} eq 'msys';
+ if ($is_msys2)
+ {
+ # get absolute, windows type path
+ my $path = qx{cygpath -a -m "$subject"};
+ if (!$?)
+ {
+ chomp $path;
+ $path =~ s!/$!!;
+ return $path if $path;
+ }
+ # fall through if this didn't work.
+ }
+ my $here = cwd;
+ my $leaf;
+ if (chdir $subject)
+ {
+ $leaf = '';
+ }
+ else
+ {
+ $leaf = '/' . basename $subject;
+ my $parent = dirname $subject;
+ if (!chdir $parent)
+ {
+ $leaf = '/' . basename($parent) . $leaf;
+ $parent = dirname $parent;
+ chdir $parent or die "could not chdir \"$parent\": $!";
+ }
+ }
+
+ # this odd way of calling 'pwd -W' is the only way that seems to work.
+ my $dir = qx{sh -c "pwd -W"};
+ chomp $dir;
+ $dir =~ s!/$!!;
+ chdir $here;
+ return $dir . $leaf;
+}
+
+=pod
+
+=item system_log(@cmd)
+
+Run (via C<system()>) the command passed as argument; the return
+value is passed through.
+
+=cut
+
+sub system_log
+{
+ print("# Running: " . join(" ", @_) . "\n");
+ return system(@_);
+}
+
+=pod
+
+=item system_or_bail(@cmd)
+
+Run (via C<system()>) the command passed as argument, and returns
+if the command is successful.
+On failure, abandon further tests and exit the program.
+
+=cut
+
+sub system_or_bail
+{
+ if (system_log(@_) != 0)
+ {
+ if ($? == -1)
+ {
+ BAIL_OUT(
+ sprintf(
+ "failed to execute command \"%s\": $!", join(" ", @_)));
+ }
+ elsif ($? & 127)
+ {
+ BAIL_OUT(
+ sprintf(
+ "command \"%s\" died with signal %d",
+ join(" ", @_),
+ $? & 127));
+ }
+ else
+ {
+ BAIL_OUT(
+ sprintf(
+ "command \"%s\" exited with value %d",
+ join(" ", @_),
+ $? >> 8));
+ }
+ }
+}
+
+=pod
+
+=item run_log(@cmd)
+
+Run the given command via C<IPC::Run::run()>, noting it in the log.
+The return value from the command is passed through.
+
+=cut
+
+sub run_log
+{
+ print("# Running: " . join(" ", @{ $_[0] }) . "\n");
+ return IPC::Run::run(@_);
+}
+
+=pod
+
+=item run_command(cmd)
+
+Run (via C<IPC::Run::run()>) the command passed as argument.
+The return value from the command is ignored.
+The return value is C<($stdout, $stderr)>.
+
+=cut
+
+sub run_command
+{
+ my ($cmd) = @_;
+ my ($stdout, $stderr);
+ my $result = IPC::Run::run $cmd, '>', \$stdout, '2>', \$stderr;
+ foreach ($stderr, $stdout) { s/\r\n/\n/g if $Config{osname} eq 'msys'; }
+ chomp($stdout);
+ chomp($stderr);
+ return ($stdout, $stderr);
+}
+
+=pod
+
+=item generate_ascii_string(from_char, to_char)
+
+Generate a string made of the given range of ASCII characters.
+
+=cut
+
+sub generate_ascii_string
+{
+ my ($from_char, $to_char) = @_;
+ my $res;
+
+ for my $i ($from_char .. $to_char)
+ {
+ $res .= sprintf("%c", $i);
+ }
+ return $res;
+}
+
+=pod
+
+=item slurp_dir(dir)
+
+Return the complete list of entries in the specified directory.
+
+=cut
+
+sub slurp_dir
+{
+ my ($dir) = @_;
+ opendir(my $dh, $dir)
+ or croak "could not opendir \"$dir\": $!";
+ my @direntries = readdir $dh;
+ closedir $dh;
+ return @direntries;
+}
+
+=pod
+
+=item slurp_file(filename [, $offset])
+
+Return the full contents of the specified file, beginning from an
+offset position if specified.
+
+=cut
+
+sub slurp_file
+{
+ my ($filename, $offset) = @_;
+ local $/;
+ my $contents;
+ my $fh;
+
+ # On windows open file using win32 APIs, to allow us to set the
+ # FILE_SHARE_DELETE flag ("d" below), otherwise other accesses to the file
+ # may fail.
+ if ($Config{osname} ne 'MSWin32')
+ {
+ open($fh, '<', $filename)
+ or croak "could not read \"$filename\": $!";
+ }
+ else
+ {
+ my $fHandle = createFile($filename, "r", "rwd")
+ or croak "could not open \"$filename\": $^E";
+ OsFHandleOpen($fh = IO::Handle->new(), $fHandle, 'r')
+ or croak "could not read \"$filename\": $^E\n";
+ }
+
+ if (defined($offset))
+ {
+ seek($fh, $offset, SEEK_SET)
+ or croak "could not seek \"$filename\": $!";
+ }
+
+ $contents = <$fh>;
+ close $fh;
+
+ $contents =~ s/\r\n/\n/g if $Config{osname} eq 'msys';
+ return $contents;
+}
+
+=pod
+
+=item append_to_file(filename, str)
+
+Append a string at the end of a given file. (Note: no newline is appended at
+end of file.)
+
+=cut
+
+sub append_to_file
+{
+ my ($filename, $str) = @_;
+ open my $fh, ">>", $filename
+ or croak "could not write \"$filename\": $!";
+ print $fh $str;
+ close $fh;
+ return;
+}
+
+=pod
+
+=item check_mode_recursive(dir, expected_dir_mode, expected_file_mode, ignore_list)
+
+Check that all file/dir modes in a directory match the expected values,
+ignoring files in C<ignore_list> (basename only).
+
+=cut
+
+sub check_mode_recursive
+{
+ my ($dir, $expected_dir_mode, $expected_file_mode, $ignore_list) = @_;
+
+ # Result defaults to true
+ my $result = 1;
+
+ find(
+ {
+ follow_fast => 1,
+ wanted => sub {
+ # Is file in the ignore list?
+ foreach my $ignore ($ignore_list ? @{$ignore_list} : [])
+ {
+ if ("$dir/$ignore" eq $File::Find::name)
+ {
+ return;
+ }
+ }
+
+ # Allow ENOENT. A running server can delete files, such as
+ # those in pg_stat. Other stat() failures are fatal.
+ my $file_stat = stat($File::Find::name);
+ unless (defined($file_stat))
+ {
+ my $is_ENOENT = $!{ENOENT};
+ my $msg = "unable to stat $File::Find::name: $!";
+ if ($is_ENOENT)
+ {
+ warn $msg;
+ return;
+ }
+ else
+ {
+ die $msg;
+ }
+ }
+
+ my $file_mode = S_IMODE($file_stat->mode);
+
+ # Is this a file?
+ if (S_ISREG($file_stat->mode))
+ {
+ if ($file_mode != $expected_file_mode)
+ {
+ print(
+ *STDERR,
+ sprintf("$File::Find::name mode must be %04o\n",
+ $expected_file_mode));
+
+ $result = 0;
+ return;
+ }
+ }
+
+ # Else a directory?
+ elsif (S_ISDIR($file_stat->mode))
+ {
+ if ($file_mode != $expected_dir_mode)
+ {
+ print(
+ *STDERR,
+ sprintf("$File::Find::name mode must be %04o\n",
+ $expected_dir_mode));
+
+ $result = 0;
+ return;
+ }
+ }
+
+ # Else something we can't handle
+ else
+ {
+ die "unknown file type for $File::Find::name";
+ }
+ }
+ },
+ $dir);
+
+ return $result;
+}
+
+=pod
+
+=item chmod_recursive(dir, dir_mode, file_mode)
+
+C<chmod> recursively each file and directory within the given directory.
+
+=cut
+
+sub chmod_recursive
+{
+ my ($dir, $dir_mode, $file_mode) = @_;
+
+ find(
+ {
+ follow_fast => 1,
+ wanted => sub {
+ my $file_stat = stat($File::Find::name);
+
+ if (defined($file_stat))
+ {
+ chmod(
+ S_ISDIR($file_stat->mode) ? $dir_mode : $file_mode,
+ $File::Find::name
+ ) or die "unable to chmod $File::Find::name";
+ }
+ }
+ },
+ $dir);
+ return;
+}
+
+=pod
+
+=item check_pg_config(regexp)
+
+Return the number of matches of the given regular expression
+within the installation's C<pg_config.h>.
+
+=cut
+
+sub check_pg_config
+{
+ my ($regexp) = @_;
+ my ($stdout, $stderr);
+ my $result = IPC::Run::run [ 'pg_config', '--includedir' ], '>',
+ \$stdout, '2>', \$stderr
+ or die "could not execute pg_config";
+ chomp($stdout);
+ $stdout =~ s/\r$//;
+
+ open my $pg_config_h, '<', "$stdout/pg_config.h" or die "$!";
+ my $match = (grep { /^$regexp/ } <$pg_config_h>);
+ close $pg_config_h;
+ return $match;
+}
+
+=pod
+
+=item dir_symlink(oldname, newname)
+
+Portably create a symlink for a directory. On Windows this creates a junction
+point. Elsewhere it just calls perl's builtin symlink.
+
+=cut
+
+sub dir_symlink
+{
+ my $oldname = shift;
+ my $newname = shift;
+ if ($windows_os)
+ {
+ $oldname = perl2host($oldname);
+ $newname = perl2host($newname);
+ $oldname =~ s,/,\\,g;
+ $newname =~ s,/,\\,g;
+ my $cmd = qq{mklink /j "$newname" "$oldname"};
+ if ($Config{osname} eq 'msys')
+ {
+ # need some indirection on msys
+ $cmd = qq{echo '$cmd' | \$COMSPEC /Q};
+ }
+ system($cmd);
+ }
+ else
+ {
+ symlink $oldname, $newname;
+ }
+ die "No $newname" unless -e $newname;
+}
+
+=pod
+
+=back
+
+=head1 Test::More-LIKE METHODS
+
+=over
+
+=item command_ok(cmd, test_name)
+
+Check that the command runs (via C<run_log>) successfully.
+
+=cut
+
+sub command_ok
+{
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ my ($cmd, $test_name) = @_;
+ my $result = run_log($cmd);
+ ok($result, $test_name);
+ return;
+}
+
+=pod
+
+=item command_fails(cmd, test_name)
+
+Check that the command fails (when run via C<run_log>).
+
+=cut
+
+sub command_fails
+{
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ my ($cmd, $test_name) = @_;
+ my $result = run_log($cmd);
+ ok(!$result, $test_name);
+ return;
+}
+
+=pod
+
+=item command_exit_is(cmd, expected, test_name)
+
+Check that the command exit code matches the expected exit code.
+
+=cut
+
+sub command_exit_is
+{
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ my ($cmd, $expected, $test_name) = @_;
+ print("# Running: " . join(" ", @{$cmd}) . "\n");
+ my $h = IPC::Run::start $cmd;
+ $h->finish();
+
+ # On Windows, the exit status of the process is returned directly as the
+ # process's exit code, while on Unix, it's returned in the high bits
+ # of the exit code (see WEXITSTATUS macro in the standard <sys/wait.h>
+ # header file). IPC::Run's result function always returns exit code >> 8,
+ # assuming the Unix convention, which will always return 0 on Windows as
+ # long as the process was not terminated by an exception. To work around
+ # that, use $h->full_results on Windows instead.
+ my $result =
+ ($Config{osname} eq "MSWin32")
+ ? ($h->full_results)[0]
+ : $h->result(0);
+ is($result, $expected, $test_name);
+ return;
+}
+
+=pod
+
+=item program_help_ok(cmd)
+
+Check that the command supports the C<--help> option.
+
+=cut
+
+sub program_help_ok
+{
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ my ($cmd) = @_;
+ my ($stdout, $stderr);
+ print("# Running: $cmd --help\n");
+ my $result = IPC::Run::run [ $cmd, '--help' ], '>', \$stdout, '2>',
+ \$stderr;
+ ok($result, "$cmd --help exit code 0");
+ isnt($stdout, '', "$cmd --help goes to stdout");
+ is($stderr, '', "$cmd --help nothing to stderr");
+ return;
+}
+
+=pod
+
+=item program_version_ok(cmd)
+
+Check that the command supports the C<--version> option.
+
+=cut
+
+sub program_version_ok
+{
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ my ($cmd) = @_;
+ my ($stdout, $stderr);
+ print("# Running: $cmd --version\n");
+ my $result = IPC::Run::run [ $cmd, '--version' ], '>', \$stdout, '2>',
+ \$stderr;
+ ok($result, "$cmd --version exit code 0");
+ isnt($stdout, '', "$cmd --version goes to stdout");
+ is($stderr, '', "$cmd --version nothing to stderr");
+ return;
+}
+
+=pod
+
+=item program_options_handling_ok(cmd)
+
+Check that a command with an invalid option returns a non-zero
+exit code and error message.
+
+=cut
+
+sub program_options_handling_ok
+{
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ my ($cmd) = @_;
+ my ($stdout, $stderr);
+ print("# Running: $cmd --not-a-valid-option\n");
+ my $result = IPC::Run::run [ $cmd, '--not-a-valid-option' ], '>',
+ \$stdout,
+ '2>', \$stderr;
+ ok(!$result, "$cmd with invalid option nonzero exit code");
+ isnt($stderr, '', "$cmd with invalid option prints error message");
+ return;
+}
+
+=pod
+
+=item command_like(cmd, expected_stdout, test_name)
+
+Check that the command runs successfully and the output
+matches the given regular expression.
+
+=cut
+
+sub command_like
+{
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ my ($cmd, $expected_stdout, $test_name) = @_;
+ my ($stdout, $stderr);
+ print("# Running: " . join(" ", @{$cmd}) . "\n");
+ my $result = IPC::Run::run $cmd, '>', \$stdout, '2>', \$stderr;
+ ok($result, "$test_name: exit code 0");
+ is($stderr, '', "$test_name: no stderr");
+ $stdout =~ s/\r\n/\n/g if $Config{osname} eq 'msys';
+ like($stdout, $expected_stdout, "$test_name: matches");
+ return;
+}
+
+=pod
+
+=item command_like_safe(cmd, expected_stdout, test_name)
+
+Check that the command runs successfully and the output
+matches the given regular expression. Doesn't assume that the
+output files are closed.
+
+=cut
+
+sub command_like_safe
+{
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+
+ # Doesn't rely on detecting end of file on the file descriptors,
+ # which can fail, causing the process to hang, notably on Msys
+ # when used with 'pg_ctl start'
+ my ($cmd, $expected_stdout, $test_name) = @_;
+ my ($stdout, $stderr);
+ my $stdoutfile = File::Temp->new();
+ my $stderrfile = File::Temp->new();
+ print("# Running: " . join(" ", @{$cmd}) . "\n");
+ my $result = IPC::Run::run $cmd, '>', $stdoutfile, '2>', $stderrfile;
+ $stdout = slurp_file($stdoutfile);
+ $stderr = slurp_file($stderrfile);
+ ok($result, "$test_name: exit code 0");
+ is($stderr, '', "$test_name: no stderr");
+ like($stdout, $expected_stdout, "$test_name: matches");
+ return;
+}
+
+=pod
+
+=item command_fails_like(cmd, expected_stderr, test_name)
+
+Check that the command fails and the error message matches
+the given regular expression.
+
+=cut
+
+sub command_fails_like
+{
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ my ($cmd, $expected_stderr, $test_name) = @_;
+ my ($stdout, $stderr);
+ print("# Running: " . join(" ", @{$cmd}) . "\n");
+ my $result = IPC::Run::run $cmd, '>', \$stdout, '2>', \$stderr;
+ ok(!$result, "$test_name: exit code not 0");
+ $stderr =~ s/\r\n/\n/g if $Config{osname} eq 'msys';
+ like($stderr, $expected_stderr, "$test_name: matches");
+ return;
+}
+
+=pod
+
+=item command_checks_all(cmd, ret, out, err, test_name)
+
+Run a command and check its status and outputs.
+Arguments:
+
+=over
+
+=item C<cmd>: Array reference of command and arguments to run
+
+=item C<ret>: Expected exit code
+
+=item C<out>: Expected stdout from command
+
+=item C<err>: Expected stderr from command
+
+=item C<test_name>: test name
+
+=back
+
+=cut
+
+sub command_checks_all
+{
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+
+ my ($cmd, $expected_ret, $out, $err, $test_name) = @_;
+
+ # run command
+ my ($stdout, $stderr);
+ print("# Running: " . join(" ", @{$cmd}) . "\n");
+ IPC::Run::run($cmd, '>', \$stdout, '2>', \$stderr);
+
+ # See http://perldoc.perl.org/perlvar.html#%24CHILD_ERROR
+ my $ret = $?;
+ die "command exited with signal " . ($ret & 127)
+ if $ret & 127;
+ $ret = $ret >> 8;
+
+ foreach ($stderr, $stdout) { s/\r\n/\n/g if $Config{osname} eq 'msys'; }
+
+ # check status
+ ok($ret == $expected_ret,
+ "$test_name status (got $ret vs expected $expected_ret)");
+
+ # check stdout
+ for my $re (@$out)
+ {
+ like($stdout, $re, "$test_name stdout /$re/");
+ }
+
+ # check stderr
+ for my $re (@$err)
+ {
+ like($stderr, $re, "$test_name stderr /$re/");
+ }
+
+ return;
+}
+
+=pod
+
+=back
+
+=cut
+
+1;
diff --git a/src/test/perl/PostgreSQL/Version.pm b/src/test/perl/PostgreSQL/Version.pm
new file mode 100644
index 00000000000..08c7f7f5191
--- /dev/null
+++ b/src/test/perl/PostgreSQL/Version.pm
@@ -0,0 +1,164 @@
+############################################################################
+#
+# PostgreSQL/Version.pm
+#
+# Module encapsulating Postgres Version numbers
+#
+# Copyright (c) 2021, PostgreSQL Global Development Group
+#
+############################################################################
+
+=pod
+
+=head1 NAME
+
+PostgreSQL::Version - class representing PostgreSQL version numbers
+
+=head1 SYNOPSIS
+
+ use PostgreSQL::Version;
+
+ my $version = PostgreSQL::Version->new($version_arg);
+
+ # compare two versions
+ my $bool = $version1 <= $version2;
+
+ # or compare with a number
+ $bool = $version < 12;
+
+ # or with a string
+ $bool = $version lt "13.1";
+
+ # interpolate in a string
+ my $stringyval = "version: $version";
+
+ # get the major version
+ my $maj = $version->major;
+
+=head1 DESCRIPTION
+
+PostgreSQL::Version encapsulates Postgres version numbers, providing parsing
+of common version formats and comparison operations.
+
+=cut
+
+package PostgreSQL::Version;
+
+use strict;
+use warnings;
+
+use Scalar::Util qw(blessed);
+
+use overload
+ '<=>' => \&_version_cmp,
+ 'cmp' => \&_version_cmp,
+ '""' => \&_stringify;
+
+=pod
+
+=head1 METHODS
+
+=over
+
+=item PostgreSQL::Version->new($version)
+
+Create a new PostgreSQL::Version instance.
+
+The argument can be a number like 12, or a string like '12.2' or the output
+of a Postgres command like `psql --version` or `pg_config --version`;
+
+=back
+
+=cut
+
+sub new
+{
+ my $class = shift;
+ my $arg = shift;
+
+ chomp $arg;
+
+ # Accept standard formats, in case caller has handed us the output of a
+ # postgres command line tool
+ my $devel;
+ ($arg, $devel) = ($1, $2)
+ if (
+ $arg =~ m!^ # beginning of line
+ (?:\(?PostgreSQL\)?\s)? # ignore PostgreSQL marker
+ (\d+(?:\.\d+)*) # version number, dotted notation
+ (devel|(?:alpha|beta|rc)\d+)? # dev marker - see version_stamp.pl
+ !x);
+
+ # Split into an array
+ my @numbers = split(/\./, $arg);
+
+ # Treat development versions as having a minor/micro version one less than
+ # the first released version of that branch.
+ push @numbers, -1 if ($devel);
+
+ $devel ||= "";
+
+ return bless { str => "$arg$devel", num => \@numbers }, $class;
+}
+
+# Routine which compares the _pg_version_array obtained for the two
+# arguments and returns -1, 0, or 1, allowing comparison between two
+# PostgreSQL::Version objects or a PostgreSQL::Version and a version string or number.
+#
+# If the second argument is not a blessed object we call the constructor
+# to make one.
+#
+# Because we're overloading '<=>' and 'cmp' this function supplies us with
+# all the comparison operators ('<' and friends, 'gt' and friends)
+#
+sub _version_cmp
+{
+ my ($a, $b, $swapped) = @_;
+
+ $b = __PACKAGE__->new($b) unless blessed($b);
+
+ ($a, $b) = ($b, $a) if $swapped;
+
+ my ($an, $bn) = ($a->{num}, $b->{num});
+
+ for (my $idx = 0;; $idx++)
+ {
+ return 0 unless (defined $an->[$idx] && defined $bn->[$idx]);
+ return $an->[$idx] <=> $bn->[$idx]
+ if ($an->[$idx] <=> $bn->[$idx]);
+ }
+}
+
+# Render the version number using the saved string.
+sub _stringify
+{
+ my $self = shift;
+ return $self->{str};
+}
+
+=pod
+
+=over
+
+=item major([separator => 'char'])
+
+Returns the major version. For versions before 10 the parts are separated by
+a dot unless the separator argument is given.
+
+=back
+
+=cut
+
+sub major
+{
+ my ($self, %params) = @_;
+ my $result = $self->{num}->[0];
+ if ($result + 0 < 10)
+ {
+ my $sep = $params{separator} || '.';
+ $result .= "$sep$self->{num}->[1]";
+ }
+ return $result;
+}
+
+1;