| |
| # Copyright (c) 2021, PostgreSQL Global Development Group |
| |
| =pod |
| |
| =head1 NAME |
| |
| TestLib - helper module for writing PostgreSQL's C<prove> tests. |
| |
| =head1 SYNOPSIS |
| |
| use TestLib; |
| |
| # 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 = TestLib::tempdir; |
| command_ok('initdb', '-D', $tempdir); |
| |
| # Miscellanea |
| print "on Windows" if $TestLib::windows_os; |
| ok(check_mode_recursive($stream_dir, 0700, 0600), |
| "check stream dir permissions"); |
| TestLib::system_log('pg_ctl', 'kill', 'QUIT', $slow_pid); |
| |
| =head1 DESCRIPTION |
| |
| C<TestLib> 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 TestLib; |
| |
| 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 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 |
| pump_until |
| |
| 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, $timeout_default, |
| $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 = $windows_os && -x '/usr/bin/uname' && |
| `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}); |
| |
| $timeout_default = $ENV{PG_TEST_TIMEOUT_DEFAULT}; |
| $timeout_default = 180 |
| if not defined $timeout_default or $timeout_default eq ''; |
| } |
| |
| =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, "SimpleTee", $orig_stdout, $testlog; |
| $fh = $builder->failure_output; |
| tie *$fh, "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 has_wal_read_bug() |
| |
| Returns true if $tmp_check is subject to a sparc64+ext4 bug that causes WAL |
| readers to see zeros if another process simultaneously wrote the same offsets. |
| Consult this in tests that fail frequently on affected configurations. The |
| bug has made streaming standbys fail to advance, reporting corrupt WAL. It |
| has made COMMIT PREPARED fail with "could not read two-phase state from WAL". |
| Non-WAL PostgreSQL reads haven't been affected, likely because those readers |
| and writers have buffering systems in common. See |
| https://postgr.es/m/20220116210241.GC756210@rfd.leadboat.com for details. |
| |
| =cut |
| |
| sub has_wal_read_bug |
| { |
| return |
| $Config{osname} eq 'linux' |
| && $Config{archname} =~ /^sparc/ |
| && !run_log([ qw(df -x ext4), $tmp_check ], '>', '/dev/null', '2>&1'); |
| } |
| |
| =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) |
| { |
| BAIL_OUT("system $_[0] failed"); |
| } |
| return; |
| } |
| |
| =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; |
| chomp($stdout); |
| chomp($stderr); |
| return ($stdout, $stderr); |
| } |
| |
| =pod |
| |
| =item pump_until(proc, timeout, stream, until) |
| |
| Pump until string is matched on the specified stream, or timeout occurs. |
| |
| =cut |
| |
| sub pump_until |
| { |
| my ($proc, $timeout, $stream, $until) = @_; |
| $proc->pump_nb(); |
| while (1) |
| { |
| last if $$stream =~ /$until/; |
| if ($timeout->is_expired) |
| { |
| diag("pump_until: timeout expired when searching for \"$until\" with stream: \"$$stream\""); |
| return 0; |
| } |
| if (not $proc->pumpable()) |
| { |
| diag("pump_until: process terminated unexpectedly when searching for \"$until\" with stream: \"$$stream\""); |
| return 0; |
| } |
| $proc->pump(); |
| } |
| return 1; |
| } |
| |
| =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; |
| |
| 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 =~ 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"); |
| 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"); |
| 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; |
| |
| # 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 |
| |
| # support release 15+ perl module namespace |
| |
| package PostgreSQL::Test::Utils; ## no critic (ProhibitMultiplePackages) |
| |
| # we don't want to export anything here, but we want to support things called |
| # via this package name explicitly. |
| |
| # use typeglobs to alias these functions and variables |
| |
| no warnings qw(once); |
| |
| *generate_ascii_string = *TestLib::generate_ascii_string; |
| *slurp_dir = *TestLib::slurp_dir; |
| *slurp_file = *TestLib::slurp_file; |
| *append_to_file = *TestLib::append_to_file; |
| *check_mode_recursive = *TestLib::check_mode_recursive; |
| *chmod_recursive = *TestLib::chmod_recursive; |
| *check_pg_config = *TestLib::check_pg_config; |
| *dir_symlink = *TestLib::dir_symlink; |
| *system_or_bail = *TestLib::system_or_bail; |
| *system_log = *TestLib::system_log; |
| *run_log = *TestLib::run_log; |
| *run_command = *TestLib::run_command; |
| *command_ok = *TestLib::command_ok; |
| *command_fails = *TestLib::command_fails; |
| *command_exit_is = *TestLib::command_exit_is; |
| *program_help_ok = *TestLib::program_help_ok; |
| *program_version_ok = *TestLib::program_version_ok; |
| *program_options_handling_ok = *TestLib::program_options_handling_ok; |
| *command_like = *TestLib::command_like; |
| *command_like_safe = *TestLib::command_like_safe; |
| *command_fails_like = *TestLib::command_fails_like; |
| *command_checks_all = *TestLib::command_checks_all; |
| |
| *windows_os = *TestLib::windows_os; |
| *is_msys2 = *TestLib::is_msys2; |
| *use_unix_sockets = *TestLib::use_unix_sockets; |
| *timeout_default = *TestLib::timeout_default; |
| *tmp_check = *TestLib::tmp_check; |
| *log_path = *TestLib::log_path; |
| *test_logfile = *TestLib::test_log_file; |
| |
| 1; |