File Coverage

lib/Graphics/Toolkit/Color/Space.pm

Criterion	Covered	Total	%
statement	97	99	97.9
branch	33	56	58.9
condition	26	69	37.6
subroutine	38	40	95.0
pod	3	34	8.8
total	197	298	66.1

# common code of Graphics::Toolkit::Color::Space::Instance::* packages

package Graphics::Toolkit::Color::Space;
use v5.12;
use warnings;
require Exporter;
our @ISA = qw(Exporter);
use Graphics::Toolkit::Color::Space::Basis;
use Graphics::Toolkit::Color::Space::Shape;
use Graphics::Toolkit::Color::Space::Format;
use Graphics::Toolkit::Color::Space::Util qw/:all/;
our @EXPORT_OK = qw/round_int round_decimals mod_real min max uniq mult_matrix_vector_3 is_nr/;
our %EXPORT_TAGS = (all => [@EXPORT_OK]);

########################################################################
sub new {
    my $pkg = shift;
    return if @_ % 2;
    my %args = @_;
    my $basis = Graphics::Toolkit::Color::Space::Basis->new( $args{'axis'}, $args{'short'}, $args{'name'}, $args{'alias'});
    return $basis unless ref $basis;
    my $shape = Graphics::Toolkit::Color::Space::Shape->new( $basis, $args{'type'}, $args{'range'}, $args{'precision'} );
    return $shape unless ref $shape;
    my $format = Graphics::Toolkit::Color::Space::Format->new( $basis, $args{'value_form'}, $args{'prefix'}, $args{'suffix'} );
    return $format unless ref $format;
    my $self = bless { basis => $basis, shape => $shape, format => $format, convert => {} };
    if (ref $args{'format'} eq 'HASH'){
        for my $format_name (keys %{$args{'format'}}){
            my $formatter = $args{'format'}{$format_name};
            next unless ref $formatter eq 'ARRAY' and  @$formatter > 0;
            $format->add_formatter($format_name, $formatter->[0])
                if exists $formatter->[0] and ref $formatter->[0] eq 'CODE';
            $format->add_deformatter($format_name, $formatter->[1])
                if exists $formatter->[1] and ref $formatter->[1] eq 'CODE';
        }
    }
    if (ref $args{'convert'} eq 'HASH'){
        for my $converter_target (keys %{$args{'convert'}}){
            my $converter = $args{'convert'}{ $converter_target };
            next unless ref $converter eq 'ARRAY' and @$converter > 1
                    and ref $converter->[0] eq 'CODE' and ref $converter->[1] eq 'CODE';
            $self->add_converter( $converter_target, @$converter );
        }
    }
    if (ref $args{'values'} eq 'HASH') {
        my $numifier = $args{'values'};
        $format->set_value_numifier( $numifier->{'read'}, $numifier->{'write'} )
            if ref $numifier->{'read'} eq 'CODE' and ref $numifier->{'write'} eq 'CODE';
    }

    return $self;
}

########################################################################
sub basis              { $_[0]{'basis'} }
sub name               { shift->basis->space_name }           #            --> ~
sub alias              { shift->basis->alias_name }           #            --> ~
sub is_name            { shift->basis->is_name(@_) }          #      ~name --> ?
sub axis_count         { shift->basis->axis_count }           #            --> +
sub is_axis_name       { shift->basis->is_axis_name(@_) }     # ~axis_name --> ?
sub is_value_tuple     { shift->basis->is_value_tuple(@_) }   # @+values   --> ?
sub is_number_tuple    { shift->basis->is_number_tuple(@_) }  # @+values   --> ?
sub is_partial_hash    { shift->basis->is_partial_hash(@_) }  # %+values   --> ?
sub tuple_from_partial_hash { shift->basis->tuple_from_partial_hash(@_) }  # %+values --> ?
sub select_tuple_value_from_name { shift->basis->select_tuple_value_from_axis_name(@_) }  # ~axis_name. %+values --> +

########################################################################
sub shape              { $_[0]{'shape'} }
sub is_linear          { shift->shape->is_linear() }          #                                    --> ?
sub is_in_linear_bounds{ shift->shape->is_in_linear_bounds(@_)}#@+values                           --> ?
sub is_equal           { shift->shape->is_equal( @_ ) }       # @+val_a, @+val_b -- @+precision    --> ?
sub round              { shift->shape->round( @_ ) }          # @+values -- @+precision            --> @+rvals       # result values
sub clamp              { shift->shape->clamp( @_ ) }          # @+values -- @+range                --> @+rvals       # result values
sub check_value_shape  { shift->shape->check_value_shape( @_)}# @+values -- @+range, @+precision   --> @+values|!~   # errmsg
sub normalize          { shift->shape->normalize(@_)}         # @+values -- @+range                --> @+rvals|!~
sub denormalize        { shift->shape->denormalize(@_)}       # @+values -- @+range                --> @+rvals|!~
sub denormalize_delta  { shift->shape->denormalize_delta(@_)} # @+values -- @+range                --> @+rvals|!~
sub delta              { shift->shape->delta( @_ ) }          # @+val_a, @+val_b                   --> @+rvals|      # on normalized values
sub add_constraint     { shift->shape->add_constraint(@_)}    # ~name, ~error, &checker, &remedy   --> %constraint

########################################################################
sub form               { $_[0]{'format'} }
sub format             { shift->form->format(@_) }            # @+values, ~format_name -- @~suffix --> $*color
sub deformat           { shift->form->deformat(@_) }          # $*color                -- @~suffix --> @+values, ~format_name

#### conversion ########################################################
sub converter_names      { keys %{  $_[0]{'convert'} } }
sub alias_converter_name {
    my ($self, $space_name, $name_alias) = @_;
    $self->{'convert'}{ uc $name_alias } = $self->{'convert'}{ uc $space_name };
}
sub can_convert          { (defined $_[1] and exists $_[0]{'convert'}{ uc $_[1] }) ? 1 : 0 }
sub add_converter {
    my ($self, $space_name, $to_code, $from_code, $normal) = @_;
    return 0 if not defined $space_name or ref $space_name or ref $from_code ne 'CODE' or ref $to_code ne 'CODE';
    return 0 if $self->can_convert( $space_name );
    return 0 if defined $normal and ref $normal ne 'HASH';
    $normal = { from => 1, to => 1, } unless ref $normal; # default is full normalisation
    $normal->{'from'} = {} if not exists $normal->{'from'} or (exists $normal->{'from'} and not $normal->{'from'});
    $normal->{'from'} = {in => 1, out => 1} if not ref $normal->{'from'};
    $normal->{'from'}{'in'} = 0 unless exists $normal->{'from'}{'in'};
    $normal->{'from'}{'out'} = 0 unless exists $normal->{'from'}{'out'};
    $normal->{'to'} = {} if not exists $normal->{'to'} or (exists $normal->{'to'} and not $normal->{'to'});
    $normal->{'to'} = {in => 1, out => 1} if not ref $normal->{'to'};
    $normal->{'to'}{'in'} = 0 unless exists $normal->{'to'}{'in'};
    $normal->{'to'}{'out'} = 0 unless exists $normal->{'to'}{'out'};
    $self->{'convert'}{ uc $space_name } = { from => $from_code, to => $to_code, normal => $normal };
}

sub convert_to { # convert value tuple from this space into another
    my ($self, $space_name, $values) = @_;
    return unless $self->is_value_tuple( $values ) and defined $space_name and $self->can_convert( $space_name );
    return $self->{'convert'}{ uc $space_name }{'to'}->( $values );
}
sub convert_from { # convert value tuple from another space into this
    my ($self, $space_name, $values) = @_;
    return unless ref $values eq 'ARRAY' and defined $space_name and $self->can_convert( $space_name );
    return $self->{'convert'}{ uc $space_name }{'from'}->( $values );
}

sub converter_normal_states {
    my ($self, $direction, $space_name) = @_;
    return unless $self->can_convert( $space_name )
              and defined $direction and ($direction eq 'from' or $direction eq 'to');
    return @{$self->{'convert'}{ uc $space_name }{'normal'}{$direction}}{'in', 'out'};
}


1;

__END__