File Coverage

blib/lib/Number/RGB.pm

Criterion	Covered	Total	%
statement	45	77	58.4
branch	1	16	6.2
condition	0	3	0.0
subroutine	15	31	48.3
pod	7	7	100.0
total	68	134	50.7

package Number::RGB;
# $Id: RGB.pm,v 1.2 2004/03/06 16:17:02 cwest Exp $
use strict;

use vars qw[$VERSION $CONSTRUCTOR_SPEC];
$VERSION = (qw$Revision: 1.2 $)[1];

=head1 NAME

Number::RGB - Manipulate RGB Tuples

=head1 SYNOPSIS

  use Number::RGB;
  my $white :RGB(255);
  my $black :RGB(0);

  my $gray = $black + (($white - $black) / 2);

  my @rgb = @{ $white->rgb };
  my $hex = $black->hex;

  my $blue   = Number::RGB->new(rgb => [0,0,255]);
  my $green  = Number::RGB->new(hex => '#00FF00');

  my $red :RGB(255,0,0);

  my $purple = $blue + $green;
  my $yellow = $red  + $green;

=cut

use Carp;
use Params::Validate qw[:all];
use base qw[Class::Accessor::Fast];
use Attribute::Handlers;

sub import {
	my $class  = shift;
	my $caller = (caller)[0];
	eval qq[
		package $caller;
		use Attribute::Handlers;
		sub RGB :ATTR(SCALAR) { 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('|',  @_) };

=head1 DESCRIPTION

This module creates RGB tuple objects and overloads their operators to
make RGB math easier. An attribute is also exported to the caller to
make construction shorter.

=head2 Methods

=over 4

=item C

  my $red   = Number::RGB->new(rgb => [255,0,0])
  my $blue  = Number::RGB->new(hex => '#0000FF');
  my $black = Number::RGB->new(rgb_number => 0);

This constructor accepts named parameters. One of three parameters are
required.

C is a list reference containing three intergers within the range
of C<0..255>. In order, each interger represents I, I, and
I.

C is a hexidecimal representation of an RGB tuple commonly used in
Cascading Style Sheets. The format begins with an optional hash (C<#>)
and follows with three groups of hexidecimal numbers represending
I, I, and I in that order.

C is a single integer which represents all primary colors.
This is shorthand to create I, I, and all shades of
I.

This method throws and exception on error, which should be caught with
C.

=cut

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);
}

=pod

=item C

Accessor and mutator for the I value.

=item C

Accessor and mutator for the I value.

=item C

Accessor and mutator for the I value.

=cut

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

=pod

=item C

Returns a list reference containing three elements. In order they
represent I, I, and I.

=item C

Returns a hexidecimal represention of the tuple conforming to the format
used in Cascading Style Sheets.

=item C

Returns the same thing as C, but any hexidecimal numbers that
include C<'A'..'F'> will be uppercased.

=item C

Returns a string representation of the tuple.  For example, I
would be the string C<255,255,255>.

=cut

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;
			int eval ($reversed ? "$y $op $x" : "$x $op $y");
		} qw[r g b]
	] );
}

=pod

=item C

  my $color = Number::RGB->new_from_guess(input());

This constructor tries to guess the format being used and returns a
tuple object. If it can't guess, an exception will be thrown.

=back

=cut

sub new_from_guess {
	my ($class, $value) = @_;
	foreach my $param ( keys %{$CONSTRUCTOR_SPEC} ) {
		my $self = eval { $class->new($param => $value) };
		return $self if defined $self;
	}
	croak "$class->new_from_guess() couldn't guess type for ($value)";
}

=head2 Attributes

=over 4

=item C<:RGB()>

  my $red   :RGB(255,0,0);
  my $blue  :RGB(#0000FF);
  my $white :RGB(0);

This attribute is exported to the caller and provides a shorthand wrapper
around C.

=back

=cut

sub RGB :ATTR(SCALAR) {
	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 { $_[0] >= 0 && $_[0] <= 255 },
    	},
    },
    hex => {
    	type      => SCALAR,
    	optional  => 1,
    	callbacks => {
    		'hex format' => sub { $_[0] =~ /^#?(?:[\da-f]{3}|[\da-f]{6})$/i },
    	},
    }
};

1;

__END__