File Coverage

blib/lib/ICC/Profile/vcgt.pm
Criterion Covered Total %
statement 14 161 8.7
branch 1 80 1.2
condition 0 45 0.0
subroutine 4 15 26.6
pod 1 8 12.5
total 20 309 6.4


line stmt bran cond sub pod time code
1             package ICC::Profile::vcgt;
2              
3 2     2   76100 use strict;
  2         9  
  2         56  
4 2     2   9 use Carp;
  2         2  
  2         104  
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   345 use parent qw(ICC::Shared);
  2         220  
  2         7  
14              
15             # create new vcgt tag object
16             # parameters: ()
17             # parameters: (ref_to_array_of_curv_objects)
18             # parameters: (ref_to_3x3_parameter_array)
19             # returns: (ref_to_object)
20             sub new {
21              
22             # get object class
23 1     1 0 670 my $class = shift();
24              
25             # create empty vcgt object
26 1         2 my $self = [
27             {}, # object header
28             [[]] # array
29             ];
30              
31             # if parameter supplied
32 1 50       4 if (@_) {
33            
34             # if one parameter, a reference to an array of 'curv' objects
35 0 0 0     0 if (@_ == 1 && ref($_[0]) eq 'ARRAY' && @{$_[0]} == grep {UNIVERSAL::isa($_, 'ICC::Profile::curv')} @{$_[0]}) {
  0 0 0     0  
  0   0     0  
  0   0     0  
36            
37             # verify one or three objects
38 0 0 0     0 (@{$_[0]} == 1 || @{$_[0]} == 3) or croak('array must contain one or three \'curv\' objects');
  0         0  
  0         0  
39            
40             # copy array
41 0         0 $self->[1] = [@{shift()}];
  0         0  
42            
43             # if one parameter, a reference to a 2-D array
44 0         0 } elsif (@_ == 1 && (ref($_[0]) eq 'ARRAY') && @{$_[0]} == grep {ref() eq 'ARRAY'} @{$_[0]}) {
  0         0  
  0         0  
45            
46             # verify 3x3 scalar array
47 0 0 0     0 (3 == @{$_[0]} && 3 == @{$_[0][0]} && 3 == grep {! ref()} @{$_[0][0]}) or croak('array must contain 3x3 scalar array');
  0   0     0  
  0         0  
  0         0  
  0         0  
48            
49             # copy array
50 0         0 $self->[1] = Storable::dclone(shift());
51            
52             } else {
53            
54             # error
55 0         0 croak('invalid parameter(s) for new \'vcgt\' object');
56            
57             }
58            
59             }
60              
61             # bless object
62 1         2 bless($self, $class);
63              
64             # return object reference
65 1         2 return($self);
66              
67             }
68              
69             # create vcgt tag object from ICC profile
70             # parameters: (ref_to_parent_object, file_handle, ref_to_tag_table_entry)
71             # returns: (ref_to_object)
72             sub new_fh {
73              
74             # get object class
75 0     0 0   my $class = shift();
76              
77 0           my $self = [
78             {}, # object header
79             [[]] # array
80             ];
81              
82             # verify 3 parameters
83 0 0         (@_ == 3) or croak('wrong number of parameters');
84              
85             # read vcgt data from profile
86 0           _readICCvcgt($self, @_);
87              
88             # bless object
89 0           bless($self, $class);
90              
91             # return object reference
92 0           return($self);
93              
94             }
95              
96             # writes vcgt tag object to ICC profile
97             # parameters: (ref_to_parent_object, file_handle, ref_to_tag_table_entry)
98             sub write_fh {
99              
100             # verify 4 parameters
101 0 0   0 0   (@_ == 4) or croak('wrong number of parameters');
102              
103             # write vcgt data to profile
104 0           goto &_writeICCvcgt;
105              
106             }
107              
108             # get tag size (for writing to profile)
109             # returns: (tag_size)
110             sub size {
111              
112             # get parameters
113 0     0 0   my ($self) = @_;
114              
115             # local variables
116 0           my ($channels, $count, $size);
117              
118             # if table
119 0 0 0       if (UNIVERSAL::isa($self->[1][0], 'ICC::Profile::curv') && @{$self->[1][0]->array()} > 1) {
  0            
120            
121             # get channels
122 0           $channels = @{$self->[1]};
  0            
123            
124             # get entryCount
125 0           $count = @{$self->[1][0]->array()};
  0            
126            
127             # get entrySize
128 0 0         $size = defined($self->[0]{'entrySize'}) ? $self->[0]{'entrySize'} : 2;
129            
130             # return size
131 0           return(18 + $channels * $count * $size);
132            
133             # if function
134             } else {
135            
136             # return size
137 0           return(48);
138            
139             }
140            
141             }
142              
143             # get/set array reference
144             # parameters: ([ref_to_array])
145             # returns: (ref_to_array)
146             sub array {
147              
148             # get object reference
149 0     0 0   my $self = shift();
150              
151             # if parameter
152 0 0         if (@_) {
153            
154             # verify array reference
155 0 0         (ref($_[0]) eq 'ARRAY') or croak('not an array reference');
156            
157             # set array reference
158 0           $self->[1] = shift();
159            
160             }
161            
162             # return array reference
163 0           return($self->[1]);
164              
165             }
166              
167             # compute curve function
168             # parameters: (array_input_values -or- ref_to_input_array)
169             # returns: (array_output_values -or- ref_to_output-array)
170             sub transform {
171            
172             # get object reference
173 0     0 0   my ($self) = shift();
174            
175             # if one input parameter, an array reference
176 0 0 0       if (@_ == 1 && ref($_[0]) eq 'ARRAY') {
    0 0        
177            
178             # transform the array structure
179 0           _crawl($self, 0, $_[0], my $out = []);
180            
181             # return output reference
182 0           return($out);
183            
184             # if one input parameter, a Math::Matrix object
185             } elsif (@_ == 1 && UNIVERSAL::isa($_[0], 'Math::Matrix')) {
186            
187             # transform the array structure
188 0           _crawl($self, 0, $_[0], my $out = bless([], 'Math::Matrix'));
189            
190             # return output reference
191 0           return($out);
192            
193             } else {
194            
195             # if caller expects array
196 0 0         if (wantarray) {
197            
198             # return array
199 0           return(_transform($self, 0, @_));
200            
201             } else {
202            
203             # transform array
204 0           my @out = _transform($self, 0, @_);
205            
206             # return scalar
207 0           return($out[0]);
208            
209             }
210            
211             }
212              
213             }
214              
215             # compute inverse curve function
216             # parameters: (array_input_values -or- ref_to_input_array)
217             # returns: (array_output_values -or- ref_to_output-array)
218             sub inverse {
219            
220             # get object reference
221 0     0 0   my ($self) = shift();
222            
223             # if one input parameter, an array reference
224 0 0 0       if (@_ == 1 && ref($_[0]) eq 'ARRAY') {
    0 0        
225            
226             # transform the array structure
227 0           _crawl($self, 1, $_[0], my $out = []);
228            
229             # return output reference
230 0           return($out);
231            
232             # if one input parameter, a Math::Matrix object
233             } elsif (@_ == 1 && UNIVERSAL::isa($_[0], 'Math::Matrix')) {
234            
235             # transform the array structure
236 0           _crawl($self, 1, $_[0], my $out = bless([], 'Math::Matrix'));
237            
238             # return output reference
239 0           return($out);
240            
241             } else {
242            
243             # if caller expects array
244 0 0         if (wantarray) {
245            
246             # return array
247 0           return(_transform($self, 1, @_));
248            
249             } else {
250            
251             # transform array
252 0           my @out = _transform($self, 1, @_);
253            
254             # return scalar
255 0           return($out[0]);
256            
257             }
258            
259             }
260            
261             }
262              
263             # print object contents to string
264             # format is an array structure
265             # parameter: ([format])
266             # returns: (string)
267             sub sdump {
268              
269             # get parameters
270 0     0 1   my ($self, $p) = @_;
271              
272             # local variables
273 0           my ($s, $fmt);
274              
275             # resolve parameter to an array reference
276 0 0         $p = defined($p) ? ref($p) eq 'ARRAY' ? $p : [$p] : [];
    0          
277              
278             # get format string
279 0 0 0       $fmt = defined($p->[0]) && ! ref($p->[0]) ? $p->[0] : 'undef';
280              
281             # set string to object ID
282 0           $s = sprintf("'%s' object, (0x%x)\n", ref($self), $self);
283              
284             # return
285 0           return($s);
286              
287             }
288              
289             # recursive transform
290             # array structure is traversed until scalar arrays are found and transformed
291             # parameters: (object_reference, direction, input_array_reference, output_array_reference)
292             sub _crawl {
293            
294             # get parameters
295 0     0     my ($self, $dir, $in, $out) = @_;
296            
297             # if input is a vector (reference to a scalar array)
298 0 0         if (@{$in} == grep {! ref()} @{$in}) {
  0            
  0            
  0            
299            
300             # transform input vector and copy to output
301 0           @{$out} = _transform($self, $dir, @{$in});
  0            
  0            
302            
303             } else {
304            
305             # for each input element
306 0           for my $i (0 .. $#{$in}) {
  0            
307            
308             # if an array reference
309 0 0         if (ref($in->[$i]) eq 'ARRAY') {
310            
311             # transform next level
312 0           _crawl($self, $dir, $in->[$i], $out->[$i] = []);
313            
314             } else {
315            
316             # error
317 0           croak('invalid transform input');
318            
319             }
320            
321             }
322            
323             }
324            
325             }
326              
327             # transform input value array (vector)
328             # direction: 0 - normal, 1 - inverse
329             # parameters: (object_reference, direction, input_value_array)
330             # returns: (output_value_array)
331             sub _transform {
332              
333             # get parameters
334 0     0     my ($self, $dir, @in) = @_;
335              
336             # local variables
337 0           my (@out);
338              
339             # verify inputs are all scalars
340 0 0         (@in == grep {! ref()} @in) or croak('invalid transform input');
  0            
341              
342             # verify number of inputs equals number of channels
343 0 0         (@in == @{$self->[1]}) or croak('wrong number of input values');
  0            
344              
345             # for each channel
346 0           for my $i (0 .. $#{$self->[1]}) {
  0            
347            
348             # if 'curv' object
349 0 0         if (UNIVERSAL::isa($self->[1][$i], 'ICC::Profile::curv')) {
350            
351             # transform using 'curv' method
352 0           $out[$i] = $self->[1][$i]->_transform($dir, $in[$i]);
353            
354             } else {
355            
356             # if normal direction
357 0 0         if ($dir == 0) {
358            
359             # forward transform using formula (out = min + (max - min) * input^gamma)
360 0           $out[$i] = $self->[1][$i][1] + ($self->[1][$i][2] - $self->[1][$i][1]) * $in[$i]**$self->[1][$i][0];
361            
362             } else {
363            
364             # reverse transform using formula (out = ((input - min)/(max - min))^(1/gamma))
365 0           $out[$i] = (($in[$i] - $self->[1][$i][1])/($self->[1][$i][2] - $self->[1][$i][1]))**(1/$self->[1][$i][0]);
366            
367             }
368            
369             }
370            
371             }
372              
373             # return output array
374 0           return(@out);
375              
376             }
377              
378             # read vcgt tag from ICC profile
379             # parameters: (ref_to_object, ref_to_parent_object, file_handle, ref_to_tag_table_entry)
380             sub _readICCvcgt {
381              
382             # get parameters
383 0     0     my ($self, $parent, $fh, $tag) = @_;
384              
385             # local variables
386 0           my ($tagType, $buf, $channels, $count, $size, @table);
387              
388             # save tag signature
389 0           $self->[0]{'signature'} = $tag->[0];
390              
391             # seek start of tag
392 0           seek($fh, $tag->[1], 0);
393              
394             # read first 12 bytes
395 0           read($fh, $buf, 12);
396              
397             # unpack tagType (0 = cmVideoCardGammaTableType, 1 = cmVideoCardGammaFormulaType)
398 0           $tagType = unpack('x8 N', $buf);
399              
400             # if table
401 0 0         if ($tagType == 0) {
    0          
402            
403             # read 6 bytes
404 0           read($fh, $buf, 6);
405            
406             # unpack channels, entryCount, entrySize
407 0           ($channels, $count, $size) = unpack('n3', $buf);
408            
409             # save entrySize in header hash
410 0           $self->[0]{'entrySize'} = $size;
411            
412             # for each channel (gray or RGB)
413 0           for my $i (0 .. $channels - 1) {
414            
415             # read table data
416 0           read($fh, $buf, $count * $size);
417            
418             # if 8-bit
419 0 0         if ($size == 1) {
420            
421             # unpack table
422 0           @table = unpack('C*', $buf);
423            
424             # save as 'curv' object
425 0           $self->[1][$i] = ICC::Profile::curv->new([map {$_/255} @table]);
  0            
426            
427             # else 16-bit
428             } else {
429            
430             # unpack table
431 0           @table = unpack('n*', $buf);
432            
433             # save as 'curv' object
434 0           $self->[1][$i] = ICC::Profile::curv->new([map {$_/65535} @table]);
  0            
435            
436             }
437            
438             }
439            
440             # if formula
441             } elsif ($tagType == 1) {
442            
443             # for each RGB
444 0           for my $i (0 .. 2) {
445            
446             # read 12 bytes
447 0           read($fh, $buf, 12);
448            
449             # unpack gamma, min, max (s15Fixed16Number values)
450 0           $self->[1][$i] = [ICC::Shared::s15f162v(unpack('N3', $buf))];
451            
452             }
453            
454             } else {
455            
456             # error
457 0           croak('invalid \'vcgt\' tagType');
458            
459             }
460            
461             }
462              
463             # write vcgt tag to ICC profile
464             # parameters: (ref_to_object, ref_to_parent_object, file_handle, ref_to_tag_table_entry)
465             sub _writeICCvcgt {
466              
467             # get parameters
468 0     0     my ($self, $parent, $fh, $tag) = @_;
469              
470             # local variables
471 0           my ($tagType, $channels, $count, $size, @table, $gamma);
472              
473             # seek start of tag
474 0           seek($fh, $tag->[1], 0);
475              
476             # determine tagType (0 = cmVideoCardGammaTableType, 1 = cmVideoCardGammaFormulaType)
477 0 0 0       $tagType = (UNIVERSAL::isa($self->[1][0], 'ICC::Profile::curv') && @{$self->[1][0]->array()} > 1) ? 0 : 1;
478              
479             # write signature and tagType
480 0           print $fh pack('a4 x4 N', 'vcgt', $tagType);
481              
482             # if table
483 0 0         if ($tagType == 0) {
484            
485             # get channels
486 0           $channels = @{$self->[1]};
  0            
487            
488             # get entryCount
489 0           $count = @{$self->[1][0]->array()};
  0            
490            
491             # if entrySize is 8-bit
492 0 0 0       $size = (defined($self->[0]{'entrySize'}) && $self->[0]{'entrySize'} == 1) ? 1 : 2;
493            
494             # write channels, entryCount, entrySize
495 0           print $fh pack('n3', $channels, $count, $size);
496            
497             # for each channel (gray or RGB)
498 0           for my $i (0 .. $channels - 1) {
499            
500             # if 8-bit
501 0 0         if ($size == 1) {
502            
503             # write table limiting values, converting to 8-bit, adding 0.5 to round
504 0 0         print $fh pack('C*', map {$_ < 0 ? 0 : ($_ > 1 ? 255 : $_ * 255 + 0.5)} @{$self->[1][$i]->array()});
  0 0          
  0            
505            
506             # else 16-bit
507             } else {
508            
509             # write table limiting values, converting to 16-bit, adding 0.5 to round
510 0 0         print $fh pack('n*', map {$_ < 0 ? 0 : ($_ > 1 ? 65535 : $_ * 65535 + 0.5)} @{$self->[1][$i]->array()});
  0 0          
  0            
511            
512             }
513            
514             }
515            
516             # if formula
517             } else {
518            
519             # if gamma type 'curv' objects
520 0 0         if (UNIVERSAL::isa($self->[1][0], 'ICC::Profile::curv')) {
521            
522             # for each RGB
523 0           for my $i (0 .. 2) {
524            
525             # get 'curv' object index (could be just one 'curv')
526 0 0         my $j = defined($self->[1][$i]) ? $i : 0;
527            
528             # get gamma (use 1.0 if undefined)
529 0 0         $gamma = defined($self->[1][$j]->array->[0]) ? $self->[1][$j]->array->[0] : 1;
530            
531             # write gamma, min, max (s15Fixed16Number values)
532 0           print $fh pack('N3', ICC::Shared::v2s15f16($gamma, 0, 1));
533            
534             }
535            
536             # if numeric array
537             } else {
538            
539             # for each RGB
540 0           for my $i (0 .. 2) {
541            
542             # write gamma, min, max (s15Fixed16Number values)
543 0           print $fh pack('N3', ICC::Shared::v2s15f16(@{$self->[1][$i]}));
  0            
544            
545             }
546            
547             }
548            
549             }
550            
551             }
552              
553             1;