1 | #------------------------------------------------------------------------------
|
---|
2 | # File: WriteIPTC.pl
|
---|
3 | #
|
---|
4 | # Description: Write IPTC meta information
|
---|
5 | #
|
---|
6 | # Revisions: 12/15/2004 - P. Harvey Created
|
---|
7 | #------------------------------------------------------------------------------
|
---|
8 |
|
---|
9 | package Image::ExifTool::IPTC;
|
---|
10 |
|
---|
11 | use strict;
|
---|
12 |
|
---|
13 | # mandatory IPTC tags for each record
|
---|
14 | my %mandatory = (
|
---|
15 | 1 => {
|
---|
16 | 0 => 4, # EnvelopeRecordVersion
|
---|
17 | },
|
---|
18 | 2 => {
|
---|
19 | 0 => 4, # ApplicationRecordVersion
|
---|
20 | },
|
---|
21 | 3 => {
|
---|
22 | 0 => 4, # NewsPhotoVersion
|
---|
23 | },
|
---|
24 | );
|
---|
25 |
|
---|
26 | # manufacturer strings for IPTCPictureNumber
|
---|
27 | my %manufacturer = (
|
---|
28 | 1 => 'Associated Press, USA',
|
---|
29 | 2 => 'Eastman Kodak Co, USA',
|
---|
30 | 3 => 'Hasselblad Electronic Imaging, Sweden',
|
---|
31 | 4 => 'Tecnavia SA, Switzerland',
|
---|
32 | 5 => 'Nikon Corporation, Japan',
|
---|
33 | 6 => 'Coatsworth Communications Inc, Canada',
|
---|
34 | 7 => 'Agence France Presse, France',
|
---|
35 | 8 => 'T/One Inc, USA',
|
---|
36 | 9 => 'Associated Newspapers, UK',
|
---|
37 | 10 => 'Reuters London',
|
---|
38 | 11 => 'Sandia Imaging Systems Inc, USA',
|
---|
39 | 12 => 'Visualize, Spain',
|
---|
40 | );
|
---|
41 |
|
---|
42 | my %iptcCharsetInv = ( 'UTF8' => "\x1b%G", 'UTF-8' => "\x1b%G" );
|
---|
43 |
|
---|
44 | # ISO 2022 Character Coding Notes
|
---|
45 | # -------------------------------
|
---|
46 | # Character set designation: (0x1b I F, or 0x1b I I F)
|
---|
47 | # Initial character 0x1b (ESC)
|
---|
48 | # Intermediate character I:
|
---|
49 | # 0x28 ('(') - G0, 94 chars
|
---|
50 | # 0x29 (')') - G1, 94 chars
|
---|
51 | # 0x2a ('*') - G2, 94 chars
|
---|
52 | # 0x2b ('+') - G3, 94 chars
|
---|
53 | # 0x2c (',') - G1, 96 chars
|
---|
54 | # 0x2d ('-') - G2, 96 chars
|
---|
55 | # 0x2e ('.') - G3, 96 chars
|
---|
56 | # 0x24 I ('$I') - multiple byte graphic sets (I from above)
|
---|
57 | # I 0x20 ('I ') - dynamically redefinable character sets
|
---|
58 | # Final character:
|
---|
59 | # 0x30 - 0x3f = private character set
|
---|
60 | # 0x40 - 0x7f = standardized character set
|
---|
61 | # Character set invocation:
|
---|
62 | # G0 : SI = 0x15
|
---|
63 | # G1 : SO = 0x14, LS1R = 0x1b 0x7e ('~')
|
---|
64 | # G2 : LS2 = 0x1b 0x6e ('n'), LS2R = 0x1b 0x7d ('}')
|
---|
65 | # G3 : LS3 = 0x1b 0x6f ('o'), LS3R = 0x1b 0x7c ('|')
|
---|
66 | # (the locking shift "R" codes shift into 0x80-0xff space)
|
---|
67 | # Single character invocation:
|
---|
68 | # G2 : SS2 = 0x1b 0x8e (or 0x4e in 7-bit)
|
---|
69 | # G3 : SS3 = 0x1b 0x8f (or 0x4f in 7-bit)
|
---|
70 | # Control chars (designated and invoked)
|
---|
71 | # C0 : 0x1b 0x21 F (0x21 = '!')
|
---|
72 | # C1 : 0x1b 0x22 F (0x22 = '"')
|
---|
73 | # Complete codes (control+graphics, designated and invoked)
|
---|
74 | # 0x1b 0x25 F (0x25 = '%')
|
---|
75 | # 0x1b 0x25 I F
|
---|
76 | # 0x1b 0x25 0x47 ("\x1b%G") - UTF-8
|
---|
77 | # 0x1b 0x25 0x40 ("\x1b%@") - return to ISO 2022
|
---|
78 | # -------------------------------
|
---|
79 |
|
---|
80 | #------------------------------------------------------------------------------
|
---|
81 | # Inverse print conversion for CodedCharacterSet
|
---|
82 | # Inputs: 0) value
|
---|
83 | sub PrintInvCodedCharset($)
|
---|
84 | {
|
---|
85 | my $val = shift;
|
---|
86 | my $code = $iptcCharsetInv{uc($val)};
|
---|
87 | unless ($code) {
|
---|
88 | if (($code = $val) =~ s/ESC */\x1b/ig) { # translate ESC chars
|
---|
89 | $code =~ s/, \x1b/\x1b/g; # remove comma separators
|
---|
90 | $code =~ tr/ //d; # remove spaces
|
---|
91 | } else {
|
---|
92 | warn "Bad syntax (use 'UTF8' or 'ESC X Y[, ...]')\n";
|
---|
93 | }
|
---|
94 | }
|
---|
95 | return $code;
|
---|
96 | }
|
---|
97 |
|
---|
98 | #------------------------------------------------------------------------------
|
---|
99 | # validate raw values for writing
|
---|
100 | # Inputs: 0) ExifTool object ref, 1) tagInfo hash ref, 2) raw value ref
|
---|
101 | # Returns: error string or undef (and possibly changes value) on success
|
---|
102 | sub CheckIPTC($$$)
|
---|
103 | {
|
---|
104 | my ($et, $tagInfo, $valPtr) = @_;
|
---|
105 | my $format = $$tagInfo{Format} || $$tagInfo{Table}{FORMAT} || '';
|
---|
106 | if ($format =~ /^int(\d+)/) {
|
---|
107 | my $bytes = int(($1 || 0) / 8);
|
---|
108 | if ($bytes != 1 and $bytes != 2 and $bytes != 4) {
|
---|
109 | return "Can't write $bytes-byte integer";
|
---|
110 | }
|
---|
111 | my $val = $$valPtr;
|
---|
112 | unless (Image::ExifTool::IsInt($val)) {
|
---|
113 | return 'Not an integer' unless Image::ExifTool::IsHex($val);
|
---|
114 | $val = $$valPtr = hex($val);
|
---|
115 | }
|
---|
116 | my $n;
|
---|
117 | for ($n=0; $n<$bytes; ++$n) { $val >>= 8; }
|
---|
118 | return "Value too large for $bytes-byte format" if $val;
|
---|
119 | } elsif ($format =~ /^(string|digits|undef)\[?(\d+),?(\d*)\]?$/) {
|
---|
120 | my ($fmt, $minlen, $maxlen) = ($1, $2, $3);
|
---|
121 | my $len = length $$valPtr;
|
---|
122 | if ($fmt eq 'digits') {
|
---|
123 | return 'Non-numeric characters in value' unless $$valPtr =~ /^\d*$/;
|
---|
124 | if ($len < $minlen and $len) {
|
---|
125 | # left pad with zeros if necessary
|
---|
126 | $$valPtr = ('0' x ($minlen - $len)) . $$valPtr;
|
---|
127 | $len = $minlen;
|
---|
128 | }
|
---|
129 | }
|
---|
130 | if (defined $minlen and $fmt ne 'string') { # (must truncate strings later, after recoding)
|
---|
131 | $maxlen or $maxlen = $minlen;
|
---|
132 | if ($len < $minlen) {
|
---|
133 | unless ($$et{OPTIONS}{IgnoreMinorErrors}) {
|
---|
134 | return "[Minor] String too short (minlen is $minlen)";
|
---|
135 | }
|
---|
136 | $$et{CHECK_WARN} = "String too short for IPTC:$$tagInfo{Name} (written anyway)";
|
---|
137 | } elsif ($len > $maxlen and not $$et{OPTIONS}{IgnoreMinorErrors}) {
|
---|
138 | $$et{CHECK_WARN} = "[Minor] IPTC:$$tagInfo{Name} exceeds length limit (truncated)";
|
---|
139 | $$valPtr = substr($$valPtr, 0, $maxlen);
|
---|
140 | }
|
---|
141 | }
|
---|
142 | } else {
|
---|
143 | return "Bad IPTC Format ($format)";
|
---|
144 | }
|
---|
145 | return undef;
|
---|
146 | }
|
---|
147 |
|
---|
148 | #------------------------------------------------------------------------------
|
---|
149 | # format IPTC data for writing
|
---|
150 | # Inputs: 0) ExifTool object ref, 1) tagInfo pointer,
|
---|
151 | # 2) value reference (changed if necessary),
|
---|
152 | # 3) reference to character set for translation (changed if necessary)
|
---|
153 | # 4) record number, 5) flag set to read value (instead of write)
|
---|
154 | sub FormatIPTC($$$$$;$)
|
---|
155 | {
|
---|
156 | my ($et, $tagInfo, $valPtr, $xlatPtr, $rec, $read) = @_;
|
---|
157 | my $format = $$tagInfo{Format} || $$tagInfo{Table}{FORMAT};
|
---|
158 | return unless $format;
|
---|
159 | if ($format =~ /^int(\d+)/) {
|
---|
160 | if ($read) {
|
---|
161 | my $len = length($$valPtr);
|
---|
162 | if ($len <= 8) { # limit integer conversion to 8 bytes long
|
---|
163 | my $val = 0;
|
---|
164 | my $i;
|
---|
165 | for ($i=0; $i<$len; ++$i) {
|
---|
166 | $val = $val * 256 + ord(substr($$valPtr, $i, 1));
|
---|
167 | }
|
---|
168 | $$valPtr = $val;
|
---|
169 | }
|
---|
170 | } else {
|
---|
171 | my $len = int(($1 || 0) / 8);
|
---|
172 | if ($len == 1) { # 1 byte
|
---|
173 | $$valPtr = chr($$valPtr);
|
---|
174 | } elsif ($len == 2) { # 2-byte integer
|
---|
175 | $$valPtr = pack('n', $$valPtr);
|
---|
176 | } else { # 4-byte integer
|
---|
177 | $$valPtr = pack('N', $$valPtr);
|
---|
178 | }
|
---|
179 | }
|
---|
180 | } elsif ($format =~ /^string/) {
|
---|
181 | if ($rec == 1) {
|
---|
182 | if ($$tagInfo{Name} eq 'CodedCharacterSet') {
|
---|
183 | $$xlatPtr = HandleCodedCharset($et, $$valPtr);
|
---|
184 | }
|
---|
185 | } elsif ($$xlatPtr and $rec < 7 and $$valPtr =~ /[\x80-\xff]/) {
|
---|
186 | TranslateCodedString($et, $valPtr, $xlatPtr, $read);
|
---|
187 | }
|
---|
188 | # must check length now (after any string recoding)
|
---|
189 | if (not $read and $format =~ /^string\[(\d+),?(\d*)\]$/) {
|
---|
190 | my ($minlen, $maxlen) = ($1, $2);
|
---|
191 | my $len = length $$valPtr;
|
---|
192 | $maxlen or $maxlen = $minlen;
|
---|
193 | if ($len < $minlen) {
|
---|
194 | if ($et->Warn("String too short for IPTC:$$tagInfo{Name} (padded)", 2)) {
|
---|
195 | $$valPtr .= ' ' x ($minlen - $len);
|
---|
196 | }
|
---|
197 | } elsif ($len > $maxlen) {
|
---|
198 | if ($et->Warn("IPTC:$$tagInfo{Name} exceeds length limit (truncated)", 2)) {
|
---|
199 | $$valPtr = substr($$valPtr, 0, $maxlen);
|
---|
200 | # make sure UTF-8 is still valid
|
---|
201 | if (($$xlatPtr || $et->Options('Charset')) eq 'UTF8') {
|
---|
202 | require Image::ExifTool::XMP;
|
---|
203 | Image::ExifTool::XMP::FixUTF8($valPtr,'.');
|
---|
204 | }
|
---|
205 | }
|
---|
206 | }
|
---|
207 | }
|
---|
208 | }
|
---|
209 | }
|
---|
210 |
|
---|
211 | #------------------------------------------------------------------------------
|
---|
212 | # generate IPTC-format date
|
---|
213 | # Inputs: 0) EXIF-format date string (YYYY:mm:dd) or date/time string
|
---|
214 | # Returns: IPTC-format date string (YYYYmmdd), or undef and issue warning on error
|
---|
215 | sub IptcDate($)
|
---|
216 | {
|
---|
217 | my $val = shift;
|
---|
218 | unless ($val =~ s{^.*(\d{4})[-:/.]?(\d{2})[-:/.]?(\d{2}).*}{$1$2$3}s) {
|
---|
219 | warn "Invalid date format (use YYYY:mm:dd)\n";
|
---|
220 | undef $val;
|
---|
221 | }
|
---|
222 | return $val;
|
---|
223 | }
|
---|
224 |
|
---|
225 | #------------------------------------------------------------------------------
|
---|
226 | # generate IPTC-format time
|
---|
227 | # Inputs: 0) EXIF-format time string (HH:MM:SS[+/-HH:MM]) or date/time string
|
---|
228 | # Returns: IPTC-format time string (HHMMSS+HHMM), or undef and issue warning on error
|
---|
229 | sub IptcTime($)
|
---|
230 | {
|
---|
231 | my $val = shift;
|
---|
232 | if ($val =~ /(.*?)\b(\d{1,2})(:?)(\d{2})(:?)(\d{2})(\S*)\s*$/s and ($3 or not $5)) {
|
---|
233 | $val = sprintf("%.2d%.2d%.2d",$2,$4,$6);
|
---|
234 | my ($date, $tz) = ($1, $7);
|
---|
235 | if ($tz =~ /([+-]\d{1,2}):?(\d{2})/) {
|
---|
236 | $tz = sprintf("%+.2d%.2d",$1,$2);
|
---|
237 | } elsif ($tz =~ /Z/i) {
|
---|
238 | $tz = '+0000'; # UTC
|
---|
239 | } else {
|
---|
240 | # use local system timezone by default
|
---|
241 | my (@tm, $time);
|
---|
242 | if ($date and $date =~ /^(\d{4}):(\d{2}):(\d{2})\s*$/ and eval { require Time::Local }) {
|
---|
243 | # we were given a date too, so determine the local timezone
|
---|
244 | # offset at the specified date/time
|
---|
245 | my @d = ($3,$2-1,$1);
|
---|
246 | $val =~ /(\d{2})(\d{2})(\d{2})/;
|
---|
247 | @tm = ($3,$2,$1,@d);
|
---|
248 | $time = Image::ExifTool::TimeLocal(@tm);
|
---|
249 | } else {
|
---|
250 | # it is difficult to get the proper local timezone offset for this
|
---|
251 | # time because the date tag is written separately. (The offset may be
|
---|
252 | # different on a different date due to daylight savings time.) In this
|
---|
253 | # case the best we can do easily is to use the current timezone offset.
|
---|
254 | $time = time;
|
---|
255 | @tm = localtime($time);
|
---|
256 | }
|
---|
257 | ($tz = Image::ExifTool::TimeZoneString(\@tm, $time)) =~ tr/://d;
|
---|
258 | }
|
---|
259 | $val .= $tz;
|
---|
260 | } else {
|
---|
261 | warn "Invalid time format (use HH:MM:SS[+/-HH:MM])\n";
|
---|
262 | undef $val; # time format error
|
---|
263 | }
|
---|
264 | return $val;
|
---|
265 | }
|
---|
266 |
|
---|
267 | #------------------------------------------------------------------------------
|
---|
268 | # Inverse print conversion for IPTC date or time value
|
---|
269 | # Inputs: 0) ExifTool ref, 1) IPTC date or 'now'
|
---|
270 | # Returns: IPTC date
|
---|
271 | sub InverseDateOrTime($$)
|
---|
272 | {
|
---|
273 | my ($et, $val) = @_;
|
---|
274 | return $et->TimeNow() if lc($val) eq 'now';
|
---|
275 | return $val;
|
---|
276 | }
|
---|
277 |
|
---|
278 | #------------------------------------------------------------------------------
|
---|
279 | # Convert picture number
|
---|
280 | # Inputs: 0) value
|
---|
281 | # Returns: Converted value
|
---|
282 | sub ConvertPictureNumber($)
|
---|
283 | {
|
---|
284 | my $val = shift;
|
---|
285 | if ($val eq "\0" x 16) {
|
---|
286 | $val = 'Unknown';
|
---|
287 | } elsif (length $val >= 16) {
|
---|
288 | my @vals = unpack('nNA8n', $val);
|
---|
289 | $val = $vals[0];
|
---|
290 | my $manu = $manufacturer{$val};
|
---|
291 | $val .= " ($manu)" if $manu;
|
---|
292 | $val .= ', equip ' . $vals[1];
|
---|
293 | $vals[2] =~ s/(\d{4})(\d{2})(\d{2})/$1:$2:$3/;
|
---|
294 | $val .= ", $vals[2], no. $vals[3]";
|
---|
295 | } else {
|
---|
296 | $val = '<format error>'
|
---|
297 | }
|
---|
298 | return $val;
|
---|
299 | }
|
---|
300 |
|
---|
301 | #------------------------------------------------------------------------------
|
---|
302 | # Inverse picture number conversion
|
---|
303 | # Inputs: 0) value
|
---|
304 | # Returns: Converted value (or undef on error)
|
---|
305 | sub InvConvertPictureNumber($)
|
---|
306 | {
|
---|
307 | my $val = shift;
|
---|
308 | $val =~ s/\(.*\)//g; # remove manufacturer description
|
---|
309 | $val =~ tr/://d; # remove date separators
|
---|
310 | $val =~ tr/0-9/ /c; # turn remaining non-numbers to spaces
|
---|
311 | my @vals = split ' ', $val;
|
---|
312 | if (@vals >= 4) {
|
---|
313 | $val = pack('nNA8n', @vals);
|
---|
314 | } elsif ($val =~ /unknown/i) {
|
---|
315 | $val = "\0" x 16;
|
---|
316 | } else {
|
---|
317 | undef $val;
|
---|
318 | }
|
---|
319 | return $val;
|
---|
320 | }
|
---|
321 |
|
---|
322 | #------------------------------------------------------------------------------
|
---|
323 | # Write IPTC data record
|
---|
324 | # Inputs: 0) ExifTool object ref, 1) source dirInfo ref, 2) tag table ref
|
---|
325 | # Returns: IPTC data block (may be empty if no IPTC data)
|
---|
326 | # Notes: Increments ExifTool CHANGED flag for each tag changed
|
---|
327 | sub DoWriteIPTC($$$)
|
---|
328 | {
|
---|
329 | my ($et, $dirInfo, $tagTablePtr) = @_;
|
---|
330 | my $verbose = $et->Options('Verbose');
|
---|
331 | my $out = $et->Options('TextOut');
|
---|
332 |
|
---|
333 | # avoid editing IPTC directory unless necessary:
|
---|
334 | # - improves speed
|
---|
335 | # - avoids changing current MD5 digest unnecessarily
|
---|
336 | # - avoids adding mandatory tags unless some other IPTC is changed
|
---|
337 | unless (exists $$et{EDIT_DIRS}{$$dirInfo{DirName}} or
|
---|
338 | # standard IPTC tags in other locations should be edited too (eg. AFCP_IPTC)
|
---|
339 | ($tagTablePtr eq \%Image::ExifTool::IPTC::Main and exists $$et{EDIT_DIRS}{IPTC}))
|
---|
340 | {
|
---|
341 | print $out "$$et{INDENT} [nothing changed]\n" if $verbose;
|
---|
342 | return undef;
|
---|
343 | }
|
---|
344 | my $dataPt = $$dirInfo{DataPt};
|
---|
345 | unless ($dataPt) {
|
---|
346 | my $emptyData = '';
|
---|
347 | $dataPt = \$emptyData;
|
---|
348 | }
|
---|
349 | my $start = $$dirInfo{DirStart} || 0;
|
---|
350 | my $dirLen = $$dirInfo{DirLen};
|
---|
351 | my ($tagInfo, %iptcInfo, $tag);
|
---|
352 |
|
---|
353 | # start by assuming default IPTC encoding
|
---|
354 | my $xlat = $et->Options('CharsetIPTC');
|
---|
355 | undef $xlat if $xlat eq $et->Options('Charset');
|
---|
356 |
|
---|
357 | # make sure our dataLen is defined (note: allow zero length directory)
|
---|
358 | unless (defined $dirLen) {
|
---|
359 | my $dataLen = $$dirInfo{DataLen};
|
---|
360 | $dataLen = length($$dataPt) unless defined $dataLen;
|
---|
361 | $dirLen = $dataLen - $start;
|
---|
362 | }
|
---|
363 | # quick check for improperly byte-swapped IPTC
|
---|
364 | if ($dirLen >= 4 and substr($$dataPt, $start, 1) ne "\x1c" and
|
---|
365 | substr($$dataPt, $start + 3, 1) eq "\x1c")
|
---|
366 | {
|
---|
367 | $et->Warn('IPTC data was improperly byte-swapped');
|
---|
368 | my $newData = pack('N*', unpack('V*', substr($$dataPt, $start, $dirLen) . "\0\0\0"));
|
---|
369 | $dataPt = \$newData;
|
---|
370 | $start = 0;
|
---|
371 | # NOTE: MUST NOT access $dirInfo DataPt, DirStart or DataLen after this!
|
---|
372 | }
|
---|
373 | # generate lookup so we can find the record numbers
|
---|
374 | my %recordNum;
|
---|
375 | foreach $tag (Image::ExifTool::TagTableKeys($tagTablePtr)) {
|
---|
376 | $tagInfo = $$tagTablePtr{$tag};
|
---|
377 | $$tagInfo{SubDirectory} or next;
|
---|
378 | my $table = $$tagInfo{SubDirectory}{TagTable} or next;
|
---|
379 | my $subTablePtr = Image::ExifTool::GetTagTable($table);
|
---|
380 | $recordNum{$subTablePtr} = $tag;
|
---|
381 | }
|
---|
382 |
|
---|
383 | # loop through new values and accumulate all IPTC information
|
---|
384 | # into lists based on their IPTC record type
|
---|
385 | foreach $tagInfo ($et->GetNewTagInfoList()) {
|
---|
386 | my $table = $$tagInfo{Table};
|
---|
387 | my $record = $recordNum{$table};
|
---|
388 | # ignore tags we aren't writing to this directory
|
---|
389 | next unless defined $record;
|
---|
390 | $iptcInfo{$record} = [] unless defined $iptcInfo{$record};
|
---|
391 | push @{$iptcInfo{$record}}, $tagInfo;
|
---|
392 | }
|
---|
393 |
|
---|
394 | # get sorted list of records used. Might as well be organized and
|
---|
395 | # write our records in order of record number first, then tag number
|
---|
396 | my @recordList = sort { $a <=> $b } keys %iptcInfo;
|
---|
397 | my ($record, %set);
|
---|
398 | foreach $record (@recordList) {
|
---|
399 | # sort tagInfo lists by tagID
|
---|
400 | @{$iptcInfo{$record}} = sort { $$a{TagID} <=> $$b{TagID} } @{$iptcInfo{$record}};
|
---|
401 | # build hash of all tagIDs to set
|
---|
402 | foreach $tagInfo (@{$iptcInfo{$record}}) {
|
---|
403 | $set{$record}->{$$tagInfo{TagID}} = $tagInfo;
|
---|
404 | }
|
---|
405 | }
|
---|
406 | # run through the old IPTC data, inserting our records in
|
---|
407 | # sequence and deleting existing records where necessary
|
---|
408 | # (the IPTC specification states that records must occur in
|
---|
409 | # numerical order, but tags within records need not be ordered)
|
---|
410 | my $pos = $start;
|
---|
411 | my $tail = $pos; # old data written up to this point
|
---|
412 | my $dirEnd = $start + $dirLen;
|
---|
413 | my $newData = '';
|
---|
414 | my $lastRec = -1;
|
---|
415 | my $lastRecPos = 0;
|
---|
416 | my $allMandatory = 0;
|
---|
417 | my %foundRec; # found flags: 0x01-existed before, 0x02-deleted, 0x04-created
|
---|
418 | my $addNow;
|
---|
419 |
|
---|
420 | for (;;$tail=$pos) {
|
---|
421 | # get next IPTC record from input directory
|
---|
422 | my ($id, $rec, $tag, $len, $valuePtr);
|
---|
423 | if ($pos + 5 <= $dirEnd) {
|
---|
424 | my $buff = substr($$dataPt, $pos, 5);
|
---|
425 | ($id, $rec, $tag, $len) = unpack("CCCn", $buff);
|
---|
426 | if ($id == 0x1c) {
|
---|
427 | if ($rec < $lastRec) {
|
---|
428 | if ($rec == 0) {
|
---|
429 | return undef if $et->Warn("IPTC record 0 encountered, subsequent records ignored", 2);
|
---|
430 | undef $rec;
|
---|
431 | $pos = $dirEnd;
|
---|
432 | $len = 0;
|
---|
433 | } else {
|
---|
434 | return undef if $et->Warn("IPTC doesn't conform to spec: Records out of sequence", 2);
|
---|
435 | }
|
---|
436 | }
|
---|
437 | # handle extended IPTC entry if necessary
|
---|
438 | $pos += 5; # step to after field header
|
---|
439 | if ($len & 0x8000) {
|
---|
440 | my $n = $len & 0x7fff; # get num bytes in length field
|
---|
441 | if ($pos + $n <= $dirEnd and $n <= 8) {
|
---|
442 | # determine length (a big-endian, variable sized int)
|
---|
443 | for ($len = 0; $n; ++$pos, --$n) {
|
---|
444 | $len = $len * 256 + ord(substr($$dataPt, $pos, 1));
|
---|
445 | }
|
---|
446 | } else {
|
---|
447 | $len = $dirEnd; # invalid length
|
---|
448 | }
|
---|
449 | }
|
---|
450 | $valuePtr = $pos;
|
---|
451 | $pos += $len; # step $pos to next entry
|
---|
452 | # make sure we don't go past the end of data
|
---|
453 | # (this can only happen if original data is bad)
|
---|
454 | $pos = $dirEnd if $pos > $dirEnd;
|
---|
455 | } else {
|
---|
456 | undef $rec;
|
---|
457 | }
|
---|
458 | }
|
---|
459 | # write out all our records that come before this one
|
---|
460 | my $writeRec = (not defined $rec or $rec != $lastRec);
|
---|
461 | if ($writeRec or $addNow) {
|
---|
462 | for (;;) {
|
---|
463 | my $newRec = $recordList[0];
|
---|
464 | if ($addNow) {
|
---|
465 | $tagInfo = $addNow;
|
---|
466 | } elsif (not defined $newRec or $newRec != $lastRec) {
|
---|
467 | # handle mandatory tags in last record unless it was empty
|
---|
468 | if (length $newData > $lastRecPos) {
|
---|
469 | if ($allMandatory > 1) {
|
---|
470 | # entire lastRec contained mandatory tags, and at least one tag
|
---|
471 | # was deleted, so delete entire record unless we specifically
|
---|
472 | # added a mandatory tag
|
---|
473 | my $num = 0;
|
---|
474 | foreach (keys %{$foundRec{$lastRec}}) {
|
---|
475 | my $code = $foundRec{$lastRec}->{$_};
|
---|
476 | $num = 0, last if $code & 0x04;
|
---|
477 | ++$num if ($code & 0x03) == 0x01;
|
---|
478 | }
|
---|
479 | if ($num) {
|
---|
480 | $newData = substr($newData, 0, $lastRecPos);
|
---|
481 | $verbose > 1 and print $out " - $num mandatory tags\n";
|
---|
482 | }
|
---|
483 | } elsif ($mandatory{$lastRec} and
|
---|
484 | $tagTablePtr eq \%Image::ExifTool::IPTC::Main)
|
---|
485 | {
|
---|
486 | # add required mandatory tags
|
---|
487 | my $mandatory = $mandatory{$lastRec};
|
---|
488 | my ($mandTag, $subTablePtr);
|
---|
489 | foreach $mandTag (sort { $a <=> $b } keys %$mandatory) {
|
---|
490 | next if $foundRec{$lastRec}->{$mandTag};
|
---|
491 | unless ($subTablePtr) {
|
---|
492 | $tagInfo = $$tagTablePtr{$lastRec};
|
---|
493 | $tagInfo and $$tagInfo{SubDirectory} or warn("WriteIPTC: Internal error 1\n"), next;
|
---|
494 | $$tagInfo{SubDirectory}{TagTable} or next;
|
---|
495 | $subTablePtr = Image::ExifTool::GetTagTable($$tagInfo{SubDirectory}{TagTable});
|
---|
496 | }
|
---|
497 | $tagInfo = $$subTablePtr{$mandTag} or warn("WriteIPTC: Internal error 2\n"), next;
|
---|
498 | my $value = $$mandatory{$mandTag};
|
---|
499 | $et->VerboseValue("+ IPTC:$$tagInfo{Name}", $value, ' (mandatory)');
|
---|
500 | # apply necessary format conversions
|
---|
501 | FormatIPTC($et, $tagInfo, \$value, \$xlat, $lastRec);
|
---|
502 | $len = length $value;
|
---|
503 | # generate our new entry
|
---|
504 | my $entry = pack("CCCn", 0x1c, $lastRec, $mandTag, length($value));
|
---|
505 | $newData .= $entry . $value; # add entry to new IPTC data
|
---|
506 | # (don't mark as changed if just mandatory tags changed)
|
---|
507 | # ++$$et{CHANGED};
|
---|
508 | }
|
---|
509 | }
|
---|
510 | }
|
---|
511 | last unless defined $newRec;
|
---|
512 | $lastRec = $newRec;
|
---|
513 | $lastRecPos = length $newData;
|
---|
514 | $allMandatory = 1;
|
---|
515 | }
|
---|
516 | unless ($addNow) {
|
---|
517 | # compare current entry with entry next in line to write out
|
---|
518 | # (write out our tags in numerical order even though
|
---|
519 | # this isn't required by the IPTC spec)
|
---|
520 | last if defined $rec and $rec <= $newRec;
|
---|
521 | $tagInfo = ${$iptcInfo{$newRec}}[0];
|
---|
522 | }
|
---|
523 | my $newTag = $$tagInfo{TagID};
|
---|
524 | my $nvHash = $et->GetNewValueHash($tagInfo);
|
---|
525 | # only add new values if...
|
---|
526 | my ($doSet, @values);
|
---|
527 | my $found = $foundRec{$newRec}->{$newTag} || 0;
|
---|
528 | if ($found & 0x02) {
|
---|
529 | # ...tag existed before and was deleted (unless we already added it)
|
---|
530 | $doSet = 1 unless $found & 0x04;
|
---|
531 | } elsif ($$tagInfo{List}) {
|
---|
532 | # ...tag is List and it existed before or we are creating it
|
---|
533 | $doSet = 1 if $found ? not $$nvHash{CreateOnly} : $$nvHash{IsCreating};
|
---|
534 | } else {
|
---|
535 | # ...tag didn't exist before and we are creating it
|
---|
536 | $doSet = 1 if not $found and $$nvHash{IsCreating};
|
---|
537 | }
|
---|
538 | if ($doSet) {
|
---|
539 | @values = $et->GetNewValue($nvHash);
|
---|
540 | @values and $foundRec{$newRec}->{$newTag} = $found | 0x04;
|
---|
541 | # write tags for each value in list
|
---|
542 | my $value;
|
---|
543 | foreach $value (@values) {
|
---|
544 | $et->VerboseValue("+ $$dirInfo{DirName}:$$tagInfo{Name}", $value);
|
---|
545 | # reset allMandatory flag if a non-mandatory tag is written
|
---|
546 | if ($allMandatory) {
|
---|
547 | my $mandatory = $mandatory{$newRec};
|
---|
548 | $allMandatory = 0 unless $mandatory and $$mandatory{$newTag};
|
---|
549 | }
|
---|
550 | # apply necessary format conversions
|
---|
551 | FormatIPTC($et, $tagInfo, \$value, \$xlat, $newRec);
|
---|
552 | # (note: IPTC string values are NOT null terminated)
|
---|
553 | $len = length $value;
|
---|
554 | # generate our new entry
|
---|
555 | my $entry = pack("CCC", 0x1c, $newRec, $newTag);
|
---|
556 | if ($len <= 0x7fff) {
|
---|
557 | $entry .= pack("n", $len);
|
---|
558 | } else {
|
---|
559 | # extended dataset tag
|
---|
560 | $entry .= pack("nN", 0x8004, $len);
|
---|
561 | }
|
---|
562 | $newData .= $entry . $value; # add entry to new IPTC data
|
---|
563 | ++$$et{CHANGED};
|
---|
564 | }
|
---|
565 | }
|
---|
566 | # continue on with regular programming if done adding tag now
|
---|
567 | if ($addNow) {
|
---|
568 | undef $addNow;
|
---|
569 | next if $writeRec;
|
---|
570 | last;
|
---|
571 | }
|
---|
572 | # remove this tagID from the sorted write list
|
---|
573 | shift @{$iptcInfo{$newRec}};
|
---|
574 | shift @recordList unless @{$iptcInfo{$newRec}};
|
---|
575 | }
|
---|
576 | if ($writeRec) {
|
---|
577 | # all done if no more records to write
|
---|
578 | last unless defined $rec;
|
---|
579 | # update last record variables
|
---|
580 | $lastRec = $rec;
|
---|
581 | $lastRecPos = length $newData;
|
---|
582 | $allMandatory = 1;
|
---|
583 | }
|
---|
584 | }
|
---|
585 | # set flag indicating we found this tag
|
---|
586 | $foundRec{$rec}->{$tag} = ($foundRec{$rec}->{$tag} || 0) || 0x01;
|
---|
587 | # write out this record unless we are setting it with a new value
|
---|
588 | $tagInfo = $set{$rec}->{$tag};
|
---|
589 | if ($tagInfo) {
|
---|
590 | my $nvHash = $et->GetNewValueHash($tagInfo);
|
---|
591 | $len = $pos - $valuePtr;
|
---|
592 | my $val = substr($$dataPt, $valuePtr, $len);
|
---|
593 | # remove null terminator if it exists (written by braindead software like Picasa 2.0)
|
---|
594 | $val =~ s/\0+$// if $$tagInfo{Format} and $$tagInfo{Format} =~ /^string/;
|
---|
595 | my $oldXlat = $xlat;
|
---|
596 | FormatIPTC($et, $tagInfo, \$val, \$xlat, $rec, 1);
|
---|
597 | if ($et->IsOverwriting($nvHash, $val)) {
|
---|
598 | $xlat = $oldXlat; # don't change translation (not writing this value)
|
---|
599 | $et->VerboseValue("- $$dirInfo{DirName}:$$tagInfo{Name}", $val);
|
---|
600 | ++$$et{CHANGED};
|
---|
601 | # set deleted flag to indicate we found and deleted this tag
|
---|
602 | $foundRec{$rec}->{$tag} |= 0x02;
|
---|
603 | # increment allMandatory flag to indicate a tag was removed
|
---|
604 | $allMandatory and ++$allMandatory;
|
---|
605 | # write this tag now if overwriting an existing value
|
---|
606 | if ($$nvHash{Value} and @{$$nvHash{Value}} and @recordList and
|
---|
607 | $recordList[0] == $rec and not $foundRec{$rec}->{$tag} & 0x04)
|
---|
608 | {
|
---|
609 | $addNow = $tagInfo;
|
---|
610 | }
|
---|
611 | next;
|
---|
612 | }
|
---|
613 | } elsif ($rec == 1 and $tag == 90) {
|
---|
614 | # handle CodedCharacterSet tag
|
---|
615 | my $val = substr($$dataPt, $valuePtr, $pos - $valuePtr);
|
---|
616 | $xlat = HandleCodedCharset($et, $val);
|
---|
617 | }
|
---|
618 | # reset allMandatory flag if a non-mandatory tag is written
|
---|
619 | if ($allMandatory) {
|
---|
620 | my $mandatory = $mandatory{$rec};
|
---|
621 | unless ($mandatory and $$mandatory{$tag}) {
|
---|
622 | $allMandatory = 0;
|
---|
623 | }
|
---|
624 | }
|
---|
625 | # write out the record
|
---|
626 | $newData .= substr($$dataPt, $tail, $pos-$tail);
|
---|
627 | }
|
---|
628 | # make sure the rest of the data is zero
|
---|
629 | if ($tail < $dirEnd) {
|
---|
630 | my $pad = substr($$dataPt, $tail, $dirEnd-$tail);
|
---|
631 | if ($pad =~ /[^\0]/) {
|
---|
632 | return undef if $et->Warn('Unrecognized data in IPTC padding', 2);
|
---|
633 | }
|
---|
634 | }
|
---|
635 | return $newData;
|
---|
636 | }
|
---|
637 |
|
---|
638 | #------------------------------------------------------------------------------
|
---|
639 | # Write IPTC data record and calculate NewIPTCDigest
|
---|
640 | # Inputs: 0) ExifTool object ref, 1) source dirInfo ref, 2) tag table ref
|
---|
641 | # Returns: IPTC data block (may be empty if no IPTC data)
|
---|
642 | # Notes: Increments ExifTool CHANGED flag for each tag changed
|
---|
643 | sub WriteIPTC($$$)
|
---|
644 | {
|
---|
645 | my ($et, $dirInfo, $tagTablePtr) = @_;
|
---|
646 | $et or return 1; # allow dummy access to autoload this package
|
---|
647 |
|
---|
648 | my $newData = DoWriteIPTC($et, $dirInfo, $tagTablePtr);
|
---|
649 |
|
---|
650 | # calculate standard IPTC digests only if we are writing or deleting
|
---|
651 | # Photoshop:IPTCDigest with a value of 'new' or 'old'
|
---|
652 | while ($Image::ExifTool::Photoshop::iptcDigestInfo) {
|
---|
653 | my $nvHash = $$et{NEW_VALUE}{$Image::ExifTool::Photoshop::iptcDigestInfo};
|
---|
654 | last unless defined $nvHash;
|
---|
655 | last unless IsStandardIPTC($et->MetadataPath());
|
---|
656 | my @values = $et->GetNewValue($nvHash);
|
---|
657 | push @values, @{$$nvHash{DelValue}} if $$nvHash{DelValue};
|
---|
658 | my $new = grep /^new$/, @values;
|
---|
659 | my $old = grep /^old$/, @values;
|
---|
660 | last unless $new or $old;
|
---|
661 | unless (eval { require Digest::MD5 }) {
|
---|
662 | $et->Warn('Digest::MD5 must be installed to calculate IPTC digest');
|
---|
663 | last;
|
---|
664 | }
|
---|
665 | my $dataPt;
|
---|
666 | if ($new) {
|
---|
667 | if (defined $newData) {
|
---|
668 | $dataPt = \$newData;
|
---|
669 | } else {
|
---|
670 | $dataPt = $$dirInfo{DataPt};
|
---|
671 | if ($$dirInfo{DirStart} or length($$dataPt) != $$dirInfo{DirLen}) {
|
---|
672 | my $buff = substr($$dataPt, $$dirInfo{DirStart}, $$dirInfo{DirLen});
|
---|
673 | $dataPt = \$buff;
|
---|
674 | }
|
---|
675 | }
|
---|
676 | # set NewIPTCDigest data member unless IPTC is being deleted
|
---|
677 | $$et{NewIPTCDigest} = Digest::MD5::md5($$dataPt) if length $$dataPt;
|
---|
678 | }
|
---|
679 | if ($old) {
|
---|
680 | if ($new and not defined $newData) {
|
---|
681 | $$et{OldIPTCDigest} = $$et{NewIPTCDigest};
|
---|
682 | } elsif ($$dirInfo{DataPt}) { #(may be undef if creating new IPTC)
|
---|
683 | $dataPt = $$dirInfo{DataPt};
|
---|
684 | if ($$dirInfo{DirStart} or length($$dataPt) != $$dirInfo{DirLen}) {
|
---|
685 | my $buff = substr($$dataPt, $$dirInfo{DirStart}, $$dirInfo{DirLen});
|
---|
686 | $dataPt = \$buff;
|
---|
687 | }
|
---|
688 | $$et{OldIPTCDigest} = Digest::MD5::md5($$dataPt) if length $$dataPt;
|
---|
689 | }
|
---|
690 | }
|
---|
691 | last;
|
---|
692 | }
|
---|
693 | # set changed if ForceWrite tag was set to "IPTC"
|
---|
694 | ++$$et{CHANGED} if defined $newData and length $newData and $$et{FORCE_WRITE}{IPTC};
|
---|
695 | return $newData;
|
---|
696 | }
|
---|
697 |
|
---|
698 |
|
---|
699 | 1; # end
|
---|
700 |
|
---|
701 | __END__
|
---|
702 |
|
---|
703 | =head1 NAME
|
---|
704 |
|
---|
705 | Image::ExifTool::WriteIPTC.pl - Write IPTC meta information
|
---|
706 |
|
---|
707 | =head1 SYNOPSIS
|
---|
708 |
|
---|
709 | This file is autoloaded by Image::ExifTool::IPTC.
|
---|
710 |
|
---|
711 | =head1 DESCRIPTION
|
---|
712 |
|
---|
713 | This file contains routines to write IPTC metadata, plus a few other
|
---|
714 | seldom-used routines.
|
---|
715 |
|
---|
716 | =head1 AUTHOR
|
---|
717 |
|
---|
718 | Copyright 2003-2021, Phil Harvey (philharvey66 at gmail.com)
|
---|
719 |
|
---|
720 | This library is free software; you can redistribute it and/or modify it
|
---|
721 | under the same terms as Perl itself.
|
---|
722 |
|
---|
723 | =head1 SEE ALSO
|
---|
724 |
|
---|
725 | L<Image::ExifTool::IPTC(3pm)|Image::ExifTool::IPTC>,
|
---|
726 | L<Image::ExifTool(3pm)|Image::ExifTool>
|
---|
727 |
|
---|
728 | =cut
|
---|