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   23 use 5.008009;
  2         4  
4 2     2   5 use strict;
  2         2  
  2         26  
5 2     2   5 use warnings;
  2         3  
  2         39  
6 2     2   6 use parent qw/Convert::Color/;
  2         2  
  2         6  
7              
8 2     2   868 use Convert::Color::RGB;
  2         1160  
  2         41  
9 2     2   8 use List::Util qw/sum/;
  2         2  
  2         173  
10              
11             our $VERSION = '1.000001';
12              
13             use constant +{ ## no critic (Capitalization)
14 2         745 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   8 };
  2         3  
22              
23             __PACKAGE__->register_color_space('xyz');
24              
25             sub new {
26 4609     4609 1 4647 my ($class, $x, $y, $z) = @_;
27 4609 100       7210 ($x, $y, $z) = split /,/s, $x unless defined $y;
28 4609         14135 bless [$x, $y, $z], $class
29             }
30              
31 1     1 1 9 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         6  
36              
37             sub _dot_product {
38 13824     13824   9685 my ($x, $y) = @_;
39 13824         8892 sum map { $x->[$_] * $y->[$_] } 0 .. $#{$x}
  41472         51311  
  13824         11763  
40             }
41              
42             sub _from_linear {
43 3072     3072   2032 my ($c) = @_;
44 3072 100       10021 $c <= 0.0031308 ? 12.92 * $c : 1.055 * $c ** (1 / 2.4) - 0.055
45             }
46              
47             sub _to_linear {
48 10752     10752   7150 my ($c) = @_;
49 10752 100       23535 $c <= 0.04045 ? $c / 12.92 : (($c + 0.055) / 1.055) ** 2.4
50             }
51              
52             sub rgb {
53 1024     1024 1 714 my ($self) = @_;
54 1024         901 map { _from_linear _dot_product $_, $self } MAT_R, MAT_G, MAT_B;
  3072         3042  
55             }
56              
57             sub new_rgb {
58 3584     3584 0 142915 my $class = shift;
59 3584         3460 my $vector = [map { _to_linear $_ } @_];
  10752         9789  
60 3584         3948 $class->new(map { _dot_product $_, $vector } IMAT_X, IMAT_Y, IMAT_Z)
  10752         9593  
61             }
62              
63             1;
64             __END__