File Coverage

lib/Graphics/Toolkit/Color/Space/Hub.pm
Criterion Covered Total %
statement 61 61 100.0
branch 34 38 89.4
condition 7 8 87.5
subroutine 16 16 100.0
pod 11 12 91.6
total 129 135 95.5


line stmt bran cond sub pod time code
1 7     7   830 use v5.12;
  7         23  
2 7     7   40 use warnings;
  7         13  
  7         317  
3              
4             # check, convert and measure color values
5              
6             package Graphics::Toolkit::Color::Space::Hub;
7 7     7   49 use Carp;
  7         14  
  7         7838  
8             our $base_package = 'RGB';
9             my @space_packages = ($base_package, qw/CMY CMYK HSL HSV HSB HWB YIQ/); # search order # HCL LAB LUV XYZ Ncol ?
10             my %space_obj = map { $_ => require "Graphics/Toolkit/Color/Space/Instance/$_.pm" } @space_packages;
11              
12 3415 100   3415 1 13409 sub get_space { $space_obj{ uc $_[0] } if exists $space_obj{ uc $_[0] } }
13 1197 100 100 1197 1 2619 sub is_space { (defined $_[0] and ref get_space($_[0])) ? 1 : 0 }
14 221     221 1 397 sub base_space { $space_obj{$base_package} }
15 252     252 1 702 sub space_names { @space_packages }
16              
17             ########################################################################
18              
19             sub check_space_name {
20 1286 100   1286 0 2405 return unless defined $_[0];
21 1143         3348 my $error = "called with unknown color space name '$_[0]', please try one of: " . join (', ', @space_packages);
22 1143 100       1913 is_space( $_[0] ) ? 0 : carp $error;
23             }
24             sub _check_values_and_space {
25 601     601   948 my ($sub_name, $values, $space_name) = @_;
26 601   66     1085 $space_name //= $base_package;
27 601 100       897 check_space_name( $space_name ) and return;
28 599         996 my $space = get_space($space_name);
29 599 100       1284 $space->is_array( $values ) ? $space
30             : carp 'need an ARRAY ref with '.$space->dimensions." $space_name values as first argument of $sub_name";
31             }
32              
33             ########################################################################
34              
35             sub partial_hash_deformat { # convert partial hash into
36 20     20 1 6809 my ($value_hash) = @_;
37 20 100       54 return unless ref $value_hash eq 'HASH';
38 19         33 for my $space_name (space_names()) {
39 72         107 my $color_space = get_space( $space_name );
40 72         143 my $pos_hash = $color_space->basis->deformat_partial_hash( $value_hash );
41 72 100       181 return $pos_hash, $color_space->name if ref $pos_hash eq 'HASH';
42             }
43 4         24 return undef;
44             }
45              
46             sub deformat { # convert from any format into list of values of any space
47 233     233 1 27997 my ($formated_values) = @_;
48 233         406 for my $space_name (space_names()) {
49 639         1348 my $color_space = get_space( $space_name );
50 639         1317 my @val = $color_space->deformat( $formated_values );
51 639 100       1801 return \@val, $space_name if defined $val[0];
52             }
53             }
54              
55             sub format { # @tuple --> % | % |~ ...
56 586     586 1 11638 my ($values, $space_name, $format_name) = @_;
57              
58 586         989 my $space = _check_values_and_space( 'format', $values, $space_name );
59 586 100       2996 return unless ref $space;
60 583   100     1750 my @values = $space->format( $values, $format_name // 'list' );
61 583 50       1114 return @values, carp "got unknown format name: '$format_name'" unless defined $values[0];
62 583 100       3371 return @values == 1 ? $values[0] : @values;
63             }
64              
65             sub deconvert { # @... --> @RGB (base color space) # normalized values only
66 1     1 1 2725 my ($values, $space_name) = @_;
67 1         4 my $space = _check_values_and_space( 'deconvert', $values, $space_name );
68 1 50       4 return unless ref $space;
69 1         3 my @values = $space->clamp( $values, 'normal');
70 1 50       3 return @values if $space->name eq base_space->name;
71 1         3 $space->convert( \@values, $base_package);
72             }
73              
74             sub convert { # @RGB --> @... # normalized values only
75 2     2 1 3911 my ($values, $space_name) = @_;
76 2         5 my $space = _check_values_and_space( 'convert', $values, $space_name );
77 2 50       6 return unless ref $space;
78 2         4 my @values = base_space->clamp( $values, 'normal');
79 2 100       6 return @values if $space->name eq base_space->name;
80 1         3 $space->deconvert( \@values, $base_package);
81             }
82              
83             sub denormalize { # result clamped, alway in space
84 5     5 1 4642 my ($values, $space_name, $range) = @_;
85 5         15 my $space = _check_values_and_space( 'denormalize', $values, $space_name );
86 5 100       1645 return unless ref $space;
87 2         5 my @values = $space->clamp($values, 'normal');
88 2         8 $space->denormalize( \@values, $range);
89             }
90              
91             sub normalize {
92 7     7 1 6440 my ($values, $space_name, $range) = @_;
93 7         16 my $space = _check_values_and_space( 'normalize', $values, $space_name );
94 7 100       1700 return unless ref $space;
95 4         10 my @values = $space->clamp($values, $range);
96 4 100       519 return unless defined $values[0];
97 3         7 $space->normalize( $values, $range);
98             }
99              
100              
101             1;
102              
103             __END__