view release on metacpan or  search on metacpan

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

{
	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;
		$res = $new_enc_obj;
	}

	my $new_encoding = first { $_->{name} eq $name } @$options;
	if (defined $new_encoding && defined $new_encoding->{value}) {
		my $new_enc_obj = find_encoding($new_encoding->{value});
		error('unknown_encoding', encoding => $new_encoding->{value}, a => $name), return unless $new_enc_obj;
		$res = $new_enc_obj;
	}

	$res
}

sub get_option_ref
{
	my ($self, $name) = @_;
	if ($self->{options}->{$name}) {
		return ($self->{options}->{$name}, 0);
	} elsif (defined($self->{optaliasmap}->{$name})) {
		return ($self->{options}->{ $self->{optaliasmap}->{$name} }, 1);
	} else {
		return (undef, undef);
	}
}

sub parse_options
{
	(my $self, local @ARGV) = @_; # we override @ARGV here, cause GetOptionsFromArray is not exported on perl 5.8.8


	return { command => 'help', map { $_ => undef } qw/errors error_texts warnings warning_texts options/}
		if (@ARGV && $ARGV[0] =~ /\b(help|h)\b/i);

	return { command => 'version', map { $_ => undef } qw/errors error_texts warnings warning_texts options/}
		if (@ARGV && $ARGV[0] =~ /^\-?\-?version$/i);

	local $context = $self;

	my @results;
	my @getopts = map {
		($_ => sub {
			my ($name, $value) = @_;
			my $sname = "$name";# can be object instead of name.. object interpolates to string well
			push @results, { name => $sname, value => $value };
		})
	} map {
		my $type = defined($_->{type}) ? $_->{type} : 's';
		$type =  "=$type" unless $type eq '';
		map { "$_$type" } $_->{name}, @{ $_->{alias} || [] }, @{ $_->{deprecated} || [] } # TODO: it's possible to implement aliasing using GetOpt itself
	} grep { !$_->{positional} } values %{$self->{options}};

	error('getopts_error') unless GetOptions(@getopts);

	my $cfg = undef;
	my $cfg_opt = undef;

	unless ($self->{errors}) {
		if (defined(my $cmd_enc = $self->{CmdEncoding})) {
			if (my $cmd_ref = $self->{options}->{$cmd_enc}) {
				confess "CmdEncoding option should be declared as binary" unless $cmd_ref->{binary};
			}
		}

		if (defined(my $cfg_enc = $self->{ConfigEncoding})) {
			if (my $cfg_ref = $self->{options}->{$cfg_enc}) {
				confess "ConfigEncoding option should be declared as binary" unless $cfg_ref->{binary};
			}
		}

		if (defined($self->{ConfigOption}) and $cfg_opt = $self->{options}->{$self->{ConfigOption}}) {
			confess "ConfigOption option should be declared as binary" unless $cfg_opt->{binary};
			my $cfg_value = first { $_->{name} eq $self->{ConfigOption} } @results;
			$cfg_value = $cfg_value->{value} if defined $cfg_value;
			$cfg_value = $cfg_opt->{default} unless defined $cfg_value;
			if (defined $cfg_value) { # we should also check that config is 'seen'. we can only check below (so it must be seen)
				$cfg = $self->read_config($cfg_value);
				confess unless defined $cfg;
			}
		}

		my $cmd_encoding = get_encoding($self->{CmdEncoding}, $cfg, \@results);
		my $cfg_encoding = get_encoding($self->{ConfigEncoding}, $cfg, \@results);
		$self->{cmd_encoding} = defined($cmd_encoding) ? $cmd_encoding : 'UTF-8';
		$self->{cfg_encoding} = defined($cfg_encoding) ? $cfg_encoding : 'UTF-8';
	}