view release on metacpan or  search on metacpan

lib/Number/RGB.pm  view on Meta::CPAN

package Number::RGB;

use strict;
use warnings;

our $VERSION = '2.001001'; # 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;