File Coverage

blib/lib/ICC/Profile.pm
Criterion Covered Total %
statement 173 609 28.4
branch 5 266 1.8
condition 1 75 1.3
subroutine 54 73 73.9
pod 7 8 87.5
total 240 1031 23.2


line stmt bran cond sub pod time code
1             package ICC::Profile;
2              
3 1     1   81104 use strict;
  1         9  
  1         26  
4 1     1   5 use Carp;
  1         1  
  1         89  
5              
6             our $VERSION = 0.74;
7              
8             # revised 2019-08-10
9             #
10             # Copyright © 2004-2020 by William B. Birkett
11              
12             # global variables
13             our (@EXPORT, @EXPORT_OK, %EXPORT_TAGS);
14              
15             # inherit from Exporter and ICC::Shared
16 1     1   372 use parent qw(Exporter ICC::Shared);
  1         248  
  1         5  
17              
18             # load library modules
19             BEGIN {
20              
21             # local variables
22 1     1   3 my (@modules, @opt, @export);
23              
24             # module list
25 1         7 @modules = qw(
26             Data::Dumper
27             Digest::MD5
28             ICC::Profile::clro
29             ICC::Profile::clrt
30             ICC::Profile::clut
31             ICC::Profile::curf
32             ICC::Profile::curv
33             ICC::Profile::cvst
34             ICC::Profile::data
35             ICC::Profile::desc
36             ICC::Profile::gbd_
37             ICC::Profile::Generic
38             ICC::Profile::mAB_
39             ICC::Profile::mBA_
40             ICC::Profile::matf
41             ICC::Profile::mft1
42             ICC::Profile::mft2
43             ICC::Profile::mluc
44             ICC::Profile::mpet
45             ICC::Profile::ncl2
46             ICC::Profile::para
47             ICC::Profile::parf
48             ICC::Profile::pseq
49             ICC::Profile::samf
50             ICC::Profile::sf32
51             ICC::Profile::sig_
52             ICC::Profile::text
53             ICC::Profile::vcgt
54             ICC::Profile::view
55             ICC::Profile::XYZ_
56             ICC::Profile::ZXML
57             ICC::Shared
58             ICC::Support::bern
59             ICC::Support::Chart
60             ICC::Support::Color
61             ICC::Support::geo1
62             ICC::Support::geo2
63             ICC::Support::nMIX
64             ICC::Support::nNET
65             ICC::Support::nNET2
66             ICC::Support::nPINT
67             ICC::Support::PCS
68             ICC::Support::ratfunc
69             ICC::Support::rbf
70             ICC::Support::spline
71             );
72              
73             # optional modules
74 1         2 @opt = qw (
75             ICC::Support::Lapack
76             ICC::Support::Levmar
77             );
78              
79             # disable strict refs (to access exported lists)
80 1     1   94 no strict 'refs';
  1         2  
  1         189  
81              
82             # for each module
83 1         2 for my $mod (@modules, @opt) {
84            
85             # load module
86 47     1   2339 eval "use $mod";
  1     1   565  
  1     1   5744  
  1     1   49  
  1     1   6  
  1     1   2  
  1     1   22  
  1     1   396  
  1     1   3  
  1     1   28  
  1     1   338  
  1     1   2  
  1     1   29  
  1     1   445  
  1     1   3  
  1     1   29  
  1     1   369  
  1     1   3  
  1     1   33  
  1     1   394  
  1     1   2  
  1     1   28  
  1     1   521  
  1     1   3  
  1     1   37  
  1     1   392  
  1     1   3  
  1     1   29  
  1     1   339  
  1     1   3  
  1     1   29  
  1     1   370  
  1     1   3  
  1     1   28  
  1     1   339  
  1     1   3  
  1     1   29  
  1     1   419  
  1     1   3  
  1     1   28  
  1     1   425  
  1     1   2  
  1     1   29  
  1     1   419  
  1     1   4  
  1     1   28  
  1     1   395  
  1         3  
  1         29  
  1         396  
  1         2  
  1         28  
  1         344  
  1         3  
  1         27  
  1         379  
  1         3  
  1         31  
  1         344  
  1         2  
  1         30  
  1         378  
  1         3  
  1         27  
  1         369  
  1         2  
  1         28  
  1         381  
  1         31  
  1         60  
  1         350  
  1         2  
  1         29  
  1         391  
  1         3  
  1         29  
  1         332  
  1         2  
  1         29  
  1         320  
  1         2  
  1         28  
  1         366  
  1         2  
  1         29  
  1         332  
  1         2  
  1         27  
  1         332  
  1         2  
  1         27  
  1         369  
  1         2  
  1         29  
  1         5  
  1         2  
  1         336  
  1         428  
  1         3  
  1         29  
  1         1208  
  1         4  
  1         63  
  1         640  
  1         3  
  1         29  
  1         391  
  1         3  
  1         30  
  1         361  
  1         2  
  1         28  
  1         409  
  1         2  
  1         33  
  1         419  
  1         3  
  1         31  
  1         390  
  1         3  
  1         45  
  1         374  
  1         3  
  1         29  
  1         431  
  1         2  
  1         33  
  1         418  
  1         3  
  1         33  
  1         408  
  1         4  
  1         32  
  1         479  
  1         3  
  1         37  
  1         179  
  0         0  
  0         0  
  1         150  
  0         0  
  0         0  
87            
88             # if error
89 47 100       181 if ($@) {
90            
91             # if an optional module
92 2 50       4 if (grep {$mod eq $_} @opt) {
  4         12  
93            
94             # warn
95 2         50 print("failed to load optional module $mod\n");
96            
97             } else {
98            
99             # error
100 0         0 die("error loading module $mod");
101            
102             }
103            
104             }
105            
106             # get exported list
107 47         70 @export = @{$mod . '::EXPORT'};
  47         156  
108            
109             # add to export list
110 47         103 push(@EXPORT, @export);
111            
112             # match module key
113 47         391 $mod =~ m/:?(\w+)$/;
114            
115             # add to group hash
116 47         222 $EXPORT_TAGS{lc($1)} = [@export];
117            
118             }
119              
120             # restore strict refs
121 1     1   7 use strict;
  1         2  
  1         46  
122              
123             # copy EXPORT list to EXPORT_OK
124 1         21 @EXPORT_OK = @EXPORT;
125              
126             # add 'all' to group hash
127 1         4738 $EXPORT_TAGS{'all'} = \@EXPORT;
128              
129             }
130              
131             # create new profile object
132             # parameters: ()
133             # parameters: (ref_to_parameter_hash)
134             # parameters: (path_to_profile, [default_profile_path])
135             # parameters: (path_to_TIFF, [default_profile_path])
136             # parameters: (path_to_PSD, [default_profile_path])
137             # supported hash keys: 'version', 'class', 'subclass', 'data', 'PCS', 'render'
138             # returns: (ref_to_profile_object)
139             sub new {
140              
141             # get object class
142 1     1 1 717 my $class = shift();
143              
144             # create empty profile object
145 1         4 my $self = [
146             {}, # object header
147             [], # profile header
148             [] # tag table
149             ];
150              
151             # if one parameter, a hash reference
152 1 50 33     7 if (@_ == 1 && ref($_[0]) eq 'HASH') {
    50          
153            
154             # create new profile from parameter hash
155 0         0 _newICCprofile($self, @_);
156            
157             # if any parameters
158             } elsif (@_) {
159            
160             # read data from existing profile
161 0 0       0 _readICCprofile($self, @_) or carp("couldn't read profile: $_[0]\n");
162            
163             }
164              
165             # bless object
166 1         2 bless($self, $class);
167              
168             # return object reference
169 1         3 return($self);
170              
171             }
172              
173             # get/set reference to header hash
174             # parameters: ([ref_to_new_hash])
175             # returns: (ref_to_hash)
176             sub header {
177              
178             # get object reference
179 0     0 1   my $self = shift();
180              
181             # if there are parameters
182 0 0         if (@_) {
183            
184             # if one parameter, a hash reference
185 0 0 0       if (@_ == 1 && ref($_[0]) eq 'HASH') {
186            
187             # set header to new hash
188 0           $self->[0] = {%{shift()}};
  0            
189            
190             } else {
191            
192             # error
193 0           croak('parameter must be a hash reference');
194            
195             }
196            
197             }
198              
199             # return reference
200 0           return($self->[0]);
201              
202             }
203              
204             # get/set profile header
205             # parameters: ([ref_to_new_array])
206             # returns: (ref_to_array)
207             sub profile_header {
208              
209             # get object reference
210 0     0 1   my $self = shift();
211              
212             # if there are parameters
213 0 0         if (@_) {
214            
215             # if one parameter, an array reference
216 0 0 0       if (@_ == 1 && ref($_[0]) eq 'ARRAY' && @{$_[0]} == grep {! ref()} @{$_[0]}) {
  0   0        
  0            
  0            
217            
218             # set header to copy of array
219 0           $self->[1] = [@{shift()}];
  0            
220            
221             } else {
222            
223             # error
224 0           croak('profile header must be an array reference');
225            
226             }
227            
228             }
229              
230             # return reference
231 0           return($self->[1]);
232              
233             }
234              
235             # get/set profile tag table
236             # parameters: ([ref_to_new_array])
237             # returns: (ref_to_array)
238             sub tag_table {
239              
240             # get object reference
241 0     0 1   my $self = shift();
242              
243             # if there are parameters
244 0 0         if (@_) {
245            
246             # if one parameter, a 2-D array reference
247 0 0 0       if (@_ == 1 && ref($_[0]) eq 'ARRAY' && @{$_[0]} == grep {ref() eq 'ARRAY'} @{$_[0]}) {
  0   0        
  0            
  0            
248            
249             # set tag table to copy of array
250 0           $self->[2] = Storable::dclone(shift());
251            
252             } else {
253            
254             # error
255 0           croak('profile tag table must be a 2-D array reference');
256            
257             }
258            
259             }
260              
261             # return reference
262 0           return($self->[2]);
263              
264             }
265              
266             # get/set tag objects
267             # get tag object(s) returns 'undef' if tag signature not found
268             # parameters: (list_of_tag_signatures)
269             # returns: (list_of_tag_objects)
270             # set tag object(s) replaces, adds or deletes tags
271             # hash keys are tag signatures, hash values are object refs
272             # a hash value of 'delete' will delete the tag
273             # parameters: (ref_to_parameter_hash)
274             # returns: (list_of_tag_objects)
275             sub tag {
276              
277             # get object reference
278 0     0 1   my $self = shift();
279              
280             # local variables
281 0           my ($hash, $value, @match, @tags, $rem);
282              
283             # if parameter hash supplied
284 0 0 0       if (@_ == 1 && ref($_[0]) eq 'HASH') {
    0          
285            
286             # get hash
287 0           $hash = shift();
288            
289             # for each key
290 0           for my $key (keys(%{$hash})) {
  0            
291            
292             # get value
293 0           $value = $hash->{$key};
294            
295             # verify tag signature
296 0 0         (length($key) == 4) or croak('tag signature wrong length');
297            
298             # match tag signature
299 0           @match = grep {$key eq $self->[2][$_][0]} (0 .. $#{$self->[2]});
  0            
  0            
300            
301             # if tag value undefined or an ICC::Profile or ICC::Support object
302 0 0 0       if (! defined($value) || ref($value) =~ m/^ICC::(Profile|Support)::/) {
    0          
303            
304             # if no matches
305 0 0         if (@match == 0) {
    0          
306            
307             # add new tag
308 0           push(@{$self->[2]}, [$key, 0, 0, $value]);
  0            
309            
310             # if one match
311             } elsif (@match == 1) {
312            
313             # modify matched tag
314 0           $self->[2][$match[0]] = [$key, 0, 0, $value];
315            
316             # more than one match
317             } else {
318            
319             # modify first matched tag
320 0           $self->[2][$match[0]] = [$key, 0, 0, $value];
321            
322             # print warning
323 0           carp "tag table contains multiple tags with '$key' signature\n";
324            
325             }
326            
327             # add tag to list
328 0           push(@tags, $value);
329            
330             # if tag value is 'delete'
331             } elsif ($value eq 'delete') {
332            
333             # if no matches
334 0 0         if (@match == 0) {
335            
336             # print warning
337 0           carp "tag table contains no '$key' tag(s) to delete\n";
338            
339             # one or more matches
340             } else {
341            
342             # for each tag
343 0           for my $i (@match) {
344            
345             # delete tag
346 0           $rem = splice(@{$self->[2]}, $i, 1);
  0            
347            
348             # add tag to list
349 0 0         push(@tags, defined($rem) ? $rem->[3] : undef);
350            
351             }
352            
353             }
354            
355             } else {
356            
357             # error
358 0           croak("invalid '$key' tag value");
359            
360             }
361            
362             }
363            
364             # if list of tag signatures
365             } elsif (@_) {
366            
367             # for each signature
368 0           for my $key (@_) {
369            
370             # match tag signature
371 0           @match = grep {$key eq $_->[0]} @{$self->[2]};
  0            
  0            
372            
373             # if no matches
374 0 0         if (@match == 0) {
    0          
375            
376             # add 'undef' to tag list
377 0           push(@tags, undef);
378            
379             # if one match
380             } elsif (@match == 1) {
381            
382             # add matched tag to tag list
383 0           push(@tags, $match[0][3]);
384            
385             # more than one match
386             } else {
387            
388             # add first matched tag to tag list
389 0           push(@tags, $match[0][3]);
390            
391             # print warning
392 0           carp "tag table contains multiple tags with '$key' signature\n";
393            
394             }
395            
396             }
397            
398             }
399            
400             # if list is expected
401 0 0         if (wantarray) {
402            
403             # return tag list
404 0           return(@tags);
405            
406             } else {
407            
408             # return first tag
409 0           return($tags[0]);
410            
411             }
412            
413             }
414              
415             # write ICC profile
416             # parameters: (path_to_profile)
417             # parameters: (scalar_reference)
418             sub write {
419              
420             # get object reference
421 0     0 1   my $self = shift();
422              
423             # verify parameter count
424 0 0         (@_ == 1) or croak('wrong number of parameters');
425              
426             # write profile
427 0           _writeICCprofile($self, @_);
428              
429             # return
430 0           return();
431              
432             }
433              
434             # write ICC profile to scalar
435             # returns: (scalar_reference)
436             sub serialize {
437              
438             # get object reference
439 0     0 0   my $self = shift();
440              
441             # local variable
442 0           my $buf;
443              
444             # write profile
445 0           _writeICCprofile($self, \$buf);
446              
447             # return
448 0           return(\$buf);
449              
450             }
451              
452             # print object contents to string
453             # optional format may contain the characters 'p', 't' and 's'
454             # when the format contains 'p' the profile header will be dumped
455             # when the format contains 't' the profile tag table will be dumped
456             # when the format contains 's' the profile structure will be dumped
457             # when the format is omitted, a default value of 'pts' is used
458             # parameter: ([format])
459             # returns: (string)
460             sub sdump {
461              
462             # get parameters
463 0     0 1   my ($self, $p) = @_;
464              
465             # local variables
466 0           my ($header, $entry, $tag, $fmt, $s, $pt, $st);
467              
468             # resolve parameter to an array reference
469 0 0         $p = defined($p) ? ref($p) eq 'ARRAY' ? $p : [$p] : [];
    0          
470              
471             # get format string
472 0 0 0       $fmt = defined($p->[0]) && ! ref($p->[0]) ? $p->[0] : 'pts';
473              
474             # set string to object ID
475 0           $s = sprintf("'%s' object, (0x%x)\n", ref($self), $self);
476              
477             # if format contains 'p'
478 0 0         if ($fmt =~ m/p/) {
479            
480             # if profile header contains data
481 0 0         if (@{$self->[1]}) {
  0            
482            
483             # get profile header array
484 0           $header = $self->[1];
485            
486             # add header info
487 0           $s .= sprintf("%24s: %d bytes\n", 'Size', $header->[0]);
488 0           $s .= sprintf("%24s: %4s\n", 'Preferred CMM', $header->[1]);
489 0           $s .= sprintf("%24s: %d.%d.%d\n", 'Specification Version', substr($header->[2], 0, 2), substr($header->[2], 2, 1), substr($header->[2], 3, 1));
490 0           $s .= sprintf("%24s: %4s\n", 'Class', $header->[3]);
491 0           $s .= sprintf("%24s: %4s\n", 'Data', $header->[4]);
492 0           $s .= sprintf("%24s: %4s\n", 'PCS', $header->[5]);
493 0           $s .= sprintf("%24s: %04d-%02d-%02d %02d:%02d:%02d\n", 'Created', @{$header}[6 .. 11]);
  0            
494 0           $s .= sprintf("%24s: %4s\n", 'Platform', $header->[13]);
495 0           $s .= sprintf("%24s: <0x%08x>\n", 'Flags', $header->[14]);
496 0           $s .= sprintf("%24s: %4s\n", 'Device Manufacturer', $header->[15]);
497 0           $s .= sprintf("%24s: %4s\n", 'Device Model', $header->[16]);
498 0           $s .= sprintf("%24s: <0x%08x> <0x%08x>\n", 'Device Attributes', @{$header}[17 .. 18]);
  0            
499 0           $s .= sprintf("%24s: %d\n", 'Rendering Intent', $header->[19]);
500 0           $s .= sprintf("%24s: %7.5f, %7.5f, %7.5f\n", 'PCS Illuminant', map {$_/65536} @{$header}[20 .. 22]);
  0            
  0            
501 0           $s .= sprintf("%24s: %4s\n", 'Creator', $header->[23]);
502            
503             # if no MD5 signature
504 0 0         if ($header->[24] eq '00' x 16) {
505            
506             # print no MD5 signature
507 0           $s .= sprintf("%24s:\n\n", 'MD5 Signature');
508            
509             } else {
510            
511             # print MD5 signature in 8 byte segments
512 0           $s .= sprintf("%24s: %8s %8s %8s %8s\n\n", 'MD5 Signature', substr($header->[24], 0, 8), substr($header->[24], 8, 8), substr($header->[24], 16, 8), substr($header->[24], 24, 8));
513            
514             }
515            
516             } else {
517            
518             # add message
519 0           $s .= "
\n";
520            
521             }
522            
523             }
524              
525             # if format contains 't'
526 0 0         if ($fmt =~ m/t/) {
527            
528             # if tag table contains data
529 0 0         if (@{$self->[2]}) {
  0            
530            
531             # print tag table header
532 0           $s .= " # Tag Object Type Offset Size\n";
533            
534             # for each tag table entry
535 0           for my $i (0 .. $#{$self->[2]}) {
  0            
536            
537             # get tag table entry
538 0           $entry = $self->[2][$i];
539            
540             # print tag table entry
541 0   0       $s .= sprintf("%4d '%4s' %-24s %8d %8d\n", $i + 1, $entry->[0], ref($entry->[3]) || ' undefined', $entry->[1] || 0, $entry->[2] || 0);
      0        
      0        
542            
543             }
544            
545             # add line ending
546 0           $s .= "\n";
547            
548             } else {
549            
550             # add message
551 0           $s .= "\n";
552            
553             }
554            
555             }
556              
557             # if format contains 's'
558 0 0         if ($fmt =~ m/s/) {
559            
560             # get default parameter
561 0           $pt = $p->[-1];
562            
563             # for each tag
564 0           for my $i (0 .. $#{$self->[2]}) {
  0            
565            
566             # get tag reference
567 0           $tag = $self->[2][$i][3];
568            
569             # if tag is undefined
570 0 0         if (! defined($tag)) {
    0          
    0          
571            
572             # append message
573 0           $s .= "\ttag is undefined\n";
574            
575             # if tag is not a blessed object
576             } elsif (! Scalar::Util::blessed($tag)) {
577            
578             # append message
579 0           $s .= "\ttag is not a blessed object\n";
580            
581             # if tag has an 'sdump' method
582             } elsif ($tag->can('sdump')) {
583            
584             # get 'sdump' string
585 0 0         $st = $tag->sdump(defined($p->[$i + 1]) ? $p->[$i + 1] : $pt);
586            
587             # prepend tabs to each line
588 0           $st =~ s/^/\t/mg;
589            
590             # append 'sdump' string
591 0           $s .= $st;
592            
593             # tag is object without an 'sdump' method
594             } else {
595            
596             # append object info
597 0           $s .= sprintf("\t'%s' object, (0x%x)\n", ref($tag), $tag);
598            
599             }
600            
601             }
602            
603             }
604              
605             # return
606 0           return($s);
607              
608             }
609              
610             # create new profile object
611             # parameters: (ref_to_object, parameter_hash)
612             sub _newICCprofile {
613              
614             # get parameters
615 0     0     my ($self, $hash) = @_;
616              
617             # local variables
618 0           my ($version, $class, $subclass, $dcs, $pcs, $dri) = @{$hash}{qw(version class subclass data PCS render)};
  0            
619 0           my ($redcs, $repcs, $vmaj, $vmin);
620              
621             # regular expression to match data color space (table 19, ICC1v43_2010-12)
622 0           $redcs = qr/^(XYZ |Lab |Luv |YCbr|Yxy |RGB |GRAY|HSV |HLS |CMYK|CMY |[2-9A-F]CLR)$/;
623              
624             # regular expression to match profile connection space (section 7.2.7, ICC1v43_2010-12)
625 0           $repcs = qr/^(XYZ |Lab )$/;
626              
627             # resolve version number (optional, default version 2.4)
628 0 0         $version = defined($version) ? $version : '02400000';
629              
630             # verify version number (section 7.2.4, ICC1v43_2010-12)
631 0 0         ($version =~ m/^[0-9]{4}0000$/) or croak('invalid version number');
632              
633             # get major revision
634 0           $vmaj = substr($version, 0, 2);
635              
636             # get minor revision
637 0           $vmin = substr($version, 2, 1);
638              
639             # verify profile class (required) (table 18, ICC1v43_2010-12)
640 0 0         (defined($class)) or croak('missing profile class parameter');
641 0 0         ($class =~ m/^(scnr|mntr|prtr|link|spac|abst|nmcl)$/) or croak('invalid profile class');
642              
643             # resolve subclass (optional, default 0)
644 0 0         $subclass = defined($subclass) ? $subclass : 0;
645              
646             # verify data color space (required)
647 0 0         (defined($dcs)) or croak('missing data color space parameter');
648 0 0 0       (($dcs =~ $repcs) || ($class ne 'abst' && $dcs =~ $redcs)) or croak('invalid data color space');
      0        
649              
650             # verify profile connection space (required)
651 0 0         $pcs = $hash->{'PCS'} or croak('missing profile connection space parameter');
652 0 0 0       (($pcs =~ $repcs) || ($class eq 'link' && $pcs =~ $redcs)) or croak('invalid profile connection space');
      0        
653              
654             # resolve default rendering intent (optional, default 0)
655 0 0         $dri = defined($dri) ? $dri : 0;
656              
657             # verify default rendering intent (table 23, ICC1v43_2010-12)
658 0 0         ($dri =~ m/^[0-3]$/) or croak('invalid default rendering intent');
659              
660             # set header (note: size, time and ID are computed when writing profile)
661 0           $self->[1] = [
662             0, # profile size
663             "\x00" x 4, # preferred CMM type signature
664             $version, # profile version number
665             $class, # profile/device class signature
666             $dcs, # data color space
667             $pcs, # profile connection space
668             0, # year
669             0, # month
670             0, # day
671             0, # hour
672             0, # minute
673             0, # second
674             'acsp', # profile file signature
675             'APPL', # primary platform signature
676             0, # flags
677             "\x00" x 4, # device manufacturer
678             "\x00" x 4, # device model
679             0, # attributes
680             0, # attributes (reserved for ICC)
681             $dri, # default rendering intent
682             0x00F6D6, # illuminant X (D50)
683             0x010000, # illuminant Y (D50)
684             0x00D32D, # illuminant Z (D50)
685             'DPLG', # profile creator signature (Doppelganger)
686             '00' x 16 # profile ID (MD5)
687             ];
688              
689             # if an input device profile
690 0 0         if ($class eq 'scnr') {
    0          
    0          
    0          
    0          
    0          
691            
692             # set tag table
693 0           $self->[2] = [
694             ['desc'],
695             ['cprt'],
696             ['wtpt']
697             ];
698            
699             # if subclass 0 (N-component LUT-based input profile)
700 0 0         if ($subclass == 0) {
    0          
    0          
701            
702             # add AToB0Tag
703 0           push(@{$self->[2]},
  0            
704             ['A2B0']
705             );
706            
707             # if subclass 1 (Three-component matrix-based input profile)
708             } elsif ($subclass == 1) {
709            
710             # add additional required tags
711 0           push(@{$self->[2]},
  0            
712             ['rXYZ'],
713             ['gXYZ'],
714             ['bXYZ'],
715             ['rTRC'],
716             ['gTRC'],
717             ['bTRC']
718             );
719            
720             # if subclass 2 (Monochrome input profile)
721             } elsif ($subclass == 2) {
722            
723             # add grayTRCTag
724 0           push(@{$self->[2]},
  0            
725             ['kTRC']
726             );
727            
728             }
729            
730             # if a display device profile
731             } elsif ($class eq 'mntr') {
732            
733             # set tag table
734 0           $self->[2] = [
735             ['desc'],
736             ['cprt'],
737             ['wtpt']
738             ];
739            
740             # if subclass 0 (N-Component LUT-based display profile)
741 0 0         if ($subclass == 0) {
    0          
    0          
742            
743             # add additional required tags
744 0           push(@{$self->[2]},
  0            
745             ['A2B0'],
746             ['B2A0']
747             );
748            
749             # if subclass 1 (Three-component matrix-based display profile)
750             } elsif ($subclass == 1) {
751            
752             # add additional required tags
753 0           push(@{$self->[2]},
  0            
754             ['rXYZ'],
755             ['gXYZ'],
756             ['bXYZ'],
757             ['rTRC'],
758             ['gTRC'],
759             ['bTRC']
760             );
761            
762             # if subclass 2 (Monochrome display profile)
763             } elsif ($subclass == 2) {
764            
765             # add grayTRCTag
766 0           push(@{$self->[2]},
  0            
767             ['kTRC']
768             );
769            
770             }
771            
772             # if a output device profile
773             } elsif ($class eq 'prtr') {
774            
775             # set tag table
776 0           $self->[2] = [
777             ['desc'],
778             ['cprt'],
779             ['wtpt']
780             ];
781            
782             # if subclass 0 (N-component LUT-based output profile)
783 0 0         if ($subclass == 0) {
    0          
784            
785             # add additional required tags
786 0           push(@{$self->[2]},
  0            
787             ['A2B0'],
788             ['A2B1'],
789             ['A2B2'],
790             ['B2A0'],
791             ['B2A1'],
792             ['B2A2'],
793             ['gamt']
794             );
795            
796             # if data color space is xCLR and version 4
797 0 0 0       if ($dcs =~ m|CLR$| && $vmaj == 4) {
798            
799             # add colorantTableTag
800 0           push(@{$self->[2]},
  0            
801             ['clrt']
802             );
803            
804             }
805            
806             # if subclass 2 (Monochrome output profile)
807             } elsif ($subclass == 2) {
808            
809             # add grayTRCTag
810 0           push(@{$self->[2]},
  0            
811             ['kTRC']
812             );
813            
814             }
815            
816             # if a device link profile
817             } elsif ($class eq 'link') {
818            
819             # set tag table
820 0           $self->[2] = [
821             ['desc'],
822             ['cprt'],
823             ['pseq'],
824             ['A2B0']
825             ];
826            
827             # if data color space is xCLR and version 4
828 0 0 0       if ($dcs =~ m|CLR$| && $vmaj == 4) {
829            
830             # add colorantTableTag
831 0           push(@{$self->[2]},
  0            
832             ['clrt']
833             );
834            
835             }
836            
837             # if data color space is xCLR and version 4
838 0 0 0       if ($pcs =~ m|CLR$| && $vmaj == 4) {
839            
840             # add colorantTableOutTag
841 0           push(@{$self->[2]},
  0            
842             ['clot']
843             );
844            
845             }
846            
847             # if a color space conversion profile
848             } elsif ($class eq 'spac') {
849            
850             # set tag table
851 0           $self->[2] = [
852             ['desc'],
853             ['cprt'],
854             ['wtpt'],
855             ['A2B0'],
856             ['B2A0']
857             ];
858            
859             # if an abstract profile
860             } elsif ($class eq 'abst') {
861            
862             # set tag table
863 0           $self->[2] = [
864             ['desc'],
865             ['cprt'],
866             ['wtpt'],
867             ['A2B0']
868             ];
869            
870             # if a named color profile
871             } else {
872            
873             # set tag table
874 0           $self->[2] = [
875             ['desc'],
876             ['cprt'],
877             ['wtpt'],
878             ['ncl2']
879             ];
880            
881             }
882            
883             }
884              
885             # read embedded profile from PSD file
886             # parameters: (file_handle)
887             # returns: (reference_to_buffer)
888             sub _readICCprofilePSD {
889              
890             # get file handle
891 0     0     my $fh = shift();
892              
893             # local variables
894 0           my ($buf, @header, @res, $end);
895              
896             # seek start of file
897 0           seek($fh, 0, 0);
898              
899             # read the header
900 0 0         (read($fh, $buf, 30) == 30) || return(0);
901              
902             # unpack the header
903 0           @header = unpack('a4 n x6 n N N n n N', $buf);
904              
905             # verify PSD signature
906 0 0 0       if (($header[0] eq '8BPS') && ($header[1] == 1)) {
907            
908             # skip to resource size
909 0           seek($fh, $header[7], 1);
910            
911             # read resource size
912 0           read($fh, $buf, 4);
913            
914             # compute resource block end
915 0           $end = tell($fh) + unpack('N', $buf);
916            
917             # while file position < resource block end
918 0           while (tell($fh) < $end) {
919            
920             # read resource type, ID and name count
921 0           read($fh, $buf, 7);
922            
923             # unpack resource type, ID and name count
924 0           @res = unpack('a4 n C', $buf);
925            
926             # read the resource name (Pascal string)
927 0           read($fh, $buf, $res[2] + (1 - $res[2] % 2));
928            
929             # save the resource name
930 0           $res[2] = substr($buf, 0, $res[2]);
931            
932             # read the resource size
933 0           read($fh, $buf, 4);
934            
935             # unpack resource size
936 0           $res[3] = unpack('N', $buf);
937            
938             # if ICC profile resource
939 0 0         if ($res[1] == 1039) {
940            
941             # read profile
942 0           read($fh, $buf, $res[3]);
943            
944             # return buffer reference
945 0           return(\$buf);
946            
947             }
948            
949             # skip to next resource
950 0           seek($fh, $res[3] + (- $res[3] % 2), 1);
951            
952             }
953            
954             }
955              
956             # return (no profile found)
957 0           return(0);
958              
959             }
960              
961             # read embedded profile from TIFF file
962             # parameters: (file_handle)
963             # returns: (reference_to_buffer)
964             sub _readICCprofileTIFF {
965              
966             # get file handle
967 0     0     my $fh = shift();
968              
969             # local variables
970 0           my (@ts, $buf, $short, $long, @header);
971 0           my ($count, @tag, $size);
972              
973             # type size (in bytes)
974 0           @ts = (0, 1, 1, 2, 4, 8, 1, 1, 2, 4, 8, 4, 8);
975              
976             # seek start of file
977 0           seek($fh, 0, 0);
978              
979             # read the header
980 0 0         (read($fh, $buf, 8) == 8) || return(0);
981              
982             # if big-endian (Motorola)
983 0 0         if ($buf =~ m|^MM|) {
984            
985             # set unpack formats
986 0           $short = 'n';
987 0           $long = 'N';
988            
989             # little-endian (Intel)
990             } else {
991            
992             # set unpack formats
993 0           $short = 'v';
994 0           $long = 'V';
995            
996             }
997              
998             # unpack the header
999 0           @header = unpack("A2 $short $long", $buf);
1000              
1001             # verify TIFF file signature
1002 0 0         if ($header[1] == 42) {
1003            
1004             # seek first IFD (image file directory)
1005 0           seek($fh, $header[2], 0);
1006            
1007             # read number entries
1008 0           read($fh, $buf, 2);
1009            
1010             # unpack the directory count
1011 0           $count = unpack("$short", $buf);
1012            
1013             # read the directory
1014 0           for (1 .. $count) {
1015            
1016             # read first part of IFD entry
1017 0           read($fh, $buf, 8);
1018            
1019             # unpack tag, type and count
1020 0           @tag = unpack("$short $short $long", $buf);
1021            
1022             # read last part of IFD entry
1023 0           read($fh, $buf, 4);
1024            
1025             # determine value/offset size
1026 0 0         $size = $ts[$tag[1]] * $tag[2] + (($tag[1] == 2) ? 1 : 0);
1027            
1028             # if value/offset size > 4 or a single long value
1029 0 0 0       if ($size > 4 || $ts[$tag[1]] == 4) {
    0 0        
    0 0        
1030            
1031             # unpack value/offset
1032 0           $tag[3] = unpack($long, $buf);
1033            
1034             } elsif ($ts[$tag[1]] == 2 && $tag[2] == 1) {
1035            
1036             # unpack value
1037 0           $tag[3] = unpack($short, $buf);
1038            
1039             } elsif ($ts[$tag[1]] == 2 && $tag[2] == 2) {
1040            
1041             # unpack values
1042 0           $tag[3 .. 4] = unpack("$short $short", $buf);
1043            
1044             }
1045            
1046             # if ICC profile tag
1047 0 0         if ($tag[0] == 34675) {
1048            
1049             # seek start of profile
1050 0           seek($fh, $tag[3], 0);
1051              
1052             # read profile
1053 0           read($fh, $buf, $tag[2]);
1054              
1055             # close file
1056 0           close($fh);
1057              
1058             # return reference to buffer
1059 0           return(\$buf);
1060            
1061             }
1062            
1063             }
1064            
1065             }
1066              
1067             # return
1068 0           return(0);
1069              
1070             }
1071              
1072             # read profile data from profile file
1073             # parameters: (ref_to_object, path_to_profile, [path_to_default_profile])
1074             # parameters: (ref_to_object, scalar_reference, [path_to_default_profile])
1075             # returns: (success_flag)
1076             sub _readICCprofile {
1077              
1078             # get parameters
1079 0     0     my ($self, $path, $default) = @_;
1080              
1081             # local variables
1082 0           my ($fh, $buf, $ref);
1083 0           my (%hash, $type, $class);
1084 0           my ($wtpt, $bkpt, $A2B0, $A2B1);
1085              
1086             # if path a scalar reference
1087 0 0         if (ref($path) eq 'SCALAR') {
    0          
1088            
1089             # open the profile file
1090 0 0         open($fh, '<', $path) or croak("unable to read profile from scalar");
1091            
1092             # save file type in object header
1093 0           $self->[0]{'file_type'} = 'scalar';
1094            
1095             # if path a scalar
1096             } elsif (! ref($path)) {
1097            
1098             # replace '~~' with 'ICC' directory path
1099 0           $path =~ s/^~~/ICC::Shared::getICCPath()/e;
  0            
1100            
1101             # filter file path
1102 0           ICC::Shared::filterPath($path);
1103            
1104             # verify file path
1105 0 0         -f $path or croak("$path is not a valid file path");
1106            
1107             # open the profile file
1108 0 0         open($fh, '<', $path) or croak("unable to read profile from $path");
1109            
1110             # save path in object header
1111 0           $self->[0]{'file_path'} = $path;
1112            
1113             # save file type in object header
1114 0           $self->[0]{'file_type'} = 'prof';
1115              
1116             } else {
1117            
1118             # error
1119 0           croak("invalid path parameter");
1120            
1121             }
1122              
1123             # set binary mode
1124 0           binmode($fh);
1125              
1126             # seek to profile file signature
1127 0           seek($fh, 36, 0);
1128              
1129             # read profile file signature
1130 0           read($fh, $buf, 4);
1131              
1132             # if not an ICC profile
1133 0 0         if ($buf ne 'acsp') {
1134            
1135             # if TIFF with embedded profile
1136 0 0         if ($ref = _readICCprofileTIFF($fh)) {
    0          
    0          
1137            
1138             # open the profile
1139 0           open($fh, '<', $ref);
1140            
1141             # set binary mode
1142 0           binmode($fh);
1143            
1144             # save file type in object header
1145 0           $self->[0]{'file_type'} = 'TIFF';
1146              
1147             # if PSD with embedded profile
1148             } elsif ($ref = _readICCprofilePSD($fh)) {
1149            
1150             # open the profile
1151 0           open($fh, '<', $ref);
1152            
1153             # set binary mode
1154 0           binmode($fh);
1155            
1156             # save file type in object header
1157 0           $self->[0]{'file_type'} = '8BPS';
1158              
1159             # if default profile path supplied
1160             } elsif (defined($default)) {
1161            
1162             # close current file
1163 0           close($fh);
1164            
1165             # filter file path
1166 0           ICC::Shared::filterPath($default);
1167            
1168             # open the profile file
1169 0 0         open($fh, '<', $default) || return(0);
1170            
1171             # set binary mode
1172 0           binmode($fh);
1173            
1174             # save path in object header
1175 0           $self->[0]{'file_path'} = $default;
1176            
1177             # seek to profile file signature
1178 0           seek($fh, 36, 0);
1179            
1180             # read profile file signature
1181 0           read($fh, $buf, 4);
1182            
1183             # if not an ICC profile
1184 0 0         if ($buf ne 'acsp') {
1185            
1186             # close file
1187 0           close($fh);
1188            
1189             # return
1190 0           return(0);
1191            
1192             }
1193            
1194             } else {
1195            
1196             # close file
1197 0           close($fh);
1198            
1199             # return
1200 0           return(0);
1201            
1202             }
1203            
1204             }
1205              
1206             # read the header
1207 0 0         _readICCheader($fh, $self->[1]) || return(0);
1208              
1209             # read the tag table
1210 0 0         _readICCtagtable($fh, $self->[2]) || return(0);
1211              
1212             # for each tag
1213 0           for my $tag (@{$self->[2]}) {
  0            
1214            
1215             # if a duplicate tag
1216 0 0         if (exists($hash{$tag->[1]})) {
1217            
1218             # use original tag
1219 0           $tag->[3] = $hash{$tag->[1]};
1220            
1221             } else {
1222            
1223             # seek to start of tag
1224 0           seek($fh, $tag->[1], 0);
1225            
1226             # read tag type signature
1227 0           read($fh, $type, 4);
1228            
1229             # convert non-word characters to underscores
1230 0           $type =~ s|\W|_|g;
1231            
1232             # form class specifier
1233 0           $class = "ICC::Profile::$type";
1234            
1235             # if 'class->new_fh' method exists
1236 0 0         if ($class->can('new_fh')) {
1237            
1238             # create specific tag object
1239 0           $tag->[3] = $class->new_fh($self, $fh, $tag);
1240            
1241             } else {
1242            
1243             # create generic tag object
1244 0           $tag->[3] = ICC::Profile::Generic->new_fh($self, $fh, $tag);
1245            
1246             # print message
1247             # print "tag type $type opened as generic\n";
1248            
1249             }
1250            
1251             # save tag in hash
1252 0           $hash{$tag->[1]} = $tag->[3];
1253            
1254             }
1255            
1256             # save white point tag
1257 0 0         $wtpt = $tag->[3] if ($tag->[0] eq 'wtpt');
1258            
1259             # save black point tag
1260 0 0         $bkpt = $tag->[3] if ($tag->[0] eq 'bkpt');
1261            
1262             # save 'A2B0' tag
1263 0 0         $A2B0 = $tag->[3] if ($tag->[0] eq 'A2B0');
1264            
1265             # save 'A2B1' tag
1266 0 0         $A2B1 = $tag->[3] if ($tag->[0] eq 'A2B1');
1267            
1268             }
1269              
1270             # close the profile file
1271 0           close($fh);
1272              
1273             # for each tag
1274 0           for my $tag (@{$self->[2]}) {
  0            
1275            
1276             # if an 'A2Bx', 'B2Ax', or 'gamt' tag
1277 0 0 0       if (($tag->[0] =~ m/^(A2B[0-9A-F]|B2A[0-9A-F]|gamt)$/) && defined($tag->[3])) {
    0 0        
1278            
1279             # add white point XYZ values to tag header (if available)
1280 0 0         $tag->[3][0]{'wtpt'} = [@{$wtpt->XYZ}] if defined($wtpt);
  0            
1281            
1282             # add black point XYZ values to tag header (if available)
1283 0 0         $tag->[3][0]{'bkpt'} = [@{$bkpt->XYZ}] if defined($bkpt);
  0            
1284            
1285             # add pcs encoding to tag header
1286 0 0         $tag->[3][0]{'pcs_encoding'} = _pcs($self, defined($A2B1) ? $A2B1 : $A2B0);
1287            
1288             # if a 'D2Bx', 'B2Dx' or 'gbdx' tag
1289             } elsif (($tag->[0] =~ m/^(D2B[0-9A-F]|B2D[0-9A-F]|gbd[0-3])$/) && defined($tag->[3])) {
1290            
1291             # add white point XYZ values to tag header (if available)
1292 0 0         $tag->[3][0]{'wtpt'} = [@{$wtpt->XYZ}] if defined($wtpt);
  0            
1293            
1294             # add black point XYZ values to tag header (if available)
1295 0 0         $tag->[3][0]{'bkpt'} = [@{$bkpt->XYZ}] if defined($bkpt);
  0            
1296            
1297             # add pcs encoding to tag header (32-bit)
1298 0 0         $tag->[3][0]{'pcs_encoding'} = $self->[1][5] eq 'Lab ' ? 3 : 8;
1299            
1300             }
1301            
1302             }
1303              
1304             # return
1305 0           return(1);
1306              
1307             }
1308              
1309             # read ICC header
1310             # parameters: (file_handle, ref_to_header_array)
1311             # returns: (success_flag)
1312             sub _readICCheader {
1313              
1314             # get parameters
1315 0     0     my ($fh, $header) = @_;
1316              
1317             # seek to start of header
1318 0           seek($fh, 0, 0);
1319              
1320             # read the header (128 bytes)
1321 0 0         (read($fh, my $buf, 128) == 128) || return(0);
1322              
1323             # unpack the header
1324 0           @{$header} = unpack('N a4 H8 a4 a4 a4 n6 a4 a4 N a4 a4 N2 N N3 a4 H32 x28', $buf);
  0            
1325              
1326             # return success if profile file signature verified
1327 0 0         return($header->[12] eq 'acsp' ? 1 : 0);
1328              
1329             }
1330              
1331             # read ICC tag table
1332             # parameters: (file_handle, ref_to_tag_table_array)
1333             # returns: (success_flag)
1334             sub _readICCtagtable {
1335              
1336             # get parameters
1337 0     0     my ($fh, $tagtab) = @_;
1338              
1339             # local variables
1340 0           my ($buf, $n);
1341              
1342             # seek to start of tag table
1343 0           seek($fh, 128, 0);
1344              
1345             # read tag count (4 bytes)
1346 0 0         (read($fh, $buf, 4) == 4) || return(0);
1347              
1348             # unpack tag count
1349 0           $n = unpack('N', $buf);
1350              
1351             # read tag entries
1352 0           for my $i (0 .. $n - 1) {
1353            
1354             # read tag entry (12 bytes)
1355 0 0         (read($fh, $buf, 12) == 12) || return(0);
1356            
1357             # unpack tag entry
1358 0           $tagtab->[$i] = [unpack('a4 N N', $buf)];
1359            
1360             }
1361              
1362             # return
1363 0           return(1);
1364              
1365             }
1366              
1367             # write ICC profile
1368             # parameters: (ref_to_object, path_to_profile)
1369             sub _writeICCprofile {
1370              
1371             # get parameters
1372 0     0     my ($self, $path) = @_;
1373              
1374             # local variables
1375 0           my (@localtime);
1376 0           my ($fh, $fp, $sig, %hash, %dup, $pad);
1377 0           my ($vmaj, $ri, $flags);
1378              
1379             # get profile major version
1380 0           $vmaj = substr($self->[1][2], 0, 2);
1381              
1382             # get localtime
1383 0           @localtime = localtime();
1384              
1385             # set time in profile header
1386 0           @{$self->[1]}[6 .. 11] = (
  0            
1387             $localtime[5] + 1900, # year
1388             $localtime[4] + 1, # month
1389             $localtime[3], # day
1390             $localtime[2], # hour
1391             $localtime[1], # minute
1392             $localtime[0], # second
1393             );
1394            
1395             # if profile version 4
1396 0 0         if ($vmaj == 4) {
1397            
1398             # convert tags to version 4
1399 0           _to_v4($self);
1400            
1401             # save flags
1402 0           $flags = $self->[1][14];
1403            
1404             # save rendering intent (clearing upper 16-bits)
1405 0           $ri = $self->[1][19] & 0x0000ffff;
1406            
1407             # clear for MD5 calculation
1408 0           $self->[1][14] = 0;
1409 0           $self->[1][19] = 0;
1410            
1411             }
1412              
1413             # clear MD5 string
1414 0           $self->[1][24] = "\x00" x 16;
1415              
1416             # for each tag
1417 0           for my $i (0 .. $#{$self->[2]}) {
  0            
1418            
1419             # get tag signature
1420 0           $sig = $self->[2][$i][0];
1421            
1422             # error if duplicate tag
1423 0 0         (! exists($dup{$sig})) or croak("duplicate '$sig' tag");
1424            
1425             # add tag to duplicate hash
1426 0           $dup{$sig} = '';
1427            
1428             # if tag object is defined
1429 0 0         if (defined($self->[2][$i][3])) {
1430            
1431             # if tag->size method exists
1432 0 0         if ($self->[2][$i][3]->can('size')) {
1433            
1434             # set tag size (without padding)
1435 0           $self->[2][$i][2] = $self->[2][$i][3]->size();
1436            
1437             # save size with padding to 4-byte boundary
1438 0           $hash{$self->[2][$i][3]} = $self->[2][$i][2] + (-$self->[2][$i][2] % 4);
1439            
1440             } else {
1441            
1442             # error
1443 0           croak("'$sig' object has no 'size' method");
1444            
1445             }
1446            
1447             } else {
1448            
1449             # error
1450 0           croak("'$sig' object undefined");
1451            
1452             }
1453            
1454             }
1455              
1456             # compute profile header and tag table size
1457 0           $self->[1][0] = 132 + @{$self->[2]} * 12;
  0            
1458              
1459             # for each unique tag
1460 0           for (values(%hash)) {
1461            
1462             # add tag size (with padding to 4-byte boundary)
1463 0           $self->[1][0] += $_;
1464            
1465             }
1466              
1467             # initialize hash
1468 0           %hash = ();
1469              
1470             # initialize file pointer
1471 0           $fp = 132 + @{$self->[2]} * 12;
  0            
1472              
1473             # for each tag
1474 0           for my $tag (@{$self->[2]}) {
  0            
1475            
1476             # if tag already processed
1477 0 0         if (exists($hash{$tag->[3]})) {
1478            
1479             # copy offset
1480 0           $tag->[1] = $hash{$tag->[3]};
1481            
1482             } else {
1483            
1484             # set offset
1485 0           $tag->[1] = $fp;
1486            
1487             # add tag to hash
1488 0           $hash{$tag->[3]} = $fp;
1489            
1490             # increment offset with padding to 4-byte boundary
1491 0           $fp += $tag->[2] + (-$tag->[2] % 4);
1492            
1493             }
1494            
1495             }
1496              
1497             # if path a scalar reference
1498 0 0         if (ref($path) eq 'SCALAR') {
    0          
1499            
1500             # open the profile file
1501 0 0         open($fh, '>', $path) or croak("unable to write profile to scalar");
1502            
1503             # if path a scalar
1504             } elsif (! ref($path)) {
1505            
1506             # filter file path
1507 0           ICC::Shared::filterPath($path);
1508            
1509             # open the profile file
1510 0 0         open($fh, '>', $path) or croak("unable to write profile to $path");
1511            
1512             } else {
1513            
1514             # error
1515 0           croak("invalid path parameter");
1516            
1517             }
1518              
1519             # set binary mode
1520 0           binmode($fh);
1521              
1522             # write header
1523 0           _writeICCheader($fh, $self->[1]);
1524              
1525             # write tag table
1526 0           _writeICCtagtable($fh, $self->[2]);
1527              
1528             # initialize hash
1529 0           %hash = ();
1530              
1531             # for each tag
1532 0           for my $tag (@{$self->[2]}) {
  0            
1533            
1534             # if tag not written
1535 0 0         if (! exists($hash{$tag->[3]})) {
1536            
1537             # if tag is writable
1538 0 0         if ($tag->[3]->can('write_fh')) {
1539            
1540             # write tag
1541 0           $tag->[3]->write_fh($self, $fh, $tag);
1542            
1543             # add to hash
1544 0           $hash{$tag->[3]}++;
1545            
1546             } else {
1547            
1548             # get tag signature
1549 0           $sig = $tag->[0];
1550            
1551             # error
1552 0           croak("'$sig' object has no 'write_fh' method");
1553            
1554             }
1555            
1556             }
1557            
1558             }
1559              
1560             # seek EOF (file pointer may be beyond actual EOF)
1561 0           seek($fh, 0, 2);
1562              
1563             # compute padding
1564 0           $pad = $self->[1][0] - tell($fh);
1565              
1566             # check for file overrun
1567 0 0         croak('file overrun') if ($pad < 0);
1568              
1569             # write final padding (if any)
1570 0 0         print $fh "\x00" x $pad if ($pad > 0);
1571              
1572             # close the profile file
1573 0           close($fh);
1574              
1575             # if profile version 4
1576 0 0         if ($vmaj == 4) {
1577            
1578             # re-open the profile file for read-write access
1579 0           open($fh, '+<', $path);
1580            
1581             # set binary mode
1582 0           binmode($fh);
1583            
1584             # calculate MD5 string
1585 0           $self->[1][24] = Digest::MD5->new->addfile($fh)->hexdigest;
1586            
1587             # restore flags
1588 0           $self->[1][14] = $flags;
1589            
1590             # restore rendering intent
1591 0           $self->[1][19] = $ri;
1592            
1593             # re-write header
1594 0           _writeICCheader($fh, $self->[1]);
1595            
1596             # close the profile file
1597 0           close($fh);
1598            
1599             }
1600              
1601             # set file creator and type (Mac OSX) if path not a reference
1602 0 0         ICC::Shared::setFile($path, 'sync', 'prof') if (! ref($path));
1603              
1604             }
1605              
1606             # write ICC header
1607             # parameters: (file_handle, ref_to_header_array)
1608             sub _writeICCheader {
1609              
1610             # get parameters
1611 0     0     my ($fh, $header) = @_;
1612              
1613             # seek to start of header
1614 0           seek($fh, 0, 0);
1615              
1616             # write the header (128 bytes)
1617 0           print $fh pack('N a4 H8 a4 a4 a4 n6 a4 a4 N a4 a4 N2 N N3 a4 H32 x28', @{$header});
  0            
1618              
1619             }
1620              
1621             # write ICC tag table
1622             # parameters: (file_handle, ref_to_tag_table)
1623             sub _writeICCtagtable {
1624              
1625             # get parameters
1626 0     0     my ($fh, $tagtab) = @_;
1627              
1628             # seek to start of tag table
1629 0           seek($fh, 128, 0);
1630              
1631             # write tag count (4 bytes)
1632 0           print $fh pack('N', $#{$tagtab} + 1);
  0            
1633              
1634             # write tag entries
1635 0           for my $tag (@{$tagtab}) {
  0            
1636            
1637             # write tag entry (12 bytes)
1638 0           print $fh pack('a4 N N', @{$tag}[0 .. 2]);
  0            
1639            
1640             }
1641            
1642             }
1643              
1644             # determine tag PCS encoding from A2B tag
1645             # parameters: (ref_to_profile_object, ref_to_tag_object)
1646             # returns: (pcs_type)
1647             sub _pcs {
1648              
1649             # get parameters
1650 0     0     my ($self, $tag) = @_;
1651              
1652             # local variables
1653 0           my (@Labmw);
1654              
1655             # if profile PCS is 'XYZ '
1656 0 0         if ($self->[1][5] eq 'XYZ ') {
    0          
1657            
1658             # return PCS encoding (16-bit XYZ)
1659 0           return(7);
1660            
1661             # if profile PCS is 'Lab '
1662             } elsif ($self->[1][5] eq 'Lab ') {
1663            
1664             # if tag is 'mft2'
1665 0 0         if (UNIVERSAL::isa($tag, 'ICC::Profile::mft2')) {
1666            
1667             # get media white L*a*b* value
1668 0 0         @Labmw = $tag->transform(($self->[1][4] eq 'RGB ' ? 1 : 0) x $tag->input->cin());
1669            
1670             # return PCS encoding (16-bit ICC legacy)
1671 0 0         return(1) if (_dE(@Labmw, 65280/65535, 32768/65535, 32768/65535) < 0.00195);
1672            
1673             # return PCS encoding (Monaco)
1674 0 0         return(2) if (_dE(@Labmw, 1, 32768/65535, 32768/65535) < 0.00195);
1675            
1676             # print warning
1677 0           print "profile PCS encoding is ambiguous\n";
1678            
1679             # return PCS encoding (16-bit legacy)
1680 0           return(1);
1681            
1682             } else {
1683            
1684             # return PCS encoding (16-bit ICC CIELab)
1685 0           return(0);
1686            
1687             }
1688            
1689             } else {
1690            
1691             # return undefined (might be a device link profile)
1692 0           return();
1693            
1694             }
1695            
1696             }
1697              
1698             # compute deltaE
1699             # parameters: (array_1, array_2)
1700             sub _dE {
1701              
1702             # return
1703 0     0     return(sqrt(($_[0] - $_[3])**2 + (2.55 * ($_[1] - $_[4]))**2 + (2.55 * ($_[2] - $_[5]))**2));
1704              
1705             }
1706              
1707             # convert 'desc' tags to version 4
1708             # see ICC1v43_2010-12.pdf, section 10.18.3
1709             # parameters: (ref_to_object)
1710             sub _to_v4 {
1711              
1712             # get parameters
1713 0     0     my ($self) = shift();
1714              
1715             # for each tag
1716 0           for my $tag (@{$self->[2]}) {
  0            
1717            
1718             # if 'desc' tag type
1719 0 0 0       if (UNIVERSAL::isa($tag->[3], 'ICC::Profile::desc')) {
    0          
    0          
1720            
1721             # replace with equivalent 'mluc' tag
1722 0           $tag->[3] = ICC::Profile::mluc->new('en', 'US', $tag->[3]->ASCII);
1723            
1724             # if 'pseq' tag type
1725             } elsif (UNIVERSAL::isa($tag->[3], 'ICC::Profile::pseq')) {
1726            
1727             # convert any 'desc' tags embedded in the 'pseq' tag
1728             #
1729             # for each pds
1730 0           for my $pds (@{$tag->[3][1]}) {
  0            
1731            
1732             # if profile device manufacturer tag is 'desc' tag type
1733 0 0         if (UNIVERSAL::isa($pds->[5], 'ICC::Profile::desc')) {
1734            
1735             # replace with equivalent 'mluc' tag
1736 0           $pds->[5] = ICC::Profile::mluc->new('en', 'US', $pds->[5]->ASCII);
1737            
1738             }
1739            
1740             # if profile device model tag is 'desc' tag type
1741 0 0         if (UNIVERSAL::isa($pds->[6], 'ICC::Profile::desc')) {
1742            
1743             # replace with equivalent 'mluc' tag
1744 0           $pds->[6] = ICC::Profile::mluc->new('en', 'US', $pds->[6]->ASCII);
1745            
1746             }
1747            
1748             }
1749            
1750             # if 'cprt' tag is 'text' tag type
1751             } elsif ($tag->[0] eq 'cprt' && UNIVERSAL::isa($tag->[3], 'ICC::Profile::text')) {
1752            
1753             # replace with equivalent 'mluc' tag
1754 0           $tag->[3] = ICC::Profile::mluc->new('en', 'US', $tag->[3]->text);
1755            
1756             }
1757            
1758             }
1759            
1760             }
1761              
1762             1;