123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706 |
- #------------------------------------------------------------------------------
- # File: WriteIPTC.pl
- #
- # Description: Write IPTC meta information
- #
- # Revisions: 12/15/2004 - P. Harvey Created
- #------------------------------------------------------------------------------
- package Image::ExifTool::IPTC;
- use strict;
- # mandatory IPTC tags for each record
- my %mandatory = (
- 1 => {
- 0 => 4, # EnvelopeRecordVersion
- },
- 2 => {
- 0 => 4, # ApplicationRecordVersion
- },
- 3 => {
- 0 => 4, # NewsPhotoVersion
- },
- );
- # manufacturer strings for IPTCPictureNumber
- my %manufacturer = (
- 1 => 'Associated Press, USA',
- 2 => 'Eastman Kodak Co, USA',
- 3 => 'Hasselblad Electronic Imaging, Sweden',
- 4 => 'Tecnavia SA, Switzerland',
- 5 => 'Nikon Corporation, Japan',
- 6 => 'Coatsworth Communications Inc, Canada',
- 7 => 'Agence France Presse, France',
- 8 => 'T/One Inc, USA',
- 9 => 'Associated Newspapers, UK',
- 10 => 'Reuters London',
- 11 => 'Sandia Imaging Systems Inc, USA',
- 12 => 'Visualize, Spain',
- );
- my %iptcCharsetInv = ( 'UTF8' => "\x1b%G", 'UTF-8' => "\x1b%G" );
- # ISO 2022 Character Coding Notes
- # -------------------------------
- # Character set designation: (0x1b I F, or 0x1b I I F)
- # Initial character 0x1b (ESC)
- # Intermediate character I:
- # 0x28 ('(') - G0, 94 chars
- # 0x29 (')') - G1, 94 chars
- # 0x2a ('*') - G2, 94 chars
- # 0x2b ('+') - G3, 94 chars
- # 0x2c (',') - G1, 96 chars
- # 0x2d ('-') - G2, 96 chars
- # 0x2e ('.') - G3, 96 chars
- # 0x24 I ('$I') - multiple byte graphic sets (I from above)
- # I 0x20 ('I ') - dynamically redefinable character sets
- # Final character:
- # 0x30 - 0x3f = private character set
- # 0x40 - 0x7f = standardized character set
- # Character set invocation:
- # G0 : SI = 0x15
- # G1 : SO = 0x14, LS1R = 0x1b 0x7e ('~')
- # G2 : LS2 = 0x1b 0x6e ('n'), LS2R = 0x1b 0x7d ('}')
- # G3 : LS3 = 0x1b 0x6f ('o'), LS3R = 0x1b 0x7c ('|')
- # (the locking shift "R" codes shift into 0x80-0xff space)
- # Single character invocation:
- # G2 : SS2 = 0x1b 0x8e (or 0x4e in 7-bit)
- # G3 : SS3 = 0x1b 0x8f (or 0x4f in 7-bit)
- # Control chars (designated and invoked)
- # C0 : 0x1b 0x21 F (0x21 = '!')
- # C1 : 0x1b 0x22 F (0x22 = '"')
- # Complete codes (control+graphics, designated and invoked)
- # 0x1b 0x25 F (0x25 = '%')
- # 0x1b 0x25 I F
- # 0x1b 0x25 0x47 ("\x1b%G") - UTF-8
- # 0x1b 0x25 0x40 ("\x1b%@") - return to ISO 2022
- # -------------------------------
- #------------------------------------------------------------------------------
- # Inverse print conversion for CodedCharacterSet
- # Inputs: 0) value
- sub PrintInvCodedCharset($)
- {
- my $val = shift;
- my $code = $iptcCharsetInv{uc($val)};
- unless ($code) {
- if (($code = $val) =~ s/ESC */\x1b/ig) { # translate ESC chars
- $code =~ s/, \x1b/\x1b/g; # remove comma separators
- $code =~ tr/ //d; # remove spaces
- } else {
- warn "Bad syntax (use 'UTF8' or 'ESC X Y[, ...]')\n";
- }
- }
- return $code;
- }
- #------------------------------------------------------------------------------
- # validate raw values for writing
- # Inputs: 0) ExifTool object ref, 1) tagInfo hash ref, 2) raw value ref
- # Returns: error string or undef (and possibly changes value) on success
- sub CheckIPTC($$$)
- {
- my ($et, $tagInfo, $valPtr) = @_;
- my $format = $$tagInfo{Format} || $$tagInfo{Table}{FORMAT} || '';
- if ($format =~ /^int(\d+)/) {
- my $bytes = int(($1 || 0) / 8);
- if ($bytes ne 1 and $bytes ne 2 and $bytes ne 4) {
- return "Can't write $bytes-byte integer";
- }
- my $val = $$valPtr;
- unless (Image::ExifTool::IsInt($val)) {
- return 'Not an integer' unless Image::ExifTool::IsHex($val);
- $val = $$valPtr = hex($val);
- }
- my $n;
- for ($n=0; $n<$bytes; ++$n) { $val >>= 8; }
- return "Value too large for $bytes-byte format" if $val;
- } elsif ($format =~ /^(string|digits|undef)\[?(\d+),?(\d*)\]?$/) {
- my ($fmt, $minlen, $maxlen) = ($1, $2, $3);
- my $len = length $$valPtr;
- if ($fmt eq 'digits') {
- return 'Non-numeric characters in value' unless $$valPtr =~ /^\d*$/;
- if ($len < $minlen and $len) {
- # left pad with zeros if necessary
- $$valPtr = ('0' x ($minlen - $len)) . $$valPtr;
- $len = $minlen;
- }
- }
- if (defined $minlen) {
- $maxlen or $maxlen = $minlen;
- if ($len < $minlen) {
- unless ($$et{OPTIONS}{IgnoreMinorErrors}) {
- return "[Minor] String too short (minlen is $minlen)";
- }
- $$et{CHECK_WARN} = "String too short for IPTC:$$tagInfo{Name} (written anyway)";
- } elsif ($len > $maxlen and not $$et{OPTIONS}{IgnoreMinorErrors}) {
- $$et{CHECK_WARN} = "[Minor] IPTC:$$tagInfo{Name} exceeds length limit (truncated)";
- $$valPtr = substr($$valPtr, 0, $maxlen);
- }
- }
- } else {
- return "Bad IPTC Format ($format)";
- }
- return undef;
- }
- #------------------------------------------------------------------------------
- # format IPTC data for writing
- # Inputs: 0) ExifTool object ref, 1) tagInfo pointer,
- # 2) value reference (changed if necessary),
- # 3) reference to character set for translation (changed if necessary)
- # 4) record number, 5) flag set to read value (instead of write)
- sub FormatIPTC($$$$$;$)
- {
- my ($et, $tagInfo, $valPtr, $xlatPtr, $rec, $read) = @_;
- my $format = $$tagInfo{Format} || $$tagInfo{Table}{FORMAT};
- return unless $format;
- if ($format =~ /^int(\d+)/) {
- if ($read) {
- my $len = length($$valPtr);
- if ($len <= 8) { # limit integer conversion to 8 bytes long
- my $val = 0;
- my $i;
- for ($i=0; $i<$len; ++$i) {
- $val = $val * 256 + ord(substr($$valPtr, $i, 1));
- }
- $$valPtr = $val;
- }
- } else {
- my $len = int(($1 || 0) / 8);
- if ($len == 1) { # 1 byte
- $$valPtr = chr($$valPtr);
- } elsif ($len == 2) { # 2-byte integer
- $$valPtr = pack('n', $$valPtr);
- } else { # 4-byte integer
- $$valPtr = pack('N', $$valPtr);
- }
- }
- } elsif ($format =~ /^string/) {
- if ($rec == 1) {
- if ($$tagInfo{Name} eq 'CodedCharacterSet') {
- $$xlatPtr = HandleCodedCharset($et, $$valPtr);
- }
- } elsif ($$xlatPtr and $rec < 7 and $$valPtr =~ /[\x80-\xff]/) {
- TranslateCodedString($et, $valPtr, $xlatPtr, $read);
- }
- }
- }
- #------------------------------------------------------------------------------
- # generate IPTC-format date
- # Inputs: 0) EXIF-format date string (YYYY:mm:dd) or date/time string
- # Returns: IPTC-format date string (YYYYmmdd), or undef and issue warning on error
- sub IptcDate($)
- {
- my $val = shift;
- unless ($val =~ s/^.*(\d{4}):?(\d{2}):?(\d{2}).*/$1$2$3/s) {
- warn "Invalid date format (use YYYY:mm:dd)\n";
- undef $val;
- }
- return $val;
- }
- #------------------------------------------------------------------------------
- # generate IPTC-format time
- # Inputs: 0) EXIF-format time string (HH:MM:SS[+/-HH:MM]) or date/time string
- # Returns: IPTC-format time string (HHMMSS+HHMM), or undef and issue warning on error
- sub IptcTime($)
- {
- my $val = shift;
- if ($val =~ /(.*?)\b(\d{1,2})(:?)(\d{2})(:?)(\d{2})(\S*)\s*$/s and ($3 or not $5)) {
- $val = sprintf("%.2d%.2d%.2d",$2,$4,$6);
- my ($date, $tz) = ($1, $7);
- if ($tz =~ /([+-]\d{1,2}):?(\d{2})/) {
- $tz = sprintf("%+.2d%.2d",$1,$2);
- } elsif ($tz =~ /Z/i) {
- $tz = '+0000'; # UTC
- } else {
- # use local system timezone by default
- my (@tm, $time);
- if ($date and $date =~ /^(\d{4}):(\d{2}):(\d{2})\s*$/ and eval { require Time::Local }) {
- # we were given a date too, so determine the local timezone
- # offset at the specified date/time
- my @d = ($3,$2-1,$1-1900);
- $val =~ /(\d{2})(\d{2})(\d{2})/;
- @tm = ($3,$2,$1,@d);
- $time = Image::ExifTool::TimeLocal(@tm);
- } else {
- # it is difficult to get the proper local timezone offset for this
- # time because the date tag is written separately. (The offset may be
- # different on a different date due to daylight savings time.) In this
- # case the best we can do easily is to use the current timezone offset.
- $time = time;
- @tm = localtime($time);
- }
- ($tz = Image::ExifTool::TimeZoneString(\@tm, $time)) =~ tr/://d;
- }
- $val .= $tz;
- } else {
- warn "Invalid time format (use HH:MM:SS[+/-HH:MM])\n";
- undef $val; # time format error
- }
- return $val;
- }
- #------------------------------------------------------------------------------
- # Inverse print conversion for IPTC date or time value
- # Inputs: 0) IPTC date or 'now'
- # Returns: IPTC date
- sub InverseDateOrTime($)
- {
- my $val = shift;
- return Image::ExifTool::TimeNow() if lc($val) eq 'now';
- return $val;
- }
- #------------------------------------------------------------------------------
- # Convert picture number
- # Inputs: 0) value
- # Returns: Converted value
- sub ConvertPictureNumber($)
- {
- my $val = shift;
- if ($val eq "\0" x 16) {
- $val = 'Unknown';
- } elsif (length $val >= 16) {
- my @vals = unpack('nNA8n', $val);
- $val = $vals[0];
- my $manu = $manufacturer{$val};
- $val .= " ($manu)" if $manu;
- $val .= ', equip ' . $vals[1];
- $vals[2] =~ s/(\d{4})(\d{2})(\d{2})/$1:$2:$3/;
- $val .= ", $vals[2], no. $vals[3]";
- } else {
- $val = '<format error>'
- }
- return $val;
- }
- #------------------------------------------------------------------------------
- # Inverse picture number conversion
- # Inputs: 0) value
- # Returns: Converted value (or undef on error)
- sub InvConvertPictureNumber($)
- {
- my $val = shift;
- $val =~ s/\(.*\)//g; # remove manufacturer description
- $val =~ tr/://d; # remove date separators
- $val =~ tr/0-9/ /c; # turn remaining non-numbers to spaces
- my @vals = split ' ', $val;
- if (@vals >= 4) {
- $val = pack('nNA8n', @vals);
- } elsif ($val =~ /unknown/i) {
- $val = "\0" x 16;
- } else {
- undef $val;
- }
- return $val;
- }
- #------------------------------------------------------------------------------
- # Write IPTC data record
- # Inputs: 0) ExifTool object ref, 1) source dirInfo ref, 2) tag table ref
- # Returns: IPTC data block (may be empty if no IPTC data)
- # Notes: Increments ExifTool CHANGED flag for each tag changed
- sub DoWriteIPTC($$$)
- {
- my ($et, $dirInfo, $tagTablePtr) = @_;
- my $verbose = $et->Options('Verbose');
- my $out = $et->Options('TextOut');
- # avoid editing IPTC directory unless necessary:
- # - improves speed
- # - avoids changing current MD5 digest unnecessarily
- # - avoids adding mandatory tags unless some other IPTC is changed
- unless (exists $$et{EDIT_DIRS}{$$dirInfo{DirName}} or
- # standard IPTC tags in other locations should be edited too (eg. AFCP_IPTC)
- ($tagTablePtr eq \%Image::ExifTool::IPTC::Main and exists $$et{EDIT_DIRS}{IPTC}))
- {
- print $out "$$et{INDENT} [nothing changed]\n" if $verbose;
- return undef;
- }
- my $dataPt = $$dirInfo{DataPt};
- unless ($dataPt) {
- my $emptyData = '';
- $dataPt = \$emptyData;
- }
- my $start = $$dirInfo{DirStart} || 0;
- my $dirLen = $$dirInfo{DirLen};
- my ($tagInfo, %iptcInfo, $tag);
- # start by assuming default IPTC encoding
- my $xlat = $et->Options('CharsetIPTC');
- undef $xlat if $xlat eq $et->Options('Charset');
- # make sure our dataLen is defined (note: allow zero length directory)
- unless (defined $dirLen) {
- my $dataLen = $$dirInfo{DataLen};
- $dataLen = length($$dataPt) unless defined $dataLen;
- $dirLen = $dataLen - $start;
- }
- # quick check for improperly byte-swapped IPTC
- if ($dirLen >= 4 and substr($$dataPt, $start, 1) ne "\x1c" and
- substr($$dataPt, $start + 3, 1) eq "\x1c")
- {
- $et->Warn('IPTC data was improperly byte-swapped');
- my $newData = pack('N*', unpack('V*', substr($$dataPt, $start, $dirLen) . "\0\0\0"));
- $dataPt = \$newData;
- $start = 0;
- # NOTE: MUST NOT access $dirInfo DataPt, DirStart or DataLen after this!
- }
- # generate lookup so we can find the record numbers
- my %recordNum;
- foreach $tag (Image::ExifTool::TagTableKeys($tagTablePtr)) {
- $tagInfo = $$tagTablePtr{$tag};
- $$tagInfo{SubDirectory} or next;
- my $table = $$tagInfo{SubDirectory}{TagTable} or next;
- my $subTablePtr = Image::ExifTool::GetTagTable($table);
- $recordNum{$subTablePtr} = $tag;
- }
- # loop through new values and accumulate all IPTC information
- # into lists based on their IPTC record type
- foreach $tagInfo ($et->GetNewTagInfoList()) {
- my $table = $$tagInfo{Table};
- my $record = $recordNum{$table};
- # ignore tags we aren't writing to this directory
- next unless defined $record;
- $iptcInfo{$record} = [] unless defined $iptcInfo{$record};
- push @{$iptcInfo{$record}}, $tagInfo;
- }
- # get sorted list of records used. Might as well be organized and
- # write our records in order of record number first, then tag number
- my @recordList = sort { $a <=> $b } keys %iptcInfo;
- my ($record, %set);
- foreach $record (@recordList) {
- # sort tagInfo lists by tagID
- @{$iptcInfo{$record}} = sort { $$a{TagID} <=> $$b{TagID} } @{$iptcInfo{$record}};
- # build hash of all tagIDs to set
- foreach $tagInfo (@{$iptcInfo{$record}}) {
- $set{$record}->{$$tagInfo{TagID}} = $tagInfo;
- }
- }
- # run through the old IPTC data, inserting our records in
- # sequence and deleting existing records where necessary
- # (the IPTC specification states that records must occur in
- # numerical order, but tags within records need not be ordered)
- my $pos = $start;
- my $tail = $pos; # old data written up to this point
- my $dirEnd = $start + $dirLen;
- my $newData = '';
- my $lastRec = -1;
- my $lastRecPos = 0;
- my $allMandatory = 0;
- my %foundRec; # found flags: 0x01-existed before, 0x02-deleted, 0x04-created
- my $addNow;
- for (;;$tail=$pos) {
- # get next IPTC record from input directory
- my ($id, $rec, $tag, $len, $valuePtr);
- if ($pos + 5 <= $dirEnd) {
- my $buff = substr($$dataPt, $pos, 5);
- ($id, $rec, $tag, $len) = unpack("CCCn", $buff);
- if ($id == 0x1c) {
- if ($rec < $lastRec) {
- if ($rec == 0) {
- return undef if $et->Warn("IPTC record 0 encountered, subsequent records ignored", 2);
- undef $rec;
- $pos = $dirEnd;
- $len = 0;
- } else {
- return undef if $et->Warn("IPTC doesn't conform to spec: Records out of sequence", 2);
- }
- }
- # handle extended IPTC entry if necessary
- $pos += 5; # step to after field header
- if ($len & 0x8000) {
- my $n = $len & 0x7fff; # get num bytes in length field
- if ($pos + $n <= $dirEnd and $n <= 8) {
- # determine length (a big-endian, variable sized int)
- for ($len = 0; $n; ++$pos, --$n) {
- $len = $len * 256 + ord(substr($$dataPt, $pos, 1));
- }
- } else {
- $len = $dirEnd; # invalid length
- }
- }
- $valuePtr = $pos;
- $pos += $len; # step $pos to next entry
- # make sure we don't go past the end of data
- # (this can only happen if original data is bad)
- $pos = $dirEnd if $pos > $dirEnd;
- } else {
- undef $rec;
- }
- }
- # write out all our records that come before this one
- my $writeRec = (not defined $rec or $rec != $lastRec);
- if ($writeRec or $addNow) {
- for (;;) {
- my $newRec = $recordList[0];
- if ($addNow) {
- $tagInfo = $addNow;
- } elsif (not defined $newRec or $newRec != $lastRec) {
- # handle mandatory tags in last record unless it was empty
- if (length $newData > $lastRecPos) {
- if ($allMandatory > 1) {
- # entire lastRec contained mandatory tags, and at least one tag
- # was deleted, so delete entire record unless we specifically
- # added a mandatory tag
- my $num = 0;
- foreach (keys %{$foundRec{$lastRec}}) {
- my $code = $foundRec{$lastRec}->{$_};
- $num = 0, last if $code & 0x04;
- ++$num if ($code & 0x03) == 0x01;
- }
- if ($num) {
- $newData = substr($newData, 0, $lastRecPos);
- $verbose > 1 and print $out " - $num mandatory tags\n";
- }
- } elsif ($mandatory{$lastRec} and
- $tagTablePtr eq \%Image::ExifTool::IPTC::Main)
- {
- # add required mandatory tags
- my $mandatory = $mandatory{$lastRec};
- my ($mandTag, $subTablePtr);
- foreach $mandTag (sort { $a <=> $b } keys %$mandatory) {
- next if $foundRec{$lastRec}->{$mandTag};
- unless ($subTablePtr) {
- $tagInfo = $$tagTablePtr{$lastRec};
- $tagInfo and $$tagInfo{SubDirectory} or warn("WriteIPTC: Internal error 1\n"), next;
- $$tagInfo{SubDirectory}{TagTable} or next;
- $subTablePtr = Image::ExifTool::GetTagTable($$tagInfo{SubDirectory}{TagTable});
- }
- $tagInfo = $$subTablePtr{$mandTag} or warn("WriteIPTC: Internal error 2\n"), next;
- my $value = $$mandatory{$mandTag};
- $et->VerboseValue("+ IPTC:$$tagInfo{Name}", $value, ' (mandatory)');
- # apply necessary format conversions
- FormatIPTC($et, $tagInfo, \$value, \$xlat, $lastRec);
- $len = length $value;
- # generate our new entry
- my $entry = pack("CCCn", 0x1c, $lastRec, $mandTag, length($value));
- $newData .= $entry . $value; # add entry to new IPTC data
- # (don't mark as changed if just mandatory tags changed)
- # ++$$et{CHANGED};
- }
- }
- }
- last unless defined $newRec;
- $lastRec = $newRec;
- $lastRecPos = length $newData;
- $allMandatory = 1;
- }
- unless ($addNow) {
- # compare current entry with entry next in line to write out
- # (write out our tags in numerical order even though
- # this isn't required by the IPTC spec)
- last if defined $rec and $rec <= $newRec;
- $tagInfo = ${$iptcInfo{$newRec}}[0];
- }
- my $newTag = $$tagInfo{TagID};
- my $nvHash = $et->GetNewValueHash($tagInfo);
- # only add new values if...
- my ($doSet, @values);
- my $found = $foundRec{$newRec}->{$newTag} || 0;
- if ($found & 0x02) {
- # ...tag existed before and was deleted (unless we already added it)
- $doSet = 1 unless $found & 0x04;
- } elsif ($$tagInfo{List}) {
- # ...tag is List and it existed before or we are creating it
- $doSet = 1 if $found ? not $$nvHash{CreateOnly} : $$nvHash{IsCreating};
- } else {
- # ...tag didn't exist before and we are creating it
- $doSet = 1 if not $found and $$nvHash{IsCreating};
- }
- if ($doSet) {
- @values = $et->GetNewValue($nvHash);
- @values and $foundRec{$newRec}->{$newTag} = $found | 0x04;
- # write tags for each value in list
- my $value;
- foreach $value (@values) {
- $et->VerboseValue("+ $$dirInfo{DirName}:$$tagInfo{Name}", $value);
- # reset allMandatory flag if a non-mandatory tag is written
- if ($allMandatory) {
- my $mandatory = $mandatory{$newRec};
- $allMandatory = 0 unless $mandatory and $$mandatory{$newTag};
- }
- # apply necessary format conversions
- FormatIPTC($et, $tagInfo, \$value, \$xlat, $newRec);
- # (note: IPTC string values are NOT null terminated)
- $len = length $value;
- # generate our new entry
- my $entry = pack("CCC", 0x1c, $newRec, $newTag);
- if ($len <= 0x7fff) {
- $entry .= pack("n", $len);
- } else {
- # extended dataset tag
- $entry .= pack("nN", 0x8004, $len);
- }
- $newData .= $entry . $value; # add entry to new IPTC data
- ++$$et{CHANGED};
- }
- }
- # continue on with regular programming if done adding tag now
- if ($addNow) {
- undef $addNow;
- next if $writeRec;
- last;
- }
- # remove this tagID from the sorted write list
- shift @{$iptcInfo{$newRec}};
- shift @recordList unless @{$iptcInfo{$newRec}};
- }
- if ($writeRec) {
- # all done if no more records to write
- last unless defined $rec;
- # update last record variables
- $lastRec = $rec;
- $lastRecPos = length $newData;
- $allMandatory = 1;
- }
- }
- # set flag indicating we found this tag
- $foundRec{$rec}->{$tag} = ($foundRec{$rec}->{$tag} || 0) || 0x01;
- # write out this record unless we are setting it with a new value
- $tagInfo = $set{$rec}->{$tag};
- if ($tagInfo) {
- my $nvHash = $et->GetNewValueHash($tagInfo);
- $len = $pos - $valuePtr;
- my $val = substr($$dataPt, $valuePtr, $len);
- # remove null terminator if it exists (written by braindead software like Picasa 2.0)
- $val =~ s/\0+$// if $$tagInfo{Format} and $$tagInfo{Format} =~ /^string/;
- my $oldXlat = $xlat;
- FormatIPTC($et, $tagInfo, \$val, \$xlat, $rec, 1);
- if ($et->IsOverwriting($nvHash, $val)) {
- $xlat = $oldXlat; # don't change translation (not writing this value)
- $et->VerboseValue("- $$dirInfo{DirName}:$$tagInfo{Name}", $val);
- ++$$et{CHANGED};
- # set deleted flag to indicate we found and deleted this tag
- $foundRec{$rec}->{$tag} |= 0x02;
- # increment allMandatory flag to indicate a tag was removed
- $allMandatory and ++$allMandatory;
- # write this tag now if overwriting an existing value
- if ($$nvHash{Value} and @{$$nvHash{Value}} and @recordList and
- $recordList[0] == $rec and not $foundRec{$rec}->{$tag} & 0x04)
- {
- $addNow = $tagInfo;
- }
- next;
- }
- } elsif ($rec == 1 and $tag == 90) {
- # handle CodedCharacterSet tag
- my $val = substr($$dataPt, $valuePtr, $pos - $valuePtr);
- $xlat = HandleCodedCharset($et, $val);
- }
- # reset allMandatory flag if a non-mandatory tag is written
- if ($allMandatory) {
- my $mandatory = $mandatory{$rec};
- unless ($mandatory and $$mandatory{$tag}) {
- $allMandatory = 0;
- }
- }
- # write out the record
- $newData .= substr($$dataPt, $tail, $pos-$tail);
- }
- # make sure the rest of the data is zero
- if ($tail < $dirEnd) {
- my $pad = substr($$dataPt, $tail, $dirEnd-$tail);
- if ($pad =~ /[^\0]/) {
- return undef if $et->Warn('Unrecognized data in IPTC padding', 2);
- }
- }
- return $newData;
- }
- #------------------------------------------------------------------------------
- # Write IPTC data record and calculate NewIPTCDigest
- # Inputs: 0) ExifTool object ref, 1) source dirInfo ref, 2) tag table ref
- # Returns: IPTC data block (may be empty if no IPTC data)
- # Notes: Increments ExifTool CHANGED flag for each tag changed
- sub WriteIPTC($$$)
- {
- my ($et, $dirInfo, $tagTablePtr) = @_;
- $et or return 1; # allow dummy access to autoload this package
- my $newData = DoWriteIPTC($et, $dirInfo, $tagTablePtr);
- # calculate standard IPTC digests only if we are writing or deleting
- # Photoshop:IPTCDigest with a value of 'new' or 'old'
- while ($Image::ExifTool::Photoshop::iptcDigestInfo) {
- my $nvHash = $$et{NEW_VALUE}{$Image::ExifTool::Photoshop::iptcDigestInfo};
- last unless defined $nvHash;
- last unless IsStandardIPTC($et->MetadataPath());
- my @values = $et->GetNewValue($nvHash);
- push @values, @{$$nvHash{DelValue}} if $$nvHash{DelValue};
- my $new = grep /^new$/, @values;
- my $old = grep /^old$/, @values;
- last unless $new or $old;
- unless (eval { require Digest::MD5 }) {
- $et->Warn('Digest::MD5 must be installed to calculate IPTC digest');
- last;
- }
- my $dataPt;
- if ($new) {
- if (defined $newData) {
- $dataPt = \$newData;
- } else {
- $dataPt = $$dirInfo{DataPt};
- if ($$dirInfo{DirStart} or length($$dataPt) != $$dirInfo{DirLen}) {
- my $buff = substr($$dataPt, $$dirInfo{DirStart}, $$dirInfo{DirLen});
- $dataPt = \$buff;
- }
- }
- # set NewIPTCDigest data member unless IPTC is being deleted
- $$et{NewIPTCDigest} = Digest::MD5::md5($$dataPt) if length $$dataPt;
- }
- if ($old) {
- if ($new and not defined $newData) {
- $$et{OldIPTCDigest} = $$et{NewIPTCDigest};
- } elsif ($$dirInfo{DataPt}) { #(may be undef if creating new IPTC)
- $dataPt = $$dirInfo{DataPt};
- if ($$dirInfo{DirStart} or length($$dataPt) != $$dirInfo{DirLen}) {
- my $buff = substr($$dataPt, $$dirInfo{DirStart}, $$dirInfo{DirLen});
- $dataPt = \$buff;
- }
- $$et{OldIPTCDigest} = Digest::MD5::md5($$dataPt) if length $$dataPt;
- }
- }
- last;
- }
- return $newData;
- }
- 1; # end
- __END__
- =head1 NAME
- Image::ExifTool::WriteIPTC.pl - Write IPTC meta information
- =head1 SYNOPSIS
- This file is autoloaded by Image::ExifTool::IPTC.
- =head1 DESCRIPTION
- This file contains routines to write IPTC metadata, plus a few other
- seldom-used routines.
- =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 SEE ALSO
- L<Image::ExifTool::IPTC(3pm)|Image::ExifTool::IPTC>,
- L<Image::ExifTool(3pm)|Image::ExifTool>
- =cut
|