view release on metacpan or  search on metacpan

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

# mt-aws-glacier - Amazon Glacier sync client
# Copyright (C) 2012-2014  Victor Efimov
# http://mt-aws.com (also http://vs-dev.com) vs@vs-dev.com
# License: GPLv3
#
# This file is part of "mt-aws-glacier"
#
#    mt-aws-glacier is free software: you can redistribute it and/or modify
#    it under the terms of the GNU General Public License as published by
#    the Free Software Foundation, either version 3 of the License, or
#    (at your option) any later version.
#
#    mt-aws-glacier is distributed in the hope that it will be useful,
#    but WITHOUT ANY WARRANTY; without even the implied warranty of
#    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#    GNU General Public License for more details.
#
#    You should have received a copy of the GNU General Public License
#    along with this program.  If not, see <http://www.gnu.org/licenses/>.

package App::MtAws::ConfigEngine;

our $VERSION = '1.120';

use Getopt::Long 2.24 qw/:config no_ignore_case/ ;
use Encode;
use Carp;
use List::Util qw/first/;
use strict;
use warnings;
use utf8;
use App::MtAws::Exceptions;
use App::MtAws::Utils;

use Exporter 'import';

our @EXPORT = qw/option options positional command validation message
	mandatory optional seen deprecated validate scope
	present valid value lists raw_option custom error warning impose explicit/;

our $context; # it's a not a global. always localized in code

# TODOS
#refactor messages %option a% vs %option option%
#options_encoding_error specify source of problem

sub message($;$%)
{
	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 {

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

sub seen
{
	my $o = @_ ? shift : $_;
	my $option = $context->{options}->{$o} or confess "undeclared option $o";
	unless ($option->{seen}) {
		$option->{seen} = 1;
		if ($option->{positional}) {
			my $v = shift @{$context->{positional_tail}};
			if (defined $v) {
				push @{$context->{positional_backlog}}, $o;
				unless (defined eval {
					@{$option}{qw/value source/} = (decode($context->{cmd_encoding}||'UTF-8', $v, Encode::DIE_ON_ERR|Encode::LEAVE_SRC), 'positional');
				}) {
					error("options_encoding_error", encoding => $context->{cmd_encoding}||'UTF-8'); # TODO: actually remove UTF and fix tests
				}
			}
		}
	}
	$o;
}

sub mandatory(@) {
	return map {
		my $opt = assert_option;
		unless ($opt->{seen}) {
			seen;
			confess "mandatory positional argument goes after optional one"
				if ($opt->{positional} and ($context->{positional_level} ||= 'mandatory') ne 'mandatory');
			unless (defined($opt->{value})) {
				$opt->{positional} ?
					error("positional_mandatory", a => $_, n => scalar @{$context->{positional_backlog}||[]}+1) :
					error("mandatory", a => _real_option_name($opt)); # actually does not have much sense
			}
		}
		$_;
	} @_;
};

sub optional(@)
{
	return map {
		seen;
		$context->{positional_level} = 'optional' if ($context->{options}->{$_}->{positional});
		$_;
	} @_;
};

sub deprecated(@)
{
	return map {
		assert_option;
		my $opt = $context->{options}->{ seen() };
		confess "positional options can't be deprecated" if $opt->{positional};
		if (defined $opt->{value}) {
			warning('option_deprecated_for_command', a => _real_option_name $opt) if $opt->{source} eq 'option';
			undef $opt->{value};
		}
		$_;
	} @_;
};
sub validate(@)
{
	return map {
		my $opt = $context->{options}->{seen()};
		if (defined($opt->{value}) && !$opt->{validated}) {
			$opt->{validated} = $opt->{valid} = 1;
			VALIDATION: for my $v (@{ $opt->{validations} }) {
				for ($opt->{value}) {
					error ({ format => $v->{message}, a => _real_option_name $opt, value => $_}),
					$opt->{valid} = 0,
					$v->{stop} && last VALIDATION
						unless $v->{cb}->();
				}
			}
		};
		$_;
	} @_;
};

sub scope($@)
{
	my $scopename = shift;
	return map {
		assert_option;
		unshift @{$context->{options}->{$_}->{scope}}, $scopename;
		$_;
	} @_;
};

sub present(@) # TODO: test that it works with arrays
{
	my $name = @_ ? shift : $_;
	assert_option for $name;
	return defined($context->{options}->{$name}->{value})
};

# TODO: test
sub explicit(@) # TODO: test that it works with arrays
{
	my $name = @_ ? shift : $_;
	return present($name) && $context->{options}->{$name}->{source} eq 'option'
};

sub valid($)
{
	my ($name) = @_;
	assert_option for $name;
	confess "validation not performed yet" unless $context->{options}->{$name}->{validated};
	return $context->{options}->{$name}->{valid};
};

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

sub impose(@)
{
	my ($name, $value) = @_;
	assert_option for $name;
	my $opt = $context->{options}->{$name};
	$opt->{source} = 'impose';
	$opt->{value} = $value;
	return $name;
};


sub lists(@)
{
	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}) ?