1 2=pod 3 4=head1 NAME 5 6PostgresNode - class representing PostgreSQL server instance 7 8=head1 SYNOPSIS 9 10 use PostgresNode; 11 12 my $node = PostgresNode->get_new_node('mynode'); 13 14 # Create a data directory with initdb 15 $node->init(); 16 17 # Start the PostgreSQL server 18 $node->start(); 19 20 # Change a setting and restart 21 $node->append_conf('postgresql.conf', 'hot_standby = on'); 22 $node->restart(); 23 24 # run a query with psql, like: 25 # echo 'SELECT 1' | psql -qAXt postgres -v ON_ERROR_STOP=1 26 $psql_stdout = $node->safe_psql('postgres', 'SELECT 1'); 27 28 # Run psql with a timeout, capturing stdout and stderr 29 # as well as the psql exit code. Pass some extra psql 30 # options. If there's an error from psql raise an exception. 31 my ($stdout, $stderr, $timed_out); 32 my $cmdret = $node->psql('postgres', 'SELECT pg_sleep(600)', 33 stdout => \$stdout, stderr => \$stderr, 34 timeout => 180, timed_out => \$timed_out, 35 extra_params => ['--single-transaction'], 36 on_error_die => 1) 37 print "Sleep timed out" if $timed_out; 38 39 # Similar thing, more convenient in common cases 40 my ($cmdret, $stdout, $stderr) = 41 $node->psql('postgres', 'SELECT 1'); 42 43 # run query every second until it returns 't' 44 # or times out 45 $node->poll_query_until('postgres', q|SELECT random() < 0.1;|') 46 or die "timed out"; 47 48 # Do an online pg_basebackup 49 my $ret = $node->backup('testbackup1'); 50 51 # Take a backup of a running server 52 my $ret = $node->backup_fs_hot('testbackup2'); 53 54 # Take a backup of a stopped server 55 $node->stop; 56 my $ret = $node->backup_fs_cold('testbackup3') 57 58 # Restore it to create a new independent node (not a replica) 59 my $replica = get_new_node('replica'); 60 $replica->init_from_backup($node, 'testbackup'); 61 $replica->start; 62 63 # Stop the server 64 $node->stop('fast'); 65 66 # Find a free, unprivileged TCP port to bind some other service to 67 my $port = get_free_port(); 68 69=head1 DESCRIPTION 70 71PostgresNode contains a set of routines able to work on a PostgreSQL node, 72allowing to start, stop, backup and initialize it with various options. 73The set of nodes managed by a given test is also managed by this module. 74 75In addition to node management, PostgresNode instances have some wrappers 76around Test::More functions to run commands with an environment set up to 77point to the instance. 78 79The IPC::Run module is required. 80 81=cut 82 83package PostgresNode; 84 85use strict; 86use warnings; 87 88use Carp; 89use Config; 90use Cwd; 91use Exporter 'import'; 92use Fcntl qw(:mode); 93use File::Basename; 94use File::Path qw(rmtree); 95use File::Spec; 96use File::stat qw(stat); 97use File::Temp (); 98use IPC::Run; 99use RecursiveCopy; 100use Socket; 101use Test::More; 102use TestLib (); 103use Time::HiRes qw(usleep); 104use Scalar::Util qw(blessed); 105 106our @EXPORT = qw( 107 get_new_node 108 get_free_port 109); 110 111our ($use_tcp, $test_localhost, $test_pghost, $last_host_assigned, 112 $last_port_assigned, @all_nodes, $died); 113 114# For backward compatibility only. 115our $vfs_path = ''; 116if ($Config{osname} eq 'msys') 117{ 118 $vfs_path = `cd / && pwd -W`; 119 chomp $vfs_path; 120} 121 122INIT 123{ 124 125 # Set PGHOST for backward compatibility. This doesn't work for own_host 126 # nodes, so prefer to not rely on this when writing new tests. 127 $use_tcp = $TestLib::windows_os; 128 $test_localhost = "127.0.0.1"; 129 $last_host_assigned = 1; 130 $test_pghost = $use_tcp ? $test_localhost : TestLib::tempdir_short; 131 $ENV{PGHOST} = $test_pghost; 132 $ENV{PGDATABASE} = 'postgres'; 133 134 # Tracking of last port value assigned to accelerate free port lookup. 135 $last_port_assigned = int(rand() * 16384) + 49152; 136} 137 138=pod 139 140=head1 METHODS 141 142=over 143 144=item PostgresNode::new($class, $name, $pghost, $pgport) 145 146Create a new PostgresNode instance. Does not initdb or start it. 147 148You should generally prefer to use get_new_node() instead since it takes care 149of finding port numbers, registering instances for cleanup, etc. 150 151=cut 152 153sub new 154{ 155 my ($class, $name, $pghost, $pgport) = @_; 156 my $testname = basename($0); 157 $testname =~ s/\.[^.]+$//; 158 my $self = { 159 _port => $pgport, 160 _host => $pghost, 161 _basedir => "$TestLib::tmp_check/t_${testname}_${name}_data", 162 _name => $name, 163 _logfile_generation => 0, 164 _logfile_base => "$TestLib::log_path/${testname}_${name}", 165 _logfile => "$TestLib::log_path/${testname}_${name}.log" 166 }; 167 168 bless $self, $class; 169 mkdir $self->{_basedir} 170 or 171 BAIL_OUT("could not create data directory \"$self->{_basedir}\": $!"); 172 $self->dump_info; 173 174 return $self; 175} 176 177=pod 178 179=item $node->port() 180 181Get the port number assigned to the host. This won't necessarily be a TCP port 182open on the local host since we prefer to use unix sockets if possible. 183 184Use $node->connstr() if you want a connection string. 185 186=cut 187 188sub port 189{ 190 my ($self) = @_; 191 return $self->{_port}; 192} 193 194=pod 195 196=item $node->host() 197 198Return the host (like PGHOST) for this instance. May be a UNIX socket path. 199 200Use $node->connstr() if you want a connection string. 201 202=cut 203 204sub host 205{ 206 my ($self) = @_; 207 return $self->{_host}; 208} 209 210=pod 211 212=item $node->basedir() 213 214The directory all the node's files will be within - datadir, archive directory, 215backups, etc. 216 217=cut 218 219sub basedir 220{ 221 my ($self) = @_; 222 return $self->{_basedir}; 223} 224 225=pod 226 227=item $node->name() 228 229The name assigned to the node at creation time. 230 231=cut 232 233sub name 234{ 235 my ($self) = @_; 236 return $self->{_name}; 237} 238 239=pod 240 241=item $node->logfile() 242 243Path to the PostgreSQL log file for this instance. 244 245=cut 246 247sub logfile 248{ 249 my ($self) = @_; 250 return $self->{_logfile}; 251} 252 253=pod 254 255=item $node->connstr() 256 257Get a libpq connection string that will establish a connection to 258this node. Suitable for passing to psql, DBD::Pg, etc. 259 260=cut 261 262sub connstr 263{ 264 my ($self, $dbname) = @_; 265 my $pgport = $self->port; 266 my $pghost = $self->host; 267 if (!defined($dbname)) 268 { 269 return "port=$pgport host=$pghost"; 270 } 271 272 # Escape properly the database string before using it, only 273 # single quotes and backslashes need to be treated this way. 274 $dbname =~ s#\\#\\\\#g; 275 $dbname =~ s#\'#\\\'#g; 276 277 return "port=$pgport host=$pghost dbname='$dbname'"; 278} 279 280=pod 281 282=item $node->group_access() 283 284Does the data dir allow group access? 285 286=cut 287 288sub group_access 289{ 290 my ($self) = @_; 291 292 my $dir_stat = stat($self->data_dir); 293 294 defined($dir_stat) 295 or die('unable to stat ' . $self->data_dir); 296 297 return (S_IMODE($dir_stat->mode) == 0750); 298} 299 300=pod 301 302=item $node->data_dir() 303 304Returns the path to the data directory. postgresql.conf and pg_hba.conf are 305always here. 306 307=cut 308 309sub data_dir 310{ 311 my ($self) = @_; 312 my $res = $self->basedir; 313 return "$res/pgdata"; 314} 315 316=pod 317 318=item $node->archive_dir() 319 320If archiving is enabled, WAL files go here. 321 322=cut 323 324sub archive_dir 325{ 326 my ($self) = @_; 327 my $basedir = $self->basedir; 328 return "$basedir/archives"; 329} 330 331=pod 332 333=item $node->backup_dir() 334 335The output path for backups taken with $node->backup() 336 337=cut 338 339sub backup_dir 340{ 341 my ($self) = @_; 342 my $basedir = $self->basedir; 343 return "$basedir/backup"; 344} 345 346=pod 347 348=item $node->info() 349 350Return a string containing human-readable diagnostic information (paths, etc) 351about this node. 352 353=cut 354 355sub info 356{ 357 my ($self) = @_; 358 my $_info = ''; 359 open my $fh, '>', \$_info or die; 360 print $fh "Name: " . $self->name . "\n"; 361 print $fh "Data directory: " . $self->data_dir . "\n"; 362 print $fh "Backup directory: " . $self->backup_dir . "\n"; 363 print $fh "Archive directory: " . $self->archive_dir . "\n"; 364 print $fh "Connection string: " . $self->connstr . "\n"; 365 print $fh "Log file: " . $self->logfile . "\n"; 366 close $fh or die; 367 return $_info; 368} 369 370=pod 371 372=item $node->dump_info() 373 374Print $node->info() 375 376=cut 377 378sub dump_info 379{ 380 my ($self) = @_; 381 print $self->info; 382 return; 383} 384 385 386# Internal method to set up trusted pg_hba.conf for replication. Not 387# documented because you shouldn't use it, it's called automatically if needed. 388sub set_replication_conf 389{ 390 my ($self) = @_; 391 my $pgdata = $self->data_dir; 392 393 $self->host eq $test_pghost 394 or croak "set_replication_conf only works with the default host"; 395 396 open my $hba, '>>', "$pgdata/pg_hba.conf"; 397 print $hba "\n# Allow replication (set up by PostgresNode.pm)\n"; 398 if ($TestLib::windows_os) 399 { 400 print $hba 401 "host replication all $test_localhost/32 sspi include_realm=1 map=regress\n"; 402 } 403 close $hba; 404 return; 405} 406 407=pod 408 409=item $node->init(...) 410 411Initialize a new cluster for testing. 412 413Authentication is set up so that only the current OS user can access the 414cluster. On Unix, we use Unix domain socket connections, with the socket in 415a directory that's only accessible to the current user to ensure that. 416On Windows, we use SSPI authentication to ensure the same (by pg_regress 417--config-auth). 418 419WAL archiving can be enabled on this node by passing the keyword parameter 420has_archiving => 1. This is disabled by default. 421 422postgresql.conf can be set up for replication by passing the keyword 423parameter allows_streaming => 'logical' or 'physical' (passing 1 will also 424suffice for physical replication) depending on type of replication that 425should be enabled. This is disabled by default. 426 427The new node is set up in a fast but unsafe configuration where fsync is 428disabled. 429 430=cut 431 432sub init 433{ 434 my ($self, %params) = @_; 435 my $port = $self->port; 436 my $pgdata = $self->data_dir; 437 my $host = $self->host; 438 439 $params{allows_streaming} = 0 unless defined $params{allows_streaming}; 440 $params{has_archiving} = 0 unless defined $params{has_archiving}; 441 442 mkdir $self->backup_dir; 443 mkdir $self->archive_dir; 444 445 TestLib::system_or_bail('initdb', '-D', $pgdata, '-A', 'trust', '-N', 446 @{ $params{extra} }); 447 TestLib::system_or_bail($ENV{PG_REGRESS}, '--config-auth', $pgdata, 448 @{ $params{auth_extra} }); 449 450 open my $conf, '>>', "$pgdata/postgresql.conf"; 451 print $conf "\n# Added by PostgresNode.pm\n"; 452 print $conf "fsync = off\n"; 453 print $conf "restart_after_crash = off\n"; 454 print $conf "log_line_prefix = '%m [%p] %q%a '\n"; 455 print $conf "log_statement = all\n"; 456 print $conf "log_replication_commands = on\n"; 457 print $conf "wal_retrieve_retry_interval = '500ms'\n"; 458 459 # If a setting tends to affect whether tests pass or fail, print it after 460 # TEMP_CONFIG. Otherwise, print it before TEMP_CONFIG, thereby permitting 461 # overrides. Settings that merely improve performance or ease debugging 462 # belong before TEMP_CONFIG. 463 print $conf TestLib::slurp_file($ENV{TEMP_CONFIG}) 464 if defined $ENV{TEMP_CONFIG}; 465 466 # XXX Neutralize any stats_temp_directory in TEMP_CONFIG. Nodes running 467 # concurrently must not share a stats_temp_directory. 468 print $conf "stats_temp_directory = 'pg_stat_tmp'\n"; 469 470 if ($params{allows_streaming}) 471 { 472 if ($params{allows_streaming} eq "logical") 473 { 474 print $conf "wal_level = logical\n"; 475 } 476 else 477 { 478 print $conf "wal_level = replica\n"; 479 } 480 print $conf "max_wal_senders = 10\n"; 481 print $conf "max_replication_slots = 10\n"; 482 print $conf "wal_log_hints = on\n"; 483 print $conf "hot_standby = on\n"; 484 # conservative settings to ensure we can run multiple postmasters: 485 print $conf "shared_buffers = 1MB\n"; 486 print $conf "max_connections = 20\n"; 487 # limit disk space consumption, too: 488 print $conf "max_wal_size = 128MB\n"; 489 } 490 else 491 { 492 print $conf "wal_level = minimal\n"; 493 print $conf "max_wal_senders = 0\n"; 494 } 495 496 print $conf "port = $port\n"; 497 if ($use_tcp) 498 { 499 print $conf "unix_socket_directories = ''\n"; 500 print $conf "listen_addresses = '$host'\n"; 501 } 502 else 503 { 504 print $conf "unix_socket_directories = '$host'\n"; 505 print $conf "listen_addresses = ''\n"; 506 } 507 close $conf; 508 509 chmod($self->group_access ? 0640 : 0600, "$pgdata/postgresql.conf") 510 or die("unable to set permissions for $pgdata/postgresql.conf"); 511 512 $self->set_replication_conf if $params{allows_streaming}; 513 $self->enable_archiving if $params{has_archiving}; 514 return; 515} 516 517=pod 518 519=item $node->append_conf(filename, str) 520 521A shortcut method to append to files like pg_hba.conf and postgresql.conf. 522 523Does no validation or sanity checking. Does not reload the configuration 524after writing. 525 526A newline is automatically appended to the string. 527 528=cut 529 530sub append_conf 531{ 532 my ($self, $filename, $str) = @_; 533 534 my $conffile = $self->data_dir . '/' . $filename; 535 536 TestLib::append_to_file($conffile, $str . "\n"); 537 538 chmod($self->group_access() ? 0640 : 0600, $conffile) 539 or die("unable to set permissions for $conffile"); 540 541 return; 542} 543 544=pod 545 546=item $node->backup(backup_name) 547 548Create a hot backup with B<pg_basebackup> in subdirectory B<backup_name> of 549B<< $node->backup_dir >>, including the WAL. 550 551By default, WAL files are fetched at the end of the backup, not streamed. 552You can adjust that and other things by passing an array of additional 553B<pg_basebackup> command line options in the keyword parameter backup_options. 554 555You'll have to configure a suitable B<max_wal_senders> on the 556target server since it isn't done by default. 557 558=cut 559 560sub backup 561{ 562 my ($self, $backup_name, %params) = @_; 563 my $backup_path = $self->backup_dir . '/' . $backup_name; 564 my $name = $self->name; 565 566 print "# Taking pg_basebackup $backup_name from node \"$name\"\n"; 567 TestLib::system_or_bail( 568 'pg_basebackup', '-D', $backup_path, '-h', 569 $self->host, '-p', $self->port, '--checkpoint', 570 'fast', '--no-sync', 571 @{ $params{backup_options} }); 572 print "# Backup finished\n"; 573 return; 574} 575 576=item $node->backup_fs_hot(backup_name) 577 578Create a backup with a filesystem level copy in subdirectory B<backup_name> of 579B<< $node->backup_dir >>, including WAL. 580 581Archiving must be enabled, as B<pg_start_backup()> and B<pg_stop_backup()> are 582used. This is not checked or enforced. 583 584The backup name is passed as the backup label to B<pg_start_backup()>. 585 586=cut 587 588sub backup_fs_hot 589{ 590 my ($self, $backup_name) = @_; 591 $self->_backup_fs($backup_name, 1); 592 return; 593} 594 595=item $node->backup_fs_cold(backup_name) 596 597Create a backup with a filesystem level copy in subdirectory B<backup_name> of 598B<< $node->backup_dir >>, including WAL. The server must be 599stopped as no attempt to handle concurrent writes is made. 600 601Use B<backup> or B<backup_fs_hot> if you want to back up a running server. 602 603=cut 604 605sub backup_fs_cold 606{ 607 my ($self, $backup_name) = @_; 608 $self->_backup_fs($backup_name, 0); 609 return; 610} 611 612 613# Common sub of backup_fs_hot and backup_fs_cold 614sub _backup_fs 615{ 616 my ($self, $backup_name, $hot) = @_; 617 my $backup_path = $self->backup_dir . '/' . $backup_name; 618 my $port = $self->port; 619 my $name = $self->name; 620 621 print "# Taking filesystem backup $backup_name from node \"$name\"\n"; 622 623 if ($hot) 624 { 625 my $stdout = $self->safe_psql('postgres', 626 "SELECT * FROM pg_start_backup('$backup_name');"); 627 print "# pg_start_backup: $stdout\n"; 628 } 629 630 RecursiveCopy::copypath( 631 $self->data_dir, 632 $backup_path, 633 filterfn => sub { 634 my $src = shift; 635 return ($src ne 'log' and $src ne 'postmaster.pid'); 636 }); 637 638 if ($hot) 639 { 640 641 # We ignore pg_stop_backup's return value. We also assume archiving 642 # is enabled; otherwise the caller will have to copy the remaining 643 # segments. 644 my $stdout = 645 $self->safe_psql('postgres', 'SELECT * FROM pg_stop_backup();'); 646 print "# pg_stop_backup: $stdout\n"; 647 } 648 649 print "# Backup finished\n"; 650 return; 651} 652 653 654 655=pod 656 657=item $node->init_from_backup(root_node, backup_name) 658 659Initialize a node from a backup, which may come from this node or a different 660node. root_node must be a PostgresNode reference, backup_name the string name 661of a backup previously created on that node with $node->backup. 662 663Does not start the node after initializing it. 664 665A recovery.conf is not created. 666 667Streaming replication can be enabled on this node by passing the keyword 668parameter has_streaming => 1. This is disabled by default. 669 670Restoring WAL segments from archives using restore_command can be enabled 671by passing the keyword parameter has_restoring => 1. This is disabled by 672default. 673 674The backup is copied, leaving the original unmodified. pg_hba.conf is 675unconditionally set to enable replication connections. 676 677=cut 678 679sub init_from_backup 680{ 681 my ($self, $root_node, $backup_name, %params) = @_; 682 my $backup_path = $root_node->backup_dir . '/' . $backup_name; 683 my $host = $self->host; 684 my $port = $self->port; 685 my $node_name = $self->name; 686 my $root_name = $root_node->name; 687 688 $params{has_streaming} = 0 unless defined $params{has_streaming}; 689 $params{has_restoring} = 0 unless defined $params{has_restoring}; 690 691 print 692 "# Initializing node \"$node_name\" from backup \"$backup_name\" of node \"$root_name\"\n"; 693 croak "Backup \"$backup_name\" does not exist at $backup_path" 694 unless -d $backup_path; 695 696 mkdir $self->backup_dir; 697 mkdir $self->archive_dir; 698 699 my $data_path = $self->data_dir; 700 rmdir($data_path); 701 RecursiveCopy::copypath($backup_path, $data_path); 702 chmod(0700, $data_path); 703 704 # Base configuration for this node 705 $self->append_conf( 706 'postgresql.conf', 707 qq( 708port = $port 709)); 710 if ($use_tcp) 711 { 712 $self->append_conf('postgresql.conf', "listen_addresses = '$host'"); 713 } 714 else 715 { 716 $self->append_conf('postgresql.conf', 717 "unix_socket_directories = '$host'"); 718 } 719 $self->enable_streaming($root_node) if $params{has_streaming}; 720 $self->enable_restoring($root_node) if $params{has_restoring}; 721 return; 722} 723 724=pod 725 726=item $node->rotate_logfile() 727 728Switch to a new PostgreSQL log file. This does not alter any running 729PostgreSQL process. Subsequent method calls, including pg_ctl invocations, 730will use the new name. Return the new name. 731 732=cut 733 734sub rotate_logfile 735{ 736 my ($self) = @_; 737 $self->{_logfile} = sprintf('%s_%d.log', 738 $self->{_logfile_base}, 739 ++$self->{_logfile_generation}); 740 return $self->{_logfile}; 741} 742 743=pod 744 745=item $node->start(%params) => success_or_failure 746 747Wrapper for pg_ctl start 748 749Start the node and wait until it is ready to accept connections. 750 751=over 752 753=item fail_ok => 1 754 755By default, failure terminates the entire F<prove> invocation. If given, 756instead return a true or false value to indicate success or failure. 757 758=back 759 760=cut 761 762sub start 763{ 764 my ($self, %params) = @_; 765 my $port = $self->port; 766 my $pgdata = $self->data_dir; 767 my $name = $self->name; 768 BAIL_OUT("node \"$name\" is already running") if defined $self->{_pid}; 769 print("### Starting node \"$name\"\n"); 770 my $ret = TestLib::system_log('pg_ctl', '-D', $self->data_dir, '-l', 771 $self->logfile, 'start'); 772 773 if ($ret != 0) 774 { 775 print "# pg_ctl start failed; logfile:\n"; 776 print TestLib::slurp_file($self->logfile); 777 BAIL_OUT("pg_ctl start failed") unless $params{fail_ok}; 778 return 0; 779 } 780 781 $self->_update_pid(1); 782 return 1; 783} 784 785=pod 786 787=item $node->kill9() 788 789Send SIGKILL (signal 9) to the postmaster. 790 791Note: if the node is already known stopped, this does nothing. 792However, if we think it's running and it's not, it's important for 793this to fail. Otherwise, tests might fail to detect server crashes. 794 795=cut 796 797sub kill9 798{ 799 my ($self) = @_; 800 my $name = $self->name; 801 return unless defined $self->{_pid}; 802 print "### Killing node \"$name\" using signal 9\n"; 803 # kill(9, ...) fails under msys Perl 5.8.8, so fall back on pg_ctl. 804 kill(9, $self->{_pid}) 805 or TestLib::system_or_bail('pg_ctl', 'kill', 'KILL', $self->{_pid}); 806 $self->{_pid} = undef; 807 return; 808} 809 810=pod 811 812=item $node->stop(mode) 813 814Stop the node using pg_ctl -m $mode and wait for it to stop. 815 816Note: if the node is already known stopped, this does nothing. 817However, if we think it's running and it's not, it's important for 818this to fail. Otherwise, tests might fail to detect server crashes. 819 820=cut 821 822sub stop 823{ 824 my ($self, $mode) = @_; 825 my $port = $self->port; 826 my $pgdata = $self->data_dir; 827 my $name = $self->name; 828 $mode = 'fast' unless defined $mode; 829 return unless defined $self->{_pid}; 830 print "### Stopping node \"$name\" using mode $mode\n"; 831 TestLib::system_or_bail('pg_ctl', '-D', $pgdata, '-m', $mode, 'stop'); 832 $self->_update_pid(0); 833 return; 834} 835 836=pod 837 838=item $node->reload() 839 840Reload configuration parameters on the node. 841 842=cut 843 844sub reload 845{ 846 my ($self) = @_; 847 my $port = $self->port; 848 my $pgdata = $self->data_dir; 849 my $name = $self->name; 850 print "### Reloading node \"$name\"\n"; 851 TestLib::system_or_bail('pg_ctl', '-D', $pgdata, 'reload'); 852 return; 853} 854 855=pod 856 857=item $node->restart() 858 859Wrapper for pg_ctl restart 860 861=cut 862 863sub restart 864{ 865 my ($self) = @_; 866 my $port = $self->port; 867 my $pgdata = $self->data_dir; 868 my $logfile = $self->logfile; 869 my $name = $self->name; 870 print "### Restarting node \"$name\"\n"; 871 TestLib::system_or_bail('pg_ctl', '-D', $pgdata, '-l', $logfile, 872 'restart'); 873 $self->_update_pid(1); 874 return; 875} 876 877=pod 878 879=item $node->promote() 880 881Wrapper for pg_ctl promote 882 883=cut 884 885sub promote 886{ 887 my ($self) = @_; 888 my $port = $self->port; 889 my $pgdata = $self->data_dir; 890 my $logfile = $self->logfile; 891 my $name = $self->name; 892 print "### Promoting node \"$name\"\n"; 893 TestLib::system_or_bail('pg_ctl', '-D', $pgdata, '-l', $logfile, 894 'promote'); 895 return; 896} 897 898# Internal routine to enable streaming replication on a standby node. 899sub enable_streaming 900{ 901 my ($self, $root_node) = @_; 902 my $root_connstr = $root_node->connstr; 903 my $name = $self->name; 904 905 print "### Enabling streaming replication for node \"$name\"\n"; 906 $self->append_conf( 907 'recovery.conf', qq( 908primary_conninfo='$root_connstr application_name=$name' 909standby_mode=on 910)); 911 return; 912} 913 914# Internal routine to enable archive recovery command on a standby node 915sub enable_restoring 916{ 917 my ($self, $root_node) = @_; 918 my $path = TestLib::perl2host($root_node->archive_dir); 919 my $name = $self->name; 920 921 print "### Enabling WAL restore for node \"$name\"\n"; 922 923 # On Windows, the path specified in the restore command needs to use 924 # double back-slashes to work properly and to be able to detect properly 925 # the file targeted by the copy command, so the directory value used 926 # in this routine, using only one back-slash, need to be properly changed 927 # first. Paths also need to be double-quoted to prevent failures where 928 # the path contains spaces. 929 $path =~ s{\\}{\\\\}g if ($TestLib::windows_os); 930 my $copy_command = 931 $TestLib::windows_os 932 ? qq{copy "$path\\\\%f" "%p"} 933 : qq{cp "$path/%f" "%p"}; 934 935 $self->append_conf( 936 'recovery.conf', qq( 937restore_command = '$copy_command' 938standby_mode = on 939)); 940 return; 941} 942 943# Internal routine to enable archiving 944sub enable_archiving 945{ 946 my ($self) = @_; 947 my $path = TestLib::perl2host($self->archive_dir); 948 my $name = $self->name; 949 950 print "### Enabling WAL archiving for node \"$name\"\n"; 951 952 # On Windows, the path specified in the restore command needs to use 953 # double back-slashes to work properly and to be able to detect properly 954 # the file targeted by the copy command, so the directory value used 955 # in this routine, using only one back-slash, need to be properly changed 956 # first. Paths also need to be double-quoted to prevent failures where 957 # the path contains spaces. 958 $path =~ s{\\}{\\\\}g if ($TestLib::windows_os); 959 my $copy_command = 960 $TestLib::windows_os 961 ? qq{copy "%p" "$path\\\\%f"} 962 : qq{cp "%p" "$path/%f"}; 963 964 # Enable archive_mode and archive_command on node 965 $self->append_conf( 966 'postgresql.conf', qq( 967archive_mode = on 968archive_command = '$copy_command' 969)); 970 return; 971} 972 973# Internal method 974sub _update_pid 975{ 976 my ($self, $is_running) = @_; 977 my $name = $self->name; 978 979 # If we can open the PID file, read its first line and that's the PID we 980 # want. 981 if (open my $pidfile, '<', $self->data_dir . "/postmaster.pid") 982 { 983 chomp($self->{_pid} = <$pidfile>); 984 print "# Postmaster PID for node \"$name\" is $self->{_pid}\n"; 985 close $pidfile; 986 987 # If we found a pidfile when there shouldn't be one, complain. 988 BAIL_OUT("postmaster.pid unexpectedly present") unless $is_running; 989 return; 990 } 991 992 $self->{_pid} = undef; 993 print "# No postmaster PID for node \"$name\"\n"; 994 995 # Complain if we expected to find a pidfile. 996 BAIL_OUT("postmaster.pid unexpectedly not present") if $is_running; 997 return; 998} 999 1000=pod 1001 1002=item PostgresNode->get_new_node(node_name, %params) 1003 1004Build a new object of class C<PostgresNode> (or of a subclass, if you have 1005one), assigning a free port number. Remembers the node, to prevent its port 1006number from being reused for another node, and to ensure that it gets 1007shut down when the test script exits. 1008 1009You should generally use this instead of C<PostgresNode::new(...)>. 1010 1011=over 1012 1013=item port => [1,65535] 1014 1015By default, this function assigns a port number to each node. Specify this to 1016force a particular port number. The caller is responsible for evaluating 1017potential conflicts and privilege requirements. 1018 1019=item own_host => 1 1020 1021By default, all nodes use the same PGHOST value. If specified, generate a 1022PGHOST specific to this node. This allows multiple nodes to use the same 1023port. 1024 1025=back 1026 1027For backwards compatibility, it is also exported as a standalone function, 1028which can only create objects of class C<PostgresNode>. 1029 1030=cut 1031 1032sub get_new_node 1033{ 1034 my $class = 'PostgresNode'; 1035 $class = shift if scalar(@_) % 2 != 1; 1036 my ($name, %params) = @_; 1037 1038 # Select a port. 1039 my $port; 1040 if (defined $params{port}) 1041 { 1042 $port = $params{port}; 1043 } 1044 else 1045 { 1046 # When selecting a port, we look for an unassigned TCP port number, 1047 # even if we intend to use only Unix-domain sockets. This is clearly 1048 # necessary on $use_tcp (Windows) configurations, and it seems like a 1049 # good idea on Unixen as well. 1050 $port = get_free_port(); 1051 } 1052 1053 # Select a host. 1054 my $host = $test_pghost; 1055 if ($params{own_host}) 1056 { 1057 if ($use_tcp) 1058 { 1059 $last_host_assigned++; 1060 $last_host_assigned > 254 and BAIL_OUT("too many own_host nodes"); 1061 $host = '127.0.0.' . $last_host_assigned; 1062 } 1063 else 1064 { 1065 $host = "$test_pghost/$name"; # Assume $name =~ /^[-_a-zA-Z0-9]+$/ 1066 mkdir $host; 1067 } 1068 } 1069 1070 # Lock port number found by creating a new node 1071 my $node = $class->new($name, $host, $port); 1072 1073 # Add node to list of nodes 1074 push(@all_nodes, $node); 1075 1076 return $node; 1077} 1078 1079=pod 1080 1081=item get_free_port() 1082 1083Locate an unprivileged (high) TCP port that's not currently bound to 1084anything. This is used by get_new_node, and is also exported for use 1085by test cases that need to start other, non-Postgres servers. 1086 1087Ports assigned to existing PostgresNode objects are automatically 1088excluded, even if those servers are not currently running. 1089 1090XXX A port available now may become unavailable by the time we start 1091the desired service. 1092 1093=cut 1094 1095sub get_free_port 1096{ 1097 my $found = 0; 1098 my $port = $last_port_assigned; 1099 1100 while ($found == 0) 1101 { 1102 1103 # advance $port, wrapping correctly around range end 1104 $port = 49152 if ++$port >= 65536; 1105 print "# Checking port $port\n"; 1106 1107 # Check first that candidate port number is not included in 1108 # the list of already-registered nodes. 1109 $found = 1; 1110 foreach my $node (@all_nodes) 1111 { 1112 $found = 0 if ($node->port == $port); 1113 } 1114 1115 # Check to see if anything else is listening on this TCP port. 1116 # Seek a port available for all possible listen_addresses values, 1117 # so callers can harness this port for the widest range of purposes. 1118 # The 0.0.0.0 test achieves that for MSYS, which automatically sets 1119 # SO_EXCLUSIVEADDRUSE. Testing 0.0.0.0 is insufficient for Windows 1120 # native Perl (https://stackoverflow.com/a/14388707), so we also 1121 # have to test individual addresses. Doing that for 127.0.0/24 1122 # addresses other than 127.0.0.1 might fail with EADDRNOTAVAIL on 1123 # non-Linux, non-Windows kernels. 1124 # 1125 # Thus, 0.0.0.0 and individual 127.0.0/24 addresses are tested 1126 # only on Windows and only when TCP usage is requested. 1127 if ($found == 1) 1128 { 1129 foreach my $addr (qw(127.0.0.1), 1130 ($use_tcp && $TestLib::windows_os) 1131 ? qw(127.0.0.2 127.0.0.3 0.0.0.0) 1132 : ()) 1133 { 1134 if (!can_bind($addr, $port)) 1135 { 1136 $found = 0; 1137 last; 1138 } 1139 } 1140 } 1141 } 1142 1143 print "# Found port $port\n"; 1144 1145 # Update port for next time 1146 $last_port_assigned = $port; 1147 1148 return $port; 1149} 1150 1151# Internal routine to check whether a host:port is available to bind 1152sub can_bind 1153{ 1154 my ($host, $port) = @_; 1155 my $iaddr = inet_aton($host); 1156 my $paddr = sockaddr_in($port, $iaddr); 1157 my $proto = getprotobyname("tcp"); 1158 1159 socket(SOCK, PF_INET, SOCK_STREAM, $proto) 1160 or die "socket failed: $!"; 1161 1162 # As in postmaster, don't use SO_REUSEADDR on Windows 1163 setsockopt(SOCK, SOL_SOCKET, SO_REUSEADDR, pack("l", 1)) 1164 unless $TestLib::windows_os; 1165 my $ret = bind(SOCK, $paddr) && listen(SOCK, SOMAXCONN); 1166 close(SOCK); 1167 return $ret; 1168} 1169 1170# Automatically shut down any still-running nodes when the test script exits. 1171# Note that this just stops the postmasters (in the same order the nodes were 1172# created in). Any temporary directories are deleted, in an unspecified 1173# order, later when the File::Temp objects are destroyed. 1174END 1175{ 1176 1177 # take care not to change the script's exit value 1178 my $exit_code = $?; 1179 1180 foreach my $node (@all_nodes) 1181 { 1182 $node->teardown_node; 1183 1184 # skip clean if we are requested to retain the basedir 1185 next if defined $ENV{'PG_TEST_NOCLEAN'}; 1186 1187 # clean basedir on clean test invocation 1188 $node->clean_node if $exit_code == 0 && TestLib::all_tests_passing(); 1189 } 1190 1191 $? = $exit_code; 1192} 1193 1194=pod 1195 1196=item $node->teardown_node() 1197 1198Do an immediate stop of the node 1199 1200=cut 1201 1202sub teardown_node 1203{ 1204 my $self = shift; 1205 1206 $self->stop('immediate'); 1207 return; 1208} 1209 1210=pod 1211 1212=item $node->clean_node() 1213 1214Remove the base directory of the node if the node has been stopped. 1215 1216=cut 1217 1218sub clean_node 1219{ 1220 my $self = shift; 1221 1222 rmtree $self->{_basedir} unless defined $self->{_pid}; 1223 return; 1224} 1225 1226=pod 1227 1228=item $node->safe_psql($dbname, $sql) => stdout 1229 1230Invoke B<psql> to run B<sql> on B<dbname> and return its stdout on success. 1231Die if the SQL produces an error. Runs with B<ON_ERROR_STOP> set. 1232 1233Takes optional extra params like timeout and timed_out parameters with the same 1234options as psql. 1235 1236=cut 1237 1238sub safe_psql 1239{ 1240 my ($self, $dbname, $sql, %params) = @_; 1241 1242 my ($stdout, $stderr); 1243 1244 my $ret = $self->psql( 1245 $dbname, $sql, 1246 %params, 1247 stdout => \$stdout, 1248 stderr => \$stderr, 1249 on_error_die => 1, 1250 on_error_stop => 1); 1251 1252 # psql can emit stderr from NOTICEs etc 1253 if ($stderr ne "") 1254 { 1255 print "#### Begin standard error\n"; 1256 print $stderr; 1257 print "\n#### End standard error\n"; 1258 } 1259 1260 return $stdout; 1261} 1262 1263=pod 1264 1265=item $node->psql($dbname, $sql, %params) => psql_retval 1266 1267Invoke B<psql> to execute B<$sql> on B<$dbname> and return the return value 1268from B<psql>, which is run with on_error_stop by default so that it will 1269stop running sql and return 3 if the passed SQL results in an error. 1270 1271As a convenience, if B<psql> is called in array context it returns an 1272array containing ($retval, $stdout, $stderr). 1273 1274psql is invoked in tuples-only unaligned mode with reading of B<.psqlrc> 1275disabled. That may be overridden by passing extra psql parameters. 1276 1277stdout and stderr are transformed to UNIX line endings if on Windows. Any 1278trailing newline is removed. 1279 1280Dies on failure to invoke psql but not if psql exits with a nonzero 1281return code (unless on_error_die specified). 1282 1283If psql exits because of a signal, an exception is raised. 1284 1285=over 1286 1287=item stdout => \$stdout 1288 1289B<stdout>, if given, must be a scalar reference to which standard output is 1290written. If not given, standard output is not redirected and will be printed 1291unless B<psql> is called in array context, in which case it's captured and 1292returned. 1293 1294=item stderr => \$stderr 1295 1296Same as B<stdout> but gets standard error. If the same scalar is passed for 1297both B<stdout> and B<stderr> the results may be interleaved unpredictably. 1298 1299=item on_error_stop => 1 1300 1301By default, the B<psql> method invokes the B<psql> program with ON_ERROR_STOP=1 1302set, so SQL execution is stopped at the first error and exit code 2 is 1303returned. Set B<on_error_stop> to 0 to ignore errors instead. 1304 1305=item on_error_die => 0 1306 1307By default, this method returns psql's result code. Pass on_error_die to 1308instead die with an informative message. 1309 1310=item timeout => 'interval' 1311 1312Set a timeout for the psql call as an interval accepted by B<IPC::Run::timer> 1313(integer seconds is fine). This method raises an exception on timeout, unless 1314the B<timed_out> parameter is also given. 1315 1316=item timed_out => \$timed_out 1317 1318If B<timeout> is set and this parameter is given, the scalar it references 1319is set to true if the psql call times out. 1320 1321=item extra_params => ['--single-transaction'] 1322 1323If given, it must be an array reference containing additional parameters to B<psql>. 1324 1325=back 1326 1327e.g. 1328 1329 my ($stdout, $stderr, $timed_out); 1330 my $cmdret = $node->psql('postgres', 'SELECT pg_sleep(600)', 1331 stdout => \$stdout, stderr => \$stderr, 1332 timeout => 180, timed_out => \$timed_out, 1333 extra_params => ['--single-transaction']) 1334 1335will set $cmdret to undef and $timed_out to a true value. 1336 1337 $node->psql('postgres', $sql, on_error_die => 1); 1338 1339dies with an informative message if $sql fails. 1340 1341=cut 1342 1343sub psql 1344{ 1345 my ($self, $dbname, $sql, %params) = @_; 1346 1347 my $stdout = $params{stdout}; 1348 my $stderr = $params{stderr}; 1349 my $timeout = undef; 1350 my $timeout_exception = 'psql timed out'; 1351 my @psql_params = 1352 ('psql', '-XAtq', '-d', $self->connstr($dbname), '-f', '-'); 1353 1354 # If the caller wants an array and hasn't passed stdout/stderr 1355 # references, allocate temporary ones to capture them so we 1356 # can return them. Otherwise we won't redirect them at all. 1357 if (wantarray) 1358 { 1359 if (!defined($stdout)) 1360 { 1361 my $temp_stdout = ""; 1362 $stdout = \$temp_stdout; 1363 } 1364 if (!defined($stderr)) 1365 { 1366 my $temp_stderr = ""; 1367 $stderr = \$temp_stderr; 1368 } 1369 } 1370 1371 $params{on_error_stop} = 1 unless defined $params{on_error_stop}; 1372 $params{on_error_die} = 0 unless defined $params{on_error_die}; 1373 1374 push @psql_params, '-v', 'ON_ERROR_STOP=1' if $params{on_error_stop}; 1375 push @psql_params, @{ $params{extra_params} } 1376 if defined $params{extra_params}; 1377 1378 $timeout = 1379 IPC::Run::timeout($params{timeout}, exception => $timeout_exception) 1380 if (defined($params{timeout})); 1381 1382 ${ $params{timed_out} } = 0 if defined $params{timed_out}; 1383 1384 # IPC::Run would otherwise append to existing contents: 1385 $$stdout = "" if ref($stdout); 1386 $$stderr = "" if ref($stderr); 1387 1388 my $ret; 1389 1390 # Run psql and capture any possible exceptions. If the exception is 1391 # because of a timeout and the caller requested to handle that, just return 1392 # and set the flag. Otherwise, and for any other exception, rethrow. 1393 # 1394 # For background, see 1395 # https://metacpan.org/pod/release/ETHER/Try-Tiny-0.24/lib/Try/Tiny.pm 1396 do 1397 { 1398 local $@; 1399 eval { 1400 my @ipcrun_opts = (\@psql_params, '<', \$sql); 1401 push @ipcrun_opts, '>', $stdout if defined $stdout; 1402 push @ipcrun_opts, '2>', $stderr if defined $stderr; 1403 push @ipcrun_opts, $timeout if defined $timeout; 1404 1405 IPC::Run::run @ipcrun_opts; 1406 $ret = $?; 1407 }; 1408 my $exc_save = $@; 1409 if ($exc_save) 1410 { 1411 1412 # IPC::Run::run threw an exception. re-throw unless it's a 1413 # timeout, which we'll handle by testing is_expired 1414 die $exc_save 1415 if (blessed($exc_save) 1416 || $exc_save !~ /^\Q$timeout_exception\E/); 1417 1418 $ret = undef; 1419 1420 die "Got timeout exception '$exc_save' but timer not expired?!" 1421 unless $timeout->is_expired; 1422 1423 if (defined($params{timed_out})) 1424 { 1425 ${ $params{timed_out} } = 1; 1426 } 1427 else 1428 { 1429 die "psql timed out: stderr: '$$stderr'\n" 1430 . "while running '@psql_params'"; 1431 } 1432 } 1433 }; 1434 1435 # Note: on Windows, IPC::Run seems to convert \r\n to \n in program output 1436 # if we're using native Perl, but not if we're using MSys Perl. So do it 1437 # by hand in the latter case, here and elsewhere. 1438 1439 if (defined $$stdout) 1440 { 1441 $$stdout =~ s/\r\n/\n/g if $Config{osname} eq 'msys'; 1442 chomp $$stdout; 1443 } 1444 1445 if (defined $$stderr) 1446 { 1447 $$stderr =~ s/\r\n/\n/g if $Config{osname} eq 'msys'; 1448 chomp $$stderr; 1449 } 1450 1451 # See http://perldoc.perl.org/perlvar.html#%24CHILD_ERROR 1452 # We don't use IPC::Run::Simple to limit dependencies. 1453 # 1454 # We always die on signal. 1455 my $core = $ret & 128 ? " (core dumped)" : ""; 1456 die "psql exited with signal " 1457 . ($ret & 127) 1458 . "$core: '$$stderr' while running '@psql_params'" 1459 if $ret & 127; 1460 $ret = $ret >> 8; 1461 1462 if ($ret && $params{on_error_die}) 1463 { 1464 die "psql error: stderr: '$$stderr'\nwhile running '@psql_params'" 1465 if $ret == 1; 1466 die "connection error: '$$stderr'\nwhile running '@psql_params'" 1467 if $ret == 2; 1468 die 1469 "error running SQL: '$$stderr'\nwhile running '@psql_params' with sql '$sql'" 1470 if $ret == 3; 1471 die "psql returns $ret: '$$stderr'\nwhile running '@psql_params'"; 1472 } 1473 1474 if (wantarray) 1475 { 1476 return ($ret, $$stdout, $$stderr); 1477 } 1478 else 1479 { 1480 return $ret; 1481 } 1482} 1483 1484=pod 1485 1486=item $node->background_psql($dbname, \$stdin, \$stdout, $timer, %params) => harness 1487 1488Invoke B<psql> on B<$dbname> and return an IPC::Run harness object, which the 1489caller may use to send input to B<psql>. The process's stdin is sourced from 1490the $stdin scalar reference, and its stdout and stderr go to the $stdout 1491scalar reference. This allows the caller to act on other parts of the system 1492while idling this backend. 1493 1494The specified timer object is attached to the harness, as well. It's caller's 1495responsibility to select the timeout length, and to restart the timer after 1496each command if the timeout is per-command. 1497 1498psql is invoked in tuples-only unaligned mode with reading of B<.psqlrc> 1499disabled. That may be overridden by passing extra psql parameters. 1500 1501Dies on failure to invoke psql, or if psql fails to connect. Errors occurring 1502later are the caller's problem. psql runs with on_error_stop by default so 1503that it will stop running sql and return 3 if passed SQL results in an error. 1504 1505Be sure to "finish" the harness when done with it. 1506 1507=over 1508 1509=item on_error_stop => 1 1510 1511By default, the B<psql> method invokes the B<psql> program with ON_ERROR_STOP=1 1512set, so SQL execution is stopped at the first error and exit code 3 is 1513returned. Set B<on_error_stop> to 0 to ignore errors instead. 1514 1515=item replication => B<value> 1516 1517If set, add B<replication=value> to the conninfo string. 1518Passing the literal value C<database> results in a logical replication 1519connection. 1520 1521=item extra_params => ['--single-transaction'] 1522 1523If given, it must be an array reference containing additional parameters to B<psql>. 1524 1525=back 1526 1527=cut 1528 1529sub background_psql 1530{ 1531 my ($self, $dbname, $stdin, $stdout, $timer, %params) = @_; 1532 1533 local $ENV{PGHOST} = $self->host; 1534 local $ENV{PGPORT} = $self->port; 1535 1536 my $replication = $params{replication}; 1537 1538 my @psql_params = ( 1539 'psql', 1540 '-XAtq', 1541 '-d', 1542 $self->connstr($dbname) 1543 . (defined $replication ? " replication=$replication" : ""), 1544 '-f', 1545 '-'); 1546 1547 $params{on_error_stop} = 1 unless defined $params{on_error_stop}; 1548 1549 push @psql_params, '-v', 'ON_ERROR_STOP=1' if $params{on_error_stop}; 1550 push @psql_params, @{ $params{extra_params} } 1551 if defined $params{extra_params}; 1552 1553 # Ensure there is no data waiting to be sent: 1554 $$stdin = "" if ref($stdin); 1555 # IPC::Run would otherwise append to existing contents: 1556 $$stdout = "" if ref($stdout); 1557 1558 my $harness = IPC::Run::start \@psql_params, 1559 '<', $stdin, '>', $stdout, $timer; 1560 1561 # Request some output, and pump until we see it. This means that psql 1562 # connection failures are caught here, relieving callers of the need to 1563 # handle those. (Right now, we have no particularly good handling for 1564 # errors anyway, but that might be added later.) 1565 my $banner = "background_psql: ready"; 1566 $$stdin = "\\echo $banner\n"; 1567 pump $harness until $$stdout =~ /$banner/ || $timer->is_expired; 1568 1569 die "psql startup timed out" if $timer->is_expired; 1570 1571 return $harness; 1572} 1573 1574# Common sub of pgbench-invoking interfaces. Makes any requested script files 1575# and returns pgbench command-line options causing use of those files. 1576sub _pgbench_make_files 1577{ 1578 my ($self, $files) = @_; 1579 my @file_opts; 1580 1581 if (defined $files) 1582 { 1583 1584 # note: files are ordered for determinism 1585 for my $fn (sort keys %$files) 1586 { 1587 my $filename = $self->basedir . '/' . $fn; 1588 push @file_opts, '-f', $filename; 1589 1590 # cleanup file weight 1591 $filename =~ s/\@\d+$//; 1592 1593 #push @filenames, $filename; 1594 # filenames are expected to be unique on a test 1595 if (-e $filename) 1596 { 1597 ok(0, "$filename must not already exist"); 1598 unlink $filename or die "cannot unlink $filename: $!"; 1599 } 1600 TestLib::append_to_file($filename, $$files{$fn}); 1601 } 1602 } 1603 1604 return @file_opts; 1605} 1606 1607=pod 1608 1609=item $node->pgbench($opts, $stat, $out, $err, $name, $files, @args) 1610 1611Invoke B<pgbench>, with parameters and files. 1612 1613=over 1614 1615=item $opts 1616 1617Options as a string to be split on spaces. 1618 1619=item $stat 1620 1621Expected exit status. 1622 1623=item $out 1624 1625Reference to a regexp list that must match stdout. 1626 1627=item $err 1628 1629Reference to a regexp list that must match stderr. 1630 1631=item $name 1632 1633Name of test for error messages. 1634 1635=item $files 1636 1637Reference to filename/contents dictionary. 1638 1639=item @args 1640 1641Further raw options or arguments. 1642 1643=back 1644 1645=cut 1646 1647sub pgbench 1648{ 1649 local $Test::Builder::Level = $Test::Builder::Level + 1; 1650 1651 my ($self, $opts, $stat, $out, $err, $name, $files, @args) = @_; 1652 my @cmd = ( 1653 'pgbench', 1654 split(/\s+/, $opts), 1655 $self->_pgbench_make_files($files), @args); 1656 1657 $self->command_checks_all(\@cmd, $stat, $out, $err, $name); 1658} 1659 1660=pod 1661 1662=item $node->background_pgbench($opts, $files, \$stdout, $timer) => harness 1663 1664Invoke B<pgbench> and return an IPC::Run harness object. The process's stdin 1665is empty, and its stdout and stderr go to the $stdout scalar reference. This 1666allows the caller to act on other parts of the system while B<pgbench> is 1667running. Errors from B<pgbench> are the caller's problem. 1668 1669The specified timer object is attached to the harness, as well. It's caller's 1670responsibility to select the timeout length, and to restart the timer after 1671each command if the timeout is per-command. 1672 1673Be sure to "finish" the harness when done with it. 1674 1675=over 1676 1677=item $opts 1678 1679Options as a string to be split on spaces. 1680 1681=item $files 1682 1683Reference to filename/contents dictionary. 1684 1685=back 1686 1687=cut 1688 1689sub background_pgbench 1690{ 1691 my ($self, $opts, $files, $stdout, $timer) = @_; 1692 1693 my @cmd = 1694 ('pgbench', split(/\s+/, $opts), $self->_pgbench_make_files($files)); 1695 1696 local $ENV{PGHOST} = $self->host; 1697 local $ENV{PGPORT} = $self->port; 1698 1699 my $stdin = ""; 1700 # IPC::Run would otherwise append to existing contents: 1701 $$stdout = "" if ref($stdout); 1702 1703 my $harness = IPC::Run::start \@cmd, '<', \$stdin, '>', $stdout, '2>&1', 1704 $timer; 1705 1706 return $harness; 1707} 1708 1709=pod 1710 1711=item $node->poll_query_until($dbname, $query [, $expected ]) 1712 1713Run B<$query> repeatedly, until it returns the B<$expected> result 1714('t', or SQL boolean true, by default). 1715Continues polling if B<psql> returns an error result. 1716Times out after 180 seconds. 1717Returns 1 if successful, 0 if timed out. 1718 1719=cut 1720 1721sub poll_query_until 1722{ 1723 my ($self, $dbname, $query, $expected) = @_; 1724 1725 $expected = 't' unless defined($expected); # default value 1726 1727 my $cmd = [ 'psql', '-XAt', '-d', $self->connstr($dbname) ]; 1728 my ($stdout, $stderr); 1729 my $max_attempts = 180 * 10; 1730 my $attempts = 0; 1731 1732 while ($attempts < $max_attempts) 1733 { 1734 my $result = IPC::Run::run $cmd, '<', \$query, 1735 '>', \$stdout, '2>', \$stderr; 1736 1737 $stdout =~ s/\r\n/\n/g if $Config{osname} eq 'msys'; 1738 chomp($stdout); 1739 $stderr =~ s/\r\n/\n/g if $Config{osname} eq 'msys'; 1740 chomp($stderr); 1741 1742 if ($stdout eq $expected && $stderr eq '') 1743 { 1744 return 1; 1745 } 1746 1747 # Wait 0.1 second before retrying. 1748 usleep(100_000); 1749 1750 $attempts++; 1751 } 1752 1753 # The query result didn't change in 180 seconds. Give up. Print the 1754 # output from the last attempt, hopefully that's useful for debugging. 1755 diag qq(poll_query_until timed out executing this query: 1756$query 1757expecting this output: 1758$expected 1759last actual query output: 1760$stdout 1761with stderr: 1762$stderr); 1763 return 0; 1764} 1765 1766=pod 1767 1768=item $node->command_ok(...) 1769 1770Runs a shell command like TestLib::command_ok, but with PGHOST and PGPORT set 1771so that the command will default to connecting to this PostgresNode. 1772 1773=cut 1774 1775sub command_ok 1776{ 1777 my $self = shift; 1778 1779 local $ENV{PGHOST} = $self->host; 1780 local $ENV{PGPORT} = $self->port; 1781 1782 TestLib::command_ok(@_); 1783 return; 1784} 1785 1786=pod 1787 1788=item $node->command_fails(...) 1789 1790TestLib::command_fails with our connection parameters. See command_ok(...) 1791 1792=cut 1793 1794sub command_fails 1795{ 1796 my $self = shift; 1797 1798 local $ENV{PGHOST} = $self->host; 1799 local $ENV{PGPORT} = $self->port; 1800 1801 TestLib::command_fails(@_); 1802 return; 1803} 1804 1805=pod 1806 1807=item $node->command_like(...) 1808 1809TestLib::command_like with our connection parameters. See command_ok(...) 1810 1811=cut 1812 1813sub command_like 1814{ 1815 my $self = shift; 1816 1817 local $ENV{PGHOST} = $self->host; 1818 local $ENV{PGPORT} = $self->port; 1819 1820 TestLib::command_like(@_); 1821 return; 1822} 1823 1824=pod 1825 1826=item $node->command_checks_all(...) 1827 1828TestLib::command_checks_all with our connection parameters. See 1829command_ok(...) 1830 1831=cut 1832 1833sub command_checks_all 1834{ 1835 my $self = shift; 1836 1837 local $ENV{PGHOST} = $self->host; 1838 local $ENV{PGPORT} = $self->port; 1839 1840 TestLib::command_checks_all(@_); 1841 return; 1842} 1843 1844=pod 1845 1846=item $node->issues_sql_like(cmd, expected_sql, test_name) 1847 1848Run a command on the node, then verify that $expected_sql appears in the 1849server log file. 1850 1851=cut 1852 1853sub issues_sql_like 1854{ 1855 my ($self, $cmd, $expected_sql, $test_name) = @_; 1856 1857 local $ENV{PGHOST} = $self->host; 1858 local $ENV{PGPORT} = $self->port; 1859 1860 my $log_location = -s $self->logfile; 1861 1862 my $result = TestLib::run_log($cmd); 1863 ok($result, "@$cmd exit code 0"); 1864 my $log = TestLib::slurp_file($self->logfile, $log_location); 1865 like($log, $expected_sql, "$test_name: SQL found in server log"); 1866 return; 1867} 1868 1869=pod 1870 1871=item $node->run_log(...) 1872 1873Runs a shell command like TestLib::run_log, but with connection parameters set 1874so that the command will default to connecting to this PostgresNode. 1875 1876=cut 1877 1878sub run_log 1879{ 1880 my $self = shift; 1881 1882 local $ENV{PGHOST} = $self->host; 1883 local $ENV{PGPORT} = $self->port; 1884 1885 TestLib::run_log(@_); 1886 return; 1887} 1888 1889=pod 1890 1891=item $node->lsn(mode) 1892 1893Look up WAL locations on the server: 1894 1895 * insert location (master only, error on replica) 1896 * write location (master only, error on replica) 1897 * flush location (master only, error on replica) 1898 * receive location (always undef on master) 1899 * replay location (always undef on master) 1900 1901mode must be specified. 1902 1903=cut 1904 1905sub lsn 1906{ 1907 my ($self, $mode) = @_; 1908 my %modes = ( 1909 'insert' => 'pg_current_wal_insert_lsn()', 1910 'flush' => 'pg_current_wal_flush_lsn()', 1911 'write' => 'pg_current_wal_lsn()', 1912 'receive' => 'pg_last_wal_receive_lsn()', 1913 'replay' => 'pg_last_wal_replay_lsn()'); 1914 1915 $mode = '<undef>' if !defined($mode); 1916 croak "unknown mode for 'lsn': '$mode', valid modes are " 1917 . join(', ', keys %modes) 1918 if !defined($modes{$mode}); 1919 1920 my $result = $self->safe_psql('postgres', "SELECT $modes{$mode}"); 1921 chomp($result); 1922 if ($result eq '') 1923 { 1924 return; 1925 } 1926 else 1927 { 1928 return $result; 1929 } 1930} 1931 1932=pod 1933 1934=item $node->wait_for_catchup(standby_name, mode, target_lsn) 1935 1936Wait for the node with application_name standby_name (usually from node->name, 1937also works for logical subscriptions) 1938until its replication location in pg_stat_replication equals or passes the 1939upstream's WAL insert point at the time this function is called. By default 1940the replay_lsn is waited for, but 'mode' may be specified to wait for any of 1941sent|write|flush|replay. The connection catching up must be in a streaming 1942state. 1943 1944If there is no active replication connection from this peer, waits until 1945poll_query_until timeout. 1946 1947Requires that the 'postgres' db exists and is accessible. 1948 1949target_lsn may be any arbitrary lsn, but is typically $master_node->lsn('insert'). 1950If omitted, pg_current_wal_lsn() is used. 1951 1952This is not a test. It die()s on failure. 1953 1954=cut 1955 1956sub wait_for_catchup 1957{ 1958 my ($self, $standby_name, $mode, $target_lsn) = @_; 1959 $mode = defined($mode) ? $mode : 'replay'; 1960 my %valid_modes = 1961 ('sent' => 1, 'write' => 1, 'flush' => 1, 'replay' => 1); 1962 croak "unknown mode $mode for 'wait_for_catchup', valid modes are " 1963 . join(', ', keys(%valid_modes)) 1964 unless exists($valid_modes{$mode}); 1965 1966 # Allow passing of a PostgresNode instance as shorthand 1967 if (blessed($standby_name) && $standby_name->isa("PostgresNode")) 1968 { 1969 $standby_name = $standby_name->name; 1970 } 1971 my $lsn_expr; 1972 if (defined($target_lsn)) 1973 { 1974 $lsn_expr = "'$target_lsn'"; 1975 } 1976 else 1977 { 1978 $lsn_expr = 'pg_current_wal_lsn()'; 1979 } 1980 print "Waiting for replication conn " 1981 . $standby_name . "'s " 1982 . $mode 1983 . "_lsn to pass " 1984 . $lsn_expr . " on " 1985 . $self->name . "\n"; 1986 my $query = 1987 qq[SELECT $lsn_expr <= ${mode}_lsn AND state = 'streaming' FROM pg_catalog.pg_stat_replication WHERE application_name = '$standby_name';]; 1988 $self->poll_query_until('postgres', $query) 1989 or croak "timed out waiting for catchup"; 1990 print "done\n"; 1991 return; 1992} 1993 1994=pod 1995 1996=item $node->wait_for_slot_catchup(slot_name, mode, target_lsn) 1997 1998Wait for the named replication slot to equal or pass the supplied target_lsn. 1999The location used is the restart_lsn unless mode is given, in which case it may 2000be 'restart' or 'confirmed_flush'. 2001 2002Requires that the 'postgres' db exists and is accessible. 2003 2004This is not a test. It die()s on failure. 2005 2006If the slot is not active, will time out after poll_query_until's timeout. 2007 2008target_lsn may be any arbitrary lsn, but is typically $master_node->lsn('insert'). 2009 2010Note that for logical slots, restart_lsn is held down by the oldest in-progress tx. 2011 2012=cut 2013 2014sub wait_for_slot_catchup 2015{ 2016 my ($self, $slot_name, $mode, $target_lsn) = @_; 2017 $mode = defined($mode) ? $mode : 'restart'; 2018 if (!($mode eq 'restart' || $mode eq 'confirmed_flush')) 2019 { 2020 croak "valid modes are restart, confirmed_flush"; 2021 } 2022 croak 'target lsn must be specified' unless defined($target_lsn); 2023 print "Waiting for replication slot " 2024 . $slot_name . "'s " 2025 . $mode 2026 . "_lsn to pass " 2027 . $target_lsn . " on " 2028 . $self->name . "\n"; 2029 my $query = 2030 qq[SELECT '$target_lsn' <= ${mode}_lsn FROM pg_catalog.pg_replication_slots WHERE slot_name = '$slot_name';]; 2031 $self->poll_query_until('postgres', $query) 2032 or croak "timed out waiting for catchup"; 2033 print "done\n"; 2034 return; 2035} 2036 2037=pod 2038 2039=item $node->query_hash($dbname, $query, @columns) 2040 2041Execute $query on $dbname, replacing any appearance of the string __COLUMNS__ 2042within the query with a comma-separated list of @columns. 2043 2044If __COLUMNS__ does not appear in the query, its result columns must EXACTLY 2045match the order and number (but not necessarily alias) of supplied @columns. 2046 2047The query must return zero or one rows. 2048 2049Return a hash-ref representation of the results of the query, with any empty 2050or null results as defined keys with an empty-string value. There is no way 2051to differentiate between null and empty-string result fields. 2052 2053If the query returns zero rows, return a hash with all columns empty. There 2054is no way to differentiate between zero rows returned and a row with only 2055null columns. 2056 2057=cut 2058 2059sub query_hash 2060{ 2061 my ($self, $dbname, $query, @columns) = @_; 2062 croak 'calls in array context for multi-row results not supported yet' 2063 if (wantarray); 2064 2065 # Replace __COLUMNS__ if found 2066 substr($query, index($query, '__COLUMNS__'), length('__COLUMNS__')) = 2067 join(', ', @columns) 2068 if index($query, '__COLUMNS__') >= 0; 2069 my $result = $self->safe_psql($dbname, $query); 2070 2071 # hash slice, see http://stackoverflow.com/a/16755894/398670 . 2072 # 2073 # Fills the hash with empty strings produced by x-operator element 2074 # duplication if result is an empty row 2075 # 2076 my %val; 2077 @val{@columns} = 2078 $result ne '' ? split(qr/\|/, $result, -1) : ('',) x scalar(@columns); 2079 return \%val; 2080} 2081 2082=pod 2083 2084=item $node->slot(slot_name) 2085 2086Return hash-ref of replication slot data for the named slot, or a hash-ref with 2087all values '' if not found. Does not differentiate between null and empty string 2088for fields, no field is ever undef. 2089 2090The restart_lsn and confirmed_flush_lsn fields are returned verbatim, and also 2091as a 2-list of [highword, lowword] integer. Since we rely on Perl 5.8.8 we can't 2092"use bigint", it's from 5.20, and we can't assume we have Math::Bigint from CPAN 2093either. 2094 2095=cut 2096 2097sub slot 2098{ 2099 my ($self, $slot_name) = @_; 2100 my @columns = ( 2101 'plugin', 'slot_type', 'datoid', 'database', 2102 'active', 'active_pid', 'xmin', 'catalog_xmin', 2103 'restart_lsn'); 2104 return $self->query_hash( 2105 'postgres', 2106 "SELECT __COLUMNS__ FROM pg_catalog.pg_replication_slots WHERE slot_name = '$slot_name'", 2107 @columns); 2108} 2109 2110=pod 2111 2112=item $node->pg_recvlogical_upto(self, dbname, slot_name, endpos, timeout_secs, ...) 2113 2114Invoke pg_recvlogical to read from slot_name on dbname until LSN endpos, which 2115corresponds to pg_recvlogical --endpos. Gives up after timeout (if nonzero). 2116 2117Disallows pg_recvlogical from internally retrying on error by passing --no-loop. 2118 2119Plugin options are passed as additional keyword arguments. 2120 2121If called in scalar context, returns stdout, and die()s on timeout or nonzero return. 2122 2123If called in array context, returns a tuple of (retval, stdout, stderr, timeout). 2124timeout is the IPC::Run::Timeout object whose is_expired method can be tested 2125to check for timeout. retval is undef on timeout. 2126 2127=cut 2128 2129sub pg_recvlogical_upto 2130{ 2131 my ($self, $dbname, $slot_name, $endpos, $timeout_secs, %plugin_options) 2132 = @_; 2133 my ($stdout, $stderr); 2134 2135 my $timeout_exception = 'pg_recvlogical timed out'; 2136 2137 croak 'slot name must be specified' unless defined($slot_name); 2138 croak 'endpos must be specified' unless defined($endpos); 2139 2140 my @cmd = ( 2141 'pg_recvlogical', '-S', $slot_name, '--dbname', 2142 $self->connstr($dbname)); 2143 push @cmd, '--endpos', $endpos; 2144 push @cmd, '-f', '-', '--no-loop', '--start'; 2145 2146 while (my ($k, $v) = each %plugin_options) 2147 { 2148 croak "= is not permitted to appear in replication option name" 2149 if ($k =~ qr/=/); 2150 push @cmd, "-o", "$k=$v"; 2151 } 2152 2153 my $timeout; 2154 $timeout = 2155 IPC::Run::timeout($timeout_secs, exception => $timeout_exception) 2156 if $timeout_secs; 2157 my $ret = 0; 2158 2159 do 2160 { 2161 local $@; 2162 eval { 2163 IPC::Run::run(\@cmd, ">", \$stdout, "2>", \$stderr, $timeout); 2164 $ret = $?; 2165 }; 2166 my $exc_save = $@; 2167 if ($exc_save) 2168 { 2169 2170 # IPC::Run::run threw an exception. re-throw unless it's a 2171 # timeout, which we'll handle by testing is_expired 2172 die $exc_save 2173 if (blessed($exc_save) || $exc_save !~ qr/$timeout_exception/); 2174 2175 $ret = undef; 2176 2177 die "Got timeout exception '$exc_save' but timer not expired?!" 2178 unless $timeout->is_expired; 2179 2180 die 2181 "$exc_save waiting for endpos $endpos with stdout '$stdout', stderr '$stderr'" 2182 unless wantarray; 2183 } 2184 }; 2185 2186 $stdout =~ s/\r\n/\n/g if $Config{osname} eq 'msys'; 2187 $stderr =~ s/\r\n/\n/g if $Config{osname} eq 'msys'; 2188 2189 if (wantarray) 2190 { 2191 return ($ret, $stdout, $stderr, $timeout); 2192 } 2193 else 2194 { 2195 die 2196 "pg_recvlogical exited with code '$ret', stdout '$stdout' and stderr '$stderr'" 2197 if $ret; 2198 return $stdout; 2199 } 2200} 2201 2202=pod 2203 2204=back 2205 2206=cut 2207 22081; 2209