view release on metacpan or  search on metacpan

lib/App/MtAws/ConfigEngine.pm  view on Meta::CPAN

{
	my ($message, $format, %opts) = @_;
	$format = $message unless defined $format;
	confess "message $message already defined" if defined $context->{messages}->{$message} and !$context->{messages}->{$message}->{allow_redefine};
	$context->{messages}->{$message} = { %opts, format => $format };
	$message;
}


sub new
{
	my ($class, %args) = @_;
	my $self = {
		%args
	};
	bless $self, $class;
	local $context = $self;
	# TODO: replace "%s option% with "%option%" - will this work?
	message 'list_options_in_config', '"List" options (where order is important) like "%s option%" cannot appear in config currently', allow_redefine => 1;
	message 'unexpected_option', 'Unexpected option %option option%', allow_redefine=>1;
	message 'unknown_config_option', 'Unknown option in config: "%s option%"', allow_redefine=>1;
	message 'unknown_command', 'Unknown command %command a%', allow_redefine=>1;
	message 'no_command', 'No command specified', allow_redefine=>1;
	message 'deprecated_option', 'Option %option% is deprecated, use %option main% instead', allow_redefine=>1;
	message 'deprecated_command', 'Command %command command% is deprecated', allow_redefine=>1;
	message 'already_specified_in_alias', 'Both options %option a% and %option b% are specified. However they are aliases', allow_redefine=>1;
	message 'getopts_error', 'Error parsing options', allow_redefine=>1;
	message 'options_encoding_error', 'Invalid %encoding% character in command line', allow_redefine => 1;
	message 'config_encoding_error', 'Invalid %encoding% character in config file', allow_redefine => 1;
	message 'mandatory', "Option %option a% is mandatory", allow_redefine => 1;
	message 'positional_mandatory', 'Positional argument #%d n% (%a%) is mandatory', allow_redefine => 1;
	message 'unexpected_argument', "Unexpected argument in command line: %a%", allow_redefine => 1;
	message 'option_deprecated_for_command', "Option %option a% deprecated for this command", allow_redefine => 1;
	message 'unknown_encoding', 'Unknown encoding "%s value%" in option %option a%', allow_redefine => 1;
	return $self;
}


sub error_to_message
{
	my ($spec, %data) = @_;
	my $rep = sub {
		my ($match) = @_;
		if (my ($format, $name) = $match =~ /^([\w]+)\s+([\w]+)$/) {
			if (lc $format eq lc 'option') {
				defined(my $value = $data{$name})||confess;
				qq{"--$value"};
			} elsif (lc $format eq lc 'command') {
				defined(my $value = $data{$name})||confess;
				qq{"$value"};
			} else {
				defined(my $value = $data{$name})||confess;
				sprintf("%$format", $value);
			}
		} else {
			defined(my $value = $data{$match})||confess $spec;
			$value;
		}
	};

	$spec =~ s{%([\w\s]+)%} {$rep->($1)}ge if %data; # in new perl versions \w also means unicode chars..
	$spec;
}


sub errors_or_warnings_to_messages
{
	my ($self, $err) = @_;
	return unless defined $err;
	map {
		if (ref($_) eq ref({})) {
			my $name = $_->{format} || confess "format not defined";
			confess qq{message $name not defined} unless $self->{messages}->{$name} and my $format = $self->{messages}->{$name}->{format};
			error_to_message($format, %$_);
		} else {
			$_;
		}
	} @{$err};
}

sub arrayref_or_undef($)
{
	my ($ref) = @_;
	defined($ref) && @$ref > 0 ? $ref : undef;
}


sub define($&)
{
	my ($self, $block) = @_;
	local $context = $self; # TODO: create wrapper like 'localize sub ..'
	$block->();
}

sub decode_option_value
{
	my ($self, $val) = @_;
	my $enc = $self->{cmd_encoding}||confess;
	my $decoded = eval {decode($enc, $val, Encode::DIE_ON_ERR|Encode::LEAVE_SRC)};
	error("options_encoding_error", encoding => $enc) unless defined $decoded;
	$decoded;
}

sub decode_config_value
{
	my ($self, $val) = @_;
	my $enc = $self->{cfg_encoding}||confess;
	my $decoded = eval {decode($enc, $val, Encode::DIE_ON_ERR|Encode::LEAVE_SRC)};
	error("config_encoding_error", encoding => $enc) unless defined $decoded;
	$decoded;
}

sub get_encoding
{
	my ($name, $config, $options) = @_;
	return undef unless defined $name;
	my $res = undef;

	if (defined $config && defined($config->{$name})) {
		my $new_enc_obj = find_encoding($config->{$name});
		error('unknown_encoding', encoding => $config->{$name}, a => $name), return unless $new_enc_obj;

lib/App/MtAws/ConfigEngine.pm  view on Meta::CPAN

{
	my @a = @_;
	grep { my $o = $_; first { $_ eq $o->{name} } @a; } @{$context->{option_list}};
}

sub raw_option($)
{
	my ($name) = @_;
	assert_option for $name;
	confess "option not present" unless defined($context->{options}->{$name}->{value});
	return $context->{options}->{$name};
};

sub custom($$)
{
	my ($name, $value) = @_;
	confess if ($context->{options}->{$name});
	$context->{options}->{$name} = {source => 'set', value => $value, name => $name, seen => 1 };
	return $name;
};


sub error($;%)
{
	my ($name, %data) = @_;
	push @{$context->{errors}},
		defined($context->{messages}->{$name}) ?
			{ format => $name, %data } :
			(%data ? confess("message '$name' is undefined") : $name);
	return;
};

sub warning($;%)
{
	my ($name, %data) = @_;
	push @{$context->{warnings}},
		defined($context->{messages}->{$name}) ?
			{ format => $name, %data } :
			(%data ? confess("message '$name' is undefined") : $name);
	return;
};

sub read_config
{
	my ($self, $filename) = @_;
	-f $filename or
		die exception 'config_file_is_not_a_file' => "Config file is not a file: %config%",
		config => hex_dump_string($filename);
	open (my $F, "<:crlf", $filename) or
		die exception 'cannot_read_config' => "Cannot read config file: %config%, errno=%errno%",
		config => hex_dump_string($filename), 'ERRNO';
	my %newconfig;
	local $_;
	my $lineno = 0;
	while (<$F>) {
		chomp;
		++$lineno;
		next if /^\s*$/;
		next if /^\s*\#/;
		my ($name, $value);
		 # we have there non-unicode data, so [ \t] can be replaced with \s. however i'll leave it for clarity
		if (($name, $value) = /^[ \t]*([A-Za-z0-9][A-Za-z0-9-]*)[ \t]*=[ \t]*(.*?)[ \t]*$/) {
			$newconfig{$name} = $value;
		} elsif (($name) = /^[ \t]*([A-Za-z0-9][A-Za-z0-9-]*)[ \t]*$/) {
			$newconfig{$name} = 1;
		} else {
			die exception 'invalid_config_line' => 'Cannot parse line in config file: %line% at %config% line %lineno%',
				lineno => $lineno, line => hex_dump_string($_), config => hex_dump_string($filename);
		}
	}
	close $F;
	return \%newconfig;
}

1;