view release on metacpan or  search on metacpan

lib/App/FuguVM/Config.pm  view on Meta::CPAN

		);
		return 0;
	}

	# Each path directive resolves against the project root, and the
	# file must be readable now. A path that fails at 'up' time, deep
	# inside an install, is a path that failed too late.
	for my $directive (qw(autoinstall base_disk root_password_file)) {
		next if !defined $vm->{$directive};
		my $path = $self->_resolve_path( $vm->{$directive} );
		if ( !-f $path || !-r $path ) {
			$self->{error} =
			    sprintf( "VM '%s': %s file is not readable: %s",
				$name, $directive, $path );
			return 0;
		}
		$vm->{$directive} = $path;
	}

	$vm->{install_mode} =
	      defined $vm->{autoinstall} ? 'autoinstall'
	    : defined $vm->{base_disk}   ? 'import'
	    :                              'expect';

	if ( $vm->{install_mode} eq 'import' && !$vm->{image_cache} ) {
		$self->{error} = sprintf(
			"VM '%s': base_disk needs the image cache;"
			    . " remove 'image_cache no'",
			$name
		);
		return 0;
	}

	# Outside the expect mode the tool does not know the root
	# password of the image, and it cannot install a key without
	# one.
	if (       $vm->{install_mode} ne 'expect'
		&& defined $vm->{ssh_pubkey}
		&& $vm->{ssh_pubkey} ne ''
		&& !defined $vm->{root_password_file} )
	{
		$self->{error} = sprintf(
			"VM '%s': ssh_pubkey needs root_password_file in the"
			    . " %s mode; add the directive, or unset"
			    . " ssh_pubkey and bake the key into the image",
			$name, $vm->{install_mode} );
		return 0;
	}

	return 1;
}

# $self->_resolve_path($value):
#	Expand a leading tilde, then make a relative path absolute
#	against the project root. The result is always absolute: the
#	project root itself can be relative, from a --project option,
#	and a daemonized child can read the path from an other working
#	directory.
sub _resolve_path ( $self, $value )
{
	my $path = Fugu::File->expand_tilde($value);
	$path = "$self->{project_root}/$path" if $path !~ m{^/};

	require File::Spec;
	return File::Spec->rel2abs($path);
}

# $self->error:
#	Return the reason of the last failed load_vm, or undef.
sub error ($self)
{
	return $self->{error};
}

# _valid_port($value):
#	Report if a port directive holds the word AUTO_PORT or a
#	decimal number from 1 to 65535.
sub _valid_port ($value)
{
	return 0 if !defined $value;
	return 1 if $value eq AUTO_PORT;

	# A leading zero is not decimal, and the string-keyed port sets
	# of the probe would not match it.
	return 0 if $value !~ /^[1-9][0-9]*$/;

	return $value <= 65535 ? 1 : 0;
}

# _valid_ipv4($value):
#	Report if a value is one IPv4 address in dotted-decimal form.
#	A host name is not: a name resolves once for QEMU and once for
#	the tool, and the two answers can differ.
sub _valid_ipv4 ($value)
{
	return 0 if !defined $value;

	my @parts = split /\./, $value, -1;
	return 0 if @parts != 4;

	for my $part (@parts) {

		# A leading zero reads as octal in inet_aton, so such a
		# component is not decimal.
		return 0 if $part !~ /^(?:0|[1-9][0-9]{0,2})$/;
		return 0 if $part > 255;
	}

	return 1;
}

sub cache_dir ($self)
{
	my $dir = $self->_setting('cache_dir') // '~/.cache/fuguvm';

	return Fugu::File->expand_tilde($dir);
}

# $self->image_cache:
#	Return whether 'fuguvm up' may use the installed-image cache.
#	The project configuration wins over the global one. The default
#	is on.
sub image_cache ($self)
{
	my $value = $self->_setting('image_cache');
	return 1 if !defined $value;

	return $self->_bool( $value, 1 );
}

# $self->verify:
#	Return whether the tool verifies each mirror download. The
#	project configuration wins over the global one. The default is
#	on.
sub verify ($self)
{
	my $value = $self->_setting('verify');
	return 1 if !defined $value;

	return $self->_bool( $value, 1 );
}

# $self->signify_dir:
#	Return the resolved directory of the signify public keys, or
#	undef without the directive. A leading tilde expands, and a
#	relative path resolves against the project root.
sub signify_dir ($self)
{
	my $dir = $self->_setting('signify_dir');
	return if !defined $dir;

	return $self->_resolve_path($dir);
}

# $self->distfile_cache:
#	Return the distfile cap in bytes. The default is 0, and 0
#	turns the distfile cache off. An unparsable value gives one
#	warning and the value 0: an unrecognized spelling must not
#	silently mean its opposite, and off is the closed state for a
#	cache.
sub distfile_cache ($self)
{
	my $value = $self->_setting('distfile_cache');
	return 0 if !defined $value;

	my $bytes = _parse_size($value);
	if ( !defined $bytes ) {
		Fugu::Log->default->warning(
			"distfile_cache '%s' is not a size; the cache is off",
			$value );
		return 0;
	}

	return $bytes;
}

# _parse_size($value):
#	Return the byte count of a size, or undef. The value is a bare
#	number of bytes, or a number with a K, M or G suffix. The
#	suffix is 1024-based, and the letter case does not matter.
sub _parse_size ($value)
{
	my ( $number, $suffix ) = $value =~ /\A([0-9]+)([KkMmGg]?)\z/;
	return if !defined $number;

	my %scale = ( '' => 1, k => 1024, m => 1024**2, g => 1024**3 );

	return $number * $scale{ lc $suffix };
}

# $self->_bool($value, $default):
#	Read a switch, and report a value that is neither yes nor no.
#	An unrecognized spelling must not silently mean its opposite,
#	so the operator hears about it.
sub _bool ( $self, $value, $default )
{
	my $parser = $self->{project};
	my $result = $parser->parse_bool( $value, $default );

	Fugu::Log->default->warning( '%s', $parser->error )
	    if defined $parser->error;

	return $result;
}