This file is indexed.

/usr/share/perl5/Image/ExifTool/WriteIPTC.pl is in libimage-exiftool-perl 10.40-1.

This file is owned by root:root, with mode 0o644.

The actual contents of the file can be viewed below.

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
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