view release on metacpan or  search on metacpan

t/dbdpg_test_setup.pl  view on Meta::CPAN

	## Did we fail last time? Fail this time too, but quicker!
	if ($testdsn =~ /FAIL!/) {
		return $helpconnect, "Previous failure ($error)", undef;
	}

	## We may want to force an initdb call
	if (!$helpconnect and $ENV{DBDPG_TESTINITDB}) {
		goto INITDB;
	}

	## Got a working DSN? Give it an attempt
	if ($testdsn and $testuser) {

		## Used by t/01connect.t
		if ($arg->{dbreplace}) {
			$testdsn =~ s/$alias\s*=/$arg->{dbreplace}=/;
		}
		if ($arg->{dbquotes}) {
			$testdsn =~ s/$alias\s*=([\-\w]+)/'db="'.lc $2.'"'/e;
		}

		goto GOTDBH if eval {
			$dbh = DBI->connect($testdsn, $testuser, '',
								{RaiseError => 1, PrintError => 0, AutoCommit => 1});
			1;
		};

		if ($@ =~ /invalid connection option/) {
			return $helpconnect, $@, undef;
		}

		if ($arg->{nocreate}) {
			return $helpconnect, '', undef;
		}

		## If this was created by us, try and restart it
		if (16 == $helpconnect) {

			## Bypass if the testdir has been removed
			if (! -e $testdir) {
				$arg->{nocreate} and return $helpconnect, '', undef;
				warn "Test directory $testdir has been removed, will create a new one\n";
			}
			else {
				if (-e "$testdir/data/postmaster.pid") {
					## Assume it's up, and move on
				}
				else {

					if ($arg->{norestart}) {
						return $helpconnect, '', undef;
					}

					warn "Restarting test database $testdsn at $testdir\n";
					my $option = '';
					if ($^O !~ /Win32/) {
						my $sockdir = "$testdir/data/socket";
						if (! -e $sockdir) {
							mkdir $sockdir;
							if ($uid) {
								if (! chown $uid, -1, $sockdir) {
									warn "chown of $sockdir failed!\n";
								}
							}
						}
						$option = q{-o '-k socket'};
					}
					my $COM = qq{$pg_ctl $option -l $testdir/dbdpg_test.logfile -D $testdir/data start};
					if ($su) {
						$COM = qq{su -m $su -c "$COM"};
						chdir $testdir;
					}
					$info = '';
					eval { $info = qx{$COM}; };
					my $err = $@;
					$su and chdir $olddir;
					if ($err or $info !~ /\w/) {
						$err = "Could not startup new database ($err) ($info)";
						return $helpconnect, $err, undef;
					}
					## Wait for it to startup and verify the connection
					sleep 1;
				}
				my $loop = 1;
			  STARTUP: {
					eval {
						$dbh = DBI->connect($testdsn, $testuser, '',
											{RaiseError => 1, PrintError => 0, AutoCommit => 1});
					};
					if ($@ =~ /starting up/ or $@ =~ /PGSQL\.\d+/) {
						if ($loop++ < 20) {
							sleep 1;
							redo STARTUP;
						}
					}
				}

				if ($@) {
					return $helpconnect, $@, $dbh;
				}

				## We've got a good connection, so do final tweaks and return
				goto GOTDBH;

			} ## end testdir exists

		} ## end error and we created this database

	} ## end got testdsn and testuser

	## No previous info (or failed attempt), so try to connect and possible create our own cluster

	$testdsn ||= $ENV{DBI_DSN};
	$testuser ||= $ENV{DBI_USER};

	if (! $testdsn) {
		$helpconnect = 1;
		$testdsn = $^O =~ /Win32/ ? 'dbi:Pg:host=localhost' : 'dbi:Pg:';
	}
	if (! $testuser) {
		$testuser = 'postgres';
	}

t/dbdpg_test_setup.pl  view on Meta::CPAN

			}
			last GETHANDLE; ## Fail - initdb bad
		}

		## Make sure pg_ctl is available as well before we go further
		if (! -e $pg_ctl) {
			$pg_ctl = 'pg_ctl';
		}
		$info = '';
		eval {
			$info = qx{$pg_ctl --help 2>&1};
		};
		last GETHANDLE if $@; ## Fail - pg_ctl bad
		if (!defined $info or ($info !~ /\@postgresql\.org/ and $info !~ /run as root/)) {
			$@ = defined $initdb ? "Bad pg_ctl output: $info" : 'Bad pg_ctl output';
			last GETHANDLE; ## Fail - pg_ctl bad
		}

		## initdb and pg_ctl seems to be available, let's use them to fire up a cluster
		warn "Please wait, creating new database for testing\n";
		$info = '';
		eval {
			$info = qx{$initdb --locale=C -E UTF8 -D $testdir/data 2>&1};
		};
		last GETHANDLE if $@; ## Fail - initdb bad

		## initdb and pg_ctl cannot be run as root, so let's handle that
		if ($info =~ /run as root/ or $info =~ /unprivilegierte/) {

			my $founduser = 0;
			$su = $testuser = '';

			## Figure out a valid directory - returns empty if nothing available
			$testdir = find_tempdir();
			if (!$testdir) {
				return $helpconnect, 'Unable to create a temp directory', undef;
			}

			my $readme = "$testdir/README";
			if (open $fh, '>', $readme) {
				print $fh "This is a test directory for DBD::Pg and may be removed\n";
				print $fh "You may want to ensure the postmaster has been stopped first.\n";
				print $fh "Check the data/postmaster.pid file\n";
				close $fh or die qq{Could not close "$readme": $!\n};
			}

			## Likely candidates for running this
			my @userlist = (qw/postgres postgresql pgsql _postgres/);

			## Start with whoever owns this file, unless it's us
			my $username = getpwuid ((stat($0))[4]);
			unshift @userlist, $username if defined $username and $username ne getpwent;

			my %doneuser;
			for (@userlist) {
				$testuser = $_;
				next if $doneuser{$testuser}++;
				$uid = (getpwnam $testuser)[2];
				next if !defined $uid;

				next unless chown $uid, -1, $testdir;
				next unless chown $uid, -1, $readme;
				$su = $testuser;
				$founduser++;
				$info = '';
				$olddir = getcwd;
				eval {
					chdir $testdir;
					$info = qx{su -m $testuser -c "$initdb --locale=C -E UTF8 -D $testdir/data 2>&1"};
				};
				my $err = $@;
				chdir $olddir;
				last if !$err;
			}
			if (!$founduser) {
				$@ = 'Unable to find a user to run initdb as';
				last GETHANDLE; ## Fail - no user
			}
			if (! -e "$testdir/data") {
				$@ = 'Could not create a test database via initdb';
				last GETHANDLE; ## Fail - no datadir created
			}
			## At this point, both $su and $testuser are set
		}

		if ($info =~ /FATAL/) {
			$@ = "initdb gave a FATAL error: $info";
			last GETHANDLE; ## Fail - FATAL
		}

		if ($info =~ /but is not empty/) {
			## Assume this is already good to go
		}
		elsif ($info !~ /pg_ctl/) {
			$@ = "initdb did not give a pg_ctl string: $info";
			last GETHANDLE; ## Fail - bad output
		}

		## Which user do we connect as?
		if (!$su and $info =~ /owned by user "(.+?)"/) {
			$testuser = $1;
		}

		## Now we need to find an open port to use
		$testport = 5442;
		## If we've got netstat available, we'll trust that
		$info = '';
		eval {
			$info = qx{netstat -na 2>&1};
		};
		if ($@) {
			warn "netstat call failed, trying port $testport\n";
		}
		else {
			## Start at 5440 and go up until we are free
			$testport = 5440;
			my $maxport = 5470;
			{
				last if $info !~ /PGSQL\.$testport$/m
					and $info !~ /\b127\.0\.0\.1:$testport\b/m;
				last if ++$testport >= $maxport;
				redo;
			}
			if ($testport >= $maxport) {
				$@ = "No free ports found for testing: tried 5440 to $maxport\n";
				last GETHANDLE; ## Fail - no free ports
			}
		}
		$@ = '';
		## Change to this new port and fire it up
		my $conf = "$testdir/data/postgresql.conf";
		my $cfh;
		if (! open $cfh, '>>', $conf) {
			$@ = qq{Could not open "$conf": $!};
			last GETHANDLE; ## Fail - no conf file
		}
		print $cfh "\n\n## DBD::Pg testing parameters\n";
		print $cfh "port=$testport\n";
		print $cfh "max_connections=4\n";
		print $cfh "log_statement = 'all'\n";
		print $cfh "log_line_prefix = '%m [%p] '\n";
		print $cfh "log_min_messages = 'DEBUG1'\n";
		print $cfh "listen_addresses='127.0.0.1'\n" if $^O =~ /Win32/;
		print $cfh "\n";
		close $cfh or die qq{Could not close "$conf": $!\n};

		## Attempt to start up the test server
		if (-e "$testdir/data/postmaster.pid") {
			## Assume it's up, and move on
		}
		else {
			$info = '';
			my $option = '';
			if ($^O !~ /Win32/) {
				my $sockdir = "$testdir/data/socket";
				if (! -e $sockdir) {
					mkdir $sockdir;
					if ($su) {
						if (! chown $uid, -1, $sockdir) {
							warn "chown of $sockdir failed!\n";
						}
					}
				}
				$option = q{-o '-k socket'};
			}
			my $COM = qq{$pg_ctl $option -l $testdir/dbdpg_test.logfile -D $testdir/data start};
		    $olddir = getcwd;
			if ($su) {
				chdir $testdir;
				$COM = qq{su -m $su -c "$COM"};
			}
			eval {
				$info = qx{$COM};
			};
			my $err = $@;
			$su and chdir $olddir;
			if ($err or $info !~ /\w/) {
				$@ = "Could not startup new database ($COM) ($err) ($info)";
				last GETHANDLE; ## Fail - startup failed
			}
			sleep 1;
		}

		## Attempt to connect to this server
		$testdsn = "dbi:Pg:dbname=postgres;port=$testport";
		if ($^O =~ /Win32/) {
			$testdsn .= ';host=localhost';
		}
		else {
			$testdsn .= ";host=$testdir/data/socket";
		}
		my $loop = 1;
	  STARTUP: {
			eval {
				$dbh = DBI->connect($testdsn, $testuser, '',
									{RaiseError => 1, PrintError => 0, AutoCommit => 1});
			};
			## Regardless of the error, try again.
			## We used to check the message, but LANG problems may complicate that.
			if ($@) {
				if ($loop++ < 5) {
					sleep 1;
					redo STARTUP;
				}
			}
			last GETHANDLE; ## Made it!
		}

	} ## end of GETHANDLE

	## At this point, we've got a connection, or have failed
	## Either way, we record for future runs

	my $connerror = $@;
	if (open $fh, '>', $helpfile) {
		print $fh "## This is a temporary file created for testing DBD::Pg\n";
		print $fh '## Created: ' . scalar localtime() . "\n";
		print $fh "## Feel free to remove it!\n";
		print $fh "## Helpconnect: $helpconnect\n";
		print $fh "## pg_ctl: $pg_ctl\n";