Ignore:
Timestamp:
2021-02-26T19:39:51+13:00 (3 years ago)
Author:
anupama
Message:

Committing the improvements to EmbeddedMetaPlugin's processing of Keywords vs other metadata fields. Keywords were literally stored as arrays of words rather than phrases in PDFs (at least in Diego's sample PDF), whereas other meta fields like Subjects and Creators stored them as arrays of phrases. To get both to work, Kathy updated EXIF to a newer version, to retrieve the actual EXIF values stored in the PDF. And Kathy and Dr Bainbridge came up with a new option that I added called apply_join_before_split_to_metafields that's a regex which can list the metadata fields to apply the join_before_split to and whcih previously always got applied to all metadata fields. Now it's applied to any *Keywords metafields by default, as that's the metafield we have experience of that behaves differently to the others, as it stores by word instead of phrases. Tested on Diego's sample PDF. Diego has double-checked it to works on his sample PDF too, setting the split char to ; and turning on the join_before_split and leaving apply_join_before_split_to_metafields at its default of .*Keywords. File changes are strings.properties for the tooltip, the plugin introducing the option and working with it and Kathy's EXIF updates affecting cpan/File and cpan/Image.

File:
1 edited

Legend:

Unmodified
Added
Removed

  • main/trunk/greenstone2/perllib/cpan/Image/ExifTool/Writer.pl

    r24107 r34921  
    66# Notes:        Also contains some less used ExifTool functions
    77#
    8 # URL:          http://owl.phy.queensu.ca/~phil/exiftool/
     8# URL:          https://exiftool.org/
    99#
    1010# Revisions:    12/16/2004 - P. Harvey Created
    … …  
    2020sub AssembleRational($$@);
    2121sub LastInList($);
    22 sub CreateDirectory($);
     22sub CreateDirectory($$);
     23sub NextFreeTagKey($$);
    2324sub RemoveNewValueHash($$$);
    2425sub RemoveNewValuesForGroup($$);
    … …  
    2829
    2930my $loadedAllTables;    # flag indicating we loaded all tables
     31my $advFmtSelf;         # ExifTool object during evaluation of advanced formatting expr
    3032
    3133# the following is a road map of where we write each directory
    … …  
    4749    CanonVRD     => 'MakerNotes', # (so VRDOffset will get updated)
    4850    NikonCapture => 'MakerNotes', # (to allow delete by group)
     51    PhaseOne     => 'MakerNotes', # (for editing PhaseOne SensorCalibration tags)
    4952);
    5053my %exifMap = (
    … …  
    6972    ICC_Profile  => 'APP2',
    7073    FlashPix     => 'APP2',
     74    MPF          => 'APP2',
    7175    Meta         => 'APP3',
    7276    MetaIFD      => 'Meta',
    … …  
    7478    Ducky        => 'APP12',
    7579    Photoshop    => 'APP13',
     80    Adobe        => 'APP14',
    7681    IPTC         => 'Photoshop',
    7782    MakerNotes   => ['ExifIFD', 'CIFF'], # (first parent is the default)
    … …  
    8287my %dirMap = (
    8388    JPEG => \%jpegMap,
     89    EXV  => \%jpegMap,
    8490    TIFF => \%tiffMap,
    8591    ORF  => \%tiffMap,
    … …  
    8894);
    8995
     96# module names and write functions for each writable file type
     97# (defaults to "$type" and "Process$type" if not defined)
     98# - types that are handled specially will not appear in this list
     99my %writableType = (
     100    CRW => [ 'CanonRaw',    'WriteCRW' ],
     101    DR4 =>   'CanonVRD',
     102    EPS => [ 'PostScript',  'WritePS'  ],
     103    FLIF=> [ undef,         'WriteFLIF'],
     104    GIF =>   undef,
     105    ICC => [ 'ICC_Profile', 'WriteICC' ],
     106    IND =>   'InDesign',
     107    JP2 =>   'Jpeg2000',
     108    MIE =>   undef,
     109    MOV => [ 'QuickTime',   'WriteMOV' ],
     110    MRW =>   'MinoltaRaw',
     111    PDF => [ undef,         'WritePDF' ],
     112    PNG =>   undef,
     113    PPM =>   undef,
     114    PS  => [ 'PostScript',  'WritePS'  ],
     115    PSD =>   'Photoshop',
     116    RAF => [ 'FujiFilm',    'WriteRAF' ],
     117    VRD =>   'CanonVRD',
     118    X3F =>   'SigmaRaw',
     119    XMP => [ undef,         'WriteXMP' ],
     120);
     121
     122# RAW file types
     123my %rawType = (
     124   '3FR'=> 1,  CR3 => 1,  IIQ => 1,  NEF => 1,  RW2 => 1,
     125    ARQ => 1,  CRW => 1,  K25 => 1,  NRW => 1,  RWL => 1,
     126    ARW => 1,  DCR => 1,  KDC => 1,  ORF => 1,  SR2 => 1,
     127    ARW => 1,  ERF => 1,  MEF => 1,  PEF => 1,  SRF => 1,
     128    CR2 => 1,  FFF => 1,  MOS => 1,  RAW => 1,  SRW => 1,
     129);
     130
    90131# groups we are allowed to delete
    91132# Notes:
    … …  
    93134# 2) any dependencies must be added to %excludeGroups
    94135my @delGroups = qw(
    95     AFCP CanonVRD CIFF Ducky EXIF ExifIFD File FlashPix FotoStation GlobParamIFD
    96     GPS ICC_Profile IFD0 IFD1 InteropIFD IPTC JFIF MakerNotes Meta MetaIFD MIE
    97     NikonCapture PDF PDF-update PhotoMechanic Photoshop PNG PrintIM RMETA RSRC
    98     SubIFD Trailer XML XML-* XMP XMP-*
     136    Adobe AFCP APP0 APP1 APP2 APP3 APP4 APP5 APP6 APP7 APP8 APP9 APP10 APP11
     137    APP12 APP13 APP14 APP15 CanonVRD CIFF Ducky EXIF ExifIFD File FlashPix
     138    FotoStation GlobParamIFD GPS ICC_Profile IFD0 IFD1 Insta360 InteropIFD IPTC
     139    ItemList JFIF Jpeg2000 Keys MakerNotes Meta MetaIFD MIE MPF NikonCapture PDF
     140    PDF-update PhotoMechanic Photoshop PNG PNG-pHYs PrintIM QuickTime RMETA RSRC
     141    SubIFD Trailer UserData XML XML-* XMP XMP-*
    99142);
     143# family 2 group names that we can delete
     144my @delGroup2 = qw(
     145    Audio Author Camera Document ExifTool Image Location Other Preview Printing
     146    Time Video
     147);
     148# Extra groups to delete when deleting another group
     149my %delMore = (
     150    QuickTime => [ qw(ItemList UserData Keys) ],
     151    XMP => [ 'XMP-*' ],
     152    XML => [ 'XML-*' ],
     153);
     154
     155# family 0 groups where directories should never be deleted
     156my %permanentDir = ( QuickTime => 1 );
     157
     158# lookup for all valid family 2 groups (lower case)
     159my %family2groups = map { lc $_ => 1 } @delGroup2, 'Unknown';
     160
     161# groups we don't delete when deleting all information
     162my $protectedGroups = '(IFD1|SubIFD|InteropIFD|GlobParamIFD|PDF-update|Adobe)';
     163
    100164# other group names of new tag values to remove when deleting an entire group
    101165my %removeGroups = (
    … …  
    125189    PhotoMechanic=> [ 'Trailer' ],
    126190    MIE          => [ 'Trailer' ],
     191    QuickTime    => [ qw(ItemList UserData Keys) ],
     192);
     193# translate (lower case) wanted group when writing for tags where group name may change
     194my %translateWantGroup = (
     195    ciff  => 'canonraw',
    127196);
    128197# group names to translate for writing
    129198my %translateWriteGroup = (
    130     EXIF => 'ExifIFD',
    131     Meta => 'MetaIFD',
    132     File => 'Comment',
    133     MIE  => 'MIE',
     199    EXIF  => 'ExifIFD',
     200    Meta  => 'MetaIFD',
     201    File  => 'Comment',
     202    # any entry in this table causes the write group to be set from the
     203    # tag information instead of whatever the user specified...
     204    MIE   => 'MIE',
     205    APP14 => 'APP14',
    134206);
    135 # names of valid EXIF and Meta directories:
     207# names of valid EXIF and Meta directories (lower case keys):
    136208my %exifDirs = (
    137209    gps          => 'GPS',
    … …  
    140212    globparamifd => 'GlobParamIFD',
    141213    interopifd   => 'InteropIFD',
    142     makernotes   => 'MakerNotes',
    143214    previewifd   => 'PreviewIFD', # (in MakerNotes)
    144215    metaifd      => 'MetaIFD', # Kodak APP3 Meta
     216    makernotes   => 'MakerNotes',
    145217);
     218# valid family 0 groups when WriteGroup is set to "All"
     219my %allFam0 = (
     220    exif         => 1,
     221    makernotes   => 1,
     222);
     223
     224my @writableMacOSTags = qw(
     225    FileCreateDate MDItemFinderComment MDItemFSCreationDate MDItemFSLabel MDItemUserTags
     226    XAttrQuarantine
     227);
     228
    146229# min/max values for integer formats
    147230my %intRange = (
    … …  
    153236    'int32u' => [0, 0xffffffff],
    154237    'int32s' => [-0x80000000, 0x7fffffff],
     238    'int64u' => [0, 18446744073709551615],
     239    'int64s' => [-9223372036854775808, 9223372036854775807],
    155240);
    156241# lookup for file types with block-writable EXIF
    157 my %blockExifTypes = ( JPEG=>1, PNG=>1, JP2=>1, MIE=>1, EXIF=>1 );
     242my %blockExifTypes = map { $_ => 1 } qw(JPEG PNG JP2 MIE EXIF FLIF MOV MP4);
    158243
    159244my $maxSegmentLen = 0xfffd;     # maximum length of data in a JPEG segment
    … …  
    164249
    165250# printConv hash keys to ignore when doing reverse lookup
    166 my %ignorePrintConv = ( OTHER => 1, BITMASK => 1, Notes => 1 );
     251my %ignorePrintConv = map { $_ => 1 } qw(OTHER BITMASK Notes);
    167252
    168253#------------------------------------------------------------------------------
    … …  
    175260#           Type => PrintConv, ValueConv or Raw - specifies value type
    176261#           AddValue => true to add to list of existing values instead of overwriting
    177 #           DelValue => true to delete this existing value value from a list
     262#           DelValue => true to delete this existing value value from a list, or
     263#                       or doing a conditional delete, or to shift a time value
    178264#           Group => family 0 or 1 group name (case insensitive)
    179265#           Replace => 0, 1 or 2 - overwrite previous new values (2=reset)
    … …  
    182268#           EditGroup => true to only edit existing groups (don't create new group)
    183269#           Shift => undef, 0, +1 or -1 - shift value if possible
     270#           NoFlat => treat flattened tags as 'unsafe'
    184271#           NoShortcut => true to prevent looking up shortcut tags
     272#           ProtectSaved => protect existing new values with a save count greater than this
     273#           IgnorePermanent => ignore attempts to delete a permanent tag
    185274#           CreateGroups => [internal use] createGroups hash ref from related tags
    186275#           ListOnly => [internal use] set only list or non-list tags
    187276#           SetTags => [internal use] hash ref to return tagInfo refs of set tags
     277#           Sanitized => [internal use] set to avoid double-sanitizing the value
    188278# Returns: number of tags set (plus error string in list context)
    189279# Notes: For tag lists (like Keywords), call repeatedly with the same tag name for
    190280#        each value in the list.  Internally, the new information is stored in
    191 #        the following members of the $self->{NEW_VALUE}{$tagInfo} hash:
     281#        the following members of the $$self{NEW_VALUE}{$tagInfo} hash:
    192282#           TagInfo - tag info ref
    193 #           DelValue - list ref for values to delete
    194 #           Value - list ref for values to add
    195 #           IsCreating - must be set for the tag to be added, otherwise just
    196 #                        changed if it already exists.  Set to 2 to not create group
     283#           DelValue - list ref for raw values to delete
     284#           Value - list ref for raw values to add (not defined if deleting the tag)
     285#           IsCreating - must be set for the tag to be added for the standard file types,
     286#                        otherwise just changed if it already exists.  This may be
     287#                        overridden for file types with a PREFERRED metadata type.
     288#                        Set to 2 to create individual tags but not new groups
     289#           EditOnly - flag set if tag should never be created (regardless of file type).
     290#                      If this is set, then IsCreating must be false
     291#           CreateOnly - flag set if creating only (never edit existing tag)
    197292#           CreateGroups - hash of all family 0 group names where tag may be created
    198293#           WriteGroup - group name where information is being written (correct case)
    199294#           WantGroup - group name as specified in call to function (case insensitive)
    200295#           Next - pointer to next new value hash (if more than one)
    201 #           Self - ExifTool object reference
     296#           NoReplace - set if value was created with Replace=0
     297#           AddBefore - number of list items added by a subsequent Replace=0 call
     298#           IsNVH - Flag indicating this is a new value hash
    202299#           Shift - shift value
     300#           Save - counter used by SaveNewValues()/RestoreNewValues()
    203301#           MAKER_NOTE_FIXUP - pointer to fixup if necessary for a maker note value
    204302sub SetNewValue($;$$%)
    … …  
    206304    local $_;
    207305    my ($self, $tag, $value, %options) = @_;
    208     my ($err, $tagInfo);
    209     my $verbose = $self->{OPTIONS}{Verbose};
    210     my $out = $self->{OPTIONS}{TextOut};
     306    my ($err, $tagInfo, $family);
     307    my $verbose = $$self{OPTIONS}{Verbose};
     308    my $out = $$self{OPTIONS}{TextOut};
    211309    my $protected = $options{Protected} || 0;
    212310    my $listOnly = $options{ListOnly};
    213311    my $setTags = $options{SetTags};
     312    my $noFlat = $options{NoFlat};
    214313    my $numSet = 0;
    215314
    216315    unless (defined $tag) {
    217         # remove any existing set values
    218         delete $self->{NEW_VALUE};
    219         $self->{DEL_GROUP} = { };
    220         $verbose > 1 and print $out "Cleared new values\n";
     316        delete $$self{NEW_VALUE};
     317        $$self{SAVE_COUNT} = 0;
     318        $$self{DEL_GROUP} = { };
    221319        return 1;
    222320    }
    … …  
    224322    if (ref $value) {
    225323        if (ref $value eq 'ARRAY') {
    226             # (since value is an ARRAY, it will have more than one entry)
    227             # set all list-type tags first
    228             my $replace = $options{Replace};
    229             foreach (@$value) {
    230                 my ($n, $e) = SetNewValue($self, $tag, $_, %options, ListOnly => 1);
    231                 $err = $e if $e;
    232                 $numSet += $n;
    233                 delete $options{Replace}; # don't replace earlier values in list
    234             }
    235             # and now set only non-list tags
    236             $value = join $self->{OPTIONS}{ListSep}, @$value;
    237             $options{Replace} = $replace;
    238             $listOnly = $options{ListOnly} = 0;
     324            # value is an ARRAY so it may have more than one entry
     325            # - set values both separately and as a combined string if there are more than one
     326            if (@$value > 1) {
     327                # set all list-type tags first
     328                my $replace = $options{Replace};
     329                my $noJoin;
     330                foreach (@$value) {
     331                    $noJoin = 1 if ref $_;
     332                    my ($n, $e) = SetNewValue($self, $tag, $_, %options, ListOnly => 1);
     333                    $err = $e if $e;
     334                    $numSet += $n;
     335                    delete $options{Replace}; # don't replace earlier values in list
     336                }
     337                return $numSet if $noJoin;  # don't join if list contains objects
     338                # and now set only non-list tags
     339                $value = join $$self{OPTIONS}{ListSep}, @$value;
     340                $options{Replace} = $replace;
     341                $listOnly = $options{ListOnly} = 0;
     342            } else {
     343                $value = $$value[0];
     344                $value = $$value if ref $value eq 'SCALAR'; # (handle single scalar ref in a list)
     345            }
    239346        } elsif (ref $value eq 'SCALAR') {
    240347            $value = $$value;
    … …  
    243350    # un-escape as necessary and make sure the Perl UTF-8 flag is OFF for the value
    244351    # if perl is 5.6 or greater (otherwise our byte manipulations get corrupted!!)
    245     $self->Sanitize(\$value) if defined $value and not ref $value;
     352    $self->Sanitize(\$value) if defined $value and not ref $value and not $options{Sanitized};
    246353
    247354    # set group name in options if specified
    248     if ($tag =~ /(.*):(.+)/) {
    249         $options{Group} = $1 if $1 ne '*' and lc($1) ne 'all';
    250         $tag = $2;
    251     }
     355    ($options{Group}, $tag) = ($1, $2) if $tag =~ /(.*):(.+)/;
     356
    252357    # allow trailing '#' for ValueConv value
    253358    $options{Type} = 'ValueConv' if $tag =~ s/#$//;
    254     # ignore leading family number if 0 or 1 specified
    255     if ($options{Group} and $options{Group} =~ /^(\d+)(.*)/ and $1 < 2) {
    256         $options{Group} = $2;
     359    my $convType = $options{Type} || ($$self{OPTIONS}{PrintConv} ? 'PrintConv' : 'ValueConv');
     360
     361    # filter value if necessary
     362    $self->Filter($$self{OPTIONS}{FilterW}, \$value) or return 0 if $convType eq 'PrintConv';
     363
     364    my (@wantGroup, $family2);
     365    my $wantGroup = $options{Group};
     366    if ($wantGroup) {
     367        foreach (split /:/, $wantGroup) {
     368            next unless length($_) and /^(\d+)?(.*)/; # separate family number and group name
     369            my ($f, $g) = ($1, $2);
     370            my $lcg = lc $g;
     371            # save group/family unless '*' or 'all'
     372            push @wantGroup, [ $f, $lcg ] unless $lcg eq '*' or $lcg eq 'all';
     373            if ($g =~ s/^ID-//i) {          # family 7 is a tag ID
     374                return 0 if defined $f and $f ne 7;
     375                $wantGroup[-1] = [ 7, $g ]; # group name with 'ID-' removed and case preserved
     376            } elsif (defined $f) {
     377                $f > 2 and return 0;        # only allow family 0, 1 or 2
     378                $family2 = 1 if $f == 2;    # set flag indicating family 2 was used
     379            } else {
     380                $family2 = 1 if $family2groups{$lcg};
     381            }
     382        }
     383        undef $wantGroup unless @wantGroup;
     384    }
     385
     386    $tag =~ s/ .*//;    # convert from tag key to tag name if necessary
     387    $tag = '*' if lc($tag) eq 'all';    # use '*' instead of 'all'
     388#
     389# handle group delete
     390#
     391    while ($tag eq '*' and not defined $value and not $family2 and @wantGroup < 2) {
     392        # set groups to delete
     393        my (@del, $grp);
     394        my $remove = ($options{Replace} and $options{Replace} > 1);
     395        if ($wantGroup) {
     396            @del = grep /^$wantGroup$/i, @delGroups unless $wantGroup =~ /^XM[LP]-\*$/i;
     397            # remove associated groups when excluding from mass delete
     398            if (@del and $remove) {
     399                # remove associated groups in other family
     400                push @del, @{$excludeGroups{$del[0]}} if $excludeGroups{$del[0]};
     401                # remove upstream groups according to JPEG map
     402                my $dirName = $del[0];
     403                my @dirNames;
     404                for (;;) {
     405                    my $parent = $jpegMap{$dirName};
     406                    if (ref $parent) {
     407                        push @dirNames, @$parent;
     408                        $parent = pop @dirNames;
     409                    }
     410                    $dirName = $parent || shift @dirNames or last;
     411                    push @del, $dirName;    # exclude this too
     412                }
     413            }
     414            # allow MIE groups to be deleted by number,
     415            # and allow any XMP family 1 group to be deleted
     416            push @del, uc($wantGroup) if $wantGroup =~ /^(MIE\d+|XM[LP]-[-\w]*\w)$/i;
     417        } else {
     418            # push all groups plus '*', except the protected groups
     419            push @del, (grep !/^$protectedGroups$/, @delGroups), '*';
     420        }
     421        if (@del) {
     422            ++$numSet;
     423            my @donegrps;
     424            my $delGroup = $$self{DEL_GROUP};
     425            foreach $grp (@del) {
     426                if ($remove) {
     427                    my $didExcl;
     428                    if ($grp =~ /^(XM[LP])(-.*)?$/) {
     429                        my $x = $1;
     430                        if ($grp eq $x) {
     431                            # exclude all related family 1 groups too
     432                            foreach (keys %$delGroup) {
     433                                next unless /^(-?)$x-/;
     434                                push @donegrps, $_ unless $1;
     435                                delete $$delGroup{$_};
     436                            }
     437                        } elsif ($$delGroup{"$x-*"} and not $$delGroup{"-$grp"}) {
     438                            # must also exclude XMP or XML to prevent bulk delete
     439                            if ($$delGroup{$x}) {
     440                                push @donegrps, $x;
     441                                delete $$delGroup{$x};
     442                            }
     443                            # flag XMP/XML family 1 group for exclusion with leading '-'
     444                            $$delGroup{"-$grp"} = 1;
     445                            $didExcl = 1;
     446                        }
     447                    }
     448                    if (exists $$delGroup{$grp}) {
     449                        delete $$delGroup{$grp};
     450                    } else {
     451                        next unless $didExcl;
     452                    }
     453                } else {
     454                    $$delGroup{$grp} = 1;
     455                    # add extra groups to delete if necessary
     456                    if ($delMore{$grp}) {
     457                        $$delGroup{$_} = 1, push @donegrps, $_ foreach @{$delMore{$grp}};
     458                    }
     459                    # remove all of this group from previous new values
     460                    $self->RemoveNewValuesForGroup($grp);
     461                }
     462                push @donegrps, $grp;
     463            }
     464            if ($verbose > 1 and @donegrps) {
     465                @donegrps = sort @donegrps;
     466                my $msg = $remove ? 'Excluding from deletion' : 'Deleting tags in';
     467                print $out "  $msg: @donegrps\n";
     468            }
     469        } elsif (grep /^$wantGroup$/i, @delGroup2) {
     470            last;   # allow tags to be deleted by group2 name
     471        } else {
     472            $err = "Not a deletable group: $wantGroup";
     473        }
     474        # all done
     475        return ($numSet, $err) if wantarray;
     476        $err and warn "$err\n";
     477        return $numSet;
     478    }
     479
     480    # initialize write/create flags
     481    my $createOnly;
     482    my $editOnly = $options{EditOnly};
     483    my $editGroup = $options{EditGroup};
     484    my $writeMode = $$self{OPTIONS}{WriteMode};
     485    if ($writeMode ne 'wcg') {
     486        $createOnly = 1 if $writeMode !~ /w/i;  # don't write existing tags
     487        if ($writeMode !~ /c/i) {
     488            return 0 if $createOnly;    # nothing to do unless writing existing tags
     489            $editOnly = 1;              # don't create new tags
     490        } elsif ($writeMode !~ /g/i) {
     491            $editGroup = 1;             # don't create new groups
     492        }
     493    }
     494    my ($ifdName, $mieGroup, $movGroup, $fg);
     495    # set family 1 group names
     496    foreach $fg (@wantGroup) {
     497        next if defined $$fg[0] and $$fg[0] != 1;
     498        $_ = $$fg[1];
     499        # set $ifdName if this group is a valid IFD or SubIFD name
     500        my $grpName;
     501        if (/^IFD(\d+)$/i) {
     502            $grpName = $ifdName = "IFD$1";
     503        } elsif (/^SubIFD(\d+)$/i) {
     504            $grpName = $ifdName = "SubIFD$1";
     505        } elsif (/^Version(\d+)$/i) {
     506            $grpName = $ifdName = "Version$1"; # Sony IDC VersionIFD
     507        } elsif ($exifDirs{$_}) {
     508            $grpName = $exifDirs{$_};
     509            $ifdName = $grpName unless $ifdName and $allFam0{$_};
     510        } elsif ($allFam0{$_}) {
     511            $grpName = $allFam0{$_};
     512        } elsif (/^Track(\d+)$/i) {
     513            $grpName = $movGroup = "Track$1";  # QuickTime track
     514        } elsif (/^MIE(\d*-?)(\w+)$/i) {
     515            $grpName = $mieGroup = "MIE$1" . ucfirst(lc($2));
     516        } elsif (not $ifdName and /^XMP\b/i) {
     517            # must load XMP table to set group1 names
     518            my $table = GetTagTable('Image::ExifTool::XMP::Main');
     519            my $writeProc = $$table{WRITE_PROC};
     520            if ($writeProc) {
     521                no strict 'refs';
     522                &$writeProc();
     523            }
     524        }
     525        # fix case for known groups
     526        $wantGroup =~ s/$grpName/$grpName/i if $grpName and $grpName ne $_;
    257527    }
    258528#
    259529# get list of tags we want to set
    260530#
    261     my $wantGroup = $options{Group};
    262     $tag =~ s/ .*//;    # convert from tag key to tag name if necessary
     531    my $origTag = $tag;
    263532    my @matchingTags = FindTagInfo($tag);
    264533    until (@matchingTags) {
    265         if ($tag eq '*' or lc($tag) eq 'all') {
    266             # set groups to delete
    267             if (defined $value) {
    268                 $err = "Can't set value for all tags";
    269             } else {
    270                 my (@del, $grp);
    271                 my $remove = ($options{Replace} and $options{Replace} > 1);
    272                 if ($wantGroup) {
    273                     @del = grep /^$wantGroup$/i, @delGroups unless $wantGroup =~ /^XM[LP]-\*$/i;
    274                     # remove associated groups when excluding from mass delete
    275                     if (@del and $remove) {
    276                         # remove associated groups in other family
    277                         push @del, @{$excludeGroups{$del[0]}} if $excludeGroups{$del[0]};
    278                         # remove upstream groups according to JPEG map
    279                         my $dirName = $del[0];
    280                         my @dirNames;
    281                         for (;;) {
    282                             my $parent = $jpegMap{$dirName};
    283                             if (ref $parent) {
    284                                 push @dirNames, @$parent;
    285                                 $parent = pop @dirNames;
    286                             }
    287                             $dirName = $parent || shift @dirNames or last;
    288                             push @del, $dirName;    # exclude this too
    289                         }
    290                     }
    291                     # allow MIE groups to be deleted by number,
    292                     # and allow any XMP family 1 group to be deleted
    293                     push @del, uc($wantGroup) if $wantGroup =~ /^(MIE\d+|XM[LP]-[-\w]+)$/i;
     534        my $langCode;
     535        # allow language suffix of form "-en_CA" or "-<rfc3066>" on tag name
     536        if ($tag =~ /^([?*\w]+)-([a-z]{2})(_[a-z]{2})$/i or # MIE
     537            $tag =~ /^([?*\w]+)-([a-z]{2,3}|[xi])(-[a-z\d]{2,8}(-[a-z\d]{1,8})*)?$/i) # XMP/PNG/QuickTime
     538        {
     539            $tag = $1;
     540            # normalize case of language codes
     541            $langCode = lc($2);
     542            $langCode .= (length($3) == 3 ? uc($3) : lc($3)) if $3;
     543            my @newMatches = FindTagInfo($tag);
     544            foreach $tagInfo (@newMatches) {
     545                # only allow language codes in tables which support them
     546                next unless $$tagInfo{Table};
     547                my $langInfoProc = $$tagInfo{Table}{LANG_INFO} or next;
     548                my $langInfo = &$langInfoProc($tagInfo, $langCode);
     549                push @matchingTags, $langInfo if $langInfo;
     550            }
     551            last if @matchingTags;
     552        } elsif (not $options{NoShortcut}) {
     553            # look for a shortcut or alias
     554            require Image::ExifTool::Shortcuts;
     555            my ($match) = grep /^\Q$tag\E$/i, keys %Image::ExifTool::Shortcuts::Main;
     556            undef $err;
     557            if ($match) {
     558                $options{NoShortcut} = $options{Sanitized} = 1;
     559                foreach $tag (@{$Image::ExifTool::Shortcuts::Main{$match}}) {
     560                    my ($n, $e) = $self->SetNewValue($tag, $value, %options);
     561                    $numSet += $n;
     562                    $e and $err = $e;
     563                }
     564                undef $err if $numSet;  # no error if any set successfully
     565                return ($numSet, $err) if wantarray;
     566                $err and warn "$err\n";
     567                return $numSet;
     568            }
     569        }
     570        unless ($listOnly) {
     571            if (not TagExists($tag)) {
     572                if ($tag =~ /^[-\w*?]+$/) {
     573                    my $pre = $wantGroup ? $wantGroup . ':' : '';
     574                    $err = "Tag '$pre${origTag}' is not defined";
     575                    $err .= ' or has a bad language code' if $origTag =~ /-/;
    294576                } else {
    295                     # push all groups plus '*', except IFD1 and a few others
    296                     push @del, (grep !/^(IFD1|SubIFD|InteropIFD|GlobParamIFD|PDF-update)$/, @delGroups), '*';
    297                 }
    298                 if (@del) {
    299                     ++$numSet;
    300                     my @donegrps;
    301                     my $delGroup = $self->{DEL_GROUP};
    302                     foreach $grp (@del) {
    303                         if ($remove) {
    304                             my $didExcl;
    305                             if ($grp =~ /^(XM[LP])(-.*)?$/) {
    306                                 my $x = $1;
    307                                 if ($grp eq $x) {
    308                                     # exclude all related family 1 groups too
    309                                     foreach (keys %$delGroup) {
    310                                         next unless /^-?$x-/;
    311                                         push @donegrps, $_ if /^$x/;
    312                                         delete $$delGroup{$_};
    313                                     }
    314                                 } elsif ($$delGroup{"$x-*"} and not $$delGroup{"-$grp"}) {
    315                                     # must also exclude XMP or XML to prevent bulk delete
    316                                     if ($$delGroup{$x}) {
    317                                         push @donegrps, $x;
    318                                         delete $$delGroup{$x};
    319                                     }
    320                                     # flag XMP/XML family 1 group for exclusion with leading '-'
    321                                     $$delGroup{"-$grp"} = 1;
    322                                     $didExcl = 1;
    323                                 }
    324                             }
    325                             if (exists $$delGroup{$grp}) {
    326                                 delete $$delGroup{$grp};
    327                             } else {
    328                                 next unless $didExcl;
    329                             }
    330                         } else {
    331                             $$delGroup{$grp} = 1;
    332                             # add flag for XMP/XML family 1 groups if deleting all XMP
    333                             if ($grp =~ /^XM[LP]$/) {
    334                                 $$delGroup{"$grp-*"} = 1;
    335                                 push @donegrps, "$grp-*";
    336                             }
    337                             # remove all of this group from previous new values
    338                             $self->RemoveNewValuesForGroup($grp);
    339                         }
    340                         push @donegrps, $grp;
    341                     }
    342                     if ($verbose > 1 and @donegrps) {
    343                         @donegrps = sort @donegrps;
    344                         my $msg = $remove ? 'Excluding from deletion' : 'Deleting tags in';
    345                         print $out "  $msg: @donegrps\n";
    346                     }
    347                 } else {
    348                     $err = "Not a deletable group: $wantGroup";
    349                 }
    350             }
    351         } else {
    352             my $origTag = $tag;
    353             my $langCode;
    354             # allow language suffix of form "-en_CA" or "-<rfc3066>" on tag name
    355             if ($tag =~ /^(\w+)-([a-z]{2})(_[a-z]{2})$/i or # MIE
    356                 $tag =~ /^(\w+)-([a-z]{2,3}|[xi])(-[a-z\d]{2,8}(-[a-z\d]{1,8})*)?$/i) # XMP/PNG
    357             {
    358                 $tag = $1;
    359                 # normalize case of language codes
    360                 $langCode = lc($2);
    361                 $langCode .= (length($3) == 3 ? uc($3) : lc($3)) if $3;
    362                 my @newMatches = FindTagInfo($tag);
    363                 foreach $tagInfo (@newMatches) {
    364                     # only allow language codes in tables which support them
    365                     next unless $$tagInfo{Table};
    366                     my $langInfoProc = $tagInfo->{Table}{LANG_INFO} or next;
    367                     my $langInfo = &$langInfoProc($tagInfo, $langCode);
    368                     push @matchingTags, $langInfo if $langInfo;
    369                 }
    370                 last if @matchingTags;
    371             } else {
    372                 # look for a shortcut or alias
    373                 require Image::ExifTool::Shortcuts;
    374                 my ($match) = grep /^\Q$tag\E$/i, keys %Image::ExifTool::Shortcuts::Main;
    375                 undef $err;
    376                 if ($match and not $options{NoShortcut}) {
    377                     if (@{$Image::ExifTool::Shortcuts::Main{$match}} == 1) {
    378                         $tag = $Image::ExifTool::Shortcuts::Main{$match}[0];
    379                         @matchingTags = FindTagInfo($tag);
    380                         last if @matchingTags;
    381                     } else {
    382                         $options{NoShortcut} = 1;
    383                         foreach $tag (@{$Image::ExifTool::Shortcuts::Main{$match}}) {
    384                             my ($n, $e) = $self->SetNewValue($tag, $value, %options);
    385                             $numSet += $n;
    386                             $e and $err = $e;
    387                         }
    388                         undef $err if $numSet;  # no error if any set successfully
    389                         return ($numSet, $err) if wantarray;
    390                         $err and warn "$err\n";
    391                         return $numSet;
    392                     }
    393                 }
    394             }
    395             if (not TagExists($tag)) {
    396                 $err = "Tag '$origTag' does not exist";
    397                 $err .= ' or has a bad language code' if $origTag =~ /-/;
     577                    $err = "Invalid tag name '${tag}'";
     578                    $err .= " (remove the leading '\$')" if $tag =~ /^\$/;
     579                }
    398580            } elsif ($langCode) {
    399                 $err = "Tag '$tag' does not support alternate languages";
     581                $err = "Tag '${tag}' does not support alternate languages";
    400582            } elsif ($wantGroup) {
    401583                $err = "Sorry, $wantGroup:$origTag doesn't exist or isn't writable";
    … …  
    412594    # get group name that we're looking for
    413595    my $foundMatch = 0;
    414     my ($ifdName, $mieGroup);
    415     if ($wantGroup) {
    416         # set $ifdName if this group is a valid IFD or SubIFD name
    417         if ($wantGroup =~ /^IFD(\d+)$/i) {
    418             $ifdName = "IFD$1";
    419         } elsif ($wantGroup =~ /^SubIFD(\d+)$/i) {
    420             $ifdName = "SubIFD$1";
    421         } elsif ($wantGroup =~ /^Version(\d+)$/i) {
    422             $ifdName = "Version$1"; # Sony IDC VersionIFD
    423         } elsif ($wantGroup =~ /^MIE(\d*-?)(\w+)$/i) {
    424             $mieGroup = "MIE$1" . ucfirst(lc($2));
    425         } else {
    426             $ifdName = $exifDirs{lc($wantGroup)};
    427             if (not $ifdName and $wantGroup =~ /^XMP\b/i) {
    428                 # must load XMP table to set group1 names
    429                 my $table = GetTagTable('Image::ExifTool::XMP::Main');
    430                 my $writeProc = $table->{WRITE_PROC};
    431                 $writeProc and &$writeProc();
    432             }
    433         }
    434     }
    435596#
    436597# determine the groups for all tags found, and the tag with
    437598# the highest priority group
    438599#
    439     my (@tagInfoList, @writeAlsoList, %writeGroup, %preferred, %tagPriority, $avoid, $wasProtected);
    440     my $highestPriority = -1;
    441     foreach $tagInfo (@matchingTags) {
    442         $tag = $tagInfo->{Name};    # set tag so warnings will use proper case
    443         my ($writeGroup, $priority);
     600    my (@tagInfoList, @writeAlsoList, %writeGroup, %preferred, %tagPriority);
     601    my (%avoid, $wasProtected, $noCreate, %highestPriority, %highestQT);
     602
     603TAG: foreach $tagInfo (@matchingTags) {
     604        $tag = $$tagInfo{Name};     # get tag name for warnings
     605        my $lcTag = lc $tag;        # get lower-case tag name for use in variables
     606        # initialize highest priority if we are starting a new tag
     607        $highestPriority{$lcTag} = -999 unless defined $highestPriority{$lcTag};
     608        my ($priority, $writeGroup);
     609        my $prfTag = defined $$tagInfo{Preferred} ? $$tagInfo{Preferred} : $$tagInfo{Table}{PREFERRED};
    444610        if ($wantGroup) {
    445             my $lcWant = lc($wantGroup);
    446             # only set tag in specified group
    447             $writeGroup = $self->GetGroup($tagInfo, 0);
    448             unless (lc($writeGroup) eq $lcWant) {
    449                 if ($writeGroup eq 'EXIF' or $writeGroup eq 'SonyIDC') {
    450                     next unless $ifdName;
    451                     # can't yet write PreviewIFD tags
    452                     $ifdName eq 'PreviewIFD' and ++$foundMatch, next;
    453                     $writeGroup = $ifdName;  # write to the specified IFD
    454                 } elsif ($writeGroup eq 'MIE') {
    455                     next unless $mieGroup;
     611            # a WriteGroup of All is special
     612            my $wgAll = ($$tagInfo{WriteGroup} and $$tagInfo{WriteGroup} eq 'All');
     613            my @grp = $self->GetGroup($tagInfo);
     614            my $hiPri = 1000;
     615            foreach $fg (@wantGroup) {
     616                my ($fam, $lcWant) = @$fg;
     617                $lcWant = $translateWantGroup{$lcWant} if $translateWantGroup{$lcWant};
     618                # only set tag in specified group
     619                # bump priority of preferred tag
     620                $hiPri += $prfTag if $prfTag;
     621                if (not defined $fam) {
     622                    if ($lcWant eq lc $grp[0]) {
     623                        # don't go to more general write group of "All"
     624                        # if something more specific was wanted
     625                        $writeGroup = $grp[0] if $wgAll and not $writeGroup;
     626                        next;
     627                    }
     628                    next if $lcWant eq lc $grp[2];
     629                } elsif ($fam == 7) {
     630                    next if IsSameID($$tagInfo{TagID}, $lcWant);
     631                } elsif ($fam != 1 and not $$tagInfo{AllowGroup}) {
     632                    next if $lcWant eq lc $grp[$fam];
     633                    if ($wgAll and not $fam and $allFam0{$lcWant}) {
     634                        $writeGroup or $writeGroup = $allFam0{$lcWant};
     635                        next;
     636                    }
     637                    next TAG;   # wrong group
     638                }
     639                # handle family 1 groups specially
     640                if ($grp[0] eq 'EXIF' or $grp[0] eq 'SonyIDC' or $wgAll) {
     641                    unless ($ifdName and $lcWant eq lc $ifdName) {
     642                        next TAG unless $wgAll and not $fam and $allFam0{$lcWant};
     643                        $writeGroup = $allFam0{$lcWant} unless $writeGroup;
     644                        next;
     645                    }
     646                    next TAG if $wgAll and $allFam0{$lcWant} and $fam;
     647                    # can't yet write PreviewIFD tags (except for image)
     648                    $lcWant eq 'PreviewIFD' and ++$foundMatch, next TAG;
     649                    $writeGroup = $ifdName; # write to the specified IFD
     650                } elsif ($grp[0] eq 'QuickTime') {
     651                    if ($grp[1] eq 'Track#') {
     652                        next TAG unless $movGroup and $lcWant eq lc($movGroup);
     653                        $writeGroup = $movGroup;
     654                    } else {
     655                        my $grp = $$tagInfo{Table}{WRITE_GROUP};
     656                        next TAG unless $grp and $lcWant eq lc $grp;
     657                        $writeGroup = $grp;
     658                    }
     659                } elsif ($grp[0] eq 'MIE') {
     660                    next TAG unless $mieGroup and $lcWant eq lc($mieGroup);
    456661                    $writeGroup = $mieGroup; # write to specific MIE group
    457662                    # set specific write group with document number if specified
    458                     if ($writeGroup =~ /^MIE\d+$/ and $tagInfo->{Table}{WRITE_GROUP}) {
    459                         $writeGroup = $tagInfo->{Table}{WRITE_GROUP};
     663                    if ($writeGroup =~ /^MIE\d+$/ and $$tagInfo{Table}{WRITE_GROUP}) {
     664                        $writeGroup = $$tagInfo{Table}{WRITE_GROUP};
    460665                        $writeGroup =~ s/^MIE/$mieGroup/;
    461666                    }
    462                 } elsif (not $$tagInfo{AllowGroup} or $wantGroup !~ /^$$tagInfo{AllowGroup}$/i) {
     667                } elsif (not $$tagInfo{AllowGroup} or $lcWant !~ /^$$tagInfo{AllowGroup}$/i) {
    463668                    # allow group1 name to be specified
    464                     my $grp1 = $self->GetGroup($tagInfo, 1);
    465                     unless ($grp1 and lc($grp1) eq $lcWant) {
    466                         # must also check group1 name directly in case it is different
    467                         $grp1 = $tagInfo->{Groups}{1};
    468                         next unless $grp1 and lc($grp1) eq $lcWant;
    469                     }
    470                 }
    471             }
    472             $priority = 1000;   # highest priority since group was specified
     669                    next TAG unless $lcWant eq lc $grp[1];
     670                }
     671            }
     672            $writeGroup or $writeGroup = ($$tagInfo{WriteGroup} || $$tagInfo{Table}{WRITE_GROUP} || $grp[0]);
     673            $priority = $hiPri; # highest priority since group was specified
    473674        }
    474675        ++$foundMatch;
    475676        # must do a dummy call to the write proc to autoload write package
    476677        # before checking Writable flag
    477         my $table = $tagInfo->{Table};
    478         my $writeProc = $table->{WRITE_PROC};
     678        my $table = $$tagInfo{Table};
     679        my $writeProc = $$table{WRITE_PROC};
    479680        # load source table if this was a user-defined table
    480681        if ($$table{SRC_TABLE}) {
    … …  
    482683            $writeProc = $$src{WRITE_PROC} unless $writeProc;
    483684        }
    484         next unless $writeProc and &$writeProc();
     685        {
     686            no strict 'refs';
     687            next unless $writeProc and &$writeProc();
     688        }
    485689        # must still check writable flags in case of UserDefined tags
    486         my $writable = $tagInfo->{Writable};
    487         next unless $writable or ($table->{WRITABLE} and
     690        my $writable = $$tagInfo{Writable};
     691        next unless $writable or ($$table{WRITABLE} and
    488692            not defined $writable and not $$tagInfo{SubDirectory});
    489693        # set specific write group (if we didn't already)
    490         if (not $writeGroup or $translateWriteGroup{$writeGroup}) {
     694        if (not $writeGroup or ($translateWriteGroup{$writeGroup} and
     695            (not $$tagInfo{WriteGroup} or $$tagInfo{WriteGroup} ne 'All')))
     696        {
    491697            # use default write group
    492             $writeGroup = $tagInfo->{WriteGroup} || $tagInfo->{Table}{WRITE_GROUP};
     698            $writeGroup = $$tagInfo{WriteGroup} || $$tagInfo{Table}{WRITE_GROUP};
    493699            # use group 0 name if no WriteGroup specified
    494700            my $group0 = $self->GetGroup($tagInfo, 0);
    … …  
    496702            # get priority for this group
    497703            unless ($priority) {
    498                 $priority = $self->{WRITE_PRIORITY}{lc($writeGroup)};
     704                $priority = $$self{WRITE_PRIORITY}{lc($writeGroup)};
    499705                unless ($priority) {
    500                     $priority = $self->{WRITE_PRIORITY}{lc($group0)} || 0;
    501                 }
    502             }
     706                    $priority = $$self{WRITE_PRIORITY}{lc($group0)} || 0;
     707                }
     708            }
     709            # adjust priority based on Preferred level for this tag
     710            $priority += $prfTag if $prfTag;
    503711        }
    504712        # don't write tag if protected
    505         if ($tagInfo->{Protected}) {
    506             my $prot = $tagInfo->{Protected} & ~$protected;
     713        my $prot = $$tagInfo{Protected};
     714        $prot = 1 if $noFlat and defined $$tagInfo{Flat};
     715        if ($prot) {
     716            $prot &= ~$protected;
    507717            if ($prot) {
    508718                my %lkup = ( 1=>'unsafe', 2=>'protected', 3=>'unsafe and protected');
    … …  
    510720                if ($verbose > 1) {
    511721                    my $wgrp1 = $self->GetWriteGroup1($tagInfo, $writeGroup);
    512                     print $out "Not writing $wgrp1:$tag ($wasProtected)\n";
     722                    print $out "Sorry, $wgrp1:$tag is $wasProtected for writing\n";
    513723                }
    514724                next;
    … …  
    517727        # set priority for this tag
    518728        $tagPriority{$tagInfo} = $priority;
    519         if ($priority > $highestPriority) {
    520             $highestPriority = $priority;
    521             %preferred = ( $tagInfo => 1 );
    522             $avoid = 0;
    523             ++$avoid if $$tagInfo{Avoid};
    524         } elsif ($priority == $highestPriority) {
     729        # keep track of highest priority QuickTime tag
     730        $highestQT{$lcTag} = $priority if $$table{GROUPS}{0} eq 'QuickTime' and
     731            (not defined $highestQT{$lcTag} or $highestQT{$lcTag} < $priority);
     732        if ($priority > $highestPriority{$lcTag}) {
     733            $highestPriority{$lcTag} = $priority;
     734            $preferred{$lcTag} = { $tagInfo => 1 };
     735            $avoid{$lcTag} = $$tagInfo{Avoid} ? 1 : 0;
     736        } elsif ($priority == $highestPriority{$lcTag}) {
    525737            # create all tags with highest priority
    526             $preferred{$tagInfo} = 1;
    527             ++$avoid if $$tagInfo{Avoid};
     738            $preferred{$lcTag}{$tagInfo} = 1;
     739            ++$avoid{$lcTag} if $$tagInfo{Avoid};
    528740        }
    529741        if ($$tagInfo{WriteAlso}) {
    … …  
    533745            push @tagInfoList, $tagInfo;
    534746        }
     747        # special case to allow override of XMP WriteGroup
     748        if ($writeGroup eq 'XMP') {
     749            my $wg = $$tagInfo{WriteGroup} || $$table{WRITE_GROUP};
     750            $writeGroup = $wg if $wg;
     751        }
    535752        $writeGroup{$tagInfo} = $writeGroup;
    536753    }
    537     # sort tag info list in reverse order of priority (higest number last)
     754    # sort tag info list in reverse order of priority (highest number last)
    538755    # so we get the highest priority error message in the end
    539756    @tagInfoList = sort { $tagPriority{$a} <=> $tagPriority{$b} } @tagInfoList;
    … …  
    541758    unshift @tagInfoList, @writeAlsoList if @writeAlsoList;
    542759
    543     # don't create tags with priority 0 if group priorities are set
    544     if ($highestPriority == 0 and %{$self->{WRITE_PRIORITY}}) {
    545         undef %preferred;
    546     }
    547     # avoid creating tags with 'Avoid' flag set if there are other alternatives
    548     if ($avoid and %preferred) {
    549         if ($avoid < scalar(keys %preferred)) {
    550             # just remove the 'Avoid' tags since there are other preferred tags
    551             foreach $tagInfo (@tagInfoList) {
    552                 delete $preferred{$tagInfo} if $$tagInfo{Avoid};
    553             }
    554         } elsif ($highestPriority < 1000) {
    555             # look for another priority tag to create instead
    556             my $nextHighest = 0;
    557             my @nextBestTags;
    558             foreach $tagInfo (@tagInfoList) {
    559                 my $priority = $tagPriority{$tagInfo} or next;
    560                 next if $priority == $highestPriority;
    561                 next if $priority < $nextHighest;
    562                 next if $$tagInfo{Avoid} or $$tagInfo{Permanent};
    563                 next if $writeGroup{$tagInfo} eq 'MakerNotes';
    564                 if ($nextHighest < $priority) {
    565                     $nextHighest = $priority;
    566                     undef @nextBestTags;
    567                 }
    568                 push @nextBestTags, $tagInfo;
    569             }
    570             if (@nextBestTags) {
    571                 # change our preferred tags to the next best tags
    572                 undef %preferred;
    573                 foreach $tagInfo (@nextBestTags) {
    574                     $preferred{$tagInfo} = 1;
     760    # check priorities for each set of tags we are writing
     761    my $lcTag;
     762    foreach $lcTag (keys %preferred) {
     763        # don't create tags with priority 0 if group priorities are set
     764        if ($preferred{$lcTag} and $highestPriority{$lcTag} == 0 and
     765            %{$$self{WRITE_PRIORITY}})
     766        {
     767            delete $preferred{$lcTag}
     768        }
     769        # avoid creating tags with 'Avoid' flag set if there are other alternatives
     770        if ($avoid{$lcTag} and $preferred{$lcTag}) {
     771            if ($avoid{$lcTag} < scalar(keys %{$preferred{$lcTag}})) {
     772                # just remove the 'Avoid' tags since there are other preferred tags
     773                foreach $tagInfo (@tagInfoList) {
     774                    next unless $lcTag eq lc $$tagInfo{Name};
     775                    delete $preferred{$lcTag}{$tagInfo} if $$tagInfo{Avoid};
     776                }
     777            } elsif ($highestPriority{$lcTag} < 1000) {
     778                # look for another priority tag to create instead
     779                my $nextHighest = 0;
     780                my @nextBestTags;
     781                foreach $tagInfo (@tagInfoList) {
     782                    next unless $lcTag eq lc $$tagInfo{Name};
     783                    my $priority = $tagPriority{$tagInfo} or next;
     784                    next if $priority == $highestPriority{$lcTag};
     785                    next if $priority < $nextHighest;
     786                    my $permanent = $$tagInfo{Permanent};
     787                    $permanent = $$tagInfo{Table}{PERMANENT} unless defined $permanent;
     788                    next if $$tagInfo{Avoid} or $permanent;
     789                    next if $writeGroup{$tagInfo} eq 'MakerNotes';
     790                    if ($nextHighest < $priority) {
     791                        $nextHighest = $priority;
     792                        undef @nextBestTags;
     793                    }
     794                    push @nextBestTags, $tagInfo;
     795                }
     796                if (@nextBestTags) {
     797                    # change our preferred tags to the next best tags
     798                    delete $preferred{$lcTag};
     799                    foreach $tagInfo (@nextBestTags) {
     800                        $preferred{$lcTag}{$tagInfo} = 1;
     801                    }
    575802                }
    576803            }
    … …  
    592819        my $writeGroup = $writeGroup{$tagInfo};
    593820        my $permanent = $$tagInfo{Permanent};
     821        $permanent = $$tagInfo{Table}{PERMANENT} unless defined $permanent;
    594822        $writeGroup eq 'MakerNotes' and $permanent = 1 unless defined $permanent;
    595823        my $wgrp1 = $self->GetWriteGroup1($tagInfo, $writeGroup);
    596         $tag = $tagInfo->{Name};    # get proper case for tag name
     824        $tag = $$tagInfo{Name};     # get tag name for warnings
     825        my $lcTag = lc $tag;
     826        my $pref = $preferred{$lcTag} || { };
    597827        my $shift = $options{Shift};
     828        my $addValue = $options{AddValue};
    598829        if (defined $shift) {
    599             # (can't currently shift List-type tags)
    600             if ($tagInfo->{Shift} and not $tagInfo->{List}) {
     830            # (can't currently shift list-type tags)
     831            my $shiftable;
     832            if ($$tagInfo{List}) {
     833                $shiftable = '';    # can add/delete but not shift
     834            } else {
     835                $shiftable = $$tagInfo{Shift};
    601836                unless ($shift) {
    602837                    # set shift according to AddValue/DelValue
    603                     $shift = 1 if $options{AddValue};
    604                     $shift = -1 if $options{DelValue};
     838                    $shift = 1 if $addValue;
     839                    # can shift a date/time with -=, but this is
     840                    # a conditional delete operation for other tags
     841                    $shift = -1 if $options{DelValue} and defined $shiftable and $shiftable eq 'Time';
    605842                }
    606843                if ($shift and (not defined $value or not length $value)) {
    … …  
    611848                    undef $shift;
    612849                }
    613             } elsif ($shift) {
     850            }
     851                # can't shift List-type tag
     852            if ((defined $shiftable and not $shiftable) and
     853                # and don't try to conditionally delete if Shift is "0"
     854                ($shift or ($shiftable eq '0' and $options{DelValue})))
     855            {
    614856                $err = "$wgrp1:$tag is not shiftable";
    615857                $verbose > 2 and print $out "$err\n";
    … …  
    620862        if (defined $val) {
    621863            # check to make sure this is a List or Shift tag if adding
    622             if ($options{AddValue} and not ($shift or $tagInfo->{List})) {
    623                 $err = "Can't add $wgrp1:$tag (not a List type)";
    624                 $verbose > 2 and print $out "$err\n";
    625                 next;
     864            if ($addValue and not ($shift or $$tagInfo{List})) {
     865                if ($addValue eq '2') {
     866                    undef $addValue;    # quietly reset this option
     867                } else {
     868                    $err = "Can't add $wgrp1:$tag (not a List type)";
     869                    $verbose > 2 and print $out "$err\n";
     870                    next;
     871                }
    626872            }
    627873            if ($shift) {
    628                 # add '+' or '-' prefix to indicate shift direction
    629                 $val = ($shift > 0 ? '+' : '-') . $val;
    630                 # check the shift for validity
    631                 require 'Image/ExifTool/Shift.pl';
    632                 my $err2 = CheckShift($tagInfo->{Shift}, $val);
    633                 if ($err2) {
    634                     $err = "$err2 for $wgrp1:$tag";
     874                if ($$tagInfo{Shift} and $$tagInfo{Shift} eq 'Time') {
     875                    # add '+' or '-' prefix to indicate shift direction
     876                    $val = ($shift > 0 ? '+' : '-') . $val;
     877                    # check the shift for validity
     878                    require 'Image/ExifTool/Shift.pl';
     879                    my $err2 = CheckShift($$tagInfo{Shift}, $val);
     880                    if ($err2) {
     881                        $err = "$err2 for $wgrp1:$tag";
     882                        $verbose > 2 and print $out "$err\n";
     883                        next;
     884                    }
     885                } elsif (IsFloat($val)) {
     886                    $val *= $shift;
     887                } else {
     888                    $err = "Shift value for $wgrp1:$tag is not a number";
    635889                    $verbose > 2 and print $out "$err\n";
    636890                    next;
    … …  
    645899            }
    646900        } elsif ($permanent) {
     901            return 0 if $options{IgnorePermanent};
    647902            # can't delete permanent tags, so set them to DelValue or empty string instead
    648903            if (defined $$tagInfo{DelValue}) {
    … …  
    652907                $val = '';
    653908            }
    654         } elsif ($options{AddValue} or $options{DelValue}) {
     909        } elsif ($addValue or $options{DelValue}) {
    655910            $err = "No value to add or delete in $wgrp1:$tag";
    656911            $verbose > 2 and print $out "$err\n";
    657912            next;
    658913        } else {
    659             if ($tagInfo->{DelCheck}) {
     914            if ($$tagInfo{DelCheck}) {
    660915                #### eval DelCheck ($self, $tagInfo, $wantGroup)
    661                 my $err2 = eval $tagInfo->{DelCheck};
     916                my $err2 = eval $$tagInfo{DelCheck};
    662917                $@ and warn($@), $err2 = 'Error evaluating DelCheck';
    663                 if ($err2) {
     918                if (defined $err2) {
     919                    # (allow other tags to be set using DelCheck as a hook)
     920                    $err2 or goto WriteAlso; # GOTO!
    664921                    $err2 .= ' for' unless $err2 =~ /delete$/;
    665922                    $err = "$err2 $wgrp1:$tag";
    666923                    $verbose > 2 and print $out "$err\n";
    667924                    next;
    668                 } elsif (defined $err2) {
    669                     ++$numSet;  # (allow other tags to be set using DelCheck as a hook)
    670                     goto WriteAlso;
    671                 }
     925                }
     926            }
     927            # set group delete flag if this tag represents an entire group
     928            if ($$tagInfo{DelGroup} and not $options{DelValue}) {
     929                my @del = ( $tag );
     930                $$self{DEL_GROUP}{$tag} = 1;
     931                # delete extra groups if necessary
     932                if ($delMore{$tag}) {
     933                    $$self{DEL_GROUP}{$_} = 1, push(@del,$_) foreach @{$delMore{$tag}};
     934                }
     935                # remove all of this group from previous new values
     936                $self->RemoveNewValuesForGroup($tag);
     937                $verbose and print $out "  Deleting tags in: @del\n";
     938                ++$numSet;
     939                next;
    672940            }
    673941            $noConv = 1;    # value is not defined, so don't do conversion
    … …  
    677945        unless ($noConv) {
    678946            # set default conversion type used by ConvInv() and CHECK_PROC routines
    679             $$self{ConvType} = $options{Type} || ($self->{OPTIONS}{PrintConv} ? 'PrintConv' : 'ValueConv');
     947            $$self{ConvType} = $convType;
    680948            my $e;
    681             ($val,$e) = $self->ConvInv($val, $tagInfo, $tag, $wgrp1, $$self{ConvType}, $wantGroup);
     949            ($val,$e) = $self->ConvInv($val,$tagInfo,$tag,$wgrp1,$$self{ConvType},$wantGroup);
    682950            if (defined $e) {
    683                 if ($e) {
    684                     ($err = $e) =~ s/\$wgrp1/$wgrp1/g;
    685                 } else {
    686                     ++$numSet;  # an empty error string causes error to be ignored
    687                 }
     951                # empty error string causes error to be ignored without setting the value
     952                $e or goto WriteAlso; # GOTO!
     953                $err = $e;
    688954            }
    689955        }
    … …  
    694960            $val = 'xxx never delete xxx';
    695961        }
    696         $self->{NEW_VALUE} or $self->{NEW_VALUE} = { };
     962        $$self{NEW_VALUE} or $$self{NEW_VALUE} = { };
    697963        if ($options{Replace}) {
    698964            # delete the previous new value
    699             $self->GetNewValueHash($tagInfo, $writeGroup, 'delete');
     965            $self->GetNewValueHash($tagInfo, $writeGroup, 'delete', $options{ProtectSaved});
    700966            # also delete related tag previous new values
    701967            if ($$tagInfo{WriteAlso}) {
    702                 my $wtag;
     968                my ($wgrp, $wtag);
     969                if ($$tagInfo{WriteGroup} and $$tagInfo{WriteGroup} eq 'All' and $writeGroup) {
     970                    $wgrp = $writeGroup . ':';
     971                } else {
     972                    $wgrp = '';
     973                }
    703974                foreach $wtag (keys %{$$tagInfo{WriteAlso}}) {
    704                     my ($n,$e) = $self->SetNewValue($wtag, undef, Replace=>2);
     975                    my ($n,$e) = $self->SetNewValue($wgrp . $wtag, undef, Replace=>2);
    705976                    $numSet += $n;
    706977                }
    … …  
    711982        if (defined $val) {
    712983            # we are editing this tag, so create a NEW_VALUE hash entry
    713             my $nvHash = $self->GetNewValueHash($tagInfo, $writeGroup, 'create');
    714             $nvHash->{WantGroup} = $wantGroup;
     984            my $nvHash = $self->GetNewValueHash($tagInfo, $writeGroup, 'create',
     985                                $options{ProtectSaved}, ($options{DelValue} and not $shift));
     986            # ignore new values protected with ProtectSaved
     987            $nvHash or ++$numSet, next; # (increment $numSet to avoid warning)
     988            $$nvHash{NoReplace} = 1 if $$tagInfo{List} and not $options{Replace};
     989            $$nvHash{WantGroup} = $wantGroup;
     990            $$nvHash{EditOnly} = 1 if $editOnly;
    715991            # save maker note information if writing maker notes
    716992            if ($$tagInfo{MakerNotes}) {
    717                 $nvHash->{MAKER_NOTE_FIXUP} = $self->{MAKER_NOTE_FIXUP};
    718             }
    719             if ($options{DelValue} or $options{AddValue} or $shift) {
     993                $$nvHash{MAKER_NOTE_FIXUP} = $$self{MAKER_NOTE_FIXUP};
     994            }
     995            if ($createOnly) {  # create only (never edit)
     996                # empty item in DelValue list to never edit existing value
     997                $$nvHash{DelValue} = [ '' ];
     998                $$nvHash{CreateOnly} = 1;
     999            } elsif ($options{DelValue} or $addValue or $shift) {
    7201000                # flag any AddValue or DelValue by creating the DelValue list
    721                 $nvHash->{DelValue} or $nvHash->{DelValue} = [ ];
     1001                $$nvHash{DelValue} or $$nvHash{DelValue} = [ ];
    7221002                if ($shift) {
    7231003                    # add shift value to list
    724                     $nvHash->{Shift} = $val;
     1004                    $$nvHash{Shift} = $val;
    7251005                } elsif ($options{DelValue}) {
    7261006                    # don't create if we are replacing a specific value
    727                     $nvHash->{IsCreating} = 0 unless $val eq '' or $tagInfo->{List};
     1007                    $$nvHash{IsCreating} = 0 unless $val eq '' or $$tagInfo{List};
    7281008                    # add delete value to list
    729                     push @{$nvHash->{DelValue}}, ref $val eq 'ARRAY' ? @$val : $val;
     1009                    push @{$$nvHash{DelValue}}, ref $val eq 'ARRAY' ? @$val : $val;
    7301010                    if ($verbose > 1) {
    7311011                        my $verb = $permanent ? 'Replacing' : 'Deleting';
    732                         my $fromList = $tagInfo->{List} ? ' from list' : '';
     1012                        my $fromList = $$tagInfo{List} ? ' from list' : '';
    7331013                        my @vals = (ref $val eq 'ARRAY' ? @$val : $val);
    7341014                        foreach (@vals) {
    … …  
    7371017                                $_ = Image::ExifTool::XMP::SerializeStruct($_);
    7381018                            }
    739                             print $out "$verb $wgrp1:$tag$fromList if value is '$_'\n";
     1019                            print $out "$verb $wgrp1:$tag$fromList if value is '${_}'\n";
    7401020                        }
    7411021                    }
    … …  
    7451025            # (will only create the priority tag if it doesn't exist,
    7461026            #  others get changed only if they already exist)
    747             if ($preferred{$tagInfo} or $tagInfo->{Table}{PREFERRED}) {
     1027            my $prf = defined $$tagInfo{Preferred} ? $$tagInfo{Preferred} : $$tagInfo{Table}{PREFERRED};
     1028            # hack to prefer only a single tag in the QuickTime group
     1029            if ($$tagInfo{Table}{GROUPS}{0} eq 'QuickTime') {
     1030                $prf = 0 if $tagPriority{$tagInfo} < $highestQT{$lcTag};
     1031            }
     1032            if ($$pref{$tagInfo} or $prf) {
    7481033                if ($permanent or $shift) {
    7491034                    # don't create permanent or Shift-ed tag but define IsCreating
    7501035                    # so we know that it is the preferred tag
    751                     $nvHash->{IsCreating} = 0;
    752                 } elsif (($tagInfo->{List} and not $options{DelValue}) or
    753                          not ($nvHash->{DelValue} and @{$nvHash->{DelValue}}) or
     1036                    $$nvHash{IsCreating} = 0;
     1037                } elsif (($$tagInfo{List} and not $options{DelValue}) or
     1038                         not ($$nvHash{DelValue} and @{$$nvHash{DelValue}}) or
    7541039                         # also create tag if any DelValue value is empty ('')
    755                          grep(/^$/,@{$nvHash->{DelValue}}))
     1040                         grep(/^$/,@{$$nvHash{DelValue}}))
    7561041                {
    757                     $nvHash->{IsCreating} = $options{EditOnly} ? 0 : ($options{EditGroup} ? 2 : 1);
     1042                    $$nvHash{IsCreating} = $editOnly ? 0 : ($editGroup ? 2 : 1);
    7581043                    # add to hash of groups where this tag is being created
    7591044                    $createGroups or $createGroups = $options{CreateGroups} || { };
    7601045                    $$createGroups{$self->GetGroup($tagInfo, 0)} = 1;
    761                     $nvHash->{CreateGroups} = $createGroups;
    762                 }
    763             }
    764             if (%{$self->{DEL_GROUP}} and $nvHash->{IsCreating}) {
    765                 my ($grp, @grps);
    766                 foreach $grp (keys %{$self->{DEL_GROUP}}) {
    767                     next if $self->{DEL_GROUP}{$grp} == 2;
    768                     # set flag indicating tags were written after this group was deleted
    769                     $self->{DEL_GROUP}{$grp} = 2;
    770                     push @grps, $grp;
    771                 }
    772                 if ($verbose > 1 and @grps) {
    773                     @grps = sort @grps;
    774                     print $out "  Writing new tags after deleting groups: @grps\n";
    775                 }
     1046                    $$nvHash{CreateGroups} = $createGroups;
     1047                }
     1048            }
     1049            if ($$nvHash{IsCreating}) {
     1050                if (%{$$self{DEL_GROUP}}) {
     1051                    my ($grp, @grps);
     1052                    foreach $grp (keys %{$$self{DEL_GROUP}}) {
     1053                        next if $$self{DEL_GROUP}{$grp} == 2;
     1054                        # set flag indicating tags were written after this group was deleted
     1055                        $$self{DEL_GROUP}{$grp} = 2;
     1056                        push @grps, $grp;
     1057                    }
     1058                    if ($verbose > 1 and @grps) {
     1059                        @grps = sort @grps;
     1060                        print $out "  Writing new tags after deleting groups: @grps\n";
     1061                    }
     1062                }
     1063            } elsif ($createOnly) {
     1064                $noCreate = $permanent ? 'permanent' : ($$tagInfo{Avoid} ? 'avoided' : '');
     1065                $noCreate or $noCreate = $shift ? 'shifting' : 'not preferred';
     1066                $verbose > 2 and print $out "Not creating $wgrp1:$tag ($noCreate)\n";
     1067                next;   # nothing to do (not creating and not editing)
    7761068            }
    7771069            if ($shift or not $options{DelValue}) {
    778                 $nvHash->{Value} or $nvHash->{Value} = [ ];
    779                 if (not $tagInfo->{List}) {
     1070                $$nvHash{Value} or $$nvHash{Value} = [ ];
     1071                if (not $$tagInfo{List}) {
    7801072                    # not a List tag -- overwrite existing value
    781                     $nvHash->{Value}[0] = $val;
     1073                    $$nvHash{Value}[0] = $val;
     1074                } elsif (defined $$nvHash{AddBefore} and @{$$nvHash{Value}} >= $$nvHash{AddBefore}) {
     1075                    # values from a later argument have been added (ie. Replace=0)
     1076                    # to this list, so the new values should come before these
     1077                    splice @{$$nvHash{Value}}, -$$nvHash{AddBefore}, 0, ref $val eq 'ARRAY' ? @$val : $val;
    7821078                } else {
    783                     # add to existing list
    784                     push @{$nvHash->{Value}}, ref $val eq 'ARRAY' ? @$val : $val;
     1079                    # add at end of existing list
     1080                    push @{$$nvHash{Value}}, ref $val eq 'ARRAY' ? @$val : $val;
    7851081                }
    7861082                if ($verbose > 1) {
    787                     my $ifExists = $nvHash->{IsCreating} ?
    788                                   ($nvHash->{IsCreating} == 2 ? " if $writeGroup exists" : '') :
    789                                   (($nvHash->{DelValue} and @{$nvHash->{DelValue}}) ?
    790                                    ' if tag was deleted' : ' if tag exists');
    791                     my $verb = ($shift ? 'Shifting' : ($options{AddValue} ? 'Adding' : 'Writing'));
     1083                    my $ifExists = $$nvHash{IsCreating} ? ( $createOnly ?
     1084                                  ($$nvHash{IsCreating} == 2 ?
     1085                                    " if $writeGroup exists and tag doesn't" :
     1086                                    " if tag doesn't exist") :
     1087                                  ($$nvHash{IsCreating} == 2 ? " if $writeGroup exists" : '')) :
     1088                                  (($$nvHash{DelValue} and @{$$nvHash{DelValue}}) ?
     1089                                    ' if tag was deleted' : ' if tag exists');
     1090                    my $verb = ($shift ? 'Shifting' : ($addValue ? 'Adding' : 'Writing'));
    7921091                    print $out "$verb $wgrp1:$tag$ifExists\n";
    7931092                }
    7941093            }
    7951094        } elsif ($permanent) {
    796             $err = "Can't delete $wgrp1:$tag";
     1095            $err = "Can't delete Permanent tag $wgrp1:$tag";
    7971096            $verbose > 1 and print $out "$err\n";
    7981097            next;
    799         } elsif ($options{AddValue} or $options{DelValue}) {
     1098        } elsif ($addValue or $options{DelValue}) {
    8001099            $verbose > 1 and print $out "Adding/Deleting nothing does nothing\n";
    8011100            next;
    … …  
    8041103            $self->GetNewValueHash($tagInfo, $writeGroup, 'delete');
    8051104            my $nvHash = $self->GetNewValueHash($tagInfo, $writeGroup, 'create');
    806             $nvHash->{WantGroup} = $wantGroup;
     1105            $$nvHash{WantGroup} = $wantGroup;
    8071106            $verbose > 1 and print $out "Deleting $wgrp1:$tag\n";
    8081107        }
     1108        $$setTags{$tagInfo} = 1 if $setTags;
     1109        $prioritySet = 1 if $$pref{$tagInfo};
     1110WriteAlso:
    8091111        ++$numSet;
    810         $$setTags{$tagInfo} = 1 if $setTags;
    811         $prioritySet = 1 if $preferred{$tagInfo};
    812 WriteAlso:
    8131112        # also write related tags
    8141113        my $writeAlso = $$tagInfo{WriteAlso};
    8151114        if ($writeAlso) {
    816             my ($wtag, $n);
     1115            my ($wgrp, $wtag, $n);
     1116            if ($$tagInfo{WriteGroup} and $$tagInfo{WriteGroup} eq 'All' and $writeGroup) {
     1117                $wgrp = $writeGroup . ':';
     1118            } else {
     1119                $wgrp = '';
     1120            }
    8171121            local $SIG{'__WARN__'} = \&SetWarning;
    8181122            foreach $wtag (keys %$writeAlso) {
    8191123                my %opts = (
    8201124                    Type => 'ValueConv',
    821                     Protected => $protected | 0x02,
    822                     AddValue => $options{AddValue},
    823                     DelValue => $options{DelValue},
    824                     CreateGroups => $createGroups,
    825                     SetTags => \%alsoWrote, # remember tags already written
     1125                    Protected   => $protected | 0x02,
     1126                    AddValue    => $addValue,
     1127                    DelValue    => $options{DelValue},
     1128                    Shift       => $options{Shift},
     1129                    Replace     => $options{Replace},   # handle lists properly
     1130                    CreateGroups=> $createGroups,
     1131                    SetTags     => \%alsoWrote,         # remember tags already written
    8261132                );
    8271133                undef $evalWarning;
    8281134                #### eval WriteAlso ($val)
    829                 my $v = eval $writeAlso->{$wtag};
     1135                my $v = eval $$writeAlso{$wtag};
     1136                # we wanted to do the eval in case there are side effect, but we
     1137                # don't want to write a value for a tag that is being deleted:
     1138                undef $v unless defined $val;
    8301139                $@ and $evalWarning = $@;
    8311140                unless ($evalWarning) {
    832                     ($n,$evalWarning) = $self->SetNewValue($wtag, $v, %opts);
     1141                    ($n,$evalWarning) = $self->SetNewValue($wgrp . $wtag, $v, %opts);
    8331142                    $numSet += $n;
    8341143                    # count this as being set if any related tag is set
    835                     $prioritySet = 1 if $n and $preferred{$tagInfo};
     1144                    $prioritySet = 1 if $n and $$pref{$tagInfo};
    8361145                }
    8371146                if ($evalWarning and (not $err or $verbose > 2)) {
    … …  
    8511160        warn "$err\n" if $err and not wantarray;
    8521161    } elsif (not $numSet) {
    853         my $pre = $wantGroup ? ($ifdName || $wantGroup) . ':' : '';
     1162        my $pre = $wantGroup ? $wantGroup . ':' : '';
    8541163        if ($wasProtected) {
    855             $err = "Tag '$pre$tag' is $wasProtected for writing";
    856         } elsif ($foundMatch) {
    857             $err = "Sorry, $pre$tag is not writable";
    858         } else {
    859             $err = "Tag '$pre$tag' does not exist";
    860         }
    861         $verbose > 2 and print $out "$err\n";
    862         warn "$err\n" unless wantarray;
     1164            $verbose = 0;   # we already printed this verbose message
     1165            unless ($options{Replace} and $options{Replace} == 2) {
     1166                $err = "Sorry, $pre$tag is $wasProtected for writing";
     1167            }
     1168        } elsif (not $listOnly) {
     1169            if ($origTag =~ /[?*]/) {
     1170                if ($noCreate) {
     1171                    $err = "No tags matching 'pre${origTag}' will be created";
     1172                    $verbose = 0;   # (already printed)
     1173                } elsif ($foundMatch) {
     1174                    $err = "Sorry, no writable tags matching '$pre${origTag}'";
     1175                } else {
     1176                    $err = "No matching tags for '$pre${origTag}'";
     1177                }
     1178            } elsif ($noCreate) {
     1179                $err = "Not creating $pre$tag";
     1180                $verbose = 0;   # (already printed)
     1181            } elsif ($foundMatch) {
     1182                $err = "Sorry, $pre$tag is not writable";
     1183            } elsif ($wantGroup and @matchingTags) {
     1184                $err = "Sorry, $pre$tag doesn't exist or isn't writable";
     1185            } else {
     1186                $err = "Tag '$pre${tag}' is not defined";
     1187            }
     1188        }
     1189        if ($err) {
     1190            $verbose > 2 and print $out "$err\n";
     1191            warn "$err\n" unless wantarray;
     1192        }
    8631193    } elsif ($$self{CHECK_WARN}) {
    8641194        $err = $$self{CHECK_WARN};
    … …  
    8881218    local $_;
    8891219    my ($self, $srcFile, @setTags) = @_;
    890     my $key;
     1220    my ($key, $tag, @exclude, @reqTags);
    8911221
    8921222    # get initial SetNewValuesFromFile options
    … …  
    8951225        $_ = shift @setTags;
    8961226        foreach $key (keys %$_) {
    897             $opts{$key} = $_->{$key};
     1227            $opts{$key} = $$_{$key};
    8981228        }
    8991229    }
    … …  
    9011231    @setTags and ExpandShortcuts(\@setTags);
    9021232    my $srcExifTool = new Image::ExifTool;
    903     my $options = $self->{OPTIONS};
     1233    # set flag to indicate we are being called from inside SetNewValuesFromFile()
     1234    $$srcExifTool{TAGS_FROM_FILE} = 1;
     1235    # synchronize and increment the file sequence number
     1236    $$srcExifTool{FILE_SEQUENCE} = $$self{FILE_SEQUENCE}++;
    9041237    # set options for our extraction tool
    905     $srcExifTool->{TAGS_FROM_FILE} = 1;
     1238    my $options = $$self{OPTIONS};
     1239    # copy both structured and flattened tags by default (but flattened tags are "unsafe")
     1240    my $structOpt = defined $$options{Struct} ? $$options{Struct} : 2;
     1241    # copy structures only if no tags specified (since flattened tags are "unsafe")
     1242    $structOpt = 1 if $structOpt eq '2' and not @setTags;
    9061243    # +------------------------------------------+
    9071244    # ! DON'T FORGET!!  Must consider each new   !
    … …  
    9091246    # +------------------------------------------+
    9101247    $srcExifTool->Options(
    911         Binary      => 1,
    912         Charset     => $$options{Charset},
    913         CharsetID3  => $$options{CharsetID3},
    914         CharsetIPTC => $$options{CharsetIPTC},
    915         CharsetPhotoshop => $$options{CharsetPhotoshop},
    916         Composite   => $$options{Composite},
    917         CoordFormat => $$options{CoordFormat} || '%d %d %.8f', # copy coordinates at high resolution unless otherwise specified
    918         DateFormat  => $$options{DateFormat},
    919         Duplicates  => 1,
    920         Escape      => $$options{Escape},
     1248        Binary          => 1,
     1249        Charset         => $$options{Charset},
     1250        CharsetEXIF     => $$options{CharsetEXIF},
     1251        CharsetFileName => $$options{CharsetFileName},
     1252        CharsetID3      => $$options{CharsetID3},
     1253        CharsetIPTC     => $$options{CharsetIPTC},
     1254        CharsetPhotoshop=> $$options{CharsetPhotoshop},
     1255        Composite       => $$options{Composite},
     1256        CoordFormat     => $$options{CoordFormat} || '%d %d %.8f', # copy coordinates at high resolution unless otherwise specified
     1257        DateFormat      => $$options{DateFormat},
     1258        Duplicates      => 1,
     1259        Escape          => $$options{Escape},
     1260      # Exclude (set below)
     1261        ExtendedXMP     => $$options{ExtendedXMP},
    9211262        ExtractEmbedded => $$options{ExtractEmbedded},
    922         FastScan    => $$options{FastScan},
    923         FixBase     => $$options{FixBase},
    924         IgnoreMinorErrors => $$options{IgnoreMinorErrors},
    925         Lang        => $$options{Lang},
    926         LargeFileSupport => $$options{LargeFileSupport},
    927         List        => 1,
    928         MakerNotes  => 1,
     1263        FastScan        => $$options{FastScan},
     1264        Filter          => $$options{Filter},
     1265        FixBase         => $$options{FixBase},
     1266        GlobalTimeShift => $$options{GlobalTimeShift},
     1267        HexTagIDs       => $$options{HexTagIDs},
     1268        IgnoreMinorErrors=>$$options{IgnoreMinorErrors},
     1269        Lang            => $$options{Lang},
     1270        LargeFileSupport=> $$options{LargeFileSupport},
     1271        List            => 1,
     1272        ListItem        => $$options{ListItem},
     1273        ListSep         => $$options{ListSep},
     1274        MakerNotes      => $$options{FastScan} && $$options{FastScan} > 1 ? undef : 1,
     1275        MDItemTags      => $$options{MDItemTags},
    9291276        MissingTagValue => $$options{MissingTagValue},
    930         Password    => $$options{Password},
    931         PrintConv   => $$options{PrintConv},
    932         ScanForXMP  => $$options{ScanForXMP},
    933         StrictDate  => 1,
    934         Struct      => ($$options{Struct} or not defined $$options{Struct}) ? 1 : 0,
    935         Unknown     => $$options{Unknown},
     1277        NoPDFList       => $$options{NoPDFList},
     1278        Password        => $$options{Password},
     1279        PrintConv       => $$options{PrintConv},
     1280        QuickTimeUTC    => $$options{QuickTimeUTC},
     1281        RequestAll      => $$options{RequestAll} || 1, # (is this still necessary now that RequestTags are being set?)
     1282        RequestTags     => $$options{RequestTags},
     1283        SaveFormat      => $$options{SaveFormat},
     1284        SavePath        => $$options{SavePath},
     1285        ScanForXMP      => $$options{ScanForXMP},
     1286        StrictDate      => defined $$options{StrictDate} ? $$options{StrictDate} : 1,
     1287        Struct          => $structOpt,
     1288        SystemTags      => $$options{SystemTags},
     1289        TimeZone        => $$options{TimeZone},
     1290        Unknown         => $$options{Unknown},
     1291        UserParam       => $$options{UserParam},
     1292        Validate        => $$options{Validate},
     1293        XAttrTags       => $$options{XAttrTags},
     1294        XMPAutoConv     => $$options{XMPAutoConv},
    9361295    );
     1296    $$srcExifTool{GLOBAL_TIME_OFFSET} = $$self{GLOBAL_TIME_OFFSET};
     1297    foreach $tag (@setTags) {
     1298        next if ref $tag;
     1299        if ($tag =~ /^-(.*)/) {
     1300            # avoid extracting tags that are excluded
     1301            push @exclude, $1;
     1302            next;
     1303        }
     1304        # add specified tags to list of requested tags
     1305        $_ = $tag;
     1306        if (/(.+?)\s*(>|<)\s*(.+)/) {
     1307            if ($2 eq '>') {
     1308                $_ = $1;
     1309            } else {
     1310                $_ = $3;
     1311                /\$/ and push(@reqTags, /\$\{?(?:[-\w]+:)*([-\w?*]+)/g), next;
     1312            }
     1313        }
     1314        push @reqTags, $2 if /(^|:)([-\w?*]+)#?$/;
     1315    }
     1316    if (@exclude) {
     1317        ExpandShortcuts(\@exclude, 1);
     1318        $srcExifTool->Options(Exclude => \@exclude);
     1319    }
     1320    $srcExifTool->Options(RequestTags => \@reqTags) if @reqTags;
    9371321    my $printConv = $$options{PrintConv};
    9381322    if ($opts{Type}) {
    … …  
    9481332    my $info = $srcExifTool->ImageInfo($srcFile);
    9491333    return $info if $$info{Error} and $$info{Error} eq 'Error opening file';
    950     delete $srcExifTool->{VALUE}{Error}; # delete so we can check this later
     1334    delete $$srcExifTool{VALUE}{Error}; # delete so we can check this later
    9511335
    9521336    # sort tags in reverse order so we get priority tag last
    9531337    my @tags = reverse sort keys %$info;
    954     my $tag;
    9551338#
    9561339# simply transfer all tags from source image if no tags specified
    … …  
    9581341    unless (@setTags) {
    9591342        # transfer maker note information to this object
    960         $self->{MAKER_NOTE_FIXUP} = $srcExifTool->{MAKER_NOTE_FIXUP};
    961         $self->{MAKER_NOTE_BYTE_ORDER} = $srcExifTool->{MAKER_NOTE_BYTE_ORDER};
     1343        $$self{MAKER_NOTE_FIXUP} = $$srcExifTool{MAKER_NOTE_FIXUP};
     1344        $$self{MAKER_NOTE_BYTE_ORDER} = $$srcExifTool{MAKER_NOTE_BYTE_ORDER};
    9621345        foreach $tag (@tags) {
    9631346            # don't try to set errors or warnings
    9641347            next if $tag =~ /^(Error|Warning)\b/;
    965             # get approprite value type if necessary
     1348            # get appropriate value type if necessary
    9661349            if ($opts{SrcType} and $opts{SrcType} ne $srcType) {
    9671350                $$info{$tag} = $srcExifTool->GetValue($tag, $opts{SrcType});
    … …  
    9691352            # set value for this tag
    9701353            my ($n, $e) = $self->SetNewValue($tag, $$info{$tag}, %opts);
    971             # delete this tag if we could't set it
     1354            # delete this tag if we couldn't set it
    9721355            $n or delete $$info{$tag};
    9731356        }
    … …  
    9781361#
    9791362    # 1) loop through input list of tags to set, and build @setList
    980     my (@setList, $set, %setMatches);
    981     foreach (@setTags) {
    982         if (ref $_ eq 'HASH') {
     1363    my (@setList, $set, %setMatches, $t);
     1364    foreach $t (@setTags) {
     1365        if (ref $t eq 'HASH') {
    9831366            # update current options
    984             foreach $key (keys %$_) {
    985                 $opts{$key} = $_->{$key};
     1367            foreach $key (keys %$t) {
     1368                $opts{$key} = $$t{$key};
    9861369            }
    9871370            next;
    … …  
    9901373        # (also use this hash to store expression and wildcard flags, EXPR and WILD)
    9911374        my $opts = { %opts };
    992         $tag = lc($_);  # change tag/group names to all lower case
    993         my ($fam, $grp, $dst, $dstGrp, $dstTag, $isExclude);
     1375        $tag = lc $t;   # change tag/group names to all lower case
     1376        my (@fg, $grp, $dst, $dstGrp, $dstTag, $isExclude);
    9941377        # handle redirection to another tag
    9951378        if ($tag =~ /(.+?)\s*(>|<)\s*(.+)/) {
    … …  
    9981381            if ($2 eq '>') {
    9991382                ($tag, $dstTag) = ($1, $3);
    1000                 # flag add and delete (ie. '+<' and '-<') redirections
     1383                # flag add and delete (eg. '+<' and '-<') redirections
    10011384                $opt = $1 if $tag =~ s/\s*([-+])$// or $dstTag =~ s/^([-+])\s*//;
    10021385            } else {
    … …  
    10051388                # handle expressions
    10061389                if ($tag =~ /\$/) {
    1007                     $tag = $_;  # restore original case
     1390                    $tag = $t;  # restore original case
    10081391                    # recover leading whitespace (except for initial single space)
    10091392                    $tag =~ s/(.+?)\s*(>|<) ?//;
    10101393                    $$opts{EXPR} = 1; # flag this expression
    1011                     $grp = '';
    10121394                } else {
    10131395                    $opt = $1 if $tag =~ s/^([-+])\s*//;
    10141396                }
    10151397            }
     1398            # validate tag name(s)
     1399            $$opts{EXPR} or ValidTagName($tag) or $self->Warn("Invalid tag name '${tag}'"), next;
     1400            ValidTagName($dstTag) or $self->Warn("Invalid tag name '${dstTag}'"), next;
    10161401            # translate '+' and '-' to appropriate SetNewValue option
    10171402            if ($opt) {
    10181403                $$opts{{ '+' => 'AddValue', '-' => 'DelValue' }->{$opt}} = 1;
    1019                 $$opts{Shift} = 0;  # shift if this is a date/time tag
     1404                $$opts{Shift} = 0;  # shift if shiftable
    10201405            }
    10211406            ($dstGrp, $dstTag) = ($1, $2) if $dstTag =~ /(.*):(.+)/;
    10221407            # ValueConv may be specified separately on the destination with '#'
    10231408            $$opts{Type} = 'ValueConv' if $dstTag =~ s/#$//;
    1024             # ignore leading family number
    1025             $dstGrp = $2 if $dstGrp =~ /^(\d+)(.*)/ and $1 < 2;
    1026             # replace 'all' with '*' in tag and group names
     1409            # replace tag name of 'all' with '*'
    10271410            $dstTag = '*' if $dstTag eq 'all';
    1028             $dstGrp = '*' if $dstGrp eq 'all';
    10291411        }
    10301412        unless ($$opts{EXPR}) {
    10311413            $isExclude = ($tag =~ s/^-//);
    1032             if ($tag =~ /^([-\w]*?|\*):(.+)/) {
     1414            if ($tag =~ /(.*):(.+)/) {
    10331415                ($grp, $tag) = ($1, $2);
    1034                 # separate leading family number
    1035                 ($fam, $grp) = ($1, $2) if $grp =~ /^(\d+)(.*)/;
    1036             } else {
    1037                 $grp = '';  # flag for don't care about group
     1416                foreach (split /:/, $grp) {
     1417                    # save family/groups in list (ignoring 'all' and '*')
     1418                    next unless length($_) and /^(\d+)?(.*)/;
     1419                    my ($f, $g) = ($1, $2);
     1420                    $f = 7 if $g =~ s/^ID-//i;
     1421                    push @fg, [ $f, $g ] unless $g eq '*' or $g eq 'all';
     1422                }
    10381423            }
    10391424            # allow ValueConv to be specified by a '#' on the tag name
    … …  
    10441429            # replace 'all' with '*' in tag and group names
    10451430            $tag = '*' if $tag eq 'all';
    1046             $grp = '*' if $grp eq 'all';
    1047             # allow wildcards in tag names
     1431            # allow wildcards in tag names (handle differently from all tags: '*')
    10481432            if ($tag =~ /[?*]/ and $tag ne '*') {
    1049                 $$opts{WILD} = 1;   # set flag indicating wildcards were used
     1433                $$opts{WILD} = 1;   # set flag indicating wildcards were used in source tag
    10501434                $tag =~ s/\*/[-\\w]*/g;
    10511435                $tag =~ s/\?/[-\\w]/g;
    10521436            }
    10531437        }
    1054         # redirect, exclude or set this tag (Note: $grp is '' if we don't care)
     1438        # redirect, exclude or set this tag (Note: @fg is empty if we don't care about the group)
    10551439        if ($dstTag) {
    10561440            # redirect this tag
    10571441            $isExclude and return { Error => "Can't redirect excluded tag" };
    1058             if ($dstTag ne '*') {
    1059                 if ($dstTag =~ /[?*]/) {
    1060                     if ($dstTag eq $tag) {
    1061                         $dstTag = '*';
    1062                     } else {
    1063                         return { Error => "Invalid use of wildcards in destination tag" };
    1064                     }
    1065                 } elsif ($tag eq '*') {
    1066                     return { Error => "Can't redirect from all tags to one tag" };
    1067                 }
    1068             }
    10691442            # set destination group the same as source if necessary
    1070           # (removed in 7.72 so '-xmp:*>*:*' will preserve XMP family 1 groups)
     1443          # (removed in 7.72 so '-*:*<xmp:*' will preserve XMP family 1 groups)
    10711444          # $dstGrp = $grp if $dstGrp eq '*' and $grp;
    10721445            # write to specified destination group/tag
    … …  
    10741447        } elsif ($isExclude) {
    10751448            # implicitly assume '*' if first entry is an exclusion
    1076             unshift @setList, [ undef, '*', '*', [ '', '*' ], $opts ] unless @setList;
     1449            unshift @setList, [ [ ], '*', [ '', '*' ], $opts ] unless @setList;
    10771450            # exclude this tag by leaving $dst undefined
    10781451        } else {
    1079             $dst = [ $grp, $$opts{WILD} ? '*' : $tag ]; # copy to same group
    1080         }
    1081         $grp or $grp = '*';     # use '*' for any group
     1452            $dst = [ $grp || '', $$opts{WILD} ? '*' : $tag ]; # use same group name for dest
     1453        }
    10821454        # save in reverse order so we don't set tags before an exclude
    1083         unshift @setList, [ $fam, $grp, $tag, $dst, $opts ];
     1455        unshift @setList, [ \@fg, $tag, $dst, $opts ];
    10841456    }
    10851457    # 2) initialize lists of matching tags for each setTag
    10861458    foreach $set (@setList) {
    1087         $$set[3] and $setMatches{$set} = [ ];
     1459        $$set[2] and $setMatches{$set} = [ ];
    10881460    }
    10891461    # 3) loop through all tags in source image and save tags matching each setTag
    … …  
    10981470        my $lcTag = lc(GetTagName($tag));
    10991471        my (@grp, %grp);
    1100         foreach $set (@setList) {
     1472SET:    foreach $set (@setList) {
    11011473            # check first for matching tag
    1102             unless ($$set[2] eq $lcTag or $$set[2] eq '*') {
     1474            unless ($$set[1] eq $lcTag or $$set[1] eq '*') {
    11031475                # handle wildcards
    1104                 next unless $$set[4]{WILD} and $lcTag =~ /^$$set[2]$/;
     1476                next unless $$set[3]{WILD} and $lcTag =~ /^$$set[1]$/;
    11051477            }
    11061478            # then check for matching group
    1107             unless ($$set[1] eq '*') {
     1479            if (@{$$set[0]}) {
    11081480                # get lower case group names if not done already
    11091481                unless (@grp) {
    … …  
    11111483                    $grp{$_} = 1 foreach @grp;
    11121484                }
    1113                 # handle leading family number
    1114                 if (defined $$set[0]) {
    1115                     next unless $grp[$$set[0]] and $$set[1] eq $grp[$$set[0]];
    1116                 } else {
    1117                     next unless $grp{$$set[1]};
    1118                 }
    1119             }
    1120             last unless $$set[3];   # all done if we hit an exclude
     1485                foreach (@{$$set[0]}) {
     1486                    my ($f, $g) = @$_;
     1487                    if (not defined $f) {
     1488                        next SET unless $grp{$g};
     1489                    } elsif ($f == 7) {
     1490                        next SET unless IsSameID($srcExifTool->GetTagID($tag), $g);
     1491                    } else {
     1492                        next SET unless defined $grp[$f] and $g eq $grp[$f];
     1493                    }
     1494                }
     1495            }
     1496            last unless $$set[2];   # all done if we hit an exclude
    11211497            # add to the list of tags matching this setTag
    11221498            push @{$setMatches{$set}}, $tag;
    … …  
    11261502    foreach $set (reverse @setList) {
    11271503        # get options for SetNewValue
    1128         my $opts = $$set[4];
     1504        my $opts = $$set[3];
    11291505        # handle expressions
    11301506        if ($$opts{EXPR}) {
    1131             my $val = $srcExifTool->InsertTagValues(\@tags, $$set[2], 'Error');
    1132             unless (defined $val) {
    1133                 # return warning if one of the tags didn't exist
    1134                 $tag = NextTagKey(\%rtnInfo, 'Warning');
    1135                 $rtnInfo{$tag} = $srcExifTool->GetValue('Error');
    1136                 delete $srcExifTool->{VALUE}{Error};
    1137                 next;
    1138             }
    1139             my ($dstGrp, $dstTag) = @{$$set[3]};
    1140             $$opts{Protected} = 1;
     1507            my $val = $srcExifTool->InsertTagValues(\@tags, $$set[1], 'Error');
     1508            if ($$srcExifTool{VALUE}{Error}) {
     1509                # pass on any error as a warning
     1510                $tag = NextFreeTagKey(\%rtnInfo, 'Warning');
     1511                $rtnInfo{$tag} = $$srcExifTool{VALUE}{Error};
     1512                delete $$srcExifTool{VALUE}{Error};
     1513                next unless defined $val;
     1514            }
     1515            my ($dstGrp, $dstTag) = @{$$set[2]};
     1516            $$opts{Protected} = 1 unless $dstTag =~ /[?*]/ and $dstTag ne '*';
    11411517            $$opts{Group} = $dstGrp if $dstGrp;
    11421518            my @rtnVals = $self->SetNewValue($dstTag, $val, %$opts);
    … …  
    11511527                $val = $$info{$tag};
    11521528            }
    1153             my ($dstGrp, $dstTag) = @{$$set[3]};
     1529            my ($dstGrp, $dstTag) = @{$$set[2]};
    11541530            if ($dstGrp) {
    1155                 if ($dstGrp eq '*') {
    1156                     $dstGrp = $srcExifTool->GetGroup($tag, 1);
     1531                my @dstGrp = split /:/, $dstGrp;
     1532                # destination group of '*' writes to same group as source tag
     1533                # (family 1 unless otherwise specified)
     1534                foreach (@dstGrp) {
     1535                    next unless /^(\d*)(all|\*)$/i;
     1536                    $_ = $1 . $srcExifTool->GetGroup($tag, length $1 ? $1 : 1);
    11571537                    $noWarn = 1;    # don't warn on wildcard destinations
    11581538                }
    1159                 $$opts{Group} = $dstGrp;
     1539                $$opts{Group} = join ':', @dstGrp;
    11601540            } else {
    11611541                delete $$opts{Group};
    11621542            }
    11631543            # transfer maker note information if setting this tag
    1164             if ($srcExifTool->{TAG_INFO}{$tag}{MakerNotes}) {
    1165                 $self->{MAKER_NOTE_FIXUP} = $srcExifTool->{MAKER_NOTE_FIXUP};
    1166                 $self->{MAKER_NOTE_BYTE_ORDER} = $srcExifTool->{MAKER_NOTE_BYTE_ORDER};
     1544            if ($$srcExifTool{TAG_INFO}{$tag}{MakerNotes}) {
     1545                $$self{MAKER_NOTE_FIXUP} = $$srcExifTool{MAKER_NOTE_FIXUP};
     1546                $$self{MAKER_NOTE_BYTE_ORDER} = $$srcExifTool{MAKER_NOTE_BYTE_ORDER};
    11671547            }
    11681548            if ($dstTag eq '*') {
    … …  
    11701550                $noWarn = 1;
    11711551            }
    1172             # allow protected tags to be copied if specified explicitly
    1173             $$opts{Protected} = ($$set[2] eq '*' ? undef : 1);
     1552            if ($$set[1] eq '*' or $$set[3]{WILD}) {
     1553                # don't copy from protected binary tags when using wildcards
     1554                next if $$srcExifTool{TAG_INFO}{$tag}{Protected} and
     1555                        $$srcExifTool{TAG_INFO}{$tag}{Binary};
     1556                # don't copy to protected tags when using wildcards
     1557                delete $$opts{Protected};
     1558                # don't copy flattened tags if copying structures too when copying all
     1559                $$opts{NoFlat} = $structOpt eq '2' ? 1 : 0;
     1560            } else {
     1561                # allow protected tags to be copied if specified explicitly
     1562                $$opts{Protected} = 1 unless $dstTag =~ /[?*]/;
     1563                delete $$opts{NoFlat};
     1564            }
    11741565            # set value(s) for this tag
    11751566            my ($rtn, $wrn) = $self->SetNewValue($dstTag, $val, %$opts);
     1567            # this was added in version 9.14, and allowed actions like "-subject<all" to
     1568            # write values of multiple tags into a list, but it had the side effect of
     1569            # duplicating items if there were multiple list tags with the same name
     1570            # (eg. -use mwg "-creator<creator"), so disable this as of ExifTool 9.36:
     1571            # $$opts{Replace} = 0;    # accumulate values from tags matching a single argument
    11761572            if ($wrn and not $noWarn) {
    11771573                # return this warning
    1178                 $rtnInfo{NextTagKey(\%rtnInfo, 'Warning')} = $wrn;
     1574                $rtnInfo{NextFreeTagKey(\%rtnInfo, 'Warning')} = $wrn;
    11791575                $noWarn = 1;
    11801576            }
    … …  
    11871583#------------------------------------------------------------------------------
    11881584# Get new value(s) for tag
    1189 # Inputs: 0) ExifTool object reference, 1) tag name or tagInfo hash ref
     1585# Inputs: 0) ExifTool object reference, 1) tag name (or tagInfo or nvHash ref, not public)
    11901586#         2) optional pointer to return new value hash reference (not part of public API)
    1191 #    or   0) new value hash reference (not part of public API)
    11921587# Returns: List of new Raw values (list may be empty if tag is being deleted)
    11931588# Notes: 1) Preferentially returns new value from Extra table if writable Extra tag exists
    11941589# 2) Must call AFTER IsOverwriting() returns 1 to get proper value for shifted times
    11951590# 3) Tag name is case sensitive and may be prefixed by family 0 or 1 group name
    1196 sub GetNewValues($;$$)
     1591# 4) Value may have been modified by CHECK_PROC routine after ValueConv
     1592sub GetNewValue($$;$)
    11971593{
    11981594    local $_;
     1595    my $self = shift;
     1596    my $tag = shift;
    11991597    my $nvHash;
    1200     if (ref $_[0] eq 'HASH') {
    1201         $nvHash = shift;
     1598    if ((ref $tag eq 'HASH' and $$tag{IsNVH}) or not defined $tag) {
     1599        $nvHash = $tag;
    12021600    } else {
    1203         my ($self, $tag, $newValueHashPt) = @_;
    1204         if ($self->{NEW_VALUE}) {
     1601        my $newValueHashPt = shift;
     1602        if ($$self{NEW_VALUE}) {
    12051603            my ($group, $tagInfo);
    12061604            if (ref $tag) {
    … …  
    12121610            } else {
    12131611                # separate group from tag name
    1214                 $group = $1 if $tag =~ s/(.*)://;
     1612                my @groups;
     1613                @groups = split ':', $1 if $tag =~ s/(.*)://;
    12151614                my @tagInfoList = FindTagInfo($tag);
    12161615                # decide which tag we want
    12171616GNV_TagInfo:    foreach $tagInfo (@tagInfoList) {
    12181617                    my $nvh = $self->GetNewValueHash($tagInfo) or next;
    1219                     # select tag in specified group if necessary
    1220                     while ($group and $group ne $$nvh{WriteGroup}) {
     1618                    # select tag in specified group(s) if necessary
     1619                    foreach (@groups) {
     1620                        next if $_ eq $$nvh{WriteGroup};
    12211621                        my @grps = $self->GetGroup($tagInfo);
    12221622                        if ($grps[0] eq $$nvh{WriteGroup}) {
    12231623                            # check family 1 group only if WriteGroup is not specific
    1224                             last if $group eq $grps[1];
     1624                            next if $_ eq $grps[1];
    12251625                        } else {
    12261626                            # otherwise check family 0 group
    1227                             last if $group eq $grps[0];
     1627                            next if $_ eq $grps[0];
    12281628                        }
     1629                        # also check family 7
     1630                        next if /^ID-(.*)/i and IsSameID($$tagInfo{TagID}, $1);
    12291631                        # step to next entry in list
    12301632                        $nvh = $$nvh{Next} or next GNV_TagInfo;
    … …  
    12321634                    $nvHash = $nvh;
    12331635                    # give priority to the one we are creating
    1234                     last if defined $nvHash->{IsCreating};
     1636                    last if defined $$nvHash{IsCreating};
    12351637                }
    12361638            }
    … …  
    12391641        $newValueHashPt and $$newValueHashPt = $nvHash;
    12401642    }
    1241     if ($nvHash and $nvHash->{Value}) {
    1242         my $vals = $nvHash->{Value};
    1243         # do inverse raw conversion if necessary
    1244         if ($nvHash->{TagInfo}{RawConvInv}) {
    1245             my @copyVals = @$vals;  # modify a copy of the values
    1246             $vals = \@copyVals;
    1247             my $tagInfo = $$nvHash{TagInfo};
    1248             my $conv = $$tagInfo{RawConvInv};
    1249             my $self = $nvHash->{Self};
    1250             my ($val, $checkProc);
    1251             my $table = $tagInfo->{Table};
    1252             $checkProc = $$table{CHECK_PROC} if $table;
    1253             local $SIG{'__WARN__'} = \&SetWarning;
    1254             undef $evalWarning;
    1255             foreach $val (@$vals) {
    1256                 if (ref($conv) eq 'CODE') {
    1257                     $val = &$conv($val, $self);
    1258                 } else {
    1259                     #### eval RawConvInv ($self, $val, $taginfo)
    1260                     $val = eval $conv;
    1261                     $@ and $evalWarning = $@;
    1262                 }
    1263                 if ($evalWarning) {
    1264                     # an empty warning ("\n") ignores tag with no error
    1265                     if ($evalWarning ne "\n") {
    1266                         my $err = CleanWarning() . " in $$tagInfo{Name} (RawConvInv)";
    1267                         $self->Warn($err);
    1268                     }
    1269                     @$vals = ();
    1270                     last;
    1271                 }
    1272                 # must check value now
    1273                 next unless $checkProc;
     1643    unless ($nvHash and $$nvHash{Value}) {
     1644        return () if wantarray;  # return empty list
     1645        return undef;
     1646    }
     1647    my $vals = $$nvHash{Value};
     1648    # do inverse raw conversion if necessary
     1649    # - must also check after doing a Shift
     1650    if ($$nvHash{TagInfo}{RawConvInv} or $$nvHash{Shift}) {
     1651        my @copyVals = @$vals;  # modify a copy of the values
     1652        $vals = \@copyVals;
     1653        my $tagInfo = $$nvHash{TagInfo};
     1654        my $conv = $$tagInfo{RawConvInv};
     1655        my $table = $$tagInfo{Table};
     1656        my ($val, $checkProc);
     1657        $checkProc = $$table{CHECK_PROC} if $$nvHash{Shift} and $table;
     1658        local $SIG{'__WARN__'} = \&SetWarning;
     1659        undef $evalWarning;
     1660        foreach $val (@$vals) {
     1661            # must check value now if it was shifted
     1662            if ($checkProc) {
    12741663                my $err = &$checkProc($self, $tagInfo, \$val);
    12751664                if ($err or not defined $val) {
    12761665                    $err or $err = 'Error generating raw value';
    1277                     $self->Warn("$err for $$tagInfo{Name}");
     1666                    $self->WarnOnce("$err for $$tagInfo{Name}");
    12781667                    @$vals = ();
    12791668                    last;
    12801669                }
    1281             }
    1282         }
    1283         # return our value(s)
    1284         return @$vals if wantarray;
    1285         return $$vals[0];
    1286     }
    1287     return () if wantarray;  # return empty list
    1288     return undef;
     1670                next unless $conv;
     1671            } else {
     1672                last unless $conv;
     1673            }
     1674            # do inverse raw conversion
     1675            if (ref($conv) eq 'CODE') {
     1676                $val = &$conv($val, $self);
     1677            } else {
     1678                #### eval RawConvInv ($self, $val, $tagInfo)
     1679                $val = eval $conv;
     1680                $@ and $evalWarning = $@;
     1681            }
     1682            if ($evalWarning) {
     1683                # an empty warning ("\n") ignores tag with no error
     1684                if ($evalWarning ne "\n") {
     1685                    my $err = CleanWarning() . " in $$tagInfo{Name} (RawConvInv)";
     1686                    $self->WarnOnce($err);
     1687                }
     1688                @$vals = ();
     1689                last;
     1690            }
     1691        }
     1692    }
     1693    # return our value(s)
     1694    return @$vals if wantarray;
     1695    return $$vals[0];
    12891696}
    12901697
    … …  
    12921699# Return the total number of new values set
    12931700# Inputs: 0) ExifTool object reference
    1294 # Returns: Scalar context) Number of new values that have been set
    1295 #          List context) Number of new values, number of "pseudo" values
     1701# Returns: Scalar context) Number of new values that have been set (incl pseudo)
     1702#          List context) Number of new values (incl pseudo), number of "pseudo" values
    12961703# ("pseudo" values are those which don't require rewriting the file to change)
    12971704sub CountNewValues($)
    12981705{
    12991706    my $self = shift;
    1300     my $newVal = $self->{NEW_VALUE};
    1301     my $num = 0;
    1302     my $tag;
     1707    my $newVal = $$self{NEW_VALUE};
     1708    my ($num, $pseudo) = (0, 0);
    13031709    if ($newVal) {
    1304         $num += scalar keys %$newVal;
    1305         # don't count "fake" tags (only in Extra table)
    1306         foreach $tag (qw{Geotag Geosync}) {
    1307             --$num if defined $$newVal{$Image::ExifTool::Extra{$tag}};
    1308         }
    1309     }
    1310     $num += scalar keys %{$self->{DEL_GROUP}};
     1710        $num = scalar keys %$newVal;
     1711        my $nv;
     1712        foreach $nv (values %$newVal) {
     1713            my $tagInfo = $$nv{TagInfo};
     1714            # don't count tags that don't write anything
     1715            $$tagInfo{WriteNothing} and --$num, next;
     1716            # count the number of pseudo tags included
     1717            $$tagInfo{WritePseudo} and ++$pseudo;
     1718        }
     1719    }
     1720    $num += scalar keys %{$$self{DEL_GROUP}};
    13111721    return $num unless wantarray;
    1312     my $pseudo = 0;
    1313     if ($newVal) {
    1314         # (Note: all writable "pseudo" tags must be found in Extra table)
    1315         foreach $tag (qw{FileName Directory FileModifyDate}) {
    1316             ++$pseudo if defined $$newVal{$Image::ExifTool::Extra{$tag}};
    1317         }
    1318     }
    13191722    return ($num, $pseudo);
    13201723}
    … …  
    13231726# Save new values for subsequent restore
    13241727# Inputs: 0) ExifTool object reference
     1728# Returns: Number of times new values have been saved
     1729# Notes: increments SAVE_COUNT flag each time routine is called
    13251730sub SaveNewValues($)
    13261731{
    13271732    my $self = shift;
    1328     my $newValues = $self->{NEW_VALUE};
     1733    my $newValues = $$self{NEW_VALUE};
     1734    my $saveCount = ++$$self{SAVE_COUNT};
    13291735    my $key;
    13301736    foreach $key (keys %$newValues) {
    13311737        my $nvHash = $$newValues{$key};
    13321738        while ($nvHash) {
    1333             $nvHash->{Save} = 1;  # set Save flag
    1334             $nvHash = $nvHash->{Next};
     1739            # set Save count if not done already
     1740            $$nvHash{Save} or $$nvHash{Save} = $saveCount;
     1741            $nvHash = $$nvHash{Next};
    13351742        }
    13361743    }
    13371744    # initialize hash for saving overwritten new values
    1338     $self->{SAVE_NEW_VALUE} = { };
     1745    $$self{SAVE_NEW_VALUE} = { };
    13391746    # make a copy of the delete group hash
    1340     if ($self->{DEL_GROUP}) {
    1341         my %delGrp = %{$self->{DEL_GROUP}};
    1342         $self->{SAVE_DEL_GROUP} = \%delGrp;
    1343     } else {
    1344         delete $self->{SAVE_DEL_GROUP};
    1345     }
     1747    my %delGrp = %{$$self{DEL_GROUP}};
     1748    $$self{SAVE_DEL_GROUP} = \%delGrp;
     1749    return $saveCount;
    13461750}
    13471751
    … …  
    13511755# Notes: Restores saved new values, but currently doesn't restore them in the
    13521756# original order, so there may be some minor side-effects when restoring tags
    1353 # with overlapping groups. ie) XMP:Identifier, XMP-dc:Identifier
     1757# with overlapping groups. eg) XMP:Identifier, XMP-dc:Identifier
     1758# Also, this doesn't do the right thing for list-type tags which accumulate
     1759# values across a save point
    13541760sub RestoreNewValues($)
    13551761{
    13561762    my $self = shift;
    1357     my $newValues = $self->{NEW_VALUE};
    1358     my $savedValues = $self->{SAVE_NEW_VALUE};
     1763    my $newValues = $$self{NEW_VALUE};
     1764    my $savedValues = $$self{SAVE_NEW_VALUE};
    13591765    my $key;
    13601766    # 1) remove any new values which don't have the Save flag set
    … …  
    13651771            my $nvHash = $$newValues{$key};
    13661772            while ($nvHash) {
    1367                 if ($nvHash->{Save}) {
     1773                if ($$nvHash{Save}) {
    13681774                    $lastHash = $nvHash;
    13691775                } else {
    13701776                    # remove this entry from the list
    13711777                    if ($lastHash) {
    1372                         $lastHash->{Next} = $nvHash->{Next};
    1373                     } elsif ($nvHash->{Next}) {
    1374                         $$newValues{$key} = $nvHash->{Next};
     1778                        $$lastHash{Next} = $$nvHash{Next};
     1779                    } elsif ($$nvHash{Next}) {
     1780                        $$newValues{$key} = $$nvHash{Next};
    13751781                    } else {
    13761782                        delete $$newValues{$key};
    13771783                    }
    13781784                }
    1379                 $nvHash = $nvHash->{Next};
     1785                $nvHash = $$nvHash{Next};
    13801786            }
    13811787        }
    … …  
    13831789    # 2) restore saved new values
    13841790    if ($savedValues) {
    1385         $newValues or $newValues = $self->{NEW_VALUE} = { };
     1791        $newValues or $newValues = $$self{NEW_VALUE} = { };
    13861792        foreach $key (keys %$savedValues) {
    13871793            if ($$newValues{$key}) {
    13881794                # add saved values to end of list
    13891795                my $nvHash = LastInList($$newValues{$key});
    1390                 $nvHash->{Next} = $$savedValues{$key};
     1796                $$nvHash{Next} = $$savedValues{$key};
    13911797            } else {
    13921798                $$newValues{$key} = $$savedValues{$key};
    13931799            }
    13941800        }
    1395         $self->{SAVE_NEW_VALUE} = { };  # reset saved new values
     1801        $$self{SAVE_NEW_VALUE} = { };  # reset saved new values
    13961802    }
    13971803    # 3) restore delete groups
    1398     if ($self->{SAVE_DEL_GROUP}) {
    1399         my %delGrp = %{$self->{SAVE_DEL_GROUP}};
    1400         $self->{DEL_GROUP} = \%delGrp;
    1401     } else {
    1402         delete $self->{DEL_GROUP};
    1403     }
    1404 }
    1405 
    1406 #------------------------------------------------------------------------------
    1407 # Set file modification time from FileModifyDate tag
     1804    my %delGrp = %{$$self{SAVE_DEL_GROUP}};
     1805    $$self{DEL_GROUP} = \%delGrp;
     1806}
     1807
     1808#------------------------------------------------------------------------------
     1809# Set filesystem time from from FileModifyDate or FileCreateDate tag
    14081810# Inputs: 0) ExifTool object reference, 1) file name or file ref
    1409 #         2) modify time (-M) of original file (needed for time shift)
     1811#         2) time (-M or -C) of original file (used for shift; obtained from file if not given)
     1812#         3) tag name to write (undef for 'FileModifyDate')
     1813#         4) flag set if argument 2 has already been converted to Unix seconds
    14101814# Returns: 1=time changed OK, 0=nothing done, -1=error setting time
    1411 #          (and increments CHANGED flag if time was changed)
    1412 sub SetFileModifyDate($$;$)
    1413 {
    1414     my ($self, $file, $originalTime) = @_;
     1815#          (increments CHANGED flag and sets corresponding WRITTEN tag)
     1816sub SetFileModifyDate($$;$$$)
     1817{
     1818    my ($self, $file, $originalTime, $tag, $isUnixTime) = @_;
    14151819    my $nvHash;
    1416     my $val = $self->GetNewValues('FileModifyDate', \$nvHash);
     1820    $tag = 'FileModifyDate' unless defined $tag;
     1821    my $val = $self->GetNewValue($tag, \$nvHash);
    14171822    return 0 unless defined $val;
    1418     my $isOverwriting = IsOverwriting($nvHash);
     1823    my $isOverwriting = $self->IsOverwriting($nvHash);
    14191824    return 0 unless $isOverwriting;
     1825    # can currently only set creation date on Windows systems
     1826    # (and Mac now too, but that is handled with the MacOS tags)
     1827    return 0 if $tag eq 'FileCreateDate' and $^O ne 'MSWin32';
    14201828    if ($isOverwriting < 0) {  # are we shifting time?
    14211829        # use original time of this file if not specified
    1422         $originalTime = -M $file unless defined $originalTime;
    1423         return 0 unless defined $originalTime;
    1424         return 0 unless IsOverwriting($nvHash, $^T - $originalTime*(24*3600));
    1425         $val = $nvHash->{Value}[0]; # get shifted value
    1426     }
    1427     unless (utime($val, $val, $file)) {
    1428         $self->Warn('Error setting FileModifyDate');
    1429         return -1;
    1430     }
    1431     ++$self->{CHANGED};
    1432     $self->VerboseValue('+ FileModifyDate', $val);
     1830        unless (defined $originalTime) {
     1831            my ($aTime, $mTime, $cTime) = $self->GetFileTime($file);
     1832            $originalTime = ($tag eq 'FileCreateDate') ? $cTime : $mTime;
     1833            return 0 unless defined $originalTime;
     1834            $isUnixTime = 1;
     1835        }
     1836        $originalTime = int($^T - $originalTime*(24*3600) + 0.5) unless $isUnixTime;
     1837        return 0 unless $self->IsOverwriting($nvHash, $originalTime);
     1838        $val = $$nvHash{Value}[0]; # get shifted value
     1839    }
     1840    my ($aTime, $mTime, $cTime);
     1841    if ($tag eq 'FileCreateDate') {
     1842        eval { require Win32::API } or $self->WarnOnce("Install Win32::API to set $tag"), return -1;
     1843        eval { require Win32API::File } or $self->WarnOnce("Install Win32API::File to set $tag"), return -1;
     1844        $cTime = $val;
     1845    } else {
     1846        $aTime = $mTime = $val;
     1847    }
     1848    $self->SetFileTime($file, $aTime, $mTime, $cTime, 1) or $self->Warn("Error setting $tag"), return -1;
     1849    ++$$self{CHANGED};
     1850    $$self{WRITTEN}{$tag} = $val;   # remember that we wrote this tag
     1851    $self->VerboseValue("+ $tag", $val);
    14331852    return 1;
    14341853}
    … …  
    14371856# Change file name and/or directory from FileName and Directory tags
    14381857# Inputs: 0) ExifTool object reference, 1) current file name (including path)
    1439 #         2) New name (or undef to build from FileName and Directory tags)
     1858#         2) new name (or undef to build from FileName and Directory tags)
     1859#         3) option: 'HardLink'/'SymLink' to create hard/symbolic link instead of renaming
     1860#                    'Test' to only print new file name
     1861#         4) 0 to indicate that a file will no longer exist (used for 'Test' only)
    14401862# Returns: 1=name changed OK, 0=nothing changed, -1=error changing name
    14411863#          (and increments CHANGED flag if filename changed)
    14421864# Notes: Will not overwrite existing file.  Creates directories as necessary.
    1443 sub SetFileName($$;$)
    1444 {
    1445     my ($self, $file, $newName) = @_;
     1865sub SetFileName($$;$$$)
     1866{
     1867    my ($self, $file, $newName, $opt, $usedFlag) = @_;
    14461868    my ($nvHash, $doName, $doDir);
     1869
     1870    $opt or $opt = '';
    14471871    # determine the new file name
    14481872    unless (defined $newName) {
    1449         my $filename = $self->GetNewValues('FileName', \$nvHash);
    1450         $doName = 1 if defined $filename and IsOverwriting($nvHash, $file);
    1451         my $dir = $self->GetNewValues('Directory', \$nvHash);
    1452         $doDir = 1 if defined $dir and IsOverwriting($nvHash, $file);
    1453         return 0 unless $doName or $doDir;  # nothing to do
    1454         if ($doName) {
    1455             $newName = GetNewFileName($file, $filename);
    1456             $newName = GetNewFileName($newName, $dir) if $doDir;
     1873        if ($opt) {
     1874            if ($opt eq 'HardLink' or $opt eq 'Link') {
     1875                $newName = $self->GetNewValue('HardLink');
     1876            } elsif ($opt eq 'SymLink') {
     1877                $newName = $self->GetNewValue('SymLink');
     1878            } elsif ($opt eq 'Test') {
     1879                $newName = $self->GetNewValue('TestName');
     1880            }
     1881            return 0 unless defined $newName;
    14571882        } else {
    1458             $newName = GetNewFileName($file, $dir);
    1459         }
    1460     }
    1461     if (-e $newName) {
    1462         # don't replace existing file
    1463         $self->Warn("File '$newName' already exists");
    1464         return -1;
     1883            my $filename = $self->GetNewValue('FileName', \$nvHash);
     1884            $doName = 1 if defined $filename and $self->IsOverwriting($nvHash, $file);
     1885            my $dir = $self->GetNewValue('Directory', \$nvHash);
     1886            $doDir = 1 if defined $dir and $self->IsOverwriting($nvHash, $file);
     1887            return 0 unless $doName or $doDir;  # nothing to do
     1888            if ($doName) {
     1889                $newName = GetNewFileName($file, $filename);
     1890                $newName = GetNewFileName($newName, $dir) if $doDir;
     1891            } else {
     1892                $newName = GetNewFileName($file, $dir);
     1893            }
     1894        }
     1895    }
     1896    # validate new file name in Windows
     1897    if ($^O eq 'MSWin32') {
     1898        if ($newName =~ /[\0-\x1f<>"|*]/) {
     1899            $self->Warn('New file name not allowed in Windows (contains reserved characters)');
     1900            return -1;
     1901        }
     1902        if ($newName =~ /:/ and $newName !~ /^[A-Z]:[^:]*$/i) {
     1903            $self->Warn("New file name not allowed in Windows (contains ':')");
     1904            return -1;
     1905        }
     1906        if ($newName =~ /\?/ and $newName !~ m{^[\\/]{2}\?[\\/][^?]*$}) {
     1907            $self->Warn("New file name not allowed in Windows (contains '?')");
     1908            return -1;
     1909        }
     1910        if ($newName =~ m{(^|[\\/])(CON|PRN|AUX|NUL|COM[1-9]|LPT[1-9])(\.[^.]*)?$}i) {
     1911            $self->Warn('New file name not allowed in Windows (reserved device name)');
     1912            return -1;
     1913        }
     1914        if ($newName =~ /([. ])$/) {
     1915            $self->Warn("New file name not recommended for Windows (ends with '${1}')", 2) and return -1;
     1916        }
     1917        if (length $newName > 259 and $newName !~ /\?/) {
     1918            $self->Warn('New file name not recommended for Windows (exceeds 260 chars)', 2) and return -1;
     1919        }
     1920    } else {
     1921        $newName =~ tr/\0//d;   # make sure name doesn't contain nulls
     1922    }
     1923    # protect against empty file name
     1924    length $newName or $self->Warn('New file name is empty'), return -1;
     1925    # don't replace existing file
     1926    if ($self->Exists($newName) and (not defined $usedFlag or $usedFlag)) {
     1927        if ($file ne $newName or $opt =~ /Link$/) {
     1928            # allow for case-insensitive filesystem
     1929            if ($opt =~ /Link$/ or not $self->IsSameFile($file, $newName)) {
     1930                $self->Warn("File '${newName}' already exists");
     1931                return -1;
     1932            }
     1933        } else {
     1934            $self->Warn('File name is unchanged');
     1935            return 0;
     1936        }
     1937    }
     1938    if ($opt eq 'Test') {
     1939        my $out = $$self{OPTIONS}{TextOut};
     1940        print $out "'${file}' --> '${newName}'\n";
     1941        return 1;
    14651942    }
    14661943    # create directory for new file if necessary
    14671944    my $result;
    1468     if (($result = CreateDirectory($newName)) != 0) {
     1945    if (($result = $self->CreateDirectory($newName)) != 0) {
    14691946        if ($result < 0) {
    1470             $self->Warn("Error creating directory for '$newName'");
     1947            $self->Warn("Error creating directory for '${newName}'");
    14711948            return -1;
    14721949        }
    1473         $self->VPrint(0, "Created directory for '$newName'");
     1950        $self->VPrint(0, "Created directory for '${newName}'\n");
     1951    }
     1952    if ($opt eq 'HardLink' or $opt eq 'Link') {
     1953        unless (link $file, $newName) {
     1954            $self->Warn("Error creating hard link '${newName}'");
     1955            return -1;
     1956        }
     1957        ++$$self{CHANGED};
     1958        $self->VerboseValue('+ HardLink', $newName);
     1959        return 1;
     1960    } elsif ($opt eq 'SymLink') {
     1961        $^O eq 'MSWin32' and $self->Warn('SymLink not supported in Windows'), return -1;
     1962        $newName =~ s(^\./)();  # remove leading "./" from link name if it exists
     1963        # path to linked file must be relative to the $newName directory, but $file
     1964        # is relative to the current directory, so convert it to an absolute path
     1965        # if using a relative directory and $newName isn't in the current directory
     1966        if ($file !~ m(^/) and $newName =~ m(/)) {
     1967            unless (eval { require Cwd }) {
     1968                $self->Warn('Install Cwd to make symlinks to other directories');
     1969                return -1;
     1970            }
     1971            $file = eval { Cwd::abs_path($file) };
     1972            unless (defined $file) {
     1973                $self->Warn('Error in Cwd::abs_path when creating symlink');
     1974                return -1;
     1975            }
     1976        }
     1977        unless (eval { symlink $file, $newName } ) {
     1978            $self->Warn("Error creating symbolic link '${newName}'");
     1979            return -1;
     1980        }
     1981        ++$$self{CHANGED};
     1982        $self->VerboseValue('+ SymLink', $newName);
     1983        return 1;
    14741984    }
    14751985    # attempt to rename the file
    1476     unless (rename $file, $newName) {
     1986    unless ($self->Rename($file, $newName)) {
    14771987        local (*EXIFTOOL_SFN_IN, *EXIFTOOL_SFN_OUT);
    14781988        # renaming didn't work, so copy the file instead
    1479         unless (open EXIFTOOL_SFN_IN, $file) {
    1480             $self->Warn("Error opening '$file'");
     1989        unless ($self->Open(\*EXIFTOOL_SFN_IN, $file)) {
     1990            $self->Error("Error opening '${file}'");
    14811991            return -1;
    14821992        }
    1483         unless (open EXIFTOOL_SFN_OUT, ">$newName") {
     1993        unless ($self->Open(\*EXIFTOOL_SFN_OUT, $newName, '>')) {
    14841994            close EXIFTOOL_SFN_IN;
    1485             $self->Warn("Error creating '$newName'");
     1995            $self->Error("Error creating '${newName}'");
    14861996            return -1;
    14871997        }
    … …  
    14952005        close EXIFTOOL_SFN_IN;
    14962006        if ($err) {
    1497             unlink $newName;    # erase bad output file
    1498             $self->Warn("Error writing '$newName'");
     2007            $self->Unlink($newName);    # erase bad output file
     2008            $self->Error("Error writing '${newName}'");
    14992009            return -1;
    15002010        }
    15012011        # preserve modification time
    1502         my $modTime = $^T - (-M $file) * (24 * 3600);
    1503         my $accTime = $^T - (-A $file) * (24 * 3600);
    1504         utime($accTime, $modTime, $newName);
     2012        my ($aTime, $mTime, $cTime) = $self->GetFileTime($file);
     2013        $self->SetFileTime($newName, $aTime, $mTime, $cTime);
    15052014        # remove the original file
    1506         unlink $file or $self->Warn('Error removing old file');
    1507     }
    1508     ++$self->{CHANGED};
     2015        $self->Unlink($file) or $self->Warn('Error removing old file');
     2016    }
     2017    $$self{NewName} = $newName; # remember new file name
     2018    ++$$self{CHANGED};
    15092019    $self->VerboseValue('+ FileName', $newName);
    15102020    return 1;
    … …  
    15122022
    15132023#------------------------------------------------------------------------------
     2024# Set file permissions, group/user id and various MDItem tags from new tag values
     2025# Inputs: 0) ExifTool ref, 1) file name or glob (must be a name for MDItem tags)
     2026# Returns: 1=something was set OK, 0=didn't try, -1=error (and warning set)
     2027# Notes: There may be errors even if 1 is returned
     2028sub SetSystemTags($$)
     2029{
     2030    my ($self, $file) = @_;
     2031    my $result = 0;
     2032
     2033    my $perm = $self->GetNewValue('FilePermissions');
     2034    if (defined $perm) {
     2035        if (eval { chmod($perm & 07777, $file) }) {
     2036            $self->VerboseValue('+ FilePermissions', $perm);
     2037            $result = 1;
     2038        } else {
     2039            $self->WarnOnce('Error setting FilePermissions');
     2040            $result = -1;
     2041        }
     2042    }
     2043    my $uid = $self->GetNewValue('FileUserID');
     2044    my $gid = $self->GetNewValue('FileGroupID');
     2045    if (defined $uid or defined $gid) {
     2046        defined $uid or $uid = -1;
     2047        defined $gid or $gid = -1;
     2048        if (eval { chown($uid, $gid, $file) }) {
     2049            $self->VerboseValue('+ FileUserID', $uid) if $uid >= 0;
     2050            $self->VerboseValue('+ FileGroupID', $gid) if $gid >= 0;
     2051            $result = 1;
     2052        } else {
     2053            $self->WarnOnce('Error setting FileGroup/UserID');
     2054            $result = -1 unless $result;
     2055        }
     2056    }
     2057    my $tag;
     2058    foreach $tag (@writableMacOSTags) {
     2059        my $nvHash;
     2060        my $val = $self->GetNewValue($tag, \$nvHash);
     2061        next unless $nvHash;
     2062        if ($^O eq 'darwin') {
     2063            ref $file and $self->Warn('Setting MDItem tags requires a file name'), last;
     2064            require Image::ExifTool::MacOS;
     2065            my $res = Image::ExifTool::MacOS::SetMacOSTags($self, $file, \@writableMacOSTags);
     2066            $result = $res if $res == 1 or not $result;
     2067            last;
     2068        } elsif ($tag ne 'FileCreateDate') {
     2069            $self->WarnOnce('Can only set MDItem tags on OS X');
     2070            last;
     2071        }
     2072    }
     2073    return $result;
     2074}
     2075
     2076#------------------------------------------------------------------------------
    15142077# Write information back to file
    15152078# Inputs: 0) ExifTool object reference,
    1516 #         1) input filename, file ref, or scalar ref (or '' or undef to create from scratch)
     2079#         1) input filename, file ref, RAF ref, or scalar ref (or '' or undef to create from scratch)
    15172080#         2) output filename, file ref, or scalar ref (or undef to overwrite)
    15182081#         3) optional output file type (required only if input file is not specified
    … …  
    15242087    my ($self, $infile, $outfile, $outType) = @_;
    15252088    my (@fileTypeList, $fileType, $tiffType, $hdr, $seekErr, $type, $tmpfile);
    1526     my ($inRef, $outRef, $closeIn, $closeOut, $outPos, $outBuff, $eraseIn);
    1527     my $oldRaf = $self->{RAF};
     2089    my ($inRef, $outRef, $closeIn, $closeOut, $outPos, $outBuff, $eraseIn, $raf, $fileExt);
     2090    my ($hardLink, $symLink, $testName);
     2091    my $oldRaf = $$self{RAF};
    15282092    my $rtnVal = 0;
    15292093
    15302094    # initialize member variables
    15312095    $self->Init();
     2096    $$self{IsWriting} = 1;
    15322097
    15332098    # first, save original file modify date if necessary
    15342099    # (do this now in case we are modifying file in place and shifting date)
    1535     my ($nvHash, $originalTime);
    1536     my $fileModifyDate =  $self->GetNewValues('FileModifyDate', \$nvHash);
    1537     if (defined $fileModifyDate and IsOverwriting($nvHash) < 0 and
     2100    my ($nvHash, $nvHash2, $originalTime, $createTime);
     2101    my $setModDate = defined $self->GetNewValue('FileModifyDate', \$nvHash);
     2102    my $setCreateDate = defined $self->GetNewValue('FileCreateDate', \$nvHash2);
     2103    my ($aTime, $mTime, $cTime);
     2104    if ($setModDate and $self->IsOverwriting($nvHash) < 0 and
    15382105        defined $infile and ref $infile ne 'SCALAR')
    15392106    {
    1540         $originalTime = -M $infile;
     2107        ($aTime, $mTime, $cTime) = $self->GetFileTime($infile);
     2108        $originalTime = $mTime;
     2109    }
     2110    if ($setCreateDate and $self->IsOverwriting($nvHash2) < 0 and
     2111        defined $infile and ref $infile ne 'SCALAR')
     2112    {
     2113        ($aTime, $mTime, $cTime) = $self->GetFileTime($infile) unless defined $cTime;
     2114        $createTime = $cTime;
    15412115    }
    15422116#
    … …  
    15452119    my ($numNew, $numPseudo) = $self->CountNewValues();
    15462120    if (not defined $outfile and defined $infile) {
    1547         my $newFileName =  $self->GetNewValues('FileName', \$nvHash);
     2121        $hardLink = $self->GetNewValue('HardLink');
     2122        $symLink = $self->GetNewValue('SymLink');
     2123        $testName = $self->GetNewValue('TestName');
     2124        undef $hardLink if defined $hardLink and not length $hardLink;
     2125        undef $symLink if defined $symLink and not length $symLink;
     2126        undef $testName if defined $testName and not length $testName;
     2127        my $newFileName =  $self->GetNewValue('FileName', \$nvHash);
     2128        my $newDir = $self->GetNewValue('Directory');
     2129        if (defined $newDir and length $newDir) {
     2130            $newDir .= '/' unless $newDir =~ m{/$};
     2131        } else {
     2132            undef $newDir;
     2133        }
    15482134        if ($numNew == $numPseudo) {
    15492135            $rtnVal = 2;
    1550             if (defined $fileModifyDate and (not ref $infile or UNIVERSAL::isa($infile,'GLOB'))) {
    1551                 $self->SetFileModifyDate($infile) > 0 and $rtnVal = 1;
    1552             }
    1553             if (defined $newFileName and not ref $infile) {
    1554                 $self->SetFileName($infile) > 0 and $rtnVal = 1;
     2136            if ((defined $newFileName or defined $newDir) and not ref $infile) {
     2137                my $result = $self->SetFileName($infile);
     2138                if ($result > 0) {
     2139                    $infile = $$self{NewName};  # file name changed
     2140                    $rtnVal = 1;
     2141                } elsif ($result < 0) {
     2142                    return 0;   # don't try to do anything else
     2143                }
     2144            }
     2145            if (not ref $infile or UNIVERSAL::isa($infile,'GLOB')) {
     2146                $self->SetFileModifyDate($infile) > 0 and $rtnVal = 1 if $setModDate;
     2147                $self->SetFileModifyDate($infile, undef, 'FileCreateDate') > 0 and $rtnVal = 1 if $setCreateDate;
     2148                $self->SetSystemTags($infile) > 0 and $rtnVal = 1;
     2149            }
     2150            if (defined $hardLink or defined $symLink or defined $testName) {
     2151                $hardLink and $self->SetFileName($infile, $hardLink, 'HardLink') and $rtnVal = 1;
     2152                $symLink and $self->SetFileName($infile, $symLink, 'SymLink') and $rtnVal = 1;
     2153                $testName and $self->SetFileName($infile, $testName, 'Test') and $rtnVal = 1;
    15552154            }
    15562155            return $rtnVal;
    … …  
    15612160                $outfile = $newFileName;
    15622161                # can't delete original
    1563             } elsif (IsOverwriting($nvHash, $infile)) {
     2162            } elsif ($self->IsOverwriting($nvHash, $infile)) {
    15642163                $outfile = GetNewFileName($infile, $newFileName);
    15652164                $eraseIn = 1; # delete original
     2165            }
     2166        }
     2167        # set new directory if specified
     2168        if (defined $newDir) {
     2169            $outfile = $infile unless defined $outfile or ref $infile;
     2170            if (defined $outfile) {
     2171                $outfile = GetNewFileName($outfile, $newDir);
     2172                $eraseIn = 1 unless ref $infile;
    15662173            }
    15672174        }
    … …  
    15742181        if (UNIVERSAL::isa($inRef,'GLOB')) {
    15752182            seek($inRef, 0, 0); # make sure we are at the start of the file
    1576         } elsif ($] >= 5.006 and (eval 'require Encode; Encode::is_utf8($$inRef)' or $@)) {
     2183        } elsif (UNIVERSAL::isa($inRef,'File::RandomAccess')) {
     2184            $inRef->Seek(0);
     2185            $raf = $inRef;
     2186        } elsif ($] >= 5.006 and (eval { require Encode; Encode::is_utf8($$inRef) } or $@)) {
    15772187            # convert image data from UTF-8 to character stream if necessary
    1578             my $buff = $@ ? pack('C*',unpack('U0C*',$$inRef)) : Encode::encode('utf8',$$inRef);
     2188            my $buff = $@ ? pack('C*',unpack($] < 5.010000 ? 'U0C*' : 'C0C*',$$inRef)) : Encode::encode('utf8',$$inRef);
    15792189            if (defined $outfile) {
    15802190                $inRef = \$buff;
    … …  
    15862196        # write to a temporary file if no output file given
    15872197        $outfile = $tmpfile = "${infile}_exiftool_tmp" unless defined $outfile;
    1588         if (open(EXIFTOOL_FILE2, $infile)) {
     2198        if ($self->Open(\*EXIFTOOL_FILE2, $infile)) {
     2199            $fileExt = GetFileExtension($infile);
    15892200            $fileType = GetFileType($infile);
    15902201            @fileTypeList = GetFileType($infile);
    … …  
    16042215        $outType = GetFileExtension($outfile) unless $outType or ref $outfile;
    16052216        if (CanCreate($outType)) {
    1606             $fileType = $tiffType = $outType;   # use output file type if no input file
    1607             $infile = "$fileType file";         # make bogus file name
    1608             $self->VPrint(0, "Creating $infile...\n");
    1609             $inRef = \ '';      # set $inRef to reference to empty data
     2217            if ($$self{OPTIONS}{WriteMode} =~ /g/i) {
     2218                $fileType = $tiffType = $outType;   # use output file type if no input file
     2219                $infile = "$fileType file";         # make bogus file name
     2220                $self->VPrint(0, "Creating $infile...\n");
     2221                $inRef = \ '';      # set $inRef to reference to empty data
     2222            } else {
     2223                $self->Error("Not creating new $outType file (disallowed by WriteMode)");
     2224                return 0;
     2225            }
    16102226        } elsif ($outType) {
    16112227            $self->Error("Can't create $outType files");
    … …  
    16402256        # editing in place, so write to memory first
    16412257        # (only when infile is a file ref or scalar ref)
     2258        if ($raf) {
     2259            $self->Error("Can't edit File::RandomAccess object in place");
     2260            return 0;
     2261        }
    16422262        $outBuff = '';
    16432263        $outRef = \$outBuff;
    16442264        $outPos = 0;
    1645     } elsif (-e $outfile) {
     2265    } elsif ($self->Exists($outfile)) {
    16462266        $self->Error("File already exists: $outfile");
    1647     } elsif (open(EXIFTOOL_OUTFILE, ">$outfile")) {
     2267    } elsif ($self->Open(\*EXIFTOOL_OUTFILE, $outfile, '>')) {
    16482268        $outRef = \*EXIFTOOL_OUTFILE;
    16492269        $closeOut = 1;  # we must close $outRef
    … …  
    16572277# write the file
    16582278#
    1659     until ($self->{VALUE}{Error}) {
     2279    until ($$self{VALUE}{Error}) {
    16602280        # create random access file object (disable seek test in case of straight copy)
    1661         my $raf = new File::RandomAccess($inRef, 1);
     2281        $raf or $raf = new File::RandomAccess($inRef, 1);
    16622282        $raf->BinMode();
    16632283        if ($numNew == $numPseudo) {
    … …  
    16712291        } elsif (not ref $infile and ($infile eq '-' or $infile =~ /\|$/)) {
    16722292            # patch for Windows command shell pipe
    1673             $raf->{TESTED} = -1;    # force buffering
     2293            $$raf{TESTED} = -1; # force buffering
    16742294        } else {
    16752295            $raf->SeekTest();
    … …  
    16772297       # $raf->Debug() and warn "  RAF debugging enabled!\n";
    16782298        my $inPos = $raf->Tell();
    1679         $self->{RAF} = $raf;
     2299        $$self{RAF} = $raf;
    16802300        my %dirInfo = (
    16812301            RAF => $raf,
    … …  
    16942314            }
    16952315            # save file type in member variable
    1696             $dirInfo{Parent} = $self->{FILE_TYPE} = $self->{PATH}[0] = $type;
     2316            $dirInfo{Parent} = $$self{FILE_TYPE} = $$self{PATH}[0] = $type;
    16972317            # determine which directories we must write for this file type
    16982318            $self->InitWriteDirs($type);
    1699             if ($type eq 'JPEG') {
     2319            if ($type eq 'JPEG' or $type eq 'EXV') {
    17002320                $rtnVal = $self->WriteJPEG(\%dirInfo);
    17012321            } elsif ($type eq 'TIFF') {
    … …  
    17052325                    undef $rtnVal;
    17062326                } else {
     2327                    if ($tiffType eq 'FFF') {
     2328                        # (see https://exiftool.org/forum/index.php?topic=10848.0)
     2329                        $self->Error('Phocus may not properly update previews of edited FFF images', 1);
     2330                    }
    17072331                    $dirInfo{Parent} = $tiffType;
    17082332                    $rtnVal = $self->ProcessTIFF(\%dirInfo);
    17092333                }
    1710             } elsif ($type eq 'GIF') {
    1711                 require Image::ExifTool::GIF;
    1712                 $rtnVal = Image::ExifTool::GIF::ProcessGIF($self,\%dirInfo);
    1713             } elsif ($type eq 'CRW') {
    1714                 require Image::ExifTool::CanonRaw;
    1715                 $rtnVal = Image::ExifTool::CanonRaw::WriteCRW($self, \%dirInfo);
    1716             } elsif ($type eq 'MRW') {
    1717                 require Image::ExifTool::MinoltaRaw;
    1718                 $rtnVal = Image::ExifTool::MinoltaRaw::ProcessMRW($self, \%dirInfo);
    1719             } elsif ($type eq 'RAF') {
    1720                 require Image::ExifTool::FujiFilm;
    1721                 $rtnVal = Image::ExifTool::FujiFilm::WriteRAF($self, \%dirInfo);
     2334            } elsif (exists $writableType{$type}) {
     2335                my ($module, $func);
     2336                if (ref $writableType{$type} eq 'ARRAY') {
     2337                    $module = $writableType{$type}[0] || $type;
     2338                    $func = $writableType{$type}[1];
     2339                } else {
     2340                    $module = $writableType{$type} || $type;
     2341                }
     2342                require "Image/ExifTool/$module.pm";
     2343                $func = "Image::ExifTool::${module}::" . ($func || "Process$type");
     2344                no strict 'refs';
     2345                $rtnVal = &$func($self, \%dirInfo);
     2346                use strict 'refs';
    17222347            } elsif ($type eq 'ORF' or $type eq 'RAW') {
    17232348                $rtnVal = $self->ProcessTIFF(\%dirInfo);
    1724             } elsif ($type eq 'X3F') {
    1725                 require Image::ExifTool::SigmaRaw;
    1726                 $rtnVal = Image::ExifTool::SigmaRaw::ProcessX3F($self, \%dirInfo);
    1727             } elsif ($type eq 'PNG') {
    1728                 require Image::ExifTool::PNG;
    1729                 $rtnVal = Image::ExifTool::PNG::ProcessPNG($self, \%dirInfo);
    1730             } elsif ($type eq 'MIE') {
    1731                 require Image::ExifTool::MIE;
    1732                 $rtnVal = Image::ExifTool::MIE::ProcessMIE($self, \%dirInfo);
    1733             } elsif ($type eq 'XMP') {
    1734                 require Image::ExifTool::XMP;
    1735                 $rtnVal = Image::ExifTool::XMP::WriteXMP($self, \%dirInfo);
    1736             } elsif ($type eq 'PPM') {
    1737                 require Image::ExifTool::PPM;
    1738                 $rtnVal = Image::ExifTool::PPM::ProcessPPM($self, \%dirInfo);
    1739             } elsif ($type eq 'PSD') {
    1740                 require Image::ExifTool::Photoshop;
    1741                 $rtnVal = Image::ExifTool::Photoshop::ProcessPSD($self, \%dirInfo);
    1742             } elsif ($type eq 'EPS' or $type eq 'PS') {
    1743                 require Image::ExifTool::PostScript;
    1744                 $rtnVal = Image::ExifTool::PostScript::WritePS($self, \%dirInfo);
    1745             } elsif ($type eq 'PDF') {
    1746                 require Image::ExifTool::PDF;
    1747                 $rtnVal = Image::ExifTool::PDF::WritePDF($self, \%dirInfo);
    1748             } elsif ($type eq 'ICC') {
    1749                 require Image::ExifTool::ICC_Profile;
    1750                 $rtnVal = Image::ExifTool::ICC_Profile::WriteICC($self, \%dirInfo);
    1751             } elsif ($type eq 'VRD') {
    1752                 require Image::ExifTool::CanonVRD;
    1753                 $rtnVal = Image::ExifTool::CanonVRD::ProcessVRD($self, \%dirInfo);
    1754             } elsif ($type eq 'JP2') {
    1755                 require Image::ExifTool::Jpeg2000;
    1756                 $rtnVal = Image::ExifTool::Jpeg2000::ProcessJP2($self, \%dirInfo);
    1757             } elsif ($type eq 'IND') {
    1758                 require Image::ExifTool::InDesign;
    1759                 $rtnVal = Image::ExifTool::InDesign::ProcessIND($self, \%dirInfo);
    17602349            } elsif ($type eq 'EXIF') {
    17612350                # go through WriteDirectory so block writes, etc are handled
    … …  
    17872376                $err = 'Error seeking in file';
    17882377            } elsif ($fileType and defined $rtnVal) {
    1789                 if ($self->{VALUE}{Error}) {
     2378                if ($$self{VALUE}{Error}) {
    17902379                    # existing error message will do
    17912380                } elsif ($fileType eq 'RAW') {
    … …  
    17932382                } else {
    17942383                    if ($wrongType) {
    1795                         $err = "Not a valid $fileType";
     2384                        my $type = $fileExt || ($fileType eq 'TIFF' ? $tiffType : $fileType);
     2385                        $err = "Not a valid $type";
    17962386                        # do a quick check to see what this file looks like
    17972387                        foreach $type (@fileTypes) {
    … …  
    18202410    # don't return success code if any error occurred
    18212411    if ($rtnVal > 0) {
    1822         unless (Tell($outRef) or $self->{VALUE}{Error}) {
     2412        if ($outType and $type and $outType ne $type) {
     2413            my @types = GetFileType($outType);
     2414            unless (grep /^$type$/, @types) {
     2415                $self->Error("Can't create $outType file from $type");
     2416                $rtnVal = 0;
     2417            }
     2418        }
     2419        if ($rtnVal > 0 and not Tell($outRef) and not $$self{VALUE}{Error}) {
    18232420            # don't write a file with zero length
    18242421            if (defined $hdr and length $hdr) {
     2422                $type = '<unk>' unless defined $type;
    18252423                $self->Error("Can't delete all meta information from $type file");
    18262424            } else {
    … …  
    18282426            }
    18292427        }
    1830         $rtnVal = 0 if $self->{VALUE}{Error};
     2428        $rtnVal = 0 if $$self{VALUE}{Error};
    18312429    }
    18322430
    18332431    # rewrite original file in place if required
    18342432    if (defined $outBuff) {
    1835         if ($rtnVal <= 0 or not $self->{CHANGED}) {
     2433        if ($rtnVal <= 0 or not $$self{CHANGED}) {
    18362434            # nothing changed, so no need to write $outBuff
    18372435        } elsif (UNIVERSAL::isa($inRef,'GLOB')) {
    … …  
    18442442                print $inRef $outBuff and       # write the new data
    18452443                ($len >= $size or               # if necessary:
    1846                 eval 'truncate($inRef, $len)'); #  shorten output file
     2444                eval { truncate($inRef, $len) }); #  shorten output file
    18472445        } else {
    18482446            $$inRef = $outBuff;                 # replace original data
    … …  
    18562454        if ($rtnVal > 0) {
    18572455            # copy Mac OS resource fork if it exists
    1858             if ($^O eq 'darwin' and -s "$infile/rsrc") {
    1859                 if ($$self{DEL_GROUP} and $$self{DEL_GROUP}{RSRC}) {
     2456            if ($^O eq 'darwin' and -s "$infile/..namedfork/rsrc") {
     2457                if ($$self{DEL_GROUP}{RSRC}) {
    18602458                    $self->VPrint(0,"Deleting Mac OS resource fork\n");
    18612459                    ++$$self{CHANGED};
    … …  
    18642462                    my ($buf, $err);
    18652463                    local (*SRC, *DST);
    1866                     if (open SRC, "$infile/rsrc") {
    1867                         if (open DST, ">$outfile/rsrc") {
     2464                    if ($self->Open(\*SRC, "$infile/..namedfork/rsrc")) {
     2465                        if ($self->Open(\*DST, "$outfile/..namedfork/rsrc", '>')) {
    18682466                            binmode SRC; # (not necessary for Darwin, but let's be thorough)
    18692467                            binmode DST;
    … …  
    18802478                        $err = 'opening';
    18812479                    }
    1882                     $rtnVal = 0 if $err and $self->Error("Error $err Mac OS resource fork", 1);
     2480                    $rtnVal = 0 if $err and $self->Error("Error $err Mac OS resource fork", 2);
    18832481                }
    18842482            }
    18852483            # erase input file if renaming while editing information in place
    1886             unlink $infile or $self->Warn('Error erasing original file') if $eraseIn;
     2484            $self->Unlink($infile) or $self->Warn('Error erasing original file') if $eraseIn;
    18872485        }
    18882486    }
    … …  
    18932491        # erase the output file if we weren't successful
    18942492        if ($rtnVal <= 0) {
    1895             unlink $outfile;
     2493            $self->Unlink($outfile);
    18962494        # else rename temporary file if necessary
    18972495        } elsif ($tmpfile) {
    1898             CopyFileAttrs($infile, $tmpfile);   # copy attributes to new file
    1899             unless (rename($tmpfile, $infile)) {
     2496            $self->CopyFileAttrs($infile, $tmpfile);    # copy attributes to new file
     2497            unless ($self->Rename($tmpfile, $infile)) {
    19002498                # some filesystems won't overwrite with 'rename', so try erasing original
    1901                 if (not unlink($infile)) {
    1902                     unlink $tmpfile;
     2499                if (not $self->Unlink($infile)) {
     2500                    $self->Unlink($tmpfile);
    19032501                    $self->Error('Error renaming temporary file');
    19042502                    $rtnVal = 0;
    1905                 } elsif (not rename($tmpfile, $infile)) {
     2503                } elsif (not $self->Rename($tmpfile, $infile)) {
    19062504                    $self->Error('Error renaming temporary file after deleting original');
    19072505                    $rtnVal = 0;
    19082506                }
    19092507            }
    1910         }
    1911     }
    1912     # set FileModifyDate if requested (and if possible!)
    1913     if (defined $fileModifyDate and $rtnVal > 0 and
    1914         ($closeOut or ($closeIn and defined $outBuff)) and
    1915         $self->SetFileModifyDate($closeOut ? $outfile : $infile, $originalTime) > 0)
    1916     {
    1917         ++$self->{CHANGED}; # we changed something
     2508            # the output file should now have the name of the original infile
     2509            $outfile = $infile if $rtnVal > 0;
     2510        }
     2511    }
     2512    # set filesystem attributes if requested (and if possible!)
     2513    if ($rtnVal > 0 and ($closeOut or (defined $outBuff and ($closeIn or UNIVERSAL::isa($infile,'GLOB'))))) {
     2514        my $target = $closeOut ? $outfile : $infile;
     2515        # set file permissions if requested
     2516        ++$$self{CHANGED} if $self->SetSystemTags($target) > 0;
     2517        if ($closeIn) { # (no use setting file times unless the input file is closed)
     2518            ++$$self{CHANGED} if $setModDate and $self->SetFileModifyDate($target, $originalTime, undef, 1) > 0;
     2519            # set FileCreateDate if requested (and if possible!)
     2520            ++$$self{CHANGED} if $setCreateDate and $self->SetFileModifyDate($target, $createTime, 'FileCreateDate', 1) > 0;
     2521            # create hard link if requested and no output filename specified (and if possible!)
     2522            ++$$self{CHANGED} if defined $hardLink and $self->SetFileName($target, $hardLink, 'HardLink');
     2523            ++$$self{CHANGED} if defined $symLink and $self->SetFileName($target, $symLink, 'SymLink');
     2524            defined $testName and $self->SetFileName($target, $testName, 'Test');
     2525        }
    19182526    }
    19192527    # check for write error and set appropriate error message and return value
    … …  
    19222530        $rtnVal = 0;    # return 0 on failure
    19232531    } elsif ($rtnVal > 0) {
    1924         ++$rtnVal unless $self->{CHANGED};
     2532        ++$rtnVal unless $$self{CHANGED};
    19252533    }
    19262534    # set things back to the way they were
    1927     $self->{RAF} = $oldRaf;
     2535    $$self{RAF} = $oldRaf;
    19282536
    19292537    return $rtnVal;
    … …  
    19422550    @groups = split ':', $group if $group;
    19432551
    1944     my $exifTool = new Image::ExifTool;
     2552    my $et = new Image::ExifTool;
    19452553    LoadAllTables();    # first load all our tables
    19462554    my @tableNames = keys %allTables;
    … …  
    19492557    while (@tableNames) {
    19502558        my $table = GetTagTable(pop @tableNames);
     2559        # generate flattened tag names for structure fields if this is an XMP table
     2560        if ($$table{GROUPS} and $$table{GROUPS}{0} eq 'XMP') {
     2561            Image::ExifTool::XMP::AddFlattenedTags($table);
     2562        }
    19512563        my $tagID;
    19522564        foreach $tagID (TagTableKeys($table)) {
    … …  
    19602572                next if $$tagInfo{Hidden};  # ignore hidden tags
    19612573                if (@groups) {
    1962                     my @tg = $exifTool->GetGroup($tagInfo);
     2574                    my @tg = $et->GetGroup($tagInfo);
    19632575                    foreach $group (@groups) {
    19642576                        next GATInfo unless grep /^$group$/i, @tg;
    … …  
    19752587# Get list of all writable tags
    19762588# Inputs: 0) optional group name (or names separated by colons)
    1977 # Returns: tag list (sorted alphbetically)
     2589# Returns: tag list (sorted alphabetically)
    19782590sub GetWritableTags(;$)
    19792591{
    … …  
    19832595    @groups = split ':', $group if $group;
    19842596
    1985     my $exifTool = new Image::ExifTool;
     2597    my $et = new Image::ExifTool;
    19862598    LoadAllTables();
    19872599    my @tableNames = keys %allTables;
    … …  
    19902602        my $tableName = pop @tableNames;
    19912603        my $table = GetTagTable($tableName);
     2604        # generate flattened tag names for structure fields if this is an XMP table
     2605        if ($$table{GROUPS} and $$table{GROUPS}{0} eq 'XMP') {
     2606            Image::ExifTool::XMP::AddFlattenedTags($table);
     2607        }
    19922608        # attempt to load Write tables if autoloaded
    1993         my @path = split(/::/,$tableName);
    1994         if (@path > 3) {
    1995             my $i = $#path - 1;
    1996             $path[$i] = "Write$path[$i]";   # add 'Write' before class name
    1997             my $module = join('::',@path[0..($#path-1)]);
    1998             eval "require $module"; # (fails silently if nothing loaded)
     2609        my @parts = split(/::/,$tableName);
     2610        if (@parts > 3) {
     2611            my $i = $#parts - 1;
     2612            $parts[$i] = "Write$parts[$i]";   # add 'Write' before class name
     2613            my $module = join('::',@parts[0..$i]);
     2614            eval { require $module }; # (fails silently if nothing loaded)
    19992615        }
    20002616        my $tagID;
    … …  
    20062622                $tag or warn("no name for tag!\n"), next;
    20072623                my $writable = $$tagInfo{Writable};
    2008                 next unless $writable or ($table->{WRITABLE} and
     2624                next unless $writable or ($$table{WRITABLE} and
    20092625                    not defined $writable and not $$tagInfo{SubDirectory});
    20102626                next if $$tagInfo{Hidden};  # ignore hidden tags
    20112627                if (@groups) {
    2012                     my @tg = $exifTool->GetGroup($tagInfo);
     2628                    my @tg = $et->GetGroup($tagInfo);
    20132629                    foreach $group (@groups) {
    20142630                        next GWTInfo unless grep /^$group$/i, @tg;
    … …  
    20242640#------------------------------------------------------------------------------
    20252641# Get list of all group names
    2026 # Inputs: 1) Group family number
     2642# Inputs: 0) [optional] ExifTool ref, 1) Group family number
    20272643# Returns: List of group names (sorted alphabetically)
    2028 sub GetAllGroups($)
     2644sub GetAllGroups($;$)
    20292645{
    20302646    local $_;
    20312647    my $family = shift || 0;
     2648    my $self;
     2649    ref $family and $self = $family, $family = shift || 0;
    20322650
    20332651    $family == 3 and return('Doc#', 'Main');
    20342652    $family == 4 and return('Copy#');
     2653    $family == 5 and return('[too many possibilities to list]');
     2654    $family == 6 and return(@Image::ExifTool::Exif::formatName[1..$#Image::ExifTool::Exif::formatName]);
    20352655
    20362656    LoadAllTables();    # first load all our tables
    … …  
    20462666        foreach $tag (TagTableKeys($table)) {
    20472667            my @infoArray = GetTagInfoList($table, $tag);
    2048             foreach $tagInfo (@infoArray) {
    2049                 next unless ($grps = $$tagInfo{Groups}) and ($grp = $$grps{$family});
    2050                 $allGroups{$grp} = 1;
    2051             }
    2052         }
    2053     }
     2668            if ($family == 7) {
     2669                foreach $tagInfo (@infoArray) {
     2670                    my $id = $$tagInfo{TagID};
     2671                    if (not defined $id) {
     2672                        $id = '';   # (just to be safe)
     2673                    } elsif ($id =~ /^\d+$/) {
     2674                        $id = sprintf('0x%x', $id) if $self and $$self{OPTIONS}{HexTagIDs};
     2675                    } else {
     2676                        $id =~ s/([^-_A-Za-z0-9])/sprintf('%.2x',ord $1)/ge;
     2677                    }
     2678                    $allGroups{'ID-' . $id} = 1;
     2679                }
     2680            } else {
     2681                foreach $tagInfo (@infoArray) {
     2682                    next unless ($grps = $$tagInfo{Groups}) and ($grp = $$grps{$family});
     2683                    $allGroups{$grp} = 1;
     2684                }
     2685            }
     2686        }
     2687    }
     2688    delete $allGroups{'*'};     # (not a real group)
    20542689    return sort keys %allGroups;
    20552690}
    … …  
    20622697{
    20632698    my $self = shift;
    2064     return @{$self->{WRITE_GROUPS}};
     2699    return @{$$self{WRITE_GROUPS}};
    20652700}
    20662701
    … …  
    20702705sub GetDeleteGroups()
    20712706{
    2072     return sort @delGroups;
     2707    return sort @delGroups, @delGroup2;
     2708}
     2709
     2710#------------------------------------------------------------------------------
     2711# Add user-defined tags at run time
     2712# Inputs: 0) destination table name, 1) tagID/tagInfo pairs for tags to add
     2713# Returns: number of tags added
     2714# Notes: will replace existing tags
     2715sub AddUserDefinedTags($%)
     2716{
     2717    local $_;
     2718    my ($tableName, %addTags) = @_;
     2719    my $table = GetTagTable($tableName) or return 0;
     2720    # add tags to writer lookup
     2721    Image::ExifTool::TagLookup::AddTags(\%addTags, $tableName);
     2722    my $tagID;
     2723    my $num = 0;
     2724    foreach $tagID (keys %addTags) {
     2725        next if $specialTags{$tagID};
     2726        delete $$table{$tagID}; # delete old entry if it existed
     2727        AddTagToTable($table, $tagID, $addTags{$tagID}, 1);
     2728        ++$num;
     2729    }
     2730    return $num;
    20732731}
    20742732
    20752733#==============================================================================
    20762734# Functions below this are not part of the public API
     2735
     2736#------------------------------------------------------------------------------
     2737# Maintain backward compatibility for old GetNewValues function name
     2738sub GetNewValues($$;$)
     2739{
     2740    my ($self, $tag, $nvHashPt) = @_;
     2741    return $self->GetNewValue($tag, $nvHashPt);
     2742}
    20772743
    20782744#------------------------------------------------------------------------------
    … …  
    20872753    # make sure the Perl UTF-8 flag is OFF for the value if perl 5.6 or greater
    20882754    # (otherwise our byte manipulations get corrupted!!)
    2089     if ($] >= 5.006 and (eval 'require Encode; Encode::is_utf8($$valPt)' or $@)) {
     2755    if ($] >= 5.006 and (eval { require Encode; Encode::is_utf8($$valPt) } or $@)) {
     2756        local $SIG{'__WARN__'} = \&SetWarning;
    20902757        # repack by hand if Encode isn't available
    2091         $$valPt = $@ ? pack('C*',unpack('U0C*',$$valPt)) : Encode::encode('utf8',$$valPt);
     2758        $$valPt = $@ ? pack('C*',unpack($] < 5.010000 ? 'U0C*' : 'C0C*',$$valPt)) : Encode::encode('utf8',$$valPt);
    20922759    }
    20932760    # un-escape value if necessary
    … …  
    20972764            $$valPt = Image::ExifTool::XMP::UnescapeXML($$valPt);
    20982765        } elsif ($$self{OPTIONS}{Escape} eq 'HTML') {
    2099             $$valPt = Image::ExifTool::HTML::UnescapeHTML($$valPt);
     2766            $$valPt = Image::ExifTool::HTML::UnescapeHTML($$valPt, $$self{OPTIONS}{Charset});
    21002767        }
    21012768    }
    … …  
    21062773# Inputs: 0) ExifTool ref, 1) value, 2) tagInfo (or Struct item) ref,
    21072774#         3) tag name, 4) group 1 name, 5) conversion type (or undef),
    2108 #         6) [optional] want group
     2775#         6) [optional] want group ("" for structure field)
    21092776# Returns: 0) converted value, 1) error string (or undef on success)
    2110 # Notes: Uses ExifTool "ConvType" member to specify conversion type
     2777# Notes:
     2778# - uses ExifTool "ConvType" member when conversion type is undef
     2779# - conversion types other than 'ValueConv' and 'PrintConv' are treated as 'Raw'
    21112780sub ConvInv($$$$$;$$)
    21122781{
    21132782    my ($self, $val, $tagInfo, $tag, $wgrp1, $convType, $wantGroup) = @_;
    21142783    my ($err, $type);
     2784
     2785    $convType or $convType = $$self{ConvType} || 'PrintConv';
    21152786
    21162787Conv: for (;;) {
    … …  
    21182789            # split value into list if necessary
    21192790            if ($$tagInfo{List}) {
    2120                 my $listSplit = $$tagInfo{AutoSplit} || $self->{OPTIONS}{ListSplit};
    2121                 if (defined $listSplit) {
     2791                my $listSplit = $$tagInfo{AutoSplit} || $$self{OPTIONS}{ListSplit};
     2792                if (defined $listSplit and not $$tagInfo{Struct} and
     2793                    ($wantGroup or not defined $wantGroup))
     2794                {
    21222795                    $listSplit = ',?\s+' if $listSplit eq '1' and $$tagInfo{AutoSplit};
    2123                     my @splitVal = split /$listSplit/, $val;
    2124                     $val = \@splitVal if @splitVal > 1;
    2125                 }
    2126             }
    2127             $type = $convType || $$self{ConvType} || 'PrintConv';
    2128         } elsif ($type ne 'ValueConv') {
     2796                    my @splitVal = split /$listSplit/, $val, -1;
     2797                    $val = @splitVal > 1 ? \@splitVal : @splitVal ? $splitVal[0] : '';
     2798                }
     2799            }
     2800            $type = $convType;
     2801        } elsif ($type eq 'PrintConv') {
    21292802            $type = 'ValueConv';
    2130         } else {   
     2803        } else {
     2804            # split raw value if necessary
     2805            if ($$tagInfo{RawJoin} and $$tagInfo{List} and not ref $val) {
     2806                my @splitVal = split ' ', $val;
     2807                $val = \@splitVal if @splitVal > 1;
     2808            }
    21312809            # finally, do our value check
    21322810            my ($err2, $v);
    2133             if ($tagInfo->{WriteCheck}) {
     2811            if ($$tagInfo{WriteCheck}) {
    21342812                #### eval WriteCheck ($self, $tagInfo, $val)
    2135                 $err2 = eval $tagInfo->{WriteCheck};
     2813                $err2 = eval $$tagInfo{WriteCheck};
    21362814                $@ and warn($@), $err2 = 'Error evaluating WriteCheck';
    21372815            }
    21382816            unless ($err2) {
    2139                 my $table = $tagInfo->{Table};
    2140                 if ($table and $table->{CHECK_PROC} and not $$tagInfo{RawConvInv}) {
    2141                     my $checkProc = $table->{CHECK_PROC};
     2817                my $table = $$tagInfo{Table};
     2818                if ($table and $$table{CHECK_PROC} and not $$tagInfo{RawConvInv}) {
     2819                    my $checkProc = $$table{CHECK_PROC};
    21422820                    if (ref $val eq 'ARRAY') {
    21432821                        # loop through array values
    21442822                        foreach $v (@$val) {
    2145                             $err2 = &$checkProc($self, $tagInfo, \$v);
     2823                            $err2 = &$checkProc($self, $tagInfo, \$v, $convType);
    21462824                            last if $err2;
    21472825                        }
    21482826                    } else {
    2149                         $err2 = &$checkProc($self, $tagInfo, \$val);
     2827                        $err2 = &$checkProc($self, $tagInfo, \$val, $convType);
    21502828                    }
    21512829                }
    21522830            }
    21532831            if (defined $err2) {
    2154                 # skip writing this tag if error string is empty
    2155                 $err2 or goto WriteAlso;
    2156                 $err = "$err2 for $wgrp1:$tag";
    2157                 $self->VPrint(2, "$err\n");
    2158                 undef $val; # value was invalid
     2832                if ($err2) {
     2833                    $err = "$err2 for $wgrp1:$tag";
     2834                    $self->VPrint(2, "$err\n");
     2835                    undef $val;     # value was invalid
     2836                } else {
     2837                    $err = $err2;   # empty error (quietly don't write tag)
     2838                }
    21592839            }
    21602840            last;
    21612841        }
    2162         my $conv = $tagInfo->{$type};
    2163         my $convInv = $tagInfo->{"${type}Inv"};
     2842        my $conv = $$tagInfo{$type};
     2843        my $convInv = $$tagInfo{"${type}Inv"};
    21642844        # nothing to do at this level if no conversion defined
    21652845        next unless defined $conv or defined $convInv;
    … …  
    22122892                }
    22132893            } elsif ($conv) {
    2214                 if (ref $conv eq 'HASH') {
     2894                if (ref $conv eq 'HASH' and (not exists $$tagInfo{"${type}Inv"} or $convInvList)) {
    22152895                    my ($multi, $lc);
    22162896                    # insert alternate language print conversions if required
    22172897                    if ($$self{CUR_LANG} and $type eq 'PrintConv' and
    2218                         ref($lc = $self->{CUR_LANG}{$tag}) eq 'HASH' and
     2898                        ref($lc = $$self{CUR_LANG}{$tag}) eq 'HASH' and
    22192899                        ($lc = $$lc{PrintConv}))
    22202900                    {
    … …  
    22342914                        $conv = \%newConv;
    22352915                    }
     2916                    undef $evalWarning;
    22362917                    if ($$conv{BITMASK}) {
    22372918                        my $lookupBits = $$conv{BITMASK};
    2238                         my ($val2, $err2) = EncodeBits($val, $lookupBits);
     2919                        my ($wbits, $tbits) = @$tagInfo{'BitsPerWord','BitsTotal'};
     2920                        my ($val2, $err2) = EncodeBits($val, $lookupBits, $wbits, $tbits);
    22392921                        if ($err2) {
    22402922                            # ok, try matching a straight value
    … …  
    22552937                        ($val, $multi) = ReverseLookup($val, $conv);
    22562938                    }
    2257                     unless (defined $val) {
    2258                         $err = "Can't convert $wgrp1:$tag (" .
    2259                                ($multi ? 'matches more than one' : 'not in') . " $type)";
     2939                    if (not defined $val) {
     2940                        my $prob = $evalWarning ? lcfirst CleanWarning() : ($multi ? 'matches more than one ' : 'not in ') . $type;
     2941                        $err = "Can't convert $wgrp1:$tag ($prob)";
    22602942                        $self->VPrint(2, "$err\n");
    22612943                        last Conv;
     2944                    } elsif ($evalWarning) {
     2945                        $self->VPrint(2, CleanWarning() . " for $wgrp1:$tag\n");
    22622946                    }
    22632947                } elsif (not $$tagInfo{WriteAlso}) {
    … …  
    22852969
    22862970#------------------------------------------------------------------------------
    2287 # convert tag names to values in a string (ie. "${EXIF:ISO}x $$" --> "100x $")
     2971# Convert tag names to values or variables in a string
     2972# (eg. '${EXIF:ISO}x $$' --> '100x $' without hash ref, or "$info{'EXIF:ISO'}x $" with)
    22882973# Inputs: 0) ExifTool object ref, 1) reference to list of found tags
    22892974#         2) string with embedded tag names, 3) Options:
    … …  
    22912976#              'Error'   - issue minor error on missing tag (and return undef)
    22922977#              'Warn'    - issue minor warning on missing tag (and return undef)
    2293 #               Hash ref - hash for return of tag/value pairs
     2978#              'Silent'  - just return undef on missing tag (no errors/warnings)
     2979#               Hash ref - defined to interpolate as variables in string instead of values
     2980#                          --> receives tag/value pairs for interpolation of the variables
     2981#         4) document group name if extracting from a specific document
     2982#         5) hash ref to cache tag keys for subsequent calls in document loop
    22942983# Returns: string with embedded tag values (or '$info{TAGNAME}' entries with Hash ref option)
    22952984# Notes:
    22962985# - tag names are not case sensitive and may end with '#' for ValueConv value
    22972986# - uses MissingTagValue option if set
    2298 sub InsertTagValues($$$;$)
    2299 {
    2300     my ($self, $foundTags, $line, $opt) = @_;
     2987# - '$GROUP:all' evaluates to 1 if any tag from GROUP exists, or 0 otherwise
     2988# - advanced feature allows Perl expressions inside braces (eg. '${model;tr/ //d}')
     2989# - an error/warning in an advanced expression ("${TAG;EXPR}") generates an error
     2990#   if option set to 'Error', or a warning otherwise
     2991sub InsertTagValues($$$;$$$)
     2992{
     2993    local $_;
     2994    my ($self, $foundTags, $line, $opt, $docGrp, $cache) = @_;
    23012995    my $rtnStr = '';
    2302     while ($line =~ /(.*?)\$(\{?)([-\w]+|\$|\/)(.*)/s) {
    2303         my (@tags, $pre, $var, $bra, $val, $tg, @vals, $type);
    2304         ($pre, $bra, $var, $line) = ($1, $2, $3, $4);
     2996    my ($docNum, $tag);
     2997    if ($docGrp) {
     2998        $docNum = $docGrp =~ /(\d+)$/ ? $1 : 0;
     2999    } else {
     3000        undef $cache;   # no cache if no document groups
     3001    }
     3002    while ($line =~ s/(.*?)\$(\{\s*)?([-\w]*\w|\$|\/)//s) {
     3003        my ($pre, $bra, $var) = ($1, $2, $3);
     3004        my (@tags, $val, $tg, @val, $type, $expr, $didExpr, $level, $asList);
    23053005        # "$$" represents a "$" symbol, and "$/" is a newline
    23063006        if ($var eq '$' or $var eq '/') {
    2307             $var = "\n" if $var eq '/';
     3007            $line =~ s/^\s*\}// if $bra;
     3008            if ($var eq '/') {
     3009                $var = "\n";
     3010            } elsif ($line =~ /^self\b/ and not $rtnStr =~ /\$$/) {
     3011                $var = '$$';    # ("$$self{var}" in string)
     3012            }
    23083013            $rtnStr .= "$pre$var";
    2309             $line =~ s/^\}// if $bra;
    23103014            next;
    23113015        }
    23123016        # allow multiple group names
    2313         while ($line =~ /^:([-\w]+)(.*)/s) {
     3017        while ($line =~ /^:([-\w]*\w)(.*)/s) {
    23143018            my $group = $var;
    23153019            ($var, $line) = ($1, $2);
    … …  
    23183022        # allow trailing '#' to indicate ValueConv value
    23193023        $type = 'ValueConv' if $line =~ s/^#//;
     3024        # special advanced formatting '@' feature to evaluate list values separately
     3025        if ($bra and $line =~ s/^\@(#)?//) {
     3026            $asList = 1;
     3027            $type = 'ValueConv' if $1;
     3028        }
    23203029        # remove trailing bracket if there was a leading one
    2321         $line =~ s/^\}// if $bra;
     3030        # and extract Perl expression from inside brackets if it exists
     3031        if ($bra and $line !~ s/^\s*\}// and $line =~ s/^\s*;\s*(.*?)\s*\}//s) {
     3032            my $part = $1;
     3033            $expr = '';
     3034            for ($level=0; ; --$level) {
     3035                # increase nesting level for each opening brace
     3036                ++$level while $part =~ /\{/g;
     3037                $expr .= $part;
     3038                last unless $level and $line =~ s/^(.*?)\s*\}//s; # get next part
     3039                $part = $1;
     3040                $expr .= '}';  # this brace was part of the expression
     3041            }
     3042            # use default Windows filename filter if expression is empty
     3043            $expr = 'tr(/\\\\?*:|"<>\\0)()d' unless length $expr;
     3044        }
    23223045        push @tags, $var;
    23233046        ExpandShortcuts(\@tags);
    23243047        @tags or $rtnStr .= $pre, next;
     3048        # save advanced formatting expression to allow access by user-defined ValueConv
     3049        $$self{FMT_EXPR} = $expr;
    23253050
    23263051        for (;;) {
    2327             my $tag = shift @tags;
    2328             if ($tag =~ /(.*):(.+)/) {
     3052            # temporarily reset ListJoin option if evaluating list values separately
     3053            my $oldListJoin;
     3054            $oldListJoin = $self->Options(ListJoin => undef) if $asList;
     3055            $tag = shift @tags;
     3056            my $lcTag = lc $tag;
     3057            if ($cache and $lcTag !~ /(^|:)all$/) {
     3058                # remove group from tag name (but not lower-case version)
    23293059                my $group;
    2330                 ($group, $tag) = ($1, $2);
    2331                 # find the specified tag
    2332                 my @matches = grep /^$tag(\s|$)/i, @$foundTags;
    2333                 @matches = $self->GroupMatches($group, \@matches);
    2334                 foreach $tg (@matches) {
    2335                     if (defined $val and $tg =~ / \((\d+)\)$/) {
    2336                         # take the most recently extracted tag
    2337                         my $tagNum = $1;
    2338                         next if $tag !~ / \((\d+)\)$/ or $1 > $tagNum;
    2339                     }
    2340                     $val = $self->GetValue($tg, $type);
    2341                     $tag = $tg;
    2342                     last unless $tag =~ / /;    # all done if we got our best match
     3060                $tag =~ s/^(.*):// and $group = $1;
     3061                # cache tag keys to speed processing for a large number of sub-documents
     3062                # (similar to code in BuildCompositeTags(), but this is case-insensitive)
     3063                my $cacheTag = $$cache{$lcTag};
     3064                unless ($cacheTag) {
     3065                    $cacheTag = $$cache{$lcTag} = [ ];
     3066                    # find all matching keys, organize into groups, and store in cache
     3067                    my $ex = $$self{TAG_EXTRA};
     3068                    my @matches = grep /^$tag(\s|$)/i, @$foundTags;
     3069                    @matches = $self->GroupMatches($group, \@matches) if defined $group;
     3070                    foreach (@matches) {
     3071                        my $doc = $$ex{$_} ? $$ex{$_}{G3} || 0 : 0;
     3072                        if (defined $$cacheTag[$doc]) {
     3073                            next unless $$cacheTag[$doc] =~ / \((\d+)\)$/;
     3074                            my $cur = $1;
     3075                            # keep the most recently extracted tag
     3076                            next if / \((\d+)\)$/ and $1 < $cur;
     3077                        }
     3078                        $$cacheTag[$doc] = $_;
     3079                    }
     3080                }
     3081                my $doc = $lcTag =~ /\b(main|doc(\d+)):/ ? ($2 || 0) : $docNum;
     3082                if ($$cacheTag[$doc]) {
     3083                    $tag = $$cacheTag[$doc];
     3084                    $val = $self->GetValue($tag, $type);
    23433085                }
    23443086            } else {
    2345                 # get the tag value
    2346                 $val = $self->GetValue($tag, $type);
    2347                 unless (defined $val) {
    2348                     # check for tag name with different case
    2349                     ($tg) = grep /^$tag$/i, @$foundTags;
    2350                     if (defined $tg) {
    2351                         $val = $self->GetValue($tg, $type);
    2352                         $tag = $tg;
    2353                     }
    2354                 }
    2355             }
     3087                # add document number to tag if specified and it doesn't already exist
     3088                if ($docGrp and $lcTag !~ /\b(main|doc\d+):/) {
     3089                    $tag = $docGrp . ':' . $tag;
     3090                    $lcTag = lc $tag;
     3091                }
     3092                if ($lcTag eq 'all') {
     3093                    $val = 1;   # always some tag available
     3094                } elsif (defined $$self{OPTIONS}{UserParam}{$lcTag}) {
     3095                    $val = $$self{OPTIONS}{UserParam}{$lcTag};
     3096                } elsif ($tag =~ /(.*):(.+)/) {
     3097                    my $group;
     3098                    ($group, $tag) = ($1, $2);
     3099                    if (lc $tag eq 'all') {
     3100                        # see if any tag from the specified group exists
     3101                        my $match = $self->GroupMatches($group, $foundTags);
     3102                        $val = $match ? 1 : 0;
     3103                    } else {
     3104                        # find the specified tag
     3105                        my @matches = grep /^$tag(\s|$)/i, @$foundTags;
     3106                        @matches = $self->GroupMatches($group, \@matches);
     3107                        foreach $tg (@matches) {
     3108                            if (defined $val and $tg =~ / \((\d+)\)$/) {
     3109                                # take the most recently extracted tag
     3110                                my $tagNum = $1;
     3111                                next if $tag !~ / \((\d+)\)$/ or $1 > $tagNum;
     3112                            }
     3113                            $val = $self->GetValue($tg, $type);
     3114                            $tag = $tg;
     3115                            last unless $tag =~ / /;    # all done if we got our best match
     3116                        }
     3117                    }
     3118                } elsif ($tag eq 'self') {
     3119                    $val = $self; # ("$self{var}" or "$self->{var}" in string)
     3120                } else {
     3121                    # get the tag value
     3122                    $val = $self->GetValue($tag, $type);
     3123                    unless (defined $val) {
     3124                        # check for tag name with different case
     3125                        ($tg) = grep /^$tag$/i, @$foundTags;
     3126                        if (defined $tg) {
     3127                            $val = $self->GetValue($tg, $type);
     3128                            $tag = $tg;
     3129                        }
     3130                    }
     3131                }
     3132            }
     3133            $self->Options(ListJoin => $oldListJoin) if $asList;
    23563134            if (ref $val eq 'ARRAY') {
    2357                 $val = join($self->{OPTIONS}{ListSep}, @$val);
     3135                push @val, @$val;
     3136                undef $val;
     3137                last unless @tags;
    23583138            } elsif (ref $val eq 'SCALAR') {
    2359                 if ($self->{OPTIONS}{Binary} or $$val =~ /^Binary data/) {
     3139                if ($$self{OPTIONS}{Binary} or $$val =~ /^Binary data/) {
    23603140                    $val = $$val;
    23613141                } else {
    23623142                    $val = 'Binary data ' . length($$val) . ' bytes';
    23633143                }
     3144            } elsif (ref $val eq 'HASH') {
     3145                require 'Image/ExifTool/XMPStruct.pl';
     3146                $val = Image::ExifTool::XMP::SerializeStruct($val);
    23643147            } elsif (not defined $val) {
    2365                 last unless @tags;
    2366                 next;
     3148                $val = $$self{OPTIONS}{MissingTagValue} if $asList;
    23673149            }
    23683150            last unless @tags;
    2369             push @vals, $val;
     3151            push @val, $val if defined $val;
    23703152            undef $val;
    23713153        }
    2372         if (@vals) {
    2373             push @vals, $val if defined $val;
    2374             $val = join '', @vals;
     3154        if (@val) {
     3155            push @val, $val if defined $val;
     3156            $val = join $$self{OPTIONS}{ListSep}, @val;
     3157        } else {
     3158            push @val, $val if defined $val; # (so the eval has access to @val if required)
     3159        }
     3160        # evaluate advanced formatting expression if given (eg. "${TAG;EXPR}")
     3161        if (defined $expr and defined $val) {
     3162            local $SIG{'__WARN__'} = \&SetWarning;
     3163            undef $evalWarning;
     3164            $advFmtSelf = $self;
     3165            if ($asList) {
     3166                foreach (@val) {
     3167                    #### eval advanced formatting expression ($_, $self, @val, $advFmtSelf)
     3168                    eval $expr;
     3169                    $@ and $evalWarning = $@;
     3170                }
     3171                # join back together if any values are still defined
     3172                @val = grep defined, @val;
     3173                $val = @val ? join $$self{OPTIONS}{ListSep}, @val : undef;
     3174            } else {
     3175                $_ = $val;
     3176                #### eval advanced formatting expression ($_, $self, @val, $advFmtSelf)
     3177                eval $expr;
     3178                $@ and $evalWarning = $@;
     3179                $val = ref $_ eq 'ARRAY' ? join($$self{OPTIONS}{ListSep}, @$_): $_;
     3180            }
     3181            if ($evalWarning) {
     3182                my $g3 = ($docGrp and $var !~ /\b(main|doc\d+):/i) ? $docGrp . ':' : '';
     3183                my $str = CleanWarning() . " for '$g3${var}'";
     3184                if ($opt) {
     3185                    if ($opt eq 'Error') {
     3186                        $self->Error($str);
     3187                    } elsif ($opt ne 'Silent') {
     3188                        $self->Warn($str);
     3189                    }
     3190                }
     3191            }
     3192            undef $advFmtSelf;
     3193            $didExpr = 1;   # set flag indicating an expression was evaluated
    23753194        }
    23763195        unless (defined $val or ref $opt) {
    2377             $val = $self->{OPTIONS}{MissingTagValue};
     3196            $val = $$self{OPTIONS}{MissingTagValue};
    23783197            unless (defined $val) {
     3198                my $g3 = ($docGrp and $var !~ /\b(main|doc\d+):/i) ? $docGrp . ':' : '';
     3199                my $msg = $didExpr ? "Advanced formatting expression returned undef for '$g3${var}'" :
     3200                                     "Tag '$g3${var}' not defined";
    23793201                no strict 'refs';
    2380                 return undef if $opt and &$opt($self, "Tag '$var' not defined", 1);
     3202                $opt and ($opt eq 'Silent' or &$opt($self, $msg, 2)) and return $$self{FMT_EXPR} = undef;
    23813203                $val = '';
    23823204            }
    … …  
    23843206        if (ref $opt eq 'HASH') {
    23853207            $var .= '#' if $type;
    2386             $rtnStr .= "$pre\$info{'$var'}";
     3208            if (defined $expr) {
     3209                # generate unique variable name for this modified tag value
     3210                my $i = 1;
     3211                ++$i while exists $$opt{"$var.expr$i"};
     3212                $var .= '.expr' . $i;
     3213            }
     3214            $rtnStr .= "$pre\$info{'${var}'}";
    23873215            $$opt{$var} = $val;
    23883216        } else {
    … …  
    23903218        }
    23913219    }
     3220    $$self{FMT_EXPR} = undef;
    23923221    return $rtnStr . $line;
     3222}
     3223
     3224#------------------------------------------------------------------------------
     3225# Reformat date/time value in $_ based on specified format string
     3226# Inputs: 0) date/time format string
     3227sub DateFmt($)
     3228{
     3229    my $et = bless { OPTIONS => { DateFormat => shift, StrictDate => 1 } };
     3230    my $shift;
     3231    if ($advFmtSelf and defined($shift = $$advFmtSelf{OPTIONS}{GlobalTimeShift})) {
     3232        $$et{OPTIONS}{GlobalTimeShift} = $shift;
     3233        $$et{GLOBAL_TIME_OFFSET} = $$advFmtSelf{GLOBAL_TIME_OFFSET};
     3234    }
     3235    $_ = $et->ConvertDateTime($_);
     3236    defined $_ or warn "Error converting date/time\n";
     3237    $$advFmtSelf{GLOBAL_TIME_OFFSET} = $$et{GLOBAL_TIME_OFFSET} if $shift;
     3238}
     3239
     3240#------------------------------------------------------------------------------
     3241# Utility routine to remove duplicate items from default input string
     3242# Inputs: 0) true to set $_ to undef if not changed
     3243# Notes: - for use only in advanced formatting expressions
     3244sub NoDups
     3245{
     3246    my %seen;
     3247    my $sep = $advFmtSelf ? $$advFmtSelf{OPTIONS}{ListSep} : ', ';
     3248    my $new = join $sep, grep { !$seen{$_}++ } split /\Q$sep\E/, $_;
     3249    $_ = ($_[0] and $new eq $_) ? undef : $new;
    23933250}
    23943251
    … …  
    24083265    my $tagInfo;
    24093266    foreach $tagInfo (@tagInfo) {
    2410         return 1 if $$tagInfo{Writable} or $tagInfo->{Table}{WRITABLE};
     3267        return $$tagInfo{Writable} ? 1 : 0 if defined $$tagInfo{Writable};
     3268        return 1 if $$tagInfo{Table}{WRITABLE};
    24113269        # must call WRITE_PROC to autoload writer because this may set the writable tag
    2412         my $writeProc = $tagInfo->{Table}{WRITE_PROC};
    2413         next unless $writeProc;
    2414         &$writeProc();  # dummy call to autoload writer
    2415         return 1 if $$tagInfo{Writable};
     3270        my $writeProc = $$tagInfo{Table}{WRITE_PROC};
     3271        if ($writeProc) {
     3272            no strict 'refs';
     3273            &$writeProc();  # dummy call to autoload writer
     3274            return 1 if $$tagInfo{Writable};
     3275        }
    24163276    }
    24173277    return 0;
    … …  
    24193279
    24203280#------------------------------------------------------------------------------
     3281# Check to see if these are the same file
     3282# Inputs: 0) ExifTool ref, 1) first file name, 2) second file name
     3283# Returns: true if file names reference the same file
     3284sub IsSameFile($$$)
     3285{
     3286    my ($self, $file, $file2) = @_;
     3287    return 0 unless lc $file eq lc $file2;  # (only looking for differences in case)
     3288    my ($isSame, $interrupted);
     3289    my $tmp1 = "${file}_ExifTool_tmp_$$";
     3290    my $tmp2 = "${file2}_ExifTool_tmp_$$";
     3291    {
     3292        local *TMP1;
     3293        local $SIG{INT} = sub { $interrupted = 1 };
     3294        if ($self->Open(\*TMP1, $tmp1, '>')) {
     3295            close TMP1;
     3296            $isSame = 1 if $self->Exists($tmp2);
     3297            $self->Unlink($tmp1);
     3298        }
     3299    }
     3300    if ($interrupted and $SIG{INT}) {
     3301        no strict 'refs';
     3302        &{$SIG{INT}}();
     3303    }
     3304    return $isSame;
     3305}
     3306
     3307#------------------------------------------------------------------------------
     3308# Is this a raw file type?
     3309# Inputs: 0) ExifTool ref
     3310# Returns: true if FileType is a type of RAW image
     3311sub IsRawType($)
     3312{
     3313    my $self = shift;
     3314    return $rawType{$$self{FileType}};
     3315}
     3316
     3317#------------------------------------------------------------------------------
    24213318# Create directory for specified file
    2422 # Inputs: 0) complete file name including path
     3319# Inputs: 0) ExifTool ref, 1) complete file name including path
    24233320# Returns: 1 = directory created, 0 = nothing done, -1 = error
    2424 sub CreateDirectory($)
     3321my $k32CreateDir;
     3322sub CreateDirectory($$)
    24253323{
    24263324    local $_;
    2427     my $file = shift;
     3325    my ($self, $file) = @_;
    24283326    my $rtnVal = 0;
     3327    my $enc = $$self{OPTIONS}{CharsetFileName};
    24293328    my $dir;
    24303329    ($dir = $file) =~ s/[^\/]*$//;  # remove filename from path specification
    2431     if ($dir and not -d $dir) {
     3330    # recode as UTF-8 if necessary
     3331    if ($dir and not $self->IsDirectory($dir)) {
    24323332        my @parts = split /\//, $dir;
    24333333        $dir = '';
    24343334        foreach (@parts) {
    24353335            $dir .= $_;
    2436             if (length $dir and not -d $dir) {
     3336            if (length $dir and not $self->IsDirectory($dir)) {
    24373337                # create directory since it doesn't exist
    2438                 mkdir($dir, 0777) or return -1;
     3338                my $d2 = $dir; # (must make a copy in case EncodeFileName recodes it)
     3339                if ($self->EncodeFileName($d2)) {
     3340                    # handle Windows Unicode directory names
     3341                    unless (eval { require Win32::API }) {
     3342                        $self->Warn('Install Win32::API to create directories with Unicode names');
     3343                        return -1;
     3344                    }
     3345                    unless ($k32CreateDir) {
     3346                        return -1 if defined $k32CreateDir;
     3347                        $k32CreateDir = new Win32::API('KERNEL32', 'CreateDirectoryW', 'PP', 'I');
     3348                        unless ($k32CreateDir) {
     3349                            $self->Warn('Error calling Win32::API::CreateDirectoryW');
     3350                            $k32CreateDir = 0;
     3351                            return -1;
     3352                        }
     3353                    }
     3354                    $k32CreateDir->Call($d2, 0) or return -1;
     3355                } else {
     3356                    mkdir($d2, 0777) or return -1;
     3357                }
    24393358                $rtnVal = 1;
    24403359            }
    … …  
    24473366#------------------------------------------------------------------------------
    24483367# Copy file attributes from one file to another
    2449 # Inputs: 0) source file name, 1) destination file name
     3368# Inputs: 0) ExifTool ref, 1) source file name, 2) destination file name
    24503369# Notes: eventually add support for extended attributes?
    2451 sub CopyFileAttrs($$)
    2452 {
    2453     my ($src, $dst) = @_;
     3370sub CopyFileAttrs($$$)
     3371{
     3372    my ($self, $src, $dst) = @_;
    24543373    my ($mode, $uid, $gid) = (stat($src))[2, 4, 5];
    2455     eval { chmod($mode & 07777, $dst) } if defined $mode;
    2456     eval { chown($uid, $gid, $dst) } if defined $uid and defined $gid;
    2457 }
    2458 
    2459 #------------------------------------------------------------------------------
    2460 # Get new file name
    2461 # Inputs: 0) existing name, 1) new name
     3374    # copy file attributes unless we already set them
     3375    if (defined $mode and not defined $self->GetNewValue('FilePermissions')) {
     3376        eval { chmod($mode & 07777, $dst) };
     3377    }
     3378    my $newUid = $self->GetNewValue('FileUserID');
     3379    my $newGid = $self->GetNewValue('FileGroupID');
     3380    if (defined $uid and defined $gid and (not defined $newUid or not defined $newGid)) {
     3381        defined $newGid and $gid = $newGid;
     3382        defined $newUid and $uid = $newUid;
     3383        eval { chown($uid, $gid, $dst) };
     3384    }
     3385}
     3386
     3387#------------------------------------------------------------------------------
     3388# Get new file path name
     3389# Inputs: 0) existing name (may contain directory),
     3390#         1) new file name, new directory, or new path (dir+name)
    24623391# Returns: new file path name
    24633392sub GetNewFileName($$)
    … …  
    24783407# Inputs: 0) hash reference (keys are tag keys), 1) tag name
    24793408# Returns: next available tag key
    2480 sub NextTagKey($$)
     3409sub NextFreeTagKey($$)
    24813410{
    24823411    my ($info, $tag) = @_;
    … …  
    25013430        $val = $1;    # was unknown
    25023431        if ($val =~ /^0x([\da-fA-F]+)$/) {
     3432            # disable "Hexadecimal number > 0xffffffff non-portable" warning
     3433            local $SIG{'__WARN__'} = sub { };
    25033434            $val = hex($val);   # convert hex value
    25043435        }
    25053436    } else {
    2506         my $qval = quotemeta $val;
     3437        my $qval = $val;
     3438        $qval =~ s/\s+$//;      # remove trailing whitespace
     3439        $qval = quotemeta $qval;
    25073440        my @patterns = (
    25083441            "^$qval\$",         # exact match
    … …  
    25333466        unless ($found) {
    25343467            # call OTHER conversion routine if available
    2535             $val = $$conv{OTHER} ? &{$$conv{OTHER}}($val,1,$conv) : undef;
     3468            if ($$conv{OTHER}) {
     3469                local $SIG{'__WARN__'} = \&SetWarning;
     3470                undef $evalWarning;
     3471                $val = &{$$conv{OTHER}}($val,1,$conv);
     3472            } else {
     3473                $val = undef;
     3474            }
    25363475            $multi = 1 if $matches > 1;
    25373476        }
    … …  
    25433482#------------------------------------------------------------------------------
    25443483# Return true if we are deleting or overwriting the specified tag
    2545 # Inputs: 0) new value hash reference
    2546 #         1) optional tag value (before RawConv) if deleting specific values
     3484# Inputs: 0) ExifTool object ref, 1) new value hash reference
     3485#         2) optional tag value (before RawConv) if deleting specific values
    25473486# Returns: >0 - tag should be overwritten
    25483487#          =0 - the tag should be preserved
    25493488#          <0 - not sure, we need the value to know
    2550 sub IsOverwriting($;$)
    2551 {
    2552     my ($nvHash, $val) = @_;
     3489# Notes: $$nvHash{Value} is updated with the new value when shifting a value
     3490sub IsOverwriting($$;$)
     3491{
     3492    my ($self, $nvHash, $val) = @_;
    25533493    return 0 unless $nvHash;
    25543494    # overwrite regardless if no DelValues specified
    … …  
    25663506        undef $evalWarning;
    25673507        if (ref $conv eq 'CODE') {
    2568             $val = &$conv($val, $$nvHash{Self});
     3508            $val = &$conv($val, $self);
    25693509        } else {
    2570             my $self = $$nvHash{Self};
     3510            my ($priority, @grps);
    25713511            my $tag = $$tagInfo{Name};
    2572             #### eval RawConv ($self, $val, $tag, $tagInfo)
     3512            #### eval RawConv ($self, $val, $tag, $tagInfo, $priority, @grps)
    25733513            $val = eval $conv;
    25743514            $@ and $evalWarning = $@;
    … …  
    25763516        return -1 unless defined $val;
    25773517    }
    2578     # apply time shift if necessary
     3518    # do not overwrite if only creating
     3519    return 0 if $$nvHash{CreateOnly};
     3520    # apply time/number shift if necessary
    25793521    if (defined $shift) {
     3522        my $shiftType = $$tagInfo{Shift};
     3523        unless ($shiftType and $shiftType eq 'Time') {
     3524            unless (IsFloat($val)) {
     3525                # do the ValueConv to try to get a number
     3526                my $conv = $$tagInfo{ValueConv};
     3527                if (defined $conv) {
     3528                    local $SIG{'__WARN__'} = \&SetWarning;
     3529                    undef $evalWarning;
     3530                    if (ref $conv eq 'CODE') {
     3531                        $val = &$conv($val, $self);
     3532                    } elsif (not ref $conv) {
     3533                        #### eval ValueConv ($val, $self)
     3534                        $val = eval $conv;
     3535                        $@ and $evalWarning = $@;
     3536                    }
     3537                    if ($evalWarning) {
     3538                        $self->Warn("ValueConv $$tagInfo{Name}: " . CleanWarning());
     3539                        return 0;
     3540                    }
     3541                }
     3542                unless (defined $val and IsFloat($val)) {
     3543                    $self->Warn("Can't shift $$tagInfo{Name} (not a number)");
     3544                    return 0;
     3545                }
     3546            }
     3547            $shiftType = 'Number';  # allow any number to be shifted
     3548        }
    25803549        require 'Image/ExifTool/Shift.pl';
    2581         my $err = ApplyShift($$tagInfo{Shift}, $shift, $val, $nvHash);
     3550        my $err = $self->ApplyShift($shiftType, $shift, $val, $nvHash);
    25823551        if ($err) {
    2583             $nvHash->{Self}->Warn("$err when shifting $$tagInfo{Name}");
     3552            $self->Warn("$err when shifting $$tagInfo{Name}");
    25843553            return 0;
    25853554        }
     3555        # ensure that the shifted value is valid and reformat if necessary
     3556        my $checkVal = $self->GetNewValue($nvHash);
     3557        return 0 unless defined $checkVal;
    25863558        # don't bother overwriting if value is the same
    25873559        return 0 if $val eq $$nvHash{Value}[0];
    … …  
    25973569
    25983570#------------------------------------------------------------------------------
    2599 # Return true if we are creating the specified tag even if it didn't exist before
    2600 # Inputs: 0) new value hash reference
    2601 # Returns: true if we should add the tag
    2602 sub IsCreating($)
    2603 {
    2604     return $_[0]{IsCreating};
    2605 }
    2606 
    2607 #------------------------------------------------------------------------------
    26083571# Get write group for specified tag
    26093572# Inputs: 0) new value hash reference
    … …  
    26213584{
    26223585    my ($self, $tagInfo, $writeGroup) = @_;
    2623     return $writeGroup unless $writeGroup =~ /^(MakerNotes|XMP|Composite)$/;
     3586    return $writeGroup unless $writeGroup =~ /^(MakerNotes|XMP|Composite|QuickTime)$/;
    26243587    return $self->GetGroup($tagInfo, 1);
    26253588}
    … …  
    26283591# Get new value hash for specified tagInfo/writeGroup
    26293592# Inputs: 0) ExifTool object reference, 1) reference to tag info hash
    2630 #         2) Write group name, 3) Options: 'delete' or 'create'
     3593#         2) Write group name, 3) Options: 'delete' or 'create' new value hash
     3594#         4) optional ProtectSaved value, 5) true if we are deleting a value
    26313595# Returns: new value hash reference for specified write group
    26323596#          (or first new value hash in linked list if write group not specified)
    2633 sub GetNewValueHash($$;$$)
     3597# Notes: May return undef when 'create' is used with ProtectSaved
     3598sub GetNewValueHash($$;$$$$)
    26343599{
    26353600    my ($self, $tagInfo, $writeGroup, $opts) = @_;
    2636     my $nvHash = $self->{NEW_VALUE}{$tagInfo};
     3601    return undef unless $tagInfo;
     3602    my $nvHash = $$self{NEW_VALUE}{$tagInfo};
    26373603
    26383604    my %opts;   # quick lookup for options
    … …  
    26423608    if ($writeGroup) {
    26433609        # find the new value in the list with the specified write group
    2644         while ($nvHash and $nvHash->{WriteGroup} ne $writeGroup) {
    2645             $nvHash = $nvHash->{Next};
     3610        while ($nvHash and $$nvHash{WriteGroup} ne $writeGroup) {
     3611            # QuickTime and All are special cases because all group1 tags may be updated at once
     3612            last if $$nvHash{WriteGroup} =~ /^(QuickTime|All)$/;
     3613            # replace existing entry if WriteGroup is 'All' (avoids confusion of forum10349)
     3614            last if $$tagInfo{WriteGroup} and $$tagInfo{WriteGroup} eq 'All';
     3615            $nvHash = $$nvHash{Next};
    26463616        }
    26473617    }
    26483618    # remove this entry if deleting, or if creating a new entry and
    26493619    # this entry is marked with "Save" flag
    2650     if (defined $nvHash and ($opts{'delete'} or
    2651         ($opts{'create'} and $nvHash->{Save})))
    2652     {
    2653         if ($opts{'delete'}) {
     3620    if (defined $nvHash and ($opts{'delete'} or ($opts{'create'} and $$nvHash{Save}))) {
     3621        my $protect = (defined $_[4] and defined $$nvHash{Save} and $$nvHash{Save} > $_[4]);
     3622        # this is a bit tricky:  we want to add to a protected nvHash only if we
     3623        # are adding a conditional delete ($_[5] true or DelValue with no Shift)
     3624        # or accumulating List items (NoReplace true)
     3625        if ($protect and not ($opts{create} and ($$nvHash{NoReplace} or $_[5] or
     3626            ($$nvHash{DelValue} and not defined $$nvHash{Shift}))))
     3627        {
     3628            return undef;   # honour ProtectSaved value by not writing this tag
     3629        } elsif ($opts{'delete'}) {
    26543630            $self->RemoveNewValueHash($nvHash, $tagInfo);
    26553631            undef $nvHash;
    … …  
    26573633            # save a copy of this new value hash
    26583634            my %copy = %$nvHash;
     3635            # make copy of Value and DelValue lists
    26593636            my $key;
    2660             # make copy of Value and DelValue lists
    26613637            foreach $key (keys %copy) {
    26623638                next unless ref $copy{$key} eq 'ARRAY';
    26633639                $copy{$key} = [ @{$copy{$key}} ];
    26643640            }
    2665             my $saveHash = $self->{SAVE_NEW_VALUE};
     3641            my $saveHash = $$self{SAVE_NEW_VALUE};
    26663642            # add to linked list of saved new value hashes
    2667             $copy{Next} = $saveHash->{$tagInfo};
    2668             $saveHash->{$tagInfo} = \%copy;
    2669             delete $nvHash->{Save};   # don't save it again
     3643            $copy{Next} = $$saveHash{$tagInfo};
     3644            $$saveHash{$tagInfo} = \%copy;
     3645            delete $$nvHash{Save}; # don't save it again
     3646            $$nvHash{AddBefore} = scalar @{$$nvHash{Value}} if $protect and $$nvHash{Value};
    26703647        }
    26713648    }
    … …  
    26753652            TagInfo => $tagInfo,
    26763653            WriteGroup => $writeGroup,
    2677             Self => $self,
     3654            IsNVH => 1, # set flag so we can recognize a new value hash
    26783655        };
    26793656        # add entry to our NEW_VALUE hash
    2680         if ($self->{NEW_VALUE}{$tagInfo}) {
     3657        if ($$self{NEW_VALUE}{$tagInfo}) {
    26813658            # add to end of linked list
    2682             my $lastHash = LastInList($self->{NEW_VALUE}{$tagInfo});
    2683             $lastHash->{Next} = $nvHash;
     3659            my $lastHash = LastInList($$self{NEW_VALUE}{$tagInfo});
     3660            $$lastHash{Next} = $nvHash;
    26843661        } else {
    2685             $self->{NEW_VALUE}{$tagInfo} = $nvHash;
     3662            $$self{NEW_VALUE}{$tagInfo} = $nvHash;
    26863663        }
    26873664    }
    … …  
    27113688        $table = GetTagTable(shift @tableNames);
    27123689        # call write proc if it exists in case it adds tags to the table
    2713         my $writeProc = $table->{WRITE_PROC};
    2714         $writeProc and &$writeProc();
     3690        my $writeProc = $$table{WRITE_PROC};
     3691        if ($writeProc) {
     3692            no strict 'refs';
     3693            &$writeProc();
     3694        }
    27153695        # recursively scan through tables in subdirectories
    27163696        foreach (TagTableKeys($table)) {
    … …  
    27363716{
    27373717    my ($self, $nvHash, $tagInfo) = @_;
    2738     my $firstHash = $self->{NEW_VALUE}{$tagInfo};
     3718    my $firstHash = $$self{NEW_VALUE}{$tagInfo};
    27393719    if ($nvHash eq $firstHash) {
    27403720        # remove first entry from linked list
    2741         if ($nvHash->{Next}) {
    2742             $self->{NEW_VALUE}{$tagInfo} = $nvHash->{Next};
     3721        if ($$nvHash{Next}) {
     3722            $$self{NEW_VALUE}{$tagInfo} = $$nvHash{Next};
    27433723        } else {
    2744             delete $self->{NEW_VALUE}{$tagInfo};
     3724            delete $$self{NEW_VALUE}{$tagInfo};
    27453725        }
    27463726    } else {
    27473727        # find the list element pointing to this hash
    2748         $firstHash = $firstHash->{Next} while $firstHash->{Next} ne $nvHash;
     3728        $firstHash = $$firstHash{Next} while $$firstHash{Next} ne $nvHash;
    27493729        # remove from linked list
    2750         $firstHash->{Next} = $nvHash->{Next};
     3730        $$firstHash{Next} = $$nvHash{Next};
    27513731    }
    27523732    # save the existing entry if necessary
    2753     if ($nvHash->{Save}) {
    2754         my $saveHash = $self->{SAVE_NEW_VALUE};
     3733    if ($$nvHash{Save}) {
     3734        my $saveHash = $$self{SAVE_NEW_VALUE};
    27553735        # add to linked list of saved new value hashes
    2756         $nvHash->{Next} = $saveHash->{$tagInfo};
    2757         $saveHash->{$tagInfo} = $nvHash;
     3736        $$nvHash{Next} = $$saveHash{$tagInfo};
     3737        $$saveHash{$tagInfo} = $nvHash;
    27583738    }
    27593739}
    … …  
    27663746    my ($self, $group) = @_;
    27673747
    2768     return unless $self->{NEW_VALUE};
     3748    return unless $$self{NEW_VALUE};
    27693749
    27703750    # make list of all groups we must remove
    … …  
    27733753
    27743754    my ($out, @keys, $hashKey);
    2775     $out = $self->{OPTIONS}{TextOut} if $self->{OPTIONS}{Verbose} > 1;
     3755    $out = $$self{OPTIONS}{TextOut} if $$self{OPTIONS}{Verbose} > 1;
    27763756
    27773757    # loop though all new values, and remove any in this group
    2778     @keys = keys %{$self->{NEW_VALUE}};
     3758    @keys = keys %{$$self{NEW_VALUE}};
    27793759    foreach $hashKey (@keys) {
    2780         my $nvHash = $self->{NEW_VALUE}{$hashKey};
     3760        my $nvHash = $$self{NEW_VALUE}{$hashKey};
    27813761        # loop through each entry in linked list
    27823762        for (;;) {
    2783             my $nextHash = $nvHash->{Next};
    2784             my $tagInfo = $nvHash->{TagInfo};
     3763            my $nextHash = $$nvHash{Next};
     3764            my $tagInfo = $$nvHash{TagInfo};
    27853765            my ($grp0,$grp1) = $self->GetGroup($tagInfo);
    2786             my $wgrp = $nvHash->{WriteGroup};
     3766            my $wgrp = $$nvHash{WriteGroup};
    27873767            # use group1 if write group is not specific
    27883768            $wgrp = $grp1 if $wgrp eq $grp0;
    … …  
    28053785    my ($self, $tagTablePtr) = @_;
    28063786    my @tagInfoList;
    2807     my $nv = $self->{NEW_VALUE};
     3787    my $nv = $$self{NEW_VALUE};
    28083788    if ($nv) {
    28093789        my $hashKey;
    28103790        foreach $hashKey (keys %$nv) {
    2811             my $tagInfo = $nv->{$hashKey}{TagInfo};
    2812             next if $tagTablePtr and $tagTablePtr ne $tagInfo->{Table};
     3791            my $tagInfo = $$nv{$hashKey}{TagInfo};
     3792            next if $tagTablePtr and $tagTablePtr ne $$tagInfo{Table};
    28133793            push @tagInfoList, $tagInfo;
    28143794        }
    … …  
    28213801# Inputs: 0) ExifTool object reference, 1-N) tag table pointers
    28223802# Returns: hash reference
     3803# Notes: returns only one tagInfo ref for each conditional list
    28233804sub GetNewTagInfoHash($@)
    28243805{
    28253806    my $self = shift;
    28263807    my (%tagInfoHash, $hashKey);
    2827     my $nv = $self->{NEW_VALUE};
     3808    my $nv = $$self{NEW_VALUE};
    28283809    while ($nv) {
    28293810        my $tagTablePtr = shift || last;
    28303811        foreach $hashKey (keys %$nv) {
    2831             my $tagInfo = $nv->{$hashKey}{TagInfo};
    2832             next if $tagTablePtr and $tagTablePtr ne $tagInfo->{Table};
     3812            my $tagInfo = $$nv{$hashKey}{TagInfo};
     3813            next if $tagTablePtr and $tagTablePtr ne $$tagInfo{Table};
    28333814            $tagInfoHash{$$tagInfo{TagID}} = $tagInfo;
    28343815        }
    … …  
    28463827{
    28473828    my ($self, $tagTablePtr, $parent) = @_;
    2848     $parent or $parent = $tagTablePtr->{GROUPS}{0};
     3829    $parent or $parent = $$tagTablePtr{GROUPS}{0};
    28493830    my $tagID;
    28503831    my %addDirHash;
    28513832    my %editDirHash;
    2852     my $addDirs = $self->{ADD_DIRS};
    2853     my $editDirs = $self->{EDIT_DIRS};
     3833    my $addDirs = $$self{ADD_DIRS};
     3834    my $editDirs = $$self{EDIT_DIRS};
    28543835    foreach $tagID (TagTableKeys($tagTablePtr)) {
    28553836        my @infoArray = GetTagInfoList($tagTablePtr,$tagID);
    … …  
    28603841            # (take directory name from SubDirectory DirName if it exists,
    28613842            #  otherwise Group0 name of SubDirectory TagTable or tag Group1 name)
    2862             my $dirName = $tagInfo->{SubDirectory}{DirName};
     3843            my $dirName = $$tagInfo{SubDirectory}{DirName};
    28633844            unless ($dirName) {
    28643845                # use tag name for directory name and save for next time
    28653846                $dirName = $$tagInfo{Name};
    2866                 $tagInfo->{SubDirectory}{DirName} = $dirName;
     3847                $$tagInfo{SubDirectory}{DirName} = $dirName;
    28673848            }
    28683849            # save this directory information if we are writing it
    … …  
    28793860#------------------------------------------------------------------------------
    28803861# Get localized version of tagInfo hash (used by MIE, XMP, PNG and QuickTime)
    2881 # Inputs: 0) tagInfo hash ref, 1) locale code (ie. "en_CA" for MIE)
     3862# Inputs: 0) tagInfo hash ref, 1) locale code (eg. "en_CA" for MIE)
    28823863# Returns: new tagInfo hash ref, or undef if invalid
    28833864# - sets LangCode member in new tagInfo
    … …  
    28973878                           " ($langCode)",
    28983879            LangCode => $langCode,
     3880            SrcTagInfo => $tagInfo, # save reference to original tagInfo
    28993881        };
    29003882        AddTagToTable($table, $tagID, $langInfo);
    … …  
    29053887#------------------------------------------------------------------------------
    29063888# initialize ADD_DIRS and EDIT_DIRS hashes for all directories that need
    2907 # need to be created or will have tags changed in them
     3889# to be created or will have tags changed in them
    29083890# Inputs: 0) ExifTool object reference, 1) file type string (or map hash ref)
    2909 #         2) preferred family 0 group name for creating tags
    2910 # Notes: The ADD_DIRS and EDIT_DIRS keys are the directory names, and the values
    2911 #        are the names of the parent directories (undefined for a top-level directory)
    2912 sub InitWriteDirs($$;$)
    2913 {
    2914     my ($self, $fileType, $preferredGroup) = @_;
    2915     my $editDirs = $self->{EDIT_DIRS} = { };
    2916     my $addDirs = $self->{ADD_DIRS} = { };
     3891#         2) preferred family 0 group for creating tags, 3) alternate preferred group
     3892# Notes:
     3893# - the ADD_DIRS and EDIT_DIRS keys are the directory names, and the values
     3894#   are the names of the parent directories (undefined for a top-level directory)
     3895# - also initializes FORCE_WRITE lookup
     3896sub InitWriteDirs($$;$$)
     3897{
     3898    my ($self, $fileType, $preferredGroup, $altGroup) = @_;
     3899    my $editDirs = $$self{EDIT_DIRS} = { };
     3900    my $addDirs = $$self{ADD_DIRS} = { };
    29173901    my $fileDirs = $dirMap{$fileType};
    29183902    unless ($fileDirs) {
    … …  
    29303914        for ($nvHash=$self->GetNewValueHash($tagInfo); $nvHash; $nvHash=$$nvHash{Next}) {
    29313915            # are we creating this tag? (otherwise just deleting or editing it)
    2932             my $isCreating = $nvHash->{IsCreating};
    2933             if ($isCreating) {
    2934                 # if another group is taking priority, only create
    2935                 # directory if specifically adding tags to this group
    2936                 # or if this tag isn't being added to the priority group
    2937                 $isCreating = 0 if $preferredGroup and
    2938                     $preferredGroup ne $self->GetGroup($tagInfo, 0) and
    2939                     $nvHash->{CreateGroups}{$preferredGroup};
    2940             } else {
    2941                 # creating this directory if any tag is preferred and has a value
    2942                 $isCreating = 1 if $preferredGroup and $$nvHash{Value} and
    2943                     $preferredGroup eq $self->GetGroup($tagInfo, 0);
     3916            my $isCreating = $$nvHash{IsCreating};
     3917            if ($preferredGroup) {
     3918                my $g0 = $self->GetGroup($tagInfo, 0);
     3919                if ($isCreating) {
     3920                    # if another group is taking priority, only create
     3921                    # directory if specifically adding tags to this group
     3922                    # or if this tag isn't being added to the priority group
     3923                    $isCreating = 0 if $preferredGroup ne $g0 and
     3924                        $$nvHash{CreateGroups}{$preferredGroup} and
     3925                        (not $altGroup or $altGroup ne $g0);
     3926                } else {
     3927                    # create this directory if any tag is preferred and has a value
     3928                    # (unless group creation is disabled via the WriteMode option)
     3929                    $isCreating = 1 if $$nvHash{Value} and $preferredGroup eq $g0 and
     3930                        not $$nvHash{EditOnly} and $$self{OPTIONS}{WriteMode} =~ /g/;
     3931                }
    29443932            }
    29453933            # tag belongs to directory specified by WriteGroup, or by
    29463934            # the Group0 name if WriteGroup not defined
    2947             my $dirName = $nvHash->{WriteGroup};
     3935            my $dirName = $$nvHash{WriteGroup};
    29483936            # remove MIE copy number(s) if they exist
    29493937            if ($dirName =~ /^MIE\d*(-[a-z]+)?\d*$/i) {
    … …  
    29513939            }
    29523940            my @dirNames;
     3941            # allow a group name of '*' to force writing EXIF/IPTC/XMP/PNG (ForceWrite tag)
     3942            if ($dirName eq '*' and $$nvHash{Value}) {
     3943                my $val = $$nvHash{Value}[0];
     3944                if ($val) {
     3945                    foreach (qw(EXIF IPTC XMP PNG FixBase)) {
     3946                        next unless $val =~ /\b($_|All)\b/i;
     3947                        push @dirNames, $_;
     3948                        push @dirNames, 'EXIF' if $_ eq 'FixBase';
     3949                        $$self{FORCE_WRITE}{$_} = 1;
     3950                    }
     3951                }
     3952                $dirName = shift @dirNames;
     3953            } elsif ($dirName eq 'QuickTime') {
     3954                # write to specific QuickTime group
     3955                $dirName = $self->GetGroup($tagInfo, 1);
     3956            }
    29533957            while ($dirName) {
    29543958                my $parent = $$fileDirs{$dirName};
    … …  
    29633967        }
    29643968    }
    2965     if (%{$self->{DEL_GROUP}}) {
     3969    if (%{$$self{DEL_GROUP}}) {
    29663970        # add delete groups to list of edited groups
    2967         foreach (keys %{$self->{DEL_GROUP}}) {
     3971        foreach (keys %{$$self{DEL_GROUP}}) {
    29683972            next if /^-/;   # ignore excluded groups
    29693973            my $dirName = $_;
    … …  
    29903994    }
    29913995
    2992     if ($self->{OPTIONS}{Verbose}) {
    2993         my $out = $self->{OPTIONS}{TextOut};
     3996    if ($$self{OPTIONS}{Verbose}) {
     3997        my $out = $$self{OPTIONS}{TextOut};
    29943998        print $out "  Editing tags in: ";
    29953999        foreach (sort keys %$editDirs) { print $out "$_ "; }
    29964000        print $out "\n";
    2997         return unless $self->{OPTIONS}{Verbose} > 1;
     4001        return unless $$self{OPTIONS}{Verbose} > 1;
    29984002        print $out "  Creating tags in: ";
    29994003        foreach (sort keys %$addDirs) { print $out "$_ "; }
    … …  
    30064010# Inputs: 0) ExifTool object reference, 1) source directory information reference
    30074011#         2) tag table reference, 3) optional reference to writing procedure
    3008 # Returns: New directory data or undefined on error
     4012# Returns: New directory data or undefined on error (or empty string to delete directory)
    30094013sub WriteDirectory($$$;$)
    30104014{
    30114015    my ($self, $dirInfo, $tagTablePtr, $writeProc) = @_;
    3012     my ($out, $nvHash);
     4016    my ($out, $nvHash, $delFlag);
    30134017
    30144018    $tagTablePtr or return undef;
    3015     $out = $self->{OPTIONS}{TextOut} if $self->{OPTIONS}{Verbose};
     4019    $out = $$self{OPTIONS}{TextOut} if $$self{OPTIONS}{Verbose};
    30164020    # set directory name from default group0 name if not done already
    30174021    my $dirName = $$dirInfo{DirName};
    30184022    my $dataPt = $$dirInfo{DataPt};
    3019     my $grp0 = $tagTablePtr->{GROUPS}{0};
     4023    my $grp0 = $$tagTablePtr{GROUPS}{0};
    30204024    $dirName or $dirName = $$dirInfo{DirName} = $grp0;
    3021     if (%{$self->{DEL_GROUP}}) {
    3022         my $delGroup = $self->{DEL_GROUP};
     4025    if (%{$$self{DEL_GROUP}}) {
     4026        my $delGroup = $$self{DEL_GROUP};
    30234027        # delete entire directory if specified
    30244028        my $grp1 = $dirName;
    3025         my $delFlag = ($$delGroup{$grp0} or $$delGroup{$grp1});
     4029        $delFlag = ($$delGroup{$grp0} or $$delGroup{$grp1}) unless $permanentDir{$grp0};
     4030        # (never delete an entire QuickTime group)
    30264031        if ($delFlag) {
    3027             unless ($blockExifTypes{$$self{FILE_TYPE}}) {
     4032            if (($grp0 =~ /^(MakerNotes)$/ or $grp1 =~ /^(IFD0|ExifIFD|MakerNotes)$/) and
     4033                $self->IsRawType() and
     4034                # allow non-permanent MakerNote directories to be deleted (ie. NikonCapture)
     4035                (not $$dirInfo{TagInfo} or not defined $$dirInfo{TagInfo}{Permanent} or
     4036                $$dirInfo{TagInfo}{Permanent}))
     4037            {
     4038                $self->WarnOnce("Can't delete $1 from $$self{FileType}",1);
     4039                undef $grp1;
     4040            } elsif (not $blockExifTypes{$$self{FILE_TYPE}}) {
    30284041                # restrict delete logic to prevent entire tiff image from being killed
    30294042                # (don't allow IFD0 to be deleted, and delete only ExifIFD if EXIF specified)
    … …  
    30344047                    # allow anything to be deleted from PostScript files
    30354048                } elsif ($grp1 eq 'IFD0') {
    3036                     my $type = $self->{TIFF_TYPE} || $self->{FILE_TYPE};
     4049                    my $type = $$self{TIFF_TYPE} || $$self{FILE_TYPE};
    30374050                    $$delGroup{IFD0} and $self->Warn("Can't delete IFD0 from $type",1);
    30384051                    undef $grp1;
    … …  
    30434056            if ($grp1) {
    30444057                if ($dataPt or $$dirInfo{RAF}) {
    3045                     ++$self->{CHANGED};
     4058                    ++$$self{CHANGED};
    30464059                    $out and print $out "  Deleting $grp1\n";
     4060                    $self->Warn('ICC_Profile deleted. Image colors may be affected') if $grp1 eq 'ICC_Profile';
    30474061                    # can no longer validate TIFF_END if deleting an entire IFD
    3048                     delete $self->{TIFF_END} if $dirName =~ /IFD/;
     4062                    delete $$self{TIFF_END} if $dirName =~ /IFD/;
    30494063                }
    30504064                # don't add back into the wrong location
    … …  
    30564070                    # also check grandparent because some routines create 2 levels in 1
    30574071                    my $right2 = $$self{ADD_DIRS}{$right} || '';
    3058                     if (not $$dirInfo{Parent} or $$dirInfo{Parent} eq $right or
    3059                         $$dirInfo{Parent} eq $right2)
    3060                     {
    3061                         # create new empty directory
     4072                    my $parent = $$dirInfo{Parent};
     4073                    if (not $parent or $parent eq $right or $parent eq $right2) {
     4074                        # prevent duplicate directories from being recreated at the same path
     4075                        my $path = join '-', @{$$self{PATH}}, $dirName;
     4076                        $$self{Recreated} or $$self{Recreated} = { };
     4077                        if ($$self{Recreated}{$path}) {
     4078                            my $p = $parent ? " in $parent" : '';
     4079                            $self->Warn("Not recreating duplicate $grp1$p",1);
     4080                            return '';
     4081                        }
     4082                        $$self{Recreated}{$path} = 1;
     4083                        # empty the directory
    30624084                        my $data = '';
    3063                         my %dirInfo = (
    3064                             DirName    => $$dirInfo{DirName},
    3065                             Parent     => $$dirInfo{Parent},
    3066                             DirStart   => 0,
    3067                             DirLen     => 0,
    3068                             DataPt     => \$data,
    3069                             NewDataPos => $$dirInfo{NewDataPos},
    3070                             Fixup      => $$dirInfo{Fixup},
    3071                         );
    3072                         $dirInfo = \%dirInfo;
     4085                        $$dirInfo{DataPt}   = \$data;
     4086                        $$dirInfo{DataLen}  = 0;
     4087                        $$dirInfo{DirStart} = 0;
     4088                        $$dirInfo{DirLen}   = 0;
     4089                        delete $$dirInfo{RAF};
     4090                        delete $$dirInfo{Base};
     4091                        delete $$dirInfo{DataPos};
    30734092                    } else {
    3074                         $self->Warn("Not recreating $grp1 in $$dirInfo{Parent} (should be in $right)",1);
     4093                        $self->Warn("Not recreating $grp1 in $parent (should be in $right)",1);
    30754094                        return '';
    30764095                    }
    … …  
    30834102    # use default proc from tag table if no proc specified
    30844103    $writeProc or $writeProc = $$tagTablePtr{WRITE_PROC} or return undef;
     4104
     4105    # are we rewriting a pre-existing directory?
     4106    my $isRewriting = ($$dirInfo{DirLen} or (defined $dataPt and length $$dataPt) or $$dirInfo{RAF});
    30854107
    30864108    # copy or delete new directory as a block if specified
    … …  
    30884110    $blockName = 'EXIF' if $blockName eq 'IFD0';
    30894111    my $tagInfo = $Image::ExifTool::Extra{$blockName} || $$dirInfo{TagInfo};
    3090     while ($tagInfo and ($nvHash = $self->{NEW_VALUE}{$tagInfo}) and IsOverwriting($nvHash)) {
     4112    while ($tagInfo and ($nvHash = $$self{NEW_VALUE}{$tagInfo}) and
     4113        $self->IsOverwriting($nvHash) and not ($$nvHash{CreateOnly} and $isRewriting))
     4114    {
    30914115        # protect against writing EXIF to wrong file types, etc
    30924116        if ($blockName eq 'EXIF') {
    … …  
    30954119                last;
    30964120            }
    3097             unless ($writeProc eq \&Image::ExifTool::WriteTIFF) {
    3098                 # this could happen if we called WriteDirectory for an EXIF directory
    3099                 # without going through WriteTIFF as the WriteProc, which would be bad
    3100                 # because the EXIF block could end up with two TIFF headers
    3101                 $self->Warn('Internal error writing EXIF -- please report');
    3102                 last;
    3103             }
    3104         }
     4121            # this can happen if we call WriteDirectory for an EXIF directory without going
     4122            # through WriteTIFF as the WriteProc (which happens if conditionally replacing
     4123            # the EXIF block and the condition fails), but we never want to do a block write
     4124            # in this case because the EXIF block would end up with two TIFF headers
     4125            last unless $writeProc eq \&Image::ExifTool::WriteTIFF;
     4126        }
     4127        last unless $self->IsOverwriting($nvHash, $dataPt ? $$dataPt : '');
    31054128        my $verb = 'Writing';
    3106         my $newVal = GetNewValues($nvHash);
     4129        my $newVal = $self->GetNewValue($nvHash);
    31074130        unless (defined $newVal and length $newVal) {
     4131            return '' unless $dataPt or $$dirInfo{RAF}; # nothing to do if block never existed
     4132            # don't allow MakerNotes to be removed from RAW files
     4133            if ($blockName eq 'MakerNotes' and $rawType{$$self{FileType}}) {
     4134                $self->Warn("Can't delete MakerNotes from $$self{VALUE}{FileType}",1);
     4135                return undef;
     4136            }
    31084137            $verb = 'Deleting';
    31094138            $newVal = '';
    … …  
    31114140        $$dirInfo{BlockWrite} = 1;  # set flag indicating we did a block write
    31124141        $out and print $out "  $verb $blockName as a block\n";
    3113         ++$self->{CHANGED};
     4142        ++$$self{CHANGED};
    31144143        return $newVal;
    31154144    }
    31164145    # guard against writing the same directory twice
    3117     if (defined $dataPt and defined $$dirInfo{DirStart} and defined $$dirInfo{DataPos}) {
     4146    if (defined $dataPt and defined $$dirInfo{DirStart} and defined $$dirInfo{DataPos} and
     4147        not $$dirInfo{NoRefTest})
     4148    {
    31184149        my $addr = $$dirInfo{DirStart} + $$dirInfo{DataPos} + ($$dirInfo{Base}||0) + $$self{BASE};
    31194150        # (Phase One P25 IIQ files have ICC_Profile duplicated in IFD0 and IFD1)
    3120         if ($self->{PROCESSED}{$addr} and ($dirName ne 'ICC_Profile' or $$self{TIFF_TYPE} ne 'IIQ')) {
    3121             if ($self->Error("$dirName pointer references previous $self->{PROCESSED}{$addr} directory", 1)) {
     4151        if ($$self{PROCESSED}{$addr} and ($dirName ne 'ICC_Profile' or $$self{TIFF_TYPE} ne 'IIQ')) {
     4152            if (defined $$dirInfo{DirLen} and not $$dirInfo{DirLen} and $dirName ne $$self{PROCESSED}{$addr}) {
     4153                # it is hypothetically possible to have 2 different directories
     4154                # with the same address if one has a length of zero
     4155            } elsif ($self->Error("$dirName pointer references previous $$self{PROCESSED}{$addr} directory", 2)) {
    31224156                return undef;
    31234157            } else {
    31244158                $self->Warn("Deleting duplicate $dirName directory");
    31254159                $out and print $out "  Deleting $dirName\n";
    3126                 return '';  # delete the duplicate directory
    3127             }
    3128         }
    3129         $self->{PROCESSED}{$addr} = $dirName;
    3130     }
    3131     my $oldDir = $self->{DIR_NAME};
    3132     my $isRewriting = ($$dirInfo{DirLen} or (defined $dataPt and length $$dataPt) or $$dirInfo{RAF});
     4160                # delete the duplicate directory (don't recreate it when writing new
     4161                # tags to prevent propagating a duplicate IFD in cases like when the
     4162                # same ExifIFD exists in both IFD0 and IFD1)
     4163                return '';
     4164            }
     4165        } else {
     4166            $$self{PROCESSED}{$addr} = $dirName;
     4167        }
     4168    }
     4169    my $oldDir = $$self{DIR_NAME};
     4170    my @save = @$self{'Compression','SubfileType'};
    31334171    my $name;
    31344172    if ($out) {
    31354173        $name = ($dirName eq 'MakerNotes' and $$dirInfo{TagInfo}) ?
    3136                  $dirInfo->{TagInfo}{Name} : $dirName;
     4174                 $$dirInfo{TagInfo}{Name} : $dirName;
    31374175        if (not defined $oldDir or $oldDir ne $name) {
    31384176            my $verb = $isRewriting ? 'Rewriting' : 'Creating';
    … …  
    31414179    }
    31424180    my $saveOrder = GetByteOrder();
    3143     my $oldChanged = $self->{CHANGED};
    3144     $self->{DIR_NAME} = $dirName;
    3145     push @{$self->{PATH}}, $$dirInfo{DirName};
     4181    my $oldChanged = $$self{CHANGED};
     4182    $$self{DIR_NAME} = $dirName;
     4183    push @{$$self{PATH}}, $dirName;
    31464184    $$dirInfo{IsWriting} = 1;
    3147     my $newData = &$writeProc($self, $dirInfo, $tagTablePtr);
    3148     pop @{$self->{PATH}};
     4185    my $newData;
     4186    {
     4187        no strict 'refs';
     4188        $newData = &$writeProc($self, $dirInfo, $tagTablePtr);
     4189    }
     4190    pop @{$$self{PATH}};
    31494191    # nothing changed if error occurred or nothing was created
    3150     $self->{CHANGED} = $oldChanged unless defined $newData and (length($newData) or $isRewriting);
    3151     $self->{DIR_NAME} = $oldDir;
     4192    $$self{CHANGED} = $oldChanged unless defined $newData and (length($newData) or $isRewriting);
     4193    $$self{DIR_NAME} = $oldDir;
     4194    @$self{'Compression','SubfileType'} = @save;
    31524195    SetByteOrder($saveOrder);
    31534196    print $out "  Deleting $name\n" if $out and defined $newData and not length $newData;
    … …  
    31734216    my $lo = Get32u($dataPt, $pos + 4 - $pt);
    31744217    return $hi * 4294967296 + $lo;
     4218}
     4219sub GetFixed64s($$)
     4220{
     4221    my ($dataPt, $pos) = @_;
     4222    my $val = Get64s($dataPt, $pos) / 4294967296;
     4223    # remove insignificant digits
     4224    return int($val * 1e10 + ($val>0 ? 0.5 : -0.5)) / 1e10;
    31754225}
    31764226# Decode extended 80-bit float used by Apple SANE and Intel 8087
    … …  
    31914241# Inputs: 0) data reference, 1) length or undef, 2-N) Options:
    31924242# Options: Start => offset to start of data (default=0)
    3193 #          Addr => address to print for data start (default=DataPos+Start)
    3194 #          DataPos => address of start of data
     4243#          Addr => address to print for data start (default=DataPos+Base+Start)
     4244#          DataPos => position of data within block (relative to Base)
     4245#          Base => base offset for pointers from start of file
    31954246#          Width => width of printout (bytes, default=16)
    31964247#          Prefix => prefix to print at start of line (default='')
    … …  
    32134264    $len = $opts{Len} if defined $opts{Len};
    32144265
    3215     $addr = $start + ($opts{DataPos} || 0) unless defined $addr;
     4266    $addr = $start + ($opts{DataPos} || 0) + ($opts{Base} || 0) unless defined $addr;
    32164267    $len = $datLen unless defined $len;
    32174268    if ($maxLen and $len > $maxLen) {
    … …  
    32384289        print $out "[$dat]\n";
    32394290    }
    3240     $more and printf $out "$prefix    [snip $more bytes]\n";
     4291    $more and print $out "$prefix    [snip $more bytes]\n";
    32414292}
    32424293
    … …  
    32504301#        DataPt => reference to value data block
    32514302#        DataPos => location of data block in file
     4303#        Base => base added to all offsets
    32524304#        Size => length of value data within block
    32534305#        Format => value format string
    … …  
    32594311{
    32604312    my ($self, $tagID, $tagInfo, %parms) = @_;
    3261     my $verbose = $self->{OPTIONS}{Verbose};
    3262     my $out = $self->{OPTIONS}{TextOut};
     4313    my $verbose = $$self{OPTIONS}{Verbose};
     4314    my $out = $$self{OPTIONS}{TextOut};
    32634315    my ($tag, $line, $hexID);
    32644316
    … …  
    32854337    my $size = $parms{Size};
    32864338    $size = length $$dataPt unless defined $size or not $dataPt;
    3287     my $indent = $self->{INDENT};
     4339    my $indent = $$self{INDENT};
    32884340
    32894341    # Level 1: print tag/value information
    … …  
    33004352    } else {
    33014353        my $maxLen = 90 - length($line);
    3302         if (defined $parms{Value}) {
    3303             $line .= ' = ' . $self->Printable($parms{Value}, $maxLen);
     4354        my $val = $parms{Value};
     4355        if (defined $val) {
     4356            $val = '[' . join(',',@$val) . ']' if ref $val eq 'ARRAY';
     4357            $line .= ' = ' . $self->Printable($val, $maxLen);
    33044358        } elsif ($dataPt) {
    33054359            my $start = $parms{Start} || 0;
    … …  
    33184372        } else {
    33194373            $tagID =~ s/([\0-\x1f\x7f-\xff])/sprintf('\\x%.2x',ord $1)/ge;
    3320             $line .= "'$tagID'";
     4374            $line .= "'${tagID}'";
    33214375        }
    33224376        $line .= $parms{Extra} if defined $parms{Extra};
    … …  
    33394393
    33404394    # Level 3: do hex dump of value
    3341     if ($verbose > 2 and $parms{DataPt}) {
     4395    if ($verbose > 2 and $parms{DataPt} and (not $tagInfo or not $$tagInfo{ReadFromRAF})) {
    33424396        $parms{Out} = $out;
    33434397        $parms{Prefix} = $indent;
    … …  
    33594413    my $trailer = $$dirInfo{DirName} || 'Unknown';
    33604414    my $pos = $$dirInfo{DataPos};
    3361     my $verbose = $self->{OPTIONS}{Verbose};
    3362     my $htmlDump = $self->{HTML_DUMP};
     4415    my $verbose = $$self{OPTIONS}{Verbose};
     4416    my $htmlDump = $$self{HTML_DUMP};
    33634417    my ($buff, $buf2);
    33644418    my $size = $$dirInfo{DirLen};
    … …  
    33804434            last;
    33814435        }
    3382         my $out = $self->{OPTIONS}{TextOut};
     4436        my $out = $$self{OPTIONS}{TextOut};
    33834437        printf $out "$trailer trailer (%d bytes at offset 0x%.4x):\n", $size, $pos;
    33844438        last unless $verbose > 2;
    … …  
    34204474    my $endPos = $pos + $$dirInfo{DirLen};
    34214475    # account for preview/MPF image trailer
    3422     my $prePos = $self->{VALUE}{PreviewImageStart} || $$self{PreviewImageStart};
    3423     my $preLen = $self->{VALUE}{PreviewImageLength} || $$self{PreviewImageLength};
     4476    my $prePos = $$self{VALUE}{PreviewImageStart} || $$self{PreviewImageStart};
     4477    my $preLen = $$self{VALUE}{PreviewImageLength} || $$self{PreviewImageLength};
    34244478    my $tag = 'PreviewImage';
    34254479    my $mpImageNum = 0;
    … …  
    34314485        # look for MPF images (in the the proper order)
    34324486        ++$mpImageNum;
    3433         $prePos = $self->{VALUE}{"MPImageStart ($mpImageNum)"};
     4487        $prePos = $$self{VALUE}{"MPImageStart ($mpImageNum)"};
    34344488        if (defined $prePos) {
    3435             $preLen = $self->{VALUE}{"MPImageLength ($mpImageNum)"};
     4489            $preLen = $$self{VALUE}{"MPImageLength ($mpImageNum)"};
    34364490        } else {
    3437             $prePos = $self->{VALUE}{'MPImageStart'};
    3438             $preLen = $self->{VALUE}{'MPImageLength'};
     4491            $prePos = $$self{VALUE}{'MPImageStart'};
     4492            $preLen = $$self{VALUE}{'MPImageLength'};
    34394493            $lastOne = 1;
    34404494        }
    … …  
    34544508        last unless $preLen;
    34554509        # dump image if verbose (it is htmlDump'd by ExtractImage)
    3456         if ($self->{OPTIONS}{Verbose}) {
     4510        if ($$self{OPTIONS}{Verbose}) {
    34574511            $$dirInfo{DirName} = $tag;
    34584512            $$dirInfo{DataPos} = $prePos;
    … …  
    34714525{
    34724526    my $element = shift;
    3473     while ($element->{Next}) {
    3474         $element = $element->{Next};
     4527    while ($$element{Next}) {
     4528        $element = $$element{Next};
    34754529    }
    34764530    return $element;
    … …  
    34784532
    34794533#------------------------------------------------------------------------------
    3480 # Print verbose directory information
    3481 # Inputs: 0) ExifTool object reference, 1) directory name or dirInfo ref
    3482 #         2) number of entries in directory (or 0 if unknown)
    3483 #         3) optional size of directory in bytes
    3484 sub VerboseDir($$;$$)
    3485 {
    3486     my ($self, $name, $entries, $size) = @_;
    3487     return unless $self->{OPTIONS}{Verbose};
    3488     if (ref $name eq 'HASH') {
    3489         $size = $$name{DirLen} unless $size;
    3490         $name = $$name{Name} || $$name{DirName};
    3491     }
    3492     my $indent = substr($self->{INDENT}, 0, -2);
    3493     my $out = $self->{OPTIONS}{TextOut};
    3494     my $str = $entries ? " with $entries entries" : '';
    3495     $str .= ", $size bytes" if $size;
    3496     print $out "$indent+ [$name directory$str]\n";
    3497 }
    3498 
    3499 #------------------------------------------------------------------------------
    35004534# Print verbose value while writing
    3501 # Inputs: 0) ExifTool object ref, 1) heading "ie. '+ IPTC:Keywords',
     4535# Inputs: 0) ExifTool object ref, 1) heading "eg. '+ IPTC:Keywords',
    35024536#         2) value, 3) [optional] extra text after value
    35034537sub VerboseValue($$$;$)
    … …  
    35054539    return unless $_[0]{OPTIONS}{Verbose} > 1;
    35064540    my ($self, $str, $val, $xtra) = @_;
    3507     my $out = $self->{OPTIONS}{TextOut};
     4541    my $out = $$self{OPTIONS}{TextOut};
    35084542    $xtra or $xtra = '';
    35094543    my $maxLen = 81 - length($str) - length($xtra);
    35104544    $val = $self->Printable($val, $maxLen);
    3511     print $out "    $str = '$val'$xtra\n";
     4545    print $out "    $str = '${val}'$xtra\n";
    35124546}
    35134547
    … …  
    35914625
    35924626#------------------------------------------------------------------------------
     4627# Generate a new, random GUID
     4628# Inputs: <none>
     4629# Returns: GUID string
     4630my $guidCount;
     4631sub NewGUID()
     4632{
     4633    my @tm = localtime time;
     4634    $guidCount = 0 unless defined $guidCount and ++$guidCount < 0x100;
     4635    return sprintf('%.4d%.2d%.2d%.2d%.2d%.2d%.2X%.4X%.4X%.4X%.4X',
     4636                   $tm[5]+1900, $tm[4]+1, $tm[3], $tm[2], $tm[1], $tm[0], $guidCount,
     4637                   $$ & 0xffff, rand(0x10000), rand(0x10000), rand(0x10000));
     4638}
     4639
     4640#------------------------------------------------------------------------------
     4641# Make TIFF header for raw data
     4642# Inputs: 0) width, 1) height, 2) num colour components, 3) bits, 4) resolution
     4643#         5) color-map data for palette-color image (8 or 16 bit)
     4644# Returns: TIFF header
     4645# Notes: Multi-byte data must be little-endian
     4646sub MakeTiffHeader($$$$;$$)
     4647{
     4648    my ($w, $h, $cols, $bits, $res, $cmap) = @_;
     4649    $res or $res = 72;
     4650    my $saveOrder = GetByteOrder();
     4651    SetByteOrder('II');
     4652    if (not $cmap) {
     4653        $cmap = '';
     4654    } elsif (length $cmap == 3 * 2**$bits) {
     4655        # convert to short
     4656        $cmap = pack 'v*', map { $_ | ($_<<8) } unpack 'C*', $cmap;
     4657    } elsif (length $cmap != 6 * 2**$bits) {
     4658        $cmap = '';
     4659    }
     4660    my $cmo = $cmap ? 12 : 0;   # offset due to ColorMap IFD entry
     4661    my $hdr =
     4662    "\x49\x49\x2a\0\x08\0\0\0\x0e\0" .                  # 0x00 14 menu entries:
     4663    "\xfe\x00\x04\0\x01\0\0\0\x00\0\0\0" .              # 0x0a SubfileType = 0
     4664    "\x00\x01\x04\0\x01\0\0\0" . Set32u($w) .           # 0x16 ImageWidth
     4665    "\x01\x01\x04\0\x01\0\0\0" . Set32u($h) .           # 0x22 ImageHeight
     4666    "\x02\x01\x03\0" . Set32u($cols) .                  # 0x2e BitsPerSample
     4667     Set32u($cols == 1 ? $bits : 0xb6 + $cmo) .
     4668    "\x03\x01\x03\0\x01\0\0\0\x01\0\0\0" .              # 0x3a Compression = 1
     4669    "\x06\x01\x03\0\x01\0\0\0" .                        # 0x46 PhotometricInterpretation
     4670     Set32u($cmap ? 3 : $cols == 1 ? 1 : 2) .
     4671    "\x11\x01\x04\0\x01\0\0\0" .                        # 0x52 StripOffsets
     4672     Set32u(0xcc + $cmo + length($cmap)) .
     4673    "\x15\x01\x03\0\x01\0\0\0" . Set32u($cols) .        # 0x5e SamplesPerPixel
     4674    "\x16\x01\x04\0\x01\0\0\0" . Set32u($h) .           # 0x6a RowsPerStrip
     4675    "\x17\x01\x04\0\x01\0\0\0" .                        # 0x76 StripByteCounts
     4676     Set32u($w * $h * $cols * int(($bits+7)/8)) .
     4677    "\x1a\x01\x05\0\x01\0\0\0" . Set32u(0xbc + $cmo) .  # 0x82 XResolution
     4678    "\x1b\x01\x05\0\x01\0\0\0" . Set32u(0xc4 + $cmo) .  # 0x8e YResolution
     4679    "\x1c\x01\x03\0\x01\0\0\0\x01\0\0\0" .              # 0x9a PlanarConfiguration = 1
     4680    "\x28\x01\x03\0\x01\0\0\0\x02\0\0\0" .              # 0xa6 ResolutionUnit = 2
     4681    ($cmap ?                                            # 0xb2 ColorMap [optional]
     4682    "\x40\x01\x03\0" . Set32u(3 * 2**$bits) . "\xd8\0\0\0" : '') .
     4683    "\0\0\0\0" .                                        # 0xb2+$cmo (no IFD1)
     4684    (Set16u($bits) x 3) .                               # 0xb6+$cmo BitsPerSample value
     4685    Set32u($res) . "\x01\0\0\0" .                       # 0xbc+$cmo XResolution = 72
     4686    Set32u($res) . "\x01\0\0\0" .                       # 0xc4+$cmo YResolution = 72
     4687    $cmap;                                              # 0xcc or 0xd8 (cmap and data go here)
     4688    SetByteOrder($saveOrder);
     4689    return $hdr;
     4690}
     4691
     4692#------------------------------------------------------------------------------
     4693# Return current time in EXIF format
     4694# Inputs: 0) [optional] ExifTool ref, 1) flag to include timezone (0 to disable,
     4695#            undef or 1 to include)
     4696# Returns: time string
     4697# - a consistent value is returned for each processed file
     4698sub TimeNow(;$$)
     4699{
     4700    my ($self, $tzFlag) = @_;
     4701    my $timeNow;
     4702    ref $self or $tzFlag = $self, $self = { };
     4703    if ($$self{Now}) {
     4704        $timeNow = $$self{Now}[0];
     4705    } else {
     4706        my $time = time();
     4707        my @tm = localtime $time;
     4708        my $tz = TimeZoneString(\@tm, $time);
     4709        $timeNow = sprintf("%4d:%.2d:%.2d %.2d:%.2d:%.2d",
     4710                    $tm[5]+1900, $tm[4]+1, $tm[3],
     4711                    $tm[2], $tm[1], $tm[0]);
     4712        $$self{Now} = [ $timeNow, $tz ];
     4713    }
     4714    $timeNow .= $$self{Now}[1] if $tzFlag or not defined $tzFlag;
     4715    return $timeNow;
     4716}
     4717
     4718#------------------------------------------------------------------------------
    35934719# Inverse date/time print conversion (reformat to YYYY:mm:dd HH:MM:SS[.ss][+-HH:MM|Z])
    35944720# Inputs: 0) ExifTool object ref, 1) Date/Time string, 2) timezone flag:
    … …  
    35994725# Returns: formatted date/time string (or undef and issues warning on error)
    36004726# Notes: currently accepts different separators, but doesn't use DateFormat yet
     4727my $strptimeLib; # strptime library name if available
    36014728sub InverseDateTime($$;$$)
    36024729{
    36034730    my ($self, $val, $tzFlag, $dateOnly) = @_;
    36044731    my ($rtnVal, $tz);
     4732    my $fmt = $$self{OPTIONS}{DateFormat};
    36054733    # strip off timezone first if it exists
    3606     if ($val =~ s/([+-])(\d{1,2}):?(\d{2})$//i) {
     4734    if (not $fmt and $val =~ s/([+-])(\d{1,2}):?(\d{2})\s*(DST)?$//i) {
    36074735        $tz = sprintf("$1%.2d:$3", $2);
    3608     } elsif ($val =~ s/Z$//i) {
     4736    } elsif (not $fmt and $val =~ s/Z$//i) {
    36094737        $tz = 'Z';
    36104738    } else {
    36114739        $tz = '';
    3612     }
    3613     # strip of sub seconds
    3614     my $fs = $val =~ /(\.\d+)$/ ? $1 : '';
     4740        # allow special value of 'now'
     4741        return $self->TimeNow($tzFlag) if lc($val) eq 'now';
     4742    }
     4743    # only convert date if a format was specified and the date is recognizable
     4744    if ($fmt) {
     4745        unless (defined $strptimeLib) {
     4746            if (eval { require POSIX::strptime }) {
     4747                $strptimeLib = 'POSIX::strptime';
     4748            } elsif (eval { require Time::Piece }) {
     4749                $strptimeLib = 'Time::Piece';
     4750                # (call use_locale() to convert localized date/time,
     4751                #  only available in Time::Piece 1.32 and later)
     4752                eval { Time::Piece->use_locale() };
     4753            } else {
     4754                $strptimeLib = '';
     4755            }
     4756        }
     4757        my ($lib, $wrn, @a);
     4758TryLib: for ($lib=$strptimeLib; ; $lib='') {
     4759            if (not $lib) {
     4760                last unless $$self{OPTIONS}{StrictDate};
     4761                warn $wrn || "Install POSIX::strptime or Time::Piece for inverse date/time conversions\n";
     4762                return undef;
     4763            } elsif ($lib eq 'POSIX::strptime') {
     4764                @a = eval { POSIX::strptime($val, $fmt) };
     4765            } else {
     4766                # protect against a negative epoch time, it can cause a hard crash in Windows
     4767                if ($^O eq 'MSWin32' and $fmt =~ /%s/ and $val =~ /-\d/) {
     4768                    warn "Can't convert negative epoch time\n";
     4769                    return undef;
     4770                }
     4771                @a = eval {
     4772                    my $t = Time::Piece->strptime($val, $fmt);
     4773                    return ($t->sec, $t->min, $t->hour, $t->mday, $t->_mon, $t->_year);
     4774                };
     4775            }
     4776            if (defined $a[5] and length $a[5]) {
     4777                $a[5] += 1900; # add 1900 to year
     4778            } else {
     4779                $wrn = "Invalid date/time (no year) using $lib\n";
     4780                next;
     4781            }
     4782            ++$a[4] if defined $a[4] and length $a[4];  # add 1 to month
     4783            my $i;
     4784            foreach $i (0..4) {
     4785                if (not defined $a[$i] or not length $a[$i]) {
     4786                    if ($i < 2 or $dateOnly) { # (allow missing minutes/seconds)
     4787                        $a[$i] = '  ';
     4788                    } else {
     4789                        $wrn = "Incomplete date/time specification using $lib\n";
     4790                        next TryLib;
     4791                    }
     4792                } elsif (length($a[$i]) < 2) {
     4793                    $$a[$i] = "0$a[$i]";# pad to 2 digits if necessary
     4794                }
     4795            }
     4796            $val = join(':', @a[5,4,3]) . ' ' . join(':', @a[2,1,0]);
     4797            last;
     4798        }
     4799    }
    36154800    if ($val =~ /(\d{4})/g) {           # get YYYY
    36164801        my $yr = $1;
    3617         my @a = ($val =~ /\d{2}/g);     # get mm, dd, HH, and maybe MM, SS
     4802        my @a = ($val =~ /\d{1,2}/g);   # get mm, dd, HH, and maybe MM, SS
     4803        length($_) < 2 and $_ = "0$_" foreach @a;   # pad to 2 digits if necessary
    36184804        if (@a >= 3) {
    36194805            my $ss = $a[4];             # get SS
    36204806            push @a, '00' while @a < 5; # add MM, SS if not given
     4807            # get sub-seconds if they exist (must be after SS, and have leading ".")
     4808            my $fs = (@a > 5 and $val =~ /(\.\d+)\s*$/) ? $1 : '';
    36214809            # add/remove timezone if necessary
    36224810            if ($tzFlag) {
    36234811                if (not $tz) {
    3624                     if (eval 'require Time::Local') {
     4812                    if (eval { require Time::Local }) {
    36254813                        # determine timezone offset for this time
    3626                         my @args = ($a[4],$a[3],$a[2],$a[1],$a[0]-1,$yr-1900);
     4814                        my @args = ($a[4],$a[3],$a[2],$a[1],$a[0]-1,$yr);
    36274815                        my $diff = Time::Local::timegm(@args) - TimeLocal(@args);
    36284816                        $tz = TimeZoneString($diff / 60);
    … …  
    36344822                $tz = $fs = ''; # remove timezone and sub-seconds
    36354823            }
    3636             if (defined $ss) {
     4824            if (defined $ss and $ss < 60) {
    36374825                $ss = ":$ss";
    36384826            } elsif ($dateOnly) {
    … …  
    36424830            }
    36434831            # construct properly formatted date/time string
     4832            if ($a[0] < 1 or $a[0] > 12) {
     4833                warn "Month '$a[0]' out of range 1..12\n";
     4834                return undef;
     4835            }
     4836            if ($a[1] < 1 or $a[1] > 31) {
     4837                warn "Day '$a[1]' out of range 1..31\n";
     4838                return undef;
     4839            }
     4840            $a[2] > 24 and warn("Hour '$a[2]' out of range 0..24\n"), return undef;
     4841            $a[3] > 59 and warn("Minutes '$a[3]' out of range 0..59\n"), return undef;
    36444842            $rtnVal = "$yr:$a[0]:$a[1] $a[2]:$a[3]$ss$fs$tz";
    36454843        } elsif ($dateOnly) {
    … …  
    36534851#------------------------------------------------------------------------------
    36544852# Set byte order according to our current preferences
    3655 # Inputs: 0) ExifTool object ref
     4853# Inputs: 0) ExifTool object ref, 1) default byte order
    36564854# Returns: new byte order ('II' or 'MM') and sets current byte order
    36574855# Notes: takes the first of the following that is valid:
    36584856#  1) ByteOrder option
    36594857#  2) new value for ExifByteOrder
    3660 #  3) makenote byte order from last file read
    3661 #  4) big endian
    3662 sub SetPreferredByteOrder($)
    3663 {
    3664     my $self = shift;
     4858#  3) default byte order passed to this routine
     4859#  4) makenote byte order from last file read
     4860#  5) big endian
     4861sub SetPreferredByteOrder($;$)
     4862{
     4863    my ($self, $default) = @_;
    36654864    my $byteOrder = $self->Options('ByteOrder') ||
    3666                     $self->GetNewValues('ExifByteOrder') ||
    3667                     $self->{MAKER_NOTE_BYTE_ORDER} || 'MM';
     4865                    $self->GetNewValue('ExifByteOrder') ||
     4866                    $default || $$self{MAKER_NOTE_BYTE_ORDER} || 'MM';
    36684867    unless (SetByteOrder($byteOrder)) {
    3669         warn "Invalid byte order '$byteOrder'\n" if $self->Options('Verbose');
    3670         $byteOrder = $self->{MAKER_NOTE_BYTE_ORDER} || 'MM';
     4868        warn "Invalid byte order '${byteOrder}'\n" if $self->Options('Verbose');
     4869        $byteOrder = $$self{MAKER_NOTE_BYTE_ORDER} || 'MM';
    36714870        SetByteOrder($byteOrder);
    36724871    }
    … …  
    36924891# Notes:
    36934892# - the returned rational will be accurate to at least 8 significant figures if possible
    3694 # - ie. an input of 3.14159265358979 returns a rational of 104348/33215,
     4893# - eg. an input of 3.14159265358979 returns a rational of 104348/33215,
    36954894#   which equals    3.14159265392142 and is accurate to 10 significant figures
     4895# - the returned rational will be reduced to the lowest common denominator except when
     4896#   the input is a fraction in which case the input is returned unchanged
    36964897# - these routines were a bit tricky, but fun to write!
    36974898sub Rationalize($;$)
    … …  
    37414942    return Set32u($val, @_);
    37424943}
     4944sub Set64u(@)
     4945{
     4946    my $val = $_[0];
     4947    my $hi = int($val / 4294967296);
     4948    my $lo = Set32u($val - $hi * 4294967296);
     4949    $hi = Set32u($hi);
     4950    $val = GetByteOrder() eq 'MM' ? $hi . $lo : $lo . $hi;
     4951    $_[1] and substr(${$_[1]}, $_[2], length($val)) = $val;
     4952    return $val;
     4953}
    37434954sub SetRational64u(@) {
    37444955    my ($numer,$denom) = Rationalize($_[0],0xffffffff);
    … …  
    38025013    int32s => \&Set32s,
    38035014    int32u => \&Set32u,
     5015    int64u => \&Set64u,
    38045016    rational32s => \&SetRational32s,
    38055017    rational32u => \&SetRational32u,
    … …  
    38355047# write binary data value (with current byte ordering)
    38365048# Inputs: 0) value, 1) format string
    3837 #         2) optional number of values (1 or string length if not specified)
    3838 #         3) optional data reference, 4) value offset
     5049#         2) number of values:
     5050#               undef = 1 for numerical types, or data length for string/undef types
     5051#                  -1 = number of space-delimited values in the input string
     5052#         3) optional data reference, 4) value offset (may be negative for bytes from end)
    38395053# Returns: packed value (and sets value in data) or undef on error
     5054# Notes: May modify input value to round for integer formats
    38405055sub WriteValue($$;$$$$)
    38415056{
    … …  
    38575072            # validate numerical formats
    38585073            if ($format =~ /^int/) {
    3859                 return undef unless IsInt($val) or IsHex($val);
     5074                unless (IsInt($val) or IsHex($val)) {
     5075                    return undef unless IsFloat($val);
     5076                    # round to nearest integer
     5077                    $val = int($val + ($val < 0 ? -0.5 : 0.5));
     5078                    $_[0] = $val;
     5079                }
    38605080            } elsif (not IsFloat($val)) {
    38615081                return undef unless $format =~ /^rational/ and ($val eq 'inf' or
    … …  
    39205140                        # don't return error string unless more than one value
    39215141                        return undef unless @vals > 1 and wantarray;
    3922                         return (undef, "no match for '$val'");
     5142                        return (undef, "no match for '${val}'");
    39235143                    }
    39245144                }
    … …  
    39385158
    39395159#------------------------------------------------------------------------------
    3940 # get current position in output file
     5160# get current position in output file (or end of file if a scalar reference)
    39415161# Inputs: 0) file or scalar reference
    39425162# Returns: Current position or -1 on error
    … …  
    39745194{
    39755195    my ($self, $trailInfo, $outfile) = @_;
    3976     if ($self->{DEL_GROUP}{Trailer}) {
     5196    if ($$self{DEL_GROUP}{Trailer}) {
    39775197        $self->VPrint(0, "  Deleting trailer ($$trailInfo{Offset} bytes)\n");
    3978         ++$self->{CHANGED};
     5198        ++$$self{CHANGED};
    39795199        return 1;
    39805200    }
    … …  
    39855205        if ($pos > 0) {
    39865206            # shift offsets to final AFCP location and write it out
    3987             $trailInfo->{Fixup}{Shift} += $pos;
    3988             $trailInfo->{Fixup}->ApplyFixup($trailPt);
     5207            $$trailInfo{Fixup}{Shift} += $pos;
     5208            $$trailInfo{Fixup}->ApplyFixup($trailPt);
    39895209        } else {
    39905210            $self->Error("Can't get file position for trailer offset fixup",1);
    … …  
    40075227    $types[0] or shift @types; # (in case undef data ref is passed)
    40085228    # add all possible trailers if none specified (currently only CanonVRD)
    4009     @types or @types = qw(CanonVRD);
    4010     # add trailers as a block
     5229    @types or @types = qw(CanonVRD CanonDR4);
     5230    # add trailers as a block (if not done already)
    40115231    my $type;
    40125232    foreach $type (@types) {
    4013         next unless $self->{NEW_VALUE}{$Image::ExifTool::Extra{$type}};
    4014         my $val = $self->GetNewValues($type) or next;
     5233        next unless $$self{NEW_VALUE}{$Image::ExifTool::Extra{$type}};
     5234        next if $$self{"Did$type"};
     5235        my $val = $self->GetNewValue($type) or next;
     5236        # DR4 record must be wrapped in VRD trailer package
     5237        if ($type eq 'CanonDR4') {
     5238            next if $$self{DidCanonVRD};    # (only allow one VRD trailer)
     5239            require Image::ExifTool::CanonVRD;
     5240            $val = Image::ExifTool::CanonVRD::WrapDR4($val);
     5241            $$self{DidCanonVRD} = 1;
     5242        }
    40155243        my $verb = $trailPt ? 'Writing' : 'Adding';
    40165244        $self->VPrint(0, "  $verb $type as a block\n");
    … …  
    40205248            $trailPt = \$val;
    40215249        }
     5250        $$self{"Did$type"} = 1;
    40225251        ++$$self{CHANGED};
    40235252    }
    … …  
    40305259#         2) segment header, 3) segment data ref, 4) segment type
    40315260# Returns: number of segments written, or 0 on error
     5261# Notes: Writes a single empty segment if data is empty
    40325262sub WriteMultiSegment($$$$;$)
    40335263{
    … …  
    40405270    $maxLen -= 2 if $type eq 'ICC'; # leave room for segment counters
    40415271    my $num = int(($len + $maxLen - 1) / $maxLen);  # number of segments to write
    4042     my $n;
     5272    my $n = 0;
    40435273    # write data, splitting into multiple segments if necessary
    40445274    # (each segment gets its own header)
    4045     for ($n=0; $n<$len; $n+=$maxLen) {
     5275    for (;;) {
    40465276        ++$count;
    40475277        my $size = $len - $n;
    4048         $size > $maxLen and $size = $maxLen;
     5278        if ($size > $maxLen) {
     5279            $size = $maxLen;
     5280            # avoid starting an Extended EXIF segment with a valid TIFF header
     5281            # (because we would interpret that as a separate EXIF segment)
     5282            --$size if $type eq 'EXIF' and $n+$maxLen <= $len-4 and
     5283                substr($$dataPt, $n+$maxLen, 4) =~ /^(MM\0\x2a|II\x2a\0)/;
     5284        }
    40495285        my $buff = substr($$dataPt,$n,$size);
     5286        $n += $size;
    40505287        $size += length($header);
    40515288        if ($type eq 'ICC') {
    … …  
    40565293        my $segHdr = $hdr . pack('n', $size + 2);
    40575294        Write($outfile, $segHdr, $header, $buff) or return 0;
     5295        last if $n >= $len;
    40585296    }
    40595297    return $count;
    … …  
    40815319    if (defined $guid) {
    40825320        $size = length($$extPt);
    4083         my $maxLen = $maxXMPLen - 75; # maximum size without 75 byte header
     5321        my $maxLen = $maxXMPLen - 75; # maximum size without 75-byte header
    40845322        my $off;
    40855323        for ($off=0; $off<$size; $off+=$maxLen) {
    … …  
    41065344    my $outfile = $$dirInfo{OutFile};
    41075345    my $raf = $$dirInfo{RAF};
    4108     my ($ch,$s,$length);
    4109     my $verbose = $self->{OPTIONS}{Verbose};
    4110     my $out = $self->{OPTIONS}{TextOut};
     5346    my ($ch, $s, $length,$err, %doneDir, $isEXV, $creatingEXV);
     5347    my $verbose = $$self{OPTIONS}{Verbose};
     5348    my $out = $$self{OPTIONS}{TextOut};
    41115349    my $rtnVal = 0;
    4112     my ($err, %doneDir);
    41135350    my %dumpParms = ( Out => $out );
    41145351    my ($writeBuffer, $oldOutfile); # used to buffer writing until PreviewImage position is known
    41155352
    4116     # check to be sure this is a valid JPG file
    4117     return 0 unless $raf->Read($s,2) == 2 and $s eq "\xff\xd8";
     5353    # check to be sure this is a valid JPG or EXV file
     5354    unless ($raf->Read($s,2) == 2 and $s eq "\xff\xd8") {
     5355        if (defined $s and length $s) {
     5356            return 0 unless $s eq "\xff\x01" and $raf->Read($s,5) == 5 and $s eq 'Exiv2';
     5357        } else {
     5358            return 0 unless $$self{FILE_TYPE} eq 'EXV';
     5359            $s = 'Exiv2';
     5360            $creatingEXV = 1;
     5361        }
     5362        Write($outfile,"\xff\x01") or $err = 1;
     5363        $isEXV = 1;
     5364    }
    41185365    $dumpParms{MaxLen} = 128 unless $verbose > 3;
    41195366
    4120     delete $self->{PREVIEW_INFO};   # reset preview information
    4121     delete $self->{DEL_PREVIEW};    # reset flag to delete preview
     5367    delete $$self{PREVIEW_INFO};   # reset preview information
     5368    delete $$self{DEL_PREVIEW};    # reset flag to delete preview
    41225369
    41235370    Write($outfile, $s) or $err = 1;
    41245371    # figure out what segments we need to write for the tags we have set
    4125     my $addDirs = $self->{ADD_DIRS};
    4126     my $editDirs = $self->{EDIT_DIRS};
    4127     my $delGroup = $self->{DEL_GROUP};
     5372    my $addDirs = $$self{ADD_DIRS};
     5373    my $editDirs = $$self{EDIT_DIRS};
     5374    my $delGroup = $$self{DEL_GROUP};
    41285375    my $path = $$self{PATH};
    41295376    my $pn = scalar @$path;
    … …  
    41455392            last unless $marker == 0xff;
    41465393        }
    4147         # SOS signifies end of meta information
    4148         if ($marker == 0xda) {
    4149             push(@dirOrder, 'SOS');
    4150             $dirCount{SOS} = 1;
     5394        my $dirName;
     5395        # stop pre-scan at SOS (end of meta information) or EOI (end of image)
     5396        if ($marker == 0xda or $marker == 0xd9) {
     5397            $dirName = $jpegMarker{$marker};
     5398            push(@dirOrder, $dirName);
     5399            $dirCount{$dirName} = 1;
    41515400            last;
    41525401        }
    4153         my $dirName;
    41545402        # handle SOF markers: SOF0-SOF15, except DHT(0xc4), JPGA(0xc8) and DAC(0xcc)
    41555403        if (($marker & 0xf0) == 0xc0 and ($marker == 0xc0 or $marker & 0x03)) {
    … …  
    41675415                $raf->Read($s, $n) == $n or last;
    41685416                $len -= $n;
    4169                 # (Note: only necessary to recognize APP segments that we can create)
     5417                # Note: only necessary to recognize APP segments that we can create,
     5418                # or delete as a group (and the names below should match @delGroups)
    41705419                if ($marker == 0xe0) {
    41715420                    $s =~ /^JFIF\0/         and $dirName = 'JFIF';
    41725421                    $s =~ /^JFXX\0\x10/     and $dirName = 'JFXX';
     5422                    $s =~ /^(II|MM).{4}HEAPJPGM/s and $dirName = 'CIFF';
    41735423                } elsif ($marker == 0xe1) {
    4174                     $s =~ /^$exifAPP1hdr/   and $dirName = 'IFD0';
     5424                    if ($s =~ /^(.{0,4})$exifAPP1hdr(.{1,4})/is) {
     5425                        $dirName = 'IFD0';
     5426                        my ($junk, $bytes) = ($1, $2);
     5427                        # support multi-segment EXIF
     5428                        if (@dirOrder and $dirOrder[-1] =~ /^(IFD0|ExtendedEXIF)$/ and
     5429                            not length $junk and $bytes !~ /^(MM\0\x2a|II\x2a\0)/)
     5430                        {
     5431                            $dirName = 'ExtendedEXIF';
     5432                        }
     5433                    }
    41755434                    $s =~ /^$xmpAPP1hdr/    and $dirName = 'XMP';
    41765435                    $s =~ /^$xmpExtAPP1hdr/ and $dirName = 'XMP';
    41775436                } elsif ($marker == 0xe2) {
    41785437                    $s =~ /^ICC_PROFILE\0/  and $dirName = 'ICC_Profile';
     5438                    $s =~ /^FPXR\0/         and $dirName = 'FlashPix';
     5439                    $s =~ /^MPF\0/          and $dirName = 'MPF';
     5440                } elsif ($marker == 0xe3) {
     5441                    $s =~ /^(Meta|META|Exif)\0\0/ and $dirName = 'Meta';
     5442                } elsif ($marker == 0xe5) {
     5443                    $s =~ /^RMETA\0/        and $dirName = 'RMETA';
    41795444                } elsif ($marker == 0xec) {
    41805445                    $s =~ /^Ducky/          and $dirName = 'Ducky';
    41815446                } elsif ($marker == 0xed) {
    41825447                    $s =~ /^$psAPP13hdr/    and $dirName = 'Photoshop';
     5448                } elsif ($marker == 0xee) {
     5449                    $s =~ /^Adobe/          and $dirName = 'Adobe';
    41835450                }
    41845451                # initialize doneDir as a flag that the directory exists
    … …  
    41935460    }
    41945461    unless ($marker and $marker == 0xda) {
    4195         $self->Error('Corrupted JPEG image');
    4196         return 1;
     5462        $isEXV or $self->Error('Corrupted JPEG image'), return 1;
     5463        $marker and $marker != 0xd9 and $self->Error('Corrupted EXV file'), return 1;
    41975464    }
    41985465    $raf->Seek($pos, 0) or $self->Error('Seek error'), return 1;
    … …  
    42005467# re-write the image
    42015468#
    4202     my ($combinedSegData, $segPos, %extendedXMP);
     5469    my ($combinedSegData, $segPos, $firstSegPos, %extendedXMP);
     5470    my (@iccChunk, $iccChunkCount, $iccChunksTotal);
    42035471    # read through each segment in the JPEG file
    42045472    Marker: for (;;) {
    … …  
    42085476        $raf->ReadLine($segJunk) or $segJunk = '';
    42095477        # remove the 0xff but write the rest of the junk up to this point
     5478        # (this will handle the data after the first 7 bytes of SOF segments)
    42105479        chomp($segJunk);
    42115480        Write($outfile, $segJunk) if length $segJunk;
    42125481        # JPEG markers can be padded with unlimited 0xff's
    42135482        for (;;) {
    4214             $raf->Read($ch, 1) or $self->Error('Format error'), return 1;
    4215             $marker = ord($ch);
    4216             last unless $marker == 0xff;
     5483            if ($raf->Read($ch, 1)) {
     5484                $marker = ord($ch);
     5485                last unless $marker == 0xff;
     5486            } elsif ($creatingEXV) {
     5487                # create EXV from scratch
     5488                $marker = 0xd9; # EOI
     5489                push @dirOrder, 'EOI';
     5490                $dirCount{EOI} = 1;
     5491                last;
     5492            } else {
     5493                $self->Error('Format error');
     5494                return 1;
     5495            }
    42175496        }
    42185497        # read the segment data
    … …  
    42225501            last unless $raf->Read($segData, 7) == 7;
    42235502        # read data for all markers except stand-alone
    4224         # markers 0x00, 0x01 and 0xd0-0xd7 (NULL, TEM, RST0-RST7)
    4225         } elsif ($marker!=0x00 and $marker!=0x01 and ($marker<0xd0 or $marker>0xd7)) {
     5503        # markers 0x00, 0x01 and 0xd0-0xd7 (NULL, TEM, EOI, RST0-RST7)
     5504        } elsif ($marker!=0x00 and $marker!=0x01 and $marker!=0xd9 and
     5505            ($marker<0xd0 or $marker>0xd7))
     5506        {
    42265507            # read record length word
    42275508            last unless $raf->Read($s, 2) == 2;
    … …  
    42365517        my $markerName = JpegMarkerName($marker);
    42375518        my $dirName = shift @dirOrder;      # get directory name
    4238         $$path[$pn] = $markerName;
    42395519#
    42405520# create all segments that must come before this one
    … …  
    42445524            if (exists $$addDirs{JFIF} and not defined $doneDir{JFIF}) {
    42455525                $doneDir{JFIF} = 1;
    4246                 if ($verbose) {
    4247                     print $out "Creating APP0:\n";
    4248                     print $out "  Creating JFIF with default values\n";
    4249                 }
    4250                 my $jfif = "\x01\x02\x01\0\x48\0\x48\0\0";
    4251                 SetByteOrder('MM');
    4252                 my $tagTablePtr = GetTagTable('Image::ExifTool::JFIF::Main');
    4253                 my %dirInfo = (
    4254                     DataPt   => \$jfif,
    4255                     DirStart => 0,
    4256                     DirLen   => length $jfif,
    4257                 );
    4258                 # must temporarily remove JFIF from DEL_GROUP so we can
    4259                 # delete JFIF and add it back again in a single step
    4260                 my $delJFIF = $$delGroup{JFIF};
    4261                 delete $$delGroup{JFIF};
    4262                 my $newData = $self->WriteDirectory(\%dirInfo, $tagTablePtr);
    4263                 $$delGroup{JFIF} = $delJFIF if defined $delJFIF;
    4264                 if (defined $newData and length $newData) {
    4265                     my $app0hdr = "\xff\xe0" . pack('n', length($newData) + 7);
    4266                     Write($outfile,$app0hdr,"JFIF\0",$newData) or $err = 1;
     5526                if (defined $doneDir{Adobe}) {
     5527                    # JFIF overrides Adobe APP14 colour components, so don't allow this
     5528                    # (ref https://docs.oracle.com/javase/8/docs/api/javax/imageio/metadata/doc-files/jpeg_metadata.html)
     5529                    $self->Warn('Not creating JFIF in JPEG with Adobe APP14');
     5530                } else {
     5531                    if ($verbose) {
     5532                        print $out "Creating APP0:\n";
     5533                        print $out "  Creating JFIF with default values\n";
     5534                    }
     5535                    my $jfif = "\x01\x02\x01\0\x48\0\x48\0\0";
     5536                    SetByteOrder('MM');
     5537                    my $tagTablePtr = GetTagTable('Image::ExifTool::JFIF::Main');
     5538                    my %dirInfo = (
     5539                        DataPt   => \$jfif,
     5540                        DirStart => 0,
     5541                        DirLen   => length $jfif,
     5542                        Parent   => 'JFIF',
     5543                    );
     5544                    # must temporarily remove JFIF from DEL_GROUP so we can
     5545                    # delete JFIF and add it back again in a single step
     5546                    my $delJFIF = $$delGroup{JFIF};
     5547                    delete $$delGroup{JFIF};
     5548                    $$path[$pn] = 'JFIF';
     5549                    my $newData = $self->WriteDirectory(\%dirInfo, $tagTablePtr);
     5550                    $$delGroup{JFIF} = $delJFIF if defined $delJFIF;
     5551                    if (defined $newData and length $newData) {
     5552                        my $app0hdr = "\xff\xe0" . pack('n', length($newData) + 7);
     5553                        Write($outfile,$app0hdr,"JFIF\0",$newData) or $err = 1;
     5554                    }
    42675555                }
    42685556            }
    42695557            # don't create anything before APP0 or APP1 EXIF (containing IFD0)
    4270             last if $markerName eq 'APP0' or $dirCount{IFD0};
     5558            last if $markerName eq 'APP0' or $dirCount{IFD0} or $dirCount{ExtendedEXIF};
    42715559            # EXIF information must come immediately after APP0
    42725560            if (exists $$addDirs{IFD0} and not defined $doneDir{IFD0}) {
    … …  
    42745562                $verbose and print $out "Creating APP1:\n";
    42755563                # write new EXIF data
    4276                 $self->{TIFF_TYPE} = 'APP1';
     5564                $$self{TIFF_TYPE} = 'APP1';
    42775565                my $tagTablePtr = GetTagTable('Image::ExifTool::Exif::Main');
    42785566                my %dirInfo = (
    … …  
    42805568                    Parent  => 'APP1',
    42815569                );
     5570                $$path[$pn] = 'APP1';
    42825571                my $buff = $self->WriteDirectory(\%dirInfo, $tagTablePtr, \&WriteTIFF);
    42835572                if (defined $buff and length $buff) {
    4284                     my $size = length($buff) + length($exifAPP1hdr);
    4285                     if ($size <= $maxSegmentLen) {
    4286                         # switch to buffered output if required
    4287                         if (($$self{PREVIEW_INFO} or $$self{LeicaTrailer}) and not $oldOutfile) {
    4288                             $writeBuffer = '';
    4289                             $oldOutfile = $outfile;
    4290                             $outfile = \$writeBuffer;
    4291                             # account for segment, EXIF and TIFF headers
    4292                             $$self{PREVIEW_INFO}{Fixup}{Start} += 18 if $$self{PREVIEW_INFO};
    4293                             $$self{LeicaTrailer}{Fixup}{Start} += 18 if $$self{LeicaTrailer};
     5573                    if (length($buff) + length($exifAPP1hdr) > $maxSegmentLen) {
     5574                        if ($self->Options('NoMultiExif')) {
     5575                            $self->Error('EXIF is too large for JPEG segment');
     5576                        } else {
     5577                            $self->Warn('Creating multi-segment EXIF',1);
    42945578                        }
    4295                         # write the new segment with appropriate header
    4296                         my $app1hdr = "\xff\xe1" . pack('n', $size + 2);
    4297                         Write($outfile,$app1hdr,$exifAPP1hdr,$buff) or $err = 1;
    4298                     } else {
    4299                         delete $self->{PREVIEW_INFO};
    4300                         $self->Warn("EXIF APP1 segment too large! ($size bytes)");
    4301                     }
     5579                    }
     5580                    # switch to buffered output if required
     5581                    if (($$self{PREVIEW_INFO} or $$self{LeicaTrailer}) and not $oldOutfile) {
     5582                        $writeBuffer = '';
     5583                        $oldOutfile = $outfile;
     5584                        $outfile = \$writeBuffer;
     5585                        # account for segment, EXIF and TIFF headers
     5586                        $$self{PREVIEW_INFO}{Fixup}{Start} += 18 if $$self{PREVIEW_INFO};
     5587                        $$self{LeicaTrailer}{Fixup}{Start} += 18 if $$self{LeicaTrailer};
     5588                    }
     5589                    # write as multi-segment
     5590                    my $n = WriteMultiSegment($outfile, 0xe1, $exifAPP1hdr, \$buff, 'EXIF');
     5591                    if (not $n) {
     5592                        $err = 1;
     5593                    } elsif ($n > 1 and $oldOutfile) {
     5594                        # (punt on this because updating the pointers would be a real pain)
     5595                        $self->Error("Can't write multi-segment EXIF with external pointers");
     5596                    }
     5597                    ++$$self{CHANGED};
    43025598                }
    43035599            }
    … …  
    43125608                    Parent => 'APP13',
    43135609                );
     5610                $$path[$pn] = 'APP13';
    43145611                my $buff = $self->WriteDirectory(\%dirInfo, $tagTablePtr);
    43155612                if (defined $buff and length $buff) {
    43165613                    WriteMultiSegment($outfile, 0xed, $psAPP13hdr, \$buff) or $err = 1;
    4317                     ++$self->{CHANGED};
     5614                    ++$$self{CHANGED};
    43185615                }
    43195616            }
    … …  
    43305627                    MaxDataLen  => $maxXMPLen - length($xmpAPP1hdr),
    43315628                );
     5629                $$path[$pn] = 'APP1';
    43325630                my $buff = $self->WriteDirectory(\%dirInfo, $tagTablePtr);
    43335631                if (defined $buff and length $buff) {
    … …  
    43475645                    Parent   => 'APP2',
    43485646                );
     5647                $$path[$pn] = 'APP2';
    43495648                my $buff = $self->WriteDirectory(\%dirInfo, $tagTablePtr);
    43505649                if (defined $buff and length $buff) {
    43515650                    WriteMultiSegment($outfile, 0xe2, "ICC_PROFILE\0", \$buff, 'ICC') or $err = 1;
    4352                     ++$self->{CHANGED};
     5651                    ++$$self{CHANGED};
    43535652                }
    43545653            }
    … …  
    43635662                    Parent   => 'APP12',
    43645663                );
     5664                $$path[$pn] = 'APP12';
    43655665                my $buff = $self->WriteDirectory(\%dirInfo, $tagTablePtr);
    43665666                if (defined $buff and length $buff) {
    … …  
    43715671                        Write($outfile, $app12hdr, 'Ducky', $buff) or $err = 1;
    43725672                    } else {
    4373                         $self->Warn("Ducky APP12 segment too large! ($size bytes)");
     5673                        $self->Warn("APP12 Ducky segment too large! ($size bytes)");
     5674                    }
     5675                }
     5676            }
     5677            # then APP14 Adobe segment
     5678            last if $dirCount{Adobe};
     5679            if (exists $$addDirs{Adobe} and not defined $doneDir{Adobe}) {
     5680                $doneDir{Adobe} = 1;
     5681                my $buff = $self->GetNewValue('Adobe');
     5682                if ($buff) {
     5683                    $verbose and print $out "Creating APP14:\n  Creating Adobe segment\n";
     5684                    my $size = length($buff);
     5685                    if ($size <= $maxSegmentLen) {
     5686                        # write the new segment with appropriate header
     5687                        my $app14hdr = "\xff\xee" . pack('n', $size + 2);
     5688                        Write($outfile, $app14hdr, $buff) or $err = 1;
     5689                        ++$$self{CHANGED};
     5690                    } else {
     5691                        $self->Warn("APP14 Adobe segment too large! ($size bytes)");
    43745692                    }
    43755693                }
    … …  
    43805698                $doneDir{COM} = 1;
    43815699                next if $$delGroup{File} and $$delGroup{File} != 2;
    4382                 my $newComment = $self->GetNewValues('Comment');
    4383                 if (defined $newComment and length($newComment)) {
     5700                my $newComment = $self->GetNewValue('Comment');
     5701                if (defined $newComment) {
    43845702                    if ($verbose) {
    43855703                        print $out "Creating COM:\n";
    … …  
    43875705                    }
    43885706                    WriteMultiSegment($outfile, 0xfe, '', \$newComment) or $err = 1;
    4389                     ++$self->{CHANGED};
     5707                    ++$$self{CHANGED};
    43905708                }
    43915709            }
    43925710            last;   # didn't want to loop anyway
    43935711        }
     5712        $$path[$pn] = $markerName;
    43945713        # decrement counter for this directory since we are about to process it
    43955714        --$dirCount{$dirName};
    … …  
    44095728            Write($outfile, $hdr, $s, $segData) or $err = 1;
    44105729            my ($buff, $endPos, $trailInfo);
    4411             my $delPreview = $self->{DEL_PREVIEW};
     5730            my $delPreview = $$self{DEL_PREVIEW};
    44125731            $trailInfo = IdentifyTrailer($raf) unless $$delGroup{Trailer};
    4413             unless ($oldOutfile or $delPreview or $trailInfo or $$delGroup{Trailer}) {
     5732            my $nvTrail = $self->GetNewValueHash($Image::ExifTool::Extra{Trailer});
     5733            unless ($oldOutfile or $delPreview or $trailInfo or $$delGroup{Trailer} or $nvTrail) {
    44145734                # blindly copy the rest of the file
    44155735                while ($raf->Read($buff, 65536)) {
    … …  
    44425762            # remember position of last data copied
    44435763            $endPos = $raf->Tell() - length($buff);
    4444             # rewrite trailers if they exist
     5764            # write new trailer if specified
     5765            if ($nvTrail) {
     5766                # access new value directly to avoid copying a potentially very large data block
     5767                if ($$nvTrail{Value} and $$nvTrail{Value}[0]) { # (note: "0" will also delete the trailer)
     5768                    $self->VPrint(0, '  Writing new trailer');
     5769                    Write($outfile, $$nvTrail{Value}[0]) or $err = 1;
     5770                    ++$$self{CHANGED};
     5771                } elsif ($raf->Seek(0, 2) and $raf->Tell() != $endPos) {
     5772                    $self->VPrint(0, '  Deleting trailer (', $raf->Tell() - $endPos, ' bytes)');
     5773                    ++$$self{CHANGED};  # changed if there was previously a trailer
     5774                }
     5775                last;   # all done
     5776            }
     5777            # rewrite existing trailers
    44455778            if ($trailInfo) {
    44465779                my $tbuf = '';
    … …  
    44735806                # use this fixup to set the size too (sneaky)
    44745807                my $trailSize = defined($dat) ? length($dat) - $junk : $$self{LeicaTrailer}{Size};
    4475                 $fixup->{Start} -= 4;  $fixup->{Shift} += 4;
    4476                 $fixup->SetMarkerPointers($outfile, 'LeicaTrailer', $trailSize);
    4477                 $fixup->{Start} += 4;  $fixup->{Shift} -= 4;
     5808                $$fixup{Start} -= 4;  $$fixup{Shift} += 4;
     5809                $fixup->SetMarkerPointers($outfile, 'LeicaTrailer', $trailSize) if defined $trailSize;
     5810                $$fixup{Start} += 4;  $$fixup{Shift} -= 4;
    44785811                # clean up and write the buffered data
    44795812                $outfile = $oldOutfile;
    … …  
    44875820            } else {
    44885821                # locate preview image and fix up preview offsets
    4489                 my $scanLen = $$self{Make} =~ /Sony/i ? 65536 : 1024;
     5822                my $scanLen = $$self{Make} =~ /^SONY/i ? 65536 : 1024;
    44905823                if (length($buff) < $scanLen) { # make sure we have enough trailer to scan
    44915824                    my $buf2;
    … …  
    44955828                my $newPos = length($$outfile) - 10; # (subtract 10 for segment and EXIF headers)
    44965829                my $junkLen;
    4497                 # adjust position if image isn't at the start (ie. Olympus E-1/E-300)
    4498                 if ($buff =~ m/(\xff\xd8\xff.|.\xd8\xff\xdb)/sg) {
    4499                     $junkLen = pos($buff) - 4;
     5830                # adjust position if image isn't at the start (eg. Olympus E-1/E-300)
     5831                if ($buff =~ /(\xff\xd8\xff.|.\xd8\xff\xdb)(..)/sg) {
     5832                    my ($jpegHdr, $segLen) = ($1, $2);
     5833                    $junkLen = pos($buff) - 6;
    45005834                    # Sony previewimage trailer has a 32 byte header
    4501                     $junkLen -= 32 if $$self{Make} =~/SONY/i and $junkLen > 32;
     5835                    if ($$self{Make} =~ /^SONY/i and $junkLen > 32) {
     5836                        # with some newer Sony models, the makernotes preview pointer
     5837                        # points to JPEG at end of EXIF inside MPImage preview (what a pain!)
     5838                        if ($jpegHdr eq "\xff\xd8\xff\xe1") {   # is the first segment EXIF?
     5839                            $segLen = unpack('n', $segLen);     # the EXIF segment length
     5840                            # Sony PreviewImage starts with last 2 bytes of EXIF segment
     5841                            # (and first byte is usually "\0", not "\xff", so don't check this)
     5842                            if (length($buff) > $junkLen + $segLen + 6 and
     5843                                substr($buff, $junkLen + $segLen + 3, 3) eq "\xd8\xff\xdb")
     5844                            {
     5845                                $junkLen += $segLen + 2;
     5846                                # (note: this will not copy the trailer after PreviewImage,
     5847                                #  which is a 14kB block full of zeros for the A77)
     5848                            }
     5849                        }
     5850                        $junkLen -= 32;
     5851                    }
    45025852                    $newPos += $junkLen;
    45035853                }
    45045854                # fix up the preview offsets to point to the start of the new image
    4505                 my $previewInfo = $self->{PREVIEW_INFO};
    4506                 delete $self->{PREVIEW_INFO};
     5855                my $previewInfo = $$self{PREVIEW_INFO};
     5856                delete $$self{PREVIEW_INFO};
    45075857                my $fixup = $$previewInfo{Fixup};
    45085858                $newPos += ($$previewInfo{BaseShift} || 0);
    … …  
    45115861                if ($$previewInfo{Relative}) {
    45125862                    # adjust for our base by looking at how far the pointer got shifted
    4513                     $newPos -= $fixup->GetMarkerPointers($outfile, 'PreviewImage');
     5863                    $newPos -= ($fixup->GetMarkerPointers($outfile, 'PreviewImage') || 0);
    45145864                } elsif ($$previewInfo{ChangeBase}) {
    45155865                    # Leica S2 uses relative offsets for the preview only (leica sucks)
    … …  
    45485898                    if ($$delGroup{Trailer}) {
    45495899                        $verbose and print $out "  Deleting unknown trailer ($extra bytes)\n";
    4550                         ++$self->{CHANGED};
     5900                        ++$$self{CHANGED};
    45515901                    } else {
    45525902                        # copy over unknown trailer
    … …  
    45645914            last;   # all done parsing file
    45655915
     5916        } elsif ($marker==0xd9 and $isEXV) {
     5917            # write EXV EOI (any trailer will be lost)
     5918            Write($outfile, "\xff\xd9") or $err = 1;
     5919            $rtnVal = 1;
     5920            last;
     5921
    45665922        } elsif ($marker==0x00 or $marker==0x01 or ($marker>=0xd0 and $marker<=0xd7)) {
    45675923            $verbose and $marker and print $out "JPEG $markerName:\n";
    … …  
    45735929        # NOTE: A 'next' statement after this point will cause $$segDataPt
    45745930        #       not to be written if there is an output file, so in this case
    4575         #       the $self->{CHANGED} flags must be updated
     5931        #       the $$self{CHANGED} flags must be updated
    45765932        #
    45775933        my $segDataPt = \$segData;
    … …  
    45835939            }
    45845940        }
     5941        # group delete of APP segments
     5942        if ($$delGroup{$dirName}) {
     5943            $verbose and print $out "  Deleting $dirName segment\n";
     5944            $self->Warn('ICC_Profile deleted. Image colors may be affected') if $dirName eq 'ICC_Profile';
     5945            ++$$self{CHANGED};
     5946            next Marker;
     5947        }
    45855948        my ($segType, $del);
    45865949        # rewrite this segment only if we are changing a tag which is contained in its
    45875950        # directory (or deleting '*', in which case we need to identify the segment type)
    45885951        while (exists $$editDirs{$markerName} or $$delGroup{'*'}) {
    4589             my $oldChanged = $self->{CHANGED};
    45905952            if ($marker == 0xe0) {              # APP0 (JFIF, CIFF)
    45915953                if ($$segDataPt =~ /^JFIF\0/) {
    … …  
    46315993            } elsif ($marker == 0xe1) {         # APP1 (EXIF, XMP)
    46325994                # check for EXIF data
    4633                 if ($$segDataPt =~ /^$exifAPP1hdr/) {
     5995                if ($$segDataPt =~ /^(.{0,4})$exifAPP1hdr/is) {
     5996                    my $hdrLen = length $exifAPP1hdr;
     5997                    if (length $1) {
     5998                        $hdrLen += length $1;
     5999                        $self->Error('Unknown garbage at start of EXIF segment',1);
     6000                    } elsif ($$segDataPt !~ /^Exif\0/) {
     6001                        $self->Error('Incorrect EXIF segment identifier',1);
     6002                    }
    46346003                    $segType = 'EXIF';
    4635                     $doneDir{IFD0} and $self->Warn('Multiple APP1 EXIF segments');
     6004                    last unless $$editDirs{IFD0};
     6005                    # add this data to the combined data if it exists
     6006                    if (defined $combinedSegData) {
     6007                        $combinedSegData .= substr($$segDataPt,$hdrLen);
     6008                        $segDataPt = \$combinedSegData;
     6009                        $segPos = $firstSegPos;
     6010                        $length = length $combinedSegData;  # update length
     6011                    }
     6012                    # peek ahead to see if the next segment is extended EXIF
     6013                    if ($dirOrder[0] eq 'ExtendedEXIF') {
     6014                        # initialize combined data if necessary
     6015                        unless (defined $combinedSegData) {
     6016                            $combinedSegData = $$segDataPt;
     6017                            $firstSegPos = $segPos;
     6018                            $self->Warn('File contains multi-segment EXIF',1);
     6019                        }
     6020                        next Marker;    # get the next segment to combine
     6021                    }
     6022                    $doneDir{IFD0} and $self->Warn('Multiple APP1 EXIF records');
    46366023                    $doneDir{IFD0} = 1;
    4637                     last unless $$editDirs{IFD0};
    46386024                    # check del groups now so we can change byte order in one step
    46396025                    if ($$delGroup{IFD0} or $$delGroup{EXIF}) {
    … …  
    46456031                    my %dirInfo = (
    46466032                        DataPt   => $segDataPt,
    4647                         DataPos  => $segPos,
    4648                         DirStart => 6,
    4649                         Base     => $segPos + 6,
     6033                        DataPos  => -$hdrLen, # (remember: relative to Base!)
     6034                        DirStart => $hdrLen,
     6035                        Base     => $segPos + $hdrLen,
    46506036                        Parent   => $markerName,
    46516037                        DirName  => 'IFD0',
    … …  
    46556041                    my $buff = $self->WriteDirectory(\%dirInfo, $tagTablePtr, \&WriteTIFF);
    46566042                    if (defined $buff) {
    4657                         # update segment with new data
    4658                         $$segDataPt = $exifAPP1hdr . $buff;
     6043                        undef $$segDataPt;  # free the old buffer
     6044                        $segDataPt = \$buff;
    46596045                    } else {
    46606046                        last Marker unless $self->Options('IgnoreMinorErrors');
    4661                         $self->{CHANGED} = $oldChanged; # nothing changed
     6047                    }
     6048                    # delete segment if IFD contains no entries
     6049                    length $$segDataPt or $del = 1, last;
     6050                    if (length($$segDataPt) + length($exifAPP1hdr) > $maxSegmentLen) {
     6051                        if ($self->Options('NoMultiExif')) {
     6052                            $self->Error('EXIF is too large for JPEG segment');
     6053                        } else {
     6054                            $self->Warn('Writing multi-segment EXIF',1);
     6055                        }
    46626056                    }
    46636057                    # switch to buffered output if required
    … …  
    46706064                        $$self{LeicaTrailer}{Fixup}{Start} += 18 if $$self{LeicaTrailer};
    46716065                    }
    4672                     # delete segment if IFD contains no entries
    4673                     $del = 1 unless length($$segDataPt) > length($exifAPP1hdr);
     6066                    # write as multi-segment
     6067                    my $n = WriteMultiSegment($outfile, $marker, $exifAPP1hdr, $segDataPt, 'EXIF');
     6068                    if (not $n) {
     6069                        $err = 1;
     6070                    } elsif ($n > 1 and $oldOutfile) {
     6071                        # (punt on this because updating the pointers would be a real pain)
     6072                        $self->Error("Can't write multi-segment EXIF with external pointers");
     6073                    }
     6074                    undef $combinedSegData;
     6075                    undef $$segDataPt;
     6076                    next Marker;
    46746077                # check for XMP data
    46756078                } elsif ($$segDataPt =~ /^($xmpAPP1hdr|$xmpExtAPP1hdr)/) {
    … …  
    46886091                                my ($size, $off) = unpack('x67N2', $$segDataPt);
    46896092                                $guid = substr($$segDataPt, 35, 32);
    4690                                 # remember extended data for each GUID
    4691                                 $extXMP = $extendedXMP{$guid};
    4692                                 if ($extXMP) {
    4693                                     $size == $$extXMP{Size} or $extendedXMP{Error} = 'Invalid size';
     6093                                if ($guid =~ /[^A-Za-z0-9]/) { # (technically, should be uppercase)
     6094                                    $extendedXMP{Error} = 'Invalid GUID';
    46946095                                } else {
    4695                                     $extXMP = $extendedXMP{$guid} = { };
     6096                                    # remember extended data for each GUID
     6097                                    $extXMP = $extendedXMP{$guid};
     6098                                    if ($extXMP) {
     6099                                        $size == $$extXMP{Size} or $extendedXMP{Error} = 'Inconsistent size';
     6100                                    } else {
     6101                                        $extXMP = $extendedXMP{$guid} = { };
     6102                                    }
     6103                                    $$extXMP{Size} = $size;
     6104                                    $$extXMP{$off} = substr($$segDataPt, 75);
    46966105                                }
    4697                                 $$extXMP{Size} = $size;
    4698                                 $$extXMP{$off} = substr($$segDataPt, 75);
    46996106                            }
    47006107                        } else {
    … …  
    47076114                        # reconstruct an XMP super-segment
    47086115                        $$segDataPt = $xmpAPP1hdr;
    4709                         $$segDataPt .= $_ foreach @{$extendedXMP{Main}};
     6116                        my $goodGuid = '';
     6117                        foreach (@{$extendedXMP{Main}}) {
     6118                            # get the HasExtendedXMP GUID if it exists
     6119                            if (/:HasExtendedXMP\s*(=\s*['"]|>)(\w{32})/) {
     6120                                # warn of subsequent XMP blocks specifying a different
     6121                                # HasExtendedXMP (have never seen this)
     6122                                if ($goodGuid and $goodGuid ne $2) {
     6123                                    $self->WarnOnce('Multiple XMP segments specifying different extended XMP GUID');
     6124                                }
     6125                                $goodGuid = $2; # GUID for the standard extended XMP
     6126                            }
     6127                            $$segDataPt .= $_;
     6128                        }
     6129                        # GUID of the extended XMP that we want to read
     6130                        my $readGuid = $$self{OPTIONS}{ExtendedXMP} || 0;
     6131                        $readGuid = $goodGuid if $readGuid eq '1';
    47106132                        foreach $guid (sort keys %extendedXMP) {
    4711                             next unless length $guid == 32;     # ignore other keys
     6133                            next unless length $guid == 32;     # ignore other (internal) keys
     6134                            if ($guid ne $readGuid and $readGuid ne '2') {
     6135                                my $non = $guid eq $goodGuid ? '' : 'non-';
     6136                                $self->Warn("Ignored ${non}standard extended XMP (GUID $guid)");
     6137                                next;
     6138                            }
     6139                            if ($guid ne $goodGuid) {
     6140                                $self->Warn("Reading non-standard extended XMP (GUID $guid)");
     6141                            }
    47126142                            $extXMP = $extendedXMP{$guid};
    47136143                            next unless ref $extXMP eq 'HASH';  # (just to be safe)
    … …  
    47236153                                $$segDataPt .= $$extXMP{$_} foreach @offsets;
    47246154                            } else {
    4725                                 $extendedXMP{Error} = 'Missing XMP data';
     6155                                $self->Error("Incomplete extended XMP (GUID $guid)", 1);
    47266156                            }
    47276157                        }
    … …  
    47506180                        }
    47516181                    } else {
    4752                         $self->{CHANGED} = $oldChanged;
    47536182                        $verbose and print $out "    [XMP rewritten with no changes]\n";
    47546183                        if ($doneDir{XMP} > 1) {
    … …  
    47816210                    $self->Warn('Ignored APP1 XMP segment with non-standard header', 1);
    47826211                }
    4783             } elsif ($marker == 0xe2) {         # APP2 (ICC Profile, FPXR)
    4784                 if ($$segDataPt =~ /^ICC_PROFILE\0/) {
     6212            } elsif ($marker == 0xe2) {         # APP2 (ICC Profile, FPXR, MPF)
     6213                if ($$segDataPt =~ /^ICC_PROFILE\0/ and $length >= 14) {
    47856214                    $segType = 'ICC_Profile';
    47866215                    $$delGroup{ICC_Profile} and $del = 1, last;
    47876216                    # must concatenate blocks of profile
    4788                     my $block_num = ord(substr($$segDataPt, 12, 1));
    4789                     my $blocks_tot = ord(substr($$segDataPt, 13, 1));
    4790                     $combinedSegData = '' if $block_num == 1;
    4791                     unless (defined $combinedSegData) {
    4792                         $self->Warn('APP2 ICC_Profile segments out of sequence');
     6217                    my $chunkNum = Get8u($segDataPt, 12);
     6218                    my $chunksTot = Get8u($segDataPt, 13);
     6219                    if (defined $iccChunksTotal) {
     6220                        # abort parsing ICC_Profile if the total chunk count is inconsistent
     6221                        if ($chunksTot != $iccChunksTotal and defined $iccChunkCount) {
     6222                            # an error because the accumulated profile data will be lost
     6223                            $self->Error('Inconsistent ICC_Profile chunk count', 1);
     6224                            undef $iccChunkCount; # abort ICC_Profile parsing
     6225                            undef $chunkNum;      # avoid 2nd warning below
     6226                            ++$$self{CHANGED};    # we are deleting the bad chunks before this one
     6227                        }
     6228                    } else {
     6229                        $iccChunkCount = 0;
     6230                        $iccChunksTotal = $chunksTot;
     6231                        $self->Warn('ICC_Profile chunk count is zero') if !$chunksTot;
     6232                    }
     6233                    if (defined $iccChunkCount) {
     6234                        # save this chunk
     6235                        if (defined $iccChunk[$chunkNum]) {
     6236                            $self->Warn("Duplicate ICC_Profile chunk number $chunkNum");
     6237                            $iccChunk[$chunkNum] .= substr($$segDataPt, 14);
     6238                        } else {
     6239                            $iccChunk[$chunkNum] = substr($$segDataPt, 14);
     6240                        }
     6241                        # continue accumulating chunks unless we have all of them
     6242                        next Marker unless ++$iccChunkCount >= $iccChunksTotal;
     6243                        undef $iccChunkCount;   # prevent reprocessing
     6244                        $doneDir{ICC_Profile} = 1;
     6245                        # combine the ICC_Profile chunks
     6246                        my $icc_profile = '';
     6247                        defined $_ and $icc_profile .= $_ foreach @iccChunk;
     6248                        undef @iccChunk;   # free memory
     6249                        $segDataPt = \$icc_profile;
     6250                        $length = length $icc_profile;
     6251                        my $tagTablePtr = GetTagTable('Image::ExifTool::ICC_Profile::Main');
     6252                        my %dirInfo = (
     6253                            DataPt   => $segDataPt,
     6254                            DataPos  => $segPos + 14,
     6255                            DataLen  => $length,
     6256                            DirStart => 0,
     6257                            DirLen   => $length,
     6258                            Parent   => $markerName,
     6259                        );
     6260                        my $newData = $self->WriteDirectory(\%dirInfo, $tagTablePtr);
     6261                        if (defined $newData) {
     6262                            undef $$segDataPt;  # free the old buffer
     6263                            $segDataPt = \$newData;
     6264                        }
     6265                        length $$segDataPt or $del = 1, last;
     6266                        # write as ICC multi-segment
     6267                        WriteMultiSegment($outfile, $marker, "ICC_PROFILE\0", $segDataPt, 'ICC') or $err = 1;
     6268                        undef $$segDataPt;
    47936269                        next Marker;
    4794                     }
    4795                     $combinedSegData .= substr($$segDataPt, 14);
    4796                     # continue accumulating segments unless this is the last
    4797                     next Marker unless $block_num == $blocks_tot;
    4798                     $doneDir{ICC_Profile} and $self->Warn('Multiple ICC_Profile records');
    4799                     $doneDir{ICC_Profile} = 1;
    4800                     $segDataPt = \$combinedSegData;
    4801                     $length = length $combinedSegData;
    4802                     my $tagTablePtr = GetTagTable('Image::ExifTool::ICC_Profile::Main');
    4803                     my %dirInfo = (
    4804                         DataPt   => $segDataPt,
    4805                         DataPos  => $segPos + 14,
    4806                         DataLen  => $length,
    4807                         DirStart => 0,
    4808                         DirLen   => $length,
    4809                         Parent   => $markerName,
    4810                     );
    4811                     my $newData = $self->WriteDirectory(\%dirInfo, $tagTablePtr);
    4812                     if (defined $newData) {
    4813                         undef $$segDataPt;  # free the old buffer
    4814                         $segDataPt = \$newData;
    4815                     }
    4816                     length $$segDataPt or $del = 1, last;
    4817                     # write as ICC multi-segment
    4818                     WriteMultiSegment($outfile, $marker, "ICC_PROFILE\0", $segDataPt, 'ICC') or $err = 1;
    4819                     undef $combinedSegData;
    4820                     undef $$segDataPt;
    4821                     next Marker;
     6270                    } elsif (defined $chunkNum) {
     6271                        $self->WarnOnce('Invalid or extraneous ICC_Profile chunk(s)');
     6272                        # fall through to preserve this extra profile...
     6273                    }
    48226274                } elsif ($$segDataPt =~ /^FPXR\0/) {
    48236275                    $segType = 'FPXR';
    48246276                    $$delGroup{FlashPix} and $del = 1;
     6277                } elsif ($$segDataPt =~ /^MPF\0/) {
     6278                    $segType = 'MPF';
     6279                    $$delGroup{MPF} and $del = 1;
    48256280                }
    48266281            } elsif ($marker == 0xe3) {         # APP3 (Kodak Meta)
    … …  
    48346289                    my %dirInfo = (
    48356290                        DataPt   => $segDataPt,
    4836                         DataPos  => $segPos,
     6291                        DataPos  => -6, # (remember: relative to Base!)
    48376292                        DirStart => 6,
    48386293                        Base     => $segPos + 6,
    … …  
    48486303                    } else {
    48496304                        last Marker unless $self->Options('IgnoreMinorErrors');
    4850                         $self->{CHANGED} = $oldChanged; # nothing changed
    48516305                    }
    48526306                    # delete segment if IFD contains no entries
    … …  
    48806334                        $newData = 'Ducky' . $newData if length $newData;
    48816335                        $segDataPt = \$newData;
    4882                     } else {
    4883                         $self->{CHANGED} = $oldChanged;
    48846336                    }
    48856337                    $del = 1 unless length $$segDataPt;
    … …  
    49216373                        undef $$segDataPt;  # free the old buffer
    49226374                        $segDataPt = \$newData;
    4923                     } else {
    4924                         $self->{CHANGED} = $oldChanged;
    49256375                    }
    49266376                    length $$segDataPt or $del = 1, last;
    … …  
    49306380                    undef $$segDataPt;
    49316381                    next Marker;
     6382                }
     6383            } elsif ($marker == 0xee) {         # APP14 (Adobe)
     6384                if ($$segDataPt =~ /^Adobe/) {
     6385                    $segType = 'Adobe';
     6386                    # delete it and replace it later if editing
     6387                    if ($$delGroup{Adobe} or $$editDirs{Adobe}) {
     6388                        $del = 1;
     6389                        undef $doneDir{Adobe};  # so we can add it back again above
     6390                    }
    49326391                }
    49336392            } elsif ($marker == 0xfe) {         # COM (JPEG comment)
    … …  
    49386397                        my $tagInfo = $Image::ExifTool::Extra{Comment};
    49396398                        my $nvHash = $self->GetNewValueHash($tagInfo);
    4940                         if (IsOverwriting($nvHash, $segData) or $$delGroup{File}) {
    4941                             $newComment = GetNewValues($nvHash);
     6399                        my $val = $segData;
     6400                        $val =~ s/\0+$//;   # allow for stupid software that adds NULL terminator
     6401                        if ($self->IsOverwriting($nvHash, $val) or $$delGroup{File}) {
     6402                            $newComment = $self->GetNewValue($nvHash);
    49426403                        } else {
    49436404                            delete $$editDirs{COM}; # we aren't editing COM after all
    … …  
    49476408                }
    49486409                $self->VerboseValue('- Comment', $$segDataPt);
    4949                 if (defined $newComment and length $newComment) {
     6410                if (defined $newComment) {
    49506411                    # write out the comments
    49516412                    $self->VerboseValue('+ Comment', $newComment);
    … …  
    49546415                    $verbose and print $out "  Deleting COM segment\n";
    49556416                }
    4956                 ++$self->{CHANGED};     # increment the changed flag
     6417                ++$$self{CHANGED};      # increment the changed flag
    49576418                undef $segDataPt;       # don't write existing comment
    49586419            }
    49596420            last;   # didn't want to loop anyway
    49606421        }
     6422
    49616423        # delete necessary segments (including unknown segments if deleting all)
    49626424        if ($del or ($$delGroup{'*'} and not $segType and $marker>=0xe0 and $marker<=0xef)) {
    49636425            $segType = 'unknown' unless $segType;
    49646426            $verbose and print $out "  Deleting $markerName $segType segment\n";
    4965             ++$self->{CHANGED};
     6427            ++$$self{CHANGED};
    49666428            next Marker;
    49676429        }
    49686430        # write out this segment if $segDataPt is still defined
    4969         if (defined $segDataPt) {
     6431        if (defined $segDataPt and defined $$segDataPt) {
    49706432            # write the data for this record (the data could have been
    49716433            # modified, so recalculate the length word)
    … …  
    49806442            }
    49816443            undef $$segDataPt;  # free the buffer
    4982         }
    4983     }
     6444            undef $segDataPt;
     6445        }
     6446    }
     6447    # make sure the ICC_Profile was complete
     6448    $self->Error('Incomplete ICC_Profile record', 1) if defined $iccChunkCount;
    49846449    pop @$path if @$path > $pn;
    49856450    # if oldOutfile is still set, there was an error copying the JPEG
    … …  
    49926457    # set return value to -1 if we only had a write error
    49936458    $rtnVal = -1 if $rtnVal and $err;
     6459    if ($creatingEXV and $rtnVal > 0 and not $$self{CHANGED}) {
     6460        $self->Error('Nothing written');
     6461        $rtnVal = -1;
     6462    }
    49946463    return $rtnVal;
    49956464}
    … …  
    50056474        $self->Options('IgnoreMinorErrors'))
    50066475    {
    5007         return '[minor] Not a valid image';
     6476        return '[Minor] Not a valid image';
    50086477    }
    50096478    return undef;
    … …  
    50736542                    }
    50746543                }
    5075                 return 'Not a floating point number' 
     6544                return 'Not a floating point number';
    50766545            }
    50776546            if ($format =~ /^rational\d+u$/ and $val < 0) {
    … …  
    51116580
    51126581#------------------------------------------------------------------------------
     6582# Rename a file (with patch for Windows Unicode file names, and other problem)
     6583# Inputs: 0) ExifTool ref, 1) old name, 2) new name
     6584# Returns: true on success
     6585sub Rename($$$)
     6586{
     6587    my ($self, $old, $new) = @_;
     6588    my ($result, $try, $winUni);
     6589
     6590    if ($self->EncodeFileName($old)) {
     6591        $self->EncodeFileName($new, 1);
     6592        $winUni = 1;
     6593    } elsif ($self->EncodeFileName($new)) {
     6594        $old = $_[1];
     6595        $self->EncodeFileName($old, 1);
     6596        $winUni = 1;
     6597    }
     6598    for (;;) {
     6599        if ($winUni) {
     6600            $result = eval { Win32API::File::MoveFileExW($old, $new,
     6601                Win32API::File::MOVEFILE_REPLACE_EXISTING() |
     6602                Win32API::File::MOVEFILE_COPY_ALLOWED()) };
     6603        } else {
     6604            $result = rename($old, $new);
     6605        }
     6606        last if $result or $^O ne 'MSWin32';
     6607        # keep trying for up to 0.5 seconds
     6608        # (patch for Windows denial-of-service susceptibility)
     6609        $try = ($try || 1) + 1;
     6610        last if $try > 50;
     6611        select(undef,undef,undef,0.01); # sleep for 0.01 sec
     6612    }
     6613    return $result;
     6614}
     6615
     6616#------------------------------------------------------------------------------
     6617# Delete a file (with patch for Windows Unicode file names)
     6618# Inputs: 0) ExifTool ref, 1-N) names of files to delete
     6619# Returns: number of files deleted
     6620sub Unlink($@)
     6621{
     6622    my $self = shift;
     6623    my $result = 0;
     6624    while (@_) {
     6625        my $file = shift;
     6626        if ($self->EncodeFileName($file)) {
     6627            ++$result if eval { Win32API::File::DeleteFileW($file) };
     6628        } else {
     6629            ++$result if unlink $file;
     6630        }
     6631    }
     6632    return $result;
     6633}
     6634
     6635#------------------------------------------------------------------------------
     6636# Set file times (Unix seconds since the epoch)
     6637# Inputs: 0) ExifTool ref, 1) file name or ref, 2) access time, 3) modification time,
     6638#         4) inode change or creation time (or undef for any time to avoid setting)
     6639#         5) flag to suppress warning
     6640# Returns: 1 on success, 0 on error
     6641my $k32SetFileTime;
     6642sub SetFileTime($$;$$$$)
     6643{
     6644    my ($self, $file, $atime, $mtime, $ctime, $noWarn) = @_;
     6645    my $saveFile;
     6646    local *FH;
     6647
     6648    # open file by name if necessary
     6649    unless (ref $file) {
     6650        # (file will be automatically closed when *FH goes out of scope)
     6651        unless ($self->Open(\*FH, $file, '+<')) {
     6652            my $success;
     6653            if (defined $atime or defined $mtime) {
     6654                my ($a, $m, $c) = $self->GetFileTime($file);
     6655                $atime = $a unless defined $atime;
     6656                $mtime = $m unless defined $mtime;
     6657                $success = eval { utime($atime, $mtime, $file) } if defined $atime and defined $mtime;
     6658            }
     6659            $self->Warn('Error opening file for update') unless $success;
     6660            return $success;
     6661        }
     6662        $saveFile = $file;
     6663        $file = \*FH;
     6664    }
     6665    # on Windows, try to work around incorrect file times when daylight saving time is in effect
     6666    if ($^O eq 'MSWin32') {
     6667        if (not eval { require Win32::API }) {
     6668            $self->WarnOnce('Install Win32::API for proper handling of Windows file times');
     6669        } elsif (not eval { require Win32API::File }) {
     6670            $self->WarnOnce('Install Win32API::File for proper handling of Windows file times');
     6671        } else {
     6672            # get Win32 handle, needed for SetFileTime
     6673            my $win32Handle = eval { Win32API::File::GetOsFHandle($file) };
     6674            unless ($win32Handle) {
     6675                $self->Warn('Win32API::File::GetOsFHandle returned invalid handle');
     6676                return 0;
     6677            }
     6678            # convert Unix seconds to FILETIME structs
     6679            my $time;
     6680            foreach $time ($atime, $mtime, $ctime) {
     6681                # set to NULL if not defined (i.e. do not change)
     6682                defined $time or $time = 0, next;
     6683                # convert to 100 ns intervals since 0:00 UTC Jan 1, 1601
     6684                # (89 leap years between 1601 and 1970)
     6685                my $wt = ($time + (((1970-1601)*365+89)*24*3600)) * 1e7;
     6686                my $hi = int($wt / 4294967296);
     6687                $time = pack 'LL', int($wt - $hi * 4294967296), $hi; # pack FILETIME struct
     6688            }
     6689            unless ($k32SetFileTime) {
     6690                return 0 if defined $k32SetFileTime;
     6691                $k32SetFileTime = new Win32::API('KERNEL32', 'SetFileTime', 'NPPP', 'I');
     6692                unless ($k32SetFileTime) {
     6693                    $self->Warn('Error calling Win32::API::SetFileTime');
     6694                    $k32SetFileTime = 0;
     6695                    return 0;
     6696                }
     6697            }
     6698            unless ($k32SetFileTime->Call($win32Handle, $ctime, $atime, $mtime)) {
     6699                $self->Warn('Win32::API::SetFileTime returned ' . Win32::GetLastError());
     6700                return 0;
     6701            }
     6702            return 1;
     6703        }
     6704    }
     6705    # other OS (or Windows fallback)
     6706    if (defined $atime and defined $mtime) {
     6707        my $success;
     6708        local $SIG{'__WARN__'} = \&SetWarning; # (this may not be necessary)
     6709        for (;;) {
     6710            undef $evalWarning;
     6711            # (this may fail on the first try if futimes is not implemented)
     6712            $success = eval { utime($atime, $mtime, $file) };
     6713            last if $success or not defined $saveFile;
     6714            close $file;
     6715            $file = $saveFile;
     6716            undef $saveFile;
     6717        }
     6718        unless ($noWarn) {
     6719            if ($@ or $evalWarning) {
     6720                $self->Warn(CleanWarning($@ || $evalWarning));
     6721            } elsif (not $success) {
     6722                $self->Warn('Error setting file time');
     6723            }
     6724        }
     6725        return $success;
     6726    }
     6727    return 1; # (nothing to do)
     6728}
     6729
     6730#------------------------------------------------------------------------------
    51136731# Copy data block from RAF to output file in max 64kB chunks
    51146732# Inputs: 0) RAF ref, 1) outfile ref, 2) block size
    … …  
    51296747
    51306748#------------------------------------------------------------------------------
    5131 # copy image data from one file to another
     6749# Copy image data from one file to another
    51326750# Inputs: 0) ExifTool object reference
    51336751#         1) reference to list of image data [ position, size, pad bytes ]
    … …  
    51376755{
    51386756    my ($self, $imageDataBlocks, $outfile) = @_;
    5139     my $raf = $self->{RAF};
     6757    my $raf = $$self{RAF};
    51406758    my ($dataBlock, $err);
    51416759    my $num = @$imageDataBlocks;
    … …  
    51586776
    51596777#------------------------------------------------------------------------------
    5160 # write to binary data block
     6778# Write to binary data block
    51616779# Inputs: 0) ExifTool object ref, 1) source dirInfo ref, 2) tag table ref
    51626780# Returns: Binary data block or undefined on error
    … …  
    51916809    my $tagInfo;
    51926810    $dataPt = \$newData;
    5193     foreach $tagInfo ($self->GetNewTagInfoList($tagTablePtr)) {
    5194         my $tagID = $tagInfo->{TagID};
     6811    foreach $tagInfo (sort { $$a{TagID} <=> $$b{TagID} } $self->GetNewTagInfoList($tagTablePtr)) {
     6812        my $tagID = $$tagInfo{TagID};
    51956813        # evaluate conditional tags now if necessary
    51966814        if (ref $$tagTablePtr{$tagID} eq 'ARRAY' or $$tagInfo{Condition}) {
    … …  
    51996817        }
    52006818        # add offsets for variable-sized tags if necessary
    5201         while (@varInfo and $varInfo[0] < $tagID) {
    5202             shift @varInfo;             # discard index
    5203             $varSize = shift @varInfo;  # get accumulated variable size
     6819        while (@varInfo and $varInfo[0][0] < $tagID) {
     6820            $varSize = $varInfo[0][1];  # get accumulated variable size
     6821            shift @varInfo;
    52046822        }
    52056823        my $count = 1;
    … …  
    52226840            $format = $defaultFormat;
    52236841        }
     6842        # read/write using variable format if changed in Hook
     6843        $format = $varInfo[0][2] if @varInfo and $varInfo[0][0] == $tagID;
    52246844        my $val = ReadValue($dataPt, $entry, $format, $count, $dirLen-$entry);
    52256845        next unless defined $val;
    5226         my $nvHash = $self->GetNewValueHash($tagInfo);
    5227         next unless IsOverwriting($nvHash, $val);
    5228         my $newVal = GetNewValues($nvHash);
     6846        my $nvHash = $self->GetNewValueHash($tagInfo, $$self{CUR_WRITE_GROUP});
     6847        next unless $self->IsOverwriting($nvHash, $val) > 0;
     6848        my $newVal = $self->GetNewValue($nvHash);
    52296849        next unless defined $newVal;    # can't delete from a binary table
     6850        # update DataMember with new value if necessary
     6851        $$self{$$tagInfo{DataMember}} = $newVal if $$tagInfo{DataMember};
    52306852        # only write masked bits if specified
    52316853        my $mask = $$tagInfo{Mask};
    5232         $newVal = ($newVal & $mask) | ($val & ~$mask) if defined $mask;
     6854        $newVal = (($newVal << $$tagInfo{BitShift}) & $mask) | ($val & ~$mask) if $mask;
    52336855        # set the size
    52346856        if ($$tagInfo{DataTag} and not $$tagInfo{IsOffset}) {
    52356857            warn 'Internal error' unless $newVal == 0xfeedfeed;
    5236             my $data = $self->GetNewValues($$tagInfo{DataTag});
     6858            my $data = $self->GetNewValue($$tagInfo{DataTag});
    52376859            $newVal = length($data) if defined $data;
    52386860            my $format = $$tagInfo{Format} || $$tagTablePtr{FORMAT} || 'int32u';
    … …  
    52456867            $self->VerboseValue("- $dirName:$$tagInfo{Name}", $val);
    52466868            $self->VerboseValue("+ $dirName:$$tagInfo{Name}", $newVal);
    5247             ++$self->{CHANGED};
     6869            ++$$self{CHANGED};
    52486870        }
    52496871    }
    … …  
    52546876        my $fixup = $$dirInfo{Fixup};
    52556877        my $tagID;
    5256         foreach $tagID (@{$tagTablePtr->{IS_OFFSET}}) {
     6878        foreach $tagID (@{$$tagTablePtr{IS_OFFSET}}) {
    52576879            $tagInfo = $self->GetTagInfo($tagTablePtr, $tagID) or next;
    5258             while (@varInfo and $varInfo[0] < $tagID) {
     6880            while (@varInfo and $varInfo[0][0] < $tagID) {
     6881                $varSize = $varInfo[0][1];
    52596882                shift @varInfo;
    5260                 $varSize = shift @varInfo;
    52616883            }
    52626884            my $entry = $tagID * $increment + $varSize; # (no offset to dirStart for new dir data)
    … …  
    52656887            my $format = $$tagInfo{Format} || $$tagTablePtr{FORMAT} || 'int32u';
    52666888            my $offset = ReadValue($dataPt, $entry, $format, 1, $dirLen-$entry);
    5267             # ignore if offset is zero (ie. Ricoh DNG uses this to indicate no preview)
     6889            # ignore if offset is zero (eg. Ricoh DNG uses this to indicate no preview)
    52686890            next unless $offset;
    52696891            $fixup->AddFixup($entry, $$tagInfo{DataTag}, $format);
    52706892            # handle the preview image now if this is a JPEG file
    5271             next unless $self->{FILE_TYPE} eq 'JPEG' and $$tagInfo{DataTag} and
     6893            next unless $$self{FILE_TYPE} eq 'JPEG' and $$tagInfo{DataTag} and
    52726894                $$tagInfo{DataTag} eq 'PreviewImage' and defined $$tagInfo{OffsetPair};
    52736895            # NOTE: here we assume there are no var-sized tags between the
    … …  
    52766898            $entry = $$tagInfo{OffsetPair} * $increment + $varSize;
    52776899            my $size = ReadValue($dataPt, $entry, $format, 1, $dirLen-$entry);
    5278             my $previewInfo = $self->{PREVIEW_INFO};
    5279             $previewInfo or $previewInfo = $self->{PREVIEW_INFO} = { };
     6900            my $previewInfo = $$self{PREVIEW_INFO};
     6901            $previewInfo or $previewInfo = $$self{PREVIEW_INFO} = {
     6902                Fixup => new Image::ExifTool::Fixup,
     6903            };
    52806904            # set flag indicating we are using short pointers
    52816905            $$previewInfo{IsShort} = 1 unless $format eq 'int32u';
    52826906            $$previewInfo{Absolute} = 1 if $$tagInfo{IsOffset} and $$tagInfo{IsOffset} eq '3';
    52836907            # get the value of the Composite::PreviewImage tag
    5284             $$previewInfo{Data} = $self->GetNewValues($Image::ExifTool::Composite{PreviewImage});
     6908            $$previewInfo{Data} = $self->GetNewValue(GetCompositeTagInfo('PreviewImage'));
    52856909            unless (defined $$previewInfo{Data}) {
    52866910                if ($offset >= 0 and $offset + $size <= $$dirInfo{DataLen}) {
    … …  
    53006924            my $tagInfo = $self->GetTagInfo($tagTablePtr, $tagID);
    53016925            next unless defined $tagInfo;
    5302             while (@varInfo and $varInfo[0] < $tagID) {
     6926            while (@varInfo and $varInfo[0][0] < $tagID) {
     6927                $varSize = $varInfo[0][1];
    53036928                shift @varInfo;
    5304                 $varSize = shift @varInfo;
    53056929            }
    53066930            my $entry = int($tagID) * $increment + $varSize;
    … …  
    53166940            next unless $$tagInfo{SubDirectory}; # (just to be safe)
    53176941            my %subdirInfo = ( DataPt => \$newData, DirStart => $entry );
    5318             my $subTablePtr = GetTagTable($tagInfo->{SubDirectory}{TagTable});
     6942            my $subTablePtr = GetTagTable($$tagInfo{SubDirectory}{TagTable});
    53196943            my $dat = $self->WriteDirectory(\%subdirInfo, $subTablePtr);
    53206944            substr($newData, $entry) = $dat if defined $dat and length $dat;
    … …  
    53316955{
    53326956    my ($self, $dirInfo, $tagTablePtr) = @_;
     6957    $self or return 1;    # allow dummy access
    53336958    my $buff = '';
    53346959    $$dirInfo{OutFile} = \$buff;
    … …  
    53566981=head1 AUTHOR
    53576982
    5358 Copyright 2003-2011, Phil Harvey (phil at owl.phy.queensu.ca)
     6983Copyright 2003-2021, Phil Harvey (philharvey66 at gmail.com)
    53596984
    53606985This library is free software; you can redistribute it and/or modify it
Note: See TracChangeset for help on using the changeset viewer.