Location via proxy:   [ UP ]  
[Report a bug]   [Manage cookies]                
summaryrefslogtreecommitdiff
path: root/src/test/perl/TestLib.pm
diff options
context:
space:
mode:
Diffstat (limited to 'src/test/perl/TestLib.pm')
-rw-r--r--src/test/perl/TestLib.pm1007
1 files changed, 0 insertions, 1007 deletions
diff --git a/src/test/perl/TestLib.pm b/src/test/perl/TestLib.pm
deleted file mode 100644
index 06aae1760eb..00000000000
--- a/src/test/perl/TestLib.pm
+++ /dev/null
@@ -1,1007 +0,0 @@
-
-# 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;
- my $path = TestLib::perl2host($backup_dir);
- 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
-
- 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, "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 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;
generated by cgit v1.2.3 (git 2.39.1) at 2025-06-15 21:23:00 +0000