1001 lines
33 KiB
Perl
1001 lines
33 KiB
Perl
|
#------------------------------------------------------------------------------
|
||
|
# 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
|