view release on metacpan or  search on metacpan

t/author/bulk_test.pl  view on Meta::CPAN

			}
		} elsif ($result == -1) {
			warn "Background process $pid has already been reaped at " . localtime  . "\n";
			delete $background_pids->{$pid};
		} else {
			return 1;
		}
	}
	if (%{$background_pids}) {
		foreach my $server (@{$servers}) {
			if ((lc $server->{type}) eq 'virsh') {
				_virsh_shutdown($server);
				_sleep_until_shutdown($server);
			}
		}
	}
	return 0;
}

sub _test_description {
	my ($command, $arguments, $env) = @_;
	my $description = q['] . (join q[ ], $command, @{$arguments}) . q['];
	if ((ref $env) && (keys %{$env})) {
		$description .= q[ with ] . join q[ and ], map { "$_=$env->{$_}" } sort { $a cmp $b } keys %{$env};
	}
	return $description;
}

sub _multiple_attempts_execute {
	my ($command, $arguments, $env, $skip_on_fail) = @_;
	local %ENV = %ENV;
	my $count = 0;
	ATTEMPT: {
		foreach my $key (sort { $a cmp $b } keys %{$env}) {
			$ENV{$key} = $env->{$key};
		}
		$count += 1;
		my $start_execute_time = time;
		my $result = system { $command } $command, @{$arguments};
		my $total_execute_time = time - $start_execute_time;
		if ($result != 0) {
			if ($count < $max_attempts) {
				my $error_message = _error_message($command, $CHILD_ERROR);
				warn q[Failed ] . _test_description($command, $arguments, $env) . q[ at ] . localtime . " exited with a '$error_message' after $total_execute_time seconds.  Sleeping for $reset_time seconds";
				sleep $reset_time;
				redo ATTEMPT;
			} else {
				die q[Failed to ] . _test_description($command, $arguments, $env) . " $count times";
			}
		}
	}
	return 1;
}

sub _win32_path {
	my ($unix_path) = @_;
	my $windows_path = join q[\\], split /[\/]/smx, $unix_path;
	return $windows_path;
}

sub _check_parent_alive {
	if (!kill 0, $parent_pid) {
		die "Parent ($parent_pid) is no longer running.  Terminating\n";
	}
}

sub _sleep_until_shutdown {
	my ($server) = @_;
	while (_virsh_node_running($server)) {
		_virsh_shutdown($server);
		_log_stderr($server, "Waiting for $server->{name} to shutdown");
		sleep 1;
	}
	return;
}

sub _determine_address {
	my ($server) = @_;
	if (!$server->{address}) {
		my $address;
		while(!($address = _get_address($server))) {
			if (_virsh_node_running($server)) {
				_log_stderr($server, "Waiting for $server->{name} to get an IP address");
				sleep 1;
			} else {
				return;
			}
		}
		$server->{address} = $address;
	}
}

sub _sleep_until_tcp_available {
	my ($server) = @_;
	my $client_socket;
	while(!($client_socket = IO::Socket->new(
		Domain => IO::Socket::AF_INET(),
		Type => IO::Socket::SOCK_STREAM(),
		proto => 'tcp',
		PeerPort => $server->{port},
		PeerHost => $server->{address},
				   ))) {
		if (_virsh_node_running($server)) {
			_log_stderr($server, "Waiting for $server->{name} to start a TCP server on port $server->{port}");
			sleep 1;
		} else {
			_log_stderr($server, "Server $server->{name} has stopped running while waiting for TCP server to start on port $server->{port}");
			return;
		}
	}
	_log_stderr($server, ($server->{name} || $server->{address}) . " has started the TCP server on port $server->{port}");
	return $client_socket;
}

sub _virsh_node_running {
	my ($server) = @_;
	my $running = 0;
	foreach my $line (_contents($server, undef, 'sudo', 'virsh','list', '--name')) {
		if ($line =~ /^\s*$server->{name}\s*$/smx) {
			$running = 1;
		}

t/author/bulk_test.pl  view on Meta::CPAN

sub _remote_contents {
	my ($server, $parameters, $remote_command_line) = @_;
	my $initial_command;
	if ($parameters->{cygwin}) {
		$initial_command = $server->{cygwin_command};
	} else {
		$initial_command = $server->{initial_command};
	}
	return _contents($server, $parameters, 'ssh', _ssh_parameters($parameters), _server_address($server, $parameters), join q[ && ], grep { defined } $initial_command, $remote_command_line);
}

sub _ssh_parameters {
	my ($parameters) = @_;
	return (
            '-2',
            ($parameters->{force_pseudo_terminal} ? ('-t', '-t') : ()),
            '-o',    'BatchMode=yes',
            '-o',    'ServerAliveCountMax=5',
            '-o',    'ServerAliveInterval=3',
		);
}

sub _server_address {
	my ($server, $parameters) = @_;
	return ('-p', ($parameters->{cygwin} ? $server->{cygwin} : $server->{port}), $server->{user} . q[@] . $server->{address});
}

sub _list_remote_tmp_directory {
	my ($server) = @_;
	return _remote_contents($server, undef, 'dir /B');
}

sub _get_address {
	my ($server) = @_;
	my $address;
	foreach my $line (_contents($server, undef, 'sudo', 'virsh', 'domifaddr', $server->{name})) {
		if ($line =~ /^\s+\w+\s+[a-f0-9:]+\s+ipv4\s+([\d.]+)\/24\s*$/smx) {
			($address) = ($1);
		}
	}
	return $address;
}

sub _prefix {
	my ($server) = @_;
	return ($server->{name} || $server->{address}). ' --> ';
}

sub _log_stderr {
	my ($server, $message) = @_;
	print {*STDERR} _prefix($server) . "$message\n" or die "Failed to print to STDERR:$EXTENDED_OS_ERROR";
}

sub _log_stdout {
	my ($server, $message) = @_;
	print _prefix($server) . "$message\n" or die "Failed to print to STDOUT:$EXTENDED_OS_ERROR";
}

sub _contents {
	my ($server, $parameters, $command, @arguments) = @_;
	_check_parent_alive();
	my @lines;
	my $return_result;
	my $handle = FileHandle->new();
	if (my $pid = $handle->open(q[-|])) {
		my $alarm_method;
		my $alarm_killed;
		if ($parameters->{alarm_after}) {
			_log_stderr($server, "Alarm is $parameters->{alarm_after} seconds");
			alarm $parameters->{alarm_after};
			$alarm_method = sub {
						_log_stderr($server, "Killing local process $pid after $parameters->{alarm_after} seconds at " . localtime);
						while (kill 0, $pid) {
							kill 'TERM', $pid;
							sleep 1;
							waitpid $pid, POSIX::WNOHANG();
						}
						_log_stderr($server, "Killed local process $pid after $parameters->{alarm_after} seconds at " . localtime);
						$alarm_killed = 1;
					};
		}
		local $SIG{ALRM} = $alarm_method;
		COMMAND: while(my $line = <$handle>) {
			$line =~ s/\r?\n$//smx;
			$line =~ s/\e\[(K|\d+;1H|\??25[lh]|2J|[mHG]|23X|17X)//smxg;
			$line =~ s/\e\]0;//smxg;
			$line =~ s/\x7//smxg;
			_check_parent_alive();
			_log_stdout($server, $line);
			push @lines, $line;
			if ($alarm_killed) {
				last COMMAND;
			}
		}
		if (!$alarm_killed) {
			my $result = close $handle;
			if ($result == 1) {
				$return_result = 0;
			} else {
				if ($ERRNO == 0) {
					_log_stderr($server, "Command " . (join q[ ], $command, @arguments) . " failed to close successfully:" . _error_message($command, $CHILD_ERROR));
				} else {
					_log_stderr($server, "Command " . (join q[ ], $command, @arguments) . " failed to cleanup successfully:$!:");
				}
				$return_result = 1;
			}
		} else {
			_log_stderr($server, "Command " . (join q[ ], $command, @arguments) . " killed by TERM after alarm time of $parameters->{alarm_after} was exceeded:" . _error_message($command, $CHILD_ERROR));
			$return_result = 1;
		}
		alarm 0;
	} elsif (defined $pid) {
		eval {
			open STDERR, '<&=', fileno STDOUT or die "Failed to redirect STDERR:$EXTENDED_OS_ERROR";
			exec { $command } $command, @arguments or die "Failed to exec $command:$EXTENDED_OS_ERROR";
		} or do {
			_log_stderr($server, q[Caught an exception while running '] . (join q[ ], $command, @arguments) . "':$EVAL_ERROR");
		};
		exit 1;
	} else {
		die "Failed to fork:$EXTENDED_OS_ERROR";
	}
	if ($parameters->{return_result}) {
		return $return_result;
	} else {
		return @lines;
	}
}

sub _signal_name {
    my ( $number ) = @_;
    return $sig_names[$number];
}

sub _error_message {
	my ($binary, $child_error) = @_;
	my $message;
	if ((POSIX::WIFEXITED($child_error)) || (POSIX::WIFSIGNALED($child_error))) {
		if ( POSIX::WIFEXITED($child_error) ) {
			$message = $binary . ' exited with a ' . POSIX::WEXITSTATUS($child_error);
		} elsif (POSIX::WIFSIGNALED($child_error)) {
			my $name = _signal_name( POSIX::WTERMSIG($child_error) );
			if ( defined $name ) {
				$message = "$binary killed by a $name signal (" . POSIX::WTERMSIG($child_error) . q[)];
			} else {
				$message = "$binary killed by a signal (" . POSIX::WTERMSIG($child_error) . q[)];
			}
		}