1# TestLib, low-level routines and actions regression tests. 2# 3# This module contains a set of routines dedicated to environment setup for 4# a PostgreSQL regression test run and includes some low-level routines 5# aimed at controlling command execution, logging and test functions. This 6# module should never depend on any other PostgreSQL regression test modules. 7 8package TestLib; 9 10use strict; 11use warnings; 12 13use Config; 14use Cwd; 15use Exporter 'import'; 16use Fcntl qw(:mode :seek); 17use File::Basename; 18use File::Spec; 19use File::Temp (); 20use IPC::Run; 21use SimpleTee; 22use Test::More; 23 24our @EXPORT = qw( 25 slurp_dir 26 slurp_file 27 append_to_file 28 system_or_bail 29 system_log 30 run_log 31 32 command_ok 33 command_fails 34 command_exit_is 35 program_help_ok 36 program_version_ok 37 program_options_handling_ok 38 command_like 39 40 $windows_os 41); 42 43our ($windows_os, $tmp_check, $log_path, $test_logfile); 44 45BEGIN 46{ 47 48 # Set to untranslated messages, to be able to compare program output 49 # with expected strings. 50 delete $ENV{LANGUAGE}; 51 delete $ENV{LC_ALL}; 52 $ENV{LC_MESSAGES} = 'C'; 53 54 # This list should be kept in sync with pg_regress.c. 55 my @envkeys = qw ( 56 PGCLIENTENCODING 57 PGCONNECT_TIMEOUT 58 PGDATA 59 PGDATABASE 60 PGGSSLIB 61 PGHOSTADDR 62 PGKRBSRVNAME 63 PGPASSFILE 64 PGPASSWORD 65 PGREQUIREPEER 66 PGREQUIRESSL 67 PGSERVICE 68 PGSERVICEFILE 69 PGSSLCERT 70 PGSSLCRL 71 PGSSLKEY 72 PGSSLMODE 73 PGSSLROOTCERT 74 PGUSER 75 PGPORT 76 PGHOST 77 ); 78 delete @ENV{@envkeys}; 79 80 # Must be set early 81 $windows_os = $Config{osname} eq 'MSWin32' || $Config{osname} eq 'msys'; 82 if ($windows_os) 83 { 84 require Win32API::File; 85 Win32API::File->import(qw(createFile OsFHandleOpen CloseHandle)); 86 } 87} 88 89INIT 90{ 91 92 # Determine output directories, and create them. The base path is the 93 # TESTDIR environment variable, which is normally set by the invoking 94 # Makefile. 95 $tmp_check = $ENV{TESTDIR} ? "$ENV{TESTDIR}/tmp_check" : "tmp_check"; 96 $log_path = "$tmp_check/log"; 97 98 mkdir $tmp_check; 99 mkdir $log_path; 100 101 # Open the test log file, whose name depends on the test name. 102 $test_logfile = basename($0); 103 $test_logfile =~ s/\.[^.]+$//; 104 $test_logfile = "$log_path/regress_log_$test_logfile"; 105 open TESTLOG, '>', $test_logfile 106 or die "could not open STDOUT to logfile \"$test_logfile\": $!"; 107 108 # Hijack STDOUT and STDERR to the log file 109 open(ORIG_STDOUT, ">&STDOUT"); 110 open(ORIG_STDERR, ">&STDERR"); 111 open(STDOUT, ">&TESTLOG"); 112 open(STDERR, ">&TESTLOG"); 113 114 # The test output (ok ...) needs to be printed to the original STDOUT so 115 # that the 'prove' program can parse it, and display it to the user in 116 # real time. But also copy it to the log file, to provide more context 117 # in the log. 118 my $builder = Test::More->builder; 119 my $fh = $builder->output; 120 tie *$fh, "SimpleTee", *ORIG_STDOUT, *TESTLOG; 121 $fh = $builder->failure_output; 122 tie *$fh, "SimpleTee", *ORIG_STDERR, *TESTLOG; 123 124 # Enable auto-flushing for all the file handles. Stderr and stdout are 125 # redirected to the same file, and buffering causes the lines to appear 126 # in the log in confusing order. 127 autoflush STDOUT 1; 128 autoflush STDERR 1; 129 autoflush TESTLOG 1; 130} 131 132END 133{ 134 135 # Test files have several ways of causing prove_check to fail: 136 # 1. Exit with a non-zero status. 137 # 2. Call ok(0) or similar, indicating that a constituent test failed. 138 # 3. Deviate from the planned number of tests. 139 # 140 # Preserve temporary directories after (1) and after (2). 141 $File::Temp::KEEP_ALL = 1 unless $? == 0 && all_tests_passing(); 142} 143 144sub all_tests_passing 145{ 146 my $fail_count = 0; 147 foreach my $status (Test::More->builder->summary) 148 { 149 return 0 unless $status; 150 } 151 return 1; 152} 153 154# 155# Helper functions 156# 157sub tempdir 158{ 159 my ($prefix) = @_; 160 $prefix = "tmp_test" unless defined $prefix; 161 return File::Temp::tempdir( 162 $prefix . '_XXXX', 163 DIR => $tmp_check, 164 CLEANUP => 1); 165} 166 167sub tempdir_short 168{ 169 170 # Use a separate temp dir outside the build tree for the 171 # Unix-domain socket, to avoid file name length issues. 172 return File::Temp::tempdir(CLEANUP => 1); 173} 174 175# Translate a Perl file name to a host file name. Currently, this is a no-op 176# except for the case of Perl=msys and host=mingw32. The subject need not 177# exist, but its parent directory must exist. 178sub perl2host 179{ 180 my ($subject) = @_; 181 return $subject unless $Config{osname} eq 'msys'; 182 my $here = cwd; 183 my $leaf; 184 if (chdir $subject) 185 { 186 $leaf = ''; 187 } 188 else 189 { 190 $leaf = '/' . basename $subject; 191 my $parent = dirname $subject; 192 chdir $parent or die "could not chdir \"$parent\": $!"; 193 } 194 195 # this odd way of calling 'pwd -W' is the only way that seems to work. 196 my $dir = qx{sh -c "pwd -W"}; 197 chomp $dir; 198 chdir $here; 199 return $dir . $leaf; 200} 201 202sub system_log 203{ 204 print("# Running: " . join(" ", @_) . "\n"); 205 return system(@_); 206} 207 208sub system_or_bail 209{ 210 if (system_log(@_) != 0) 211 { 212 BAIL_OUT("system $_[0] failed"); 213 } 214} 215 216sub run_log 217{ 218 print("# Running: " . join(" ", @{ $_[0] }) . "\n"); 219 return IPC::Run::run(@_); 220} 221 222sub slurp_dir 223{ 224 my ($dir) = @_; 225 opendir(my $dh, $dir) 226 or die "could not opendir \"$dir\": $!"; 227 my @direntries = readdir $dh; 228 closedir $dh; 229 return @direntries; 230} 231 232sub slurp_file 233{ 234 my ($filename, $offset) = @_; 235 local $/; 236 my $contents; 237 my $fh; 238 239 # On windows open file using win32 APIs, to allow us to set the 240 # FILE_SHARE_DELETE flag ("d" below), otherwise other accesses to the file 241 # may fail. 242 if ($Config{osname} ne 'MSWin32') 243 { 244 open($fh, '<', $filename) 245 or die "could not read \"$filename\": $!"; 246 } 247 else 248 { 249 my $fHandle = createFile($filename, "r", "rwd") 250 or die "could not open \"$filename\": $^E"; 251 OsFHandleOpen($fh = IO::Handle->new(), $fHandle, 'r') 252 or die "could not read \"$filename\": $^E\n"; 253 } 254 255 if (defined($offset)) 256 { 257 seek($fh, $offset, SEEK_SET) 258 or die "could not seek \"$filename\": $!"; 259 } 260 261 $contents = <$fh>; 262 close $fh; 263 264 $contents =~ s/\r\n/\n/g if $Config{osname} eq 'msys'; 265 return $contents; 266} 267 268sub append_to_file 269{ 270 my ($filename, $str) = @_; 271 open my $fh, ">>", $filename 272 or die "could not write \"$filename\": $!"; 273 print $fh $str; 274 close $fh; 275} 276 277# 278# Test functions 279# 280sub command_ok 281{ 282 my ($cmd, $test_name) = @_; 283 my $result = run_log($cmd); 284 ok($result, $test_name); 285} 286 287sub command_fails 288{ 289 my ($cmd, $test_name) = @_; 290 my $result = run_log($cmd); 291 ok(!$result, $test_name); 292} 293 294sub command_exit_is 295{ 296 my ($cmd, $expected, $test_name) = @_; 297 print("# Running: " . join(" ", @{$cmd}) . "\n"); 298 my $h = IPC::Run::start $cmd; 299 $h->finish(); 300 301 # On Windows, the exit status of the process is returned directly as the 302 # process's exit code, while on Unix, it's returned in the high bits 303 # of the exit code (see WEXITSTATUS macro in the standard <sys/wait.h> 304 # header file). IPC::Run's result function always returns exit code >> 8, 305 # assuming the Unix convention, which will always return 0 on Windows as 306 # long as the process was not terminated by an exception. To work around 307 # that, use $h->full_result on Windows instead. 308 my $result = 309 ($Config{osname} eq "MSWin32") 310 ? ($h->full_results)[0] 311 : $h->result(0); 312 is($result, $expected, $test_name); 313} 314 315sub program_help_ok 316{ 317 my ($cmd) = @_; 318 my ($stdout, $stderr); 319 print("# Running: $cmd --help\n"); 320 my $result = IPC::Run::run [ $cmd, '--help' ], '>', \$stdout, '2>', 321 \$stderr; 322 ok($result, "$cmd --help exit code 0"); 323 isnt($stdout, '', "$cmd --help goes to stdout"); 324 is($stderr, '', "$cmd --help nothing to stderr"); 325} 326 327sub program_version_ok 328{ 329 my ($cmd) = @_; 330 my ($stdout, $stderr); 331 print("# Running: $cmd --version\n"); 332 my $result = IPC::Run::run [ $cmd, '--version' ], '>', \$stdout, '2>', 333 \$stderr; 334 ok($result, "$cmd --version exit code 0"); 335 isnt($stdout, '', "$cmd --version goes to stdout"); 336 is($stderr, '', "$cmd --version nothing to stderr"); 337} 338 339sub program_options_handling_ok 340{ 341 my ($cmd) = @_; 342 my ($stdout, $stderr); 343 print("# Running: $cmd --not-a-valid-option\n"); 344 my $result = IPC::Run::run [ $cmd, '--not-a-valid-option' ], '>', 345 \$stdout, 346 '2>', \$stderr; 347 ok(!$result, "$cmd with invalid option nonzero exit code"); 348 isnt($stderr, '', "$cmd with invalid option prints error message"); 349} 350 351sub command_like 352{ 353 my ($cmd, $expected_stdout, $test_name) = @_; 354 my ($stdout, $stderr); 355 print("# Running: " . join(" ", @{$cmd}) . "\n"); 356 my $result = IPC::Run::run $cmd, '>', \$stdout, '2>', \$stderr; 357 ok($result, "@$cmd exit code 0"); 358 is($stderr, '', "@$cmd no stderr"); 359 $stdout =~ s/\r\n/\n/g if $Config{osname} eq 'msys'; 360 like($stdout, $expected_stdout, "$test_name: matches"); 361} 362 363# Run a command and check its status and outputs. 364# The 5 arguments are: 365# - cmd: ref to list for command, options and arguments to run 366# - ret: expected exit status 367# - out: ref to list of re to be checked against stdout (all must match) 368# - err: ref to list of re to be checked against stderr (all must match) 369# - test_name: name of test 370sub command_checks_all 371{ 372 my ($cmd, $expected_ret, $out, $err, $test_name) = @_; 373 374 # run command 375 my ($stdout, $stderr); 376 print("# Running: " . join(" ", @{$cmd}) . "\n"); 377 IPC::Run::run($cmd, '>', \$stdout, '2>', \$stderr); 378 379 # See http://perldoc.perl.org/perlvar.html#%24CHILD_ERROR 380 my $ret = $?; 381 die "command exited with signal " . ($ret & 127) 382 if $ret & 127; 383 $ret = $ret >> 8; 384 385 foreach ($stderr, $stdout) { s/\r\n/\n/g if $Config{osname} eq 'msys'; } 386 387 # check status 388 ok($ret == $expected_ret, 389 "$test_name status (got $ret vs expected $expected_ret)"); 390 391 # check stdout 392 for my $re (@$out) 393 { 394 like($stdout, $re, "$test_name stdout /$re/"); 395 } 396 397 # check stderr 398 for my $re (@$err) 399 { 400 like($stderr, $re, "$test_name stderr /$re/"); 401 } 402 403 return; 404} 405 4061; 407