source: gs2-extensions/parallel-building/trunk/src/perllib/cpan/Image/ExifTool/ICC_Profile.pm@ 24626

Last change on this file since 24626 was 24626, checked in by jmt12, 13 years ago

An (almost) complete copy of the perllib directory from a (circa SEP2011) head checkout from Greenstone 2 trunk - in order to try and make merging in this extension a little easier later on (as there have been some major changes to buildcol.pl commited in the main trunk but not in the x64 branch)
File size: 32.9 KB
Line 
1#------------------------------------------------------------------------------
2# File: ICC_Profile.pm
3#
4# Description: Read ICC Profile meta information
5#
6# Revisions: 11/16/2004 - P. Harvey Created
7#
8# References: 1) http://www.color.org/icc_specs2.html (ICC.1:2003-09)
9# 2) http://www.color.org/icc_specs2.html (ICC.1:2001-04)
10# 3) http://developer.apple.com/documentation/GraphicsImaging/Reference/ColorSync_Manager/ColorSync_Manager.pdf
11# 4) http://www.color.org/privatetag2007-01.pdf
12# 5) http://www.color.org/icc_specs2.xalter (approved revisions, 2010-07-16)
13#
14# Notes: The ICC profile information is different: the format of each
15# tag is embedded in the information instead of in the directory
16# structure. This makes things a bit more complex because I need
17# an extra level of logic to decode the variable-format tags.
18#------------------------------------------------------------------------------
19
20package Image::ExifTool::ICC_Profile;
21
22use strict;
23use vars qw($VERSION);
24use Image::ExifTool qw(:DataAccess :Utils);
25
26$VERSION = '1.22';
27
28sub ProcessICC($$);
29sub ProcessICC_Profile($$$);
30sub WriteICC_Profile($$;$);
31sub ProcessMetadata($$$);
32sub ValidateICC($);
33
34# illuminant type definitions
35my %illuminantType = (
36 1 => 'D50',
37 2 => 'D65',
38 3 => 'D93',
39 4 => 'F2',
40 5 => 'D55',
41 6 => 'A',
42 7 => 'Equi-Power (E)',
43 8 => 'F8',
44);
45my %profileClass = (
46 scnr => 'Input Device Profile',
47 mntr => 'Display Device Profile',
48 prtr => 'Output Device Profile',
49 'link'=> 'DeviceLink Profile',
50 spac => 'ColorSpace Conversion Profile',
51 abst => 'Abstract Profile',
52 nmcl => 'NamedColor Profile',
53 nkpf => 'Nikon Input Device Profile (NON-STANDARD!)', # (written by Nikon utilities)
54);
55
56# ICC_Profile tag table
57%Image::ExifTool::ICC_Profile::Main = (
58 GROUPS => { 2 => 'Image' },
59 PROCESS_PROC => \&ProcessICC_Profile,
60 WRITE_PROC => \&WriteICC_Profile,
61 NOTES => q{
62 ICC profile information is used in many different file types including JPEG,
63 TIFF, PDF, PostScript, Photoshop, PNG, MIFF, PICT, QuickTime, XCF and some
64 RAW formats. While the tags listed below are not individually writable, the
65 entire profile itself can be accessed via the extra 'ICC_Profile' tag, but
66 this tag is neither extracted nor written unless specified explicitly. See
67 L<http://www.color.org/icc_specs2.xalter> for the official ICC
68 specification.
69 },
70 A2B0 => 'AToB0',
71 A2B1 => 'AToB1',
72 A2B2 => 'AToB2',
73 bXYZ => 'BlueMatrixColumn', # (called BlueColorant in ref 2)
74 bTRC => {
75 Name => 'BlueTRC',
76 Description => 'Blue Tone Reproduction Curve',
77 },
78 B2A0 => 'BToA0',
79 B2A1 => 'BToA1',
80 B2A2 => 'BToA2',
81 calt => {
82 Name => 'CalibrationDateTime',
83 Groups => { 2 => 'Time' },
84 PrintConv => '$self->ConvertDateTime($val)',
85 },
86 targ => {
87 Name => 'CharTarget',
88 ValueConv => 'length $val > 128 ? \$val : $val',
89 },
90 chad => 'ChromaticAdaptation',
91 chrm => {
92 Name => 'Chromaticity',
93 Groups => { 1 => 'ICC_Profile#' }, #(just for the group list)
94 SubDirectory => {
95 TagTable => 'Image::ExifTool::ICC_Profile::Chromaticity',
96 Validate => '$type eq "chrm"',
97 },
98 },
99 clro => 'ColorantOrder',
100 clrt => {
101 Name => 'ColorantTable',
102 SubDirectory => {
103 TagTable => 'Image::ExifTool::ICC_Profile::ColorantTable',
104 Validate => '$type eq "clrt"',
105 },
106 },
107 clot => { # new in version 4.2
108 Name => 'ColorantTableOut',
109 Binary => 1,
110 },
111 cprt => {
112 Name => 'ProfileCopyright',
113 ValueConv => '$val=~s/\0.*//; $val', # may be null terminated
114 },
115 crdi => 'CRDInfo', #2
116 dmnd => {
117 Name => 'DeviceMfgDesc',
118 Groups => { 2 => 'Camera' },
119 },
120 dmdd => {
121 Name => 'DeviceModelDesc',
122 Groups => { 2 => 'Camera' },
123 },
124 devs => {
125 Name => 'DeviceSettings', #2
126 Groups => { 2 => 'Camera' },
127 },
128 gamt => 'Gamut',
129 kTRC => {
130 Name => 'GrayTRC',
131 Description => 'Gray Tone Reproduction Curve',
132 },
133 gXYZ => 'GreenMatrixColumn', # (called GreenColorant in ref 2)
134 gTRC => {
135 Name => 'GreenTRC',
136 Description => 'Green Tone Reproduction Curve',
137 },
138 lumi => 'Luminance',
139 meas => {
140 Name => 'Measurement',
141 SubDirectory => {
142 TagTable => 'Image::ExifTool::ICC_Profile::Measurement',
143 Validate => '$type eq "meas"',
144 },
145 },
146 bkpt => 'MediaBlackPoint',
147 wtpt => 'MediaWhitePoint',
148 ncol => 'NamedColor', #2
149 ncl2 => 'NamedColor2',
150 resp => 'OutputResponse',
151 pre0 => 'Preview0',
152 pre1 => 'Preview1',
153 pre2 => 'Preview2',
154 desc => 'ProfileDescription',
155 pseq => 'ProfileSequenceDesc',
156 psd0 => 'PostScript2CRD0', #2
157 psd1 => 'PostScript2CRD1', #2
158 psd2 => 'PostScript2CRD2', #2
159 ps2s => 'PostScript2CSA', #2
160 ps2i => 'PS2RenderingIntent', #2
161 rXYZ => 'RedMatrixColumn', # (called RedColorant in ref 2)
162 rTRC => {
163 Name => 'RedTRC',
164 Description => 'Red Tone Reproduction Curve',
165 },
166 scrd => 'ScreeningDesc',
167 scrn => 'Screening',
168 'bfd '=> {
169 Name => 'UCRBG',
170 Description => 'Under Color Removal and Black Gen.',
171 },
172 tech => {
173 Name => 'Technology',
174 PrintConv => {
175 fscn => 'Film Scanner',
176 dcam => 'Digital Camera',
177 rscn => 'Reflective Scanner',
178 ijet => 'Ink Jet Printer',
179 twax => 'Thermal Wax Printer',
180 epho => 'Electrophotographic Printer',
181 esta => 'Electrostatic Printer',
182 dsub => 'Dye Sublimation Printer',
183 rpho => 'Photographic Paper Printer',
184 fprn => 'Film Writer',
185 vidm => 'Video Monitor',
186 vidc => 'Video Camera',
187 pjtv => 'Projection Television',
188 'CRT '=> 'Cathode Ray Tube Display',
189 'PMD '=> 'Passive Matrix Display',
190 'AMD '=> 'Active Matrix Display',
191 KPCD => 'Photo CD',
192 imgs => 'Photo Image Setter',
193 grav => 'Gravure',
194 offs => 'Offset Lithography',
195 silk => 'Silkscreen',
196 flex => 'Flexography',
197 mpfs => 'Motion Picture Film Scanner', #5
198 mpfr => 'Motion Picture Film Recorder', #5
199 dmpc => 'Digital Motion Picture Camera', #5
200 dcpj => 'Digital Cinema Projector', #5
201 },
202 },
203 vued => 'ViewingCondDesc',
204 view => {
205 Name => 'ViewingConditions',
206 SubDirectory => {
207 TagTable => 'Image::ExifTool::ICC_Profile::ViewingConditions',
208 Validate => '$type eq "view"',
209 },
210 },
211 ciis => 'ColorimetricIntentImageState', #5
212 scoe => 'SceneColorimetryEstimates', #5
213 sape => 'SceneAppearanceEstimates', #5
214 fpce => 'FocalPlaneColorimetryEstimates', #5
215 rhoc => 'ReflectionHardcopyOrigColorimetry', #5
216 rpoc => 'ReflectionPrintOutputColorimetry', #5
217 psid => { #5
218 Name => 'ProfileSequenceIdentifier',
219 Binary => 1,
220 },
221 B2D0 => { Name => 'BToD0', Binary => 1 }, #5
222 B2D1 => { Name => 'BToD1', Binary => 1 }, #5
223 B2D2 => { Name => 'BToD2', Binary => 1 }, #5
224 B2D3 => { Name => 'BToD3', Binary => 1 }, #5
225 D2B0 => { Name => 'DToB0', Binary => 1 }, #5
226 D2B1 => { Name => 'DToB1', Binary => 1 }, #5
227 D2B2 => { Name => 'DToB2', Binary => 1 }, #5
228 D2B3 => { Name => 'DToB3', Binary => 1 }, #5
229 rig0 => { #5
230 Name => 'PerceptualRenderingIntentGamut',
231 PrintConv => {
232 prmg => 'Perceptual Reference Medium Gamut',
233 },
234 },
235 rig2 => { #5
236 Name => 'SaturationRenderingIntentGamut',
237 PrintConv => {
238 prmg => 'Perceptual Reference Medium Gamut',
239 },
240 },
241 meta => { #5 (EVENTUALLY DECODE THIS ONCE WE HAVE A SAMPLE!!)
242 Name => 'Metadata',
243 SubDirectory => {
244 TagTable => 'Image::ExifTool::ICC_Profile::Metadata',
245 Validate => '$type eq "meta"',
246 },
247 },
248
249 # ColorSync custom tags (ref 3)
250 psvm => 'PS2CRDVMSize',
251 vcgt => 'VideoCardGamma',
252 mmod => 'MakeAndModel',
253 dscm => 'ProfileDescriptionML',
254 ndin => 'NativeDisplayInfo',
255
256 # Microsoft custom tags (ref http://msdn2.microsoft.com/en-us/library/ms536870.aspx)
257 MS00 => 'WCSProfiles',
258
259 # the following entry represents the ICC profile header, and doesn't
260 # exist as a tag in the directory. It is only in this table to provide
261 # a link so ExifTool can locate the header tags
262 Header => {
263 Name => 'ProfileHeader',
264 SubDirectory => {
265 TagTable => 'Image::ExifTool::ICC_Profile::Header',
266 },
267 },
268);
269
270# ICC profile header definition
271%Image::ExifTool::ICC_Profile::Header = (
272 PROCESS_PROC => \&Image::ExifTool::ProcessBinaryData,
273 GROUPS => { 0 => 'ICC_Profile', 1 => 'ICC-header', 2 => 'Image' },
274 4 => {
275 Name => 'ProfileCMMType',
276 Format => 'string[4]',
277 },
278 8 => {
279 Name => 'ProfileVersion',
280 Format => 'int16s',
281 PrintConv => '($val >> 8).".".(($val & 0xf0)>>4).".".($val & 0x0f)',
282 },
283 12 => {
284 Name => 'ProfileClass',
285 Format => 'string[4]',
286 PrintConv => \%profileClass,
287 },
288 16 => {
289 Name => 'ColorSpaceData',
290 Format => 'string[4]',
291 },
292 20 => {
293 Name => 'ProfileConnectionSpace',
294 Format => 'string[4]',
295 },
296 24 => {
297 Name => 'ProfileDateTime',
298 Groups => { 2 => 'Time' },
299 Format => 'int16u[6]',
300 ValueConv => 'sprintf("%.4d:%.2d:%.2d %.2d:%.2d:%.2d",split(" ",$val));',
301 PrintConv => '$self->ConvertDateTime($val)',
302 },
303 36 => {
304 Name => 'ProfileFileSignature',
305 Format => 'string[4]',
306 },
307 40 => {
308 Name => 'PrimaryPlatform',
309 Format => 'string[4]',
310 PrintConv => {
311 'APPL' => 'Apple Computer Inc.',
312 'MSFT' => 'Microsoft Corporation',
313 'SGI ' => 'Silicon Graphics Inc.',
314 'SUNW' => 'Sun Microsystems Inc.',
315 'TGNT' => 'Taligent Inc.',
316 },
317 },
318 44 => {
319 Name => 'CMMFlags',
320 Format => 'int32u',
321 PrintConv => q[
322 ($val & 0x01 ? "Embedded, " : "Not Embedded, ") .
323 ($val & 0x02 ? "Not Independent" : "Independent")
324 ],
325 },
326 48 => {
327 Name => 'DeviceManufacturer',
328 Format => 'string[4]',
329 # KODA = Kodak
330 },
331 52 => {
332 Name => 'DeviceModel',
333 Format => 'string[4]',
334 # ROMM = Refrence Output Medium Metric
335 },
336 56 => {
337 Name => 'DeviceAttributes',
338 Format => 'int32u[2]',
339 PrintConv => q[
340 my @v = split ' ', $val;
341 ($v[1] & 0x01 ? "Transparency, " : "Reflective, ") .
342 ($v[1] & 0x02 ? "Matte, " : "Glossy, ") .
343 ($v[1] & 0x04 ? "Negative, " : "Positive, ") .
344 ($v[1] & 0x08 ? "B&W" : "Color");
345 ],
346 },
347 64 => {
348 Name => 'RenderingIntent',
349 Format => 'int32u',
350 PrintConv => {
351 0 => 'Perceptual',
352 1 => 'Media-Relative Colorimetric',
353 2 => 'Saturation',
354 3 => 'ICC-Absolute Colorimetric',
355 },
356 },
357 68 => {
358 Name => 'ConnectionSpaceIlluminant',
359 Format => 'fixed32s[3]', # xyz
360 },
361 80 => {
362 Name => 'ProfileCreator',
363 Format => 'string[4]',
364 # KODA = Kodak
365 },
366 84 => {
367 Name => 'ProfileID',
368 Format => 'int8u[16]',
369 PrintConv => 'Image::ExifTool::ICC_Profile::HexID($val)',
370 },
371);
372
373# viewingConditionsType (view) definition
374%Image::ExifTool::ICC_Profile::ViewingConditions = (
375 PROCESS_PROC => \&Image::ExifTool::ProcessBinaryData,
376 GROUPS => { 0 => 'ICC_Profile', 1 => 'ICC-view', 2 => 'Image' },
377 8 => {
378 Name => 'ViewingCondIlluminant',
379 Format => 'fixed32s[3]', # xyz
380 },
381 20 => {
382 Name => 'ViewingCondSurround',
383 Format => 'fixed32s[3]', # xyz
384 },
385 32 => {
386 Name => 'ViewingCondIlluminantType',
387 Format => 'int32u',
388 PrintConv => \%illuminantType,
389 },
390);
391
392# measurementType (meas) definition
393%Image::ExifTool::ICC_Profile::Measurement = (
394 PROCESS_PROC => \&Image::ExifTool::ProcessBinaryData,
395 GROUPS => { 0 => 'ICC_Profile', 1 => 'ICC-meas', 2 => 'Image' },
396 8 => {
397 Name => 'MeasurementObserver',
398 Format => 'int32u',
399 PrintConv => {
400 1 => 'CIE 1931',
401 2 => 'CIE 1964',
402 },
403 },
404 12 => {
405 Name => 'MeasurementBacking',
406 Format => 'fixed32s[3]', # xyz
407 },
408 24 => {
409 Name => 'MeasurementGeometry',
410 Format => 'int32u',
411 PrintConv => {
412 1 => '0/45 or 45/0',
413 2 => '0/d or d/0',
414 },
415 },
416 28 => {
417 Name => 'MeasurementFlare',
418 Format => 'fixed32u',
419 PrintConv => '$val*100 . "%"', # change into a percent
420 },
421 32 => {
422 Name => 'MeasurementIlluminant',
423 Format => 'int32u',
424 PrintConv => \%illuminantType,
425 },
426);
427
428# chromaticity (chrm) definition
429%Image::ExifTool::ICC_Profile::Chromaticity = (
430 PROCESS_PROC => \&Image::ExifTool::ProcessBinaryData,
431 GROUPS => { 0 => 'ICC_Profile', 1 => 'ICC-chrm', 2 => 'Image' },
432 8 => {
433 Name => 'ChromaticityChannels',
434 Format => 'int16u',
435 },
436 10 => {
437 Name => 'ChromaticityColorant',
438 Format => 'int16u',
439 PrintConv => {
440 1 => 'ITU-R BT.709',
441 2 => 'SMPTE RP145-1994',
442 3 => 'EBU Tech.3213-E',
443 4 => 'P22',
444 },
445 },
446 # include definitions for 4 channels -- if there are
447 # fewer then the ProcessBinaryData logic won't print them.
448 # If there are more, oh well.
449 12 => {
450 Name => 'ChromaticityChannel1',
451 Format => 'fixed32u[2]',
452 },
453 20 => {
454 Name => 'ChromaticityChannel2',
455 Format => 'fixed32u[2]',
456 },
457 28 => {
458 Name => 'ChromaticityChannel3',
459 Format => 'fixed32u[2]',
460 },
461 36 => {
462 Name => 'ChromaticityChannel4',
463 Format => 'fixed32u[2]',
464 },
465);
466
467# colorantTable (clrt) definition
468%Image::ExifTool::ICC_Profile::ColorantTable = (
469 PROCESS_PROC => \&Image::ExifTool::ProcessBinaryData,
470 GROUPS => { 0 => 'ICC_Profile', 1 => 'ICC-clrt', 2 => 'Image' },
471 8 => {
472 Name => 'ColorantCount',
473 Format => 'int32u',
474 },
475 # include definitions for 3 colorants -- if there are
476 # fewer then the ProcessBinaryData logic won't print them.
477 # If there are more, oh well.
478 12 => {
479 Name => 'Colorant1Name',
480 Format => 'string[32]',
481 },
482 44 => {
483 Name => 'Colorant1Coordinates',
484 Format => 'int16u[3]',
485 },
486 50 => {
487 Name => 'Colorant2Name',
488 Format => 'string[32]',
489 },
490 82 => {
491 Name => 'Colorant2Coordinates',
492 Format => 'int16u[3]',
493 },
494 88 => {
495 Name => 'Colorant3Name',
496 Format => 'string[32]',
497 },
498 120 => {
499 Name => 'Colorant3Coordinates',
500 Format => 'int16u[3]',
501 },
502);
503
504# metadata (meta) tags
505%Image::ExifTool::ICC_Profile::Metadata = (
506 PROCESS_PROC => \&ProcessMetadata,
507 GROUPS => { 0 => 'ICC_Profile', 1 => 'ICC-meta', 2 => 'Image' },
508 VARS => { NO_ID => 1 },
509 NOTES => q{
510 Only these few tags have been pre-defined, but ExifTool will extract any
511 Metadata tags that exist.
512 },
513 ManufacturerName => { },
514 MediaColor => { },
515 MediaWeight => { },
516);
517
518#------------------------------------------------------------------------------
519# print ICC Profile ID in hex
520# Inputs: 1) string of numbers
521# Returns: string of hex digits
522sub HexID($)
523{
524 my $val = shift;
525 my @vals = split(' ', $val);
526 # return a simple zero if no MD5 done
527 return 0 unless grep(!/^0/, @vals);
528 $val = '';
529 foreach (@vals) { $val .= sprintf("%.2x",$_); }
530 return $val;
531}
532
533#------------------------------------------------------------------------------
534# get formatted value from ICC tag (which has the type embedded)
535# Inputs: 0) data reference, 1) offset to tag data, 2) tag data size
536# Returns: Formatted value or undefined if format not supported
537# Notes: The following types are handled by BinaryTables:
538# chromaticityType, colorantTableType, measurementType, viewingConditionsType
539# The following types are not currently handled (most are large tables):
540# curveType, lut16Type, lut8Type, lutAtoBType, lutBtoAType, namedColor2Type,
541# parametricCurveType, profileSeqDescType, responseCurveSet16Type
542# The multiLocalizedUnicodeType must be handled by the calling routine.
543sub FormatICCTag($$$)
544{
545 my ($dataPt, $offset, $size) = @_;
546
547 my $type;
548 if ($size >= 8) {
549 # get data type from start of tag data
550 $type = substr($$dataPt, $offset, 4);
551 } else {
552 $type = 'err';
553 }
554 # colorantOrderType
555 if ($type eq 'clro' and $size >= 12) {
556 my $num = Get32u($dataPt, $offset+8);
557 if ($size >= $num + 12) {
558 my $pos = $offset + 12;
559 return join(' ',unpack("x$pos c$num", $$dataPt));
560 }
561 }
562 # dataType
563 if ($type eq 'data' and $size >= 12) {
564 my $form = Get32u($dataPt, $offset+8);
565 # format 0 is ASCII data
566 $form == 0 and return substr($$dataPt, $offset+12, $size-12);
567 # binary data and other data types treat as binary (ie. don't format)
568 }
569 # dateTimeType
570 if ($type eq 'dtim' and $size >= 20) {
571 return sprintf("%.4d:%.2d:%.2d %.2d:%.2d:%.2d",
572 Get16u($dataPt, $offset+8), Get16u($dataPt, $offset+10),
573 Get16u($dataPt, $offset+12), Get16u($dataPt, $offset+14),
574 Get16u($dataPt, $offset+16), Get16u($dataPt, $offset+18));
575 }
576 # s15Fixed16ArrayType
577 if ($type eq 'sf32') {
578 return ReadValue($dataPt,$offset+8,'fixed32s',($size-8)/4,$size-8);
579 }
580 # signatureType
581 if ($type eq 'sig ' and $size >= 12) {
582 return substr($$dataPt, $offset+8, 4);
583 }
584 # textType
585 $type eq 'text' and return substr($$dataPt, $offset+8, $size-8);
586 # textDescriptionType (ref 2, replaced by multiLocalizedUnicodeType)
587 if ($type eq 'desc' and $size >= 12) {
588 my $len = Get32u($dataPt, $offset+8);
589 if ($size >= $len + 12) {
590 my $str = substr($$dataPt, $offset+12, $len);
591 $str =~ s/\0.*//s; # truncate at null terminator
592 return $str;
593 }
594 }
595 # u16Fixed16ArrayType
596 if ($type eq 'uf32') {
597 return ReadValue($dataPt,$offset+8,'fixed32u',($size-8)/4,$size-8);
598 }
599 # uInt32ArrayType
600 if ($type eq 'ui32') {
601 return ReadValue($dataPt,$offset+8,'int32u',($size-8)/4,$size-8);
602 }
603 # uInt64ArrayType
604 if ($type eq 'ui64') {
605 return ReadValue($dataPt,$offset+8,'int64u',($size-8)/8,$size-8);
606 }
607 # uInt8ArrayType
608 if ($type eq 'ui08') {
609 return ReadValue($dataPt,$offset+8,'int8u',$size-8,$size-8);
610 }
611 # XYZType
612 if ($type eq 'XYZ ') {
613 my $str = '';
614 my $pos;
615 for ($pos=8; $pos+12<=$size; $pos+=12) {
616 $str and $str .= ', ';
617 $str .= ReadValue($dataPt,$offset+$pos,'fixed32s',3,$size-$pos);
618 }
619 return $str;
620 }
621 return undef; # data type is not supported
622}
623
624#------------------------------------------------------------------------------
625# Process ICC metadata record (ref 5) (UNTESTED!)
626# Inputs: 0) ExifTool ref, 1) dirInfo ref, 2) tag table ref
627# Returns: 1 on success
628sub ProcessMetadata($$$)
629{
630 my ($exifTool, $dirInfo, $tagTablePtr) = @_;
631 my $dataPt = $$dirInfo{DataPt};
632 my $dirStart = $$dirInfo{DirStart};
633 my $dirLen = $$dirInfo{DirLen};
634 my $dirEnd = $dirStart + $dirLen;
635
636 if ($dirLen < 16 or substr($$dataPt, $dirStart, 4) ne 'dict') {
637 $exifTool->Warn('Invalid ICC meta dictionary');
638 return 0;
639 }
640 my $num = Get32u($dataPt, $dirStart + 8);
641 $exifTool->VerboseDir('Metadata', $num);
642 my $size = Get32u($dataPt, $dirStart + 12);
643 $size < 16 and $exifTool->Warn('Invalid ICC meta record size'), return 0;
644 # NOTE: In the example the minimum offset is 20,
645 # but this doesn't jive with the table (both in ref 5)
646 my $minPtr = 16 + $size * $num;
647 my $index;
648 for ($index=0; $index<$num; ++$index) {
649 my $entry = $dirStart + 16 + $size * $index;
650 if ($entry + $size > $dirEnd) {
651 $exifTool->Warn('Truncated ICC meta dictionary');
652 last;
653 }
654 my $namePtr = Get32u($dataPt, $entry);
655 my $nameLen = Get32u($dataPt, $entry + 4);
656 my $valuePtr = Get32u($dataPt, $entry + 8);
657 my $valueLen = Get32u($dataPt, $entry + 16);
658 next unless $namePtr and $valuePtr; # ignore if offsets are zero
659 if ($namePtr < $minPtr or $namePtr + $nameLen > $dirLen or
660 $valuePtr < $minPtr or $valuePtr + $valueLen > $dirLen)
661 {
662 $exifTool->Warn('Corrupted ICC meta dictionary');
663 last;
664 }
665 my $tag = substr($dataPt, $dirStart + $namePtr, $nameLen);
666 my $val = substr($dataPt, $dirStart + $valuePtr, $valueLen);
667 $tag = $exifTool->Decode($tag, 'UTF16', 'MM', 'UTF8');
668 $val = $exifTool->Decode($val, 'UTF16', 'MM');
669 # generate tagInfo if it doesn't exist
670 unless ($$tagTablePtr{$tag}) {
671 my $name = ucfirst $tag;
672 $name =~ s/\s+(.)/\u$1/g;
673 $name =~ tr/-_a-zA-Z0-9//dc;
674 next unless length $name;
675 Image::ExifTool::AddTagToTable($tagTablePtr, $tag, { Name => $name });
676 }
677 $exifTool->HandleTag($tagTablePtr, $tag, $val);
678 }
679 return 1;
680}
681
682#------------------------------------------------------------------------------
683# Write ICC profile file
684# Inputs: 0) ExifTool object reference, 1) Reference to directory information
685# Returns: 1 on success, 0 if this wasn't a valid ICC file,
686# or -1 if a write error occurred
687sub WriteICC($$)
688{
689 my ($exifTool, $dirInfo) = @_;
690 # first make sure this is a valid ICC file (or no file at all)
691 my $raf = $$dirInfo{RAF};
692 my $buff;
693 return 0 if $raf->Read($buff, 24) and ValidateICC(\$buff);
694 # now write the new ICC
695 $buff = WriteICC_Profile($exifTool, $dirInfo);
696 if (defined $buff and length $buff) {
697 Write($$dirInfo{OutFile}, $buff) or return -1;
698 } else {
699 $exifTool->Error('No ICC information to write');
700 }
701 return 1;
702}
703
704#------------------------------------------------------------------------------
705# Write ICC data as a block
706# Inputs: 0) ExifTool object reference, 1) source dirInfo reference,
707# 2) tag table reference
708# Returns: ICC data block (may be empty if no ICC data)
709# Notes: Increments ExifTool CHANGED flag if changed
710sub WriteICC_Profile($$;$)
711{
712 my ($exifTool, $dirInfo, $tagTablePtr) = @_;
713 $exifTool or return 1; # allow dummy access
714 my $dirName = $$dirInfo{DirName} || 'ICC_Profile';
715 # (don't write AsShotICCProfile or CurrentICCProfile here)
716 return undef unless $dirName eq 'ICC_Profile';
717 my $nvHash = $exifTool->GetNewValueHash($Image::ExifTool::Extra{$dirName});
718 return undef unless Image::ExifTool::IsOverwriting($nvHash);
719 my $val = Image::ExifTool::GetNewValues($nvHash);
720 $val = '' unless defined $val;
721 ++$exifTool->{CHANGED};
722 return $val;
723}
724
725#------------------------------------------------------------------------------
726# Validate ICC data
727# Inputs: 0) ICC data reference
728# Returns: error string or undef on success
729sub ValidateICC($)
730{
731 my $valPtr = shift;
732 my $err;
733 length($$valPtr) < 24 and return 'Invalid ICC profile';
734 $profileClass{substr($$valPtr, 12, 4)} or $err = 'profile class';
735 my $col = substr($$valPtr, 16, 4); # ColorSpaceData
736 my $con = substr($$valPtr, 20, 4); # ConnectionSpace
737 my $match = '(XYZ |Lab |Luv |YCbr|Yxy |RGB |GRAY|HSV |HLS |CMYK|CMY |[2-9A-F]CLR)';
738 $col =~ /$match/ or $err = 'color space';
739 $con =~ /$match/ or $err = 'connection space';
740 return $err ? "Invalid ICC profile (bad $err)" : undef;
741}
742
743#------------------------------------------------------------------------------
744# Process ICC profile file
745# Inputs: 0) ExifTool object reference, 1) Reference to directory information
746# Returns: 1 if this was an ICC file
747sub ProcessICC($$)
748{
749 my ($exifTool, $dirInfo) = @_;
750 my $raf = $$dirInfo{RAF};
751 my $buff;
752 $raf->Read($buff, 24) == 24 or return 0;
753 # check to see if this is a valid ICC profile file
754 return 0 if ValidateICC(\$buff);
755 $exifTool->SetFileType();
756 # read the profile
757 my $size = unpack('N', $buff);
758 if ($size < 128 or $size & 0x80000000) {
759 $exifTool->Error("Bad ICC Profile length ($size)");
760 return 1;
761 }
762 $raf->Seek(0, 0);
763 unless ($raf->Read($buff, $size)) {
764 $exifTool->Error('Truncated ICC profile');
765 return 1;
766 }
767 my %dirInfo = (
768 DataPt => \$buff,
769 DataLen => $size,
770 DirStart => 0,
771 DirLen => $size,
772 );
773 my $tagTablePtr = GetTagTable('Image::ExifTool::ICC_Profile::Main');
774 return ProcessICC_Profile($exifTool, \%dirInfo, $tagTablePtr);
775}
776
777#------------------------------------------------------------------------------
778# Process ICC_Profile APP13 record
779# Inputs: 0) ExifTool object reference, 1) Reference to directory information
780# 2) Tag table reference (undefined to read ICC file)
781# Returns: 1 on success
782sub ProcessICC_Profile($$$)
783{
784 my ($exifTool, $dirInfo, $tagTablePtr) = @_;
785 my $dataPt = $$dirInfo{DataPt};
786 my $dirStart = $$dirInfo{DirStart};
787 my $dirLen = $$dirInfo{DirLen};
788 my $verbose = $exifTool->Options('Verbose');
789
790 return 0 if $dirLen < 4;
791
792 # extract binary ICC_Profile data block if binary mode or requested
793 if ($exifTool->{OPTIONS}->{Binary} or $exifTool->{REQ_TAG_LOOKUP}->{icc_profile} and
794 # (don't extract from AsShotICCProfile or CurrentICCProfile)
795 (not $$dirInfo{Name} or $$dirInfo{Name} eq 'ICC_Profile'))
796 {
797 $exifTool->FoundTag('ICC_Profile', substr($$dataPt, $dirStart, $dirLen));
798 }
799
800 SetByteOrder('MM'); # ICC_Profile is always big-endian
801
802 # check length of table
803 my $len = Get32u($dataPt, $dirStart);
804 if ($len != $dirLen or $len < 128) {
805 $exifTool->Warn("Bad length ICC_Profile (length $len)");
806 return 0 if $len < 128 or $dirLen < $len;
807 }
808 my $pos = $dirStart + 128; # position at start of table
809 my $numEntries = Get32u($dataPt, $pos);
810 if ($numEntries < 1 or $numEntries >= 0x100
811 or $numEntries * 12 + 132 > $dirLen)
812 {
813 $exifTool->Warn("Bad ICC_Profile table ($numEntries entries)");
814 return 0;
815 }
816
817 if ($verbose) {
818 $exifTool->VerboseDir('ICC_Profile', $numEntries, $dirLen);
819 my $fakeInfo = { Name=>'ProfileHeader', SubDirectory => { } };
820 $exifTool->VerboseInfo(undef, $fakeInfo);
821 }
822 # increment ICC dir count
823 my $dirCount = $exifTool->{DIR_COUNT}->{ICC} = ($exifTool->{DIR_COUNT}->{ICC} || 0) + 1;
824 $exifTool->{SET_GROUP1} = '+' . $dirCount if $dirCount > 1;
825 # process the header block
826 my %subdirInfo = (
827 Name => 'ProfileHeader',
828 DataPt => $dataPt,
829 DataLen => $$dirInfo{DataLen},
830 DirStart => $dirStart,
831 DirLen => 128,
832 Parent => $$dirInfo{DirName},
833 );
834 my $newTagTable = GetTagTable('Image::ExifTool::ICC_Profile::Header');
835 $exifTool->ProcessDirectory(\%subdirInfo, $newTagTable);
836
837 $pos += 4; # skip item count
838 my $index;
839 for ($index=0; $index<$numEntries; ++$index) {
840 my $tagID = substr($$dataPt, $pos, 4);
841 my $offset = Get32u($dataPt, $pos + 4);
842 my $size = Get32u($dataPt, $pos + 8);
843 $pos += 12;
844 my $tagInfo = $exifTool->GetTagInfo($tagTablePtr, $tagID);
845 # unknown tags aren't generated automatically by GetTagInfo()
846 # if the tagID's aren't numeric, so we must do this manually:
847 if (not $tagInfo and $exifTool->{OPTIONS}->{Unknown}) {
848 $tagInfo = { Unknown => 1 };
849 Image::ExifTool::AddTagToTable($tagTablePtr, $tagID, $tagInfo);
850 }
851 next unless defined $tagInfo;
852
853 if ($offset + $size > $dirLen) {
854 $exifTool->Warn("Bad ICC_Profile table (truncated)");
855 last;
856 }
857 my $valuePtr = $dirStart + $offset;
858
859 my $subdir = $$tagInfo{SubDirectory};
860 # format the value unless this is a subdirectory
861 my ($value, $fmt);
862 if ($size > 4) {
863 $fmt = substr($$dataPt, $valuePtr, 4);
864 # handle multiLocalizedUnicodeType
865 if ($fmt eq 'mluc' and not $subdir) {
866 next if $size < 28;
867 my $count = Get32u($dataPt, $valuePtr + 8);
868 my $recLen = Get32u($dataPt, $valuePtr + 12);
869 next if $recLen < 12;
870 my $i;
871 for ($i=0; $i<$count; ++$i) {
872 my $recPos = $valuePtr + 16 + $i * $recLen;
873 last if $recPos + $recLen > $valuePtr + $size;
874 my $lang = substr($$dataPt, $recPos, 4);
875 my $langInfo;
876 # validate language code and change to standard case (just in case)
877 if ($lang =~ s/^([a-z]{2})([A-Z]{2})$/\L$1-\U$2/i and $lang ne 'en-US') {
878 $langInfo = Image::ExifTool::GetLangInfo($tagInfo, $lang);
879 }
880 my $strLen = Get32u($dataPt, $recPos + 4);
881 my $strPos = Get32u($dataPt, $recPos + 8);
882 last if $strPos + $strLen > $size;
883 my $str = substr($$dataPt, $valuePtr + $strPos, $strLen);
884 $str = $exifTool->Decode($str, 'UTF16');
885 $exifTool->HandleTag($tagTablePtr, $tagID, $str,
886 TagInfo => $langInfo || $tagInfo,
887 Table => $tagTablePtr,
888 Index => $index,
889 Value => $str,
890 DataPt => $dataPt,
891 Size => $strLen,
892 Start => $valuePtr + $strPos,
893 Format => "type '$fmt'",
894 );
895 }
896 $exifTool->Warn("Corrupted $$tagInfo{Name} data") if $i < $count;
897 next;
898 }
899 } else {
900 $fmt = 'err ';
901 }
902 $value = FormatICCTag($dataPt, $valuePtr, $size) unless $subdir;
903 $verbose and $exifTool->VerboseInfo($tagID, $tagInfo,
904 Table => $tagTablePtr,
905 Index => $index,
906 Value => $value,
907 DataPt => $dataPt,
908 Size => $size,
909 Start => $valuePtr,
910 Format => "type '$fmt'",
911 );
912 if ($subdir) {
913 my $name = $$tagInfo{Name};
914 undef $newTagTable;
915 if ($$subdir{TagTable}) {
916 $newTagTable = GetTagTable($$subdir{TagTable});
917 unless ($newTagTable) {
918 warn "Unknown tag table $$subdir{TagTable}\n";
919 next;
920 }
921 } else {
922 warn "Must specify TagTable for SubDirectory $name\n";
923 next;
924 }
925 %subdirInfo = (
926 Name => $name,
927 DataPt => $dataPt,
928 DataPos => $$dirInfo{DataPos},
929 DataLen => $$dirInfo{DataLen},
930 DirStart => $valuePtr,
931 DirLen => $size,
932 Parent => $$dirInfo{DirName},
933 );
934 my $type = substr($$dataPt, $valuePtr, 4);
935 #### eval Validate ($type)
936 if (defined $$subdir{Validate} and not eval $$subdir{Validate}) {
937 $exifTool->Warn("Invalid $name data");
938 } else {
939 $exifTool->ProcessDirectory(\%subdirInfo, $newTagTable, $$subdir{ProcessProc});
940 }
941 } elsif (defined $value) {
942 $exifTool->FoundTag($tagInfo, $value);
943 } else {
944 $value = substr($$dataPt, $valuePtr, $size);
945 # treat unsupported formats as binary data
946 $$tagInfo{ValueConv} = '\$val' unless defined $$tagInfo{ValueConv};
947 $exifTool->FoundTag($tagInfo, $value);
948 }
949 }
950 delete $exifTool->{SET_GROUP1};
951 return 1;
952}
953
954
9551; # end
956
957
958__END__
959
960=head1 NAME
961
962Image::ExifTool::ICC_Profile - Read ICC Profile meta information
963
964=head1 SYNOPSIS
965
966This module is loaded automatically by Image::ExifTool when required.
967
968=head1 DESCRIPTION
969
970This module contains the definitions to read information from ICC profiles.
971ICC (International Color Consortium) profiles are used to translate color
972data created on one device into another device's native color space.
973
974=head1 AUTHOR
975
976Copyright 2003-2011, Phil Harvey (phil at owl.phy.queensu.ca)
977
978This library is free software; you can redistribute it and/or modify it
979under the same terms as Perl itself.
980
981=head1 REFERENCES
982
983=over 4
984
985=item L<http://www.color.org/icc_specs2.html>
986
987=item L<http://developer.apple.com/documentation/GraphicsImaging/Reference/ColorSync_Manager/ColorSync_Manager.pdf>
988
989=back
990
991=head1 SEE ALSO
992
993L<Image::ExifTool::TagNames/ICC_Profile Tags>,
994L<Image::ExifTool(3pm)|Image::ExifTool>
995
996=cut
Note: See TracBrowser for help on using the repository browser.