| 1 | #------------------------------------------------------------------------------
|
|---|
| 2 | # File: TagInfoXML.pm
|
|---|
| 3 | #
|
|---|
| 4 | # Description: Read/write tag information XML database
|
|---|
| 5 | #
|
|---|
| 6 | # Revisions: 2009/01/28 - P. Harvey Created
|
|---|
| 7 | #------------------------------------------------------------------------------
|
|---|
| 8 |
|
|---|
| 9 | package Image::ExifTool::TagInfoXML;
|
|---|
| 10 |
|
|---|
| 11 | use strict;
|
|---|
| 12 | require Exporter;
|
|---|
| 13 |
|
|---|
| 14 | use vars qw($VERSION @ISA);
|
|---|
| 15 | use Image::ExifTool qw(:Utils :Vars);
|
|---|
| 16 | use Image::ExifTool::XMP;
|
|---|
| 17 |
|
|---|
| 18 | $VERSION = '1.15';
|
|---|
| 19 | @ISA = qw(Exporter);
|
|---|
| 20 |
|
|---|
| 21 | # set this to a language code to generate Lang module with 'MISSING' entries
|
|---|
| 22 | my $makeMissing = '';
|
|---|
| 23 |
|
|---|
| 24 | # set this to true to override existing different descriptions/values
|
|---|
| 25 | my $overrideDifferent;
|
|---|
| 26 |
|
|---|
| 27 | sub LoadLangModules($);
|
|---|
| 28 | sub WriteLangModule($$;$);
|
|---|
| 29 | sub NumbersFirst;
|
|---|
| 30 |
|
|---|
| 31 | # names for acknowledgements in the POD documentation
|
|---|
| 32 | my %credits = (
|
|---|
| 33 | cs => 'Jens Duttke and Petr MichE<aacute>lek',
|
|---|
| 34 | de => 'Jens Duttke and Herbert Kauer',
|
|---|
| 35 | es => 'Jens Duttke and Santiago del BrE<iacute>o GonzE<aacute>lez',
|
|---|
| 36 | fr => 'Jens Duttke, Bernard Guillotin, Jean Glasser, Jean Piquemal and Harry Nizard',
|
|---|
| 37 | it => 'Jens Duttke, Ferdinando Agovino and Emilio Dati',
|
|---|
| 38 | ja => 'Jens Duttke and Kazunari Nishina',
|
|---|
| 39 | ko => 'Jens Duttke and Jeong Beom Kim',
|
|---|
| 40 | nl => 'Jens Duttke, Peter Moonen and Herman Beld',
|
|---|
| 41 | pl => 'Jens Duttke and Przemyslaw Sulek',
|
|---|
| 42 | ru => 'Jens Duttke, Sergey Shemetov, Dmitry Yerokhin and Anton Sukhinov',
|
|---|
| 43 | sv => 'Jens Duttke and BjE<ouml>rn SE<ouml>derstrE<ouml>m',
|
|---|
| 44 | 'tr' => 'Jens Duttke, Hasan Yildirim and Cihan Ulusoy',
|
|---|
| 45 | zh_cn => 'Jens Duttke and Haibing Zhong',
|
|---|
| 46 | zh_tw => 'Jens Duttke and MikeF',
|
|---|
| 47 | );
|
|---|
| 48 |
|
|---|
| 49 | # translate country codes to language codes
|
|---|
| 50 | my %translateLang = (
|
|---|
| 51 | ch_s => 'zh_cn',
|
|---|
| 52 | ch_cn => 'zh_cn',
|
|---|
| 53 | ch_tw => 'zh_tw',
|
|---|
| 54 | cz => 'cs',
|
|---|
| 55 | jp => 'ja',
|
|---|
| 56 | kr => 'ko',
|
|---|
| 57 | se => 'sv',
|
|---|
| 58 | );
|
|---|
| 59 |
|
|---|
| 60 | my $caseInsensitive; # used internally by sort routine
|
|---|
| 61 |
|
|---|
| 62 | #------------------------------------------------------------------------------
|
|---|
| 63 | # Utility to print tag information database as an XML list
|
|---|
| 64 | # Inputs: 0) output file name (undef to send to console),
|
|---|
| 65 | # 1) group name (may be undef), 2) options hash ('Flags','NoDesc')
|
|---|
| 66 | # Returns: true on success
|
|---|
| 67 | sub Write(;$$%)
|
|---|
| 68 | {
|
|---|
| 69 | local ($_, *PTIFILE);
|
|---|
| 70 | my ($file, $group, %opts) = @_;
|
|---|
| 71 | my @groups = split ':', $group if $group;
|
|---|
| 72 | my $exifTool = new Image::ExifTool;
|
|---|
| 73 | my ($fp, $tableName, %langInfo, @langs, $defaultLang);
|
|---|
| 74 |
|
|---|
| 75 | Image::ExifTool::LoadAllTables(); # first load all our tables
|
|---|
| 76 | unless ($opts{NoDesc}) {
|
|---|
| 77 | LoadLangModules(\%langInfo); # load all existing Lang modules
|
|---|
| 78 | @langs = sort keys %langInfo;
|
|---|
| 79 | $defaultLang = $Image::ExifTool::defaultLang;
|
|---|
| 80 | }
|
|---|
| 81 | if (defined $file) {
|
|---|
| 82 | open PTIFILE, ">$file" or return 0;
|
|---|
| 83 | $fp = \*PTIFILE;
|
|---|
| 84 | } else {
|
|---|
| 85 | $fp = \*STDOUT;
|
|---|
| 86 | }
|
|---|
| 87 | print $fp "<?xml version='1.0' encoding='UTF-8'?>\n";
|
|---|
| 88 | print $fp "<taginfo>\n\n";
|
|---|
| 89 |
|
|---|
| 90 | # loop through all tables and save tag names to %allTags hash
|
|---|
| 91 | foreach $tableName (sort keys %allTables) {
|
|---|
| 92 | my $table = GetTagTable($tableName);
|
|---|
| 93 | my $grps = $$table{GROUPS};
|
|---|
| 94 | my ($tagID, $didTag);
|
|---|
| 95 | # sort in same order as tag name documentation
|
|---|
| 96 | $caseInsensitive = ($tableName =~ /::XMP::/);
|
|---|
| 97 | my @keys = sort NumbersFirst TagTableKeys($table);
|
|---|
| 98 | # get list of languages defining elements in this table
|
|---|
| 99 | my $isBinary = ($$table{PROCESS_PROC} and
|
|---|
| 100 | $$table{PROCESS_PROC} eq \&Image::ExifTool::ProcessBinaryData);
|
|---|
| 101 | # loop throug all tag ID's in this table
|
|---|
| 102 | foreach $tagID (@keys) {
|
|---|
| 103 | my @infoArray = GetTagInfoList($table, $tagID);
|
|---|
| 104 | my $xmlID = Image::ExifTool::XMP::FullEscapeXML($tagID);
|
|---|
| 105 | # get a list of languages defining elements for this ID
|
|---|
| 106 | my ($index, $fam);
|
|---|
| 107 | PTILoop: for ($index=0; $index<@infoArray; ++$index) {
|
|---|
| 108 | my $tagInfo = $infoArray[$index];
|
|---|
| 109 | # don't list subdirectories unless they are writable
|
|---|
| 110 | next unless $$tagInfo{Writable} or not $$tagInfo{SubDirectory};
|
|---|
| 111 | if (@groups) {
|
|---|
| 112 | my @tg = $exifTool->GetGroup($tagInfo);
|
|---|
| 113 | foreach $group (@groups) {
|
|---|
| 114 | next PTILoop unless grep /^$group$/i, @tg;
|
|---|
| 115 | }
|
|---|
| 116 | }
|
|---|
| 117 | unless ($didTag) {
|
|---|
| 118 | my $tname = $$table{SHORT_NAME};
|
|---|
| 119 | print $fp "<table name='$tname' g0='$$grps{0}' g1='$$grps{1}' g2='$$grps{2}'>\n";
|
|---|
| 120 | unless ($opts{NoDesc}) {
|
|---|
| 121 | # print table description
|
|---|
| 122 | my $desc = $$table{TABLE_DESC};
|
|---|
| 123 | unless ($desc) {
|
|---|
| 124 | ($desc = $tname) =~ s/::Main$//;
|
|---|
| 125 | $desc =~ s/::/ /g;
|
|---|
| 126 | }
|
|---|
| 127 | # print alternate language descriptions
|
|---|
| 128 | print $fp " <desc lang='en'>$desc</desc>\n";
|
|---|
| 129 | foreach (@langs) {
|
|---|
| 130 | $desc = $langInfo{$_}{$tableName} or next;
|
|---|
| 131 | $desc = Image::ExifTool::XMP::EscapeXML($desc);
|
|---|
| 132 | print $fp " <desc lang='$_'>$desc</desc>\n";
|
|---|
| 133 | }
|
|---|
| 134 | }
|
|---|
| 135 | $didTag = 1;
|
|---|
| 136 | }
|
|---|
| 137 | my $name = $$tagInfo{Name};
|
|---|
| 138 | my $ind = @infoArray > 1 ? " index='$index'" : '';
|
|---|
| 139 | my $format = $$tagInfo{Writable} || $$table{WRITABLE};
|
|---|
| 140 | my $writable = $format ? 'true' : 'false';
|
|---|
| 141 | # check our conversions to make sure we can really write this tag
|
|---|
| 142 | if ($writable eq 'true') {
|
|---|
| 143 | foreach ('PrintConv','ValueConv') {
|
|---|
| 144 | next unless $$tagInfo{$_};
|
|---|
| 145 | next if $$tagInfo{$_ . 'Inv'};
|
|---|
| 146 | next if ref($$tagInfo{$_}) =~ /^(HASH|ARRAY)$/;
|
|---|
| 147 | next if $$tagInfo{WriteAlso};
|
|---|
| 148 | $writable = 'false';
|
|---|
| 149 | last;
|
|---|
| 150 | }
|
|---|
| 151 | }
|
|---|
| 152 | $format = $$tagInfo{Format} || $$table{FORMAT} if not defined $format or $format eq '1';
|
|---|
| 153 | if (defined $format) {
|
|---|
| 154 | $format =~ s/\[.*\$.*\]//; # remove expressions from format
|
|---|
| 155 | } elsif ($isBinary) {
|
|---|
| 156 | $format = 'int8u';
|
|---|
| 157 | } else {
|
|---|
| 158 | $format = '?';
|
|---|
| 159 | }
|
|---|
| 160 | my $count = '';
|
|---|
| 161 | if ($format =~ s/\[.*?(\d*)\]$//) {
|
|---|
| 162 | $count = " count='$1'" if length $1;
|
|---|
| 163 | }
|
|---|
| 164 | my @groups = $exifTool->GetGroup($tagInfo);
|
|---|
| 165 | my $writeGroup = $$tagInfo{WriteGroup} || $$table{WRITE_GROUP};
|
|---|
| 166 | if ($writeGroup and $writeGroup ne 'Comment') {
|
|---|
| 167 | $groups[1] = $writeGroup; # use common write group for group 1
|
|---|
| 168 | }
|
|---|
| 169 | # add group names if different from table defaults
|
|---|
| 170 | my $grp = '';
|
|---|
| 171 | for ($fam=0; $fam<3; ++$fam) {
|
|---|
| 172 | $grp .= " g$fam='$groups[$fam]'" if $groups[$fam] ne $$grps{$fam};
|
|---|
| 173 | }
|
|---|
| 174 | # add flags if necessary
|
|---|
| 175 | if ($opts{Flags}) {
|
|---|
| 176 | my @flags;
|
|---|
| 177 | foreach (qw(Avoid Binary List Mandatory Unknown)) {
|
|---|
| 178 | push @flags, $_ if $$tagInfo{$_};
|
|---|
| 179 | }
|
|---|
| 180 | push @flags, $$tagInfo{List} if $$tagInfo{List} and $$tagInfo{List} =~ /^(Alt|Bag|Seq)$/;
|
|---|
| 181 | push @flags, 'Unsafe' if $$tagInfo{Protected} and $$tagInfo{Protected} & 0x01;
|
|---|
| 182 | push @flags, 'Protected' if $$tagInfo{Protected} and $$tagInfo{Protected} & 0x02;
|
|---|
| 183 | push @flags, 'Permanent' if $$tagInfo{Permanent} or
|
|---|
| 184 | ($groups[0] eq 'MakerNotes' and not defined $$tagInfo{Permanent});
|
|---|
| 185 | $grp = " flags='" . join(',', sort @flags) . "'$grp" if @flags;
|
|---|
| 186 | }
|
|---|
| 187 | print $fp " <tag id='$xmlID' name='$name'$ind type='$format'$count writable='$writable'$grp";
|
|---|
| 188 | if ($opts{NoDesc}) {
|
|---|
| 189 | # short output format
|
|---|
| 190 | print $fp "/>\n"; # empty tag element
|
|---|
| 191 | next; # no descriptions or values
|
|---|
| 192 | }
|
|---|
| 193 | my $desc = $$tagInfo{Description};
|
|---|
| 194 | $desc = Image::ExifTool::MakeDescription($name) unless defined $desc;
|
|---|
| 195 | # add alternate language descriptions and get references
|
|---|
| 196 | # to alternate language PrintConv hashes
|
|---|
| 197 | my $altDescr = '';
|
|---|
| 198 | my %langConv;
|
|---|
| 199 | foreach (@langs) {
|
|---|
| 200 | my $ld = $langInfo{$_}{$name} or next;
|
|---|
| 201 | if (ref $ld) {
|
|---|
| 202 | $langConv{$_} = $$ld{PrintConv};
|
|---|
| 203 | $ld = $$ld{Description} or next;
|
|---|
| 204 | }
|
|---|
| 205 | # ignore descriptions that are the same as the default language
|
|---|
| 206 | next if $ld eq $desc;
|
|---|
| 207 | $ld = Image::ExifTool::XMP::EscapeXML($ld);
|
|---|
| 208 | $altDescr .= "\n <desc lang='$_'>$ld</desc>";
|
|---|
| 209 | }
|
|---|
| 210 | # print tag descriptions
|
|---|
| 211 | $desc = Image::ExifTool::XMP::EscapeXML($desc);
|
|---|
| 212 | print $fp ">\n <desc lang='$defaultLang'>$desc</desc>$altDescr\n";
|
|---|
| 213 | for (my $i=0; ; ++$i) {
|
|---|
| 214 | my $conv = $$tagInfo{PrintConv};
|
|---|
| 215 | my $idx = '';
|
|---|
| 216 | if (ref $conv eq 'ARRAY') {
|
|---|
| 217 | last unless $i < @$conv;
|
|---|
| 218 | $conv = $$conv[$i];
|
|---|
| 219 | $idx = " index='$i'";
|
|---|
| 220 | } else {
|
|---|
| 221 | last if $i;
|
|---|
| 222 | }
|
|---|
| 223 | next unless ref $conv eq 'HASH';
|
|---|
| 224 | # make a list of available alternate languages
|
|---|
| 225 | my @langConv = sort keys %langConv;
|
|---|
| 226 | print $fp " <values$idx>\n";
|
|---|
| 227 | my $key;
|
|---|
| 228 | $caseInsensitive = 0;
|
|---|
| 229 | # add bitmask values to main lookup
|
|---|
| 230 | if ($$conv{BITMASK}) {
|
|---|
| 231 | foreach $key (keys %{$$conv{BITMASK}}) {
|
|---|
| 232 | my $mask = 0x01 << $key;
|
|---|
| 233 | next if $$conv{$mask};
|
|---|
| 234 | $$conv{$mask} = $$conv{BITMASK}{$key};
|
|---|
| 235 | }
|
|---|
| 236 | }
|
|---|
| 237 | foreach $key (sort NumbersFirst keys %$conv) {
|
|---|
| 238 | next if $key eq 'BITMASK' or $key eq 'OTHER' or $key eq 'Notes';
|
|---|
| 239 | my $val = $$conv{$key};
|
|---|
| 240 | my $xmlVal = Image::ExifTool::XMP::EscapeXML($val);
|
|---|
| 241 | my $xmlKey = Image::ExifTool::XMP::FullEscapeXML($key);
|
|---|
| 242 | print $fp " <key id='$xmlKey'>";
|
|---|
| 243 | print $fp "\n <val lang='$defaultLang'>$xmlVal</val>\n";
|
|---|
| 244 | # add alternate language values
|
|---|
| 245 | foreach (@langConv) {
|
|---|
| 246 | my $lv = $langConv{$_};
|
|---|
| 247 | # handle indexed PrintConv entries
|
|---|
| 248 | $lv = $$lv[$i] or next if ref $lv eq 'ARRAY';
|
|---|
| 249 | $lv = $$lv{$val};
|
|---|
| 250 | # ignore values that are missing or same as default
|
|---|
| 251 | next unless defined $lv and $lv ne $val;
|
|---|
| 252 | $lv = Image::ExifTool::XMP::EscapeXML($lv);
|
|---|
| 253 | print $fp " <val lang='$_'>$lv</val>\n";
|
|---|
| 254 | }
|
|---|
| 255 | print $fp " </key>\n";
|
|---|
| 256 | }
|
|---|
| 257 | print $fp " </values>\n";
|
|---|
| 258 | }
|
|---|
| 259 | print $fp " </tag>\n";
|
|---|
| 260 | }
|
|---|
| 261 | }
|
|---|
| 262 | print $fp "</table>\n\n" if $didTag;
|
|---|
| 263 | }
|
|---|
| 264 | my $success = 1;
|
|---|
| 265 | print $fp "</taginfo>\n" or $success = 0;
|
|---|
| 266 | close $fp or $success = 0 if defined $file;
|
|---|
| 267 | return $success;
|
|---|
| 268 | }
|
|---|
| 269 |
|
|---|
| 270 | #------------------------------------------------------------------------------
|
|---|
| 271 | # Perl-ize this constant
|
|---|
| 272 | # Inputs: string
|
|---|
| 273 | # Returns: constant string for Perl
|
|---|
| 274 | sub Perlize($)
|
|---|
| 275 | {
|
|---|
| 276 | my $str = shift;
|
|---|
| 277 | unless (($str =~ /^[+-]?(?=\d|\.\d)\d*(\.\d*)?$/ and # int or float
|
|---|
| 278 | not $str =~ /^[+-]?0\d+$/) or # not octal
|
|---|
| 279 | $str =~ /^0x[0-9a-f]+$/i) # hexadecimal
|
|---|
| 280 | {
|
|---|
| 281 | # translate unprintable characters
|
|---|
| 282 | $str =~ s/\\/\\\\/g; # escape backslashes
|
|---|
| 283 | if ($str =~ /([\x00-\x1f\x80-\xff])/) {
|
|---|
| 284 | $str =~ s/"/\\"/g; # escape double quotes
|
|---|
| 285 | # escape unprintable characters
|
|---|
| 286 | $str =~ s/([\x00-\x1f\x80-\xff])/sprintf("\\x%.2x",ord $1)/eg;
|
|---|
| 287 | $str = qq{"$str"};
|
|---|
| 288 | } else {
|
|---|
| 289 | $str =~ s/'/\\'/g; # escape single quotes
|
|---|
| 290 | $str = qq{'$str'};
|
|---|
| 291 | }
|
|---|
| 292 | }
|
|---|
| 293 | return $str;
|
|---|
| 294 | }
|
|---|
| 295 |
|
|---|
| 296 | #------------------------------------------------------------------------------
|
|---|
| 297 | # Escape backslash and quote in string
|
|---|
| 298 | # Inputs: string
|
|---|
| 299 | # Returns: escaped string
|
|---|
| 300 | sub EscapePerl
|
|---|
| 301 | {
|
|---|
| 302 | my $str = shift;
|
|---|
| 303 | $str =~ s/\\/\\\\/g;
|
|---|
| 304 | $str =~ s/'/\\'/g;
|
|---|
| 305 | return $str;
|
|---|
| 306 | }
|
|---|
| 307 |
|
|---|
| 308 | #------------------------------------------------------------------------------
|
|---|
| 309 | # Generate Lang modules from input tag info XML database
|
|---|
| 310 | # Inputs: 0) XML filename, 1) update flag:
|
|---|
| 311 | # undef = default (update changed modules only)
|
|---|
| 312 | # 0 = (update changed modules only, but preserve version numbers)
|
|---|
| 313 | # 1 = (update all, but preserve version numbers)
|
|---|
| 314 | # 2 = (update all from scratch, but preserve version numbers)
|
|---|
| 315 | # Returns: Count of updated Lang modules, or -1 on error
|
|---|
| 316 | # Notes: Must be run from the directory containing 'lib'
|
|---|
| 317 | sub BuildLangModules($;$)
|
|---|
| 318 | {
|
|---|
| 319 | local ($_, *XFILE);
|
|---|
| 320 | my ($file, $forceUpdate) = @_;
|
|---|
| 321 | my ($table, $tableName, $id, $index, $valIndex, $name, $key, $lang);
|
|---|
| 322 | my (%langInfo, %different, %changed);
|
|---|
| 323 |
|
|---|
| 324 | Image::ExifTool::LoadAllTables(); # first load all our tables
|
|---|
| 325 | LoadLangModules(\%langInfo); # load all existing Lang modules
|
|---|
| 326 | %langInfo = () if $forceUpdate and $forceUpdate eq '2';
|
|---|
| 327 |
|
|---|
| 328 | if (defined $file) {
|
|---|
| 329 | open XFILE, $file or return -1;
|
|---|
| 330 | while (<XFILE>) {
|
|---|
| 331 | next unless /^\s*<(\/?)(\w+)/;
|
|---|
| 332 | my $tok = $2;
|
|---|
| 333 | if ($1) {
|
|---|
| 334 | # close appropriate entities
|
|---|
| 335 | if ($tok eq 'tag') {
|
|---|
| 336 | undef $id;
|
|---|
| 337 | undef $index;
|
|---|
| 338 | undef $name;
|
|---|
| 339 | } elsif ($tok eq 'values') {
|
|---|
| 340 | undef $key;
|
|---|
| 341 | undef $valIndex;
|
|---|
| 342 | } elsif ($tok eq 'table') {
|
|---|
| 343 | undef $table;
|
|---|
| 344 | undef $id;
|
|---|
| 345 | }
|
|---|
| 346 | next;
|
|---|
| 347 | }
|
|---|
| 348 | if ($tok eq 'table') {
|
|---|
| 349 | /^\s*<table name='([^']+)'[ >]/ or warn('Bad table'), next;
|
|---|
| 350 | $tableName = "Image::ExifTool::$1";
|
|---|
| 351 | # ignore userdefined tables
|
|---|
| 352 | next if $tableName =~ /^Image::ExifTool::UserDefined/;
|
|---|
| 353 | $table = Image::ExifTool::GetTagTable($tableName);
|
|---|
| 354 | $table or warn("Unknown tag table $tableName\n");
|
|---|
| 355 | next;
|
|---|
| 356 | }
|
|---|
| 357 | next unless defined $table;
|
|---|
| 358 | if ($tok eq 'tag') {
|
|---|
| 359 | /^\s*<tag id='([^']*)' name='([^']+)'( index='(\d+)')?[ >]/ or warn('Bad tag'), next;
|
|---|
| 360 | $id = Image::ExifTool::XMP::FullUnescapeXML($1);
|
|---|
| 361 | $name = $2;
|
|---|
| 362 | $index = $4;
|
|---|
| 363 | $id = hex($id) if $id =~ /^0x[\da-fA-F]+$/; # convert hex ID's
|
|---|
| 364 | next;
|
|---|
| 365 | }
|
|---|
| 366 | if ($tok eq 'values') {
|
|---|
| 367 | /^\s*<values index='([^']*)'>/ or next;
|
|---|
| 368 | $valIndex = $1;
|
|---|
| 369 | } elsif ($tok eq 'key') {
|
|---|
| 370 | defined $id or warn('No ID'), next;
|
|---|
| 371 | /^\s*<key id='([^']*)'>/ or warn('Bad key'), next;
|
|---|
| 372 | $key = Image::ExifTool::XMP::FullUnescapeXML($1);
|
|---|
| 373 | $key = hex($key) if $key =~ /^0x[\da-fA-F]+$/; # convert hex keys
|
|---|
| 374 | } elsif ($tok eq 'val' or $tok eq 'desc') {
|
|---|
| 375 | /^\s*<$tok( lang='([-\w]+?)')?>(.*)<\/$tok>/ or warn("Bad $tok"), next;
|
|---|
| 376 | $tok eq 'desc' and defined $key and warn('Out of order "desc"'), next;
|
|---|
| 377 | my $lang = $2 or next; # looking only for alternate languages
|
|---|
| 378 | $lang =~ tr/-A-Z/_a-z/;
|
|---|
| 379 | # use standard ISO 639-1 language codes
|
|---|
| 380 | $lang = $translateLang{$lang} if $translateLang{$lang};
|
|---|
| 381 | my $tval = Image::ExifTool::XMP::UnescapeXML($3);
|
|---|
| 382 | my $val = ucfirst $tval;
|
|---|
| 383 | my $cap = ($tval ne $val);
|
|---|
| 384 | if ($makeMissing and $lang eq 'en') {
|
|---|
| 385 | $lang = $makeMissing;
|
|---|
| 386 | $val = 'MISSING';
|
|---|
| 387 | }
|
|---|
| 388 | my $isDefault = ($lang eq $Image::ExifTool::defaultLang);
|
|---|
| 389 | unless ($langInfo{$lang} or $isDefault) {
|
|---|
| 390 | print "Creating new language $lang\n";
|
|---|
| 391 | $langInfo{$lang} = { };
|
|---|
| 392 | }
|
|---|
| 393 | defined $name or $name = '<unknown>';
|
|---|
| 394 | unless (defined $id) {
|
|---|
| 395 | next if $isDefault;
|
|---|
| 396 | # this is a table description
|
|---|
| 397 | next if $langInfo{$lang}{$tableName} and
|
|---|
| 398 | $langInfo{$lang}{$tableName} eq $val;
|
|---|
| 399 | $langInfo{$lang}{$tableName} = $val;
|
|---|
| 400 | $changed{$lang} = 1;
|
|---|
| 401 | warn("Capitalized '$lang' val for $name: $val\n") if $cap;
|
|---|
| 402 | next;
|
|---|
| 403 | }
|
|---|
| 404 | my @infoArray = GetTagInfoList($table, $id);
|
|---|
| 405 |
|
|---|
| 406 | # this will fail for UserDefined tags and tags without ID's
|
|---|
| 407 | @infoArray or warn("Error loading tag for $tableName ID='$id'\n"), next;
|
|---|
| 408 | my ($tagInfo, $langInfo);
|
|---|
| 409 | if (defined $index) {
|
|---|
| 410 | $tagInfo = $infoArray[$index];
|
|---|
| 411 | $tagInfo or warn('Invalid index'), next;
|
|---|
| 412 | } else {
|
|---|
| 413 | @infoArray > 1 and warn('Missing index'), next;
|
|---|
| 414 | $tagInfo = $infoArray[0];
|
|---|
| 415 | }
|
|---|
| 416 | my $tagName = $$tagInfo{Name};
|
|---|
| 417 | if ($isDefault) {
|
|---|
| 418 | unless ($$tagInfo{Description}) {
|
|---|
| 419 | $$tagInfo{Description} = Image::ExifTool::MakeDescription($tagName);
|
|---|
| 420 | }
|
|---|
| 421 | $langInfo = $tagInfo;
|
|---|
| 422 | } else {
|
|---|
| 423 | $langInfo = $langInfo{$lang}{$tagName};
|
|---|
| 424 | if (not defined $langInfo) {
|
|---|
| 425 | $langInfo = $langInfo{$lang}{$tagName} = { };
|
|---|
| 426 | } elsif (not ref $langInfo) {
|
|---|
| 427 | $langInfo = $langInfo{$lang}{$tagName} = { Description => $langInfo };
|
|---|
| 428 | }
|
|---|
| 429 | }
|
|---|
| 430 | # save new value in langInfo record
|
|---|
| 431 | if ($tok eq 'desc') {
|
|---|
| 432 | my $oldVal = $$langInfo{Description};
|
|---|
| 433 | next if defined $oldVal and $oldVal eq $val;
|
|---|
| 434 | if ($makeMissing) {
|
|---|
| 435 | next if defined $oldVal and $val eq 'MISSING';
|
|---|
| 436 | } elsif (defined $oldVal) {
|
|---|
| 437 | my $t = "$lang $tagName";
|
|---|
| 438 | unless (defined $different{$t} and $different{$t} eq $val) {
|
|---|
| 439 | my $a = defined $different{$t} ? 'ANOTHER ' : '';
|
|---|
| 440 | warn "${a}Different '$lang' desc for $tagName: $val (was $$langInfo{Description})\n";
|
|---|
| 441 | next if defined $different{$t}; # don't change back again
|
|---|
| 442 | $different{$t} = $val;
|
|---|
| 443 | }
|
|---|
| 444 | next unless $overrideDifferent;
|
|---|
| 445 | }
|
|---|
| 446 | next if $isDefault;
|
|---|
| 447 | $$langInfo{Description} = $val;
|
|---|
| 448 | } else {
|
|---|
| 449 | defined $key or warn("No key for $$tagInfo{Name}"), next;
|
|---|
| 450 | my $printConv = $$tagInfo{PrintConv};
|
|---|
| 451 | if (ref $printConv eq 'ARRAY') {
|
|---|
| 452 | defined $valIndex or warn('No value index'), next;
|
|---|
| 453 | $printConv = $$printConv[$valIndex];
|
|---|
| 454 | }
|
|---|
| 455 | ref $printConv eq 'HASH' or warn('No PrintConv'), next;
|
|---|
| 456 | my $convVal = $$printConv{$key};
|
|---|
| 457 | unless (defined $convVal) {
|
|---|
| 458 | if ($$printConv{BITMASK} and $key =~ /^\d+$/) {
|
|---|
| 459 | my $i;
|
|---|
| 460 | for ($i=0; $i<32; ++$i) {
|
|---|
| 461 | next unless $key == (0x01 << $i);
|
|---|
| 462 | $convVal = $$printConv{BITMASK}{$i};
|
|---|
| 463 | }
|
|---|
| 464 | }
|
|---|
| 465 | warn("Missing PrintConv entry for $key") and next unless defined $convVal;
|
|---|
| 466 | }
|
|---|
| 467 | my $lc = $$langInfo{PrintConv};
|
|---|
| 468 | $lc or $lc = $$langInfo{PrintConv} = { };
|
|---|
| 469 | $lc = $printConv if ref $lc eq 'ARRAY'; #(default lang only)
|
|---|
| 470 | my $oldVal = $$lc{$convVal};
|
|---|
| 471 | next if defined $oldVal and $oldVal eq $val;
|
|---|
| 472 | if ($makeMissing) {
|
|---|
| 473 | next if defined $oldVal and $val eq 'MISSING';
|
|---|
| 474 | } elsif (defined $oldVal and (not $isDefault or not $val=~/^\d+$/)) {
|
|---|
| 475 | my $t = "$lang $tagName $convVal";
|
|---|
| 476 | unless (defined $different{$t} and $different{$t} eq $val) {
|
|---|
| 477 | my $a = defined $different{$t} ? 'ANOTHER ' : '';
|
|---|
| 478 | warn "${a}Different '$lang' val for $tagName '$convVal': $val (was $oldVal)\n";
|
|---|
| 479 | next if defined $different{$t}; # don't change back again
|
|---|
| 480 | $different{$t} = $val;
|
|---|
| 481 | }
|
|---|
| 482 | next unless $overrideDifferent;
|
|---|
| 483 | }
|
|---|
| 484 | next if $isDefault;
|
|---|
| 485 | warn("Capitalized '$lang' val for $tagName: $tval\n") if $cap;
|
|---|
| 486 | $$lc{$convVal} = $val;
|
|---|
| 487 | }
|
|---|
| 488 | $changed{$lang} = 1;
|
|---|
| 489 | }
|
|---|
| 490 | }
|
|---|
| 491 | close XFILE;
|
|---|
| 492 | }
|
|---|
| 493 | # rewrite all changed Lang modules
|
|---|
| 494 | my $rtnVal = 0;
|
|---|
| 495 | foreach $lang ($forceUpdate ? @Image::ExifTool::langs : sort keys %changed) {
|
|---|
| 496 | next if $lang eq $Image::ExifTool::defaultLang;
|
|---|
| 497 | ++$rtnVal;
|
|---|
| 498 | # write this module (only increment version number if not forced)
|
|---|
| 499 | WriteLangModule($lang, $langInfo{$lang}, not defined $forceUpdate) or $rtnVal = -1, last;
|
|---|
| 500 | }
|
|---|
| 501 | return $rtnVal;
|
|---|
| 502 | }
|
|---|
| 503 |
|
|---|
| 504 | #------------------------------------------------------------------------------
|
|---|
| 505 | # Write Lang module
|
|---|
| 506 | # Inputs: 0) language string, 1) langInfo lookup reference, 2) flag to increment version
|
|---|
| 507 | # Returns: true on success
|
|---|
| 508 | sub WriteLangModule($$;$)
|
|---|
| 509 | {
|
|---|
| 510 | local ($_, *XOUT);
|
|---|
| 511 | my ($lang, $langTags, $newVersion) = @_;
|
|---|
| 512 | my $err;
|
|---|
| 513 | -e "lib/Image/ExifTool" or die "Must run from directory containing 'lib'\n";
|
|---|
| 514 | my $out = "lib/Image/ExifTool/Lang/$lang.pm";
|
|---|
| 515 | my $tmp = "$out.tmp";
|
|---|
| 516 | open XOUT, ">$tmp" or die "Error creating $tmp\n";
|
|---|
| 517 | my $ver = "Image::ExifTool::Lang::${lang}::VERSION";
|
|---|
| 518 | no strict 'refs';
|
|---|
| 519 | if ($$ver) {
|
|---|
| 520 | $ver = $$ver;
|
|---|
| 521 | $ver = int($ver * 100 + 1.5) / 100 if $newVersion;
|
|---|
| 522 | } else {
|
|---|
| 523 | $ver = 1.0;
|
|---|
| 524 | }
|
|---|
| 525 | $ver = sprintf('%.2f', $ver);
|
|---|
| 526 | use strict 'refs';
|
|---|
| 527 | my $langName = $Image::ExifTool::langName{$lang} || $lang;
|
|---|
| 528 | $langName =~ s/\s*\(.*//;
|
|---|
| 529 | print XOUT <<HEADER;
|
|---|
| 530 | #------------------------------------------------------------------------------
|
|---|
| 531 | # File: $lang.pm
|
|---|
| 532 | #
|
|---|
| 533 | # Description: ExifTool $langName language translations
|
|---|
| 534 | #
|
|---|
| 535 | # Notes: This file generated automatically by Image::ExifTool::TagInfoXML
|
|---|
| 536 | #------------------------------------------------------------------------------
|
|---|
| 537 |
|
|---|
| 538 | package Image::ExifTool::Lang::$lang;
|
|---|
| 539 |
|
|---|
| 540 | use strict;
|
|---|
| 541 | use vars qw(\$VERSION);
|
|---|
| 542 |
|
|---|
| 543 | \$VERSION = '$ver';
|
|---|
| 544 |
|
|---|
| 545 | HEADER
|
|---|
| 546 | print XOUT "\%Image::ExifTool::Lang::${lang}::Translate = (\n";
|
|---|
| 547 | # loop through all tag and table names
|
|---|
| 548 | my $tag;
|
|---|
| 549 | foreach $tag (sort keys %$langTags) {
|
|---|
| 550 | my $desc = $$langTags{$tag};
|
|---|
| 551 | my $conv;
|
|---|
| 552 | if (ref $desc) {
|
|---|
| 553 | $conv = $$desc{PrintConv};
|
|---|
| 554 | $desc = $$desc{Description};
|
|---|
| 555 | # remove description if not necessary
|
|---|
| 556 | # (not strictly correct -- should test against tag description, not name)
|
|---|
| 557 | undef $desc if $desc and $desc eq $tag;
|
|---|
| 558 | # remove unnecessary value translations
|
|---|
| 559 | if ($conv) {
|
|---|
| 560 | my @keys = keys %$conv;
|
|---|
| 561 | foreach (@keys) {
|
|---|
| 562 | delete $$conv{$_} if $_ eq $$conv{$_};
|
|---|
| 563 | }
|
|---|
| 564 | undef $conv unless %$conv;
|
|---|
| 565 | }
|
|---|
| 566 | }
|
|---|
| 567 | if (defined $desc) {
|
|---|
| 568 | $desc = EscapePerl($desc);
|
|---|
| 569 | } else {
|
|---|
| 570 | next unless $conv;
|
|---|
| 571 | }
|
|---|
| 572 | print XOUT " '$tag' => ";
|
|---|
| 573 | unless ($conv) {
|
|---|
| 574 | print XOUT "'$desc',\n";
|
|---|
| 575 | next;
|
|---|
| 576 | }
|
|---|
| 577 | print XOUT "{\n";
|
|---|
| 578 | print XOUT " Description => '$desc',\n" if defined $desc;
|
|---|
| 579 | if ($conv) {
|
|---|
| 580 | print XOUT " PrintConv => {\n";
|
|---|
| 581 | foreach (sort keys %$conv) {
|
|---|
| 582 | my $str = EscapePerl($_);
|
|---|
| 583 | my $val = EscapePerl($$conv{$_});
|
|---|
| 584 | print XOUT " '$str' => '$val',\n";
|
|---|
| 585 | }
|
|---|
| 586 | print XOUT " },\n";
|
|---|
| 587 | }
|
|---|
| 588 | print XOUT " },\n";
|
|---|
| 589 | }
|
|---|
| 590 | # generate acknowledgements for this language
|
|---|
| 591 | my $ack;
|
|---|
| 592 | if ($credits{$lang}) {
|
|---|
| 593 | $ack = "Thanks to $credits{$lang} for providing this translation.";
|
|---|
| 594 | $ack =~ s/(.{1,76})( +|$)/$1\n/sg; # wrap text to 76 columns
|
|---|
| 595 | $ack = "~head1 ACKNOWLEDGEMENTS\n\n$ack\n";
|
|---|
| 596 | } else {
|
|---|
| 597 | $ack = '';
|
|---|
| 598 | }
|
|---|
| 599 | my $footer = <<FOOTER;
|
|---|
| 600 | );
|
|---|
| 601 |
|
|---|
| 602 | 1; # end
|
|---|
| 603 |
|
|---|
| 604 |
|
|---|
| 605 | __END__
|
|---|
| 606 |
|
|---|
| 607 | ~head1 NAME
|
|---|
| 608 |
|
|---|
| 609 | Image::ExifTool::Lang::$lang.pm - ExifTool $langName language translations
|
|---|
| 610 |
|
|---|
| 611 | ~head1 DESCRIPTION
|
|---|
| 612 |
|
|---|
| 613 | This file is used by Image::ExifTool to generate localized tag descriptions
|
|---|
| 614 | and values.
|
|---|
| 615 |
|
|---|
| 616 | ~head1 AUTHOR
|
|---|
| 617 |
|
|---|
| 618 | Copyright 2003-2011, Phil Harvey (phil at owl.phy.queensu.ca)
|
|---|
| 619 |
|
|---|
| 620 | This library is free software; you can redistribute it and/or modify it
|
|---|
| 621 | under the same terms as Perl itself.
|
|---|
| 622 |
|
|---|
| 623 | $ack~head1 SEE ALSO
|
|---|
| 624 |
|
|---|
| 625 | L<Image::ExifTool(3pm)|Image::ExifTool>,
|
|---|
| 626 | L<Image::ExifTool::TagInfoXML(3pm)|Image::ExifTool::TagInfoXML>
|
|---|
| 627 |
|
|---|
| 628 | ~cut
|
|---|
| 629 | FOOTER
|
|---|
| 630 | $footer =~ s/^~/=/mg; # un-do pod obfuscation
|
|---|
| 631 | print XOUT $footer or $err = 1;
|
|---|
| 632 | close XOUT or $err = 1;
|
|---|
| 633 | if ($err or not rename($tmp, $out)) {
|
|---|
| 634 | warn "Error writing $out\n";
|
|---|
| 635 | unlink $tmp;
|
|---|
| 636 | $err = 1;
|
|---|
| 637 | }
|
|---|
| 638 | return $err ? 0 : 1;
|
|---|
| 639 | }
|
|---|
| 640 |
|
|---|
| 641 | #------------------------------------------------------------------------------
|
|---|
| 642 | # load all lang modules into hash
|
|---|
| 643 | # Inputs: 0) Hash reference
|
|---|
| 644 | sub LoadLangModules($)
|
|---|
| 645 | {
|
|---|
| 646 | my $langHash = shift;
|
|---|
| 647 | my $lang;
|
|---|
| 648 | require Image::ExifTool;
|
|---|
| 649 | foreach $lang (@Image::ExifTool::langs) {
|
|---|
| 650 | next if $lang eq $Image::ExifTool::defaultLang;
|
|---|
| 651 | eval "require Image::ExifTool::Lang::$lang" or warn("Can't load Lang::$lang\n"), next;
|
|---|
| 652 | my $xlat = "Image::ExifTool::Lang::${lang}::Translate";
|
|---|
| 653 | no strict 'refs';
|
|---|
| 654 | %$xlat or warn("Missing Info for $lang\n"), next;
|
|---|
| 655 | $$langHash{$lang} = \%$xlat;
|
|---|
| 656 | use strict 'refs';
|
|---|
| 657 | }
|
|---|
| 658 | }
|
|---|
| 659 |
|
|---|
| 660 | #------------------------------------------------------------------------------
|
|---|
| 661 | # sort numbers first numerically, then strings alphabetically (case insensitive)
|
|---|
| 662 | sub NumbersFirst
|
|---|
| 663 | {
|
|---|
| 664 | my $rtnVal;
|
|---|
| 665 | my $bNum = ($b =~ /^-?[0-9]+(\.\d*)?$/);
|
|---|
| 666 | if ($a =~ /^-?[0-9]+(\.\d*)?$/) {
|
|---|
| 667 | $rtnVal = ($bNum ? $a <=> $b : -1);
|
|---|
| 668 | } elsif ($bNum) {
|
|---|
| 669 | $rtnVal = 1;
|
|---|
| 670 | } else {
|
|---|
| 671 | my ($a2, $b2) = ($a, $b);
|
|---|
| 672 | # expand numbers to 3 digits (with restrictions to avoid messing up ascii-hex tags)
|
|---|
| 673 | $a2 =~ s/(\d+)/sprintf("%.3d",$1)/eg if $a2 =~ /^(APP)?[.0-9 ]*$/ and length($a2)<16;
|
|---|
| 674 | $b2 =~ s/(\d+)/sprintf("%.3d",$1)/eg if $b2 =~ /^(APP)?[.0-9 ]*$/ and length($b2)<16;
|
|---|
| 675 | $caseInsensitive and $rtnVal = (lc($a2) cmp lc($b2));
|
|---|
| 676 | $rtnVal or $rtnVal = ($a2 cmp $b2);
|
|---|
| 677 | }
|
|---|
| 678 | return $rtnVal;
|
|---|
| 679 | }
|
|---|
| 680 |
|
|---|
| 681 | 1; # end
|
|---|
| 682 |
|
|---|
| 683 |
|
|---|
| 684 | __END__
|
|---|
| 685 |
|
|---|
| 686 | =head1 NAME
|
|---|
| 687 |
|
|---|
| 688 | Image::ExifTool::TagInfoXML - Read/write tag information XML database
|
|---|
| 689 |
|
|---|
| 690 | =head1 DESCRIPTION
|
|---|
| 691 |
|
|---|
| 692 | This module is used to generate an XML database from all ExifTool tag
|
|---|
| 693 | information. The XML database may then be edited and used to re-generate
|
|---|
| 694 | the language modules (Image::ExifTool::Lang::*).
|
|---|
| 695 |
|
|---|
| 696 | =head1 METHODS
|
|---|
| 697 |
|
|---|
| 698 | =head2 Write
|
|---|
| 699 |
|
|---|
| 700 | Print complete tag information database in XML format.
|
|---|
| 701 |
|
|---|
| 702 | # save list of all tags
|
|---|
| 703 | $success = Image::ExifTool::TagInfoXML::Write('dst.xml');
|
|---|
| 704 |
|
|---|
| 705 | # list all IPTC tags to console, including Flags
|
|---|
| 706 | Image::ExifTool::TagInfoXML::Write(undef, 'IPTC', Flags => 1);
|
|---|
| 707 |
|
|---|
| 708 | # write all EXIF Camera tags to file
|
|---|
| 709 | Image::ExifTool::TagInfoXML::Write($outfile, 'exif:camera');
|
|---|
| 710 |
|
|---|
| 711 | =over 4
|
|---|
| 712 |
|
|---|
| 713 | =item Inputs:
|
|---|
| 714 |
|
|---|
| 715 | 0) [optional] Output file name, or undef for console output. Output file
|
|---|
| 716 | will be overwritten if it already exists.
|
|---|
| 717 |
|
|---|
| 718 | 1) [optional] String of group names separated by colons to specify the group
|
|---|
| 719 | to print. A specific IFD may not be given as a group, since EXIF tags may
|
|---|
| 720 | be written to any IFD. Saves all groups if not specified.
|
|---|
| 721 |
|
|---|
| 722 | 2) [optional] Hash of options values:
|
|---|
| 723 |
|
|---|
| 724 | Flags - Set to output 'flags' attribute
|
|---|
| 725 | NoDesc - Set to suppress output of descriptions
|
|---|
| 726 |
|
|---|
| 727 | =item Return Value:
|
|---|
| 728 |
|
|---|
| 729 | True on success.
|
|---|
| 730 |
|
|---|
| 731 | =item Sample XML Output:
|
|---|
| 732 |
|
|---|
| 733 | =back
|
|---|
| 734 |
|
|---|
| 735 | <?xml version='1.0' encoding='UTF-8'?>
|
|---|
| 736 | <taginfo>
|
|---|
| 737 |
|
|---|
| 738 | <table name='XMP::dc' g0='XMP' g1='XMP-dc' g2='Other'>
|
|---|
| 739 | <desc lang='en'>XMP Dublin Core</desc>
|
|---|
| 740 | <tag id='title' name='Title' type='lang-alt' writable='true' g2='Image'>
|
|---|
| 741 | <desc lang='en'>Title</desc>
|
|---|
| 742 | <desc lang='de'>Titel</desc>
|
|---|
| 743 | <desc lang='fr'>Titre</desc>
|
|---|
| 744 | </tag>
|
|---|
| 745 | ...
|
|---|
| 746 | </table>
|
|---|
| 747 |
|
|---|
| 748 | </taginfo>
|
|---|
| 749 |
|
|---|
| 750 | Flags (if selected and available) are formatted as a comma-separated list of
|
|---|
| 751 | the following possible values: Avoid, Binary, List, Mandatory, Permanent,
|
|---|
| 752 | Protected, Unknown and Unsafe. See the
|
|---|
| 753 | L<tag name documentation|Image::ExifTool::TagNames> and
|
|---|
| 754 | lib/Image/ExifTool/README for a description of these flags. For XMP List
|
|---|
| 755 | tags, the list type (Alt, Bag or Seq) is also output as a flag if
|
|---|
| 756 | applicable.
|
|---|
| 757 |
|
|---|
| 758 | =head2 BuildLangModules
|
|---|
| 759 |
|
|---|
| 760 | Build all Image::ExifTool::Lang modules from an XML database file.
|
|---|
| 761 |
|
|---|
| 762 | Image::ExifTool::TagInfoXML::BuildLangModules('src.xml');
|
|---|
| 763 |
|
|---|
| 764 | =over 4
|
|---|
| 765 |
|
|---|
| 766 | =item Inputs:
|
|---|
| 767 |
|
|---|
| 768 | 0) XML file name
|
|---|
| 769 |
|
|---|
| 770 | =item Return Value:
|
|---|
| 771 |
|
|---|
| 772 | Number of modules updated, or negative on error.
|
|---|
| 773 |
|
|---|
| 774 | =back
|
|---|
| 775 |
|
|---|
| 776 | =head1 AUTHOR
|
|---|
| 777 |
|
|---|
| 778 | Copyright 2003-2011, Phil Harvey (phil at owl.phy.queensu.ca)
|
|---|
| 779 |
|
|---|
| 780 | This library is free software; you can redistribute it and/or modify it
|
|---|
| 781 | under the same terms as Perl itself.
|
|---|
| 782 |
|
|---|
| 783 | =head1 SEE ALSO
|
|---|
| 784 |
|
|---|
| 785 | L<Image::ExifTool(3pm)|Image::ExifTool>,
|
|---|
| 786 | L<Image::ExifTool::TagNames(3pm)|Image::ExifTool::TagNames>
|
|---|
| 787 |
|
|---|
| 788 | =cut
|
|---|
