File Coverage

blib/lib/Convert/Color/XYZ.pm
Criterion Covered Total %
statement 44 44 100.0
branch 6 6 100.0
condition n/a
subroutine 17 17 100.0
pod 6 7 85.7
total 73 74 98.6


line stmt bran cond sub pod time code
1             package Convert::Color::XYZ;
2              
3 2     2   27 use 5.008009;
  2         4  
4 2     2   7 use strict;
  2         2  
  2         26  
5 2     2   4 use warnings;
  2         3  
  2         44  
6 2     2   6 use parent qw/Convert::Color/;
  2         1  
  2         6  
7              
8 2     2   862 use Convert::Color::RGB;
  2         1143  
  2         39  
9 2     2   8 use List::Util qw/sum/;
  2         2  
  2         146  
10              
11             our $VERSION = '1.000';
12              
13             use constant +{ ## no critic (Capitalization)
14 2         766 MAT_R => [ 3.2409699419045214, -1.5373831775700935, -0.49861076029300328 ],
15             MAT_G => [ -0.96924363628087983, 1.8759675015077207, 0.041555057407175613 ],
16             MAT_B => [ 0.055630079696993609, -0.20397695888897657, 1.0569715142428786 ],
17              
18             IMAT_X => [ 0.41239079926595948, 0.35758433938387796, 0.18048078840183429 ],
19             IMAT_Y => [ 0.21263900587151036, 0.71516867876775593, 0.072192315360733715 ],
20             IMAT_Z => [ 0.019330818715591851, 0.11919477979462599, 0.95053215224966058 ],
21 2     2   6 };
  2         2  
22              
23             __PACKAGE__->register_color_space('xyz');
24              
25             sub new {
26 4609     4609 1 4406 my ($class, $x, $y, $z) = @_;
27 4609 100       6820 ($x, $y, $z) = split /,/s, $x unless defined $y;
28 4609         14068 bless [$x, $y, $z], $class
29             }
30              
31 1     1 1 6 sub X { shift->[0] }
32 1     1 1 4 sub Y { shift->[1] }
33 1     1 1 4 sub Z { shift->[2] }
34              
35 1     1 1 2 sub xyz { @{$_[0]} }
  1         8  
36              
37             sub _dot_product {
38 13824     13824   9629 my ($x, $y) = @_;
39 13824         9238 sum map { $x->[$_] * $y->[$_] } 0 .. $#{$x}
  41472         52066  
  13824         12848  
40             }
41              
42             sub _from_linear {
43 3072     3072   2086 my ($c) = @_;
44 3072 100       10160 $c <= 0.0031308 ? 12.92 * $c : 1.055 * $c ** (1 / 2.4) - 0.055
45             }
46              
47             sub _to_linear {
48 10752     10752   6793 my ($c) = @_;
49 10752 100       22504 $c <= 0.04045 ? $c / 12.92 : (($c + 0.055) / 1.055) ** 2.4
50             }
51              
52             sub rgb {
53 1024     1024 1 678 my ($self) = @_;
54 1024         903 map { _from_linear _dot_product $_, $self } MAT_R, MAT_G, MAT_B;
  3072         2900  
55             }
56              
57             sub new_rgb {
58 3584     3584 0 162600 my $class = shift;
59 3584         3570 my $vector = [map { _to_linear $_ } @_];
  10752         9903  
60 3584         3709 $class->new(map { _dot_product $_, $vector } IMAT_X, IMAT_Y, IMAT_Z)
  10752         9683  
61             }
62              
63             1;
64             __END__