exiftool_vendored 10.31.0 → 10.40.0

data/bin/Image-ExifTool-10.40/lib/Image/ExifTool/WriteIPTC.pl

@@ -0,0 +1,706 @@
+#------------------------------------------------------------------------------
+# 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-2017, 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