| 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 |
|
|---|
| 10 | use strict;
|
|---|
| 11 | use Image::ExifTool qw(:DataAccess :Utils);
|
|---|
| 12 |
|
|---|
| 13 | sub CheckXMP($$$);
|
|---|
| 14 | sub SetPropertyPath($$;$$);
|
|---|
| 15 | sub CaptureXMP($$$;$);
|
|---|
| 16 |
|
|---|
| 17 | my $debug = 0;
|
|---|
| 18 |
|
|---|
| 19 | # XMP structures (each structure is similar to a tag table so we can
|
|---|
| 20 | # recurse through them in SetPropertyPath() as if they were tag tables)
|
|---|
| 21 | my %xmpStruct = (
|
|---|
| 22 | ResourceRef => {
|
|---|
| 23 | NAMESPACE => 'stRef',
|
|---|
| 24 | InstanceID => { },
|
|---|
| 25 | DocumentID => { },
|
|---|
| 26 | VersionID => { },
|
|---|
| 27 | RenditionClass => { },
|
|---|
| 28 | RenditionParams => { },
|
|---|
| 29 | Manager => { },
|
|---|
| 30 | ManagerVariant => { },
|
|---|
| 31 | ManageTo => { },
|
|---|
| 32 | ManageUI => { },
|
|---|
| 33 | },
|
|---|
| 34 | ResourceEvent => {
|
|---|
| 35 | NAMESPACE => 'stEvt',
|
|---|
| 36 | action => { },
|
|---|
| 37 | instanceID => { },
|
|---|
| 38 | parameters => { },
|
|---|
| 39 | softwareAgent => { },
|
|---|
| 40 | when => { },
|
|---|
| 41 | },
|
|---|
| 42 | JobRef => {
|
|---|
| 43 | NAMESPACE => 'stJob',
|
|---|
| 44 | name => { },
|
|---|
| 45 | id => { },
|
|---|
| 46 | url => { },
|
|---|
| 47 | },
|
|---|
| 48 | Version => {
|
|---|
| 49 | NAMESPACE => 'stVer',
|
|---|
| 50 | comments => { },
|
|---|
| 51 | event => { Struct => 'ResourceEvent' },
|
|---|
| 52 | modifyDate => { },
|
|---|
| 53 | modifier => { },
|
|---|
| 54 | version => { },
|
|---|
| 55 | },
|
|---|
| 56 | Thumbnail => {
|
|---|
| 57 | NAMESPACE => 'xapGImg',
|
|---|
| 58 | height => { },
|
|---|
| 59 | width => { },
|
|---|
| 60 | 'format' => { },
|
|---|
| 61 | image => { },
|
|---|
| 62 | },
|
|---|
| 63 | IdentifierScheme => {
|
|---|
| 64 | NAMESPACE => 'xmpidq',
|
|---|
| 65 | Scheme => { }, # qualifier for xmp:Identifier only
|
|---|
| 66 | },
|
|---|
| 67 | Dimensions => {
|
|---|
| 68 | NAMESPACE => 'stDim',
|
|---|
| 69 | w => { },
|
|---|
| 70 | h => { },
|
|---|
| 71 | unit => { },
|
|---|
| 72 | },
|
|---|
| 73 | Colorant => {
|
|---|
| 74 | NAMESPACE => 'xapG',
|
|---|
| 75 | swatchName => { },
|
|---|
| 76 | mode => { },
|
|---|
| 77 | type => { },
|
|---|
| 78 | cyan => { },
|
|---|
| 79 | magenta => { },
|
|---|
| 80 | yellow => { },
|
|---|
| 81 | black => { },
|
|---|
| 82 | red => { },
|
|---|
| 83 | green => { },
|
|---|
| 84 | blue => { },
|
|---|
| 85 | L => { },
|
|---|
| 86 | A => { },
|
|---|
| 87 | B => { },
|
|---|
| 88 | },
|
|---|
| 89 | Font => {
|
|---|
| 90 | NAMESPACE => 'stFnt',
|
|---|
| 91 | fontName => { },
|
|---|
| 92 | fontFamily => { },
|
|---|
| 93 | fontFace => { },
|
|---|
| 94 | fontType => { },
|
|---|
| 95 | versionString => { },
|
|---|
| 96 | composite => { },
|
|---|
| 97 | fontFileName=> { },
|
|---|
| 98 | childFontFiles=> { List => 'Seq' },
|
|---|
| 99 | },
|
|---|
| 100 | # the following stuctures are different: They don't have
|
|---|
| 101 | # their own namespaces -- instead they use the parent namespace
|
|---|
| 102 | Flash => {
|
|---|
| 103 | NAMESPACE => 'exif',
|
|---|
| 104 | Fired => { },
|
|---|
| 105 | Return => { },
|
|---|
| 106 | Mode => { },
|
|---|
| 107 | Function => { },
|
|---|
| 108 | RedEyeMode => { },
|
|---|
| 109 | },
|
|---|
| 110 | OECF => {
|
|---|
| 111 | NAMESPACE => 'exif',
|
|---|
| 112 | Columns => { },
|
|---|
| 113 | Rows => { },
|
|---|
| 114 | Names => { },
|
|---|
| 115 | Values => { },
|
|---|
| 116 | },
|
|---|
| 117 | CFAPattern => {
|
|---|
| 118 | NAMESPACE => 'exif',
|
|---|
| 119 | Columns => { },
|
|---|
| 120 | Rows => { },
|
|---|
| 121 | Values => { },
|
|---|
| 122 | },
|
|---|
| 123 | DeviceSettings => {
|
|---|
| 124 | NAMESPACE => 'exif',
|
|---|
| 125 | Columns => { },
|
|---|
| 126 | Rows => { },
|
|---|
| 127 | Settings => { },
|
|---|
| 128 | },
|
|---|
| 129 | # Iptc4xmpCore structures
|
|---|
| 130 | ContactInfo => {
|
|---|
| 131 | NAMESPACE => 'Iptc4xmpCore',
|
|---|
| 132 | CiAdrCity => { },
|
|---|
| 133 | CiAdrCtry => { },
|
|---|
| 134 | CiAdrExtadr => { },
|
|---|
| 135 | CiAdrPcode => { },
|
|---|
| 136 | CiAdrRegion => { },
|
|---|
| 137 | CiEmailWork => { },
|
|---|
| 138 | CiTelWork => { },
|
|---|
| 139 | CiUrlWork => { },
|
|---|
| 140 | },
|
|---|
| 141 | # Dynamic Media structures
|
|---|
| 142 | BeatSpliceStretch => {
|
|---|
| 143 | NAMESPACE => 'xmpDM',
|
|---|
| 144 | useFileBeatsMarker => { },
|
|---|
| 145 | riseInDecibel => { },
|
|---|
| 146 | riseInTimeDuration => { },
|
|---|
| 147 | },
|
|---|
| 148 | Marker => {
|
|---|
| 149 | NAMESPACE => 'xmpDM',
|
|---|
| 150 | startTime => { },
|
|---|
| 151 | duration => { },
|
|---|
| 152 | comment => { },
|
|---|
| 153 | name => { },
|
|---|
| 154 | location => { },
|
|---|
| 155 | target => { },
|
|---|
| 156 | type => { },
|
|---|
| 157 | },
|
|---|
| 158 | Media => {
|
|---|
| 159 | NAMESPACE => 'xmpDM',
|
|---|
| 160 | path => { },
|
|---|
| 161 | track => { },
|
|---|
| 162 | startTime => { },
|
|---|
| 163 | duration => { },
|
|---|
| 164 | managed => { },
|
|---|
| 165 | webStatement=> { },
|
|---|
| 166 | },
|
|---|
| 167 | ProjectLink => {
|
|---|
| 168 | NAMESPACE => 'xmpDM',
|
|---|
| 169 | type => { },
|
|---|
| 170 | path => { },
|
|---|
| 171 | },
|
|---|
| 172 | ResampleStretch => {
|
|---|
| 173 | NAMESPACE => 'xmpDM',
|
|---|
| 174 | quality => { },
|
|---|
| 175 | },
|
|---|
| 176 | Time => {
|
|---|
| 177 | NAMESPACE => 'xmpDM',
|
|---|
| 178 | value => { },
|
|---|
| 179 | scale => { },
|
|---|
| 180 | },
|
|---|
| 181 | Timecode => {
|
|---|
| 182 | NAMESPACE => 'xmpDM',
|
|---|
| 183 | timeValue => { },
|
|---|
| 184 | timeFormat => { },
|
|---|
| 185 | },
|
|---|
| 186 | TimeScaleStretch => {
|
|---|
| 187 | NAMESPACE => 'xmpDM',
|
|---|
| 188 | quality => { },
|
|---|
| 189 | frameSize => { },
|
|---|
| 190 | frameOverlappingPercentage => { },
|
|---|
| 191 | },
|
|---|
| 192 | );
|
|---|
| 193 |
|
|---|
| 194 | # Lookup to translate our namespace prefixes into URI's. This list need
|
|---|
| 195 | # not be complete, but it must contain an entry for each namespace prefix
|
|---|
| 196 | # (NAMESPACE) for writable tags in the XMP tables or the table above
|
|---|
| 197 | my %nsURI = (
|
|---|
| 198 | aux => 'http://ns.adobe.com/exif/1.0/aux/',
|
|---|
| 199 | cc => 'http://web.resource.org/cc/',
|
|---|
| 200 | crs => 'http://ns.adobe.com/camera-raw-settings/1.0/',
|
|---|
| 201 | crss => 'http://ns.adobe.com/camera-raw-saved-settings/1.0/',
|
|---|
| 202 | dc => 'http://purl.org/dc/elements/1.1/',
|
|---|
| 203 | exif => 'http://ns.adobe.com/exif/1.0/',
|
|---|
| 204 | iX => 'http://ns.adobe.com/iX/1.0/',
|
|---|
| 205 | pdf => 'http://ns.adobe.com/pdf/1.3/',
|
|---|
| 206 | pdfx => 'http://ns.adobe.com/pdfx/1.3/',
|
|---|
| 207 | photoshop => 'http://ns.adobe.com/photoshop/1.0/',
|
|---|
| 208 | rdf => 'http://www.w3.org/1999/02/22-rdf-syntax-ns#',
|
|---|
| 209 | rdfs => 'http://www.w3.org/2000/01/rdf-schema#',
|
|---|
| 210 | stDim => 'http://ns.adobe.com/xap/1.0/sType/Dimensions#',
|
|---|
| 211 | stEvt => 'http://ns.adobe.com/xap/1.0/sType/ResourceEvent#',
|
|---|
| 212 | stFnt => 'http://ns.adobe.com/xap/1.0/sType/Font#',
|
|---|
| 213 | stJob => 'http://ns.adobe.com/xap/1.0/sType/Job#',
|
|---|
| 214 | stRef => 'http://ns.adobe.com/xap/1.0/sType/ResourceRef#',
|
|---|
| 215 | stVer => 'http://ns.adobe.com/xap/1.0/sType/Version#',
|
|---|
| 216 | tiff => 'http://ns.adobe.com/tiff/1.0/',
|
|---|
| 217 | 'x' => 'adobe:ns:meta/',
|
|---|
| 218 | xapG => 'http://ns.adobe.com/xap/1.0/g/',
|
|---|
| 219 | xapGImg => 'http://ns.adobe.com/xap/1.0/g/img/',
|
|---|
| 220 | xmp => 'http://ns.adobe.com/xap/1.0/',
|
|---|
| 221 | xmpBJ => 'http://ns.adobe.com/xap/1.0/bj/',
|
|---|
| 222 | xmpDM => 'http://ns.adobe.com/xmp/1.0/DynamicMedia/',
|
|---|
| 223 | xmpMM => 'http://ns.adobe.com/xap/1.0/mm/',
|
|---|
| 224 | xmpRights => 'http://ns.adobe.com/xap/1.0/rights/',
|
|---|
| 225 | xmpTPg => 'http://ns.adobe.com/xap/1.0/t/pg/',
|
|---|
| 226 | xmpidq => 'http://ns.adobe.com/xmp/Identifier/qual/1.0/',
|
|---|
| 227 | xmpPLUS => 'http://ns.adobe.com/xap/1.0/PLUS/',
|
|---|
| 228 | dex => 'http://ns.optimasc.com/dex/1.0/',
|
|---|
| 229 | mediapro => 'http://ns.iview-multimedia.com/mediapro/1.0/',
|
|---|
| 230 | Iptc4xmpCore => 'http://iptc.org/std/Iptc4xmpCore/1.0/xmlns/',
|
|---|
| 231 | MicrosoftPhoto => 'http://ns.microsoft.com/photo/1.0',
|
|---|
| 232 | lr => 'http://ns.adobe.com/lightroom/1.0/',
|
|---|
| 233 | DICOM => 'http://ns.adobe.com/DICOM/',
|
|---|
| 234 | );
|
|---|
| 235 |
|
|---|
| 236 | my $x_toolkit = "x:xmptk='Image::ExifTool $Image::ExifTool::VERSION'";
|
|---|
| 237 | my $rdfDesc = 'rdf:Description';
|
|---|
| 238 | #
|
|---|
| 239 | # packet/xmp/rdf headers and trailers
|
|---|
| 240 | #
|
|---|
| 241 | my $pktOpen = "<?xpacket begin='\xef\xbb\xbf' id='W5M0MpCehiHzreSzNTczkc9d'?>\n";
|
|---|
| 242 | my $xmlOpen = "<?xml version='1.0' encoding='UTF-8'?>\n";
|
|---|
| 243 | my $xmpOpen = "<x:xmpmeta xmlns:x='$nsURI{x}' $x_toolkit>\n";
|
|---|
| 244 | my $rdfOpen = "<rdf:RDF xmlns:rdf='$nsURI{rdf}'>\n";
|
|---|
| 245 | my $rdfClose = "</rdf:RDF>\n";
|
|---|
| 246 | my $xmpClose = "</x:xmpmeta>\n";
|
|---|
| 247 | my $pktCloseW = "<?xpacket end='w'?>"; # writable by default
|
|---|
| 248 | my $pktCloseR = "<?xpacket end='r'?>";
|
|---|
| 249 |
|
|---|
| 250 | # Update XMP tag tables when this library is loaded:
|
|---|
| 251 | # - generate all TagID's (required when writing)
|
|---|
| 252 | # - generate PropertyPath for structure elements
|
|---|
| 253 | # - add necessary inverse conversion routines
|
|---|
| 254 | {
|
|---|
| 255 | my $mainTable = GetTagTable('Image::ExifTool::XMP::Main');
|
|---|
| 256 | GenerateTagIDs($mainTable);
|
|---|
| 257 | my ($mainTag, $ns, $tag);
|
|---|
| 258 | foreach $mainTag (keys %$mainTable) {
|
|---|
| 259 | my $mainInfo = $mainTable->{$mainTag};
|
|---|
| 260 | next unless ref $mainInfo eq 'HASH' and $mainInfo->{SubDirectory};
|
|---|
| 261 | my $table = GetTagTable($mainInfo->{SubDirectory}->{TagTable});
|
|---|
| 262 | $$table{WRITE_PROC} = \&WriteXMP; # set WRITE_PROC for all tables
|
|---|
| 263 | GenerateTagIDs($table);
|
|---|
| 264 | $table->{CHECK_PROC} = \&CheckXMP; # add our write check routine
|
|---|
| 265 | foreach $tag (TagTableKeys($table)) {
|
|---|
| 266 | my $tagInfo = $$table{$tag};
|
|---|
| 267 | next unless ref $tagInfo eq 'HASH';
|
|---|
| 268 | # must set PropertyPath now for all tags that are Struct elements
|
|---|
| 269 | # (normal tags will get set later if they are actually written)
|
|---|
| 270 | SetPropertyPath($table, $tag) if $$tagInfo{Struct};
|
|---|
| 271 | my $format = $$tagInfo{Writable};
|
|---|
| 272 | next unless $format and $format eq 'date';
|
|---|
| 273 | # add dummy conversion for dates (for now...)
|
|---|
| 274 | $$tagInfo{PrintConvInv} = '$val' unless $$tagInfo{PrintConvInv};
|
|---|
| 275 | $$tagInfo{ValueConvInv} = '$val' unless $$tagInfo{ValueConvInv};
|
|---|
| 276 | }
|
|---|
| 277 | # add new namespace if NAMESPACE is ns/uri pair
|
|---|
| 278 | next unless ref $$table{NAMESPACE};
|
|---|
| 279 | my $nsRef = $$table{NAMESPACE};
|
|---|
| 280 | # recognize as either a list or hash
|
|---|
| 281 | if (ref $nsRef eq 'ARRAY') {
|
|---|
| 282 | $ns = $$nsRef[0];
|
|---|
| 283 | $nsURI{$ns} = $$nsRef[1];
|
|---|
| 284 | } else { # must be a hash
|
|---|
| 285 | ($ns) = keys %$nsRef;
|
|---|
| 286 | $nsURI{$ns} = $$nsRef{$ns};
|
|---|
| 287 | }
|
|---|
| 288 | $$table{NAMESPACE} = $ns;
|
|---|
| 289 | }
|
|---|
| 290 | }
|
|---|
| 291 |
|
|---|
| 292 | #------------------------------------------------------------------------------
|
|---|
| 293 | # Validate XMP packet and set read or read/write mode
|
|---|
| 294 | # Inputs: 0) XMP data reference, 1) 'r' = read only, 'w' or undef = read/write
|
|---|
| 295 | # Returns: true if XMP is good (and adds packet header/trailer if necessary)
|
|---|
| 296 | sub ValidateXMP($;$)
|
|---|
| 297 | {
|
|---|
| 298 | my ($xmpPt, $mode) = @_;
|
|---|
| 299 | unless ($$xmpPt =~ /^\0*<\0*\?\0*x\0*p\0*a\0*c\0*k\0*e\0*t/) {
|
|---|
| 300 | return '' unless $$xmpPt =~ /^<x(mp)?:xmpmeta/;
|
|---|
| 301 | # add required xpacket header/trailer
|
|---|
| 302 | $$xmpPt = $pktOpen . $$xmpPt . $pktCloseW;
|
|---|
| 303 | }
|
|---|
| 304 | $mode = 'w' unless $mode;
|
|---|
| 305 | my $end = substr($$xmpPt, -32, 32);
|
|---|
| 306 | # check for proper xpacket trailer and set r/w mode if necessary
|
|---|
| 307 | return '' unless $end =~ s/(e\0*n\0*d\0*=\0*['"]\0*)([rw])(\0*['"]\0*\?\0*>)/$1$mode$3/;
|
|---|
| 308 | substr($$xmpPt, -32, 32) = $end if $2 ne $mode;
|
|---|
| 309 | return 1;
|
|---|
| 310 | }
|
|---|
| 311 |
|
|---|
| 312 | #------------------------------------------------------------------------------
|
|---|
| 313 | # Check XMP values for validity and format accordingly
|
|---|
| 314 | # Inputs: 0) ExifTool object reference, 1) tagInfo hash reference,
|
|---|
| 315 | # 2) raw value reference
|
|---|
| 316 | # Returns: error string or undef (and may change value) on success
|
|---|
| 317 | sub CheckXMP($$$)
|
|---|
| 318 | {
|
|---|
| 319 | my ($exifTool, $tagInfo, $valPtr) = @_;
|
|---|
| 320 | # convert value from Latin if necessary
|
|---|
| 321 | if ($exifTool->{OPTIONS}->{Charset} eq 'Latin' and $$valPtr =~ /[\x80-\xff]/) {
|
|---|
| 322 | # convert from Latin to UTF-8
|
|---|
| 323 | my $val = Image::ExifTool::Latin2Unicode($$valPtr,'n');
|
|---|
| 324 | $$valPtr = Image::ExifTool::Unicode2UTF8($val,'n');
|
|---|
| 325 | }
|
|---|
| 326 | my $format = $tagInfo->{Writable};
|
|---|
| 327 | # if no format specified, value is a simple string
|
|---|
| 328 | return undef unless $format and $format ne 'string';
|
|---|
| 329 | if ($format eq 'rational' or $format eq 'real') {
|
|---|
| 330 | # make sure the value is a valid floating point number
|
|---|
| 331 | Image::ExifTool::IsFloat($$valPtr) or return 'Not a floating point number';
|
|---|
| 332 | if ($format eq 'rational') {
|
|---|
| 333 | $$valPtr = join('/', Image::ExifTool::Rationalize($$valPtr));
|
|---|
| 334 | }
|
|---|
| 335 | } elsif ($format eq 'integer') {
|
|---|
| 336 | # make sure the value is integer
|
|---|
| 337 | if (Image::ExifTool::IsInt($$valPtr)) {
|
|---|
| 338 | # no conversion required (converting to 'int' would remove leading '+')
|
|---|
| 339 | } elsif (Image::ExifTool::IsHex($$valPtr)) {
|
|---|
| 340 | $$valPtr = hex($$valPtr);
|
|---|
| 341 | } else {
|
|---|
| 342 | return 'Not an integer';
|
|---|
| 343 | }
|
|---|
| 344 | } elsif ($format eq 'date') {
|
|---|
| 345 | if ($$valPtr =~ /(\d{4}):(\d{2}):(\d{2}) (\d{2}:\d{2}(?::\d{2}(?:\.\d*)?)?)(.*)/) {
|
|---|
| 346 | my ($y, $m, $d, $t, $tz) = ($1, $2, $3, $4, $5);
|
|---|
| 347 | # use 'Z' for timezone unless otherwise specified
|
|---|
| 348 | $tz = 'Z' unless $tz and $tz =~ /([+-]\d{2}:\d{2})/;
|
|---|
| 349 | $$valPtr = "$y-$m-${d}T$t$tz";
|
|---|
| 350 | } elsif ($$valPtr =~ /^\s*\d{4}(:\d{2}){0,2}\s*$/) {
|
|---|
| 351 | # this is just a date (YYYY, YYYY-MM or YYYY-MM-DD)
|
|---|
| 352 | $$valPtr =~ tr/:/-/;
|
|---|
| 353 | } elsif ($$valPtr =~ /^\s*(\d{2}:\d{2}:\d{2})(.*)\s*$/) {
|
|---|
| 354 | # this is just a time
|
|---|
| 355 | my ($t, $tz) = ($1, $2);
|
|---|
| 356 | $tz = 'Z' unless $tz and $tz =~ /([+-]\d{2}:\d{2})/;
|
|---|
| 357 | $$valPtr = "$t$tz";
|
|---|
| 358 | } else {
|
|---|
| 359 | return "Invalid date or time format (should be YYYY:MM:DD HH:MM:SS[+/-HH:MM])";
|
|---|
| 360 | }
|
|---|
| 361 | } elsif ($format eq 'lang-alt') {
|
|---|
| 362 | # nothing to do
|
|---|
| 363 | } elsif ($format eq 'boolean') {
|
|---|
| 364 | if (not $$valPtr or $$valPtr =~ /false/i or $$valPtr =~ /^no$/i) {
|
|---|
| 365 | $$valPtr = 'False';
|
|---|
| 366 | } else {
|
|---|
| 367 | $$valPtr = 'True';
|
|---|
| 368 | }
|
|---|
| 369 | } elsif ($format eq '1') {
|
|---|
| 370 | # this is the entire XMP data block
|
|---|
| 371 | return 'Invalid XMP data' unless ValidateXMP($valPtr);
|
|---|
| 372 | } else {
|
|---|
| 373 | return "Unknown XMP format: $format";
|
|---|
| 374 | }
|
|---|
| 375 | return undef; # success!
|
|---|
| 376 | }
|
|---|
| 377 |
|
|---|
| 378 | #------------------------------------------------------------------------------
|
|---|
| 379 | # Get PropertyPath for specified tagInfo
|
|---|
| 380 | # Inputs: 0) tagInfo reference
|
|---|
| 381 | # Returns: PropertyPath string
|
|---|
| 382 | sub GetPropertyPath($)
|
|---|
| 383 | {
|
|---|
| 384 | my $tagInfo = shift;
|
|---|
| 385 | unless ($$tagInfo{PropertyPath}) {
|
|---|
| 386 | SetPropertyPath($$tagInfo{Table}, $$tagInfo{TagID});
|
|---|
| 387 | }
|
|---|
| 388 | return $$tagInfo{PropertyPath};
|
|---|
| 389 | }
|
|---|
| 390 |
|
|---|
| 391 | #------------------------------------------------------------------------------
|
|---|
| 392 | # Set PropertyPath for specified tag (also for any structure elements)
|
|---|
| 393 | # Inputs: 0) tagTable reference, 1) tagID, 2) structure reference (or undef),
|
|---|
| 394 | # 3) property list up to this point (or undef), 4) true if tag is a list
|
|---|
| 395 | sub SetPropertyPath($$;$$)
|
|---|
| 396 | {
|
|---|
| 397 | my ($tagTablePtr, $tagID, $structPtr, $propList) = @_;
|
|---|
| 398 | my $table = $structPtr || $tagTablePtr;
|
|---|
| 399 | my $tagInfo = $$table{$tagID};
|
|---|
| 400 | my $ns = $$table{NAMESPACE};
|
|---|
| 401 | # don't override existing main table entry if already set by a Struct
|
|---|
| 402 | return if not $structPtr and $$tagInfo{PropertyPath};
|
|---|
| 403 | $ns or warn("No namespace for $tagID\n"), return;
|
|---|
| 404 | my (@propList, $listType);
|
|---|
| 405 | $propList and @propList = @$propList;
|
|---|
| 406 | push @propList, "$ns:$tagID";
|
|---|
| 407 | # lang-alt lists are handled specially, signified by Writable='lang-alt'
|
|---|
| 408 | if ($$tagInfo{Writable} and $$tagInfo{Writable} eq 'lang-alt') {
|
|---|
| 409 | $listType = 'Alt';
|
|---|
| 410 | # remove language code from property path if it exists
|
|---|
| 411 | $propList[-1] =~ s/-$$tagInfo{LangCode}$// if $$tagInfo{LangCode};
|
|---|
| 412 | } else {
|
|---|
| 413 | $listType = $$tagInfo{List};
|
|---|
| 414 | }
|
|---|
| 415 | # add required properties if this is a list
|
|---|
| 416 | push @propList, "rdf:$listType", 'rdf:li 000' if $listType and $listType ne '1';
|
|---|
| 417 | # set PropertyPath for all elements of this structure if necessary
|
|---|
| 418 | if ($$tagInfo{Struct}) {
|
|---|
| 419 | my $struct = $xmpStruct{$$tagInfo{Struct}};
|
|---|
| 420 | $struct or warn("No XMP $$tagInfo{Struct} structure!\n"), return;
|
|---|
| 421 | my $tag;
|
|---|
| 422 | foreach $tag (keys %$struct) {
|
|---|
| 423 | next if $tag eq 'NAMESPACE';
|
|---|
| 424 | SetPropertyPath($tagTablePtr, $tag, $struct, \@propList);
|
|---|
| 425 | }
|
|---|
| 426 | }
|
|---|
| 427 | # use tagInfo for combined tag name if this was a Struct
|
|---|
| 428 | if ($structPtr) {
|
|---|
| 429 | my $tagName = GetXMPTagID(\@propList);
|
|---|
| 430 | $$tagTablePtr{$tagName} or warn("Tag $tagName not found!\n"), return;
|
|---|
| 431 | $tagInfo = $$tagTablePtr{$tagName};
|
|---|
| 432 | # must check again for List's at this level
|
|---|
| 433 | if ($$tagInfo{Writable} and $$tagInfo{Writable} eq 'lang-alt') {
|
|---|
| 434 | $listType = 'Alt';
|
|---|
| 435 | } else {
|
|---|
| 436 | $listType = $$tagInfo{List};
|
|---|
| 437 | }
|
|---|
| 438 | push @propList, "rdf:$listType", 'rdf:li 000' if $listType and $listType ne '1';
|
|---|
| 439 | }
|
|---|
| 440 | # set property path for tagInfo in main table
|
|---|
| 441 | $$tagInfo{PropertyPath} = join '/', @propList;
|
|---|
| 442 | }
|
|---|
| 443 |
|
|---|
| 444 | #------------------------------------------------------------------------------
|
|---|
| 445 | # Save XMP property name/value for rewriting
|
|---|
| 446 | # Inputs: 0) ExifTool object reference
|
|---|
| 447 | # 1) reference to array of XMP property path (last is current property)
|
|---|
| 448 | # 2) property value, 3) optional reference to hash of property attributes
|
|---|
| 449 | sub CaptureXMP($$$;$)
|
|---|
| 450 | {
|
|---|
| 451 | my ($exifTool, $propList, $val, $attrs) = @_;
|
|---|
| 452 | return unless defined $val and @$propList > 2;
|
|---|
| 453 | if ($$propList[0] =~ /^x:x(a|m)pmeta$/ and
|
|---|
| 454 | $$propList[1] eq 'rdf:RDF' and
|
|---|
| 455 | $$propList[2] =~ /$rdfDesc( |$)/)
|
|---|
| 456 | {
|
|---|
| 457 | # no properties to save yet if this is just the description
|
|---|
| 458 | return unless @$propList > 3;
|
|---|
| 459 | # save information about this property
|
|---|
| 460 | my $capture = $exifTool->{XMP_CAPTURE};
|
|---|
| 461 | my $path = join('/', @$propList[3..$#$propList]);
|
|---|
| 462 | if (defined $$capture{$path}) {
|
|---|
| 463 | $exifTool->{XMP_ERROR} = "Duplicate XMP property: $path";
|
|---|
| 464 | } else {
|
|---|
| 465 | $$capture{$path} = [$val, $attrs || { }];
|
|---|
| 466 | }
|
|---|
| 467 | } else {
|
|---|
| 468 | $exifTool->{XMP_ERROR} = 'Improperly enclosed XMP property: ' . join('/',@$propList);
|
|---|
| 469 | }
|
|---|
| 470 | }
|
|---|
| 471 |
|
|---|
| 472 | #------------------------------------------------------------------------------
|
|---|
| 473 | # Save information about resource containing blank node with nodeID
|
|---|
| 474 | # Inputs: 0) reference to blank node information hash
|
|---|
| 475 | # 1) reference to property list
|
|---|
| 476 | # 2) property value
|
|---|
| 477 | # 3) [optional] reference to attribute hash
|
|---|
| 478 | # Notes: This routine and ProcessBlankInfo() are also used for reading information, but
|
|---|
| 479 | # are uncommon so are put in this file to reduce compile time for the common case
|
|---|
| 480 | sub SaveBlankInfo($$$;$)
|
|---|
| 481 | {
|
|---|
| 482 | my ($blankInfo, $propListPt, $val, $attrs) = @_;
|
|---|
| 483 |
|
|---|
| 484 | my $propPath = join '/', @$propListPt;
|
|---|
| 485 | my @ids = ($propPath =~ m{ #([^ /]*)}g);
|
|---|
| 486 | my $id;
|
|---|
| 487 | # split the property path at each nodeID
|
|---|
| 488 | foreach $id (@ids) {
|
|---|
| 489 | my ($pre, $prop, $post) = ($propPath =~ m{^(.*?)/([^/]*) #$id((/.*)?)$});
|
|---|
| 490 | defined $pre or warn("internal error parsing nodeID's"), next;
|
|---|
| 491 | # the element with the nodeID should be in the path prefix for subject
|
|---|
| 492 | # nodes and the path suffix for object nodes
|
|---|
| 493 | unless ($prop eq $rdfDesc) {
|
|---|
| 494 | if ($post) {
|
|---|
| 495 | $post = "/$prop$post";
|
|---|
| 496 | } else {
|
|---|
| 497 | $pre = "$pre/$prop";
|
|---|
| 498 | }
|
|---|
| 499 | }
|
|---|
| 500 | $blankInfo->{Prop}->{$id}->{Pre}->{$pre} = 1;
|
|---|
| 501 | if ((defined $post and length $post) or (defined $val and length $val)) {
|
|---|
| 502 | # save the property value and attributes for each unique path suffix
|
|---|
| 503 | $blankInfo->{Prop}->{$id}->{Post}->{$post} = [ $val, $attrs, $propPath ];
|
|---|
| 504 | }
|
|---|
| 505 | }
|
|---|
| 506 | }
|
|---|
| 507 |
|
|---|
| 508 | #------------------------------------------------------------------------------
|
|---|
| 509 | # Process blank-node information
|
|---|
| 510 | # Inputs: 0) ExifTool object ref, 1) tag table ref,
|
|---|
| 511 | # 2) blank node information hash ref, 3) flag set for writing
|
|---|
| 512 | sub ProcessBlankInfo($$$;$)
|
|---|
| 513 | {
|
|---|
| 514 | my ($exifTool, $tagTablePtr, $blankInfo, $isWriting) = @_;
|
|---|
| 515 | $exifTool->VPrint(1, " [Elements with nodeID set:]\n") unless $isWriting;
|
|---|
| 516 | my ($id, $pre, $post);
|
|---|
| 517 | # handle each nodeID separately
|
|---|
| 518 | foreach $id (sort keys %{$$blankInfo{Prop}}) {
|
|---|
| 519 | my $path = $blankInfo->{Prop}->{$id};
|
|---|
| 520 | # flag all resource names so we can warn later if some are unused
|
|---|
| 521 | my %unused;
|
|---|
| 522 | foreach $post (keys %{$path->{Post}}) {
|
|---|
| 523 | $unused{$post} = 1;
|
|---|
| 524 | }
|
|---|
| 525 | # combine property paths for all possible paths through this node
|
|---|
| 526 | foreach $pre (sort keys %{$path->{Pre}}) {
|
|---|
| 527 | # there will be no description for the object of a blank node
|
|---|
| 528 | next unless $pre =~ m{/$rdfDesc/};
|
|---|
| 529 | foreach $post (sort keys %{$path->{Post}}) {
|
|---|
| 530 | my @propList = split m{/}, "$pre$post";
|
|---|
| 531 | my ($val, $attrs) = @{$path->{Post}->{$post}};
|
|---|
| 532 | if ($isWriting) {
|
|---|
| 533 | CaptureXMP($exifTool, \@propList, $val, $attrs);
|
|---|
| 534 | } else {
|
|---|
| 535 | FoundXMP($exifTool, $tagTablePtr, \@propList, $val);
|
|---|
| 536 | }
|
|---|
| 537 | delete $unused{$post};
|
|---|
| 538 | }
|
|---|
| 539 | }
|
|---|
| 540 | # save information from unused properties (if RDF is malformed like f-spot output)
|
|---|
| 541 | if (%unused) {
|
|---|
| 542 | $exifTool->Options('Verbose') and $exifTool->Warn('An XMP resource is about nothing');
|
|---|
| 543 | foreach $post (sort keys %unused) {
|
|---|
| 544 | my ($val, $attrs, $propPath) = @{$path->{Post}->{$post}};
|
|---|
| 545 | my @propList = split m{/}, $propPath;
|
|---|
| 546 | if ($isWriting) {
|
|---|
| 547 | CaptureXMP($exifTool, \@propList, $val, $attrs);
|
|---|
| 548 | } else {
|
|---|
| 549 | FoundXMP($exifTool, $tagTablePtr, \@propList, $val);
|
|---|
| 550 | }
|
|---|
| 551 | }
|
|---|
| 552 | }
|
|---|
| 553 | }
|
|---|
| 554 | }
|
|---|
| 555 |
|
|---|
| 556 | #------------------------------------------------------------------------------
|
|---|
| 557 | # Convert path to namespace used in file (this is a pain, but the XMP
|
|---|
| 558 | # spec only suggests 'preferred' namespace prefixes...)
|
|---|
| 559 | # Inputs: 0) ExifTool object reference, 1) property path
|
|---|
| 560 | # Returns: conforming property path
|
|---|
| 561 | sub ConformPathToNamespace($$)
|
|---|
| 562 | {
|
|---|
| 563 | my ($exifTool, $path) = @_;
|
|---|
| 564 | my @propList = split('/',$path);
|
|---|
| 565 | my ($prop, $newKey);
|
|---|
| 566 | my $nsUsed = $exifTool->{XMP_NS};
|
|---|
| 567 | foreach $prop (@propList) {
|
|---|
| 568 | my ($ns, $tag) = $prop =~ /(.+?):(.*)/;
|
|---|
| 569 | next if $$nsUsed{$ns};
|
|---|
| 570 | my $uri = $nsURI{$ns};
|
|---|
| 571 | unless ($uri) {
|
|---|
| 572 | warn "No URI for namepace prefix $ns!\n";
|
|---|
| 573 | next;
|
|---|
| 574 | }
|
|---|
| 575 | my $ns2;
|
|---|
| 576 | foreach $ns2 (keys %$nsUsed) {
|
|---|
| 577 | next unless $$nsUsed{$ns2} eq $uri;
|
|---|
| 578 | # use the existing namespace prefix instead of ours
|
|---|
| 579 | $prop = "$ns2:$tag";
|
|---|
| 580 | last;
|
|---|
| 581 | }
|
|---|
| 582 | }
|
|---|
| 583 | return join('/',@propList);
|
|---|
| 584 | }
|
|---|
| 585 |
|
|---|
| 586 | #------------------------------------------------------------------------------
|
|---|
| 587 | # sort tagInfo hash references by tag name
|
|---|
| 588 | sub ByTagName
|
|---|
| 589 | {
|
|---|
| 590 | return $$a{Name} cmp $$b{Name};
|
|---|
| 591 | }
|
|---|
| 592 |
|
|---|
| 593 | #------------------------------------------------------------------------------
|
|---|
| 594 | # Write XMP information
|
|---|
| 595 | # Inputs: 0) ExifTool object reference, 1) source dirInfo reference,
|
|---|
| 596 | # 2) [optional] tag table reference
|
|---|
| 597 | # Returns: with tag table: new XMP data (may be empty if no XMP data) or undef on error
|
|---|
| 598 | # without tag table: 1 on success, 0 if not valid XMP file, -1 on write error
|
|---|
| 599 | # Notes: May set dirInfo InPlace flag to rewrite with specified DirLen
|
|---|
| 600 | # May set dirInfo ReadOnly flag to write as read-only XMP ('r' mode and no padding)
|
|---|
| 601 | sub WriteXMP($$;$)
|
|---|
| 602 | {
|
|---|
| 603 | my ($exifTool, $dirInfo, $tagTablePtr) = @_;
|
|---|
| 604 | $exifTool or return 1; # allow dummy access to autoload this package
|
|---|
| 605 | my $dataPt = $$dirInfo{DataPt};
|
|---|
| 606 | my $dirStart = $$dirInfo{DirStart} || 0;
|
|---|
| 607 | my (%capture, %nsUsed, $xmpErr, $uuid);
|
|---|
| 608 | my $changed = 0;
|
|---|
| 609 | my $xmpFile = (not $tagTablePtr); # this is an XMP data file if no $tagTablePtr
|
|---|
| 610 | my $preferred = $xmpFile; # write XMP as preferred if this is an XMP file
|
|---|
| 611 | my $verbose = $exifTool->Options('Verbose');
|
|---|
| 612 | #
|
|---|
| 613 | # extract existing XMP information into %capture hash
|
|---|
| 614 | #
|
|---|
| 615 | # define hash in ExifTool object to capture XMP information (also causes
|
|---|
| 616 | # CaptureXMP() instead of FoundXMP() to be called from ParseXMPElement())
|
|---|
| 617 | #
|
|---|
| 618 | # The %capture hash is keyed on the complete property path beginning after
|
|---|
| 619 | # rdf:RDF/rdf:Description/. The values are array references with the
|
|---|
| 620 | # following entries: 0) value, 1) attribute hash reference.
|
|---|
| 621 | $exifTool->{XMP_CAPTURE} = \%capture;
|
|---|
| 622 | $exifTool->{XMP_NS} = \%nsUsed;
|
|---|
| 623 |
|
|---|
| 624 | if ($dataPt or $xmpFile) {
|
|---|
| 625 | delete $exifTool->{XMP_ERROR};
|
|---|
| 626 | delete $exifTool->{XMP_UUID};
|
|---|
| 627 | # extract all existing XMP information (to the XMP_CAPTURE hash)
|
|---|
| 628 | my $success = ProcessXMP($exifTool, $dirInfo, $tagTablePtr);
|
|---|
| 629 | # don't continue if there is nothing to parse or if we had a parsing error
|
|---|
| 630 | unless ($success and not $exifTool->{XMP_ERROR}) {
|
|---|
| 631 | my $err = $exifTool->{XMP_ERROR} || 'Error parsing XMP';
|
|---|
| 632 | # may ignore this error only if we were successful
|
|---|
| 633 | if ($xmpFile) {
|
|---|
| 634 | my $raf = $$dirInfo{RAF};
|
|---|
| 635 | # allow empty XMP data so we can create something from nothing
|
|---|
| 636 | if ($success or not $raf->Seek(0,2) or $raf->Tell()) {
|
|---|
| 637 | # no error message if not an XMP file
|
|---|
| 638 | return 0 unless $exifTool->{XMP_ERROR};
|
|---|
| 639 | if ($exifTool->Error($err, $success)) {
|
|---|
| 640 | delete $exifTool->{XMP_CAPTURE};
|
|---|
| 641 | return 0;
|
|---|
| 642 | }
|
|---|
| 643 | }
|
|---|
| 644 | } else {
|
|---|
| 645 | if ($exifTool->Warn($err, $success)) {
|
|---|
| 646 | delete $exifTool->{XMP_CAPTURE};
|
|---|
| 647 | return undef;
|
|---|
| 648 | }
|
|---|
| 649 | }
|
|---|
| 650 | }
|
|---|
| 651 | $uuid = $exifTool->{XMP_UUID} || '';
|
|---|
| 652 | delete $exifTool->{XMP_ERROR};
|
|---|
| 653 | delete $exifTool->{XMP_UUID};
|
|---|
| 654 | } else {
|
|---|
| 655 | $uuid = '';
|
|---|
| 656 | }
|
|---|
| 657 | #
|
|---|
| 658 | # add, delete or change information as specified
|
|---|
| 659 | #
|
|---|
| 660 | # get hash of all information we want to change
|
|---|
| 661 | # (sorted by tag name so alternate languages come last)
|
|---|
| 662 | my @tagInfoList = sort ByTagName $exifTool->GetNewTagInfoList();
|
|---|
| 663 | my $tagInfo;
|
|---|
| 664 | foreach $tagInfo (@tagInfoList) {
|
|---|
| 665 | next unless $exifTool->GetGroup($tagInfo, 0) eq 'XMP';
|
|---|
| 666 | my $tag = $tagInfo->{TagID};
|
|---|
| 667 | my $path = GetPropertyPath($tagInfo);
|
|---|
| 668 | unless ($path) {
|
|---|
| 669 | $exifTool->Warn("Can't write XMP:$tag (namespace unknown)");
|
|---|
| 670 | next;
|
|---|
| 671 | }
|
|---|
| 672 | # change our property path namespace prefixes to conform
|
|---|
| 673 | # to the ones used in this file
|
|---|
| 674 | $path = ConformPathToNamespace($exifTool, $path);
|
|---|
| 675 | # find existing property
|
|---|
| 676 | my $capList = $capture{$path};
|
|---|
| 677 | # MicrosoftPhoto screws up the case of some tags, so test for this
|
|---|
| 678 | unless ($capList) {
|
|---|
| 679 | my ($path2) = grep /^\Q$path\E$/i, keys %capture;
|
|---|
| 680 | $path2 and $capList = $capture{$path = $path2};
|
|---|
| 681 | }
|
|---|
| 682 | my $newValueHash = $exifTool->GetNewValueHash($tagInfo);
|
|---|
| 683 | my $overwrite = Image::ExifTool::IsOverwriting($newValueHash);
|
|---|
| 684 | my $writable = $$tagInfo{Writable} || '';
|
|---|
| 685 | my (%attrs, $deleted, $added);
|
|---|
| 686 | # delete existing entry if necessary
|
|---|
| 687 | if ($capList) {
|
|---|
| 688 | # take attributes from old values if they exist
|
|---|
| 689 | %attrs = %{$capList->[1]};
|
|---|
| 690 | if ($overwrite) {
|
|---|
| 691 | my ($delPath, @matchingPaths, $oldLang, $delLang);
|
|---|
| 692 | # check to see if this is an indexed list item
|
|---|
| 693 | if ($path =~ / /) {
|
|---|
| 694 | my $pathPattern;
|
|---|
| 695 | ($pathPattern = $path) =~ s/ 000/ \\d\{3\}/g;
|
|---|
| 696 | @matchingPaths = sort grep(/^$pathPattern$/, keys %capture);
|
|---|
| 697 | } else {
|
|---|
| 698 | push @matchingPaths, $path;
|
|---|
| 699 | }
|
|---|
| 700 | foreach $path (@matchingPaths) {
|
|---|
| 701 | my ($val, $attrs) = @{$capture{$path}};
|
|---|
| 702 | if ($overwrite < 0) {
|
|---|
| 703 | # only overwrite specific values
|
|---|
| 704 | next unless Image::ExifTool::IsOverwriting($newValueHash, $val);
|
|---|
| 705 | }
|
|---|
| 706 | if ($writable eq 'lang-alt') {
|
|---|
| 707 | # get original language code (lc for comparisons)
|
|---|
| 708 | $oldLang = lc($$attrs{'xml:lang'} || 'x-default');
|
|---|
| 709 | # delete all if deleting "x-default" or writing with no LangCode
|
|---|
| 710 | # (XMP spec requires x-default language exist and be first in list)
|
|---|
| 711 | if ($oldLang eq 'x-default' and not ($newValueHash->{Value} or
|
|---|
| 712 | ($$tagInfo{LangCode} and $$tagInfo{LangCode} ne 'x-default')))
|
|---|
| 713 | {
|
|---|
| 714 | $delLang = 1; # delete all languages
|
|---|
| 715 | $overwrite = 1; # force overwrite
|
|---|
| 716 | }
|
|---|
| 717 | if ($$tagInfo{LangCode} and not $delLang) {
|
|---|
| 718 | # only overwrite specified language
|
|---|
| 719 | next unless lc($$tagInfo{LangCode}) eq $oldLang;
|
|---|
| 720 | }
|
|---|
| 721 | }
|
|---|
| 722 | if ($verbose > 1) {
|
|---|
| 723 | my $grp = $exifTool->GetGroup($tagInfo, 1);
|
|---|
| 724 | my $tagName = $$tagInfo{Name};
|
|---|
| 725 | $tagName =~ s/-$$tagInfo{LangCode}$// if $$tagInfo{LangCode};
|
|---|
| 726 | $tagName .= '-' . $$attrs{'xml:lang'} if $$attrs{'xml:lang'};
|
|---|
| 727 | $exifTool->VPrint(1, " - $grp:$tagName = '$val'\n");
|
|---|
| 728 | }
|
|---|
| 729 | # save attributes and path from first deleted property
|
|---|
| 730 | # so we can replace it exactly
|
|---|
| 731 | unless ($delPath) {
|
|---|
| 732 | %attrs = %$attrs;
|
|---|
| 733 | $delPath = $path;
|
|---|
| 734 | }
|
|---|
| 735 | delete $capture{$path};
|
|---|
| 736 | ++$changed;
|
|---|
| 737 | }
|
|---|
| 738 | next unless $delPath or $$tagInfo{List} or $oldLang;
|
|---|
| 739 | if ($delPath) {
|
|---|
| 740 | $path = $delPath;
|
|---|
| 741 | $deleted = 1;
|
|---|
| 742 | } else {
|
|---|
| 743 | # don't change tag if we couldn't delete old copy
|
|---|
| 744 | # unless this is a list or an lang-alt tag
|
|---|
| 745 | next unless $$tagInfo{List} or $oldLang;
|
|---|
| 746 | $path =~ m/ (\d{3})/g or warn "Internal error: no list index!\n", next;
|
|---|
| 747 | $added = $1;
|
|---|
| 748 | }
|
|---|
| 749 | } elsif ($path =~ m/ (\d{3})/g) {
|
|---|
| 750 | $added = $1;
|
|---|
| 751 | }
|
|---|
| 752 | if (defined $added) {
|
|---|
| 753 | # add to end of list
|
|---|
| 754 | my $pos = pos($path) - 3;
|
|---|
| 755 | for (;;) {
|
|---|
| 756 | substr($path, $pos, 3) = ++$added;
|
|---|
| 757 | last unless $capture{$path};
|
|---|
| 758 | }
|
|---|
| 759 | }
|
|---|
| 760 | }
|
|---|
| 761 | # check to see if we want to create this tag
|
|---|
| 762 | # (create non-avoided tags in XMP data files by default)
|
|---|
| 763 | my $isCreating = (Image::ExifTool::IsCreating($newValueHash) or
|
|---|
| 764 | ($preferred and not $$tagInfo{Avoid} and
|
|---|
| 765 | not defined $$newValueHash{Shift}));
|
|---|
| 766 |
|
|---|
| 767 | # don't add new values unless...
|
|---|
| 768 | # ...tag existed before and was deleted, or we added it to a list
|
|---|
| 769 | next unless $deleted or defined $added or
|
|---|
| 770 | # ...tag didn't exist before and we are creating it
|
|---|
| 771 | (not $capList and $isCreating);
|
|---|
| 772 |
|
|---|
| 773 | # get list of new values (all done if no new values specified)
|
|---|
| 774 | my @newValues = Image::ExifTool::GetNewValues($newValueHash) or next;
|
|---|
| 775 |
|
|---|
| 776 | # set language attribute for lang-alt lists
|
|---|
| 777 | if ($writable eq 'lang-alt') {
|
|---|
| 778 | $attrs{'xml:lang'} = $$tagInfo{LangCode} || 'x-default';
|
|---|
| 779 | # must generate x-default entry as first entry if it didn't exist
|
|---|
| 780 | unless ($capList or lc($attrs{'xml:lang'}) eq 'x-default') {
|
|---|
| 781 | my $newValue = EscapeXML($newValues[0]);
|
|---|
| 782 | $capture{$path} = [ $newValue, { %attrs, 'xml:lang' => 'x-default' } ];
|
|---|
| 783 | if ($verbose > 1) {
|
|---|
| 784 | my $tagName = $$tagInfo{Name};
|
|---|
| 785 | $tagName =~ s/-$$tagInfo{LangCode}$/-x-default/;
|
|---|
| 786 | my $grp = $exifTool->GetGroup($tagInfo, 1);
|
|---|
| 787 | $exifTool->VPrint(1, " + $grp:$tagName = '$newValue'\n");
|
|---|
| 788 | }
|
|---|
| 789 | $path =~ s/ 000/ 001/ or warn "Internal error: no list index!\n", next;
|
|---|
| 790 | }
|
|---|
| 791 | }
|
|---|
| 792 |
|
|---|
| 793 | # add new value(s) to %capture hash
|
|---|
| 794 | for (;;) {
|
|---|
| 795 | my $newValue = EscapeXML(shift @newValues);
|
|---|
| 796 | $capture{$path} = [ $newValue, \%attrs ];
|
|---|
| 797 | if ($verbose > 1) {
|
|---|
| 798 | my $grp = $exifTool->GetGroup($tagInfo, 1);
|
|---|
| 799 | $exifTool->VPrint(1, " + $grp:$$tagInfo{Name} = '$newValue'\n");
|
|---|
| 800 | }
|
|---|
| 801 | ++$changed;
|
|---|
| 802 | last unless @newValues;
|
|---|
| 803 | $path =~ m/ (\d{3})/g or warn("Internal error: no list index!\n"), next;
|
|---|
| 804 | my $listIndex = $1;
|
|---|
| 805 | my $pos = pos($path) - 3;
|
|---|
| 806 | for (;;) {
|
|---|
| 807 | substr($path, $pos, 3) = ++$listIndex;
|
|---|
| 808 | last unless $capture{$path};
|
|---|
| 809 | }
|
|---|
| 810 | $capture{$path} and warn("Too many entries in XMP list!\n"), next;
|
|---|
| 811 | }
|
|---|
| 812 | }
|
|---|
| 813 | # remove the ExifTool members we created
|
|---|
| 814 | delete $exifTool->{XMP_CAPTURE};
|
|---|
| 815 | delete $exifTool->{XMP_NS};
|
|---|
| 816 |
|
|---|
| 817 | # return now if we didn't change anything
|
|---|
| 818 | unless ($changed) {
|
|---|
| 819 | return undef unless $xmpFile; # just rewrite original XMP
|
|---|
| 820 | # get DataPt again because it may have been set by ProcessXMP
|
|---|
| 821 | $dataPt = $$dirInfo{DataPt};
|
|---|
| 822 | unless (defined $dataPt) {
|
|---|
| 823 | $exifTool->Error("Nothing to write");
|
|---|
| 824 | return 1;
|
|---|
| 825 | }
|
|---|
| 826 | return 1 if Write($$dirInfo{OutFile}, $$dataPt);
|
|---|
| 827 | return -1;
|
|---|
| 828 | }
|
|---|
| 829 | #
|
|---|
| 830 | # write out the new XMP information
|
|---|
| 831 | #
|
|---|
| 832 | # start writing the XMP data
|
|---|
| 833 | my $newData = '';
|
|---|
| 834 | if ($$exifTool{XMP_NO_XPACKET}) {
|
|---|
| 835 | # write BOM if flag is set
|
|---|
| 836 | $newData .= "\xef\xbb\xbf" if $$exifTool{XMP_NO_XPACKET} == 2;
|
|---|
| 837 | } else {
|
|---|
| 838 | $newData .= $pktOpen;
|
|---|
| 839 | }
|
|---|
| 840 | $newData .= $xmlOpen if $$exifTool{XMP_IS_XML};
|
|---|
| 841 | $newData .= $xmpOpen . $rdfOpen;
|
|---|
| 842 |
|
|---|
| 843 | # initialize current property path list
|
|---|
| 844 | my @curPropList;
|
|---|
| 845 | my (%nsCur, $prop, $n);
|
|---|
| 846 | my @pathList = sort keys %capture;
|
|---|
| 847 |
|
|---|
| 848 | while (@pathList) {
|
|---|
| 849 | my $path = shift @pathList;
|
|---|
| 850 | my @propList = split('/',$path); # get property list
|
|---|
| 851 | # must open/close rdf:Description too
|
|---|
| 852 | unshift @propList, $rdfDesc;
|
|---|
| 853 | # make sure we have defined all necessary namespaces
|
|---|
| 854 | my (%nsNew, $newDesc);
|
|---|
| 855 | foreach $prop (@propList) {
|
|---|
| 856 | $prop =~ /(.*):/ or next;
|
|---|
| 857 | $1 eq 'rdf' and next; # rdf namespace already defined
|
|---|
| 858 | my $nsNew = $nsUsed{$1};
|
|---|
| 859 | unless ($nsNew) {
|
|---|
| 860 | $nsNew = $nsURI{$1}; # we must have added a namespace
|
|---|
| 861 | unless ($nsNew) {
|
|---|
| 862 | $xmpErr = "Undefined XMP namespace: $1";
|
|---|
| 863 | next;
|
|---|
| 864 | }
|
|---|
| 865 | }
|
|---|
| 866 | $nsNew{$1} = $nsNew;
|
|---|
| 867 | # need a new description if any new namespaces
|
|---|
| 868 | $newDesc = 1 unless $nsCur{$1};
|
|---|
| 869 | }
|
|---|
| 870 | my $closeTo = 0;
|
|---|
| 871 | if ($newDesc) {
|
|---|
| 872 | # look forward to see if we will want to also open other namespaces
|
|---|
| 873 | # (this is necessary to keep lists from being broken if a property
|
|---|
| 874 | # introduces a new namespace; plus it improves formatting)
|
|---|
| 875 | my ($path2, $ns2);
|
|---|
| 876 | foreach $path2 (@pathList) {
|
|---|
| 877 | my @ns2s = ($path2 =~ m{(?:^|/)([^/]+?):}g);
|
|---|
| 878 | my $opening = 0;
|
|---|
| 879 | foreach $ns2 (@ns2s) {
|
|---|
| 880 | next if $ns2 eq 'rdf';
|
|---|
| 881 | $nsNew{$ns2} and ++$opening, next;
|
|---|
| 882 | last unless $opening and $nsURI{$ns2};
|
|---|
| 883 | # also open this namespace
|
|---|
| 884 | $nsNew{$ns2} = $nsURI{$ns2};
|
|---|
| 885 | }
|
|---|
| 886 | last unless $opening;
|
|---|
| 887 | }
|
|---|
| 888 | } else {
|
|---|
| 889 | # find first property where the current path differs from the new path
|
|---|
| 890 | for ($closeTo=0; $closeTo<@curPropList; ++$closeTo) {
|
|---|
| 891 | last unless $closeTo < @propList;
|
|---|
| 892 | last unless $propList[$closeTo] eq $curPropList[$closeTo];
|
|---|
| 893 | }
|
|---|
| 894 | }
|
|---|
| 895 | # close out properties down to the common base path
|
|---|
| 896 | while (@curPropList > $closeTo) {
|
|---|
| 897 | ($prop = pop @curPropList) =~ s/ .*//;
|
|---|
| 898 | $newData .= (' ' x scalar(@curPropList)) . " </$prop>\n";
|
|---|
| 899 | }
|
|---|
| 900 | if ($newDesc) {
|
|---|
| 901 | # open the new description
|
|---|
| 902 | $prop = $rdfDesc;
|
|---|
| 903 | %nsCur = %nsNew; # save current namespaces
|
|---|
| 904 | $newData .= "\n <$prop rdf:about='$uuid'";
|
|---|
| 905 | foreach (sort keys %nsCur) {
|
|---|
| 906 | $newData .= "\n xmlns:$_='$nsCur{$_}'";
|
|---|
| 907 | }
|
|---|
| 908 | $newData .= ">\n";
|
|---|
| 909 | push @curPropList, $prop;
|
|---|
| 910 | }
|
|---|
| 911 | # loop over all values for this new property
|
|---|
| 912 | my $capList = $capture{$path};
|
|---|
| 913 | my ($val, $attrs) = @$capList;
|
|---|
| 914 | $debug and print "$path = $val\n";
|
|---|
| 915 | # open new properties
|
|---|
| 916 | my $attr;
|
|---|
| 917 | for ($n=@curPropList; $n<$#propList; ++$n) {
|
|---|
| 918 | $prop = $propList[$n];
|
|---|
| 919 | push @curPropList, $prop;
|
|---|
| 920 | # remove list index if it exists
|
|---|
| 921 | $prop =~ s/ .*//;
|
|---|
| 922 | $attr = '';
|
|---|
| 923 | if ($prop ne $rdfDesc and $propList[$n+1] !~ /^rdf:/) {
|
|---|
| 924 | # need parseType='Resource' to avoid new 'rdf:Description'
|
|---|
| 925 | $attr = " rdf:parseType='Resource'";
|
|---|
| 926 | }
|
|---|
| 927 | $newData .= (' ' x scalar(@curPropList)) . "<$prop$attr>\n";
|
|---|
| 928 | }
|
|---|
| 929 | my $prop2 = pop @propList; # get new property name
|
|---|
| 930 | $prop2 =~ s/ .*//; # remove list index if it exists
|
|---|
| 931 | $newData .= (' ' x scalar(@curPropList)) . " <$prop2";
|
|---|
| 932 | # print out attributes
|
|---|
| 933 | foreach $attr (sort keys %$attrs) {
|
|---|
| 934 | my $attrVal = $$attrs{$attr};
|
|---|
| 935 | my $quot = ($attrVal =~ /'/) ? '"' : "'";
|
|---|
| 936 | $newData .= " $attr=$quot$attrVal$quot";
|
|---|
| 937 | }
|
|---|
| 938 | $newData .= ">$val</$prop2>\n";
|
|---|
| 939 | }
|
|---|
| 940 | # close off any open elements
|
|---|
| 941 | while ($prop = pop @curPropList) {
|
|---|
| 942 | $prop =~ s/ .*//; # remove list index if it exists
|
|---|
| 943 | $newData .= (' ' x scalar(@curPropList)) . " </$prop>\n";
|
|---|
| 944 | }
|
|---|
| 945 | #
|
|---|
| 946 | # clean up, close out the XMP, and return our data
|
|---|
| 947 | #
|
|---|
| 948 | # remove the ExifTool members we created
|
|---|
| 949 | delete $exifTool->{XMP_CAPTURE};
|
|---|
| 950 | delete $exifTool->{XMP_NS};
|
|---|
| 951 |
|
|---|
| 952 | $newData .= $rdfClose . $xmpClose;
|
|---|
| 953 |
|
|---|
| 954 | # (the XMP standard recommends writing 2k-4k of white space before the
|
|---|
| 955 | # packet trailer, with a newline every 100 characters)
|
|---|
| 956 | unless ($$exifTool{XMP_NO_XPACKET}) {
|
|---|
| 957 | my $pad = (' ' x 100) . "\n";
|
|---|
| 958 | if ($$dirInfo{InPlace}) {
|
|---|
| 959 | # pad to specified DirLen
|
|---|
| 960 | my $dirLen = $$dirInfo{DirLen} || length $$dataPt;
|
|---|
| 961 | my $len = length($newData) + length($pktCloseW);
|
|---|
| 962 | if ($len > $dirLen) {
|
|---|
| 963 | $exifTool->Warn('Not enough room to edit XMP in place');
|
|---|
| 964 | return undef;
|
|---|
| 965 | }
|
|---|
| 966 | my $num = int(($dirLen - $len) / length($pad));
|
|---|
| 967 | if ($num) {
|
|---|
| 968 | $newData .= $pad x $num;
|
|---|
| 969 | $len += length($pad) * $num;
|
|---|
| 970 | }
|
|---|
| 971 | $len < $dirLen and $newData .= (' ' x ($dirLen - $len - 1)) . "\n";
|
|---|
| 972 | } elsif (not $exifTool->Options('Compact') and
|
|---|
| 973 | not $xmpFile and not $$dirInfo{ReadOnly})
|
|---|
| 974 | {
|
|---|
| 975 | $newData .= $pad x 24;
|
|---|
| 976 | }
|
|---|
| 977 | $newData .= ($$dirInfo{ReadOnly} ? $pktCloseR : $pktCloseW);
|
|---|
| 978 | }
|
|---|
| 979 | # return empty data if no properties exist
|
|---|
| 980 | $newData = '' unless %capture or $$dirInfo{InPlace};
|
|---|
| 981 |
|
|---|
| 982 | if ($xmpErr) {
|
|---|
| 983 | if ($xmpFile) {
|
|---|
| 984 | $exifTool->Error($xmpErr);
|
|---|
| 985 | return -1;
|
|---|
| 986 | }
|
|---|
| 987 | $exifTool->Warn($xmpErr);
|
|---|
| 988 | return undef;
|
|---|
| 989 | }
|
|---|
| 990 | $exifTool->{CHANGED} += $changed;
|
|---|
| 991 | $debug > 1 and $newData and print $newData,"\n";
|
|---|
| 992 | return $newData unless $xmpFile;
|
|---|
| 993 | return 1 if Write($$dirInfo{OutFile}, $newData);
|
|---|
| 994 | return -1;
|
|---|
| 995 | }
|
|---|
| 996 |
|
|---|
| 997 |
|
|---|
| 998 | 1; # end
|
|---|
| 999 |
|
|---|
| 1000 | __END__
|
|---|
| 1001 |
|
|---|
| 1002 | =head1 NAME
|
|---|
| 1003 |
|
|---|
| 1004 | Image::ExifTool::WriteXMP.pl - Write XMP meta information
|
|---|
| 1005 |
|
|---|
| 1006 | =head1 SYNOPSIS
|
|---|
| 1007 |
|
|---|
| 1008 | These routines are autoloaded by Image::ExifTool::XMP.
|
|---|
| 1009 |
|
|---|
| 1010 | =head1 DESCRIPTION
|
|---|
| 1011 |
|
|---|
| 1012 | This file contains routines to write XMP metadata.
|
|---|
| 1013 |
|
|---|
| 1014 | =head1 AUTHOR
|
|---|
| 1015 |
|
|---|
| 1016 | Copyright 2003-2007, Phil Harvey (phil at owl.phy.queensu.ca)
|
|---|
| 1017 |
|
|---|
| 1018 | This library is free software; you can redistribute it and/or modify it
|
|---|
| 1019 | under the same terms as Perl itself.
|
|---|
| 1020 |
|
|---|
| 1021 | =head1 SEE ALSO
|
|---|
| 1022 |
|
|---|
| 1023 | L<Image::ExifTool::XMP(3pm)|Image::ExifTool::XMP>,
|
|---|
| 1024 | L<Image::ExifTool(3pm)|Image::ExifTool>
|
|---|
| 1025 |
|
|---|
| 1026 | =cut
|
|---|
