—

              
#------------------------------------------------------------------------------
# File:         TagInfoXML.pm
#
# Description:  Read/write tag information XML database
#
# Revisions:    2009/01/28 - P. Harvey Created
#------------------------------------------------------------------------------
package Image::ExifTool::TagInfoXML;
use strict;
require Exporter;
use vars qw($VERSION @ISA $makeMissing);
use Image::ExifTool qw(:Utils :Vars);
use Image::ExifTool::XMP;
$VERSION = '1.37';
@ISA = qw(Exporter);
# set this to a language code to generate Lang module with 'MISSING' entries
$makeMissing = '';
sub LoadLangModules($;$);
sub WriteLangModule($$;$);
sub NumbersFirst;
# names for acknowledgements in the POD documentation
my %credits = (
    cs   => 'Jens Duttke and Petr MichE<aacute>lek',
    de   => 'Jens Duttke, Herbert Kauer and Jobi',
    es   => 'Jens Duttke, Santiago del BrE<iacute>o GonzE<aacute>lez and Emilio Sancha',
    fi   => 'Jens Duttke and Jarkko ME<auml>kineva',
    fr   => 'Jens Duttke, Bernard Guillotin, Jean Glasser, Jean Piquemal, Harry Nizard, Alphonse Philippe and Philippe Bonnaure (GraphicConverter)',
    it   => 'Jens Duttke, Ferdinando Agovino, Emilio Dati and Michele Locati',
    ja   => 'Jens Duttke and Kazunari Nishina',
    ko   => 'Jens Duttke and Jeong Beom Kim',
    nl   => 'Jens Duttke, Peter Moonen, Herman Beld and Peter van der Laan',
    pl   => 'Jens Duttke, Przemyslaw Sulek and Kacper Perschke',
    ru   => 'Jens Duttke, Sergey Shemetov, Dmitry Yerokhin, Anton Sukhinov and Alexander',
    sk   => 'Peter Bagin',
    sv   => 'Jens Duttke and BjE<ouml>rn SE<ouml>derstrE<ouml>m',
   'tr'  => 'Jens Duttke, Hasan Yildirim and Cihan Ulusoy',
    zh_cn => 'Jens Duttke and Haibing Zhong',
    zh_tw => 'Jens Duttke and MikeF',
);
# translate country codes to language codes
my %translateLang = (
    ch_s  => 'zh_cn',
    ch_cn => 'zh_cn',
    ch_tw => 'zh_tw',
    cz    => 'cs',
    jp    => 'ja',
    kr    => 'ko',
    se    => 'sv',
);
my $numbersFirst = 1;   # set to -1 to sort numbers last, or 2 to put negative numbers last
my $caseInsensitive;    # used internally by sort routine
# write groups that don't represent real family 1 group names
my %fakeWriteGroup = (
    Comment => 1,   # (JPEG Comment)
    colr => 1,      # (Jpeg2000 'colr' box)
);
#------------------------------------------------------------------------------
# Utility to print tag information database as an XML list
# Inputs: 0) output file name (undef to send to console),
#         1) group name (may be undef), 2) options hash ('Flags','NoDesc','Lang')
# Returns: true on success
sub Write(;$$%)
{
    local ($_, *PTIFILE);
    my ($file, $group, %opts) = @_;
    my $et = Image::ExifTool->new;
    my ($fp, $tableName, %langInfo, @langs, $defaultLang, @groups);
    @groups = split ':', $group if $group;
    Image::ExifTool::LoadAllTables();   # first load all our tables
    unless ($opts{NoDesc}) {
        $defaultLang = $Image::ExifTool::defaultLang;
        LoadLangModules(\%langInfo, $opts{Lang}); # load necessary Lang modules
        if ($opts{Lang}) {
            @langs = grep /^$opts{Lang}$/i, keys %langInfo;
        } else {
            @langs = sort keys %langInfo;
        }
    }
    if (defined $file) {
        open PTIFILE, ">$file" or return 0;
        $fp = \*PTIFILE;
    } else {
        $fp = \*STDOUT;
    }
    print $fp "<?xml version='1.0' encoding='UTF-8'?>\n";
    print $fp "<!-- Generated by Image::ExifTool $Image::ExifTool::VERSION -->\n";
    print $fp "<taginfo>\n\n";
    # loop through all tables and save tag names to %allTags hash
    foreach $tableName (sort keys %allTables) {
        my $table = GetTagTable($tableName);
        my $grps = $$table{GROUPS};
        my ($tagID, $didTag);
        # sort in same order as tag name documentation
        $caseInsensitive = ($tableName =~ /::XMP::/);
        # get list of languages defining elements in this table
        my $isBinary = ($$table{PROCESS_PROC} and
                        $$table{PROCESS_PROC} eq \&Image::ExifTool::ProcessBinaryData);
        # generate flattened tag names for structure fields if this is an XMP table
        if ($$table{GROUPS} and $$table{GROUPS}{0} eq 'XMP') {
            Image::ExifTool::XMP::AddFlattenedTags($table);
        }
        $numbersFirst = 2;
        $numbersFirst = -1 if $$table{VARS} and $$table{VARS}{ALPHA_FIRST};
        my @keys = sort NumbersFirst TagTableKeys($table);
        $numbersFirst = 1;
        # loop through all tag ID's in this table
        foreach $tagID (@keys) {
            my @infoArray = GetTagInfoList($table, $tagID);
            my $xmlID = Image::ExifTool::XMP::FullEscapeXML($tagID);
            # get a list of languages defining elements for this ID
            my ($index, $fam);
PTILoop:    for ($index=0; $index<@infoArray; ++$index) {
                my $tagInfo = $infoArray[$index];
                # don't list subdirectories unless they are writable
                next unless $$tagInfo{Writable} or not $$tagInfo{SubDirectory};
                if (@groups) {
                    my @tg = $et->GetGroup($tagInfo);
                    foreach $group (@groups) {
                        next PTILoop unless grep /^$group$/i, @tg;
                    }
                }
                unless ($didTag) {
                    my $tname = $$table{SHORT_NAME};
                    print $fp "<table name='${tname}' g0='$$grps{0}' g1='$$grps{1}' g2='$$grps{2}'>\n";
                    unless ($opts{NoDesc}) {
                        # print table description
                        my $desc = $$table{TABLE_DESC};
                        unless ($desc) {
                            ($desc = $tname) =~ s/::Main$//;
                            $desc =~ s/::/ /g;
                        }
                        # print alternate language descriptions
                        print $fp " <desc lang='en'>$desc</desc>\n";
                        foreach (@langs) {
                            $desc = $langInfo{$_}{$tableName} or next;
                            $desc = Image::ExifTool::XMP::EscapeXML($desc);
                            print $fp " <desc lang='${_}'>$desc</desc>\n";
                        }
                    }
                    $didTag = 1;
                }
                my $name = $$tagInfo{Name};
                my $ind = @infoArray > 1 ? " index='${index}'" : '';
                my $format = $$tagInfo{Writable} || $$table{WRITABLE};
                my $writable = $format ? 'true' : 'false';
                # check our conversions to make sure we can really write this tag
                if ($writable eq 'true') {
                    $writable = 'false' if defined $$tagInfo{Writable} and not $$tagInfo{Writable};
                    foreach ('PrintConv','ValueConv') {
                        next unless $$tagInfo{$_};
                        next if $$tagInfo{$_ . 'Inv'};
                        next if ref($$tagInfo{$_}) =~ /^(HASH|ARRAY)$/;
                        next if $$tagInfo{WriteAlso};
                        $writable = 'false';
                        last;
                    }
                }
                $format = $$tagInfo{Format} || $$table{FORMAT} if not $format or $format eq '1';
                $format = 'struct' if $$tagInfo{Struct};
                if (defined $format) {
                    $format =~ s/\[.*\$.*\]//;   # remove expressions from format
                    $format = 'undef' if $format eq '2'; # (special case)
                } elsif ($isBinary) {
                    $format = 'int8u';
                } else {
                    $format = '?';
                }
                my $count = '';
                if ($format =~ s/\[.*?(\d*)\]$//) {
                    $count = " count='${1}'" if length $1;
                } elsif ($$tagInfo{Count} and $$tagInfo{Count} > 1) {
                    $count = " count='$$tagInfo{Count}'";
                }
                my @groups = $et->GetGroup($tagInfo);
                my $writeGroup = $$tagInfo{WriteGroup} || $$table{WRITE_GROUP};
                # use common write group for group 1 (unless fake)
                $groups[1] = $writeGroup if $writeGroup and not $fakeWriteGroup{$writeGroup};
                # add group names if different from table defaults
                my $grp = '';
                for ($fam=0; $fam<3; ++$fam) {
                    $grp .= " g$fam='$groups[$fam]'" if $groups[$fam] ne $$grps{$fam};
                }
                # add flags if necessary
                if ($opts{Flags}) {
                    my @flags;
                    foreach (qw(Avoid Binary List Mandatory Unknown)) {
                        push @flags, $_ if $$tagInfo{$_};
                    }
                    push @flags, $$tagInfo{List} if $$tagInfo{List} and $$tagInfo{List} =~ /^(Alt|Bag|Seq)$/;
                    push @flags, 'Flattened' if defined $$tagInfo{Flat};
                    push @flags, 'Unsafe' if $$tagInfo{Protected} and $$tagInfo{Protected} & 0x01;
                    push @flags, 'Protected' if $$tagInfo{Protected} and $$tagInfo{Protected} & 0x02;
                    push @flags, 'Permanent' if $$tagInfo{Permanent} or
                        ($groups[0] eq 'MakerNotes' and not defined $$tagInfo{Permanent});
                    $grp = " flags='" . join(',', sort @flags) . "'$grp" if @flags;
                    # add parent structure tag ID
                    $grp .= " struct='$$tagInfo{ParentTagInfo}{TagID}'" if $$tagInfo{ParentTagInfo};
                }
                print $fp " <tag id='${xmlID}' name='${name}'$ind type='${format}'$count writable='${writable}'$grp";
                if ($opts{NoDesc}) {
                    # short output format
                    print $fp "/>\n";   # empty tag element
                    next;               # no descriptions or values
                } else {
                    print $fp ">";
                }
                my $desc = $$tagInfo{Description};
                $desc = Image::ExifTool::MakeDescription($name) unless defined $desc;
                # add alternate language descriptions and get references
                # to alternate language PrintConv hashes
                my $altDescr = '';
                my %langConv;
                foreach (@langs) {
                    my $ld = $langInfo{$_}{$name} or next;
                    if (ref $ld) {
                        $langConv{$_} = $$ld{PrintConv};
                        $ld = $$ld{Description} or next;
                    }
                    # ignore descriptions that are the same as the default language
                    next if $ld eq $desc;
                    $ld = Image::ExifTool::XMP::EscapeXML($ld);
                    $altDescr .= "\n  <desc lang='${_}'>$ld</desc>";
                }
                # print tag descriptions
                $desc = Image::ExifTool::XMP::EscapeXML($desc);
                unless ($opts{Lang} and $altDescr) {
                    print $fp "\n  <desc lang='${defaultLang}'>$desc</desc>";
                }
                print $fp "$altDescr\n";
                for (my $i=0; ; ++$i) {
                    my $conv = $$tagInfo{PrintConv};
                    my $idx = '';
                    if (ref $conv eq 'ARRAY') {
                        last unless $i < @$conv;
                        $conv = $$conv[$i];
                        $idx = " index='${i}'";
                    } else {
                        last if $i;
                    }
                    next unless ref $conv eq 'HASH';
                    # make a list of available alternate languages
                    my @langConv = sort keys %langConv;
                    print $fp "  <values$idx>\n";
                    my $key;
                    $caseInsensitive = 0;
                    # add bitmask values to main lookup
                    if ($$conv{BITMASK}) {
                        foreach $key (keys %{$$conv{BITMASK}}) {
                            my $mask = "Bit$key";
                            next if not $mask or $$conv{$mask};
                            $$conv{$mask} = $$conv{BITMASK}{$key};
                        }
                    }
                    foreach $key (sort NumbersFirst keys %$conv) {
                        next if $key eq 'BITMASK' or $key eq 'OTHER' or $key eq 'Notes';
                        my $val = $$conv{$key};
                        my $xmlVal = Image::ExifTool::XMP::EscapeXML($val);
                        my $xmlKey = Image::ExifTool::XMP::FullEscapeXML($key);
                        print $fp "   <key id='${xmlKey}'>\n";
                        # add alternate language values
                        my $altConv = '';
                        foreach (@langConv) {
                            my $lv = $langConv{$_};
                            # handle indexed PrintConv entries
                            $lv = $$lv[$i] or next if ref $lv eq 'ARRAY';
                            $lv = $$lv{$val};
                            # ignore values that are missing or same as default
                            next unless defined $lv and $lv ne $val;
                            $lv = Image::ExifTool::XMP::EscapeXML($lv);
                            $altConv .= "    <val lang='${_}'>$lv</val>\n";
                        }
                        unless ($opts{Lang} and $altConv) {
                            print $fp "    <val lang='${defaultLang}'>$xmlVal</val>\n"
                        }
                        print $fp "$altConv   </key>\n";
                    }
                    print $fp "  </values>\n";
                }
                print $fp " </tag>\n";
            }
        }
        print $fp "</table>\n\n" if $didTag;
    }
    my $success = 1;
    print $fp "</taginfo>\n" or $success = 0;
    close $fp or $success = 0 if defined $file;
    return $success;
}
#------------------------------------------------------------------------------
# Escape backslash and quote in string
# Inputs: string
# Returns: escaped string
sub EscapePerl
{
    my $str = shift;
    $str =~ s/\\/\\\\/g;
    $str =~ s/'/\\'/g;
    return $str;
}
#------------------------------------------------------------------------------
# Generate Lang modules from input tag info XML database
# Inputs: 0) XML filename, 1) update flags:
#       0x01 = preserve version numbers
#       0x02 = update all modules, even if they didn't change
#       0x04 = update from scratch, ignoring existing definitions
#       0x08 = override existing different descriptions and values
# Returns: Count of updated Lang modules, or -1 on error
# Notes: Must be run from the directory containing 'lib'
sub BuildLangModules($;$)
{
    local ($_, *XFILE);
    my ($file, $updateFlag) = @_;
    my ($table, $tableName, $id, $index, $valIndex, $name, $key, $lang, $defDesc);
    my (%langInfo, %different, %changed, $overrideDifferent);
    Image::ExifTool::LoadAllTables();   # first load all our tables
    # generate our flattened tags
    foreach $tableName (sort keys %allTables) {
        my $table = GetTagTable($tableName);
        next unless $$table{GROUPS} and $$table{GROUPS}{0} eq 'XMP';
        Image::ExifTool::XMP::AddFlattenedTags($table);
    }
    LoadLangModules(\%langInfo);        # load all existing Lang modules
    $updateFlag = 0 unless $updateFlag;
    %langInfo = () if $updateFlag & 0x04;
    $overrideDifferent = 1 if $updateFlag & 0x08;
    if (defined $file) {
        open XFILE, $file or return -1;
        while (<XFILE>) {
            next unless /^\s*<(\/?)(\w+)/;
            my $tok = $2;
            if ($1) {
                # close appropriate entities
                if ($tok eq 'tag') {
                    undef $id;
                    undef $index;
                    undef $name;
                    undef $defDesc;
                } elsif ($tok eq 'values') {
                    undef $key;
                    undef $valIndex;
                } elsif ($tok eq 'table') {
                    undef $table;
                    undef $id;
                }
                next;
            }
            if ($tok eq 'table') {
                /^\s*<table name='([^']+)'[ >]/ or warn('Bad table'), next;
                $tableName = "Image::ExifTool::$1";
                # ignore userdefined tables
                next if $tableName =~ /^Image::ExifTool::UserDefined/;
                $table = Image::ExifTool::GetTagTable($tableName);
                $table or warn("Unknown tag table $tableName\n");
                next;
            }
            next unless defined $table;
            if ($tok eq 'tag') {
                /^\s*<tag id='([^']*)' name='([^']+)'( index='(\d+)')?[ >]/ or warn('Bad tag'), next;
                $id = Image::ExifTool::XMP::FullUnescapeXML($1);
                $name = $2;
                $index = $4;
                # convert hex ID's unless HEX_ID is 0 (for string ID's that look like hex)
                if ($id =~ /^0x[\da-fA-F]+$/ and (not defined $$table{VARS} or
                    not defined $$table{VARS}{HEX_ID} or $$table{VARS}{HEX_ID}))
                {
                    $id = hex($id);
                }
                next;
            }
            if ($tok eq 'values') {
                /^\s*<values index='([^']*)'>/ or next;
                $valIndex = $1;
            } elsif ($tok eq 'key') {
                defined $id or warn('No ID'), next;
                /^\s*<key id='([^']*)'>/ or warn('Bad key'), next;
                $key = Image::ExifTool::XMP::FullUnescapeXML($1);
                $key = hex($key) if $key =~ /^0x[\da-fA-F]+$/; # convert hex keys
            } elsif ($tok eq 'val' or $tok eq 'desc') {
                /^\s*<$tok( lang='([-\w]+?)')?>(.*)<\/$tok>/ or warn("Bad $tok"), next;
                $tok eq 'desc' and defined $key and warn('Out of order "desc"'), next;
                my $lang = $2 or next; # looking only for alternate languages
                $lang =~ tr/-A-Z/_a-z/;
                # use standard ISO 639-1 language codes
                $lang = $translateLang{$lang} if $translateLang{$lang};
                my $tval = Image::ExifTool::XMP::UnescapeXML($3);
                my $val = ucfirst $tval;
                $val = $tval if $tval =~ /^(cRAW|iTun)/; # special-case non-capitalized values
                my $cap = ($tval ne $val);
                if ($makeMissing) {
                    if ($lang eq 'en') {
                        $lang = $makeMissing;
                        $val = 'MISSING';
                        undef $cap;
                    }
                } elsif ($val eq 'MISSING') {
                    next;   # ignore "MISSING" entries
                }
                my $isDefault = ($lang eq $Image::ExifTool::defaultLang);
                unless ($langInfo{$lang} or $isDefault) {
                    print "Creating new language $lang\n";
                    $langInfo{$lang} = { };
                }
                defined $name or $name = '<unknown>';
                unless (defined $id) {
                    next if $isDefault;
                    # this is a table description
                    next if $langInfo{$lang}{$tableName} and
                            $langInfo{$lang}{$tableName} eq $val;
                    $langInfo{$lang}{$tableName} = $val;
                    $changed{$lang} = 1;
                    warn("Capitalized '${lang}' val for $name: $val\n") if $cap;
                    next;
                }
                my @infoArray = GetTagInfoList($table, $id);
                # this will fail for UserDefined tags and tags without ID's
                @infoArray or warn("Error loading tag for $tableName ID='${id}'\n"), next;
                my ($tagInfo, $langInfo);
                if (defined $index) {
                    $tagInfo = $infoArray[$index];
                    $tagInfo or warn('Invalid index'), next;
                } else {
                    @infoArray > 1 and warn('Missing index'), next;
                    $tagInfo = $infoArray[0];
                }
                my $tagName = $$tagInfo{Name};
                if ($isDefault) {
                    unless ($$tagInfo{Description}) {
                        $$tagInfo{Description} = Image::ExifTool::MakeDescription($tagName);
                    }
                    $defDesc = $$tagInfo{Description};
                    $langInfo = $tagInfo;
                } else {
                    $langInfo = $langInfo{$lang}{$tagName};
                    if (not defined $langInfo) {
                        $langInfo = $langInfo{$lang}{$tagName} = { };
                    } elsif (not ref $langInfo) {
                        $langInfo = $langInfo{$lang}{$tagName} = { Description => $langInfo };
                    }
                }
                # save new value in langInfo record
                if ($tok eq 'desc') {
                    my $oldVal = $$langInfo{Description};
                    next if defined $oldVal and $oldVal eq $val;
                    if ($makeMissing) {
                        next if defined $oldVal and $val eq 'MISSING';
                    } elsif (defined $oldVal) {
                        my $t = "$lang $tagName";
                        unless (defined $different{$t} and $different{$t} eq $val) {
                            my $a = defined $different{$t} ? 'ANOTHER ' : '';
                            warn "${a}Different '${lang}' desc for $tagName: $val (was $$langInfo{Description})\n";
                            next if defined $different{$t}; # don't change back again
                            $different{$t} = $val;
                        }
                        next unless $overrideDifferent;
                    }
                    next if $isDefault;
                    if (defined $defDesc and $defDesc eq $val) {
                        delete $$langInfo{Description}; # delete if same as default language
                    } else {
                        $$langInfo{Description} = $val;
                    }
                } else {
                    defined $key or warn("No key for $$tagInfo{Name}"), next;
                    my $printConv = $$tagInfo{PrintConv};
                    if (ref $printConv eq 'ARRAY') {
                        defined $valIndex or warn('No value index'), next;
                        $printConv = $$printConv[$valIndex];
                    }
                    ref $printConv eq 'HASH' or warn('No PrintConv'), next;
                    my $convVal = $$printConv{$key};
                    unless (defined $convVal) {
                        if ($$printConv{BITMASK} and $key =~ /^\d+$/) {
                            my $i;
                            for ($i=0; $i<64; ++$i) {
                                my $mask = (0x01 << $i) or last;
                                next unless $key == $mask;
                                $convVal = $$printConv{BITMASK}{$i};
                            }
                        }
                        warn("Missing PrintConv entry for $tableName $$tagInfo{Name} $key\n") and next unless defined $convVal;
                    }
                    if ($cap and $convVal =~ /^[a-z]/) {
                        $val = lcfirst $val;    # change back to lower case
                        undef $cap;
                    }
                    my $lc = $$langInfo{PrintConv};
                    $lc or $lc = $$langInfo{PrintConv} = { };
                    $lc = $printConv if ref $lc eq 'ARRAY'; #(default lang only)
                    my $oldVal = $$lc{$convVal};
                    next if defined $oldVal and $oldVal eq $val;
                    if ($makeMissing) {
                        next if defined $oldVal and $val eq 'MISSING';
                    } elsif (defined $oldVal and (not $isDefault or not $val=~/^\d+$/)) {
                        my $t = "$lang $tagName $convVal";
                        unless (defined $different{$t} and $different{$t} eq $val) {
                            my $a = defined $different{$t} ? 'ANOTHER ' : '';
                            warn "${a}Different '${lang}' val for $tagName '${convVal}': $val (was $oldVal)\n";
                            next if defined $different{$t}; # don't change back again
                            $different{$t} = $val;
                        }
                        next unless $overrideDifferent;
                    }
                    next if $isDefault;
                    warn("Capitalized '${lang}' val for $tagName: $tval\n") if $cap;
                    $$lc{$convVal} = $val;
                }
                $changed{$lang} = 1;
            }
        }
        close XFILE;
    }
    # rewrite all changed Lang modules
    my $rtnVal = 0;
    foreach $lang ($updateFlag & 0x02 ? @Image::ExifTool::langs : sort keys %changed) {
        next if $lang eq $Image::ExifTool::defaultLang;
        ++$rtnVal;
        # write this module (only increment version number if not forced)
        WriteLangModule($lang, $langInfo{$lang}, not $updateFlag & 0x01) or $rtnVal = -1, last;
    }
    return $rtnVal;
}
#------------------------------------------------------------------------------
# Write Lang module
# Inputs: 0) language string, 1) langInfo lookup reference, 2) flag to increment version
# Returns: true on success
sub WriteLangModule($$;$)
{
    local ($_, *XOUT);
    my ($lang, $langTags, $newVersion) = @_;
    my $err;
    -e "lib/Image/ExifTool" or die "Must run from directory containing 'lib'\n";
    my $out = "lib/Image/ExifTool/Lang/$lang.pm";
    my $tmp = "$out.tmp";
    open XOUT, ">$tmp" or die "Error creating $tmp\n";
    my $ver = "Image::ExifTool::Lang::${lang}::VERSION";
    no strict 'refs';
    if ($$ver) {
        $ver = $$ver;
        $ver = int($ver * 100 + 1.5) / 100 if $newVersion;
    } else {
        $ver = 1.0;
    }
    $ver = sprintf('%.2f', $ver);
    use strict 'refs';
    my $langName = $Image::ExifTool::langName{$lang} || $lang;
    $langName =~ s/\s*\(.*//;
    print XOUT <<HEADER;
#------------------------------------------------------------------------------
# File:         $lang.pm
#
# Description:  ExifTool $langName language translations
#
# Notes:        This file generated automatically by Image::ExifTool::TagInfoXML
#------------------------------------------------------------------------------
package Image::ExifTool::Lang::$lang;
use strict;
use vars qw(\$VERSION);
\$VERSION = '${ver}';
HEADER
    print XOUT "\%Image::ExifTool::Lang::${lang}::Translate = (\n";
    # loop through all tag and table names
    my $tag;
    foreach $tag (sort keys %$langTags) {
        my $desc = $$langTags{$tag};
        my $conv;
        if (ref $desc) {
            $conv = $$desc{PrintConv};
            $desc = $$desc{Description};
            # remove description if not necessary
            # (not strictly correct -- should test against tag description, not name)
            undef $desc if $desc and $desc eq $tag;
            # remove unnecessary value translations
            if ($conv) {
                my @keys = keys %$conv;
                foreach (@keys) {
                    delete $$conv{$_} if $_ eq $$conv{$_};
                }
                undef $conv unless %$conv;
            }
        }
        if (defined $desc) {
            $desc = EscapePerl($desc);
        } else {
            next unless $conv;
        }
        print XOUT "   '${tag}' => ";
        unless ($conv) {
            print XOUT "'${desc}',\n";
            next;
        }
        print XOUT "{\n";
        print XOUT "      Description => '${desc}',\n" if defined $desc;
        if ($conv) {
            print XOUT "      PrintConv => {\n";
            foreach (sort keys %$conv) {
                my $str = EscapePerl($_);
                my $val = EscapePerl($$conv{$_});
                print XOUT "        '${str}' => '${val}',\n";
            }
            print XOUT "      },\n";
        }
        print XOUT "    },\n";
    }
    # generate acknowledgements for this language
    my $ack;
    if ($credits{$lang}) {
        $ack = "Thanks to $credits{$lang} for providing this translation.";
        $ack =~ s/(.{1,76})( +|$)/$1\n/sg;  # wrap text to 76 columns
        $ack = "~head1 ACKNOWLEDGEMENTS\n\n$ack\n";
    } else {
        $ack = '';
    }
    my $footer = <<FOOTER;
);
1;  # end
__END__
~head1 NAME
Image::ExifTool::Lang::$lang.pm - ExifTool $langName language translations
~head1 DESCRIPTION
This file is used by Image::ExifTool to generate localized tag descriptions
and values.
~head1 AUTHOR
Copyright 2003-2025, Phil Harvey (philharvey66 at gmail.com)
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
$ack~head1 SEE ALSO
L<Image::ExifTool(3pm)|Image::ExifTool>,
L<Image::ExifTool::TagInfoXML(3pm)|Image::ExifTool::TagInfoXML>
~cut
FOOTER
    $footer =~ s/^~/=/mg;   # un-do pod obfuscation
    print XOUT $footer or $err = 1;
    close XOUT or $err = 1;
    if ($err or not rename($tmp, $out)) {
        warn "Error writing $out\n";
        unlink $tmp;
        $err = 1;
    }
    return $err ? 0 : 1;
}
#------------------------------------------------------------------------------
# load all lang modules into hash
# Inputs: 0) Hash reference, 1) specific language to load (undef for all)
sub LoadLangModules($;$)
{
    my ($langHash, $lang) = @_;
    require Image::ExifTool;
    my @langs = $lang ? ($lang) : @Image::ExifTool::langs;
    foreach $lang (@langs) {
        next if $lang eq $Image::ExifTool::defaultLang;
        eval "require Image::ExifTool::Lang::$lang" or warn("Can't load Lang::$lang\n"), next;
        my $xlat = "Image::ExifTool::Lang::${lang}::Translate";
        no strict 'refs';
        %$xlat or warn("Missing Info for $lang\n"), next;
        $$langHash{$lang} = \%$xlat;
        use strict 'refs';
    }
}
#------------------------------------------------------------------------------
# sort numbers first numerically, then strings alphabetically (case insensitive)
sub NumbersFirst
{
    my $rtnVal;
    my ($bNum, $bDec);
    ($bNum, $bDec) = ($1, $3) if $b =~ /^(-?[0-9]+)(\.(\d*))?$/;
    if ($a =~ /^(-?[0-9]+)(\.(\d*))?$/) {
        if (defined $bNum) {
            $bNum += 1e9 if $numbersFirst == 2 and $bNum < 0;
            my $aInt = $1;
            $aInt += 1e9 if $numbersFirst == 2 and $aInt < 0;
            # compare integer part as a number
            $rtnVal = $aInt <=> $bNum;
            unless ($rtnVal) {
                my $aDec = $3 || 0;
                $bDec or $bDec = 0;
                # compare decimal part as an integer too
                # (so that "1.10" comes after "1.9")
                $rtnVal = $aDec <=> $bDec;
            }
        } else {
            $rtnVal = -$numbersFirst;
        }
    } elsif (defined $bNum) {
        $rtnVal = $numbersFirst;
    } else {
        my ($a2, $b2) = ($a, $b);
        # expand numbers to 3 digits (with restrictions to avoid messing up ascii-hex tags)
        $a2 =~ s/(\d+)/sprintf("%.3d",$1)/eg if $a2 =~ /^(APP|DMC-\w+ )?[.0-9 ]*$/ and length($a2)<16;
        $b2 =~ s/(\d+)/sprintf("%.3d",$1)/eg if $b2 =~ /^(APP|DMC-\w+ )?[.0-9 ]*$/ and length($b2)<16;
        $caseInsensitive and $rtnVal = (lc($a2) cmp lc($b2));
        $rtnVal or $rtnVal = ($a2 cmp $b2);
    }
    return $rtnVal;
}
1;  # end
__END__
HideShow 112 lines of Pod
=head1 NAME
Image::ExifTool::TagInfoXML - Read/write tag information XML database
=head1 DESCRIPTION
This module is used to generate an XML database from all ExifTool tag
information.  The XML database may then be edited and used to re-generate
the language modules (Image::ExifTool::Lang::*).
=head1 METHODS
=head2 Write
Print complete tag information database in XML format.
  # save list of all tags
  $success = Image::ExifTool::TagInfoXML::Write('dst.xml');
  # list all IPTC tags to console, including Flags
  Image::ExifTool::TagInfoXML::Write(undef, 'IPTC', Flags => 1);
  # write all EXIF Camera tags to file
  Image::ExifTool::TagInfoXML::Write($outfile, 'exif:camera');
=over 4
=item Inputs:
0) [optional] Output file name, or undef for console output.  Output file
will be overwritten if it already exists.
1) [optional] String of group names separated by colons to specify the group
to print.  A specific IFD may not be given as a group, since EXIF tags may
be written to any IFD.  Saves all groups if not specified.
2) [optional] Hash of options values:
    Flags   - Set to output 'flags' attribute
    NoDesc  - Set to suppress output of descriptions
    Lang    - Select a single language for output
=item Return Value:
True on success.
=item Sample XML Output:
=back
  <?xml version='1.0' encoding='UTF-8'?>
  <taginfo>
  <table name='XMP::dc' g0='XMP' g1='XMP-dc' g2='Other'>
   <desc lang='en'>XMP Dublin Core</desc>
   <tag id='title' name='Title' type='lang-alt' writable='true' g2='Image'>
    <desc lang='en'>Title</desc>
    <desc lang='de'>Titel</desc>
    <desc lang='fr'>Titre</desc>
   </tag>
   ...
  </table>
  </taginfo>
Flags (if selected and available) are formatted as a comma-separated list of
the following possible values:  Avoid, Binary, List, Mandatory, Permanent,
Protected, Unknown and Unsafe.  See the
L<tag name documentation|Image::ExifTool::TagNames> and
lib/Image/ExifTool/README for a description of these flags.  For XMP List
tags, the list type (Alt, Bag or Seq) is also output as a flag if
applicable.
=head2 BuildLangModules
Build all Image::ExifTool::Lang modules from an XML database file.
    Image::ExifTool::TagInfoXML::BuildLangModules('src.xml');
=over 4
=item Inputs:
0) XML file name
1) Update flags:
    0x01 = preserve version numbers
    0x02 = update all modules, even if they didn't change
    0x04 = update from scratch, ignoring existing definitions
    0x08 = override existing different descriptions and values
=item Return Value:
Number of modules updated, or negative on error.
=back
=head1 AUTHOR
Copyright 2003-2025, Phil Harvey (philharvey66 at gmail.com)
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
=head1 SEE ALSO
L<Image::ExifTool(3pm)|Image::ExifTool>,
L<Image::ExifTool::TagNames(3pm)|Image::ExifTool::TagNames>
=cut