File Coverage

blib/lib/Mo/utils.pm

Criterion	Covered	Total	%
statement	152	152	100.0
branch	84	84	100.0
condition	18	18	100.0
subroutine	29	29	100.0
pod	19	19	100.0
total	302	302	100.0

package Mo::utils;

use base qw(Exporter);
use strict;
use warnings;

use Error::Pure qw(err);
use List::Util qw(none);
use Readonly;
use Scalar::Util qw(blessed looks_like_number);

Readonly::Array our @EXPORT_OK => qw(check_angle check_array check_array_object
	check_array_required check_bool check_code check_isa check_length
	check_length_fix check_number check_number_id check_number_min
	check_number_of_items check_number_range check_regexp check_required
	check_string check_string_begin check_strings);

our $VERSION = 0.32;

sub check_angle {
	my ($self, $key) = @_;

	check_number_range($self, $key, 0, 360);

	return;
}

sub check_array {
	my ($self, $key) = @_;

	if (! exists $self->{$key}) {
		return;
	}

	if (ref $self->{$key} ne 'ARRAY') {
		my $ref = ref $self->{$key};
		err "Parameter '".$key."' must be a array.",
			'Value', $self->{$key},
			'Reference', ($ref eq '' ? 'SCALAR' : $ref),
		;
	}

	return;
}

sub check_array_object {
	my ($self, $key, $class, $class_name) = @_;

	if (! exists $self->{$key}) {
		return;
	}

	check_array($self, $key);

	foreach my $obj (@{$self->{$key}}) {
		_check_object($obj, $class,
			'%s isn\'t \'%s\' object.',
			[$class_name, $class],
		);
	}

	return;
}

sub check_array_required {
	my ($self, $key) = @_;

	if (! exists $self->{$key}) {
		err "Parameter '$key' is required.";
	}

	check_array($self, $key);

	if (! @{$self->{$key}}) {
		err "Parameter '".$key."' with array must have at least one item.";
	}

	return;
}

sub check_bool {
	my ($self, $key) = @_;

	_check_key($self, $key) && return;

	if ($self->{$key} !~ m/^\d+$/ms || ($self->{$key} != 0 && $self->{$key} != 1)) {
		err "Parameter '$key' must be a bool (0/1).",
			'Value', $self->{$key},
		;
	}

	return;
}

sub check_code {
	my ($self, $key) = @_;

	_check_key($self, $key) && return;

	if (ref $self->{$key} ne 'CODE') {
		err "Parameter '$key' must be a code.",
			'Value', $self->{$key},
		;
	}

	return;
}

sub check_isa {
	my ($self, $key, $class) = @_;

	_check_key($self, $key) && return;
	_check_object($self->{$key}, $class,
		'Parameter \'%s\' must be a \'%s\' object.',
		[$key, $class],
	);

	return;
}

sub check_length {
	my ($self, $key, $max_length) = @_;

	_check_key($self, $key) && return;

	if (length $self->{$key} > $max_length) {
		err "Parameter '$key' has length greater than '$max_length'.",
			'Value', $self->{$key},
		;
	}

	return;
}

sub check_length_fix {
	my ($self, $key, $length) = @_;

	_check_key($self, $key) && return;

	if (length $self->{$key} != $length) {
		err "Parameter '$key' has length different than '$length'.",
			'Value', $self->{$key},
		;
	}

	return;
}

sub check_number {
	my ($self, $key) = @_;

	_check_key($self, $key) && return;

	if (! looks_like_number($self->{$key})) {
		err "Parameter '$key' must be a number.",
			'Value', $self->{$key},
		;
	}

	return;
}

sub check_number_id {
	my ($self, $key) = @_;

	_check_key($self, $key) && return;

	if ($self->{$key} !~ m/^\d+$/ms || $self->{$key} == 0) {
		err "Parameter '$key' must be a natural number.",
			'Value', $self->{$key},
		;
	}

	return;
}

sub check_number_min {
	my ($self, $key, $min) = @_;

	_check_key($self, $key) && return;

	check_number($self, $key);

	if ($self->{$key} < $min) {
		err "Parameter '".$key."' must be greater than $min.",
			'Value', $self->{$key},
		;
	}

	return;
}

sub check_number_of_items {
	my ($self, $list_method, $item_method, $object_name, $item_name) = @_;

	my $item_hr = {};
	foreach my $item (@{$self->$list_method}) {
		$item_hr->{$item->$item_method} += 1;
	}

	foreach my $item (keys %{$item_hr}) {
		if ($item_hr->{$item} > 1) {
			err "$object_name for $item_name '$item' has multiple values."
		}
	}

	return;
}

sub check_number_range {
	my ($self, $key, $min, $max) = @_;

	_check_key($self, $key) && return;

	check_number($self, $key);

	if ($self->{$key} < $min || $self->{$key} > $max) {
		err "Parameter '".$key."' must be a number between $min and $max.",
			'Value', $self->{$key},
		;
	}

	return;
}

sub check_regexp {
	my ($self, $key, $regexp) = @_;

	_check_key($self, $key) && return;

	if (! defined $regexp) {
		err "Parameter '$key' must have defined regexp.";
	}
	if ($self->{$key} !~ m/^$regexp/ms) {
		err "Parameter '$key' does not match the specified regular expression.",
			'String', $self->{$key},
			'Regexp', $regexp,
		;
	}

	return;
}

sub check_required {
	my ($self, $key) = @_;

	if (! exists $self->{$key} || ! defined $self->{$key}) {
		err "Parameter '$key' is required.";
	}

	return;
}

sub check_string {
	my ($self, $key, $string) = @_;

	_check_key($self, $key) && return;

	if ($self->{$key} ne $string) {
		err "Parameter '$key' must have expected value.",
			'Value', $self->{$key},
			'Expected value', $string,
		;
	}

	return;
}

sub check_string_begin {
	my ($self, $key, $string_base) = @_;

	_check_key($self, $key) && return;

	if (! defined $string_base) {
		err "Parameter '$key' must have defined string base.";
	}
	if ($self->{$key} !~ m/^$string_base/) {
		err "Parameter '$key' must begin with defined string base.",
			'String', $self->{$key},
			'String base', $string_base,
		;
	}

	return;
}

sub check_strings {
	my ($self, $key, $strings_ar) = @_;

	_check_key($self, $key) && return;

	if (! defined $strings_ar) {
		err "Parameter '$key' must have strings definition.";
	}
	if (ref $strings_ar ne 'ARRAY') {
		err "Parameter '$key' must have right string definition.";
	}
	if (none { $self->{$key} eq $_ } @{$strings_ar}) {
		err "Parameter '$key' must be one of defined strings.",
			'String', $self->{$key},
			'Possible strings', "'".(join "', '", @{$strings_ar})."'",
		;
	}

	return;
}

sub _check_key {
	my ($self, $key) = @_;

	if (! exists $self->{$key} || ! defined $self->{$key}) {
		return 1;
	}

	return 0;
}

sub _check_object {
	my ($value, $class, $message, $message_params_ar) = @_;

	if (! blessed($value)) {
		my $err_message = sprintf $message, @{$message_params_ar};
		err $err_message,

			# Only, if value is scalar.
			(ref $value eq '') ? (
				'Value', $value,
			) : (),

			# Only if value is reference.
			(ref $value ne '') ? (
				'Reference', (ref $value),
			) : (),
	}

	if (! $value->isa($class)) {
		my $err_message = sprintf $message, @{$message_params_ar};
		err $err_message,
			'Reference', (ref $value),
		;
	}

	return;
}

1;

__END__