File Coverage

blib/lib/ICC/Profile/view.pm
Criterion Covered Total %
statement 9 65 13.8
branch 0 22 0.0
condition 0 15 0.0
subroutine 3 13 23.0
pod 1 7 14.2
total 13 122 10.6


line stmt bran cond sub pod time code
1             package ICC::Profile::view;
2              
3 2     2   83029 use strict;
  2         11  
  2         47  
4 2     2   9 use Carp;
  2         3  
  2         111  
5              
6             our $VERSION = 0.12;
7              
8             # revised 2018-08-07
9             #
10             # Copyright © 2004-2020 by William B. Birkett
11              
12             # inherit from Shared
13 2     2   369 use parent qw(ICC::Shared);
  2         266  
  2         15  
14              
15             # create new view tag object
16             # parameters: ()
17             # parameters: (ref_to_attribute_hash)
18             # returns: (ref_to_object)
19             sub new {
20              
21             # get object class
22 0     0 0   my $class = shift();
23            
24             # create empty view object
25 0           my $self = [
26             {}, # object header
27             [], # illuminant XYZ array
28             [], # surround XYZ array
29             0 # illuminant type
30             ];
31              
32             # if single parameter is a hash reference
33 0 0 0       if (@_ == 1 && ref($_[0]) eq 'HASH') {
34              
35             # set object attributes
36 0           _newICCview($self, @_);
37              
38             }
39              
40             # bless object
41 0           bless($self, $class);
42              
43             # return object reference
44 0           return($self);
45              
46             }
47              
48             # create view tag object from ICC profile
49             # parameters: (ref_to_parent_object, file_handle, ref_to_tag_table_entry)
50             # returns: (ref_to_object)
51             sub new_fh {
52              
53             # get object class
54 0     0 0   my $class = shift();
55              
56             # create empty view object
57 0           my $self = [
58             {}, # object header
59             [], # illuminant XYZ array
60             [], # surround XYZ array
61             0 # illuminant type
62             ];
63              
64             # verify 3 parameters
65 0 0         (@_ == 3) or croak('wrong number of parameters');
66              
67             # read view data from profile
68 0           _readICCview($self, @_);
69              
70             # bless object
71 0           bless($self, $class);
72              
73             # return object reference
74 0           return($self);
75              
76             }
77              
78             # writes view tag object to ICC profile
79             # parameters: (ref_to_parent_object, file_handle, ref_to_tag_table_entry)
80             sub write_fh {
81              
82             # verify 4 parameters
83 0 0   0 0   (@_ == 4) or croak('wrong number of parameters');
84              
85             # write view data to profile
86 0           goto &_writeICCview;
87              
88             }
89              
90             # get tag size (for writing to profile)
91             # returns: (tag_size)
92             sub size {
93            
94             # get parameters
95 0     0 0   my ($self) = @_;
96            
97             # return size
98 0           return(36);
99            
100             }
101              
102             # get XYZ values
103             # index: illuminant = 0, surround = 1
104             # returns: (ref_to_XYZ_array)
105             sub XYZ {
106              
107             # get parameters
108 0     0 0   my $self = shift();
109            
110             # get index
111 0           my $i = shift();
112            
113             # verify index
114 0 0 0       ($i == 0 || $i == 1) or croak('invalid view index');
115              
116             # return XYZ values
117 0           return($self->[$i + 1]);
118              
119             }
120              
121             # get/set illuminant type
122             # 0 = unknown, 1 = D50, 2 = D65, 3 = D93, 4 = F2, 5 = D55, 6 = A, 7 = Equi_Power, 8 = F8
123             # parameters: ([type_value])
124             # returns: (type_value)
125             sub type {
126              
127             # get object reference
128 0     0 0   my $self = shift();
129            
130             # if parameter supplied
131 0 0         if (@_) {
132            
133             # get type value
134 0           my $type = shift();
135            
136             # verify type value
137 0 0 0       ($type == int($type) && $type >= 0 && $type <= 8) or croak('invalid illuminant type');
      0        
138            
139             # save it
140 0           $self->[3] = $type;
141            
142             }
143            
144             # return illuminant type
145 0           return($self->[3]);
146              
147             }
148              
149             # print object contents to string
150             # format is an array structure
151             # parameter: ([format])
152             # returns: (string)
153             sub sdump {
154              
155             # get parameters
156 0     0 1   my ($self, $p) = @_;
157              
158             # local variables
159 0           my ($s, $fmt);
160              
161             # resolve parameter to an array reference
162 0 0         $p = defined($p) ? ref($p) eq 'ARRAY' ? $p : [$p] : [];
    0          
163              
164             # get format string
165 0 0 0       $fmt = defined($p->[0]) && ! ref($p->[0]) ? $p->[0] : 'undef';
166              
167             # set string to object ID
168 0           $s = sprintf("'%s' object, (0x%x)\n", ref($self), $self);
169              
170             # return
171 0           return($s);
172              
173             }
174              
175             # make new view tag from attribute hash
176             # hash may contain pointers to header, illuminant XYZ array, surround XYZ array, illuminant type
177             # keys are: ('header', 'illuminant', 'surround', 'type')
178             # tag elements not specified in the hash are left empty
179             # parameters: (ref_to_object, ref_to_attribute_hash)
180             sub _newICCview {
181            
182             # get parameters
183 0     0     my ($self, $hash) = @_;
184            
185             # local variables
186 0           my (%list);
187            
188             # set attribute list (key => [reference_type, array_index])
189 0           %list = ('header' => ['HASH', 0], 'illuminant' => ['ARRAY', 1], 'surround' => ['ARRAY', 2], 'type' => ['', 3]);
190            
191             # for each attribute
192 0           for my $attr (keys(%list)) {
193            
194             # if attribute specified
195 0 0         if (exists($hash->{$attr})) {
196            
197             # if correct reference type
198 0 0         if (ref($hash->{$attr}) eq $list{$attr}[0]) {
199            
200             # set tag element
201 0           $self->[$list{$attr}[1]] = $hash->{$attr};
202            
203             } else {
204            
205             # error
206 0           croak('wrong reference type');
207            
208             }
209            
210             }
211            
212             }
213            
214             }
215              
216             # read view tag from ICC profile
217             # parameters: (ref_to_object, ref_to_parent_object, file_handle, ref_to_tag_table_entry)
218             sub _readICCview {
219            
220             # get parameters
221 0     0     my ($self, $parent, $fh, $tag) = @_;
222            
223             # local variables
224 0           my ($buf, $i);
225            
226             # save tag signature
227 0           $self->[0]{'signature'} = $tag->[0];
228            
229             # seek start of tag data
230 0           seek($fh, $tag->[1] + 8, 0);
231            
232             # read illuminant XYZ values
233 0           read($fh, $buf, 12);
234            
235             # unpack and save values
236 0           $self->[1] = [ICC::Shared::s15f162v(unpack('N3', $buf))];
237            
238             # read surround XYZ values
239 0           read($fh, $buf, 12);
240            
241             # unpack and save values
242 0           $self->[2] = [ICC::Shared::s15f162v(unpack('N3', $buf))];
243            
244             # read illuminant type
245 0           read($fh, $buf, 4);
246            
247             # unpack and save value
248 0           $self->[3] = unpack('N', $buf);
249            
250             }
251              
252             # write view tag to ICC profile
253             # parameters: (ref_to_object, ref_to_parent_object, file_handle, ref_to_tag_table_entry)
254             sub _writeICCview {
255              
256             # get parameters
257 0     0     my ($self, $parent, $fh, $tag) = @_;
258              
259             # local variables
260 0           my ($buf, $XYZ);
261              
262             # seek start of tag
263 0           seek($fh, $tag->[1], 0);
264              
265             # write tag
266 0           print $fh pack('a4 x4 N3 N3 N', 'view', ICC::Shared::v2s15f16(@{$self->[1]}), ICC::Shared::v2s15f16(@{$self->[2]}), $self->[3]);
  0            
  0            
267              
268             }
269              
270             1;