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::Find; 19use File::Spec; 20use File::stat qw(stat); 21use File::Temp (); 22use IPC::Run; 23use SimpleTee; 24 25# specify a recent enough version of Test::More to support the done_testing() function 26use Test::More 0.87; 27 28our @EXPORT = qw( 29 generate_ascii_string 30 slurp_dir 31 slurp_file 32 append_to_file 33 check_mode_recursive 34 chmod_recursive 35 check_pg_config 36 system_or_bail 37 system_log 38 run_log 39 40 command_ok 41 command_fails 42 command_exit_is 43 program_help_ok 44 program_version_ok 45 program_options_handling_ok 46 command_like 47 command_like_safe 48 command_fails_like 49 command_checks_all 50 51 $windows_os 52); 53 54our ($windows_os, $tmp_check, $log_path, $test_logfile); 55 56BEGIN 57{ 58 59 # Set to untranslated messages, to be able to compare program output 60 # with expected strings. 61 delete $ENV{LANGUAGE}; 62 delete $ENV{LC_ALL}; 63 $ENV{LC_MESSAGES} = 'C'; 64 65 # This list should be kept in sync with pg_regress.c. 66 my @envkeys = qw ( 67 PGCLIENTENCODING 68 PGCONNECT_TIMEOUT 69 PGDATA 70 PGDATABASE 71 PGGSSLIB 72 PGHOSTADDR 73 PGKRBSRVNAME 74 PGPASSFILE 75 PGPASSWORD 76 PGREQUIREPEER 77 PGREQUIRESSL 78 PGSERVICE 79 PGSERVICEFILE 80 PGSSLCERT 81 PGSSLCRL 82 PGSSLKEY 83 PGSSLMODE 84 PGSSLROOTCERT 85 PGTARGETSESSIONATTRS 86 PGUSER 87 PGPORT 88 PGHOST 89 ); 90 delete @ENV{@envkeys}; 91 92 $ENV{PGAPPNAME} = basename($0); 93 94 # Must be set early 95 $windows_os = $Config{osname} eq 'MSWin32' || $Config{osname} eq 'msys'; 96 if ($windows_os) 97 { 98 require Win32API::File; 99 Win32API::File->import(qw(createFile OsFHandleOpen CloseHandle)); 100 } 101} 102 103INIT 104{ 105 106 # Return EPIPE instead of killing the process with SIGPIPE. An affected 107 # test may still fail, but it's more likely to report useful facts. 108 $SIG{PIPE} = 'IGNORE'; 109 110 # Determine output directories, and create them. The base path is the 111 # TESTDIR environment variable, which is normally set by the invoking 112 # Makefile. 113 $tmp_check = $ENV{TESTDIR} ? "$ENV{TESTDIR}/tmp_check" : "tmp_check"; 114 $log_path = "$tmp_check/log"; 115 116 mkdir $tmp_check; 117 mkdir $log_path; 118 119 # Open the test log file, whose name depends on the test name. 120 $test_logfile = basename($0); 121 $test_logfile =~ s/\.[^.]+$//; 122 $test_logfile = "$log_path/regress_log_$test_logfile"; 123 open my $testlog, '>', $test_logfile 124 or die "could not open STDOUT to logfile \"$test_logfile\": $!"; 125 126 # Hijack STDOUT and STDERR to the log file 127 open(my $orig_stdout, '>&', \*STDOUT); 128 open(my $orig_stderr, '>&', \*STDERR); 129 open(STDOUT, '>&', $testlog); 130 open(STDERR, '>&', $testlog); 131 132 # The test output (ok ...) needs to be printed to the original STDOUT so 133 # that the 'prove' program can parse it, and display it to the user in 134 # real time. But also copy it to the log file, to provide more context 135 # in the log. 136 my $builder = Test::More->builder; 137 my $fh = $builder->output; 138 tie *$fh, "SimpleTee", $orig_stdout, $testlog; 139 $fh = $builder->failure_output; 140 tie *$fh, "SimpleTee", $orig_stderr, $testlog; 141 142 # Enable auto-flushing for all the file handles. Stderr and stdout are 143 # redirected to the same file, and buffering causes the lines to appear 144 # in the log in confusing order. 145 autoflush STDOUT 1; 146 autoflush STDERR 1; 147 autoflush $testlog 1; 148} 149 150END 151{ 152 153 # Test files have several ways of causing prove_check to fail: 154 # 1. Exit with a non-zero status. 155 # 2. Call ok(0) or similar, indicating that a constituent test failed. 156 # 3. Deviate from the planned number of tests. 157 # 158 # Preserve temporary directories after (1) and after (2). 159 $File::Temp::KEEP_ALL = 1 unless $? == 0 && all_tests_passing(); 160} 161 162sub all_tests_passing 163{ 164 my $fail_count = 0; 165 foreach my $status (Test::More->builder->summary) 166 { 167 return 0 unless $status; 168 } 169 return 1; 170} 171 172# 173# Helper functions 174# 175sub tempdir 176{ 177 my ($prefix) = @_; 178 $prefix = "tmp_test" unless defined $prefix; 179 return File::Temp::tempdir( 180 $prefix . '_XXXX', 181 DIR => $tmp_check, 182 CLEANUP => 1); 183} 184 185sub tempdir_short 186{ 187 188 # Use a separate temp dir outside the build tree for the 189 # Unix-domain socket, to avoid file name length issues. 190 return File::Temp::tempdir(CLEANUP => 1); 191} 192 193# Translate a Perl file name to a host file name. Currently, this is a no-op 194# except for the case of Perl=msys and host=mingw32. The subject need not 195# exist, but its parent directory must exist. 196sub perl2host 197{ 198 my ($subject) = @_; 199 return $subject unless $Config{osname} eq 'msys'; 200 my $here = cwd; 201 my $leaf; 202 if (chdir $subject) 203 { 204 $leaf = ''; 205 } 206 else 207 { 208 $leaf = '/' . basename $subject; 209 my $parent = dirname $subject; 210 chdir $parent or die "could not chdir \"$parent\": $!"; 211 } 212 213 # this odd way of calling 'pwd -W' is the only way that seems to work. 214 my $dir = qx{sh -c "pwd -W"}; 215 chomp $dir; 216 chdir $here; 217 return $dir . $leaf; 218} 219 220# For backward compatibility only. 221sub real_dir 222{ 223 return perl2host(@_); 224} 225 226sub system_log 227{ 228 print("# Running: " . join(" ", @_) . "\n"); 229 return system(@_); 230} 231 232sub system_or_bail 233{ 234 if (system_log(@_) != 0) 235 { 236 BAIL_OUT("system $_[0] failed"); 237 } 238 return; 239} 240 241sub run_log 242{ 243 print("# Running: " . join(" ", @{ $_[0] }) . "\n"); 244 return IPC::Run::run(@_); 245} 246 247# Generate a string made of the given range of ASCII characters 248sub generate_ascii_string 249{ 250 my ($from_char, $to_char) = @_; 251 my $res; 252 253 for my $i ($from_char .. $to_char) 254 { 255 $res .= sprintf("%c", $i); 256 } 257 return $res; 258} 259 260sub slurp_dir 261{ 262 my ($dir) = @_; 263 opendir(my $dh, $dir) 264 or die "could not opendir \"$dir\": $!"; 265 my @direntries = readdir $dh; 266 closedir $dh; 267 return @direntries; 268} 269 270sub slurp_file 271{ 272 my ($filename, $offset) = @_; 273 local $/; 274 my $contents; 275 my $fh; 276 277 # On windows open file using win32 APIs, to allow us to set the 278 # FILE_SHARE_DELETE flag ("d" below), otherwise other accesses to the file 279 # may fail. 280 if ($Config{osname} ne 'MSWin32') 281 { 282 open($fh, '<', $filename) 283 or die "could not read \"$filename\": $!"; 284 } 285 else 286 { 287 my $fHandle = createFile($filename, "r", "rwd") 288 or die "could not open \"$filename\": $^E"; 289 OsFHandleOpen($fh = IO::Handle->new(), $fHandle, 'r') 290 or die "could not read \"$filename\": $^E\n"; 291 } 292 293 if (defined($offset)) 294 { 295 seek($fh, $offset, SEEK_SET) 296 or die "could not seek \"$filename\": $!"; 297 } 298 299 $contents = <$fh>; 300 close $fh; 301 302 $contents =~ s/\r\n/\n/g if $Config{osname} eq 'msys'; 303 return $contents; 304} 305 306sub append_to_file 307{ 308 my ($filename, $str) = @_; 309 open my $fh, ">>", $filename 310 or die "could not write \"$filename\": $!"; 311 print $fh $str; 312 close $fh; 313 return; 314} 315 316# Check that all file/dir modes in a directory match the expected values, 317# ignoring the mode of any specified files. 318sub check_mode_recursive 319{ 320 my ($dir, $expected_dir_mode, $expected_file_mode, $ignore_list) = @_; 321 322 # Result defaults to true 323 my $result = 1; 324 325 find( 326 { 327 follow_fast => 1, 328 wanted => sub { 329 # Is file in the ignore list? 330 foreach my $ignore ($ignore_list ? @{$ignore_list} : []) 331 { 332 if ("$dir/$ignore" eq $File::Find::name) 333 { 334 return; 335 } 336 } 337 338 # Allow ENOENT. A running server can delete files, such as 339 # those in pg_stat. Other stat() failures are fatal. 340 my $file_stat = stat($File::Find::name); 341 unless (defined($file_stat)) 342 { 343 my $is_ENOENT = $!{ENOENT}; 344 my $msg = "unable to stat $File::Find::name: $!"; 345 if ($is_ENOENT) 346 { 347 warn $msg; 348 return; 349 } 350 else 351 { 352 die $msg; 353 } 354 } 355 356 my $file_mode = S_IMODE($file_stat->mode); 357 358 # Is this a file? 359 if (S_ISREG($file_stat->mode)) 360 { 361 if ($file_mode != $expected_file_mode) 362 { 363 print( 364 *STDERR, 365 sprintf("$File::Find::name mode must be %04o\n", 366 $expected_file_mode)); 367 368 $result = 0; 369 return; 370 } 371 } 372 373 # Else a directory? 374 elsif (S_ISDIR($file_stat->mode)) 375 { 376 if ($file_mode != $expected_dir_mode) 377 { 378 print( 379 *STDERR, 380 sprintf("$File::Find::name mode must be %04o\n", 381 $expected_dir_mode)); 382 383 $result = 0; 384 return; 385 } 386 } 387 388 # Else something we can't handle 389 else 390 { 391 die "unknown file type for $File::Find::name"; 392 } 393 } 394 }, 395 $dir); 396 397 return $result; 398} 399 400# Change mode recursively on a directory 401sub chmod_recursive 402{ 403 my ($dir, $dir_mode, $file_mode) = @_; 404 405 find( 406 { 407 follow_fast => 1, 408 wanted => sub { 409 my $file_stat = stat($File::Find::name); 410 411 if (defined($file_stat)) 412 { 413 chmod( 414 S_ISDIR($file_stat->mode) ? $dir_mode : $file_mode, 415 $File::Find::name 416 ) or die "unable to chmod $File::Find::name"; 417 } 418 } 419 }, 420 $dir); 421 return; 422} 423 424# Check presence of a given regexp within pg_config.h for the installation 425# where tests are running, returning a match status result depending on 426# that. 427sub check_pg_config 428{ 429 my ($regexp) = @_; 430 my ($stdout, $stderr); 431 my $result = IPC::Run::run [ 'pg_config', '--includedir' ], '>', 432 \$stdout, '2>', \$stderr 433 or die "could not execute pg_config"; 434 chomp($stdout); 435 $stdout =~ s/\r$//; 436 437 open my $pg_config_h, '<', "$stdout/pg_config.h" or die "$!"; 438 my $match = (grep { /^$regexp/ } <$pg_config_h>); 439 close $pg_config_h; 440 return $match; 441} 442 443# 444# Test functions 445# 446sub command_ok 447{ 448 my ($cmd, $test_name) = @_; 449 my $result = run_log($cmd); 450 ok($result, $test_name); 451 return; 452} 453 454sub command_fails 455{ 456 my ($cmd, $test_name) = @_; 457 my $result = run_log($cmd); 458 ok(!$result, $test_name); 459 return; 460} 461 462sub command_exit_is 463{ 464 my ($cmd, $expected, $test_name) = @_; 465 print("# Running: " . join(" ", @{$cmd}) . "\n"); 466 my $h = IPC::Run::start $cmd; 467 $h->finish(); 468 469 # On Windows, the exit status of the process is returned directly as the 470 # process's exit code, while on Unix, it's returned in the high bits 471 # of the exit code (see WEXITSTATUS macro in the standard <sys/wait.h> 472 # header file). IPC::Run's result function always returns exit code >> 8, 473 # assuming the Unix convention, which will always return 0 on Windows as 474 # long as the process was not terminated by an exception. To work around 475 # that, use $h->full_result on Windows instead. 476 my $result = 477 ($Config{osname} eq "MSWin32") 478 ? ($h->full_results)[0] 479 : $h->result(0); 480 is($result, $expected, $test_name); 481 return; 482} 483 484sub program_help_ok 485{ 486 my ($cmd) = @_; 487 my ($stdout, $stderr); 488 print("# Running: $cmd --help\n"); 489 my $result = IPC::Run::run [ $cmd, '--help' ], '>', \$stdout, '2>', 490 \$stderr; 491 ok($result, "$cmd --help exit code 0"); 492 isnt($stdout, '', "$cmd --help goes to stdout"); 493 is($stderr, '', "$cmd --help nothing to stderr"); 494 return; 495} 496 497sub program_version_ok 498{ 499 my ($cmd) = @_; 500 my ($stdout, $stderr); 501 print("# Running: $cmd --version\n"); 502 my $result = IPC::Run::run [ $cmd, '--version' ], '>', \$stdout, '2>', 503 \$stderr; 504 ok($result, "$cmd --version exit code 0"); 505 isnt($stdout, '', "$cmd --version goes to stdout"); 506 is($stderr, '', "$cmd --version nothing to stderr"); 507 return; 508} 509 510sub program_options_handling_ok 511{ 512 my ($cmd) = @_; 513 my ($stdout, $stderr); 514 print("# Running: $cmd --not-a-valid-option\n"); 515 my $result = IPC::Run::run [ $cmd, '--not-a-valid-option' ], '>', 516 \$stdout, 517 '2>', \$stderr; 518 ok(!$result, "$cmd with invalid option nonzero exit code"); 519 isnt($stderr, '', "$cmd with invalid option prints error message"); 520 return; 521} 522 523sub command_like 524{ 525 my ($cmd, $expected_stdout, $test_name) = @_; 526 my ($stdout, $stderr); 527 print("# Running: " . join(" ", @{$cmd}) . "\n"); 528 my $result = IPC::Run::run $cmd, '>', \$stdout, '2>', \$stderr; 529 ok($result, "$test_name: exit code 0"); 530 is($stderr, '', "$test_name: no stderr"); 531 $stdout =~ s/\r\n/\n/g if $Config{osname} eq 'msys'; 532 like($stdout, $expected_stdout, "$test_name: matches"); 533 return; 534} 535 536sub command_like_safe 537{ 538 539 # Doesn't rely on detecting end of file on the file descriptors, 540 # which can fail, causing the process to hang, notably on Msys 541 # when used with 'pg_ctl start' 542 my ($cmd, $expected_stdout, $test_name) = @_; 543 my ($stdout, $stderr); 544 my $stdoutfile = File::Temp->new(); 545 my $stderrfile = File::Temp->new(); 546 print("# Running: " . join(" ", @{$cmd}) . "\n"); 547 my $result = IPC::Run::run $cmd, '>', $stdoutfile, '2>', $stderrfile; 548 $stdout = slurp_file($stdoutfile); 549 $stderr = slurp_file($stderrfile); 550 ok($result, "$test_name: exit code 0"); 551 is($stderr, '', "$test_name: no stderr"); 552 like($stdout, $expected_stdout, "$test_name: matches"); 553 return; 554} 555 556sub command_fails_like 557{ 558 my ($cmd, $expected_stderr, $test_name) = @_; 559 my ($stdout, $stderr); 560 print("# Running: " . join(" ", @{$cmd}) . "\n"); 561 my $result = IPC::Run::run $cmd, '>', \$stdout, '2>', \$stderr; 562 ok(!$result, "$test_name: exit code not 0"); 563 $stderr =~ s/\r\n/\n/g if $Config{osname} eq 'msys'; 564 like($stderr, $expected_stderr, "$test_name: matches"); 565 return; 566} 567 568# Run a command and check its status and outputs. 569# The 5 arguments are: 570# - cmd: ref to list for command, options and arguments to run 571# - ret: expected exit status 572# - out: ref to list of re to be checked against stdout (all must match) 573# - err: ref to list of re to be checked against stderr (all must match) 574# - test_name: name of test 575sub command_checks_all 576{ 577 my ($cmd, $expected_ret, $out, $err, $test_name) = @_; 578 579 # run command 580 my ($stdout, $stderr); 581 print("# Running: " . join(" ", @{$cmd}) . "\n"); 582 IPC::Run::run($cmd, '>', \$stdout, '2>', \$stderr); 583 584 # See http://perldoc.perl.org/perlvar.html#%24CHILD_ERROR 585 my $ret = $?; 586 die "command exited with signal " . ($ret & 127) 587 if $ret & 127; 588 $ret = $ret >> 8; 589 590 foreach ($stderr, $stdout) { s/\r\n/\n/g if $Config{osname} eq 'msys'; } 591 592 # check status 593 ok($ret == $expected_ret, 594 "$test_name status (got $ret vs expected $expected_ret)"); 595 596 # check stdout 597 for my $re (@$out) 598 { 599 like($stdout, $re, "$test_name stdout /$re/"); 600 } 601 602 # check stderr 603 for my $re (@$err) 604 { 605 like($stderr, $re, "$test_name stderr /$re/"); 606 } 607 608 return; 609} 610 6111; 612