File Coverage

blib/lib/Colouring/In.pm

Criterion	Covered	Total	%
statement	173	197	87.8
branch	94	102	92.1
condition	41	61	67.2
subroutine	29	35	82.8
pod	26	26	100.0
total	363	421	86.2

package Colouring::In;

use 5.006;
use strict;
use warnings;
use smallnum;
our $VERSION = '0.27';

our (%TOOL, $ANOBJECT);

use overload
	'""' => sub { $_[0]->toCSS() };


BEGIN {
	%TOOL = (
		clamp => sub { return $TOOL{min}( $TOOL{max}( $_[0], 0 ), $_[1]); },
		max => sub { $_[ ($_[0] || 0) < ($_[1] || 0) ] || 0 },
		min => sub { $_[ ($_[0] || 0) > ($_[1] || 0) ] || 0 },
		round => sub {
			return sprintf '%.' . ( defined $_[1] ? $_[1] : 0 ) . 'f', $_[0];
		},
		numIs => sub { return defined $_[0] && $_[0] =~ /^[0-9]+/; },
		percent => sub { return ( $_[0] * 100 ) . '%'; },
		depercent => sub { my $p = shift; $p =~ s/%$//; return $p / 100; },
		joinRgb => sub {
			return join ',', map { $TOOL{clamp}( $TOOL{round}($_), 255 ); } @_;
		},
		rgb2hs => sub {
			my @rgb = map { $_ / 255 } @_;
			push @rgb, $TOOL{max}( $TOOL{max}( $rgb[0], $rgb[1] ), $rgb[2] );
			push @rgb, $TOOL{min}( $TOOL{min}( $rgb[0], $rgb[1] ), $rgb[2] );
			push @rgb, ( $rgb[3] - $rgb[4] );
			return @rgb;
		},
		hue => sub {
			my ( $h, $m1, $m2 ) = @_;
			$h = $h < 0 ? $h + 1 : ( $h > 1 ? $h - 1 : $h );
			if ( $h * 6 < 1 ) { return $m1 + ( $m2 - $m1 ) * $h * 6; }
			elsif ( $h * 2 < 1 ) { return $m2; }
			elsif ( $h * 3 < 2 ) {
				return $m1 + ( $m2 - $m1 ) * ( 2 / 3 - $h ) * 6;
			}
			return $m1;
		},
		scaled => sub {
			my ( $n, $size ) = @_;
			return ( $n =~ s/%// )
				? sprintf( '%.f', (($n * $size) / 100 ))
				: return sprintf( "%d", $n );
		},
		convertColour => sub {
			my $colour	 = shift;
			my %converter = (
				'#'	=> 'hex2rgb',
				'rgb' => 'rgb2rgb',
				'hsl' => 'hsl2rgb',
				'hsla' => 'hsl2rgb',
			);
			my $reg = join '|', reverse sort keys %converter;
			if ( $colour =~ s/^($reg)// ) {
				return $TOOL{ $converter{$1} }($colour);
			}
			die $TOOL{MESSAGES}{INVALID_COLOUR} || 'Cannot convert the colour format';
		},
		rgb2rgb => sub {
			my @numbers = $TOOL{numbers}(shift);
			die $TOOL{MESSAGES}{INVALID_RGB} || 'Cannot convert rgb colour format' unless (scalar @numbers > 2);
			return @numbers;
		},
		hex2rgb => sub {
			my $hex = shift;
			my $l = length $hex;
			return $l != 6
				? $l == 3
					? map { my $h = hex( $_ . $_ ); $_ =~ 0 || $h ? $h : die( $TOOL{MESSAGES}{INVALID_HEX} || 'Cannot convert hex colour format' ) } $hex =~ m/./g
					: die 'hex length must be 3 or 6'
				: map { my $h = hex( $_ ); $_ =~ m/00/ || $h ? $h : die( $TOOL{MESSAGES}{INVALID_HEX} || 'Cannot convert hex colour format' ) } $hex =~ m/../g;
		},
		hsl2rgb => sub {
			my ( $h, $s, $l, $a, $m1, $m2 ) = scalar @_ > 1 ? @_ : $TOOL{numbers}(shift);
			defined $_ && $_ =~ m/([0-9.]+)/ or die $TOOL{MESSAGES}{INVALID_HSL} || 'Cannot convert hsl colour format' for ($h, $s, $l);
			$h = ( $h % 360 ) / 360;
			unless ($m1) {
				$s = $TOOL{depercent}($s);
				$l = $TOOL{depercent}($l);
			}
			$m2 = $l <= 0.5 ? $l * ( $s + 1 ) : $l + $s - $l * $s;
			$m1 = $l * 2 - $m2;
			return (
				($TOOL{clamp}($TOOL{hue}( $h + 1 / 3, $m1, $m2 ), 1) * 255),
				($TOOL{clamp}($TOOL{hue}( $h,			$m1, $m2 ), 1) * 255),
				($TOOL{clamp}($TOOL{hue}( $h - 1 / 3, $m1, $m2 ), 1) * 255),
				( defined $a ? $a : () ),
			);
		},
		numbers => sub {
			return ( $_[0] =~ m/([0-9.]+)/g );
		},
		hsl => sub {
			my $colour = shift;
			if ( ref \$colour eq 'SCALAR' ) {
				$colour = Colouring::In->new($colour);
			}
			my $hsl = $TOOL{asHSL}($colour);
			return ( $hsl, $colour );
		},
		hash2array => sub {
			my $hash = shift;
			return map { $hash->{$_} } @_;
		},
		asHSL => sub {
			my ( $r, $g, $b, $max, $min, $d, $h, $s, $l ) = $TOOL{rgb2hs}( $_[0]->colour );

			$l = ( $max + $min ) / 2;
			if ( $max == $min ) {
				$h = $s = 0;
			}
			else {
				$d = smallnum::_smallnum($d); #grrr
				$s = $l > 0.5 ? ($d / ( 2 - $max - $min )) : ($d / ( $max + $min ));
				$h = ( $max == $r )
					? ( $g - $b ) / $d + ( $g < $b ? 6 : 0 )
					: ( $max == $g )
							? ( $b - $r ) / $d + +2
							: ( $r - $g ) / $d + 4;
				$h /= 6;
			}

			return {
				h => $h * 360,
				s => $s,
				l => $l,
				a => $_[0]->{alpha},
			};
		}
	);
}

sub import {
	my ($pkg, @exports) = @_;
	my $caller = caller;
	$TOOL{MESSAGES} = pop @exports if (ref $exports[-1] eq 'HASH');
	if (scalar @exports) {
		no strict 'refs';
		*{"${caller}::${_}"} = \&{"${_[0]}::${_}"} foreach @exports;
	}
}

sub rgb {
	return $_[0]->rgba( $_[1], $_[2], $_[3], $_[4] );
}

sub rgba {
	my $rgb = [ map { $TOOL{scaled}( $_, 255 ) } ( $_[1], $_[2], $_[3] ) ];
	return Colouring::In->new( $rgb, $TOOL{clamp}($_[4], 1) );
}

sub hsl {
	my $self = shift;
	return $self->rgba($TOOL{hsl2rgb}(@_, 1));
}

sub hsla {
	my $self = shift;
	return $self->rgba($TOOL{hsl2rgb}(@_, 1));
}

sub new {
	my ( $pkg, $rgb, $a ) = @_;

	my $self = bless {}, $pkg;
	# The end goal here, is to parse the arguments
	# into an integer triplet, such as `128, 255, 0`
	if ( ref $rgb eq 'ARRAY' ) {
		scalar @$rgb == 4 and $a = pop @$rgb;
		$self->{colour} = $rgb;
	} else {
		$self->{colour} = [ $TOOL{convertColour}($rgb) ];
		scalar @{ $self->{colour} } == 4 and $a = pop @{$self->{colour}};
	}
	$self->{alpha} = $TOOL{numIs}($a) ? $a : 1;
	return $self;
}

sub toCSS {
	my $alpha = $TOOL{round}( $_[0]->{alpha}, $_[1] );
	return ( $alpha != 1 ) ? $_[0]->toRGBA() : $_[0]->toHEX( $_[2] );
}

sub toTerm {
	return sprintf( "r%sg%sb%s", $_[0]->colour );
}

sub toOnTerm {
	return sprintf( "on_r%sg%sb%s", $_[0]->colour );
}

sub toRGB {
	return $_[0]->toRGBA( $_[1] ) if $TOOL{numIs}( $_[1] ) and $_[1] != 1;
	return sprintf( 'rgb(%s)', ( $TOOL{joinRgb}( $_[0]->colour ) ) );
}

sub toRGBA {
	return sprintf 'rgba(%s,%s)', $TOOL{joinRgb}( $_[0]->colour ),
		$_[0]->{alpha};
}

sub toHEX {
	my $colour = sprintf(
		"#%02lx%02lx%02lx",
		(
			map { my $c = $TOOL{clamp}( $TOOL{round}($_), 255 ); $c }
				$_[0]->colour
		)
	);
	unless ( $_[1] ) {
		if ( $colour =~ /#(.)\1(.)\2(.)\3/g ) {
			$colour = sprintf "#%s%s%s", $1, $2, $3;
		}
	}
	return $colour;
}

sub toHSL {
	my $hsl = $TOOL{asHSL}($_[0]);
	sprintf( "hsl(%s,%s,%s)",
		$hsl->{h},
		$TOOL{percent}( $hsl->{s} ),
		$TOOL{percent}( $hsl->{l} ),
	);
}

sub toHSV {
	 my ( $r, $g, $b, $max, $min, $d, $h, $s, $v ) = $TOOL{rgb2hs}( $_[0]->colour );

	 $v = $max;
	 $s = ( $max == 0 ) ? $max : $d / $max;

	 if ( $max == $min ) {
		  $h = 0;
	 }
	 else {
		  $h = ( $max == $r ) ? ( $g - $b ) / $d + ( $g < $b ? 6 : 0 )
			 : ( $max == $g ) ? ( $b - $r ) / $d + 2
			 : ( $r - $g ) / $d + 4;
		  $h /= 6;
	 }

	 return sprintf( "hsv(%s,%s,%s)",
		( $h * 360 ),
		$TOOL{percent}($s),
		$TOOL{percent}($v),
	);
}

sub lighten {
	my ( $colour, $amt, $meth, $hsl ) = @_;

	( $hsl, $colour ) = $TOOL{hsl}($colour);

	$amt = $TOOL{depercent}($amt);
	$hsl->{l} += $TOOL{clamp}(
		( $meth && $meth eq 'relative' )
			? (($hsl->{l} || 1) * $amt)
			: $amt, 1
	);

	return $colour->hsla( $TOOL{hash2array}( $hsl, 'h', 's', 'l', 'a' ) );
}

sub darken {
	my ( $colour, $amt, $meth, $hsl ) = @_;

	( $hsl, $colour ) = $TOOL{hsl}($colour);

	$amt = $TOOL{depercent}($amt);
	$hsl->{l} -= $TOOL{clamp}(
		( $meth && $meth eq 'relative' )
			? $hsl->{l} * $amt
			: $amt, 1,
	);

	return $colour->hsla( $TOOL{hash2array}( $hsl, 'h', 's', 'l', 'a' ) );
}

sub fade {
	my ($colour, $amt, $hsl) = @_;

	($hsl, $colour) = $TOOL{hsl}($colour);
	$hsl->{a} = $TOOL{depercent}($amt);

	return $colour->hsla( $TOOL{hash2array}( $hsl, 'h', 's', 'l', 'a' ) );
}

sub fadeout {
	my ($colour, $amt, $meth, $hsl) = @_;

	($hsl, $colour) = $TOOL{hsl}($colour);
	$hsl->{a} -= (($meth && $meth eq 'relative')
		? $hsl->{a} * $TOOL{depercent}($amt)
 		: $TOOL{depercent}($amt));
	return $colour->hsla( $TOOL{hash2array}( $hsl, 'h', 's', 'l', 'a' ) );
}

sub fadein {
	my ($colour, $amt, $meth, $hsl) = @_;
	($hsl, $colour) = $TOOL{hsl}($colour);
	$hsl->{a} += ($meth && $meth eq 'relative')
		? $hsl->{a} * $TOOL{depercent}($amt)
 		: $TOOL{depercent}($amt);
	$hsl->{a} = smallnum::_smallnum($hsl->{a});
	return $colour->hsla( $TOOL{hash2array}( $hsl, 'h', 's', 'l', 'a' ) );
}

sub mix {
	my ($colour1, $colour2, $weight) = @_;
	my ($h1, $c1, $h2, $c2) = ($TOOL{hsl}($colour1), $TOOL{hsl}($colour2));
	$weight = ($weight || 50) / 100;
	my $a = $h1->{a} - $h2->{a};
	my $w = ($weight * 2) - 1;
	my $w1 = ((($w * $a == -1) ? $w : ($w + $a) / (1 + $w * $a)) + 1) / 2;
	my $w2 = 1 - $w1;
	return Colouring::In->new([
		($c1->{colour}[0] * $w1) + ($c2->{colour}[0] * $w2),
		($c1->{colour}[1] * $w1) + ($c2->{colour}[1] * $w2),
		($c1->{colour}[2] * $w1) + ($c2->{colour}[2] * $w2),
		($c1->{alpha} * $weight) + ($c2->{alpha} * 1 - $weight)
	]);
}

sub tint {
	my ($colour, $weight) = @_;
	mix(
		'rgb(255,255,255)',
		$colour,
		$weight
	);
}

sub shade {
	my ($colour, $weight) = @_;
	mix(
		'rgb(0, 0, 0)',
		$colour,
		$weight
	);
}

sub saturate {
	my ($colour, $amt, $meth) = @_;
	my ($h1, $c1) = $TOOL{hsl}($colour);
	$amt = $TOOL{depercent}($amt);
	$h1->{s} += $TOOL{clamp}(
		( $meth && $meth eq 'relative' )
			? $h1->{s} * $amt
			: $amt, 1,
	);
	return $c1->hsla( $TOOL{hash2array}( $h1, 'h', 's', 'l', 'a' ) );
}

sub desaturate {
	my ($colour, $amt, $meth) = @_;
	my ($h1, $c1) = $TOOL{hsl}($colour);
	$amt = $TOOL{depercent}($amt);
	$h1->{s} -= $TOOL{clamp}(
		( $meth && $meth eq 'relative' )
			? $h1->{s} * $amt
			: $amt, 1,
	);
	return $c1->hsla( $TOOL{hash2array}( $h1, 'h', 's', 'l', 'a' ) );
}

sub greyscale {
	my ($colour) = @_;
	desaturate($colour, 100);
}

sub colour {
	my @rgb = @{ $_[0]->{colour} };
	my $r = defined $rgb[0] ? $rgb[0] : 255;
	my $g = defined $rgb[1] ? $rgb[1] : 255;
	my $b = defined $rgb[2] ? $rgb[2] : 255;
	return ( $r, $g, $b );
}

sub validate {
	my ($self, $colour) = @_;
	my $new = eval { $self->new($colour) };
	if ($@) {
		return {
			valid => \0,
			message => $TOOL{MESSAGES}{VALIDATE_ERROR} || 'The string passed to Colouring::In::validate is not a valid color.',
			color => $colour
		};
	}
	return {
		valid => \1,
		message => $TOOL{MESSAGES}{VALIDATE} || 'The string passed to Colouring::In::validate is a valid color',
		color => $colour,
		colour => $new
	};
}

1;

__END__