File Coverage

blib/lib/ICC/Profile/mAB_.pm
Criterion Covered Total %
statement 206 457 45.0
branch 48 220 21.8
condition 11 98 11.2
subroutine 11 35 31.4
pod 2 21 9.5
total 278 831 33.4


line stmt bran cond sub pod time code
1             package ICC::Profile::mAB_;
2              
3 2     2   73100 use strict;
  2         4  
  2         91  
4 2     2   10 use Carp;
  2         5  
  2         112  
5              
6             our $VERSION = 2.51;
7              
8             # revised 2018-08-07
9             #
10             # Copyright © 2004-2020 by William B. Birkett
11              
12             # inherit from Shared
13 2     2   10 use parent qw(ICC::Shared);
  2         4  
  2         14  
14              
15             # use POSIX math
16 2     2   94 use POSIX ();
  2         4  
  2         8781  
17              
18             # create new mAB_ object
19             # hash may contain pointers to B-curves, matrix, M-curves, CLUT, or A-curves
20             # keys are: ('b_curves', 'matrix', 'm_curves', 'clut', 'a_curves')
21             # tag elements not specified in the hash are left empty
22             # parameters: ()
23             # parameters: (ref_to_attribute_hash)
24             # parameters: (ref_to_matrix-based_profile_object)
25             # returns: (ref_to_object)
26             sub new {
27              
28             # get object class
29 1     1 0 905 my $class = shift();
30              
31             # create empty mAB_ object
32 1         3 my $self = [
33             {}, # object header
34             [], # processing elements
35             0x00, # transform mask
36             0x00 # clipping mask
37             ];
38              
39             # if there are parameters
40 1 50       4 if (@_) {
41            
42             # if one parameter, a hash reference
43 0 0 0     0 if (@_ == 1 && ref($_[0]) eq 'HASH') {
    0 0        
44            
45             # make new mAB_ tag from attribute hash
46 0         0 _new_from_hash($self, @_);
47            
48             # if one parameter, an ICC::Profile object
49             } elsif (@_ == 1 && UNIVERSAL::isa($_[0], 'ICC::Profile')) {
50              
51             # make new mAB_ tag from ICC::Profile object
52 0         0 _newICCmatrix($self, @_);
53              
54             } else {
55            
56             # error
57 0         0 croak('parameter must be a hash reference or a display matrix profile');
58            
59             }
60            
61             }
62              
63             # bless object
64 1         2 bless($self, $class);
65              
66             # return object reference
67 1         2 return($self);
68              
69             }
70              
71             # get/set reference to header hash
72             # parameters: ([ref_to_new_hash])
73             # returns: (ref_to_hash)
74             sub header {
75              
76             # get object reference
77 0     0 0 0 my $self = shift();
78              
79             # if there are parameters
80 0 0       0 if (@_) {
81            
82             # if one parameter, a hash reference
83 0 0 0     0 if (@_ == 1 && ref($_[0]) eq 'HASH') {
84            
85             # set header to new hash
86 0         0 $self->[0] = shift();
87            
88             } else {
89            
90             # error
91 0         0 croak('parameter must be a hash reference');
92            
93             }
94            
95             }
96              
97             # return reference
98 0         0 return($self->[0]);
99              
100             }
101              
102             # get/set processing element array reference
103             # parameters: ([ref_to_array])
104             # returns: (ref_to_array)
105             sub array {
106              
107             # get object reference
108 0     0 0 0 my $self = shift();
109              
110             # if parameter
111 0 0       0 if (@_) {
112            
113             # verify array reference
114 0 0       0 (ref($_[0]) eq 'ARRAY') or croak('not an array reference');
115            
116             # set array reference
117 0         0 $self->[1] = [@{shift()}];
  0         0  
118            
119             }
120              
121             # return array reference
122 0         0 return($self->[1]);
123              
124             }
125              
126             # get/set reference to B-curves 'cvst' object
127             # parameters: ([ref_to_new_object])
128             # returns: (ref_to_object)
129             sub b_curves {
130              
131             # get object reference
132 0     0 0 0 my $self = shift();
133              
134             # if there are parameters
135 0 0       0 if (@_) {
136            
137             # if one parameter, a 'cvst' object
138 0 0 0     0 if (@_ == 1 && UNIVERSAL::isa($_[0], 'ICC::Profile::cvst')) {
139            
140             # set B-curves to new object
141 0         0 $self->[1][0] = shift();
142            
143             # set transform mask bit
144 0         0 $self->[2] |= 0x01;
145            
146             } else {
147            
148             # error
149 0         0 croak('parameter must be a \'cvst\' object');
150            
151             }
152            
153             }
154              
155             # return object reference
156 0         0 return($self->[1][0]);
157              
158             }
159              
160             # get/set reference to matrix 'matf' object
161             # parameters: ([ref_to_new_object])
162             # returns: (ref_to_object)
163             sub matrix {
164              
165             # get object reference
166 0     0 0 0 my $self = shift();
167              
168             # if there are parameters
169 0 0       0 if (@_) {
170            
171             # if one parameter, an 'matf' object
172 0 0 0     0 if (@_ == 1 && UNIVERSAL::isa($_[0], 'ICC::Profile::matf')) {
173            
174             # set matrix to new object
175 0         0 $self->[1][1] = shift();
176            
177             # set transform mask bit
178 0         0 $self->[2] |= 0x02;
179            
180             } else {
181            
182             # error
183 0         0 croak('parameter must be an \'matf\' object');
184            
185             }
186            
187             }
188              
189             # return object reference
190 0         0 return($self->[1][1]);
191              
192             }
193              
194             # get/set reference to M-curves 'cvst' object
195             # parameters: ([ref_to_new_object])
196             # returns: (ref_to_object)
197             sub m_curves {
198              
199             # get object reference
200 0     0 0 0 my $self = shift();
201              
202             # if there are parameters
203 0 0       0 if (@_) {
204            
205             # if one parameter, a 'cvst' object
206 0 0 0     0 if (@_ == 1 && UNIVERSAL::isa($_[0], 'ICC::Profile::cvst')) {
207            
208             # set M-curves to new object
209 0         0 $self->[1][2] = shift();
210            
211             # set transform mask bit
212 0         0 $self->[2] |= 0x04;
213            
214             } else {
215            
216             # error
217 0         0 croak('parameter must be a \'cvst\' object');
218            
219             }
220            
221             }
222              
223             # return object reference
224 0         0 return($self->[1][2]);
225              
226             }
227              
228             # get/set reference to CLUT 'clut' object
229             # parameters: ([ref_to_new_object])
230             # returns: (ref_to_object)
231             sub clut {
232              
233             # get object reference
234 0     0 0 0 my $self = shift();
235              
236             # if there are parameters
237 0 0       0 if (@_) {
238            
239             # if one parameter, a 'clut' object
240 0 0 0     0 if (@_ == 1 && UNIVERSAL::isa($_[0], 'ICC::Profile::clut')) {
241            
242             # set CLUT to new object
243 0         0 $self->[1][3] = shift();
244            
245             # set transform mask bit
246 0         0 $self->[2] |= 0x08;
247            
248             } else {
249            
250             # error
251 0         0 croak('parameter must be a \'clut\' object');
252            
253             }
254            
255             }
256              
257             # return object reference
258 0         0 return($self->[1][3]);
259              
260             }
261              
262             # get/set reference to A-curves 'cvst' object
263             # parameters: ([ref_to_new_object])
264             # returns: (ref_to_object)
265             sub a_curves {
266              
267             # get object reference
268 0     0 0 0 my $self = shift();
269              
270             # if there are parameters
271 0 0       0 if (@_) {
272            
273             # if one parameter, a 'cvst' object
274 0 0 0     0 if (@_ == 1 && UNIVERSAL::isa($_[0], 'ICC::Profile::cvst')) {
275            
276             # set A-curves to new object
277 0         0 $self->[1][4] = shift();
278            
279             # set transform mask bit
280 0         0 $self->[2] |= 0x10;
281            
282             } else {
283            
284             # error
285 0         0 croak('parameter must be a \'cvst\' object');
286            
287             }
288            
289             }
290              
291             # return object reference
292 0         0 return($self->[1][4]);
293              
294             }
295              
296             # get/set transform mask
297             # bits 4-3-2-1-0 correpsond to A-CLUT-M-MATRIX-B
298             # parameters: ([new_mask_value])
299             # returns: (mask_value)
300             sub mask {
301              
302             # get object reference
303 0     0 0 0 my $self = shift();
304              
305             # if there are parameters
306 0 0       0 if (@_) {
307            
308             # if one parameter
309 0 0       0 if (@_ == 1) {
310            
311             # set object transform mask value
312 0         0 $self->[2] = shift();
313            
314             } else {
315            
316             # error
317 0         0 croak('more than one parameter');
318            
319             }
320            
321             }
322              
323             # return transform mask value
324 0         0 return($self->[2]);
325              
326             }
327              
328             # get/set clipping mask
329             # bits 4-3-2-1-0 correpsond to A-CLUT-M-MATRIX-B
330             # parameters: ([new_mask_value])
331             # returns: (mask_value)
332             sub clip {
333            
334             # get object reference
335 0     0 1 0 my $self = shift();
336            
337             # if there are parameters
338 0 0       0 if (@_) {
339            
340             # if one parameter
341 0 0       0 if (@_ == 1) {
342            
343             # set object clipping mask value
344 0         0 $self->[3] = shift();
345            
346             } else {
347            
348             # error
349 0         0 croak('more than one parameter');
350            
351             }
352            
353             }
354            
355             # return clipping mask value
356 0         0 return($self->[3]);
357            
358             }
359              
360             # create mAB_ tag object from ICC profile
361             # parameters: (ref_to_parent_object, file_handle, ref_to_tag_table_entry)
362             # returns: (ref_to_object)
363             sub new_fh {
364              
365             # get object class
366 1     1 0 510 my $class = shift();
367              
368             # create empty mAB_ object
369 1         3 my $self = [
370             {}, # object header
371             [], # processing elements
372             0x00, # transform mask
373             0x00 # clipping mask
374             ];
375              
376             # verify 3 parameters
377 1 50       4 (@_ == 3) or croak('wrong number of parameters');
378              
379             # read mAB_ data from profile
380 1         3 _readICCmAB_($self, @_);
381              
382             # bless object
383 1         1 bless($self, $class);
384              
385             # return object reference
386 1         8 return($self);
387              
388             }
389              
390             # writes mAB_ tag object to ICC profile
391             # parameters: (ref_to_parent_object, file_handle, ref_to_tag_table_entry)
392             sub write_fh {
393              
394             # verify 4 parameters
395 1 50   1 0 903 (@_ == 4) or croak('wrong number of parameters');
396              
397             # write mAB_ data to profile
398 1         4 goto &_writeICCmAB_;
399              
400             }
401              
402             # get tag size (for writing to profile)
403             # returns: (tag_clut_size)
404             sub size {
405              
406             # get parameters
407 3     3 0 417 my ($self) = @_;
408              
409             # local variables
410 3         5 my ($size);
411              
412             # set header size
413 3         5 $size = 32;
414              
415             # for each B-curve
416 3         3 for my $curve (@{$self->[1][0]->array()}) {
  3         13  
417            
418             # add curve size
419 9         20 $size += $curve->size;
420            
421             # pad to 4-bytes
422 9         23 $size += (-$size % 4);
423            
424             }
425              
426             # if matrix defined
427 3 50       11 if (defined($self->[1][1])) {
428            
429             # add matrix size (48 bytes)
430 3         5 $size += 48;
431            
432             }
433              
434             # if M-curves defined
435 3 50       6 if (defined($self->[1][2])) {
436            
437             # for each M-curve
438 3         4 for my $curve (@{$self->[1][2]->array()}) {
  3         6  
439            
440             # add curve size
441 9         17 $size += $curve->size;
442            
443             # pad to 4-bytes
444 9         13 $size += (-$size % 4);
445            
446             }
447            
448             }
449              
450             # if CLUT defined
451 3 50       8 if (defined($self->[1][3])) {
452            
453             # add CLUT size (nCLUT object)
454 3   50     15 $size += 20 + $self->[1][3]->_clut_size($self->[1][3][0]{'clut_bytes'} || 2);
455            
456             # pad to 4-byte boundary
457 3         6 $size += (-$size % 4);
458            
459             }
460              
461             # if A-curves defined
462 3 50       7 if (defined($self->[1][4])) {
463            
464             # for each A-curve
465 3         4 for my $curve (@{$self->[1][4]->array()}) {
  3         9  
466            
467             # add curve size
468 9         23 $size += $curve->size;
469            
470             # pad to 4-bytes
471 9         14 $size += (-$size % 4);
472            
473             }
474            
475             }
476              
477             # return size
478 3         108 return($size);
479              
480             }
481              
482             # get number of input channels
483             # returns: (number)
484             sub cin {
485              
486             # get object reference
487 0     0 0 0 my $self = shift();
488              
489             # return
490 0         0 return($self->[1][-1]->cin());
491              
492             }
493              
494             # get number of output channels
495             # returns: (number)
496             sub cout {
497              
498             # get object reference
499 0     0 0 0 my $self = shift();
500              
501             # return
502 0         0 return($self->[1][0]->cout());
503              
504             }
505              
506             # transform data
507             # transform mask enables/disables individual tag elements
508             # clipping mask enables/disables individual tag output clipping
509             # supported input types:
510             # parameters: (list, [hash])
511             # parameters: (vector, [hash])
512             # parameters: (matrix, [hash])
513             # parameters: (Math::Matrix_object, [hash])
514             # parameters: (structure, [hash])
515             # returns: (same_type_as_input)
516             sub transform {
517              
518             # set hash value (0 or 1)
519 0 0   0 0 0 my $h = ref($_[-1]) eq 'HASH' ? 1 : 0;
520              
521             # if input a 'Math::Matrix' object
522 0 0 0     0 if (@_ == $h + 2 && UNIVERSAL::isa($_[1], 'Math::Matrix')) {
    0 0        
    0          
523            
524             # call matrix transform
525 0         0 &_trans2;
526            
527             # if input an array reference
528             } elsif (@_ == $h + 2 && ref($_[1]) eq 'ARRAY') {
529            
530             # if array contains numbers (vector)
531 0 0 0     0 if (! ref($_[1][0]) && @{$_[1]} == grep {Scalar::Util::looks_like_number($_)} @{$_[1]}) {
  0 0 0     0  
  0         0  
  0         0  
532            
533             # call vector transform
534 0         0 &_trans1;
535            
536             # if array contains vectors (2-D array)
537 0 0       0 } elsif (ref($_[1][0]) eq 'ARRAY' && @{$_[1]} == grep {ref($_) eq 'ARRAY' && Scalar::Util::looks_like_number($_->[0])} @{$_[1]}) {
  0         0  
  0         0  
538            
539             # call matrix transform
540 0         0 &_trans2;
541            
542             } else {
543            
544             # call structure transform
545 0         0 &_trans3;
546            
547             }
548            
549             # if input a list (of numbers)
550 0         0 } elsif (@_ == $h + 1 + grep {Scalar::Util::looks_like_number($_)} @_) {
551            
552             # call list transform
553 0         0 &_trans0;
554            
555             } else {
556            
557             # error
558 0         0 croak('invalid transform input');
559            
560             }
561              
562             }
563              
564             # inverse transform
565             # note: number of undefined output values must equal number of defined input values
566             # note: the input and output vectors contain the final solution on return
567             # hash key 'init' specifies initial value vector
568             # hash key 'ubox' enables unit box extrapolation
569             # parameters: (input_vector, output_vector, [hash])
570             # returns: (RMS_error_value)
571             sub inverse {
572              
573             # get parameters
574 0     0 0 0 my ($self, $in, $out, $hash) = @_;
575              
576             # local variables
577 0         0 my ($i, $j, @si, @so, $init);
578 0         0 my ($int, $jac, $mat, $delta);
579 0         0 my ($max, $elim, $dlim, $accum, $error);
580              
581             # initialize indices
582 0         0 $i = $j = -1;
583              
584             # build slice arrays while validating input and output arrays
585 0 0       0 ((grep {$i++; defined() && push(@si, $i)} @{$in}) == (grep {$j++; ! defined() && push(@so, $j)} @{$out})) or croak('wrong number of undefined values');
  0 0       0  
  0 0       0  
  0         0  
  0         0  
  0         0  
  0         0  
586              
587             # get init array
588 0         0 $init = $hash->{'init'};
589              
590             # for each undefined output value
591 0         0 for my $i (@so) {
592            
593             # set to supplied initial value or 0.5
594 0 0       0 $out->[$i] = defined($init->[$i]) ? $init->[$i] : 0.5;
595            
596             }
597              
598             # set maximum loop count
599 0   0     0 $max = $hash->{'inv_max'} || 10;
600              
601             # loop error limit
602 0   0     0 $elim = $hash->{'inv_elim'} || 1E-6;
603              
604             # set delta limit
605 0   0     0 $dlim = $hash->{'inv_dlim'} || 0.5;
606              
607             # create empty solution matrix
608 0         0 $mat = Math::Matrix->new([]);
609              
610             # compute initial transform values
611 0         0 ($jac, $int) = jacobian($self, $out, $hash);
612              
613             # solution loop
614 0         0 for (1 .. $max) {
615            
616             # for each input
617 0         0 for my $i (0 .. $#si) {
618            
619             # for each output
620 0         0 for my $j (0 .. $#so) {
621            
622             # copy Jacobian value to solution matrix
623 0         0 $mat->[$i][$j] = $jac->[$si[$i]][$so[$j]];
624            
625             }
626            
627             # save residual value to solution matrix
628 0         0 $mat->[$i][$#si + 1] = $in->[$si[$i]] - $int->[$si[$i]];
629            
630             }
631            
632             # solve for delta values
633 0         0 $delta = $mat->solve;
634            
635             # for each output value
636 0         0 for my $i (0 .. $#so) {
637            
638             # add delta (limited using hyperbolic tangent)
639 0         0 $out->[$so[$i]] += POSIX::tanh($delta->[$i][0]/$dlim) * $dlim;
640            
641             }
642            
643             # compute updated transform values
644 0         0 ($jac, $int) = jacobian($self, $out, $hash);
645            
646             # initialize error accumulator
647 0         0 $accum = 0;
648            
649             # for each input
650 0         0 for my $i (0 .. $#si) {
651            
652             # accumulate delta squared
653 0         0 $accum += ($in->[$si[$i]] - $int->[$si[$i]])**2;
654            
655             }
656            
657             # compute RMS error
658 0         0 $error = sqrt($accum/@si);
659            
660             # if error less than limit
661 0 0       0 last if ($error < $elim);
662            
663             }
664              
665             # update input vector with final values
666 0         0 @{$in} = @{$int};
  0         0  
  0         0  
667              
668             # return
669 0         0 return($error);
670              
671             }
672              
673             # compute Jacobian matrix
674             # transform mask enables/disables individual tag elements
675             # parameters: (input_vector, [hash])
676             # returns: (Jacobian_matrix, [output_vector])
677             sub jacobian {
678              
679             # get parameters
680 0     0 0 0 my ($self, $data, $hash) = @_;
681              
682             # local variables
683 0         0 my ($jac, $jaci);
684              
685             # for each processing element (note: sequence is from the last element to the first)
686 0         0 for my $i (reverse(0 .. $#{$self->[1]})) {
  0         0  
687            
688             # if processing element defined, and transform mask bit set
689 0 0 0     0 if (defined($self->[1][$i]) && $self->[2] & 0x01 << $i) {
690            
691             # compute Jacobian matrix and transform data
692 0         0 ($jaci, $data) = $self->[1][$i]->jacobian($data, $hash);
693            
694             # multiply Jacobian matrices
695 0 0       0 $jac = defined($jac) ? $jaci * $jac : $jaci;
696            
697             }
698            
699             }
700              
701             # if Jacobian matrix is undefined, use identity matrix
702 0 0       0 $jac = Math::Matrix->diagonal((1) x @{$data}) if (! defined($jac));
  0         0  
703              
704             # if output values wanted
705 0 0       0 if (wantarray) {
706            
707             # return Jacobian and output values
708 0         0 return($jac, $data);
709            
710             } else {
711            
712             # return Jacobian only
713 0         0 return($jac);
714            
715             }
716            
717             }
718              
719             # get/set PCS encoding
720             # for use with ICC::Support::PCS objects
721             # parameters: ([PCS_encoding])
722             # returns: (PCS_encoding)
723             sub pcs {
724              
725             # get parameters
726 0     0 0 0 my ($self, $pcs) = @_;
727              
728             # if PCS parameter is supplied
729 0 0       0 if (defined($pcs)) {
730            
731             # if a valid PCS encoding
732 0 0       0 if (grep {$pcs == $_} (3, 8)) {
  0         0  
733            
734             # copy to tag header hash
735 0         0 $self->[0]{'pcs_encoding'} = $pcs;
736            
737             # return PCS encoding
738 0         0 return($pcs);
739            
740             } else {
741            
742             # error
743 0         0 croak('invalid PCS encoding');
744            
745             }
746            
747             } else {
748            
749             # if PCS is defined in tag header
750 0 0       0 if (defined($self->[0]{'pcs_encoding'})) {
751            
752             # return PCS encoding
753 0         0 return($self->[0]{'pcs_encoding'});
754            
755             } else {
756            
757             # error
758 0         0 croak('can\'t determine PCS encoding');
759            
760             }
761            
762             }
763            
764             }
765              
766             # get/set white point
767             # parameters: ([white_point])
768             # returns: (white_point)
769             sub wtpt {
770              
771             # get parameters
772 0     0 0 0 my ($self, $wtpt) = @_;
773              
774             # if white point parameter is supplied
775 0 0       0 if (defined($wtpt)) {
776            
777             # if an array of three scalars
778 0 0 0     0 if (@{$wtpt} == 3 && 3 == grep {! ref()} @{$wtpt}) {
  0         0  
  0         0  
  0         0  
779            
780             # copy to tag header hash
781 0         0 $self->[0]{'wtpt'} = $wtpt;
782            
783             # return white point
784 0         0 return($wtpt);
785            
786             } else {
787            
788             # error
789 0         0 croak('invalid white point');
790            
791             }
792            
793             } else {
794            
795             # if white point is defined in tag header
796 0 0       0 if (defined($self->[0]{'wtpt'})) {
797            
798             # return return white point
799 0         0 return($self->[0]{'wtpt'});
800            
801             } else {
802            
803             # error
804 0         0 croak('can\'t determine white point');
805            
806             }
807            
808             }
809            
810             }
811              
812             # print object contents to string
813             # format is an array structure
814             # parameter: ([format])
815             # returns: (string)
816             sub sdump {
817              
818             # get parameters
819 0     0 1 0 my ($self, $p) = @_;
820              
821             # local variables
822 0         0 my ($element, $fmt, $s, $pt, $st);
823              
824             # resolve parameter to an array reference
825 0 0       0 $p = defined($p) ? ref($p) eq 'ARRAY' ? $p : [$p] : [];
    0          
826              
827             # get format string
828 0 0 0     0 $fmt = defined($p->[0]) && ! ref($p->[0]) ? $p->[0] : 's';
829              
830             # set string to object ID
831 0         0 $s = sprintf("'%s' object, (0x%x)\n", ref($self), $self);
832              
833             # if format contains 'o'
834 0 0       0 if ($fmt =~ m/s/) {
835            
836             # get default parameter
837 0         0 $pt = $p->[-1];
838            
839             # for each processing element
840 0         0 for my $i (0 .. $#{$self->[1]}) {
  0         0  
841            
842             # get element reference
843 0         0 $element = $self->[1][$i];
844            
845             # if processing element is undefined
846 0 0       0 if (! defined($element)) {
    0          
    0          
847            
848             # append message
849 0         0 $s .= "\tprocessing element is undefined\n";
850            
851             # if processing element is not a blessed object
852             } elsif (! Scalar::Util::blessed($element)) {
853            
854             # append message
855 0         0 $s .= "\tprocessing element is not a blessed object\n";
856            
857             # if processing element has an 'sdump' method
858             } elsif ($element->can('sdump')) {
859            
860             # get 'sdump' string
861 0 0       0 $st = $element->sdump(defined($p->[$i + 1]) ? $p->[$i + 1] : $pt);
862            
863             # prepend tabs to each line
864 0         0 $st =~ s/^/\t/mg;
865            
866             # append 'sdump' string
867 0         0 $s .= $st;
868            
869             # processing element is object without an 'sdump' method
870             } else {
871            
872             # append object info
873 0         0 $s .= sprintf("\t'%s' object, (0x%x)\n", ref($element), $element);
874            
875             }
876            
877             }
878            
879             }
880              
881             # return
882 0         0 return($s);
883              
884             }
885              
886             # transform list
887             # parameters: (object_reference, list, [hash])
888             # returns: (list)
889             sub _trans0 {
890              
891             # local variables
892 0     0   0 my ($self, $hash, $data);
893              
894             # get object reference
895 0         0 $self = shift();
896              
897             # get optional hash
898 0 0       0 $hash = pop() if (ref($_[-1]) eq 'HASH');
899              
900             # process data
901 0         0 $data = _trans1($self, [@_], $hash);
902              
903             # return list
904 0         0 return(@{$data});
  0         0  
905              
906             }
907              
908             # transform vector
909             # parameters: (object_reference, vector, [hash])
910             # returns: (vector)
911             sub _trans1 {
912              
913             # get parameters
914 0     0   0 my ($self, $data, $hash) = @_;
915              
916             # for each processing element (note: sequence is from the last element to the first)
917 0         0 for my $i (reverse(0 .. $#{$self->[1]})) {
  0         0  
918            
919             # if processing element defined, and transform mask bit set
920 0 0 0     0 if (defined($self->[1][$i]) && $self->[2] & 0x01 << $i) {
921            
922             # transform data
923 0         0 $data = $self->[1][$i]->_trans1($data, $hash);
924            
925             # clip output values if clipping mask bit set
926 0 0       0 ICC::Shared::clip_struct($data) if ($self->[3] & 0x01 << $i);
927            
928             }
929            
930             }
931            
932             # return
933 0         0 return($data);
934            
935             }
936              
937             # transform matrix (2-D array -or- Math::Matrix object)
938             # parameters: (object_reference, matrix, [hash])
939             # returns: (matrix)
940             sub _trans2 {
941              
942             # get parameters
943 0     0   0 my ($self, $data, $hash) = @_;
944              
945             # for each processing element (note: sequence is from the last element to the first)
946 0         0 for my $i (reverse(0 .. $#{$self->[1]})) {
  0         0  
947            
948             # if processing element defined, and transform mask bit set
949 0 0 0     0 if (defined($self->[1][$i]) && $self->[2] & 0x01 << $i) {
950            
951             # transform data
952 0         0 $data = $self->[1][$i]->_trans2($data, $hash);
953            
954             # clip output values if clipping mask bit set
955 0 0       0 ICC::Shared::clip_struct($data) if ($self->[3] & 0x01 << $i);
956            
957             }
958            
959             }
960              
961             # return
962 0         0 return($data);
963              
964             }
965              
966             # transform structure
967             # parameters: (object_reference, structure, [hash])
968             # returns: (structure)
969             sub _trans3 {
970              
971             # get parameters
972 0     0   0 my ($self, $in, $hash) = @_;
973              
974             # transform the array structure
975 0         0 _crawl($self, $in, my $out = [], $hash);
976              
977             # return
978 0         0 return($out);
979              
980             }
981              
982             # recursive transform
983             # array structure is traversed until scalar arrays are found and transformed
984             # parameters: (ref_to_object, input_array_reference, output_array_reference, hash)
985             sub _crawl {
986              
987             # get parameters
988 0     0   0 my ($self, $in, $out, $hash) = @_;
989              
990             # if input is a vector (reference to a scalar array)
991 0 0       0 if (@{$in} == grep {! ref()} @{$in}) {
  0         0  
  0         0  
  0         0  
992            
993             # transform input vector and copy to output
994 0         0 @{$out} = @{_trans1($self, $in, $hash)};
  0         0  
  0         0  
995            
996             } else {
997            
998             # for each input element
999 0         0 for my $i (0 .. $#{$in}) {
  0         0  
1000            
1001             # if an array reference
1002 0 0       0 if (ref($in->[$i]) eq 'ARRAY') {
1003            
1004             # transform next level
1005 0         0 _crawl($self, $in->[$i], $out->[$i] = [], $hash);
1006            
1007             } else {
1008            
1009             # error
1010 0         0 croak('invalid transform input');
1011            
1012             }
1013            
1014             }
1015            
1016             }
1017            
1018             }
1019              
1020             # check object structure
1021             # parameter: (ref_to_object)
1022             # returns: (number_input_channels, number_output_channels)
1023             sub _check {
1024              
1025             # get object reference
1026 1     1   2 my $self = shift();
1027              
1028             # local variables
1029 1         2 my (@class, $ci, $co);
1030              
1031             # make object class array
1032 1         2 @class = qw(ICC::Profile::cvst ICC::Profile::matf ICC::Profile::cvst ICC::Profile::clut ICC::Profile::cvst);
1033              
1034             # verify number of processing elements
1035 1 50       2 ($#{$self->[1]} <= 4) or croak('\'mAB_\' object has too many processing elements');
  1         4  
1036              
1037             # for each processing element (note: sequence is from the last element to the first)
1038 1         2 for my $i (reverse(0 .. $#{$self->[1]})) {
  1         3  
1039            
1040             # if element is defined (matrix and M-curves to may be undefined)
1041 5 50       10 if (defined($self->[1][$i])) {
1042            
1043             # verify element has correct class
1044 5 50       10 (ref($self->[1][$i]) eq $class[$i]) or croak("'mAB_' processing element $i has wrong class");
1045            
1046             # if element has 'cin' method
1047 5 50       23 if ($self->[1][$i]->can('cin')) {
1048            
1049             # if number of input channels is undefined
1050 5 100       9 if (! defined($ci)) {
1051            
1052             # set number of input channels
1053 1         10 $ci = $self->[1][$i]->cin();
1054            
1055             }
1056            
1057             # if number of output channels is defined
1058 5 100       10 if (defined($co)) {
1059            
1060             # verify input channels of this element match output channels of previous element
1061 4 50       9 ($self->[1][$i]->cin() == $co) or croak("'mAB_' processing element $i has wrong number of channels");
1062            
1063             }
1064            
1065             }
1066            
1067             # if element has 'cout' method
1068 5 50       14 if ($self->[1][$i]->can('cout')) {
1069            
1070             # set number of output channels
1071 5         12 $co = $self->[1][$i]->cout();
1072            
1073             }
1074            
1075             }
1076            
1077             }
1078              
1079             # verify B-curves are defined
1080 1 50       4 (defined($self->[1][0])) or croak('B-curves are required');
1081              
1082             # verify matrix and M-curves are both defined, or neither
1083 1 50 25     6 (defined($self->[1][1]) xor defined($self->[1][2])) && croak('matrix and M-curves must both be defined, or neither');
1084              
1085             # verify CLUT and A-curves are both defined, or neither
1086 1 50 25     12 (defined($self->[1][3]) xor defined($self->[1][4])) && croak('CLUT and A-curves must both be defined, or neither');
1087              
1088             # if matrix defined
1089 1 50       3 if (defined($self->[1][1])) {
1090            
1091             # verify object has 3 output channels
1092 1 50       3 ($co == 3) or croak("matrix processing element not permitted with $co output channels");
1093            
1094             # verify matrix size (3x3)
1095 1 50 33     3 ($self->[1][1]->cin() == 3 && $self->[1][1]->cout() == 3) or croak('matrix processing element matrix wrong size');
1096            
1097             # verify offset size (undefined, 0 or 3)
1098 1 50 33     4 (! defined($self->[1][1][2]) || @{$self->[1][1][2]} == 0 || @{$self->[1][1][2]} == 3) or croak('matrix processing element offset wrong size');
  1   33     5  
  1         8  
1099            
1100             }
1101              
1102             # return
1103 1         10 return($ci, $co);
1104              
1105             }
1106              
1107             # set M-curves, matrix, and B-curves
1108             # equivalent to a matrix-based display profile
1109             # parameters: (ref_to_object, ref_to_profile_object)
1110             sub _newICCmatrix {
1111              
1112             # get parameters
1113 0     0   0 my ($self, $disp) = @_;
1114              
1115             # local variables
1116 0         0 my (@XYZ, @TRC, $wtpt, $bkpt, $id, $mat);
1117              
1118             # verify an RGB/XYZ display profile
1119 0 0 0     0 (UNIVERSAL::isa($disp, 'ICC::Profile') && $disp->profile_header->[3] eq 'mntr' && $disp->profile_header->[4] eq 'RGB ' && $disp->profile_header->[5] eq 'XYZ ') or croak('not an RGB-XYZ display profile');
      0        
      0        
1120              
1121             # get primary tags
1122 0         0 @XYZ = $disp->tag(qw(rXYZ gXYZ bXYZ));
1123              
1124             # get TRC tags
1125 0         0 @TRC = $disp->tag(qw(rTRC gTRC bTRC));
1126              
1127             # verify a matrix profile
1128 0 0 0     0 (@XYZ == 3 && @TRC == 3) or croak('not a matrix profile');
1129              
1130             # set input colorspace
1131 0         0 $self->[0]{'input_cs'} = 'RGB ';
1132              
1133             # set output colorspace
1134 0         0 $self->[0]{'output_cs'} = 'XYZ ';
1135              
1136             # set PCS encoding
1137 0         0 $self->[0]{'pcs_encoding'} = 7;
1138              
1139             # get white point tag
1140 0         0 $wtpt = $disp->tag('wtpt');
1141              
1142             # set white point value
1143 0 0       0 $self->[0]{'wtpt'} = [@{$wtpt->XYZ}] if (defined($wtpt));
  0         0  
1144              
1145             # get black point tag
1146 0         0 $bkpt = $disp->tag('bkpt');
1147              
1148             # set black point value
1149 0 0       0 $self->[0]{'bkpt'} = [@{$bkpt->XYZ}] if (defined($bkpt));
  0         0  
1150              
1151             # make identity curve
1152 0         0 $id = ICC::Profile::curv->new();
1153              
1154             # make Math::Matrix object from primary tags
1155 0         0 $mat = Math::Matrix->new(map {$_->XYZ()} @XYZ)->transpose->multiply_scalar(32768/65535);
  0         0  
1156              
1157             # set B-curves
1158 0         0 $self->[1][0] = ICC::Profile::cvst->new([$id, $id, $id]);
1159              
1160             # set matrix
1161 0         0 $self->[1][1] = ICC::Profile::matf->new({'matrix' => $mat});
1162              
1163             # set M-curves
1164 0         0 $self->[1][2] = ICC::Profile::cvst->new(Storable::dclone(\@TRC));
1165              
1166             # set transform mask
1167 0         0 $self->[2] = 0x07;
1168              
1169             }
1170              
1171             # make new mAB_ tag from attribute hash
1172             # hash may contain pointers to B-curves, matrix, M-curves, CLUT, or A-curves
1173             # keys are: ('b_curves', 'matrix', 'm_curves', 'clut', 'a_curves')
1174             # tag elements not specified in the hash are left empty
1175             # parameters: (ref_to_object, ref_to_attribute_hash)
1176             sub _new_from_hash {
1177              
1178             # get parameters
1179 0     0   0 my ($self, $hash) = @_;
1180              
1181             # set attribute list (key => [reference_type, array_index])
1182 0         0 my %list = ('b_curves' => ['ICC::Profile::cvst', 0], 'matrix' => ['ICC::Profile::matf', 1], 'm_curves' => ['ICC::Profile::cvst', 2], 'clut' => ['ICC::Profile::clut', 3], 'a_curves' => ['ICC::Profile::cvst', 4]);
1183              
1184             # for each attribute
1185 0         0 for my $attr (keys(%{$hash})) {
  0         0  
1186            
1187             # if value defined
1188 0 0       0 if (defined($hash->{$attr})) {
1189            
1190             # if correct reference type
1191 0 0       0 if (ref($hash->{$attr}) eq $list{$attr}[0]) {
1192            
1193             # set tag element
1194 0         0 $self->[1][$list{$attr}[1]] = $hash->{$attr};
1195            
1196             # set transform mask bit
1197 0         0 $self->[2] |= (0x01 << $list{$attr}[1]);
1198            
1199             } else {
1200            
1201             # error
1202 0         0 croak("wrong object type for $attr key");
1203            
1204             }
1205            
1206             }
1207            
1208             }
1209            
1210             }
1211              
1212             # read mAB_ tag from ICC profile
1213             # parameters: (ref_to_object, ref_to_parent_object, file_handle, ref_to_tag_table_entry)
1214             sub _readICCmAB_ {
1215              
1216             # get parameters
1217 1     1   3 my ($self, $parent, $fh, $tag) = @_;
1218              
1219             # local variables
1220 1         2 my ($buf, @mft, $pel, $mark, @mat, $bytes, $gsa);
1221              
1222             # set tag signature
1223 1         3 $self->[0]{'signature'} = $tag->[0];
1224              
1225             # set input colorspace
1226 1         3 $self->[0]{'input_cs'} = $parent->[1][4];
1227              
1228             # set output colorspace
1229 1         2 $self->[0]{'output_cs'} = $parent->[1][5];
1230              
1231             # seek start of tag
1232 1         11 seek($fh, $tag->[1], 0);
1233              
1234             # read tag header
1235 1         8 read($fh, $buf, 32);
1236              
1237             # unpack header
1238 1         6 @mft = unpack('a4 x4 C2 x2 N5', $buf);
1239            
1240             # verify tag signature
1241 1 50       3 ($mft[0] eq 'mAB ') or croak('wrong tag type');
1242              
1243             # verify number input channels (1 to 15)
1244 1 50 33     6 ($mft[1] > 0 && $mft[1] < 16) or croak('unsupported number of input channels');
1245              
1246             # verify number output channels (1 to 15)
1247 1 50 33     6 ($mft[2] > 0 && $mft[2] < 16) or croak('unsupported number of output channels');
1248              
1249             # if B-curves are defined
1250 1 50       2 if ($mft[3]) {
1251            
1252             # make 'cvst' object for B-curves
1253 1         6 $pel = ICC::Profile::cvst->new();
1254            
1255             # set file pointer to start of first B-curve
1256 1         2 $mark = $tag->[1] + $mft[3];
1257            
1258             # for each output channel
1259 1         3 for my $i (0 .. $mft[2] - 1) {
1260            
1261             # adjust file pointer to 4-byte boundary
1262 3         6 $mark += (-$mark % 4);
1263            
1264             # seek to start of curve
1265 3         24 seek($fh, $mark, 0);
1266            
1267             # read curve type
1268 3         22 read($fh, $buf, 4);
1269            
1270             # if 'curv' type
1271 3 50       10 if ($buf eq 'curv') {
    50          
1272            
1273             # parse 'curv' object
1274 0         0 $pel->[1][$i] = ICC::Profile::curv->new_fh($self, $fh, ['cvst', $mark, 0, 0]);
1275            
1276             } elsif ($buf eq 'para') {
1277            
1278             # parse 'para' object
1279 3         15 $pel->[1][$i] = ICC::Profile::para->new_fh($self, $fh, ['cvst', $mark, 0, 0]);
1280            
1281             } else {
1282            
1283             # error
1284 0         0 croak('unsupported curve type or invalid tag structure');
1285            
1286             }
1287            
1288             # mark current file pointer location
1289 3         8 $mark = tell($fh);
1290            
1291             }
1292            
1293             # set signature
1294 1         3 $pel->[0]{'signature'} = 'mAB_';
1295            
1296             # add processing element
1297 1         2 $self->[1][0] = $pel;
1298            
1299             # set transform mask
1300 1         3 $self->[2] |= 0x01;
1301            
1302             }
1303              
1304             # if matrix is defined
1305 1 50       3 if ($mft[4]) {
1306            
1307             # make 'matf' object for matrix
1308 1         5 $pel = ICC::Profile::matf->new();
1309            
1310             # seek to start of matrix
1311 1         10 seek($fh, $tag->[1] + $mft[4], 0);
1312            
1313             # read matrix
1314 1         7 $pel->_read_matf($fh, 3, 3, 1, 2);
1315            
1316             # set signature
1317 1         3 $pel->[0]{'signature'} = 'mAB_';
1318            
1319             # add processing element
1320 1         2 $self->[1][1] = $pel;
1321            
1322             # set transform mask
1323 1         2 $self->[2] |= 0x02;
1324            
1325             }
1326              
1327             # if M-curves are defined
1328 1 50       2 if ($mft[5]) {
1329            
1330             # make 'cvst' object for M-curves
1331 1         4 $pel = ICC::Profile::cvst->new();
1332            
1333             # set file pointer to start of first M-curve
1334 1         2 $mark = $tag->[1] + $mft[5];
1335            
1336             # for each output channel
1337 1         3 for my $i (0 .. $mft[2] - 1) {
1338            
1339             # adjust file pointer to 4-byte boundary
1340 3         5 $mark += (-$mark % 4);
1341            
1342             # seek to start of curve
1343 3         25 seek($fh, $mark, 0);
1344            
1345             # read curve type
1346 3         21 read($fh, $buf, 4);
1347            
1348             # if 'curv' type
1349 3 50       17 if ($buf eq 'curv') {
    50          
1350            
1351             # parse 'curv' object
1352 0         0 $pel->[1][$i] = ICC::Profile::curv->new_fh($self, $fh, ['cvst', $mark, 0, 0]);
1353            
1354             } elsif ($buf eq 'para') {
1355            
1356             # parse 'para' object
1357 3         12 $pel->[1][$i] = ICC::Profile::para->new_fh($self, $fh, ['cvst', $mark, 0, 0]);
1358            
1359             } else {
1360            
1361             # error
1362 0         0 croak('unsupported curve type or invalid tag structure');
1363            
1364             }
1365            
1366             # mark current file pointer location
1367 3         8 $mark = tell($fh);
1368            
1369             }
1370            
1371             # set signature
1372 1         3 $pel->[0]{'signature'} = 'mAB_';
1373            
1374             # add processing element
1375 1         1 $self->[1][2] = $pel;
1376            
1377             # set transform mask
1378 1         3 $self->[2] |= 0x04;
1379            
1380             }
1381              
1382             # if CLUT defined
1383 1 50       2 if ($mft[6]) {
1384            
1385             # make 'clut' object for CLUT
1386 1         7 $pel = ICC::Profile::clut->new();
1387            
1388             # seek to start of CLUT
1389 1         10 seek($fh, $tag->[1] + $mft[6], 0);
1390            
1391             # read header
1392 1         9 read($fh, $buf, 20);
1393            
1394             # unpack header
1395 1         5 @mat = unpack('C17', $buf);
1396            
1397             # get CLUT byte width
1398 1         2 $bytes = pop(@mat);
1399            
1400             # save CLUT byte width
1401 1         6 $pel->[0]{'clut_bytes'} = $bytes;
1402            
1403             # set number of input channels
1404 1         1 $pel->[0]{'input_channels'} = $mft[1];
1405              
1406             # set number of output channels
1407 1         2 $pel->[0]{'output_channels'} = $mft[2];
1408              
1409             # make grid size array
1410 1         3 $gsa = [grep {$_} @mat];
  16         18  
1411            
1412             # read 'clut' data
1413 1         5 $pel->_read_clut($fh, $mft[2], $gsa, $bytes);
1414            
1415             # save grid size array
1416 1         2 $pel->[2] = [@{$gsa}];
  1         2  
1417            
1418             # set signature
1419 1         3 $pel->[0]{'signature'} = 'mAB_';
1420            
1421             # add processing element
1422 1         2 $self->[1][3] = $pel;
1423            
1424             # set transform mask
1425 1         2 $self->[2] |= 0x08;
1426            
1427             }
1428              
1429             # if A-curves are defined
1430 1 50       3 if ($mft[7]) {
1431            
1432             # make 'cvst' object for A-curves
1433 1         5 $pel = ICC::Profile::cvst->new();
1434            
1435             # set file pointer to start of first A-curve
1436 1         3 $mark = $tag->[1] + $mft[7];
1437            
1438             # for each input channel
1439 1         3 for my $i (0 .. $mft[1] - 1) {
1440            
1441             # adjust file pointer to 4-byte boundary
1442 3         6 $mark += (-$mark % 4);
1443            
1444             # seek to start of curve
1445 3         24 seek($fh, $mark, 0);
1446            
1447             # read curve type
1448 3         23 read($fh, $buf, 4);
1449            
1450             # if 'curv' type
1451 3 50       9 if ($buf eq 'curv') {
    0          
1452            
1453             # parse 'curv' object
1454 3         15 $pel->[1][$i] = ICC::Profile::curv->new_fh($self, $fh, ['cvst', $mark, 0, 0]);
1455            
1456             } elsif ($buf eq 'para') {
1457            
1458             # parse 'para' object
1459 0         0 $pel->[1][$i] = ICC::Profile::para->new_fh($self, $fh, ['cvst', $mark, 0, 0]);
1460            
1461             } else {
1462            
1463             # error
1464 0         0 croak('unsupported curve type or invalid tag structure');
1465            
1466             }
1467            
1468             # mark current file pointer location
1469 3         8 $mark = tell($fh);
1470            
1471             }
1472            
1473             # set signature
1474 1         2 $pel->[0]{'signature'} = 'mAB_';
1475            
1476             # add processing element
1477 1         2 $self->[1][4] = $pel;
1478            
1479             # set transform mask
1480 1         4 $self->[2] |= 0x10;
1481            
1482             }
1483              
1484             }
1485              
1486             # write mAB_ tag to ICC profile
1487             # parameters: (ref_to_object, ref_to_parent_object, file_handle, ref_to_tag_table_entry)
1488             sub _writeICCmAB_ {
1489              
1490             # get parameters
1491 1     1   4 my ($self, $parent, $fh, $tag) = @_;
1492              
1493             # local variables
1494 1         2 my (@mft, $offset, @mat, $bytes, $size);
1495              
1496             # set tag type
1497 1         2 $mft[0] = 'mAB ';
1498              
1499             # check object structure
1500 1         3 @mft[1, 2] = _check($self);
1501              
1502             # initialize offset
1503 1         3 $offset = 32;
1504              
1505             # set offset to B-curves
1506 1         2 $mft[3] = 32;
1507              
1508             # if B-curves defined
1509 1 50       4 if (defined($self->[1][0])) {
1510            
1511             # for each B-curve
1512 1         2 for my $curve (@{$self->[1][0]->array()}) {
  1         35  
1513            
1514             # add curve size
1515 3         7 $offset += $curve->size;
1516            
1517             # pad to 4-bytes
1518 3         29 $offset += (-$offset % 4);
1519            
1520             }
1521            
1522             } else {
1523            
1524             # error
1525 0         0 croak('B-curves are required');
1526            
1527             }
1528              
1529             # if matrix is defined
1530 1 50       4 if (defined($self->[1][1])) {
1531            
1532             # verify output channels
1533 1 50       3 ($mft[2] == 3) or croak('3 output channels required for matrix');
1534            
1535             # set offset
1536 1         2 $mft[4] = $offset;
1537            
1538             # increment offset for matrix size
1539 1         2 $offset += 48;
1540            
1541             } else {
1542            
1543             # set offset
1544 0         0 $mft[4] = 0;
1545            
1546             }
1547              
1548             # if M-curves defined
1549 1 50       2 if (defined($self->[1][2])) {
1550            
1551             # verify output channels
1552 1 50       3 ($mft[2] == 3) or croak('3 output channels required for M-curves');
1553            
1554             # set offset
1555 1         2 $mft[5] = $offset;
1556            
1557             # for each M-curve
1558 1         2 for my $curve (@{$self->[1][2]->array()}) {
  1         3  
1559            
1560             # add curve size
1561 3         5 $offset += $curve->size;
1562            
1563             # pad to 4-bytes
1564 3         5 $offset += (-$offset % 4);
1565            
1566             }
1567            
1568             } else {
1569            
1570             # set offset
1571 0         0 $mft[5] = 0;
1572            
1573             }
1574              
1575             # if CLUT defined
1576 1 50       4 if (defined($self->[1][3])) {
1577            
1578             # set offset
1579 1         2 $mft[6] = $offset;
1580            
1581             # get CLUT data size
1582 1   50     3 $bytes = $self->[1][3][0]{'clut_bytes'} || 2;
1583            
1584             # add CLUT size to offset
1585 1         3 $offset += 20 + $self->[1][3]->_clut_size($bytes);
1586            
1587             # pad to 4-byte boundary
1588 1         2 $offset += (-$offset % 4);
1589            
1590             } else {
1591            
1592             # set offset
1593 0         0 $mft[6] = 0;
1594            
1595             }
1596              
1597             # if A-curves defined
1598 1 50       3 if (defined($self->[1][4])) {
1599            
1600             # set offset
1601 1         2 $mft[7] = $offset;
1602            
1603             } else {
1604            
1605             # set offset
1606 0         0 $mft[7] = 0;
1607            
1608             }
1609              
1610             # seek start of tag
1611 1         8 seek($fh, $tag->[1], 0);
1612              
1613             # write header
1614 1         18 print $fh pack('a4 x4 C2 x2 N5', @mft);
1615              
1616             # seek start of B-curves
1617 1         39 seek($fh, $tag->[1] + $mft[3], 0);
1618              
1619             # for each B-curve
1620 1         3 for my $curve (@{$self->[1][0]->array()}) {
  1         4  
1621            
1622             # write curve object
1623 3         16 $curve->write_fh($self->[1][0], $fh, ['cvst', tell($fh), 0, 0]);
1624            
1625             # add padding to 4-byte boundary
1626 3         39 seek($fh, (-tell($fh) % 4), 1);
1627            
1628             }
1629              
1630             # if matrix is defined
1631 1 50       5 if (defined($self->[1][1])) {
1632            
1633             # seek start of matrix
1634 1         7 seek($fh, $tag->[1] + $mft[4], 0);
1635            
1636             # write matrix
1637 1         5 $self->[1][1]->_write_matf($fh, 1, 2);
1638            
1639             }
1640              
1641             # if M-curves are defined
1642 1 50       4 if (defined($self->[1][2])) {
1643            
1644             # seek start of M-curves
1645 1         13 seek($fh, $tag->[1] + $mft[5], 0);
1646            
1647             # for each M-curve
1648 1         2 for my $curve (@{$self->[1][2]->array()}) {
  1         4  
1649            
1650             # write curve object
1651 3         15 $curve->write_fh($self->[1][2], $fh, ['cvst', tell($fh), 0, 0]);
1652            
1653             # add padding to 4-byte boundary
1654 3         36 seek($fh, (-tell($fh) % 4), 1);
1655            
1656             }
1657            
1658             }
1659              
1660             # if CLUT is defined
1661 1 50       5 if (defined($self->[1][3])) {
1662            
1663             # for each possible input channel
1664 1         3 for my $i (0 .. 15) {
1665            
1666             # set grid size
1667 16   100     37 $mat[$i] = $self->[1][3]->gsa->[$i] || 0;
1668            
1669             }
1670            
1671             # set CLUT byte width
1672 1         2 $mat[16] = $bytes;
1673            
1674             # seek start of CLUT
1675 1         7 seek($fh, $tag->[1] + $mft[6], 0);
1676            
1677             # write CLUT header
1678 1         5 print $fh pack('C17 x3', @mat);
1679            
1680             # write CLUT
1681 1         4 $self->[1][3]->_write_clut($fh, $self->[1][3]->gsa(), $bytes);
1682            
1683             }
1684              
1685             # if A-curves are defined
1686 1 50       6 if (defined($self->[1][4])) {
1687            
1688             # seek start of A-curves
1689 1         29 seek($fh, $tag->[1] + $mft[7], 0);
1690            
1691             # for each M-curve
1692 1         3 for my $curve (@{$self->[1][4]->array()}) {
  1         7  
1693            
1694             # write curve object
1695 3         18 $curve->write_fh($self->[1][4], $fh, ['cvst', tell($fh), 0, 0]);
1696            
1697             # add padding to 4-byte boundary
1698 3         41 seek($fh, (-tell($fh) % 4), 1);
1699            
1700             }
1701            
1702             }
1703            
1704             }
1705              
1706             1;