view release on metacpan or  search on metacpan

CSS.pm  view on Meta::CPAN

package Mo::utils::CSS;

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

use Error::Pure qw(err);
use Graphics::ColorNames::CSS;
use List::Util 1.33 qw(any none);
use Mo::utils::Array qw(check_array);
use Mo::utils::Number::Utils qw(sub_check_percent);
use Readonly;

Readonly::Array our @EXPORT_OK => qw(check_array_css_color check_css_border
	check_css_class check_css_color check_css_unit);
Readonly::Array our @ABSOLUTE_LENGTHS => qw(cm mm in px pt pc);
Readonly::Array our @BORDER_GLOBAL => qw(inherit initial revert revert-layer unset);
Readonly::Array our @BORDER_STYLES => qw(none hidden dotted dashed solid double groove ridge inset outset);
Readonly::Array our @BORDER_WIDTHS => qw(thin medium thick);
Readonly::Array our @RELATIVE_LENGTHS => qw(em ex ch rem vw vh vmin vmax %);
Readonly::Array our @COLOR_FUNC => qw(rgb rgba hsl hsla);

our $VERSION = 0.13;

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

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

	check_array($self, $key);

	foreach my $css_color (@{$self->{$key}}) {
		_check_color($css_color, $key);
	}

	return;
}

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

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

	# Global values.
	if (any { $self->{$key} eq $_ } @BORDER_GLOBAL) {
		return;
	}

	my @parts = split m/\s+/ms, $self->{$key}, 3;
	if (@parts == 1) {
		_check_border_style($self->{$key}, $key);
	} elsif (@parts == 2) {

		# Border style on first place.
		if (any { $parts[0] eq $_ } @BORDER_STYLES) {
			_check_color($parts[1], $key, $self->{$key});

		# Border style on second place.
		} elsif (any { $parts[1] eq $_ } @BORDER_STYLES) {
			if (none { $parts[0] eq $_ } @BORDER_WIDTHS) {
				_check_unit($parts[0], $key, $self->{$key});
			}

		} else {
			err "Parameter '$key' hasn't border style.",
				'Value', $self->{$key},
			;
		}
	} else {
		if (none { $parts[0] eq $_ } @BORDER_WIDTHS) {
			_check_unit($parts[0], $key, $self->{$key});
		}
		_check_border_style($parts[1], $key, $self->{$key});
		_check_color($parts[2], $key, $self->{$key});
	}

	return;
}

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

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

	if ($self->{$key} !~ m/^[a-zA-Z0-9\-_]+$/ms) {
		err "Parameter '$key' has bad CSS class name.",
			'Value', $self->{$key},
		;
	} elsif ($self->{$key} =~ m/^\d/ms) {
		err "Parameter '$key' has bad CSS class name (number on begin).",
			'Value', $self->{$key},
		;
	}

	return;
}

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

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

	_check_color($self->{$key}, $key);

	return;
}

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

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

	_check_unit($self->{$key}, $key);

	return;
}

sub _check_alpha {
	my ($alpha, $key, $func, $error_value) = @_;

	if ($alpha !~ m/^[\d\.]+$/ms || $alpha > 1) {
		err "Parameter '$key' has bad $func alpha.",
			'Value', $error_value,
		;
	}

	return;
}

sub _check_border_style {
	my ($value, $key, $error_value) = @_;

	if (! defined $error_value) {
		$error_value = $value;
	}

	if (none { $value eq $_ } @BORDER_STYLES) {
		err "Parameter '$key' has bad border style.",
			'Value', $error_value,
		;
	}

	return;
}

sub _check_color {
	my ($value, $key, $error_value) = @_;

	if (! defined $error_value) {
		$error_value = $value;
	}

	my $funcs = join '|', @COLOR_FUNC;
	if ($value =~ m/^#(.*)$/ms) {
		my $rgb = $1;
		if (length $rgb == 3 || length $rgb == 6 || length $rgb == 8) {
			if ($rgb !~ m/^[0-9A-Fa-f]+$/ms) {
				err "Parameter '$key' has bad rgb color (bad hex number).",
					'Value', $error_value,
				;
			}
		} else {
			err "Parameter '$key' has bad rgb color (bad length).",
				'Value', $error_value,
			;
		}
	} elsif ($value =~ m/^($funcs)\((.*)\)$/ms) {
		my $func = $1;
		my $args_string = $2;
		my @args = split m/\s*,\s*/ms, $args_string;
		if ($func eq 'rgb') {
			if (@args != 3) {
				err "Parameter '$key' has bad rgb color (bad number of arguments).",
					'Value', $error_value,
				;
			}
			_check_colors([@args[0 .. 2]], $key, $func, $error_value);
		} elsif ($func eq 'rgba') {
			if (@args != 4) {
				err "Parameter '$key' has bad rgba color (bad number of arguments).",
					'Value', $error_value,
				;
			}
			_check_colors([@args[0 .. 2]], $key, $func, $error_value);
			_check_alpha($args[3], $key, $func, $error_value);
		} elsif ($func eq 'hsl') {
			if (@args != 3) {
				err "Parameter '$key' has bad hsl color (bad number of arguments).",
					'Value', $error_value,
				;
			}
			_check_degree($args[0], $key, $func, $error_value);
			_check_percent([@args[1 .. 2]], $key, $func.' percent', $error_value);
		# hsla
		} else {
			if (@args != 4) {
				err "Parameter '$key' has bad hsla color (bad number of arguments).",
					'Value', $error_value,
				;
			}
			_check_degree($args[0], $key, $func, $error_value);
			_check_percent([@args[1 .. 2]], $key, $func.' percent', $error_value);
			_check_alpha($args[3], $key, $func, $error_value);
		}
	} else {
		if (none { $value eq $_ } keys %{Graphics::ColorNames::CSS->NamesRgbTable}) {
			err "Parameter '$key' has bad color name.",
				'Value', $error_value,
			;
		}
	}

	return;
}

sub _check_colors {
	my ($value_ar, $key, $func, $error_value) = @_;

	foreach my $i (@{$value_ar}) {
		if ($i !~ m/^\d+$/ms || $i > 255) {
			err "Parameter '$key' has bad $func color (bad number).",
				'Value', $error_value,
			;
		}
	}

	return;
}

sub _check_degree {