source: gsdl/trunk/perllib/cpan/Image/ExifTool/ICC_Profile.pm@ 16842

Last change on this file since 16842 was 16842, checked in by davidb, 16 years ago

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