WriteIPTC.pl 28 KB

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