#------------------------------------------------------------------------------ # File: ICC_Profile.pm # # Description: Read ICC Profile meta information # # Revisions: 11/16/2004 - P. Harvey Created # # References: 1) http://www.color.org/icc_specs2.html (ICC.1:2003-09) # 2) http://www.color.org/icc_specs2.html (ICC.1:2001-04) # 3) http://developer.apple.com/documentation/GraphicsImaging/Reference/ColorSync_Manager/ColorSync_Manager.pdf # 4) http://www.color.org/privatetag2007-01.pdf # 5) http://www.color.org/icc_specs2.xalter (approved revisions, 2010-07-16) # # Notes: The ICC profile information is different: the format of each # tag is embedded in the information instead of in the directory # structure. This makes things a bit more complex because I need # an extra level of logic to decode the variable-format tags. #------------------------------------------------------------------------------ package Image::ExifTool::ICC_Profile; use strict; use vars qw($VERSION); use Image::ExifTool qw(:DataAccess :Utils); $VERSION = '1.29'; sub ProcessICC($$); sub ProcessICC_Profile($$$); sub WriteICC_Profile($$;$); sub ProcessMetadata($$$); sub ValidateICC($); # illuminant type definitions my %illuminantType = ( 1 => 'D50', 2 => 'D65', 3 => 'D93', 4 => 'F2', 5 => 'D55', 6 => 'A', 7 => 'Equi-Power (E)', 8 => 'F8', ); my %profileClass = ( scnr => 'Input Device Profile', mntr => 'Display Device Profile', prtr => 'Output Device Profile', 'link'=> 'DeviceLink Profile', spac => 'ColorSpace Conversion Profile', abst => 'Abstract Profile', nmcl => 'NamedColor Profile', nkpf => 'Nikon Input Device Profile (NON-STANDARD!)', # (written by Nikon utilities) ); # ICC_Profile tag table %Image::ExifTool::ICC_Profile::Main = ( GROUPS => { 2 => 'Image' }, PROCESS_PROC => \&ProcessICC_Profile, WRITE_PROC => \&WriteICC_Profile, NOTES => q{ ICC profile information is used in many different file types including JPEG, TIFF, PDF, PostScript, Photoshop, PNG, MIFF, PICT, QuickTime, XCF and some RAW formats. While the tags listed below are not individually writable, the entire profile itself can be accessed via the extra 'ICC_Profile' tag, but this tag is neither extracted nor written unless specified explicitly. See L for the official ICC specification. }, A2B0 => 'AToB0', A2B1 => 'AToB1', A2B2 => 'AToB2', bXYZ => 'BlueMatrixColumn', # (called BlueColorant in ref 2) bTRC => { Name => 'BlueTRC', Description => 'Blue Tone Reproduction Curve', }, B2A0 => 'BToA0', B2A1 => 'BToA1', B2A2 => 'BToA2', calt => { Name => 'CalibrationDateTime', Groups => { 2 => 'Time' }, PrintConv => '$self->ConvertDateTime($val)', }, targ => { Name => 'CharTarget', ValueConv => 'length $val > 128 ? \$val : $val', }, chad => 'ChromaticAdaptation', chrm => { Name => 'Chromaticity', Groups => { 1 => 'ICC_Profile#' }, #(just for the group list) SubDirectory => { TagTable => 'Image::ExifTool::ICC_Profile::Chromaticity', Validate => '$type eq "chrm"', }, }, clro => 'ColorantOrder', clrt => { Name => 'ColorantTable', SubDirectory => { TagTable => 'Image::ExifTool::ICC_Profile::ColorantTable', Validate => '$type eq "clrt"', }, }, clot => { # new in version 4.2 Name => 'ColorantTableOut', Binary => 1, }, cprt => { Name => 'ProfileCopyright', ValueConv => '$val=~s/\0.*//; $val', # may be null terminated }, crdi => 'CRDInfo', #2 dmnd => { Name => 'DeviceMfgDesc', Groups => { 2 => 'Camera' }, }, dmdd => { Name => 'DeviceModelDesc', Groups => { 2 => 'Camera' }, }, devs => { Name => 'DeviceSettings', #2 Groups => { 2 => 'Camera' }, }, gamt => 'Gamut', kTRC => { Name => 'GrayTRC', Description => 'Gray Tone Reproduction Curve', }, gXYZ => 'GreenMatrixColumn', # (called GreenColorant in ref 2) gTRC => { Name => 'GreenTRC', Description => 'Green Tone Reproduction Curve', }, lumi => 'Luminance', meas => { Name => 'Measurement', SubDirectory => { TagTable => 'Image::ExifTool::ICC_Profile::Measurement', Validate => '$type eq "meas"', }, }, bkpt => 'MediaBlackPoint', wtpt => 'MediaWhitePoint', ncol => 'NamedColor', #2 ncl2 => 'NamedColor2', resp => 'OutputResponse', pre0 => 'Preview0', pre1 => 'Preview1', pre2 => 'Preview2', desc => 'ProfileDescription', pseq => 'ProfileSequenceDesc', psd0 => 'PostScript2CRD0', #2 psd1 => 'PostScript2CRD1', #2 psd2 => 'PostScript2CRD2', #2 ps2s => 'PostScript2CSA', #2 ps2i => 'PS2RenderingIntent', #2 rXYZ => 'RedMatrixColumn', # (called RedColorant in ref 2) rTRC => { Name => 'RedTRC', Description => 'Red Tone Reproduction Curve', }, scrd => 'ScreeningDesc', scrn => 'Screening', 'bfd '=> { Name => 'UCRBG', Description => 'Under Color Removal and Black Gen.', }, tech => { Name => 'Technology', PrintConv => { fscn => 'Film Scanner', dcam => 'Digital Camera', rscn => 'Reflective Scanner', ijet => 'Ink Jet Printer', twax => 'Thermal Wax Printer', epho => 'Electrophotographic Printer', esta => 'Electrostatic Printer', dsub => 'Dye Sublimation Printer', rpho => 'Photographic Paper Printer', fprn => 'Film Writer', vidm => 'Video Monitor', vidc => 'Video Camera', pjtv => 'Projection Television', 'CRT '=> 'Cathode Ray Tube Display', 'PMD '=> 'Passive Matrix Display', 'AMD '=> 'Active Matrix Display', KPCD => 'Photo CD', imgs => 'Photo Image Setter', grav => 'Gravure', offs => 'Offset Lithography', silk => 'Silkscreen', flex => 'Flexography', mpfs => 'Motion Picture Film Scanner', #5 mpfr => 'Motion Picture Film Recorder', #5 dmpc => 'Digital Motion Picture Camera', #5 dcpj => 'Digital Cinema Projector', #5 }, }, vued => 'ViewingCondDesc', view => { Name => 'ViewingConditions', SubDirectory => { TagTable => 'Image::ExifTool::ICC_Profile::ViewingConditions', Validate => '$type eq "view"', }, }, ciis => 'ColorimetricIntentImageState', #5 scoe => 'SceneColorimetryEstimates', #5 sape => 'SceneAppearanceEstimates', #5 fpce => 'FocalPlaneColorimetryEstimates', #5 rhoc => 'ReflectionHardcopyOrigColorimetry', #5 rpoc => 'ReflectionPrintOutputColorimetry', #5 psid => { #5 Name => 'ProfileSequenceIdentifier', Binary => 1, }, B2D0 => { Name => 'BToD0', Binary => 1 }, #5 B2D1 => { Name => 'BToD1', Binary => 1 }, #5 B2D2 => { Name => 'BToD2', Binary => 1 }, #5 B2D3 => { Name => 'BToD3', Binary => 1 }, #5 D2B0 => { Name => 'DToB0', Binary => 1 }, #5 D2B1 => { Name => 'DToB1', Binary => 1 }, #5 D2B2 => { Name => 'DToB2', Binary => 1 }, #5 D2B3 => { Name => 'DToB3', Binary => 1 }, #5 rig0 => { #5 Name => 'PerceptualRenderingIntentGamut', PrintConv => { prmg => 'Perceptual Reference Medium Gamut', }, }, rig2 => { #5 Name => 'SaturationRenderingIntentGamut', PrintConv => { prmg => 'Perceptual Reference Medium Gamut', }, }, meta => { #5 (EVENTUALLY DECODE THIS ONCE WE HAVE A SAMPLE!!) Name => 'Metadata', SubDirectory => { TagTable => 'Image::ExifTool::ICC_Profile::Metadata', Validate => '$type eq "meta"', }, }, # ColorSync custom tags (ref 3) psvm => 'PS2CRDVMSize', vcgt => 'VideoCardGamma', mmod => 'MakeAndModel', dscm => 'ProfileDescriptionML', ndin => 'NativeDisplayInfo', # Microsoft custom tags (ref http://msdn2.microsoft.com/en-us/library/ms536870.aspx) MS00 => 'WCSProfiles', # the following entry represents the ICC profile header, and doesn't # exist as a tag in the directory. It is only in this table to provide # a link so ExifTool can locate the header tags Header => { Name => 'ProfileHeader', SubDirectory => { TagTable => 'Image::ExifTool::ICC_Profile::Header', }, }, ); # ICC profile header definition %Image::ExifTool::ICC_Profile::Header = ( PROCESS_PROC => \&Image::ExifTool::ProcessBinaryData, GROUPS => { 0 => 'ICC_Profile', 1 => 'ICC-header', 2 => 'Image' }, 4 => { Name => 'ProfileCMMType', Format => 'string[4]', }, 8 => { Name => 'ProfileVersion', Format => 'int16s', PrintConv => '($val >> 8).".".(($val & 0xf0)>>4).".".($val & 0x0f)', }, 12 => { Name => 'ProfileClass', Format => 'string[4]', PrintConv => \%profileClass, }, 16 => { Name => 'ColorSpaceData', Format => 'string[4]', }, 20 => { Name => 'ProfileConnectionSpace', Format => 'string[4]', }, 24 => { Name => 'ProfileDateTime', Groups => { 2 => 'Time' }, Format => 'int16u[6]', ValueConv => 'sprintf("%.4d:%.2d:%.2d %.2d:%.2d:%.2d",split(" ",$val));', PrintConv => '$self->ConvertDateTime($val)', }, 36 => { Name => 'ProfileFileSignature', Format => 'string[4]', }, 40 => { Name => 'PrimaryPlatform', Format => 'string[4]', PrintConv => { 'APPL' => 'Apple Computer Inc.', 'MSFT' => 'Microsoft Corporation', 'SGI ' => 'Silicon Graphics Inc.', 'SUNW' => 'Sun Microsystems Inc.', 'TGNT' => 'Taligent Inc.', }, }, 44 => { Name => 'CMMFlags', Format => 'int32u', PrintConv => q[ ($val & 0x01 ? "Embedded, " : "Not Embedded, ") . ($val & 0x02 ? "Not Independent" : "Independent") ], }, 48 => { Name => 'DeviceManufacturer', Format => 'string[4]', # KODA = Kodak }, 52 => { Name => 'DeviceModel', Format => 'string[4]', # ROMM = Refrence Output Medium Metric }, 56 => { Name => 'DeviceAttributes', Format => 'int32u[2]', PrintConv => q[ my @v = split ' ', $val; ($v[1] & 0x01 ? "Transparency, " : "Reflective, ") . ($v[1] & 0x02 ? "Matte, " : "Glossy, ") . ($v[1] & 0x04 ? "Negative, " : "Positive, ") . ($v[1] & 0x08 ? "B&W" : "Color"); ], }, 64 => { Name => 'RenderingIntent', Format => 'int32u', PrintConv => { 0 => 'Perceptual', 1 => 'Media-Relative Colorimetric', 2 => 'Saturation', 3 => 'ICC-Absolute Colorimetric', }, }, 68 => { Name => 'ConnectionSpaceIlluminant', Format => 'fixed32s[3]', # xyz }, 80 => { Name => 'ProfileCreator', Format => 'string[4]', # KODA = Kodak }, 84 => { Name => 'ProfileID', Format => 'int8u[16]', PrintConv => 'Image::ExifTool::ICC_Profile::HexID($val)', }, ); # viewingConditionsType (view) definition %Image::ExifTool::ICC_Profile::ViewingConditions = ( PROCESS_PROC => \&Image::ExifTool::ProcessBinaryData, GROUPS => { 0 => 'ICC_Profile', 1 => 'ICC-view', 2 => 'Image' }, 8 => { Name => 'ViewingCondIlluminant', Format => 'fixed32s[3]', # xyz }, 20 => { Name => 'ViewingCondSurround', Format => 'fixed32s[3]', # xyz }, 32 => { Name => 'ViewingCondIlluminantType', Format => 'int32u', PrintConv => \%illuminantType, }, ); # measurementType (meas) definition %Image::ExifTool::ICC_Profile::Measurement = ( PROCESS_PROC => \&Image::ExifTool::ProcessBinaryData, GROUPS => { 0 => 'ICC_Profile', 1 => 'ICC-meas', 2 => 'Image' }, 8 => { Name => 'MeasurementObserver', Format => 'int32u', PrintConv => { 1 => 'CIE 1931', 2 => 'CIE 1964', }, }, 12 => { Name => 'MeasurementBacking', Format => 'fixed32s[3]', # xyz }, 24 => { Name => 'MeasurementGeometry', Format => 'int32u', PrintConv => { 0 => 'Unknown', 1 => '0/45 or 45/0', 2 => '0/d or d/0', }, }, 28 => { Name => 'MeasurementFlare', Format => 'fixed32u', PrintConv => '$val*100 . "%"', # change into a percent }, 32 => { Name => 'MeasurementIlluminant', Format => 'int32u', PrintConv => \%illuminantType, }, ); # chromaticity (chrm) definition %Image::ExifTool::ICC_Profile::Chromaticity = ( PROCESS_PROC => \&Image::ExifTool::ProcessBinaryData, GROUPS => { 0 => 'ICC_Profile', 1 => 'ICC-chrm', 2 => 'Image' }, 8 => { Name => 'ChromaticityChannels', Format => 'int16u', }, 10 => { Name => 'ChromaticityColorant', Format => 'int16u', PrintConv => { 1 => 'ITU-R BT.709', 2 => 'SMPTE RP145-1994', 3 => 'EBU Tech.3213-E', 4 => 'P22', }, }, # include definitions for 4 channels -- if there are # fewer then the ProcessBinaryData logic won't print them. # If there are more, oh well. 12 => { Name => 'ChromaticityChannel1', Format => 'fixed32u[2]', }, 20 => { Name => 'ChromaticityChannel2', Format => 'fixed32u[2]', }, 28 => { Name => 'ChromaticityChannel3', Format => 'fixed32u[2]', }, 36 => { Name => 'ChromaticityChannel4', Format => 'fixed32u[2]', }, ); # colorantTable (clrt) definition %Image::ExifTool::ICC_Profile::ColorantTable = ( PROCESS_PROC => \&Image::ExifTool::ProcessBinaryData, GROUPS => { 0 => 'ICC_Profile', 1 => 'ICC-clrt', 2 => 'Image' }, 8 => { Name => 'ColorantCount', Format => 'int32u', }, # include definitions for 3 colorants -- if there are # fewer then the ProcessBinaryData logic won't print them. # If there are more, oh well. 12 => { Name => 'Colorant1Name', Format => 'string[32]', }, 44 => { Name => 'Colorant1Coordinates', Format => 'int16u[3]', }, 50 => { Name => 'Colorant2Name', Format => 'string[32]', }, 82 => { Name => 'Colorant2Coordinates', Format => 'int16u[3]', }, 88 => { Name => 'Colorant3Name', Format => 'string[32]', }, 120 => { Name => 'Colorant3Coordinates', Format => 'int16u[3]', }, ); # metadata (meta) tags %Image::ExifTool::ICC_Profile::Metadata = ( PROCESS_PROC => \&ProcessMetadata, GROUPS => { 0 => 'ICC_Profile', 1 => 'ICC-meta', 2 => 'Image' }, VARS => { NO_ID => 1 }, NOTES => q{ Only these few tags have been pre-defined, but ExifTool will extract any Metadata tags that exist. }, ManufacturerName => { }, MediaColor => { }, MediaWeight => { }, ); #------------------------------------------------------------------------------ # print ICC Profile ID in hex # Inputs: 1) string of numbers # Returns: string of hex digits sub HexID($) { my $val = shift; my @vals = split(' ', $val); # return a simple zero if no MD5 done return 0 unless grep(!/^0/, @vals); $val = ''; foreach (@vals) { $val .= sprintf("%.2x",$_); } return $val; } #------------------------------------------------------------------------------ # get formatted value from ICC tag (which has the type embedded) # Inputs: 0) data reference, 1) offset to tag data, 2) tag data size # Returns: Formatted value or undefined if format not supported # Notes: The following types are handled by BinaryTables: # chromaticityType, colorantTableType, measurementType, viewingConditionsType # The following types are currently not handled (most are large tables): # curveType, lut16Type, lut8Type, lutAtoBType, lutBtoAType, namedColor2Type, # parametricCurveType, profileSeqDescType, responseCurveSet16Type # The multiLocalizedUnicodeType must be handled by the calling routine. sub FormatICCTag($$$) { my ($dataPt, $offset, $size) = @_; my $type; if ($size >= 8) { # get data type from start of tag data $type = substr($$dataPt, $offset, 4); } else { $type = 'err'; } # colorantOrderType if ($type eq 'clro' and $size >= 12) { my $num = Get32u($dataPt, $offset+8); if ($size >= $num + 12) { my $pos = $offset + 12; return join(' ',unpack("x$pos c$num", $$dataPt)); } } # dataType if ($type eq 'data' and $size >= 12) { my $form = Get32u($dataPt, $offset+8); # format 0 is ASCII data $form == 0 and return substr($$dataPt, $offset+12, $size-12); # binary data and other data types treat as binary (ie. don't format) } # dateTimeType if ($type eq 'dtim' and $size >= 20) { return sprintf("%.4d:%.2d:%.2d %.2d:%.2d:%.2d", Get16u($dataPt, $offset+8), Get16u($dataPt, $offset+10), Get16u($dataPt, $offset+12), Get16u($dataPt, $offset+14), Get16u($dataPt, $offset+16), Get16u($dataPt, $offset+18)); } # s15Fixed16ArrayType if ($type eq 'sf32') { return ReadValue($dataPt,$offset+8,'fixed32s',($size-8)/4,$size-8); } # signatureType if ($type eq 'sig ' and $size >= 12) { return substr($$dataPt, $offset+8, 4); } # textType $type eq 'text' and return substr($$dataPt, $offset+8, $size-8); # textDescriptionType (ref 2, replaced by multiLocalizedUnicodeType) if ($type eq 'desc' and $size >= 12) { my $len = Get32u($dataPt, $offset+8); if ($size >= $len + 12) { my $str = substr($$dataPt, $offset+12, $len); $str =~ s/\0.*//s; # truncate at null terminator return $str; } } # u16Fixed16ArrayType if ($type eq 'uf32') { return ReadValue($dataPt,$offset+8,'fixed32u',($size-8)/4,$size-8); } # uInt32ArrayType if ($type eq 'ui32') { return ReadValue($dataPt,$offset+8,'int32u',($size-8)/4,$size-8); } # uInt64ArrayType if ($type eq 'ui64') { return ReadValue($dataPt,$offset+8,'int64u',($size-8)/8,$size-8); } # uInt8ArrayType if ($type eq 'ui08') { return ReadValue($dataPt,$offset+8,'int8u',$size-8,$size-8); } # XYZType if ($type eq 'XYZ ') { my $str = ''; my $pos; for ($pos=8; $pos+12<=$size; $pos+=12) { $str and $str .= ', '; $str .= ReadValue($dataPt,$offset+$pos,'fixed32s',3,$size-$pos); } return $str; } return undef; # data type is not supported } #------------------------------------------------------------------------------ # Process ICC metadata record (ref 5) (UNTESTED!) # Inputs: 0) ExifTool ref, 1) dirInfo ref, 2) tag table ref # Returns: 1 on success sub ProcessMetadata($$$) { my ($et, $dirInfo, $tagTablePtr) = @_; my $dataPt = $$dirInfo{DataPt}; my $dirStart = $$dirInfo{DirStart}; my $dirLen = $$dirInfo{DirLen}; my $dirEnd = $dirStart + $dirLen; if ($dirLen < 16 or substr($$dataPt, $dirStart, 4) ne 'dict') { $et->Warn('Invalid ICC meta dictionary'); return 0; } my $num = Get32u($dataPt, $dirStart + 8); $et->VerboseDir('Metadata', $num); my $size = Get32u($dataPt, $dirStart + 12); $size < 16 and $et->Warn('Invalid ICC meta record size'), return 0; # NOTE: In the example the minimum offset is 20, # but this doesn't jive with the table (both in ref 5) my $minPtr = 16 + $size * $num; my $index; for ($index=0; $index<$num; ++$index) { my $entry = $dirStart + 16 + $size * $index; if ($entry + $size > $dirEnd) { $et->Warn('Truncated ICC meta dictionary'); last; } my $namePtr = Get32u($dataPt, $entry); my $nameLen = Get32u($dataPt, $entry + 4); my $valuePtr = Get32u($dataPt, $entry + 8); my $valueLen = Get32u($dataPt, $entry + 16); next unless $namePtr and $valuePtr; # ignore if offsets are zero if ($namePtr < $minPtr or $namePtr + $nameLen > $dirLen or $valuePtr < $minPtr or $valuePtr + $valueLen > $dirLen) { $et->Warn('Corrupted ICC meta dictionary'); last; } my $tag = substr($dataPt, $dirStart + $namePtr, $nameLen); my $val = substr($dataPt, $dirStart + $valuePtr, $valueLen); $tag = $et->Decode($tag, 'UTF16', 'MM', 'UTF8'); $val = $et->Decode($val, 'UTF16', 'MM'); # generate tagInfo if it doesn't exist unless ($$tagTablePtr{$tag}) { my $name = ucfirst $tag; $name =~ s/\s+(.)/\u$1/g; $name =~ tr/-_a-zA-Z0-9//dc; next unless length $name; AddTagToTable($tagTablePtr, $tag, { Name => $name }); } $et->HandleTag($tagTablePtr, $tag, $val); } return 1; } #------------------------------------------------------------------------------ # Write ICC profile file # Inputs: 0) ExifTool object reference, 1) Reference to directory information # Returns: 1 on success, 0 if this wasn't a valid ICC file, # or -1 if a write error occurred sub WriteICC($$) { my ($et, $dirInfo) = @_; # first make sure this is a valid ICC file (or no file at all) my $raf = $$dirInfo{RAF}; my $buff; return 0 if $raf->Read($buff, 24) and ValidateICC(\$buff); # now write the new ICC $buff = WriteICC_Profile($et, $dirInfo); if (defined $buff and length $buff) { Write($$dirInfo{OutFile}, $buff) or return -1; } else { $et->Error('No ICC information to write'); } return 1; } #------------------------------------------------------------------------------ # Write ICC data as a block # Inputs: 0) ExifTool object reference, 1) source dirInfo reference, # 2) tag table reference # Returns: ICC data block (may be empty if no ICC data) # Notes: Increments ExifTool CHANGED flag if changed sub WriteICC_Profile($$;$) { my ($et, $dirInfo, $tagTablePtr) = @_; $et or return 1; # allow dummy access my $dirName = $$dirInfo{DirName} || 'ICC_Profile'; # (don't write AsShotICCProfile or CurrentICCProfile here) return undef unless $dirName eq 'ICC_Profile'; my $nvHash = $et->GetNewValueHash($Image::ExifTool::Extra{$dirName}); my $val = $et->GetNewValues($nvHash); $val = '' unless defined $val; return undef unless $et->IsOverwriting($nvHash, $val); ++$$et{CHANGED}; return $val; } #------------------------------------------------------------------------------ # Validate ICC data # Inputs: 0) ICC data reference # Returns: error string or undef on success sub ValidateICC($) { my $valPtr = shift; my $err; length($$valPtr) < 24 and return 'Invalid ICC profile'; $profileClass{substr($$valPtr, 12, 4)} or $err = 'profile class'; my $col = substr($$valPtr, 16, 4); # ColorSpaceData my $con = substr($$valPtr, 20, 4); # ConnectionSpace my $match = '(XYZ |Lab |Luv |YCbr|Yxy |RGB |GRAY|HSV |HLS |CMYK|CMY |[2-9A-F]CLR)'; $col =~ /$match/ or $err = 'color space'; $con =~ /$match/ or $err = 'connection space'; return $err ? "Invalid ICC profile (bad $err)" : undef; } #------------------------------------------------------------------------------ # Process ICC profile file # Inputs: 0) ExifTool object reference, 1) Reference to directory information # Returns: 1 if this was an ICC file sub ProcessICC($$) { my ($et, $dirInfo) = @_; my $raf = $$dirInfo{RAF}; my $buff; $raf->Read($buff, 24) == 24 or return 0; # check to see if this is a valid ICC profile file return 0 if ValidateICC(\$buff); $et->SetFileType(); # read the profile my $size = unpack('N', $buff); if ($size < 128 or $size & 0x80000000) { $et->Error("Bad ICC Profile length ($size)"); return 1; } $raf->Seek(0, 0); unless ($raf->Read($buff, $size)) { $et->Error('Truncated ICC profile'); return 1; } my %dirInfo = ( DataPt => \$buff, DataLen => $size, DirStart => 0, DirLen => $size, ); my $tagTablePtr = GetTagTable('Image::ExifTool::ICC_Profile::Main'); return ProcessICC_Profile($et, \%dirInfo, $tagTablePtr); } #------------------------------------------------------------------------------ # Process ICC_Profile APP13 record # Inputs: 0) ExifTool object reference, 1) Reference to directory information # 2) Tag table reference (undefined to read ICC file) # Returns: 1 on success sub ProcessICC_Profile($$$) { my ($et, $dirInfo, $tagTablePtr) = @_; my $dataPt = $$dirInfo{DataPt}; my $dirStart = $$dirInfo{DirStart} || 0; my $dirLen = $$dirInfo{DirLen}; my $verbose = $et->Options('Verbose'); return 0 if $dirLen < 4; # extract binary ICC_Profile data block if binary mode or requested if ((($$et{TAGS_FROM_FILE} and not $$et{EXCL_TAG_LOOKUP}{icc_profile}) or $$et{REQ_TAG_LOOKUP}{icc_profile}) and # (don't extract from AsShotICCProfile or CurrentICCProfile) (not $$dirInfo{Name} or $$dirInfo{Name} eq 'ICC_Profile')) { $et->FoundTag('ICC_Profile', substr($$dataPt, $dirStart, $dirLen)); } SetByteOrder('MM'); # ICC_Profile is always big-endian # check length of table my $len = Get32u($dataPt, $dirStart); if ($len != $dirLen or $len < 128) { $et->Warn("Bad length ICC_Profile (length $len)"); return 0 if $len < 128 or $dirLen < $len; } my $pos = $dirStart + 128; # position at start of table my $numEntries = Get32u($dataPt, $pos); if ($numEntries < 1 or $numEntries >= 0x100 or $numEntries * 12 + 132 > $dirLen) { $et->Warn("Bad ICC_Profile table ($numEntries entries)"); return 0; } if ($verbose) { $et->VerboseDir('ICC_Profile', $numEntries, $dirLen); my $fakeInfo = { Name=>'ProfileHeader', SubDirectory => { } }; $et->VerboseInfo(undef, $fakeInfo); } # increment ICC dir count my $dirCount = $$et{DIR_COUNT}{ICC} = ($$et{DIR_COUNT}{ICC} || 0) + 1; $$et{SET_GROUP1} = '+' . $dirCount if $dirCount > 1; # process the header block my %subdirInfo = ( Name => 'ProfileHeader', DataPt => $dataPt, DataLen => $$dirInfo{DataLen}, DirStart => $dirStart, DirLen => 128, Parent => $$dirInfo{DirName}, DirName => 'Header', ); my $newTagTable = GetTagTable('Image::ExifTool::ICC_Profile::Header'); $et->ProcessDirectory(\%subdirInfo, $newTagTable); $pos += 4; # skip item count my $index; for ($index=0; $index<$numEntries; ++$index) { my $tagID = substr($$dataPt, $pos, 4); my $offset = Get32u($dataPt, $pos + 4); my $size = Get32u($dataPt, $pos + 8); $pos += 12; my $tagInfo = $et->GetTagInfo($tagTablePtr, $tagID); # unknown tags aren't generated automatically by GetTagInfo() # if the tagID's aren't numeric, so we must do this manually: if (not $tagInfo and $$et{OPTIONS}{Unknown}) { $tagInfo = { Unknown => 1 }; AddTagToTable($tagTablePtr, $tagID, $tagInfo); } next unless defined $tagInfo; if ($offset + $size > $dirLen) { $et->Warn("Bad ICC_Profile table (truncated)"); last; } my $valuePtr = $dirStart + $offset; my $subdir = $$tagInfo{SubDirectory}; # format the value unless this is a subdirectory my ($value, $fmt); if ($size > 4) { $fmt = substr($$dataPt, $valuePtr, 4); # handle multiLocalizedUnicodeType if ($fmt eq 'mluc' and not $subdir) { next if $size < 28; my $count = Get32u($dataPt, $valuePtr + 8); my $recLen = Get32u($dataPt, $valuePtr + 12); next if $recLen < 12; my $i; for ($i=0; $i<$count; ++$i) { my $recPos = $valuePtr + 16 + $i * $recLen; last if $recPos + $recLen > $valuePtr + $size; my $lang = substr($$dataPt, $recPos, 4); my $langInfo; # validate language code and change to standard case (just in case) if ($lang =~ s/^([a-z]{2})([A-Z]{2})$/\L$1-\U$2/i and $lang ne 'en-US') { $langInfo = Image::ExifTool::GetLangInfo($tagInfo, $lang); } my $strLen = Get32u($dataPt, $recPos + 4); my $strPos = Get32u($dataPt, $recPos + 8); last if $strPos + $strLen > $size; my $str = substr($$dataPt, $valuePtr + $strPos, $strLen); $str = $et->Decode($str, 'UTF16'); $et->HandleTag($tagTablePtr, $tagID, $str, TagInfo => $langInfo || $tagInfo, Table => $tagTablePtr, Index => $index, Value => $str, DataPt => $dataPt, Size => $strLen, Start => $valuePtr + $strPos, Format => "type '$fmt'", ); } $et->Warn("Corrupted $$tagInfo{Name} data") if $i < $count; next; } } else { $fmt = 'err '; } $value = FormatICCTag($dataPt, $valuePtr, $size) unless $subdir; $verbose and $et->VerboseInfo($tagID, $tagInfo, Table => $tagTablePtr, Index => $index, Value => $value, DataPt => $dataPt, Size => $size, Start => $valuePtr, Format => "type '$fmt'", ); if ($subdir) { my $name = $$tagInfo{Name}; undef $newTagTable; if ($$subdir{TagTable}) { $newTagTable = GetTagTable($$subdir{TagTable}); unless ($newTagTable) { warn "Unknown tag table $$subdir{TagTable}\n"; next; } } else { warn "Must specify TagTable for SubDirectory $name\n"; next; } %subdirInfo = ( Name => $name, DataPt => $dataPt, DataPos => $$dirInfo{DataPos}, DataLen => $$dirInfo{DataLen}, DirStart => $valuePtr, DirLen => $size, DirName => $name, Parent => $$dirInfo{DirName}, ); my $type = substr($$dataPt, $valuePtr, 4); #### eval Validate ($type) if (defined $$subdir{Validate} and not eval $$subdir{Validate}) { $et->Warn("Invalid $name data"); } else { $et->ProcessDirectory(\%subdirInfo, $newTagTable, $$subdir{ProcessProc}); } } elsif (defined $value) { $et->FoundTag($tagInfo, $value); } else { $value = substr($$dataPt, $valuePtr, $size); # treat unsupported formats as binary data $$tagInfo{ValueConv} = '\$val' unless defined $$tagInfo{ValueConv}; $et->FoundTag($tagInfo, $value); } } delete $$et{SET_GROUP1}; return 1; } 1; # end __END__ =head1 NAME Image::ExifTool::ICC_Profile - Read ICC Profile meta information =head1 SYNOPSIS This module is loaded automatically by Image::ExifTool when required. =head1 DESCRIPTION This module contains the definitions to read information from ICC profiles. ICC (International Color Consortium) profiles are used to translate color data created on one device into another device's native color space. =head1 AUTHOR Copyright 2003-2015, Phil Harvey (phil at owl.phy.queensu.ca) This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 REFERENCES =over 4 =item L =item L =back =head1 SEE ALSO L, L =cut