view release on metacpan or  search on metacpan

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

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;
		$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';
	}



	unless ($self->{errors}) {
		for (@results) { # sort needed here to define a/b order for already_specified_in_alias
			my ($optref, $is_alias) = $self->get_option_ref($_->{name});
			$optref||confess;
			warning('deprecated_option', option => $_->{name}, main => $self->{optaliasmap}->{$_->{name}})
				if $is_alias && $self->{deprecated_options}->{$_->{name}};

			error('already_specified_in_alias', ($optref->{original_option} lt $_->{name}) ?
				(a => $optref->{original_option}, b => $_->{name}) :
				(b => $optref->{original_option}, a => $_->{name})
			)
				if ((defined $optref->{value}) && !$optref->{list} && $optref->{source} eq 'option' );

			my $decoded;
			if ($optref->{binary}) {
				$decoded = $_->{value};
			} else {
				$decoded = $self->decode_option_value($_->{value});
				last unless defined $decoded;
			}

			if ($optref->{list}) {
				if (defined $optref->{value}) {
					push @{ $optref->{value} }, $decoded;
				} else {
					@{$optref}{qw/value source/} = ([ $decoded ], 'list');
				}
				push @{$self->{option_list} ||= []}, { name => $optref->{name}, value => $decoded };
			} else {
				# fill from options from command line
				@{$optref}{qw/value source original_option is_alias/} = ($decoded, 'option', $_->{name}, $is_alias);
			}
		}
	}
	my $command = undef;

	unless ($self->{errors}) {
		my $original_command = $command = shift @ARGV;
		if (defined($command)) {
			error("unknown_command", a => $original_command) unless
				$self->{commands}->{$command} ||
				(defined($command = $self->{aliasmap}->{$command}) && $self->{commands}->{$command});
			warning('deprecated_command', command => $original_command) if ($self->{deprecated_commands}->{$original_command});
		} else {
			error("no_command") unless defined $command;
		}
	}

	unless ($self->{errors}) {
		if (defined $cfg) {
			for (keys %$cfg) {
				my ($optref, $is_alias) = $self->get_option_ref($_);
				if ($optref) {
					if ($optref->{list}) {
						error('list_options_in_config', option => $_);
					} elsif (!defined $optref->{value}) {
						# fill from config
						my $decoded = $optref->{binary} ? $cfg->{$_} : $self->decode_config_value($cfg->{$_});
						last unless defined $decoded;
						@{$optref}{qw/value source/} = ($decoded, 'config'); # TODO: support for array options??
					}
				} else {
					error('unknown_config_option', option => $_);
				}
			}
		}
	}
	unless ($self->{errors}) {

		for (values %{$self->{options}}) {
			# fill from default values
			@{$_}{qw/value source/} = ($_->{default}, 'default') if (!defined($_->{value}) && defined($_->{default}));#$_->{seen} &&
		}

		$self->{preinitialize}->() if $self->{preinitialize};

		$self->{positional_tail} = \@ARGV; #[map { decode($self->{cmd_encoding}, $_, Encode::DIE_ON_ERR|Encode::LEAVE_SRC) } @ARGV];

		$self->{commands}->{$command}->{cb}->(); # the callback!

		for (qw/ConfigOption ConfigEncoding CmdEncoding/) {
			confess "Special option '$_' must be seen" if $self->{$_} && !$self->{options}{$self->{$_}}{seen};
		}

		for (values %{$self->{options}}) {
			error('unexpected_option', option => _real_option_name($_)) if defined($_->{value}) && ($_->{source} eq 'option') && !$_->{seen}; # TODO: test validation same way
		}

		unless ($self->{errors}) {
			if (@ARGV) {
				unless (defined eval {
					error('unexpected_argument', a => decode($self->{cmd_encoding}, shift @ARGV, Encode::DIE_ON_ERR|Encode::LEAVE_SRC)); 1;
				}) {
					error("options_encoding_error", encoding => $self->{cmd_encoding}); #TODO: not utf!
				}
			}
		}

		unless ($self->{errors}) {
			$self->unflatten_scope();
		}
	}

	$self->{error_texts} = [ $self->errors_or_warnings_to_messages($self->{errors}) ];
	$self->{warning_texts} = [ $self->errors_or_warnings_to_messages($self->{warnings}) ];

	return {
		errors => arrayref_or_undef $self->{errors},
		error_texts => arrayref_or_undef $self->{error_texts},
		warnings => arrayref_or_undef $self->{warnings},
		warning_texts => arrayref_or_undef $self->{warning_texts},
		command => $self->{errors} ? undef : $command,
		options => $self->{data},
		option_list => $self->{option_list},
	};
}

sub unflatten_scope
{
	my ($self) = @_;