File Coverage

blib/lib/Number/RGB.pm

Criterion	Covered	Total	%
statement	88	90	97.7
branch	22	24	91.6
condition	9	11	81.8
subroutine	31	33	93.9
pod	7	7	100.0
total	157	165	95.1

package Number::RGB;

use strict;
use warnings;

our $VERSION = '1.4'; # VERSION

use vars qw[$CONSTRUCTOR_SPEC];
use Scalar::Util qw[looks_like_number];
use Params::Validate qw[:all];
use base qw[Class::Accessor::Fast];
use Attribute::Handlers 0.99;
use Carp;
our @CARP_NOT = ('Attribute::Handlers', __PACKAGE__);
$Carp::Internal{'attributes'}++; # no idea why doesn't work in @CARP_NOT

sub import {
    my $class  = shift;
    my $caller = (caller)[0];
    eval qq[
        package $caller;
        use Attribute::Handlers;
        sub RGB :ATTR(RAWDATA) { goto &$class\::RGB }
        package $class;
    ];
}

use overload fallback => 1,
    '""'  => \&as_string,
    '+'   => sub { shift->_op_math('+',  @_) },
    '-'   => sub { shift->_op_math('-',  @_) },
    '*'   => sub { shift->_op_math('*',  @_) },
    '/'   => sub { shift->_op_math('/',  @_) },
    '%'   => sub { shift->_op_math('%',  @_) },
    '**'  => sub { shift->_op_math('**', @_) },
    '<<'  => sub { shift->_op_math('<<', @_) },
    '>>'  => sub { shift->_op_math('>>', @_) },
    '&'   => sub { shift->_op_math('&',  @_) },
    '^'   => sub { shift->_op_math('^',  @_) },
    '|'   => sub { shift->_op_math('|',  @_) };

sub new {
    my $class = shift;
    my %params = validate( @_,  $CONSTRUCTOR_SPEC );
    croak "$class->new() requires parameters" unless keys %params;

    my %rgb;
    if ( defined $params{rgb} ) {
        @rgb{qw[r g b]} = @{$params{rgb}};
    } elsif ( defined $params{rgb_number} ) {
        return $class->new(rgb => [($params{rgb_number})x3]);
    } elsif ( defined $params{hex} ) {
        my $hex = $params{hex};
        $hex =~ s/^#//;
        $hex =~ s/(.)/$1$1/g if length($hex) == 3;
        @rgb{qw[r g b]} = map hex, $hex =~ /(.{2})/g;
    }

    $class->SUPER::new(\%rgb);
}

__PACKAGE__->mk_accessors( qw[r g b] );

sub rgb       { [ map $_[0]->$_, qw[r g b] ] }
sub hex       { '#' . join '', map { substr sprintf('0%x',$_[0]->$_), -2 } qw[r g b] }
sub hex_uc    { uc shift->hex }
sub as_string {
    join ',', map $_[0]->$_, qw[r g b]
}

sub _op_math {
    my ($self,$op, $other, $reversed) = @_;
    ref($self)->new(rgb => [
        map {
            my $x = $self->$_;
            my $y = ref($other) && overload::Overloaded($other) ? $other->$_ : $other;
            my $ans = eval ($reversed ? "$y $op $x" : "$x $op $y");
            $ans = sprintf '%.0f', $ans||0;
            $ans = 0 if $ans < 0; $ans = 255 if $ans > 255;
            $ans;
        } qw[r g b]
    ] );
}

sub new_from_guess {
    my ($class, $value) = @_;
    $value = [ $value =~ /\d+/g ] if $value =~ /,/;
    my $is_single_rgb = looks_like_number($value) && $value>=0 && $value<=255;

    foreach my $param ( keys %{$CONSTRUCTOR_SPEC} ) {
        next if $param eq 'hex' and $is_single_rgb;
        my $self = eval { $class->new($param => $value) };
        return $self if defined $self;
    }
    croak q{couldn't guess value type};
}

sub RGB :ATTR(RAWDATA) {
    my ($var, $data) = @_[2,4];
    $$var = __PACKAGE__->new_from_guess($data);
}

$CONSTRUCTOR_SPEC = {
    rgb => {
        type      => ARRAYREF,
        optional  => 1,
        callbacks => {
            'three elements'    => sub { 3 == @{$_[0]} },
            'only digits'       => sub { 0 == grep /\D/, @{$_[0]} },
            'between 0 and 255' => sub { 3 == grep { $_ >= 0 && $_ <= 255 } @{$_[0]} },
        },
    },
    rgb_number => {
        type      => SCALAR,
        optional  => 1,
        callbacks => {
            'only digits'       => sub { $_[0] !~ /\D/ },
            'between 0 and 255' => sub {
                looks_like_number($_[0]) and $_[0] >= 0 && $_[0] <= 255
            },
        },
    },
    hex => {
        type      => SCALAR,
        optional  => 1,
        callbacks => {
            'hex format' => sub { $_[0] =~ /^#?(?:[\da-f]{3}|[\da-f]{6})$/i },
        },
    }
};

1;

__END__