File Coverage

lib/Template/Colour.pm

Criterion	Covered	Total	%
statement	58	71	81.6
branch	24	32	75.0
condition	12	28	42.8
subroutine	13	17	76.4
pod	3	12	25.0
total	110	160	68.7

package Template::Colour;

use Template::Colour::Class
    debug     => 0,
    base      => 'Badger::Base',
    constants => 'HASH SCHEME WHITE BLACK',
    utils     => 'is_object',
    import    => 'class',
    messages  => {
        bad_param => 'invalid %s parameter(s): %s',
        no_param  => 'missing %s colour parameter: %s',
    };

use Template::Colour::RGB;
use Template::Colour::HSV;
use POSIX 'floor';

our $VERSION = 0.05;
our @SCHEME  = qw(
    black darkest darker dark mid light lighter lightest white
    pale wash dull bold bright
);
our $SPACES  = {
    RGB => 'Template::Colour::RGB',
    HSV => 'Template::Colour::HSV',
};

class->methods(
    # create methods for each of the scheme variants
    map {
        my $name = $_;              # lexical copy for closure
        $_ => sub {
            shift->scheme->{ $name };
        }
    }
    @SCHEME
);


sub new {
    my $class = shift;
    my ($config, $space);

    if (@_ == 1) {
        # single argument is either an existing colour object which we copy...
        return $_[0]->copy()
            if is_object(ref $class || $class, $_[0]);

        # ... or a hash ref of named parameters...
        #   e.g { rgb => '#rrggbb' }, { rgb => [r, g, b] },  hsv => [h, s, v] }
        # ... or a single RGB argument
        #   e.g. [r, g, b], '#rrggbb'
        $config = ref $_[0] eq HASH ? shift : { rgb => shift };
    }
    elsif (@_ == 2) {
        # two arguments are (colour-space => $value),
        #   e.g. (rgb => '#rrggbb'), (rgb => [r, g, b]), (hsv => [h, s, v])
        $config = { @_ };
    }
    elsif (@_ == 3) {
        # three arguments are (r, g, b)
        $config->{ rgb } = [ @_ ];
    }
    elsif (@_) {
        # four or more arguments are named parameters
        $config = { @_ };
    }
    else {
        # How much more black can this be?  The answer is none.  None more black.
        $config = { rgb => [0, 0, 0] };
    }

    if ($space = $config->{ rgb } || $config->{ RGB }) {
        # explicit RGB specification (rgb => ...)
        return $class->RGB($space);
    }
    elsif ($space = $config->{ hsv } || $config->{ HSV }) {
        # explicit HSV specification (hsv => ...)
        return $class->HSV($space);
    }
    elsif (exists $config->{ hue }) {
        # implicit HSV specification (hue => $h, ...)
        return $class->HSV($config);
    }
    else {
        # if we don't get an explicit RGB or HSV colour space then we
        # default to RGB to handle the (red => $r, green => $g, blue => $b) case
        return $class->RGB($config);
    }
}

sub RGB {
    my $self = shift;
    return $self->class->hash_value( SPACES => 'RGB' )->new(@_);
}

sub HSV {
    my $self = shift;
    return $self->class->hash_value( SPACES => 'HSV' )->new(@_);
}

sub copy {
    # should be redefined by subclasses
    return $_[0];
}

sub adjust {
    my $self = shift;
    return $self->not_implemented();
}

sub range {
    my $self = shift;
    return $self->not_implemented();
}

sub tints {
    my $self  = shift;
    my $steps = shift || 4;
    return $self->range($steps, @_ && $_[0] ? @_ : WHITE);
}

sub shades {
    my $self  = shift;
    my $steps = shift || 4;
    my @black = @_ && $_[0] ? @_ : BLACK;
    return $self->range($steps, @black);
}

sub scheme {
    my $self   = shift;

    # return the cached scheme if we have one and no args are defined
    return $self->[SCHEME]
        if $self->[SCHEME]
        && ! @_;

    my $args   = @_ && ref $_[0] eq HASH ? shift : { @_ };
    my $shades = $self->shades(4, $args->{ black });        # black to col
    my $tints  = $self->tints(4, $args->{ white });         # col to white
    my $washes = $tints->[3]->tints(3, $args->{ white });   # pale washes
    my $scheme = { };

    # remove the base colour and white from washes
    shift(@$washes);
    pop(@$washes);

    # remove base colour from shades to avoid duplication with same in tints
    shift(@$shades);

    @$scheme{ @SCHEME } = (
        # black, darkest, darker, dark
        reverse(@$shades),
        # mid light lighter lightest white
        @$tints,
        # pale, wash
        @$washes,
        # dull
        $self->copy->hsv->adjust(sat => '-10%', value => '-10%'),
        # bold
        $self->copy->hsv->adjust(sat => '+10%', value => '-10%'),
        # bright
        $self->copy->hsv->adjust(sat => '+10%', value => '+10%'),
    );
    return $scheme;
}

sub variations {
    my $self   = shift;
    my $args   = @_ && ref $_[0] eq HASH ? shift : { @_ };
    my $scheme = { };
    while (my($name, $values) = each %$args) {
        $scheme->{ $name } = $self->copy->update($values);
    }
    return $scheme;
}

#------------------------------------------------------------------------
# min($r, $g, $b)
#
# Returns minimum value from arguments, used for colour space conversion.
#------------------------------------------------------------------------

sub min {
    my $self = shift;
    my $min  = shift;
    foreach my $v (@_) {
        $min = $v if $v < $min;
    }
    return $min;
}


#------------------------------------------------------------------------
# max($r, $g, $b)
#
# Returns maximum value from arguments, used for colour space conversion.
#------------------------------------------------------------------------

sub max {
    my $self = shift;
    my $max  = shift;
    foreach my $v (@_) {
        $max = $v if $v > $max;
    }
    return $max;
}


1;

__END__