XMPStruct.pl 35 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841
  1. #------------------------------------------------------------------------------
  2. # File: XMPStruct.pl
  3. #
  4. # Description: XMP structure support
  5. #
  6. # Revisions: 01/01/2011 - P. Harvey Created
  7. #------------------------------------------------------------------------------
  8. package Image::ExifTool::XMP;
  9. use strict;
  10. use vars qw(%specialStruct %stdXlatNS);
  11. use Image::ExifTool qw(:Utils);
  12. use Image::ExifTool::XMP;
  13. sub SerializeStruct($;$);
  14. sub InflateStruct($;$);
  15. sub DumpStruct($;$);
  16. sub CheckStruct($$$);
  17. sub AddNewStruct($$$$$$);
  18. sub ConvertStruct($$$$;$);
  19. #------------------------------------------------------------------------------
  20. # Serialize a structure (or other object) into a simple string
  21. # Inputs: 0) HASH ref, ARRAY ref, or SCALAR, 1) closing bracket (or undef)
  22. # Returns: serialized structure string
  23. # eg) "{field=text with {braces|}|, and a comma, field2=val2,field3={field4=[a,b]}}"
  24. sub SerializeStruct($;$)
  25. {
  26. my ($obj, $ket) = @_;
  27. my ($key, $val, @vals, $rtnVal);
  28. if (ref $obj eq 'HASH') {
  29. foreach $key (sort keys %$obj) {
  30. push @vals, $key . '=' . SerializeStruct($$obj{$key}, '}');
  31. }
  32. $rtnVal = '{' . join(',', @vals) . '}';
  33. } elsif (ref $obj eq 'ARRAY') {
  34. foreach $val (@$obj) {
  35. push @vals, SerializeStruct($val, ']');
  36. }
  37. $rtnVal = '[' . join(',', @vals) . ']';
  38. } elsif (defined $obj) {
  39. $obj = $$obj if ref $obj eq 'SCALAR';
  40. # escape necessary characters in string (closing bracket plus "," and "|")
  41. my $pat = $ket ? "\\$ket|,|\\|" : ',|\\|';
  42. ($rtnVal = $obj) =~ s/($pat)/|$1/g;
  43. # also must escape opening bracket or whitespace at start of string
  44. $rtnVal =~ s/^([\s\[\{])/|$1/;
  45. } else {
  46. $rtnVal = ''; # allow undefined list items
  47. }
  48. return $rtnVal;
  49. }
  50. #------------------------------------------------------------------------------
  51. # Inflate structure (or other object) from a serialized string
  52. # Inputs: 0) reference to object in string form (serialized using the '|' escape)
  53. # 1) extra delimiter for scalar values delimiters
  54. # Returns: 0) object as a SCALAR, HASH ref, or ARRAY ref (or undef on error),
  55. # 1) warning string (or undef)
  56. # Notes: modifies input string to remove parsed objects
  57. sub InflateStruct($;$)
  58. {
  59. my ($obj, $delim) = @_;
  60. my ($val, $warn, $part);
  61. if ($$obj =~ s/^\s*\{//) {
  62. my %struct;
  63. while ($$obj =~ s/^\s*([-\w:]+#?)\s*=//s) {
  64. my $tag = $1;
  65. my ($v, $w) = InflateStruct($obj, '}');
  66. $warn = $w if $w and not $warn;
  67. return(undef, $warn) unless defined $v;
  68. $struct{$tag} = $v;
  69. # eat comma separator, or all done if there wasn't one
  70. last unless $$obj =~ s/^\s*,//s;
  71. }
  72. # eat closing brace and warn if we didn't find one
  73. unless ($$obj =~ s/^\s*\}//s or $warn) {
  74. if (length $$obj) {
  75. ($part = $$obj) =~ s/^\s*//s;
  76. $part =~ s/[\x0d\x0a].*//s;
  77. $part = substr($part,0,27) . '...' if length($part) > 30;
  78. $warn = "Invalid structure field at '$part'";
  79. } else {
  80. $warn = 'Missing closing brace for structure';
  81. }
  82. }
  83. $val = \%struct;
  84. } elsif ($$obj =~ s/^\s*\[//) {
  85. my @list;
  86. for (;;) {
  87. my ($v, $w) = InflateStruct($obj, ']');
  88. $warn = $w if $w and not $warn;
  89. return(undef, $warn) unless defined $v;
  90. push @list, $v;
  91. last unless $$obj =~ s/^\s*,//s;
  92. }
  93. # eat closing bracket and warn if we didn't find one
  94. $$obj =~ s/^\s*\]//s or $warn or $warn = 'Missing closing bracket for list';
  95. $val = \@list;
  96. } else {
  97. $$obj =~ s/^\s+//s; # remove leading whitespace
  98. # read scalar up to specified delimiter (or "," if not defined)
  99. $val = '';
  100. $delim = $delim ? "\\$delim|,|\\||\$" : ',|\\||$';
  101. for (;;) {
  102. $$obj =~ s/^(.*?)($delim)//s and $val .= $1;
  103. last unless $2;
  104. $2 eq '|' or $$obj = $2 . $$obj, last;
  105. $$obj =~ s/^(.)//s and $val .= $1; # add escaped character
  106. }
  107. }
  108. return($val, $warn);
  109. }
  110. #------------------------------------------------------------------------------
  111. # Get XMP language code from tag name string
  112. # Inputs: 0) tag name string
  113. # Returns: 0) separated tag name, 1) language code (in standard case), or '' if
  114. # language code was 'x-default', or undef if the tag had no language code
  115. sub GetLangCode($)
  116. {
  117. my $tag = shift;
  118. if ($tag =~ /^(\w+)[-_]([a-z]{2,3}|[xi])([-_][a-z\d]{2,8}([-_][a-z\d]{1,8})*)?$/i) {
  119. # normalize case of language codes
  120. my ($tg, $langCode) = ($1, lc($2));
  121. $langCode .= (length($3) == 3 ? uc($3) : lc($3)) if $3;
  122. $langCode =~ tr/_/-/; # RFC 3066 specifies '-' as a separator
  123. $langCode = '' if lc($langCode) eq 'x-default';
  124. return($tg, $langCode);
  125. } else {
  126. return($tag, undef);
  127. }
  128. }
  129. #------------------------------------------------------------------------------
  130. # Debugging routine to dump a structure, list or scalar
  131. # Inputs: 0) scalar, ARRAY ref or HASH ref, 1) indent (or undef)
  132. sub DumpStruct($;$)
  133. {
  134. local $_;
  135. my ($obj, $indent) = @_;
  136. $indent or $indent = '';
  137. if (ref $obj eq 'HASH') {
  138. print "{\n";
  139. foreach (sort keys %$obj) {
  140. print "$indent $_ = ";
  141. DumpStruct($$obj{$_}, "$indent ");
  142. }
  143. print $indent, "},\n";
  144. } elsif (ref $obj eq 'ARRAY') {
  145. print "[\n";
  146. foreach (@$obj) {
  147. print "$indent ";
  148. DumpStruct($_, "$indent ");
  149. }
  150. print $indent, "],\n",
  151. } else {
  152. print "\"$obj\",\n";
  153. }
  154. }
  155. #------------------------------------------------------------------------------
  156. # Recursively validate structure fields (tags)
  157. # Inputs: 0) ExifTool ref, 1) Structure ref, 2) structure table definition ref
  158. # Returns: 0) validated structure ref, 1) error string, or undef on success
  159. # Notes:
  160. # - fixes field names in structure and applies inverse conversions to values
  161. # - copies structure to avoid interdependencies with calling code on referenced values
  162. # - handles lang-alt tags, and '#' on field names
  163. # - resets UTF-8 flag of SCALAR values
  164. # - un-escapes for XML or HTML as per Escape option setting
  165. sub CheckStruct($$$)
  166. {
  167. my ($et, $struct, $strTable) = @_;
  168. my $strName = $$strTable{STRUCT_NAME} || ('XMP ' . RegisterNamespace($strTable));
  169. ref $struct eq 'HASH' or return wantarray ? (undef, "Expecting $strName structure") : undef;
  170. my ($key, $err, $warn, %copy, $rtnVal, $val);
  171. Key:
  172. foreach $key (keys %$struct) {
  173. my $tag = $key;
  174. # allow trailing '#' to disable print conversion on a per-field basis
  175. my ($type, $fieldInfo);
  176. $type = 'ValueConv' if $tag =~ s/#$//;
  177. $fieldInfo = $$strTable{$tag} unless $specialStruct{$tag};
  178. # fix case of field name if necessary
  179. unless ($fieldInfo) {
  180. # (sort in reverse to get lower case (not special) tags first)
  181. my ($fix) = reverse sort grep /^$tag$/i, keys %$strTable;
  182. $fieldInfo = $$strTable{$tag = $fix} if $fix and not $specialStruct{$fix};
  183. }
  184. until (ref $fieldInfo eq 'HASH') {
  185. # generate wildcard fields on the fly (eg. mwg-rs:Extensions)
  186. unless ($$strTable{NAMESPACE}) {
  187. my ($grp, $tg, $langCode);
  188. ($grp, $tg) = $tag =~ /^(.+):(.+)/ ? (lc $1, $2) : ('', $tag);
  189. undef $grp if $grp eq 'XMP'; # (a group of 'XMP' is implied)
  190. require Image::ExifTool::TagLookup;
  191. my @matches = Image::ExifTool::TagLookup::FindTagInfo($tg);
  192. # also look for lang-alt tags
  193. unless (@matches) {
  194. ($tg, $langCode) = GetLangCode($tg);
  195. @matches = Image::ExifTool::TagLookup::FindTagInfo($tg) if defined $langCode;
  196. }
  197. my ($tagInfo, $priority, $ti, $g1);
  198. # find best matching tag
  199. foreach $ti (@matches) {
  200. my @grps = $et->GetGroup($ti);
  201. next unless $grps[0] eq 'XMP';
  202. next if $grp and $grp ne lc $grps[1];
  203. # must be lang-alt tag if we are writing an alternate language
  204. next if defined $langCode and not ($$ti{Writable} and $$ti{Writable} eq 'lang-alt');
  205. my $pri = $$ti{Priority} || 1;
  206. $pri -= 10 if $$ti{Avoid};
  207. next if defined $priority and $priority >= $pri;
  208. $priority = $pri;
  209. $tagInfo = $ti;
  210. $g1 = $grps[1];
  211. }
  212. $tagInfo or $warn = "'$tag' is not a writable XMP tag", next Key;
  213. GetPropertyPath($tagInfo); # make sure property path is generated for this tag
  214. $tag = $$tagInfo{Name};
  215. $tag = "$g1:$tag" if $grp;
  216. $tag .= "-$langCode" if $langCode;
  217. $fieldInfo = $$strTable{$tag};
  218. # create new structure field if necessary
  219. $fieldInfo or $fieldInfo = $$strTable{$tag} = {
  220. %$tagInfo, # (also copies the necessary TagID and PropertyPath)
  221. Namespace => $$tagInfo{Table}{NAMESPACE},
  222. LangCode => $langCode,
  223. };
  224. # delete stuff we don't need (shouldn't cause harm, but better safe than sorry)
  225. # - need to keep StructType and Table in case we need to call AddStructType later
  226. delete $$fieldInfo{Description};
  227. delete $$fieldInfo{Groups};
  228. last; # write this dynamically-generated field
  229. }
  230. # generate lang-alt fields on the fly (eg. Iptc4xmpExt:AOTitle)
  231. my ($tg, $langCode) = GetLangCode($tag);
  232. if (defined $langCode) {
  233. $fieldInfo = $$strTable{$tg} unless $specialStruct{$tg};
  234. unless ($fieldInfo) {
  235. my ($fix) = reverse sort grep /^$tg$/i, keys %$strTable;
  236. $fieldInfo = $$strTable{$tg = $fix} if $fix and not $specialStruct{$fix};
  237. }
  238. if (ref $fieldInfo eq 'HASH' and $$fieldInfo{Writable} and
  239. $$fieldInfo{Writable} eq 'lang-alt')
  240. {
  241. my $srcInfo = $fieldInfo;
  242. $tag = $tg . '-' . $langCode if $langCode;
  243. $fieldInfo = $$strTable{$tag};
  244. # create new structure field if necessary
  245. $fieldInfo or $fieldInfo = $$strTable{$tag} = {
  246. %$srcInfo,
  247. TagID => $tg,
  248. LangCode => $langCode,
  249. };
  250. last; # write this lang-alt field
  251. }
  252. }
  253. $warn = "'$tag' is not a field of $strName";
  254. next Key;
  255. }
  256. if (ref $$struct{$key} eq 'HASH') {
  257. $$fieldInfo{Struct} or $warn = "$tag is not a structure in $strName", next Key;
  258. # recursively check this structure
  259. ($val, $err) = CheckStruct($et, $$struct{$key}, $$fieldInfo{Struct});
  260. $err and $warn = $err, next Key;
  261. $copy{$tag} = $val;
  262. } elsif (ref $$struct{$key} eq 'ARRAY') {
  263. $$fieldInfo{List} or $warn = "$tag is not a list in $strName", next Key;
  264. # check all items in the list
  265. my ($item, @copy);
  266. my $i = 0;
  267. foreach $item (@{$$struct{$key}}) {
  268. if (not ref $item) {
  269. $item = '' unless defined $item; # use empty string for missing items
  270. if ($$fieldInfo{Struct}) {
  271. # (allow empty structures)
  272. $item =~ /^\s*$/ or $warn = "$tag items are not valid structures", next Key;
  273. $copy[$i] = { }; # create hash for empty structure
  274. } else {
  275. $et->Sanitize(\$item);
  276. ($copy[$i],$err) = $et->ConvInv($item,$fieldInfo,$tag,$strName,$type,'');
  277. $err and $warn = $err, next Key;
  278. $err = CheckXMP($et, $fieldInfo, \$copy[$i]);
  279. $err and $warn = "$err in $strName $tag", next Key;
  280. }
  281. } elsif (ref $item eq 'HASH') {
  282. $$fieldInfo{Struct} or $warn = "$tag is not a structure in $strName", next Key;
  283. ($copy[$i], $err) = CheckStruct($et, $item, $$fieldInfo{Struct});
  284. $err and $warn = $err, next Key;
  285. } else {
  286. $warn = "Invalid value for $tag in $strName";
  287. next Key;
  288. }
  289. ++$i;
  290. }
  291. $copy{$tag} = \@copy;
  292. } elsif ($$fieldInfo{Struct}) {
  293. $warn = "Improperly formed structure in $strName $tag";
  294. } else {
  295. $et->Sanitize(\$$struct{$key});
  296. ($val,$err) = $et->ConvInv($$struct{$key},$fieldInfo,$tag,$strName,$type,'');
  297. $err and $warn = $err, next Key;
  298. $err = CheckXMP($et, $fieldInfo, \$val);
  299. $err and $warn = "$err in $strName $tag", next Key;
  300. # turn this into a list if necessary
  301. $copy{$tag} = $$fieldInfo{List} ? [ $val ] : $val;
  302. }
  303. }
  304. if (%copy or not $warn) {
  305. $rtnVal = \%copy;
  306. undef $err;
  307. $$et{CHECK_WARN} = $warn if $warn;
  308. } else {
  309. $err = $warn;
  310. }
  311. return wantarray ? ($rtnVal, $err) : $rtnVal;
  312. }
  313. #------------------------------------------------------------------------------
  314. # Delete matching structures from existing linearized XMP
  315. # Inputs: 0) ExifTool ref, 1) capture hash ref, 2) structure path ref,
  316. # 3) new value hash ref, 4) reference to change counter
  317. # Returns: 0) delete flag, 1) list index of deleted structure if adding to list
  318. # 2) flag set if structure existed
  319. # Notes: updates path to new base path for structure to be added
  320. sub DeleteStruct($$$$$)
  321. {
  322. my ($et, $capture, $pathPt, $nvHash, $changed) = @_;
  323. my ($deleted, $added, $existed, $p, $pp, $val, $delPath);
  324. my (@structPaths, @matchingPaths, @delPaths);
  325. # find all existing elements belonging to this structure
  326. ($pp = $$pathPt) =~ s/ \d+/ \\d\+/g;
  327. @structPaths = sort grep(/^$pp(\/|$)/, keys %$capture);
  328. $existed = 1 if @structPaths;
  329. # delete only structures with matching fields if necessary
  330. if ($$nvHash{DelValue}) {
  331. if (@{$$nvHash{DelValue}}) {
  332. my $strTable = $$nvHash{TagInfo}{Struct};
  333. # all fields must match corresponding elements in the same
  334. # root structure for it to be deleted
  335. foreach $val (@{$$nvHash{DelValue}}) {
  336. next unless ref $val eq 'HASH';
  337. my (%cap, $p2, %match);
  338. next unless AddNewStruct(undef, undef, \%cap, $$pathPt, $val, $strTable);
  339. foreach $p (keys %cap) {
  340. if ($p =~ / /) {
  341. ($p2 = $p) =~ s/ \d+/ \\d\+/g;
  342. @matchingPaths = sort grep(/^$p2$/, @structPaths);
  343. } else {
  344. push @matchingPaths, $p;
  345. }
  346. foreach $p2 (@matchingPaths) {
  347. $p2 =~ /^($pp)/ or next;
  348. # language attribute must also match if it exists
  349. my $attr = $cap{$p}[1];
  350. if ($$attr{'xml:lang'}) {
  351. my $a2 = $$capture{$p2}[1];
  352. next unless $$a2{'xml:lang'} and $$a2{'xml:lang'} eq $$attr{'xml:lang'};
  353. }
  354. if ($$capture{$p2} and $$capture{$p2}[0] eq $cap{$p}[0]) {
  355. # ($1 contains root path for this structure)
  356. $match{$1} = ($match{$1} || 0) + 1;
  357. }
  358. }
  359. }
  360. my $num = scalar(keys %cap);
  361. foreach $p (keys %match) {
  362. # do nothing unless all fields matched the same structure
  363. next unless $match{$p} == $num;
  364. # delete all elements of this structure
  365. foreach $p2 (@structPaths) {
  366. push @delPaths, $p2 if $p2 =~ /^$p/;
  367. }
  368. # remember path of first deleted structure
  369. $delPath = $p if not $delPath or $delPath gt $p;
  370. }
  371. }
  372. } # (else don't delete anything)
  373. } elsif (@structPaths) {
  374. @delPaths = @structPaths; # delete all
  375. $structPaths[0] =~ /^($pp)/;
  376. $delPath = $1;
  377. }
  378. if (@delPaths) {
  379. my $verbose = $et->Options('Verbose');
  380. @delPaths = sort @delPaths if $verbose > 1;
  381. foreach $p (@delPaths) {
  382. $et->VerboseValue("- XMP-$p", $$capture{$p}[0]) if $verbose > 1;
  383. delete $$capture{$p};
  384. $deleted = 1;
  385. ++$$changed;
  386. }
  387. $delPath or warn("Internal error 1 in DeleteStruct\n"), return(undef,undef,$existed);
  388. $$pathPt = $delPath; # return path of first element deleted
  389. } elsif ($$nvHash{TagInfo}{List}) {
  390. # NOTE: we don't yet properly handle lang-alt elements!!!!
  391. if (@structPaths) {
  392. $structPaths[-1] =~ /^($pp)/ or warn("Internal error 2 in DeleteStruct\n"), return(undef,undef,$existed);
  393. my $path = $1;
  394. # delete any improperly formatted xmp
  395. if ($$capture{$path}) {
  396. my $cap = $$capture{$path};
  397. # an error unless this was an empty structure
  398. $et->Error("Improperly structured XMP ($path)",1) if ref $cap ne 'ARRAY' or $$cap[0];
  399. delete $$capture{$path};
  400. }
  401. # (match last index to put in same lang-alt list for Bag of lang-alt items)
  402. $path =~ m/.* (\d+)/g or warn("Internal error 3 in DeleteStruct\n"), return(undef,undef,$existed);
  403. $added = $1;
  404. # add after last item in list
  405. my $len = length $added;
  406. my $pos = pos($path) - $len;
  407. my $nxt = substr($added, 1) + 1;
  408. substr($path, $pos, $len) = length($nxt) . $nxt;
  409. $$pathPt = $path;
  410. } else {
  411. $added = '10';
  412. }
  413. }
  414. return($deleted, $added, $existed);
  415. }
  416. #------------------------------------------------------------------------------
  417. # Add new element to XMP capture hash
  418. # Inputs: 0) ExifTool ref, 1) TagInfo ref, 2) capture hash ref,
  419. # 3) resource path, 4) value ref, 5) hash ref for last used index numbers
  420. sub AddNewTag($$$$$$)
  421. {
  422. my ($et, $tagInfo, $capture, $path, $valPtr, $langIdx) = @_;
  423. my $val = EscapeXML($$valPtr);
  424. my %attrs;
  425. # support writing RDF "resource" values
  426. if ($$tagInfo{Resource}) {
  427. $attrs{'rdf:resource'} = $val;
  428. $val = '';
  429. }
  430. if ($$tagInfo{Writable} and $$tagInfo{Writable} eq 'lang-alt') {
  431. # write the lang-alt tag
  432. my $langCode = $$tagInfo{LangCode};
  433. # add indexed lang-alt list properties
  434. my $i = $$langIdx{$path} || 0;
  435. $$langIdx{$path} = $i + 1; # save next list index
  436. if ($i) {
  437. my $idx = length($i) . $i;
  438. $path =~ s/(.*) \d+/$1 $idx/; # set list index
  439. }
  440. $attrs{'xml:lang'} = $langCode || 'x-default';
  441. }
  442. $$capture{$path} = [ $val, \%attrs ];
  443. # print verbose message
  444. if ($et and $et->Options('Verbose') > 1) {
  445. $et->VerboseValue("+ XMP-$path", $val);
  446. }
  447. }
  448. #------------------------------------------------------------------------------
  449. # Add new structure to capture hash for writing
  450. # Inputs: 0) ExifTool object ref (or undef for no warnings),
  451. # 1) tagInfo ref (or undef if no ExifTool), 2) capture hash ref,
  452. # 3) base path, 4) struct ref, 5) struct hash ref
  453. # Returns: number of tags changed
  454. # Notes: Escapes values for XML
  455. sub AddNewStruct($$$$$$)
  456. {
  457. my ($et, $tagInfo, $capture, $basePath, $struct, $strTable) = @_;
  458. my $verbose = $et ? $et->Options('Verbose') : 0;
  459. my ($tag, %langIdx);
  460. my $ns = $$strTable{NAMESPACE} || '';
  461. my $changed = 0;
  462. # add dummy field to allow empty structures (name starts with '~' so it will come
  463. # after all valid structure fields, which is necessary when serializing the XMP later)
  464. %$struct or $$struct{'~dummy~'} = '';
  465. foreach $tag (sort keys %$struct) {
  466. my $fieldInfo = $$strTable{$tag};
  467. unless ($fieldInfo) {
  468. next unless $tag eq '~dummy~'; # check for dummy field
  469. $fieldInfo = { }; # create dummy field info for dummy structure
  470. }
  471. my $val = $$struct{$tag};
  472. my $propPath = $$fieldInfo{PropertyPath};
  473. unless ($propPath) {
  474. $propPath = ($$fieldInfo{Namespace} || $ns) . ':' . ($$fieldInfo{TagID} || $tag);
  475. if ($$fieldInfo{List}) {
  476. $propPath .= "/rdf:$$fieldInfo{List}/rdf:li 10";
  477. }
  478. if ($$fieldInfo{Writable} and $$fieldInfo{Writable} eq 'lang-alt') {
  479. $propPath .= "/rdf:Alt/rdf:li 10";
  480. }
  481. $$fieldInfo{PropertyPath} = $propPath; # save for next time
  482. }
  483. my $path = $basePath . '/' . ConformPathToNamespace($et, $propPath);
  484. my $addedTag;
  485. if (ref $val eq 'HASH') {
  486. my $subStruct = $$fieldInfo{Struct} or next;
  487. $changed += AddNewStruct($et, $tagInfo, $capture, $path, $val, $subStruct);
  488. } elsif (ref $val eq 'ARRAY') {
  489. next unless $$fieldInfo{List};
  490. my $i = 0;
  491. my ($item, $p);
  492. # loop through all list items (note: can't yet write multi-dimensional lists)
  493. foreach $item (@{$val}) {
  494. if ($i) {
  495. # update first index in field property (may be list of lang-alt lists)
  496. $p = ConformPathToNamespace($et, $propPath);
  497. my $idx = length($i) . $i;
  498. $p =~ s/ \d+/ $idx/;
  499. $p = "$basePath/$p";
  500. } else {
  501. $p = $path;
  502. }
  503. if (ref $item eq 'HASH') {
  504. my $subStruct = $$fieldInfo{Struct} or next;
  505. AddNewStruct($et, $tagInfo, $capture, $p, $item, $subStruct) or next;
  506. } elsif (length $item) { # don't write empty items in list
  507. AddNewTag($et, $fieldInfo, $capture, $p, \$item, \%langIdx);
  508. $addedTag = 1;
  509. }
  510. ++$changed;
  511. ++$i;
  512. }
  513. } else {
  514. AddNewTag($et, $fieldInfo, $capture, $path, \$val, \%langIdx);
  515. $addedTag = 1;
  516. ++$changed;
  517. }
  518. # this is tricky, but we must add the rdf:type for contained structures
  519. # in the case that a whole hierarchy was added at once by writing a
  520. # flattened tag inside a variable-namespace structure
  521. if ($addedTag and $$fieldInfo{StructType} and $$fieldInfo{Table}) {
  522. AddStructType($et, $$fieldInfo{Table}, $capture, $propPath, $basePath);
  523. }
  524. }
  525. # add 'rdf:type' property if necessary
  526. if ($$strTable{TYPE} and $changed) {
  527. my $path = $basePath . '/' . ConformPathToNamespace($et, "rdf:type");
  528. unless ($$capture{$path}) {
  529. $$capture{$path} = [ '', { 'rdf:resource' => $$strTable{TYPE} } ];
  530. $et->VerboseValue("+ XMP-$path", $$strTable{TYPE}) if $verbose > 1;
  531. }
  532. }
  533. return $changed;
  534. }
  535. #------------------------------------------------------------------------------
  536. # Convert structure field values for printing
  537. # Inputs: 0) ExifTool ref, 1) tagInfo ref for structure tag, 2) value,
  538. # 3) conversion type: PrintConv, ValueConv or Raw (Both not allowed)
  539. # 4) tagID of parent structure (needed only if there was no flattened tag)
  540. # Notes: Makes a copy of the hash so any applied escapes won't affect raw values
  541. sub ConvertStruct($$$$;$)
  542. {
  543. my ($et, $tagInfo, $value, $type, $parentID) = @_;
  544. if (ref $value eq 'HASH') {
  545. my (%struct, $key);
  546. my $table = $$tagInfo{Table};
  547. $parentID = $$tagInfo{TagID} unless $parentID;
  548. foreach $key (keys %$value) {
  549. my $tagID = $parentID . ucfirst($key);
  550. my $flatInfo = $$table{$tagID};
  551. unless ($flatInfo) {
  552. # handle variable-namespace structures
  553. if ($key =~ /^XMP-(.*?:)(.*)/) {
  554. $tagID = $1 . $parentID . ucfirst($2);
  555. $flatInfo = $$table{$tagID};
  556. }
  557. $flatInfo or $flatInfo = $tagInfo;
  558. }
  559. my $v = $$value{$key};
  560. if (ref $v) {
  561. $v = ConvertStruct($et, $flatInfo, $v, $type, $tagID);
  562. } else {
  563. $v = $et->GetValue($flatInfo, $type, $v);
  564. }
  565. $struct{$key} = $v if defined $v; # save the converted value
  566. }
  567. return \%struct;
  568. } elsif (ref $value eq 'ARRAY') {
  569. if (defined $$et{OPTIONS}{ListItem}) {
  570. my $li = $$et{OPTIONS}{ListItem};
  571. return undef unless defined $$value[$li];
  572. undef $$et{OPTIONS}{ListItem}; # only do top-level list
  573. my $val = ConvertStruct($et, $tagInfo, $$value[$li], $type, $parentID);
  574. $$et{OPTIONS}{ListItem} = $li;
  575. return $val;
  576. } else {
  577. my (@list, $val);
  578. foreach $val (@$value) {
  579. my $v = ConvertStruct($et, $tagInfo, $val, $type, $parentID);
  580. push @list, $v if defined $v;
  581. }
  582. return \@list;
  583. }
  584. } else {
  585. return $et->GetValue($tagInfo, $type, $value);
  586. }
  587. }
  588. #------------------------------------------------------------------------------
  589. # Restore XMP structures in extracted information
  590. # Inputs: 0) ExifTool object ref, 1) flag to keep original flattened tags
  591. # Notes: also restores lists (including multi-dimensional)
  592. sub RestoreStruct($;$)
  593. {
  594. local $_;
  595. my ($et, $keepFlat) = @_;
  596. my ($key, %structs, %var, %lists, $si, %listKeys);
  597. my $ex = $$et{TAG_EXTRA};
  598. my $valueHash = $$et{VALUE};
  599. my $tagExtra = $$et{TAG_EXTRA};
  600. foreach $key (keys %{$$et{TAG_INFO}}) {
  601. $$ex{$key} or next;
  602. my $structProps = $$ex{$key}{Struct} or next;
  603. delete $$ex{$key}{Struct}; # (don't re-use)
  604. my $tagInfo = $$et{TAG_INFO}{$key}; # tagInfo for flattened tag
  605. my $table = $$tagInfo{Table};
  606. my $prop = shift @$structProps;
  607. my $tag = $$prop[0];
  608. # get reference to structure tag (or normal list tag if not a structure)
  609. my $strInfo = @$structProps ? $$table{$tag} : $tagInfo;
  610. if ($strInfo) {
  611. ref $strInfo eq 'HASH' or next; # (just to be safe)
  612. if (@$structProps and not $$strInfo{Struct}) {
  613. # this could happen for invalid XMP containing mixed lists
  614. # (or for something like this -- what should we do here?:
  615. # <meta:user-defined meta:name="License">test</meta:user-defined>)
  616. $et->Warn("$$strInfo{Name} is not a structure!") unless $$et{NO_STRUCT_WARN};
  617. next;
  618. }
  619. } else {
  620. # create new entry in tag table for this structure
  621. my $g1 = $$table{GROUPS}{0} || 'XMP';
  622. my $name = $tag;
  623. # tag keys will have a group 1 prefix when coming from import of XML from -X option
  624. if ($tag =~ /(.+):(.+)/) {
  625. my $ns;
  626. ($ns, $name) = ($1, $2);
  627. $ns =~ s/^XMP-//; # remove leading "XMP-" if it exists because we add it later
  628. $ns = $stdXlatNS{$ns} if $stdXlatNS{$ns};
  629. $g1 .= "-$ns";
  630. }
  631. $strInfo = {
  632. Name => ucfirst $name,
  633. Groups => { 1 => $g1 },
  634. Struct => 'Unknown',
  635. };
  636. # add Struct entry if this is a structure
  637. if (@$structProps) {
  638. # this is a structure
  639. $$strInfo{Struct} = { STRUCT_NAME => 'XMP Unknown' } if @$structProps;
  640. } elsif ($$tagInfo{LangCode}) {
  641. # this is lang-alt list
  642. $tag = $tag . '-' . $$tagInfo{LangCode};
  643. $$strInfo{LangCode} = $$tagInfo{LangCode};
  644. }
  645. AddTagToTable($table, $tag, $strInfo);
  646. }
  647. # use strInfo ref for base key to avoid collisions
  648. $tag = $strInfo;
  649. my $struct = \%structs;
  650. my $oldStruct = $structs{$strInfo};
  651. # (fyi: 'lang-alt' Writable type will be valid even if tag is not pre-defined)
  652. my $writable = $$tagInfo{Writable} || '';
  653. # walk through the stored structure property information
  654. # to rebuild this structure
  655. my ($err, $i);
  656. for (;;) {
  657. my $index = $$prop[1];
  658. if ($index and not @$structProps) {
  659. # ignore this list if it is a simple lang-alt tag
  660. if ($writable eq 'lang-alt') {
  661. pop @$prop; # remove lang-alt index
  662. undef $index if @$prop < 2;
  663. }
  664. # add language code if necessary
  665. if ($$tagInfo{LangCode} and not ref $tag) {
  666. $tag = $tag . '-' . $$tagInfo{LangCode};
  667. }
  668. }
  669. my $nextStruct = $$struct{$tag};
  670. if (defined $index) {
  671. # the field is a list
  672. $index = substr $index, 1; # remove digit count
  673. if ($nextStruct) {
  674. ref $nextStruct eq 'ARRAY' or $err = 2, last;
  675. $struct = $nextStruct;
  676. } else {
  677. $struct = $$struct{$tag} = [ ];
  678. }
  679. $nextStruct = $$struct[$index];
  680. # descend into multi-dimensional lists
  681. for ($i=2; $$prop[$i]; ++$i) {
  682. if ($nextStruct) {
  683. ref $nextStruct eq 'ARRAY' or last;
  684. $struct = $nextStruct;
  685. } else {
  686. $lists{$struct} = $struct;
  687. $struct = $$struct[$index] = [ ];
  688. }
  689. $nextStruct = $$struct[$index];
  690. $index = substr $$prop[$i], 1;
  691. }
  692. if (ref $nextStruct eq 'HASH') {
  693. $struct = $nextStruct; # continue building sub-structure
  694. } elsif (@$structProps) {
  695. $lists{$struct} = $struct;
  696. $struct = $$struct[$index] = { };
  697. } else {
  698. $lists{$struct} = $struct;
  699. $$struct[$index] = $$valueHash{$key};
  700. last;
  701. }
  702. } else {
  703. if ($nextStruct) {
  704. ref $nextStruct eq 'HASH' or $err = 3, last;
  705. $struct = $nextStruct;
  706. } elsif (@$structProps) {
  707. $struct = $$struct{$tag} = { };
  708. } else {
  709. $$struct{$tag} = $$valueHash{$key};
  710. last;
  711. }
  712. }
  713. $prop = shift @$structProps or last;
  714. $tag = $$prop[0];
  715. if ($tag =~ /(.+):(.+)/) {
  716. # tag in variable-namespace tables will have a leading
  717. # XMP namespace on the tag name. In this case, add
  718. # the corresponding group1 name to the tag ID.
  719. my ($ns, $name) = ($1, $2);
  720. $ns = $stdXlatNS{$ns} if $stdXlatNS{$ns};
  721. $tag = "XMP-$ns:" . ucfirst $name;
  722. } else {
  723. $tag = ucfirst $tag;
  724. }
  725. }
  726. if ($err) {
  727. # this may happen if we have a structural error in the XMP
  728. # (like an improperly contained list for example)
  729. unless ($$et{NO_STRUCT_WARN}) {
  730. my $ns = $$tagInfo{Namespace} || $$tagInfo{Table}{NAMESPACE} || '';
  731. $et->Warn("Error $err placing $ns:$$tagInfo{TagID} in structure or list", 1);
  732. }
  733. delete $structs{$strInfo} unless $oldStruct;
  734. } elsif ($tagInfo eq $strInfo) {
  735. # just a regular list tag
  736. if ($oldStruct) {
  737. # keep tag with lowest numbered key (well, not exactly, since
  738. # "Tag (10)" is lt "Tag (2)", but at least "Tag" is lt
  739. # everything else, and this is really what we care about)
  740. my $k = $listKeys{$oldStruct};
  741. $k lt $key and $et->DeleteTag($key), next;
  742. $et->DeleteTag($k); # remove tag with greater copy number
  743. }
  744. # replace existing value with new list
  745. $$valueHash{$key} = $structs{$strInfo};
  746. $listKeys{$structs{$strInfo}} = $key; # save key for this list tag
  747. } else {
  748. # save strInfo ref and file order
  749. if ($var{$strInfo}) {
  750. # set file order to just before the first associated flattened tag
  751. if ($var{$strInfo}[1] > $$et{FILE_ORDER}{$key}) {
  752. $var{$strInfo}[1] = $$et{FILE_ORDER}{$key} - 0.5;
  753. }
  754. } else {
  755. $var{$strInfo} = [ $strInfo, $$et{FILE_ORDER}{$key} - 0.5 ];
  756. }
  757. # preserve original flattened tags if requested
  758. if ($keepFlat) {
  759. my $extra = $$tagExtra{$key} or next;
  760. # restore list behaviour of this flattened tag
  761. if ($$extra{NoList}) {
  762. $$valueHash{$key} = $$extra{NoList};
  763. delete $$extra{NoList};
  764. } elsif ($$extra{NoListDel}) {
  765. # delete this tag since its value was included another list
  766. $et->DeleteTag($key);
  767. }
  768. } else {
  769. $et->DeleteTag($key); # delete the flattened tag
  770. }
  771. }
  772. }
  773. # fill in undefined items in lists. In theory, undefined list items should
  774. # be fine, but in practice the calling code may not check for this (and
  775. # historically this wasn't necessary, so do this for backward compatibility)
  776. foreach $si (keys %lists) {
  777. defined $_ or $_ = '' foreach @{$lists{$si}};
  778. }
  779. # save new structure tags
  780. foreach $si (keys %structs) {
  781. next unless $var{$si}; # already handled regular lists
  782. $key = $et->FoundTag($var{$si}[0], '');
  783. $$valueHash{$key} = $structs{$si};
  784. $$et{FILE_ORDER}{$key} = $var{$si}[1];
  785. }
  786. }
  787. 1; #end
  788. __END__
  789. =head1 NAME
  790. Image::ExifTool::XMPStruct.pl - XMP structure support
  791. =head1 SYNOPSIS
  792. This module is loaded automatically by Image::ExifTool when required.
  793. =head1 DESCRIPTION
  794. This file contains routines to provide read/write support of structured XMP
  795. information.
  796. =head1 AUTHOR
  797. Copyright 2003-2016, Phil Harvey (phil at owl.phy.queensu.ca)
  798. This library is free software; you can redistribute it and/or modify it
  799. under the same terms as Perl itself.
  800. =head1 SEE ALSO
  801. L<Image::ExifTool::TagNames/XMP Tags>,
  802. L<Image::ExifTool(3pm)|Image::ExifTool>
  803. =cut