WriteXMP.pl 58 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380
  1. #------------------------------------------------------------------------------
  2. # File: WriteXMP.pl
  3. #
  4. # Description: Write XMP meta information
  5. #
  6. # Revisions: 12/19/2004 - P. Harvey Created
  7. #------------------------------------------------------------------------------
  8. package Image::ExifTool::XMP;
  9. use strict;
  10. use vars qw(%specialStruct %dateTimeInfo %stdXlatNS);
  11. use Image::ExifTool qw(:DataAccess :Utils);
  12. sub CheckXMP($$$);
  13. sub CaptureXMP($$$;$);
  14. sub SetPropertyPath($$;$$$$);
  15. my $debug = 0;
  16. my $numPadLines = 24; # number of blank padding lines
  17. # when writing extended XMP, resources bigger than this get placed in their own
  18. # rdf:Description so they can be moved to the extended segments if necessary
  19. my $newDescThresh = 10240; # 10 kB
  20. # individual resources and namespaces to place last in separate rdf:Description's
  21. # so they can be moved to extended XMP segments if required (see Oct. 2008 XMP spec)
  22. my %extendedRes = (
  23. 'photoshop:History' => 1,
  24. 'xap:Thumbnails' => 1,
  25. 'xmp:Thumbnails' => 1,
  26. 'crs' => 1,
  27. 'crss' => 1,
  28. );
  29. my $rdfDesc = 'rdf:Description';
  30. #
  31. # packet/xmp/rdf headers and trailers
  32. #
  33. my $pktOpen = "<?xpacket begin='\xef\xbb\xbf' id='W5M0MpCehiHzreSzNTczkc9d'?>\n";
  34. my $xmlOpen = "<?xml version='1.0' encoding='UTF-8'?>\n";
  35. my $xmpOpenPrefix = "<x:xmpmeta xmlns:x='$nsURI{x}'";
  36. my $rdfOpen = "<rdf:RDF xmlns:rdf='$nsURI{rdf}'>\n";
  37. my $rdfClose = "</rdf:RDF>\n";
  38. my $xmpClose = "</x:xmpmeta>\n";
  39. my $pktCloseW = "<?xpacket end='w'?>"; # writable by default
  40. my $pktCloseR = "<?xpacket end='r'?>";
  41. #------------------------------------------------------------------------------
  42. # Get XMP opening tag (and set x:xmptk appropriately)
  43. # Inputs: 0) ExifTool object ref
  44. # Returns: x:xmpmeta opening tag
  45. sub XMPOpen($)
  46. {
  47. my $et = shift;
  48. my $nv = $$et{NEW_VALUE}{$Image::ExifTool::XMP::x{xmptk}};
  49. my $tk;
  50. if (defined $nv) {
  51. $tk = $et->GetNewValue($nv);
  52. $et->VerboseValue(($tk ? '+' : '-') . ' XMP-x:XMPToolkit', $tk);
  53. ++$$et{CHANGED};
  54. } else {
  55. $tk = "Image::ExifTool $Image::ExifTool::VERSION";
  56. }
  57. my $str = $tk ? (" x:xmptk='" . EscapeXML($tk) . "'") : '';
  58. return "$xmpOpenPrefix$str>\n";
  59. }
  60. #------------------------------------------------------------------------------
  61. # Validate XMP packet and set read or read/write mode
  62. # Inputs: 0) XMP data reference, 1) 'r' = read only, 'w' or undef = read/write
  63. # Returns: true if XMP is good (and adds packet header/trailer if necessary)
  64. sub ValidateXMP($;$)
  65. {
  66. my ($xmpPt, $mode) = @_;
  67. $$xmpPt =~ s/^\s*<!--.*?-->\s*//s; # remove leading comment if it exists
  68. unless ($$xmpPt =~ /^\0*<\0*\?\0*x\0*p\0*a\0*c\0*k\0*e\0*t/) {
  69. return '' unless $$xmpPt =~ /^<x(mp)?:x[ma]pmeta/;
  70. # add required xpacket header/trailer
  71. $$xmpPt = $pktOpen . $$xmpPt . $pktCloseW;
  72. }
  73. $mode = 'w' unless $mode;
  74. my $end = substr($$xmpPt, -32, 32);
  75. # check for proper xpacket trailer and set r/w mode if necessary
  76. return '' unless $end =~ s/(e\0*n\0*d\0*=\0*['"]\0*)([rw])(\0*['"]\0*\?\0*>)/$1$mode$3/;
  77. substr($$xmpPt, -32, 32) = $end if $2 ne $mode;
  78. return 1;
  79. }
  80. #------------------------------------------------------------------------------
  81. # Check XMP date values for validity and format accordingly
  82. # Inputs: 1) date string
  83. # Returns: XMP date/time string (or undef on error)
  84. sub FormatXMPDate($)
  85. {
  86. my $val = shift;
  87. my ($y, $m, $d, $t, $tz);
  88. if ($val =~ /(\d{4}):(\d{2}):(\d{2}) (\d{2}:\d{2}(?::\d{2}(?:\.\d*)?)?)(.*)/) {
  89. ($y, $m, $d, $t, $tz) = ($1, $2, $3, $4, $5);
  90. $val = "$y-$m-${d}T$t";
  91. } elsif ($val =~ /^\s*\d{4}(:\d{2}){0,2}\s*$/) {
  92. # this is just a date (YYYY, YYYY-mm or YYYY-mm-dd)
  93. $val =~ tr/:/-/;
  94. } elsif ($val =~ /^\s*(\d{2}:\d{2}(?::\d{2}(?:\.\d*)?)?)(.*)\s*$/) {
  95. # this is just a time
  96. ($t, $tz) = ($1, $2);
  97. $val = $t;
  98. } else {
  99. return undef;
  100. }
  101. if ($tz) {
  102. $tz =~ /^(Z|[+-]\d{2}:\d{2})$/ or return undef;
  103. $val .= $tz;
  104. }
  105. return $val;
  106. }
  107. #------------------------------------------------------------------------------
  108. # Check XMP values for validity and format accordingly
  109. # Inputs: 0) ExifTool object ref, 1) tagInfo hash ref, 2) raw value ref
  110. # Returns: error string or undef (and may change value) on success
  111. # Note: copies structured information to avoid conflicts with calling code
  112. sub CheckXMP($$$)
  113. {
  114. my ($et, $tagInfo, $valPtr) = @_;
  115. if ($$tagInfo{Struct}) {
  116. require 'Image/ExifTool/XMPStruct.pl';
  117. my ($item, $err, $w, $warn);
  118. unless (ref $$valPtr) {
  119. ($$valPtr, $warn) = InflateStruct($valPtr);
  120. # expect a structure HASH ref or ARRAY of structures
  121. unless (ref $$valPtr) {
  122. $$valPtr eq '' and $$valPtr = { }, return undef; # allow empty structures
  123. return 'Improperly formed structure';
  124. }
  125. }
  126. if (ref $$valPtr eq 'ARRAY') {
  127. return 'Not a list tag' unless $$tagInfo{List};
  128. my @copy = ( @{$$valPtr} ); # copy the list for ExifTool to use
  129. $$valPtr = \@copy; # return the copy
  130. foreach $item (@copy) {
  131. unless (ref $item eq 'HASH') {
  132. ($item, $w) = InflateStruct(\$item); # deserialize structure
  133. $w and $warn = $w;
  134. next if ref $item eq 'HASH';
  135. $err = 'Improperly formed structure';
  136. last;
  137. }
  138. ($item, $err) = CheckStruct($et, $item, $$tagInfo{Struct});
  139. last if $err;
  140. }
  141. } else {
  142. ($$valPtr, $err) = CheckStruct($et, $$valPtr, $$tagInfo{Struct});
  143. }
  144. $warn and $$et{CHECK_WARN} = $warn;
  145. return $err;
  146. }
  147. my $format = $$tagInfo{Writable};
  148. # (if no format specified, value is a simple string)
  149. if (not $format or $format eq 'string' or $format eq 'lang-alt') {
  150. # convert value to UTF8 if necessary
  151. if ($$et{OPTIONS}{Charset} ne 'UTF8') {
  152. if ($$valPtr =~ /[\x80-\xff]/) {
  153. # convert from Charset to UTF-8
  154. $$valPtr = $et->Encode($$valPtr,'UTF8');
  155. }
  156. } else {
  157. # translate invalid XML characters to "."
  158. $$valPtr =~ tr/\0-\x08\x0b\x0c\x0e-\x1f/./;
  159. # fix any malformed UTF-8 characters
  160. if (FixUTF8($valPtr) and not $$et{WarnBadUTF8}) {
  161. $et->Warn('Malformed UTF-8 character(s)');
  162. $$et{WarnBadUTF8} = 1;
  163. }
  164. }
  165. return undef; # success
  166. }
  167. if ($format eq 'rational' or $format eq 'real') {
  168. # make sure the value is a valid floating point number
  169. unless (Image::ExifTool::IsFloat($$valPtr) or
  170. # allow 'inf' and 'undef' rational values
  171. ($format eq 'rational' and ($$valPtr eq 'inf' or
  172. $$valPtr eq 'undef' or Image::ExifTool::IsRational($$valPtr))))
  173. {
  174. return 'Not a floating point number';
  175. }
  176. if ($format eq 'rational') {
  177. $$valPtr = join('/', Image::ExifTool::Rationalize($$valPtr));
  178. }
  179. } elsif ($format eq 'integer') {
  180. # make sure the value is integer
  181. if (Image::ExifTool::IsInt($$valPtr)) {
  182. # no conversion required (converting to 'int' would remove leading '+')
  183. } elsif (Image::ExifTool::IsHex($$valPtr)) {
  184. $$valPtr = hex($$valPtr);
  185. } else {
  186. return 'Not an integer';
  187. }
  188. } elsif ($format eq 'date') {
  189. my $newDate = FormatXMPDate($$valPtr);
  190. return "Invalid date/time (use YYYY:mm:dd HH:MM:SS[.ss][+/-HH:MM|Z])" unless $newDate;
  191. $$valPtr = $newDate;
  192. } elsif ($format eq 'boolean') {
  193. if (not $$valPtr or $$valPtr =~ /false/i or $$valPtr =~ /^no$/i) {
  194. $$valPtr = 'False';
  195. } else {
  196. $$valPtr = 'True';
  197. }
  198. } elsif ($format eq '1') {
  199. # this is the entire XMP data block
  200. return 'Invalid XMP data' unless ValidateXMP($valPtr);
  201. } else {
  202. return "Unknown XMP format: $format";
  203. }
  204. return undef; # success!
  205. }
  206. #------------------------------------------------------------------------------
  207. # Get PropertyPath for specified tagInfo
  208. # Inputs: 0) tagInfo reference
  209. # Returns: PropertyPath string
  210. sub GetPropertyPath($)
  211. {
  212. my $tagInfo = shift;
  213. SetPropertyPath($$tagInfo{Table}, $$tagInfo{TagID}) unless $$tagInfo{PropertyPath};
  214. return $$tagInfo{PropertyPath};
  215. }
  216. #------------------------------------------------------------------------------
  217. # Set PropertyPath for specified tag (also for associated flattened tags and structure elements)
  218. # Inputs: 0) tagTable reference, 1) tagID, 2) tagID of parent structure,
  219. # 3) structure definition ref (or undef), 4) property list up to this point (or undef),
  220. # 5) flag set if any containing structure has a TYPE
  221. # Notes: also generates flattened tags if they don't already exist
  222. sub SetPropertyPath($$;$$$$)
  223. {
  224. my ($tagTablePtr, $tagID, $parentID, $structPtr, $propList, $isType) = @_;
  225. my $table = $structPtr || $tagTablePtr;
  226. my $tagInfo = $$table{$tagID};
  227. my $flatInfo;
  228. return if ref($tagInfo) ne 'HASH'; # (shouldn't happen)
  229. if ($structPtr) {
  230. my $flatID = $parentID . ucfirst($tagID);
  231. $flatInfo = $$tagTablePtr{$flatID};
  232. if ($flatInfo) {
  233. return if $$flatInfo{PropertyPath};
  234. } else {
  235. # flattened tag doesn't exist, so create it now
  236. # (could happen if we were just writing a structure)
  237. $flatInfo = { Name => ucfirst($flatID), Flat => 1 };
  238. AddTagToTable($tagTablePtr, $flatID, $flatInfo);
  239. }
  240. $isType = 1 if $$structPtr{TYPE};
  241. } else {
  242. # don't override existing main table entry if already set by a Struct
  243. return if $$tagInfo{PropertyPath};
  244. # use property path from original tagInfo if this is an alternate-language tag
  245. my $srcInfo = $$tagInfo{SrcTagInfo};
  246. $$tagInfo{PropertyPath} = GetPropertyPath($srcInfo) if $srcInfo;
  247. return if $$tagInfo{PropertyPath};
  248. # set property path for all flattened tags in structure if necessary
  249. if ($$tagInfo{RootTagInfo}) {
  250. SetPropertyPath($tagTablePtr, $$tagInfo{RootTagInfo}{TagID});
  251. return if $$tagInfo{PropertyPath};
  252. warn "Internal Error: Didn't set path from root for $tagID\n";
  253. }
  254. }
  255. my $ns = $$tagInfo{Namespace} || $$table{NAMESPACE};
  256. $ns or warn("No namespace for $tagID\n"), return;
  257. my (@propList, $listType);
  258. $propList and @propList = @$propList;
  259. push @propList, "$ns:$tagID";
  260. # lang-alt lists are handled specially, signified by Writable='lang-alt'
  261. if ($$tagInfo{Writable} and $$tagInfo{Writable} eq 'lang-alt') {
  262. $listType = 'Alt';
  263. # remove language code from property path if it exists
  264. $propList[-1] =~ s/-$$tagInfo{LangCode}$// if $$tagInfo{LangCode};
  265. # handle lists of lang-alt lists (eg. XMP-plus:Custom tags)
  266. if ($$tagInfo{List} and $$tagInfo{List} ne '1') {
  267. push @propList, "rdf:$$tagInfo{List}", 'rdf:li 10';
  268. }
  269. } else {
  270. $listType = $$tagInfo{List};
  271. }
  272. # add required properties if this is a list
  273. push @propList, "rdf:$listType", 'rdf:li 10' if $listType and $listType ne '1';
  274. # set PropertyPath for all flattened tags of this structure if necessary
  275. # (note: don't do this for variable-namespace structures (undef NAMESPACE))
  276. my $strTable = $$tagInfo{Struct};
  277. if ($strTable and $$strTable{NAMESPACE} and not ($parentID and
  278. # must test NoSubStruct flag to avoid infinite recursion
  279. (($$tagTablePtr{$parentID} and $$tagTablePtr{$parentID}{NoSubStruct}) or
  280. length $parentID > 500))) # avoid deep recursion
  281. {
  282. # make sure the structure namespace has been registered
  283. # (user-defined namespaces may not have been)
  284. RegisterNamespace($strTable) if ref $$strTable{NAMESPACE};
  285. my $tag;
  286. foreach $tag (keys %$strTable) {
  287. # ignore special fields and any lang-alt fields we may have added
  288. next if $specialStruct{$tag} or $$strTable{$tag}{LangCode};
  289. my $fullID = $parentID ? $parentID . ucfirst($tagID) : $tagID;
  290. SetPropertyPath($tagTablePtr, $tag, $fullID, $strTable, \@propList, $isType);
  291. }
  292. }
  293. # if this was a structure field and not a normal tag,
  294. # we set PropertyPath in the corresponding flattened tag
  295. if ($structPtr) {
  296. $tagInfo = $flatInfo;
  297. # set StructType flag if any containing structure has a TYPE
  298. $$tagInfo{StructType} = 1 if $isType;
  299. }
  300. # set property path for tagInfo in main table
  301. $$tagInfo{PropertyPath} = join '/', @propList;
  302. }
  303. #------------------------------------------------------------------------------
  304. # Save XMP property name/value for rewriting
  305. # Inputs: 0) ExifTool object reference
  306. # 1) reference to array of XMP property path (last is current property)
  307. # 2) property value, 3) optional reference to hash of property attributes
  308. sub CaptureXMP($$$;$)
  309. {
  310. my ($et, $propList, $val, $attrs) = @_;
  311. return unless defined $val and @$propList > 2;
  312. if ($$propList[0] =~ /^x:x[ma]pmeta$/ and
  313. $$propList[1] eq 'rdf:RDF' and
  314. $$propList[2] =~ /$rdfDesc( |$)/)
  315. {
  316. # no properties to save yet if this is just the description
  317. return unless @$propList > 3;
  318. # ignore empty list properties
  319. if ($$propList[-1] =~ /^rdf:(Bag|Seq|Alt)$/) {
  320. $et->Warn("Ignored empty $$propList[-1] list for $$propList[-2]", 1);
  321. return;
  322. }
  323. # save information about this property
  324. my $capture = $$et{XMP_CAPTURE};
  325. my $path = join('/', @$propList[3..$#$propList]);
  326. if (defined $$capture{$path}) {
  327. $$et{XMP_ERROR} = "Duplicate XMP property: $path";
  328. } else {
  329. $$capture{$path} = [$val, $attrs || { }];
  330. }
  331. } elsif ($$propList[0] eq 'rdf:RDF' and
  332. $$propList[1] =~ /$rdfDesc( |$)/)
  333. {
  334. # set flag so we don't write x:xmpmeta element
  335. $$et{XMP_NO_XMPMETA} = 1;
  336. # add missing x:xmpmeta element and try again
  337. unshift @$propList, 'x:xmpmeta';
  338. CaptureXMP($et, $propList, $val, $attrs);
  339. } else {
  340. $$et{XMP_ERROR} = 'Improperly enclosed XMP property: ' . join('/',@$propList);
  341. }
  342. }
  343. #------------------------------------------------------------------------------
  344. # Save information about resource containing blank node with nodeID
  345. # Inputs: 0) reference to blank node information hash
  346. # 1) reference to property list
  347. # 2) property value
  348. # 3) [optional] reference to attribute hash
  349. # Notes: This routine and ProcessBlankInfo() are also used for reading information, but
  350. # are uncommon so are put in this file to reduce compile time for the common case
  351. sub SaveBlankInfo($$$;$)
  352. {
  353. my ($blankInfo, $propListPt, $val, $attrs) = @_;
  354. my $propPath = join '/', @$propListPt;
  355. my @ids = ($propPath =~ m{ #([^ /]*)}g);
  356. my $id;
  357. # split the property path at each nodeID
  358. foreach $id (@ids) {
  359. my ($pre, $prop, $post) = ($propPath =~ m{^(.*?)/([^/]*) #$id((/.*)?)$});
  360. defined $pre or warn("internal error parsing nodeID's"), next;
  361. # the element with the nodeID should be in the path prefix for subject
  362. # nodes and the path suffix for object nodes
  363. unless ($prop eq $rdfDesc) {
  364. if ($post) {
  365. $post = "/$prop$post";
  366. } else {
  367. $pre = "$pre/$prop";
  368. }
  369. }
  370. $$blankInfo{Prop}{$id}{Pre}{$pre} = 1;
  371. if ((defined $post and length $post) or (defined $val and length $val)) {
  372. # save the property value and attributes for each unique path suffix
  373. $$blankInfo{Prop}{$id}{Post}{$post} = [ $val, $attrs, $propPath ];
  374. }
  375. }
  376. }
  377. #------------------------------------------------------------------------------
  378. # Process blank-node information
  379. # Inputs: 0) ExifTool object ref, 1) tag table ref,
  380. # 2) blank node information hash ref, 3) flag set for writing
  381. sub ProcessBlankInfo($$$;$)
  382. {
  383. my ($et, $tagTablePtr, $blankInfo, $isWriting) = @_;
  384. $et->VPrint(1, " [Elements with nodeID set:]\n") unless $isWriting;
  385. my ($id, $pre, $post);
  386. # handle each nodeID separately
  387. foreach $id (sort keys %{$$blankInfo{Prop}}) {
  388. my $path = $$blankInfo{Prop}{$id};
  389. # flag all resource names so we can warn later if some are unused
  390. my %unused;
  391. foreach $post (keys %{$$path{Post}}) {
  392. $unused{$post} = 1;
  393. }
  394. # combine property paths for all possible paths through this node
  395. foreach $pre (sort keys %{$$path{Pre}}) {
  396. # there will be no description for the object of a blank node
  397. next unless $pre =~ m{/$rdfDesc/};
  398. foreach $post (sort keys %{$$path{Post}}) {
  399. my @propList = split m{/}, "$pre$post";
  400. my ($val, $attrs) = @{$$path{Post}{$post}};
  401. if ($isWriting) {
  402. CaptureXMP($et, \@propList, $val, $attrs);
  403. } else {
  404. FoundXMP($et, $tagTablePtr, \@propList, $val);
  405. }
  406. delete $unused{$post};
  407. }
  408. }
  409. # save information from unused properties (if RDF is malformed like f-spot output)
  410. if (%unused) {
  411. $et->Options('Verbose') and $et->Warn('An XMP resource is about nothing');
  412. foreach $post (sort keys %unused) {
  413. my ($val, $attrs, $propPath) = @{$$path{Post}{$post}};
  414. my @propList = split m{/}, $propPath;
  415. if ($isWriting) {
  416. CaptureXMP($et, \@propList, $val, $attrs);
  417. } else {
  418. FoundXMP($et, $tagTablePtr, \@propList, $val);
  419. }
  420. }
  421. }
  422. }
  423. }
  424. #------------------------------------------------------------------------------
  425. # Convert path to namespace used in file (this is a pain, but the XMP
  426. # spec only suggests 'preferred' namespace prefixes...)
  427. # Inputs: 0) ExifTool object reference, 1) property path
  428. # Returns: conforming property path
  429. sub ConformPathToNamespace($$)
  430. {
  431. my ($et, $path) = @_;
  432. my @propList = split('/',$path);
  433. my $nsUsed = $$et{XMP_NS};
  434. my $prop;
  435. foreach $prop (@propList) {
  436. my ($ns, $tag) = $prop =~ /(.+?):(.*)/;
  437. next if $$nsUsed{$ns};
  438. my $uri = $nsURI{$ns};
  439. unless ($uri) {
  440. warn "No URI for namepace prefix $ns!\n";
  441. next;
  442. }
  443. my $ns2;
  444. foreach $ns2 (keys %$nsUsed) {
  445. next unless $$nsUsed{$ns2} eq $uri;
  446. # use the existing namespace prefix instead of ours
  447. $prop = "$ns2:$tag";
  448. last;
  449. }
  450. }
  451. return join('/',@propList);
  452. }
  453. #------------------------------------------------------------------------------
  454. # Add necessary rdf:type element when writing structure
  455. # Inputs: 0) ExifTool ref, 1) tag table ref, 2) capture hash ref, 3) path string
  456. # 4) optional base path (already conformed to namespace) for elements in
  457. # variable-namespace structures
  458. sub AddStructType($$$$;$)
  459. {
  460. my ($et, $tagTablePtr, $capture, $path, $basePath) = @_;
  461. my @props = split '/', $path;
  462. my %doneID;
  463. for (;;) {
  464. pop @props;
  465. last unless @props;
  466. my $tagID = GetXMPTagID(\@props);
  467. next if $doneID{$tagID};
  468. $doneID{$tagID} = 1;
  469. my $tagInfo = $$tagTablePtr{$tagID};
  470. last unless ref $tagInfo eq 'HASH';
  471. if ($$tagInfo{Struct}) {
  472. my $type = $$tagInfo{Struct}{TYPE};
  473. if ($type) {
  474. my $pat = $$tagInfo{PropertyPath};
  475. $pat or warn("Missing PropertyPath in AddStructType\n"), last;
  476. $pat = ConformPathToNamespace($et, $pat);
  477. $pat =~ s/ \d+/ \\d\+/g;
  478. $path =~ /^($pat)/ or warn("Wrong path in AddStructType\n"), last;
  479. my $p = $1 . '/rdf:type';
  480. $p = "$basePath/$p" if $basePath;
  481. $$capture{$p} = [ '', { 'rdf:resource' => $type } ] unless $$capture{$p};
  482. }
  483. }
  484. last unless $$tagInfo{StructType};
  485. }
  486. }
  487. #------------------------------------------------------------------------------
  488. # Utility routine to encode data in base64
  489. # Inputs: 0) binary data string, 1) flag to avoid inserting newlines
  490. # Returns: base64-encoded string
  491. sub EncodeBase64($;$)
  492. {
  493. # encode the data in 45-byte chunks
  494. my $chunkSize = 45;
  495. my $len = length $_[0];
  496. my $str = '';
  497. my $i;
  498. for ($i=0; $i<$len; $i+=$chunkSize) {
  499. my $n = $len - $i;
  500. $n = $chunkSize if $n > $chunkSize;
  501. # add uuencoded data to output (minus size byte, but including trailing newline)
  502. $str .= substr(pack('u', substr($_[0], $i, $n)), 1);
  503. }
  504. # convert to base64 (remember that "\0" may be encoded as ' ' or '`')
  505. $str =~ tr/` -_/AA-Za-z0-9+\//;
  506. # convert pad characters at the end (remember to account for trailing newline)
  507. my $pad = 3 - ($len % 3);
  508. substr($str, -$pad-1, $pad) = ('=' x $pad) if $pad < 3;
  509. $str =~ tr/\n//d if $_[1]; # remove newlines if specified
  510. return $str;
  511. }
  512. #------------------------------------------------------------------------------
  513. # sort tagInfo hash references by tag name
  514. sub ByTagName
  515. {
  516. return $$a{Name} cmp $$b{Name};
  517. }
  518. #------------------------------------------------------------------------------
  519. # sort alphabetically, but with rdf:type first in the structure
  520. sub TypeFirst
  521. {
  522. if ($a =~ /rdf:type$/) {
  523. return substr($a, 0, -8) cmp $b unless $b =~ /rdf:type$/;
  524. } elsif ($b =~ /rdf:type$/) {
  525. return $a cmp substr($b, 0, -8);
  526. }
  527. return $a cmp $b;
  528. }
  529. #------------------------------------------------------------------------------
  530. # Limit size of XMP
  531. # Inputs: 0) ExifTool object ref, 1) XMP data ref (written up to start of $rdfClose),
  532. # 2) max XMP len, 3) rdf:about string, 4) list ref for description start offsets
  533. # 5) start offset of first description recommended for extended XMP
  534. # Returns: 0) extended XMP ref, 1) GUID and updates $$dataPt (or undef if no extended XMP)
  535. sub LimitXMPSize($$$$$$)
  536. {
  537. my ($et, $dataPt, $maxLen, $about, $startPt, $extStart) = @_;
  538. # return straight away if it isn't too big
  539. return undef if length($$dataPt) < $maxLen;
  540. push @$startPt, length($$dataPt); # add end offset to list
  541. my $newData = substr($$dataPt, 0, $$startPt[0]);
  542. my $guid = '0' x 32;
  543. # write the required xmpNote:HasExtendedXMP property
  544. $newData .= "\n <$rdfDesc rdf:about='$about'\n xmlns:xmpNote='$nsURI{xmpNote}'>\n" .
  545. " <xmpNote:HasExtendedXMP>$guid</xmpNote:HasExtendedXMP>\n" .
  546. " </$rdfDesc>\n";
  547. my ($i, %descSize, $start);
  548. # calculate all description block sizes
  549. for ($i=1; $i<@$startPt; ++$i) {
  550. $descSize{$$startPt[$i-1]} = $$startPt[$i] - $$startPt[$i-1];
  551. }
  552. pop @$startPt; # remove end offset
  553. # write the descriptions from smallest to largest, as many in main XMP as possible
  554. my @descStart = sort { $descSize{$a} <=> $descSize{$b} } @$startPt;
  555. my $extData = XMPOpen($et) . $rdfOpen;
  556. for ($i=0; $i<2; ++$i) {
  557. foreach $start (@descStart) {
  558. # write main XMP first (in order of size), then extended XMP afterwards (in order)
  559. next if $i xor $start >= $extStart;
  560. my $pt = (length($newData) + $descSize{$start} > $maxLen) ? \$extData : \$newData;
  561. $$pt .= substr($$dataPt, $start, $descSize{$start});
  562. }
  563. }
  564. $extData .= $rdfClose . $xmpClose; # close rdf:RDF and x:xmpmeta
  565. # calculate GUID from MD5 of extended XMP data
  566. if (eval { require Digest::MD5 }) {
  567. $guid = uc unpack('H*', Digest::MD5::md5($extData));
  568. $newData =~ s/0{32}/$guid/; # update GUID in main XMP segment
  569. }
  570. $et->VerboseValue('+ XMP-xmpNote:HasExtendedXMP', $guid);
  571. $$dataPt = $newData; # return main XMP block
  572. return (\$extData, $guid); # return extended XMP and its GUID
  573. }
  574. #------------------------------------------------------------------------------
  575. # Write XMP information
  576. # Inputs: 0) ExifTool object reference, 1) source dirInfo reference,
  577. # 2) [optional] tag table reference
  578. # Returns: with tag table: new XMP data (may be empty if no XMP data) or undef on error
  579. # without tag table: 1 on success, 0 if not valid XMP file, -1 on write error
  580. # Notes: May set dirInfo InPlace flag to rewrite with specified DirLen
  581. # May set dirInfo ReadOnly flag to write as read-only XMP ('r' mode and no padding)
  582. # May set dirInfo Compact flag to force compact (drops 2kB of padding)
  583. # May set dirInfo MaxDataLen to limit output data length -- this causes ExtendedXMP
  584. # and ExtendedGUID to be returned in dirInfo if extended XMP was required
  585. sub WriteXMP($$;$)
  586. {
  587. my ($et, $dirInfo, $tagTablePtr) = @_;
  588. $et or return 1; # allow dummy access to autoload this package
  589. my $dataPt = $$dirInfo{DataPt};
  590. my (%capture, %nsUsed, $xmpErr, $tagInfo, $about);
  591. my $changed = 0;
  592. my $xmpFile = (not $tagTablePtr); # this is an XMP data file if no $tagTablePtr
  593. # prefer XMP over other metadata formats in some types of files
  594. my $preferred = $xmpFile || ($$et{PreferredGroup} and $$et{PreferredGroup} eq 'XMP');
  595. my $verbose = $et->Options('Verbose');
  596. my $dirLen = $$dirInfo{DirLen};
  597. $dirLen = length($$dataPt) if not defined $dirLen and $dataPt;
  598. #
  599. # extract existing XMP information into %capture hash
  600. #
  601. # define hash in ExifTool object to capture XMP information (also causes
  602. # CaptureXMP() instead of FoundXMP() to be called from ParseXMPElement())
  603. #
  604. # The %capture hash is keyed on the complete property path beginning after
  605. # rdf:RDF/rdf:Description/. The values are array references with the
  606. # following entries: 0) value, 1) attribute hash reference.
  607. $$et{XMP_CAPTURE} = \%capture;
  608. $$et{XMP_NS} = \%nsUsed;
  609. delete $$et{XMP_NO_XMPMETA};
  610. delete $$et{XMP_NO_XPACKET};
  611. delete $$et{XMP_IS_XML};
  612. delete $$et{XMP_IS_SVG};
  613. if ($xmpFile or $dirLen) {
  614. delete $$et{XMP_ERROR};
  615. delete $$et{XMP_ABOUT};
  616. # extract all existing XMP information (to the XMP_CAPTURE hash)
  617. my $success = ProcessXMP($et, $dirInfo, $tagTablePtr);
  618. # don't continue if there is nothing to parse or if we had a parsing error
  619. unless ($success and not $$et{XMP_ERROR}) {
  620. my $err = $$et{XMP_ERROR} || 'Error parsing XMP';
  621. # may ignore this error only if we were successful
  622. if ($xmpFile) {
  623. my $raf = $$dirInfo{RAF};
  624. # allow empty XMP data so we can create something from nothing
  625. if ($success or not $raf->Seek(0,2) or $raf->Tell()) {
  626. # no error message if not an XMP file
  627. return 0 unless $$et{XMP_ERROR};
  628. if ($et->Error($err, $success)) {
  629. delete $$et{XMP_CAPTURE};
  630. return 0;
  631. }
  632. }
  633. } else {
  634. if ($et->Warn($err, $success)) {
  635. delete $$et{XMP_CAPTURE};
  636. return undef;
  637. }
  638. }
  639. }
  640. $tagInfo = $Image::ExifTool::XMP::rdf{about};
  641. if (defined $$et{NEW_VALUE}{$tagInfo}) {
  642. $about = $et->GetNewValue($$et{NEW_VALUE}{$tagInfo}) || '';
  643. if ($verbose > 1) {
  644. my $wasAbout = $$et{XMP_ABOUT};
  645. $et->VerboseValue('- XMP-rdf:About', UnescapeXML($wasAbout)) if defined $wasAbout;
  646. $et->VerboseValue('+ XMP-rdf:About', $about);
  647. }
  648. $about = EscapeXML($about); # must escape for XML
  649. ++$changed;
  650. } else {
  651. $about = $$et{XMP_ABOUT} || '';
  652. }
  653. delete $$et{XMP_ERROR};
  654. delete $$et{XMP_ABOUT};
  655. } else {
  656. $about = '';
  657. }
  658. #
  659. # handle writing XMP as a block to XMP file
  660. #
  661. if ($xmpFile) {
  662. $tagInfo = $Image::ExifTool::Extra{XMP};
  663. if ($tagInfo and $$et{NEW_VALUE}{$tagInfo}) {
  664. my $rtnVal = 1;
  665. my $newVal = $et->GetNewValue($$et{NEW_VALUE}{$tagInfo});
  666. if (defined $newVal and length $newVal) {
  667. $et->VPrint(0, " Writing XMP as a block\n");
  668. ++$$et{CHANGED};
  669. Write($$dirInfo{OutFile}, $newVal) or $rtnVal = -1;
  670. }
  671. delete $$et{XMP_CAPTURE};
  672. return $rtnVal;
  673. }
  674. }
  675. #
  676. # delete groups in family 1 if requested
  677. #
  678. if (%{$$et{DEL_GROUP}} and (grep /^XMP-.+$/, keys %{$$et{DEL_GROUP}} or
  679. # (logic is a bit more complex for group names in exiftool XML files)
  680. grep m{^http://ns.exiftool.ca/}, values %nsUsed))
  681. {
  682. my $del = $$et{DEL_GROUP};
  683. my $path;
  684. foreach $path (keys %capture) {
  685. my @propList = split('/',$path); # get property list
  686. my ($tag, $ns) = GetXMPTagID(\@propList);
  687. # translate namespace if necessary
  688. $ns = $stdXlatNS{$ns} if $stdXlatNS{$ns};
  689. my ($grp, @g);
  690. # no "XMP-" added to most groups in exiftool RDF/XML output file
  691. if ($nsUsed{$ns} and (@g = ($nsUsed{$ns} =~ m{^http://ns.exiftool.ca/(.*?)/(.*?)/}))) {
  692. if ($g[1] =~ /^\d/) {
  693. $grp = "XML-$g[0]";
  694. #(all XML-* groups stored as uppercase DEL_GROUP key)
  695. my $ucg = uc $grp;
  696. next unless $$del{$ucg} or ($$del{'XML-*'} and not $$del{"-$ucg"});
  697. } else {
  698. $grp = $g[1];
  699. next unless $$del{$grp} or ($$del{$g[0]} and not $$del{"-$grp"});
  700. }
  701. } else {
  702. $grp = "XMP-$ns";
  703. my $ucg = uc $grp;
  704. next unless $$del{$ucg} or ($$del{'XMP-*'} and not $$del{"-$ucg"});
  705. }
  706. $et->VerboseValue("- $grp:$tag", $capture{$path}->[0]);
  707. delete $capture{$path};
  708. ++$changed;
  709. }
  710. }
  711. # delete HasExtendedXMP tag (we create it as needed)
  712. my $hasExtTag = 'xmpNote:HasExtendedXMP';
  713. if ($capture{$hasExtTag}) {
  714. $et->VerboseValue("- XMP-$hasExtTag", $capture{$hasExtTag}->[0]);
  715. delete $capture{$hasExtTag};
  716. }
  717. # set $xmpOpen now to to handle xmptk tag first
  718. my $xmpOpen = $$et{XMP_NO_XMPMETA} ? '' : XMPOpen($et);
  719. #
  720. # add, delete or change information as specified
  721. #
  722. # get hash of all information we want to change
  723. # (sorted by tag name so alternate languages come last, but with structures
  724. # first so flattened tags may be used to override individual structure elements)
  725. my @tagInfoList;
  726. foreach $tagInfo (sort ByTagName $et->GetNewTagInfoList()) {
  727. next unless $et->GetGroup($tagInfo, 0) eq 'XMP';
  728. next if $$tagInfo{Name} eq 'XMP'; # (ignore full XMP block if we didn't write it already)
  729. if ($$tagInfo{Struct}) {
  730. unshift @tagInfoList, $tagInfo;
  731. } else {
  732. push @tagInfoList, $tagInfo;
  733. }
  734. }
  735. foreach $tagInfo (@tagInfoList) {
  736. my $tag = $$tagInfo{TagID};
  737. my $path = GetPropertyPath($tagInfo);
  738. unless ($path) {
  739. $et->Warn("Can't write XMP:$tag (namespace unknown)");
  740. next;
  741. }
  742. # skip tags that were handled specially
  743. if ($path eq 'rdf:about' or $path eq 'x:xmptk') {
  744. ++$changed;
  745. next;
  746. }
  747. my $isStruct = $$tagInfo{Struct};
  748. # change our property path namespace prefixes to conform
  749. # to the ones used in this file
  750. $path = ConformPathToNamespace($et, $path);
  751. # find existing property
  752. my $cap = $capture{$path};
  753. # MicrosoftPhoto screws up the case of some tags, and some other software,
  754. # including Adobe software, has been known to write the wrong list type or
  755. # not properly enclose properties in a list, so we check for this
  756. until ($cap) {
  757. # find and fix all incorrect property names if this is a structure or a flattened tag
  758. my @fixInfo;
  759. if ($isStruct or defined $$tagInfo{Flat}) {
  760. # get tagInfo for all containing (possibly nested) structures
  761. my @props = split '/', $path;
  762. my $tbl = $$tagInfo{Table};
  763. while (@props) {
  764. my $info = $$tbl{GetXMPTagID(\@props)};
  765. unshift @fixInfo, $info if ref $info eq 'HASH' and $$info{Struct} and
  766. (not @fixInfo or $fixInfo[0] ne $info);
  767. pop @props;
  768. }
  769. $et->WarnOnce("Error finding parent structure for $$tagInfo{Name}") unless @fixInfo;
  770. }
  771. # fix property path for this tag (last in the @fixInfo list)
  772. push @fixInfo, $tagInfo unless @fixInfo and $isStruct;
  773. # start from outermost containing structure, fixing incorrect list types, etc,
  774. # finally fixing the actual tag properties after all containing structures
  775. my $err;
  776. while (@fixInfo) {
  777. my $fixInfo = shift @fixInfo;
  778. my $fixPath = ConformPathToNamespace($et, GetPropertyPath($fixInfo));
  779. my $regex = quotemeta($fixPath);
  780. $regex =~ s/ \d+/ \\d\+/g; # match any list index
  781. my $ok = $regex;
  782. my ($ok2, $match, $i, @fixed, %fixed, $fixed);
  783. # check for incorrect list types
  784. if ($regex =~ s{\\/rdf\\:(Bag|Seq|Alt)\\/}{/rdf:(Bag|Seq|Alt)/}g) {
  785. # also look for missing bottom-level list
  786. if ($regex =~ s{/rdf:\(Bag\|Seq\|Alt\)\/rdf\\:li\\ \\d\+$}{}) {
  787. $regex .= '(/.*)?' unless @fixInfo;
  788. }
  789. } elsif (not @fixInfo) {
  790. $ok2 = $regex;
  791. # check for properties in lists that shouldn't be (ref forum4325)
  792. $regex .= '(/rdf:(Bag|Seq|Alt)/rdf:li \d+)?';
  793. }
  794. if (@fixInfo) {
  795. $regex .= '(/.*)?';
  796. $ok .= '(/.*)?';
  797. }
  798. my @matches = sort grep m{^$regex$}i, keys %capture;
  799. last unless @matches;
  800. if ($matches[0] =~ m{^$ok$}) {
  801. unless (@fixInfo) {
  802. $path = $matches[0];
  803. $cap = $capture{$path};
  804. }
  805. next;
  806. }
  807. # needs fixing...
  808. my @fixProps = split '/', $fixPath;
  809. foreach $match (@matches) {
  810. my @matchProps = split '/', $match;
  811. # remove superfluous list properties if necessary
  812. $#matchProps = $#fixProps if $ok2 and $#matchProps > $#fixProps;
  813. for ($i=0; $i<@fixProps; ++$i) {
  814. defined $matchProps[$i] or $matchProps[$i] = $fixProps[$i], next;
  815. next if $matchProps[$i] =~ / \d+$/ or $matchProps[$i] eq $fixProps[$i];
  816. $matchProps[$i] = $fixProps[$i];
  817. }
  818. $fixed = join '/', @matchProps;
  819. $err = 1 if $fixed{$fixed} or ($capture{$fixed} and $match ne $fixed);
  820. push @fixed, $fixed;
  821. $fixed{$fixed} = 1;
  822. }
  823. my $tg = $et->GetGroup($fixInfo, 1) . ':' . $$fixInfo{Name};
  824. my $wrn = lc($fixed[0]) eq lc($matches[0]) ? 'tag ID case' : 'list type';
  825. if ($err) {
  826. $et->Warn("Incorrect $wrn for existing $tg (not changed)");
  827. } else {
  828. # fix the incorrect property paths for all values of this tag
  829. my $didFix;
  830. foreach $fixed (@fixed) {
  831. my $match = shift @matches;
  832. next if $fixed eq $match;
  833. $capture{$fixed} = $capture{$match};
  834. delete $capture{$match};
  835. # remove xml:lang attribute from incorrect lang-alt list if necessary
  836. delete $capture{$fixed}[1]{'xml:lang'} if $ok2 and $match !~ /^$ok2$/;
  837. $didFix = 1;
  838. }
  839. $cap = $capture{$path} || $capture{$fixed[0]} unless @fixInfo;
  840. if ($didFix) {
  841. $et->Warn("Fixed incorrect $wrn for $tg", 1);
  842. ++$changed;
  843. }
  844. }
  845. }
  846. last;
  847. }
  848. my $nvHash = $et->GetNewValueHash($tagInfo);
  849. my $overwrite = $et->IsOverwriting($nvHash);
  850. my $writable = $$tagInfo{Writable} || '';
  851. my (%attrs, $deleted, $added, $existed);
  852. # delete existing entry if necessary
  853. if ($isStruct) {
  854. require 'Image/ExifTool/XMPStruct.pl';
  855. ($deleted, $added, $existed) = DeleteStruct($et, \%capture, \$path, $nvHash, \$changed);
  856. next unless $deleted or $added or $et->IsOverwriting($nvHash);
  857. next if $existed and $$nvHash{CreateOnly};
  858. } elsif ($cap) {
  859. next if $$nvHash{CreateOnly}; # (necessary for List-type tags)
  860. # take attributes from old values if they exist
  861. %attrs = %{$$cap[1]};
  862. if ($overwrite) {
  863. my ($delPath, $oldLang, $delLang, $addLang, @matchingPaths);
  864. # check to see if this is an indexed list item
  865. if ($path =~ / /) {
  866. my $pp;
  867. ($pp = $path) =~ s/ \d+/ \\d\+/g;
  868. @matchingPaths = sort grep(/^$pp$/, keys %capture);
  869. } else {
  870. push @matchingPaths, $path;
  871. }
  872. foreach $path (@matchingPaths) {
  873. my ($val, $attrs) = @{$capture{$path}};
  874. if ($writable eq 'lang-alt') {
  875. unless (defined $addLang) {
  876. # add to lang-alt list by default if creating this tag from scratch
  877. $addLang = $$nvHash{IsCreating} ? 1 : 0;
  878. }
  879. # get original language code (lc for comparisons)
  880. $oldLang = lc($$attrs{'xml:lang'} || 'x-default');
  881. if ($overwrite < 0) {
  882. my $newLang = lc($$tagInfo{LangCode} || 'x-default');
  883. next unless $oldLang eq $newLang;
  884. # only add new tag if we are overwriting this one
  885. # (note: this won't match if original XML contains CDATA!)
  886. $addLang = $et->IsOverwriting($nvHash, UnescapeXML($val));
  887. next unless $addLang;
  888. }
  889. # delete all if deleting "x-default" and writing with no LangCode
  890. # (XMP spec requires x-default language exist and be first in list)
  891. if ($oldLang eq 'x-default' and not $$tagInfo{LangCode}) {
  892. $delLang = 1; # delete all languages
  893. $overwrite = 1; # force overwrite
  894. } elsif ($$tagInfo{LangCode} and not $delLang) {
  895. # only overwrite specified language
  896. next unless lc($$tagInfo{LangCode}) eq $oldLang;
  897. }
  898. } elsif ($overwrite < 0) {
  899. # only overwrite specific values
  900. if ($$nvHash{Shift}) {
  901. # values to be shifted are checked (hence re-formatted) late,
  902. # so we must un-format the to-be-shifted value for IsOverwriting()
  903. my $fmt = $$tagInfo{Writable} || '';
  904. if ($fmt eq 'rational') {
  905. ConvertRational($val);
  906. } elsif ($fmt eq 'date') {
  907. $val = ConvertXMPDate($val);
  908. }
  909. }
  910. # (note: this won't match if original XML contains CDATA!)
  911. next unless $et->IsOverwriting($nvHash, UnescapeXML($val));
  912. }
  913. if ($verbose > 1) {
  914. my $grp = $et->GetGroup($tagInfo, 1);
  915. my $tagName = $$tagInfo{Name};
  916. $tagName =~ s/-$$tagInfo{LangCode}$// if $$tagInfo{LangCode};
  917. $tagName .= '-' . $$attrs{'xml:lang'} if $$attrs{'xml:lang'};
  918. $et->VerboseValue("- $grp:$tagName", $val);
  919. }
  920. # save attributes and path from first deleted property
  921. # so we can replace it exactly
  922. unless ($delPath) {
  923. %attrs = %$attrs;
  924. $delPath = $path;
  925. }
  926. # delete this tag
  927. delete $capture{$path};
  928. ++$changed;
  929. # delete rdf:type tag if it is the only thing left in this structure
  930. if ($path =~ /^(.*)\// and $capture{"$1/rdf:type"}) {
  931. my $pp = $1;
  932. my @a = grep /^\Q$pp\E\/[^\/]+/, keys %capture;
  933. delete $capture{"$pp/rdf:type"} if @a == 1;
  934. }
  935. }
  936. next unless $delPath or $$tagInfo{List} or $addLang;
  937. if ($delPath) {
  938. $path = $delPath;
  939. $deleted = 1;
  940. } else {
  941. # don't change tag if we couldn't delete old copy
  942. # unless this is a list or an lang-alt tag
  943. next unless $$tagInfo{List} or $oldLang;
  944. # (match last index to put in same lang-alt list for Bag of lang-alt items)
  945. $path =~ m/.* (\d+)/g or warn "Internal error: no list index!\n", next;
  946. $added = $1;
  947. }
  948. } else {
  949. # we are never overwriting, so we must be adding to a list
  950. # match the last index unless this is a list of lang-alt lists
  951. my $pat = $writable eq 'lang-alt' ? '.* (\d+)(.*? \d+)' : '.* (\d+)';
  952. if ($path =~ m/$pat/g) {
  953. $added = $1;
  954. # set position to end of matching index number
  955. pos($path) = pos($path) - length($2) if $2;
  956. }
  957. }
  958. if (defined $added) {
  959. my $len = length $added;
  960. my $pos = pos($path) - $len;
  961. my $nxt = substr($added, 1) + 1;
  962. # always insert x-default lang-alt entry first (as per XMP spec)
  963. # (need to test $overwrite because this will be a new lang-alt entry otherwise)
  964. if ($overwrite and $writable eq 'lang-alt' and (not $$tagInfo{LangCode} or
  965. $$tagInfo{LangCode} eq 'x-default'))
  966. {
  967. my $saveCap = $capture{$path};
  968. for (;;) {
  969. my $p = $path;
  970. substr($p, $pos, $len) = length($nxt) . $nxt;
  971. # increment index in the path of the existing item
  972. my $nextCap = $capture{$p};
  973. $capture{$p} = $saveCap;
  974. last unless $nextCap;
  975. $saveCap = $nextCap;
  976. ++$nxt;
  977. }
  978. } else {
  979. # add to end of list
  980. for (;;) {
  981. my $try = length($nxt) . $nxt;
  982. substr($path, $pos, $len) = $try;
  983. last unless $capture{$path};
  984. $len = length $try;
  985. ++$nxt;
  986. }
  987. }
  988. }
  989. }
  990. # check to see if we want to create this tag
  991. # (create non-avoided tags in XMP data files by default)
  992. my $isCreating = ($$nvHash{IsCreating} or (($isStruct or
  993. ($preferred and not $$tagInfo{Avoid} and
  994. not defined $$nvHash{Shift})) and not $$nvHash{EditOnly}));
  995. # don't add new values unless...
  996. # ...tag existed before and was deleted, or we added it to a list
  997. next unless $deleted or defined $added or
  998. # ...tag didn't exist before and we are creating it
  999. (not $cap and $isCreating);
  1000. # get list of new values (all done if no new values specified)
  1001. my @newValues = $et->GetNewValue($nvHash) or next;
  1002. # set language attribute for lang-alt lists
  1003. $attrs{'xml:lang'} = $$tagInfo{LangCode} || 'x-default' if $writable eq 'lang-alt';
  1004. # add new value(s) to %capture hash
  1005. my $subIdx;
  1006. for (;;) {
  1007. my $newValue = shift @newValues;
  1008. if ($isStruct) {
  1009. ++$changed if AddNewStruct($et, $tagInfo, \%capture,
  1010. $path, $newValue, $$tagInfo{Struct});
  1011. } else {
  1012. $newValue = EscapeXML($newValue);
  1013. for (;;) { # (a cheap 'goto')
  1014. if ($$tagInfo{Resource}) {
  1015. # only store as a resource if it doesn't contain any illegal characters
  1016. if ($newValue !~ /[^a-z0-9\:\/\?\#\[\]\@\!\$\&\'\(\)\*\+\,\;\=\.\-\_\~]/i) {
  1017. $capture{$path} = [ '', { %attrs, 'rdf:resource' => $newValue } ];
  1018. last;
  1019. }
  1020. my $grp = $et->GetGroup($tagInfo, 1);
  1021. $et->Warn("$grp:$$tagInfo{Name} written as a literal because value is not a valid URI", 1);
  1022. # fall through to write as a string literal
  1023. }
  1024. delete $attrs{'rdf:resource'}; # (remove existing resource if necessary)
  1025. $capture{$path} = [ $newValue, \%attrs ];
  1026. last;
  1027. }
  1028. if ($verbose > 1) {
  1029. my $grp = $et->GetGroup($tagInfo, 1);
  1030. $et->VerboseValue("+ $grp:$$tagInfo{Name}", $newValue);
  1031. }
  1032. ++$changed;
  1033. # add rdf:type if necessary
  1034. if ($$tagInfo{StructType}) {
  1035. AddStructType($et, $$tagInfo{Table}, \%capture, $path);
  1036. }
  1037. }
  1038. last unless @newValues;
  1039. # match last index except for lang-alt items where we want to put each
  1040. # item in a different lang-alt list (so match the 2nd-last for these)
  1041. my $pat = $writable eq 'lang-alt' ? '.* (\d+)(.*? \d+)' : '.* (\d+)';
  1042. $path =~ m/$pat/g or warn("Internal error: no list index for $tag!\n"), next;
  1043. my $idx = $1;
  1044. my $len = length $1;
  1045. my $pos = pos($path) - $len - ($2 ? length $2 : 0);
  1046. # generate unique list sub-indices to store additional values in sequence
  1047. if ($subIdx) {
  1048. $idx = substr($idx, 0, -length($subIdx)); # remove old sub-index
  1049. $subIdx = substr($subIdx, 1) + 1;
  1050. $subIdx = length($subIdx) . $subIdx;
  1051. } else {
  1052. $subIdx = '10';
  1053. }
  1054. substr($path, $pos, $len) = $idx . $subIdx;
  1055. }
  1056. # make sure any empty structures are deleted
  1057. # (ExifTool shouldn't write these, but other software may)
  1058. if (defined $$tagInfo{Flat}) {
  1059. my $p = $path;
  1060. while ($p =~ s/\/[^\/]+$//) {
  1061. next unless $capture{$p};
  1062. # it is an error if this property has a value
  1063. $et->Error("Improperly structured XMP ($p)",1) if $capture{$p}[0] =~ /\S/;
  1064. delete $capture{$p}; # delete the (hopefully) empty structure
  1065. }
  1066. }
  1067. }
  1068. # remove the ExifTool members we created
  1069. delete $$et{XMP_CAPTURE};
  1070. delete $$et{XMP_NS};
  1071. my $maxDataLen = $$dirInfo{MaxDataLen};
  1072. # get DataPt again because it may have been set by ProcessXMP
  1073. $dataPt = $$dirInfo{DataPt};
  1074. # return now if we didn't change anything
  1075. unless ($changed or ($maxDataLen and $dataPt and defined $$dataPt and
  1076. length($$dataPt) > $maxDataLen))
  1077. {
  1078. return undef unless $xmpFile; # just rewrite original XMP
  1079. Write($$dirInfo{OutFile}, $$dataPt) or return -1 if $dataPt and defined $$dataPt;
  1080. return 1;
  1081. }
  1082. #
  1083. # write out the new XMP information (serialize it)
  1084. #
  1085. # start writing the XMP data
  1086. my $newData = '';
  1087. if ($$et{XMP_NO_XPACKET}) {
  1088. # write BOM if flag is set
  1089. $newData .= "\xef\xbb\xbf" if $$et{XMP_NO_XPACKET} == 2;
  1090. } else {
  1091. $newData .= $pktOpen;
  1092. }
  1093. $newData .= $xmlOpen if $$et{XMP_IS_XML};
  1094. $newData .= $xmpOpen . $rdfOpen;
  1095. # initialize current property path list
  1096. my (@curPropList, @writeLast, @descStart, $extStart);
  1097. my (%nsCur, $prop, $n, $path);
  1098. my @pathList = sort TypeFirst keys %capture;
  1099. # order properties to write large values last if we have a MaxDataLen limit
  1100. if ($maxDataLen and @pathList) {
  1101. my @pathTmp;
  1102. my ($lastProp, $lastNS, $propSize) = ('', '', 0);
  1103. my @pathLoop = (@pathList, ''); # add empty path to end of list for loop
  1104. undef @pathList;
  1105. foreach $path (@pathLoop) {
  1106. $path =~ /^((\w*)[^\/]*)/; # get path element ($1) and ns ($2)
  1107. if ($1 eq $lastProp) {
  1108. push @pathTmp, $path; # accumulate all paths with same root
  1109. } else {
  1110. # put in list to write last if recommended or values are too large
  1111. if ($extendedRes{$lastProp} or $extendedRes{$lastNS} or
  1112. $propSize > $newDescThresh)
  1113. {
  1114. push @writeLast, @pathTmp;
  1115. } else {
  1116. push @pathList, @pathTmp;
  1117. }
  1118. last unless $path; # all done if we hit empty path
  1119. @pathTmp = ( $path );
  1120. ($lastProp, $lastNS, $propSize) = ($1, $2, 0);
  1121. }
  1122. $propSize += length $capture{$path}->[0];
  1123. }
  1124. }
  1125. # write out all properties
  1126. for (;;) {
  1127. my (%nsNew, $newDesc);
  1128. unless (@pathList) {
  1129. last unless @writeLast;
  1130. @pathList = @writeLast;
  1131. undef @writeLast;
  1132. $extStart = length $newData;
  1133. $newDesc = 1; # start with a new description
  1134. }
  1135. $path = shift @pathList;
  1136. my @propList = split('/',$path); # get property list
  1137. # must open/close rdf:Description too
  1138. unshift @propList, $rdfDesc;
  1139. # make sure we have defined all necessary namespaces
  1140. foreach $prop (@propList) {
  1141. $prop =~ /(.*):/ or next;
  1142. $1 eq 'rdf' and next; # rdf namespace already defined
  1143. my $uri = $nsUsed{$1};
  1144. unless ($uri) {
  1145. $uri = $nsURI{$1}; # we must have added a namespace
  1146. $uri or $xmpErr = "Undefined XMP namespace: $1", next;
  1147. }
  1148. $nsNew{$1} = $uri;
  1149. # need a new description if any new namespaces
  1150. $newDesc = 1 unless $nsCur{$1};
  1151. }
  1152. my $closeTo = 0;
  1153. if ($newDesc) {
  1154. # look forward to see if we will want to also open other namespaces
  1155. # at this level (this is necessary to keep lists and structures from
  1156. # being broken if a property introduces a new namespace; plus it
  1157. # improves formatting)
  1158. my ($path2, $ns2);
  1159. foreach $path2 (@pathList) {
  1160. my @ns2s = ($path2 =~ m{(?:^|/)([^/]+?):}g);
  1161. my $opening = 0;
  1162. foreach $ns2 (@ns2s) {
  1163. next if $ns2 eq 'rdf';
  1164. $nsNew{$ns2} and ++$opening, next;
  1165. last unless $opening;
  1166. # get URI for this existing or new namespace
  1167. my $uri = $nsUsed{$ns2} || $nsURI{$ns2} or last;
  1168. $nsNew{$ns2} = $uri; # also open this namespace
  1169. }
  1170. last unless $opening;
  1171. }
  1172. } else {
  1173. # find first property where the current path differs from the new path
  1174. for ($closeTo=0; $closeTo<@curPropList; ++$closeTo) {
  1175. last unless $closeTo < @propList;
  1176. last unless $propList[$closeTo] eq $curPropList[$closeTo];
  1177. }
  1178. }
  1179. # close out properties down to the common base path
  1180. while (@curPropList > $closeTo) {
  1181. ($prop = pop @curPropList) =~ s/ .*//;
  1182. $newData .= (' ' x scalar(@curPropList)) . " </$prop>\n";
  1183. }
  1184. if ($newDesc) {
  1185. # save rdf:Description start positions so we can reorder them if necessary
  1186. push @descStart, length($newData) if $maxDataLen;
  1187. # open the new description
  1188. $prop = $rdfDesc;
  1189. %nsCur = %nsNew; # save current namespaces
  1190. $newData .= "\n <$prop rdf:about='$about'";
  1191. my @ns = sort keys %nsCur;
  1192. # generate et:toolkit attribute if this is an exiftool RDF/XML output file
  1193. if (@ns and $nsCur{$ns[0]} =~ m{^http://ns.exiftool.ca/}) {
  1194. $newData .= "\n xmlns:et='http://ns.exiftool.ca/1.0/'" .
  1195. " et:toolkit='Image::ExifTool $Image::ExifTool::VERSION'";
  1196. }
  1197. foreach (@ns) {
  1198. $newData .= "\n xmlns:$_='$nsCur{$_}'";
  1199. }
  1200. $newData .= ">\n";
  1201. push @curPropList, $prop;
  1202. }
  1203. # loop over all values for this new property
  1204. my ($val, $attrs) = @{$capture{$path}};
  1205. $debug and print "$path = $val\n";
  1206. # open new properties
  1207. my ($attr, $dummy);
  1208. for ($n=@curPropList; $n<$#propList; ++$n) {
  1209. $prop = $propList[$n];
  1210. push @curPropList, $prop;
  1211. # remove list index if it exists
  1212. $prop =~ s/ .*//;
  1213. $attr = '';
  1214. if ($prop ne $rdfDesc and ($propList[$n+1] !~ /^rdf:/ or
  1215. ($propList[$n+1] eq 'rdf:type' and $n+1 == $#propList)))
  1216. {
  1217. # need parseType='Resource' to avoid new 'rdf:Description'
  1218. $attr = " rdf:parseType='Resource'";
  1219. # check for empty structure
  1220. if ($propList[$n+1] =~ /:~dummy~$/) {
  1221. $newData .= (' ' x scalar(@curPropList)) . "<$prop$attr/>\n";
  1222. pop @curPropList;
  1223. $dummy = 1;
  1224. last;
  1225. }
  1226. }
  1227. $newData .= (' ' x scalar(@curPropList)) . "<$prop$attr>\n";
  1228. }
  1229. my $prop2 = pop @propList; # get new property name
  1230. # add element unless it was a dummy structure field
  1231. unless ($dummy or ($val eq '' and $prop2 =~ /:~dummy~$/)) {
  1232. $prop2 =~ s/ .*//; # remove list index if it exists
  1233. $newData .= (' ' x scalar(@curPropList)) . " <$prop2";
  1234. # write out attributes
  1235. foreach $attr (sort keys %$attrs) {
  1236. my $attrVal = $$attrs{$attr};
  1237. my $quot = ($attrVal =~ /'/) ? '"' : "'";
  1238. $newData .= " $attr=$quot$attrVal$quot";
  1239. }
  1240. $newData .= length $val ? ">$val</$prop2>\n" : "/>\n";
  1241. }
  1242. }
  1243. # close off any open elements
  1244. while ($prop = pop @curPropList) {
  1245. $prop =~ s/ .*//; # remove list index if it exists
  1246. $newData .= (' ' x scalar(@curPropList)) . " </$prop>\n";
  1247. }
  1248. # limit XMP length and re-arrange if necessary to fit inside specified size
  1249. my $compact = $$dirInfo{Compact} || $et->Options('Compact');
  1250. if ($maxDataLen) {
  1251. # adjust maxDataLen to allow room for closing elements
  1252. $maxDataLen -= length($rdfClose) + length($xmpClose) + length($pktCloseW);
  1253. $extStart or $extStart = length $newData;
  1254. my @rtn = LimitXMPSize($et, \$newData, $maxDataLen, $about, \@descStart, $extStart);
  1255. # return extended XMP information in $dirInfo
  1256. $$dirInfo{ExtendedXMP} = $rtn[0];
  1257. $$dirInfo{ExtendedGUID} = $rtn[1];
  1258. # compact if necessary to fit
  1259. $compact = 1 if length($newData) + 101 * $numPadLines > $maxDataLen;
  1260. }
  1261. #
  1262. # close out the XMP, clean up, and return our data
  1263. #
  1264. $newData .= $rdfClose;
  1265. $newData .= $xmpClose unless $$et{XMP_NO_XMPMETA};
  1266. # remove the ExifTool members we created
  1267. delete $$et{XMP_CAPTURE};
  1268. delete $$et{XMP_NS};
  1269. delete $$et{XMP_NO_XMPMETA};
  1270. # (the XMP standard recommends writing 2k-4k of white space before the
  1271. # packet trailer, with a newline every 100 characters)
  1272. unless ($$et{XMP_NO_XPACKET}) {
  1273. my $pad = (' ' x 100) . "\n";
  1274. if ($$dirInfo{InPlace}) {
  1275. # pad to specified DirLen
  1276. my $len = length($newData) + length($pktCloseW);
  1277. if ($len > $dirLen) {
  1278. $et->Warn('Not enough room to edit XMP in place');
  1279. return undef;
  1280. }
  1281. my $num = int(($dirLen - $len) / length($pad));
  1282. if ($num) {
  1283. $newData .= $pad x $num;
  1284. $len += length($pad) * $num;
  1285. }
  1286. $len < $dirLen and $newData .= (' ' x ($dirLen - $len - 1)) . "\n";
  1287. } elsif (not $compact and not $xmpFile and not $$dirInfo{ReadOnly}) {
  1288. $newData .= $pad x $numPadLines;
  1289. }
  1290. $newData .= ($$dirInfo{ReadOnly} ? $pktCloseR : $pktCloseW);
  1291. }
  1292. # return empty data if no properties exist and this is allowed
  1293. unless (%capture or $xmpFile or $$dirInfo{InPlace} or $$dirInfo{NoDelete}) {
  1294. $newData = '';
  1295. }
  1296. if ($xmpErr) {
  1297. if ($xmpFile) {
  1298. $et->Error($xmpErr);
  1299. return -1;
  1300. }
  1301. $et->Warn($xmpErr);
  1302. return undef;
  1303. }
  1304. $$et{CHANGED} += $changed;
  1305. $debug > 1 and $newData and print $newData,"\n";
  1306. return $newData unless $xmpFile;
  1307. Write($$dirInfo{OutFile}, $newData) or return -1;
  1308. return 1;
  1309. }
  1310. 1; # end
  1311. __END__
  1312. =head1 NAME
  1313. Image::ExifTool::WriteXMP.pl - Write XMP meta information
  1314. =head1 SYNOPSIS
  1315. These routines are autoloaded by Image::ExifTool::XMP.
  1316. =head1 DESCRIPTION
  1317. This file contains routines to write XMP metadata.
  1318. =head1 AUTHOR
  1319. Copyright 2003-2016, Phil Harvey (phil at owl.phy.queensu.ca)
  1320. This library is free software; you can redistribute it and/or modify it
  1321. under the same terms as Perl itself.
  1322. =head1 SEE ALSO
  1323. L<Image::ExifTool::XMP(3pm)|Image::ExifTool::XMP>,
  1324. L<Image::ExifTool(3pm)|Image::ExifTool>
  1325. =cut