1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000 |
- #------------------------------------------------------------------------------
- # 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.30';
- 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<http://www.color.org/icc_specs2.xalter> 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->GetNewValue($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-2016, 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<http://www.color.org/icc_specs2.html>
- =item L<http://developer.apple.com/documentation/GraphicsImaging/Reference/ColorSync_Manager/ColorSync_Manager.pdf>
- =back
- =head1 SEE ALSO
- L<Image::ExifTool::TagNames/ICC_Profile Tags>,
- L<Image::ExifTool(3pm)|Image::ExifTool>
- =cut
|