#------------------------------------------------------------------------------ # 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 and $fmt ne 'string') { # (must truncate strings later, after recoding) $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); } # must check length now (after any string recoding) if (not $read and $format =~ /^string\[(\d+),?(\d*)\]$/) { my ($minlen, $maxlen) = ($1, $2); my $len = length $$valPtr; $maxlen or $maxlen = $minlen; if ($len < $minlen) { if ($et->Warn("String to short for IPTC:$$tagInfo{Name} (padded)", 2)) { $$valPtr .= ' ' x ($minlen - $len); } } elsif ($len > $maxlen) { if ($et->Warn("IPTC:$$tagInfo{Name} exceeds length limit (truncated)", 2)) { $$valPtr = substr($$valPtr, 0, $maxlen); # make sure UTF-8 is still valid if (($$xlatPtr || $et->Options('Charset')) eq 'UTF8') { require Image::ExifTool::XMP; Image::ExifTool::XMP::FixUTF8($valPtr,'.'); } } } } } } #------------------------------------------------------------------------------ # 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) ExifTool ref, 1) IPTC date or 'now' # Returns: IPTC date sub InverseDateOrTime($$) { my ($et, $val) = @_; return $et->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 = '' } 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; } # set changed if ForceWrite tag was set to "IPTC" ++$$et{CHANGED} if defined $newData and length $newData and $$et{FORCE_WRITE}{IPTC}; 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-2018, 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, L =cut