1#------------------------------------------------------------------------------ 2# File: Writer.pl 3# 4# Description: ExifTool write routines 5# 6# Notes: Also contains some less used ExifTool functions 7# 8# URL: https://exiftool.org/ 9# 10# Revisions: 12/16/2004 - P. Harvey Created 11#------------------------------------------------------------------------------ 12 13package Image::ExifTool; 14 15use strict; 16 17use Image::ExifTool::TagLookup qw(FindTagInfo TagExists); 18use Image::ExifTool::Fixup; 19 20sub AssembleRational($$@); 21sub LastInList($); 22sub CreateDirectory($$); 23sub NextFreeTagKey($$); 24sub RemoveNewValueHash($$$); 25sub RemoveNewValuesForGroup($$); 26sub GetWriteGroup1($$); 27sub Sanitize($$); 28sub ConvInv($$$$$;$$); 29 30my $loadedAllTables; # flag indicating we loaded all tables 31my $advFmtSelf; # ExifTool object during evaluation of advanced formatting expr 32 33# the following is a road map of where we write each directory 34# in the different types of files. 35my %tiffMap = ( 36 IFD0 => 'TIFF', 37 IFD1 => 'IFD0', 38 XMP => 'IFD0', 39 ICC_Profile => 'IFD0', 40 ExifIFD => 'IFD0', 41 GPS => 'IFD0', 42 SubIFD => 'IFD0', 43 GlobParamIFD => 'IFD0', 44 PrintIM => 'IFD0', 45 IPTC => 'IFD0', 46 Photoshop => 'IFD0', 47 InteropIFD => 'ExifIFD', 48 MakerNotes => 'ExifIFD', 49 CanonVRD => 'MakerNotes', # (so VRDOffset will get updated) 50 NikonCapture => 'MakerNotes', # (to allow delete by group) 51 PhaseOne => 'MakerNotes', # (for editing PhaseOne SensorCalibration tags) 52); 53my %exifMap = ( 54 IFD1 => 'IFD0', 55 EXIF => 'IFD0', # to write EXIF as a block 56 ExifIFD => 'IFD0', 57 GPS => 'IFD0', 58 SubIFD => 'IFD0', 59 GlobParamIFD => 'IFD0', 60 PrintIM => 'IFD0', 61 InteropIFD => 'ExifIFD', 62 MakerNotes => 'ExifIFD', 63 NikonCapture => 'MakerNotes', # (to allow delete by group) 64 # (no CanonVRD trailer allowed) 65); 66my %jpegMap = ( 67 %exifMap, # covers all JPEG EXIF mappings 68 JFIF => 'APP0', 69 CIFF => 'APP0', 70 IFD0 => 'APP1', 71 XMP => 'APP1', 72 ICC_Profile => 'APP2', 73 FlashPix => 'APP2', 74 MPF => 'APP2', 75 Meta => 'APP3', 76 MetaIFD => 'Meta', 77 RMETA => 'APP5', 78 Ducky => 'APP12', 79 Photoshop => 'APP13', 80 Adobe => 'APP14', 81 IPTC => 'Photoshop', 82 MakerNotes => ['ExifIFD', 'CIFF'], # (first parent is the default) 83 CanonVRD => 'MakerNotes', # (so VRDOffset will get updated) 84 NikonCapture => 'MakerNotes', # (to allow delete by group) 85 Comment => 'COM', 86); 87my %dirMap = ( 88 JPEG => \%jpegMap, 89 EXV => \%jpegMap, 90 TIFF => \%tiffMap, 91 ORF => \%tiffMap, 92 RAW => \%tiffMap, 93 EXIF => \%exifMap, 94); 95 96# module names and write functions for each writable file type 97# (defaults to "$type" and "Process$type" if not defined) 98# - types that are handled specially will not appear in this list 99my %writableType = ( 100 CRW => [ 'CanonRaw', 'WriteCRW' ], 101 DR4 => 'CanonVRD', 102 EPS => [ 'PostScript', 'WritePS' ], 103 FLIF=> [ undef, 'WriteFLIF'], 104 GIF => undef, 105 ICC => [ 'ICC_Profile', 'WriteICC' ], 106 IND => 'InDesign', 107 JP2 => 'Jpeg2000', 108 JXL => 'Jpeg2000', 109 MIE => undef, 110 MOV => [ 'QuickTime', 'WriteMOV' ], 111 MRW => 'MinoltaRaw', 112 PDF => [ undef, 'WritePDF' ], 113 PNG => undef, 114 PPM => undef, 115 PS => [ 'PostScript', 'WritePS' ], 116 PSD => 'Photoshop', 117 RAF => [ 'FujiFilm', 'WriteRAF' ], 118 VRD => 'CanonVRD', 119 X3F => 'SigmaRaw', 120 XMP => [ undef, 'WriteXMP' ], 121); 122 123# RAW file types 124my %rawType = ( 125 '3FR'=> 1, CR3 => 1, IIQ => 1, NEF => 1, RW2 => 1, 126 ARQ => 1, CRW => 1, K25 => 1, NRW => 1, RWL => 1, 127 ARW => 1, DCR => 1, KDC => 1, ORF => 1, SR2 => 1, 128 ARW => 1, ERF => 1, MEF => 1, PEF => 1, SRF => 1, 129 CR2 => 1, FFF => 1, MOS => 1, RAW => 1, SRW => 1, 130); 131 132# groups we are allowed to delete 133# Notes: 134# 1) these names must either exist in %dirMap, or be translated in InitWriteDirs()) 135# 2) any dependencies must be added to %excludeGroups 136my @delGroups = qw( 137 Adobe AFCP APP0 APP1 APP2 APP3 APP4 APP5 APP6 APP7 APP8 APP9 APP10 APP11 138 APP12 APP13 APP14 APP15 CanonVRD CIFF Ducky EXIF ExifIFD File FlashPix 139 FotoStation GlobParamIFD GPS ICC_Profile IFD0 IFD1 Insta360 InteropIFD 140 IPTC ItemList JFIF Jpeg2000 Keys MakerNotes Meta MetaIFD Microsoft MIE 141 MPF NikonCapture PDF PDF-update PhotoMechanic Photoshop PNG PNG-pHYs 142 PrintIM QuickTime RMETA RSRC SubIFD Trailer UserData XML XML-* XMP XMP-* 143); 144# family 2 group names that we can delete 145my @delGroup2 = qw( 146 Audio Author Camera Document ExifTool Image Location Other Preview Printing 147 Time Video 148); 149# Extra groups to delete when deleting another group 150my %delMore = ( 151 QuickTime => [ qw(ItemList UserData Keys) ], 152 XMP => [ 'XMP-*' ], 153 XML => [ 'XML-*' ], 154); 155 156# family 0 groups where directories should never be deleted 157my %permanentDir = ( QuickTime => 1 ); 158 159# lookup for all valid family 2 groups (lower case) 160my %family2groups = map { lc $_ => 1 } @delGroup2, 'Unknown'; 161 162# groups we don't delete when deleting all information 163my $protectedGroups = '(IFD1|SubIFD|InteropIFD|GlobParamIFD|PDF-update|Adobe)'; 164 165# other group names of new tag values to remove when deleting an entire group 166my %removeGroups = ( 167 IFD0 => [ 'EXIF', 'MakerNotes' ], 168 EXIF => [ 'MakerNotes' ], 169 ExifIFD => [ 'MakerNotes', 'InteropIFD' ], 170 Trailer => [ 'CanonVRD' ], #(because we can add back CanonVRD as a block) 171); 172# related family 0/1 groups in @delGroups (and not already in %jpegMap) 173# that must be removed from delete list when excluding a group 174my %excludeGroups = ( 175 EXIF => [ qw(IFD0 IFD1 ExifIFD GPS MakerNotes GlobParamIFD InteropIFD PrintIM SubIFD) ], 176 IFD0 => [ 'EXIF' ], 177 IFD1 => [ 'EXIF' ], 178 ExifIFD => [ 'EXIF' ], 179 GPS => [ 'EXIF' ], 180 MakerNotes => [ 'EXIF' ], 181 InteropIFD => [ 'EXIF' ], 182 GlobParamIFD => [ 'EXIF' ], 183 PrintIM => [ 'EXIF' ], 184 CIFF => [ 'MakerNotes' ], 185 # technically correct, but very uncommon and not a good reason to avoid deleting trailer 186 # IPTC => [ qw(AFCP FotoStation Trailer) ], 187 AFCP => [ 'Trailer' ], 188 FotoStation => [ 'Trailer' ], 189 CanonVRD => [ 'Trailer' ], 190 PhotoMechanic=> [ 'Trailer' ], 191 MIE => [ 'Trailer' ], 192 QuickTime => [ qw(ItemList UserData Keys) ], 193); 194# translate (lower case) wanted group when writing for tags where group name may change 195my %translateWantGroup = ( 196 ciff => 'canonraw', 197); 198# group names to translate for writing 199my %translateWriteGroup = ( 200 EXIF => 'ExifIFD', 201 Meta => 'MetaIFD', 202 File => 'Comment', 203 # any entry in this table causes the write group to be set from the 204 # tag information instead of whatever the user specified... 205 MIE => 'MIE', 206 APP14 => 'APP14', 207); 208# names of valid EXIF and Meta directories (lower case keys): 209my %exifDirs = ( 210 gps => 'GPS', 211 exififd => 'ExifIFD', 212 subifd => 'SubIFD', 213 globparamifd => 'GlobParamIFD', 214 interopifd => 'InteropIFD', 215 previewifd => 'PreviewIFD', # (in MakerNotes) 216 metaifd => 'MetaIFD', # Kodak APP3 Meta 217 makernotes => 'MakerNotes', 218); 219# valid family 0 groups when WriteGroup is set to "All" 220my %allFam0 = ( 221 exif => 1, 222 makernotes => 1, 223); 224 225my @writableMacOSTags = qw( 226 FileCreateDate MDItemFinderComment MDItemFSCreationDate MDItemFSLabel MDItemUserTags 227 XAttrQuarantine 228); 229 230# min/max values for integer formats 231my %intRange = ( 232 'int8u' => [0, 0xff], 233 'int8s' => [-0x80, 0x7f], 234 'int16u' => [0, 0xffff], 235 'int16uRev' => [0, 0xffff], 236 'int16s' => [-0x8000, 0x7fff], 237 'int32u' => [0, 0xffffffff], 238 'int32s' => [-0x80000000, 0x7fffffff], 239 'int64u' => [0, 18446744073709551615], 240 'int64s' => [-9223372036854775808, 9223372036854775807], 241); 242# lookup for file types with block-writable EXIF 243my %blockExifTypes = map { $_ => 1 } qw(JPEG PNG JP2 MIE EXIF FLIF MOV MP4); 244 245my $maxSegmentLen = 0xfffd; # maximum length of data in a JPEG segment 246my $maxXMPLen = $maxSegmentLen; # maximum length of XMP data in JPEG 247 248# value separators when conversion list is used (in SetNewValue) 249my %listSep = ( PrintConv => '; ?', ValueConv => ' ' ); 250 251# printConv hash keys to ignore when doing reverse lookup 252my %ignorePrintConv = map { $_ => 1 } qw(OTHER BITMASK Notes); 253 254#------------------------------------------------------------------------------ 255# Set tag value 256# Inputs: 0) ExifTool object reference 257# 1) tag key, tag name, or '*' (optionally prefixed by group name), 258# or undef to reset all previous SetNewValue() calls 259# 2) new value (scalar, scalar ref or list ref), or undef to delete tag 260# 3-N) Options: 261# Type => PrintConv, ValueConv or Raw - specifies value type 262# AddValue => true to add to list of existing values instead of overwriting 263# DelValue => true to delete this existing value value from a list, or 264# or doing a conditional delete, or to shift a time value 265# Group => family 0 or 1 group name (case insensitive) 266# Replace => 0, 1 or 2 - overwrite previous new values (2=reset) 267# Protected => bitmask to write tags with specified protections 268# EditOnly => true to only edit existing tags (don't create new tag) 269# EditGroup => true to only edit existing groups (don't create new group) 270# Shift => undef, 0, +1 or -1 - shift value if possible 271# NoFlat => treat flattened tags as 'unsafe' 272# NoShortcut => true to prevent looking up shortcut tags 273# ProtectSaved => protect existing new values with a save count greater than this 274# IgnorePermanent => ignore attempts to delete a permanent tag 275# CreateGroups => [internal use] createGroups hash ref from related tags 276# ListOnly => [internal use] set only list or non-list tags 277# SetTags => [internal use] hash ref to return tagInfo refs of set tags 278# Sanitized => [internal use] set to avoid double-sanitizing the value 279# Returns: number of tags set (plus error string in list context) 280# Notes: For tag lists (like Keywords), call repeatedly with the same tag name for 281# each value in the list. Internally, the new information is stored in 282# the following members of the $$self{NEW_VALUE}{$tagInfo} hash: 283# TagInfo - tag info ref 284# DelValue - list ref for raw values to delete 285# Value - list ref for raw values to add (not defined if deleting the tag) 286# IsCreating - must be set for the tag to be added for the standard file types, 287# otherwise just changed if it already exists. This may be 288# overridden for file types with a PREFERRED metadata type. 289# Set to 2 to create individual tags but not new groups 290# EditOnly - flag set if tag should never be created (regardless of file type). 291# If this is set, then IsCreating must be false 292# CreateOnly - flag set if creating only (never edit existing tag) 293# CreateGroups - hash of all family 0 group names where tag may be created 294# WriteGroup - group name where information is being written (correct case) 295# WantGroup - group name as specified in call to function (case insensitive) 296# Next - pointer to next new value hash (if more than one) 297# NoReplace - set if value was created with Replace=0 298# AddBefore - number of list items added by a subsequent Replace=0 call 299# IsNVH - Flag indicating this is a new value hash 300# Shift - shift value 301# Save - counter used by SaveNewValues()/RestoreNewValues() 302# MAKER_NOTE_FIXUP - pointer to fixup if necessary for a maker note value 303sub SetNewValue($;$$%) 304{ 305 local $_; 306 my ($self, $tag, $value, %options) = @_; 307 my ($err, $tagInfo, $family); 308 my $verbose = $$self{OPTIONS}{Verbose}; 309 my $out = $$self{OPTIONS}{TextOut}; 310 my $protected = $options{Protected} || 0; 311 my $listOnly = $options{ListOnly}; 312 my $setTags = $options{SetTags}; 313 my $noFlat = $options{NoFlat}; 314 my $numSet = 0; 315 316 unless (defined $tag) { 317 delete $$self{NEW_VALUE}; 318 $$self{SAVE_COUNT} = 0; 319 $$self{DEL_GROUP} = { }; 320 return 1; 321 } 322 # allow value to be scalar or list reference 323 if (ref $value) { 324 if (ref $value eq 'ARRAY') { 325 # value is an ARRAY so it may have more than one entry 326 # - set values both separately and as a combined string if there are more than one 327 if (@$value > 1) { 328 # set all list-type tags first 329 my $replace = $options{Replace}; 330 my $noJoin; 331 foreach (@$value) { 332 $noJoin = 1 if ref $_; 333 my ($n, $e) = SetNewValue($self, $tag, $_, %options, ListOnly => 1); 334 $err = $e if $e; 335 $numSet += $n; 336 delete $options{Replace}; # don't replace earlier values in list 337 } 338 return $numSet if $noJoin; # don't join if list contains objects 339 # and now set only non-list tags 340 $value = join $$self{OPTIONS}{ListSep}, @$value; 341 $options{Replace} = $replace; 342 $listOnly = $options{ListOnly} = 0; 343 } else { 344 $value = $$value[0]; 345 $value = $$value if ref $value eq 'SCALAR'; # (handle single scalar ref in a list) 346 } 347 } elsif (ref $value eq 'SCALAR') { 348 $value = $$value; 349 } 350 } 351 # un-escape as necessary and make sure the Perl UTF-8 flag is OFF for the value 352 # if perl is 5.6 or greater (otherwise our byte manipulations get corrupted!!) 353 $self->Sanitize(\$value) if defined $value and not ref $value and not $options{Sanitized}; 354 355 # set group name in options if specified 356 ($options{Group}, $tag) = ($1, $2) if $tag =~ /(.*):(.+)/; 357 358 # allow trailing '#' for ValueConv value 359 $options{Type} = 'ValueConv' if $tag =~ s/#$//; 360 my $convType = $options{Type} || ($$self{OPTIONS}{PrintConv} ? 'PrintConv' : 'ValueConv'); 361 362 # filter value if necessary 363 $self->Filter($$self{OPTIONS}{FilterW}, \$value) or return 0 if $convType eq 'PrintConv'; 364 365 my (@wantGroup, $family2); 366 my $wantGroup = $options{Group}; 367 if ($wantGroup) { 368 foreach (split /:/, $wantGroup) { 369 next unless length($_) and /^(\d+)?(.*)/; # separate family number and group name 370 my ($f, $g) = ($1, $2); 371 my $lcg = lc $g; 372 # save group/family unless '*' or 'all' 373 push @wantGroup, [ $f, $lcg ] unless $lcg eq '*' or $lcg eq 'all'; 374 if ($g =~ s/^ID-//i) { # family 7 is a tag ID 375 return 0 if defined $f and $f ne 7; 376 $wantGroup[-1] = [ 7, $g ]; # group name with 'ID-' removed and case preserved 377 } elsif (defined $f) { 378 $f > 2 and return 0; # only allow family 0, 1 or 2 379 $family2 = 1 if $f == 2; # set flag indicating family 2 was used 380 } else { 381 $family2 = 1 if $family2groups{$lcg}; 382 } 383 } 384 undef $wantGroup unless @wantGroup; 385 } 386 387 $tag =~ s/ .*//; # convert from tag key to tag name if necessary 388 $tag = '*' if lc($tag) eq 'all'; # use '*' instead of 'all' 389# 390# handle group delete 391# 392 while ($tag eq '*' and not defined $value and not $family2 and @wantGroup < 2) { 393 # set groups to delete 394 my (@del, $grp); 395 my $remove = ($options{Replace} and $options{Replace} > 1); 396 if ($wantGroup) { 397 @del = grep /^$wantGroup$/i, @delGroups unless $wantGroup =~ /^XM[LP]-\*$/i; 398 # remove associated groups when excluding from mass delete 399 if (@del and $remove) { 400 # remove associated groups in other family 401 push @del, @{$excludeGroups{$del[0]}} if $excludeGroups{$del[0]}; 402 # remove upstream groups according to JPEG map 403 my $dirName = $del[0]; 404 my @dirNames; 405 for (;;) { 406 my $parent = $jpegMap{$dirName}; 407 if (ref $parent) { 408 push @dirNames, @$parent; 409 $parent = pop @dirNames; 410 } 411 $dirName = $parent || shift @dirNames or last; 412 push @del, $dirName; # exclude this too 413 } 414 } 415 # allow MIE groups to be deleted by number, 416 # and allow any XMP family 1 group to be deleted 417 push @del, uc($wantGroup) if $wantGroup =~ /^(MIE\d+|XM[LP]-[-\w]*\w)$/i; 418 } else { 419 # push all groups plus '*', except the protected groups 420 push @del, (grep !/^$protectedGroups$/, @delGroups), '*'; 421 } 422 if (@del) { 423 ++$numSet; 424 my @donegrps; 425 my $delGroup = $$self{DEL_GROUP}; 426 foreach $grp (@del) { 427 if ($remove) { 428 my $didExcl; 429 if ($grp =~ /^(XM[LP])(-.*)?$/) { 430 my $x = $1; 431 if ($grp eq $x) { 432 # exclude all related family 1 groups too 433 foreach (keys %$delGroup) { 434 next unless /^(-?)$x-/; 435 push @donegrps, $_ unless $1; 436 delete $$delGroup{$_}; 437 } 438 } elsif ($$delGroup{"$x-*"} and not $$delGroup{"-$grp"}) { 439 # must also exclude XMP or XML to prevent bulk delete 440 if ($$delGroup{$x}) { 441 push @donegrps, $x; 442 delete $$delGroup{$x}; 443 } 444 # flag XMP/XML family 1 group for exclusion with leading '-' 445 $$delGroup{"-$grp"} = 1; 446 $didExcl = 1; 447 } 448 } 449 if (exists $$delGroup{$grp}) { 450 delete $$delGroup{$grp}; 451 } else { 452 next unless $didExcl; 453 } 454 } else { 455 $$delGroup{$grp} = 1; 456 # add extra groups to delete if necessary 457 if ($delMore{$grp}) { 458 $$delGroup{$_} = 1, push @donegrps, $_ foreach @{$delMore{$grp}}; 459 } 460 # remove all of this group from previous new values 461 $self->RemoveNewValuesForGroup($grp); 462 } 463 push @donegrps, $grp; 464 } 465 if ($verbose > 1 and @donegrps) { 466 @donegrps = sort @donegrps; 467 my $msg = $remove ? 'Excluding from deletion' : 'Deleting tags in'; 468 print $out " $msg: @donegrps\n"; 469 } 470 } elsif (grep /^$wantGroup$/i, @delGroup2) { 471 last; # allow tags to be deleted by group2 name 472 } else { 473 $err = "Not a deletable group: $wantGroup"; 474 } 475 # all done 476 return ($numSet, $err) if wantarray; 477 $err and warn "$err\n"; 478 return $numSet; 479 } 480 481 # initialize write/create flags 482 my $createOnly; 483 my $editOnly = $options{EditOnly}; 484 my $editGroup = $options{EditGroup}; 485 my $writeMode = $$self{OPTIONS}{WriteMode}; 486 if ($writeMode ne 'wcg') { 487 $createOnly = 1 if $writeMode !~ /w/i; # don't write existing tags 488 if ($writeMode !~ /c/i) { 489 return 0 if $createOnly; # nothing to do unless writing existing tags 490 $editOnly = 1; # don't create new tags 491 } elsif ($writeMode !~ /g/i) { 492 $editGroup = 1; # don't create new groups 493 } 494 } 495 my ($ifdName, $mieGroup, $movGroup, $fg); 496 # set family 1 group names 497 foreach $fg (@wantGroup) { 498 next if defined $$fg[0] and $$fg[0] != 1; 499 $_ = $$fg[1]; 500 # set $ifdName if this group is a valid IFD or SubIFD name 501 my $grpName; 502 if (/^IFD(\d+)$/i) { 503 $grpName = $ifdName = "IFD$1"; 504 } elsif (/^SubIFD(\d+)$/i) { 505 $grpName = $ifdName = "SubIFD$1"; 506 } elsif (/^Version(\d+)$/i) { 507 $grpName = $ifdName = "Version$1"; # Sony IDC VersionIFD 508 } elsif ($exifDirs{$_}) { 509 $grpName = $exifDirs{$_}; 510 $ifdName = $grpName unless $ifdName and $allFam0{$_}; 511 } elsif ($allFam0{$_}) { 512 $grpName = $allFam0{$_}; 513 } elsif (/^Track(\d+)$/i) { 514 $grpName = $movGroup = "Track$1"; # QuickTime track 515 } elsif (/^MIE(\d*-?)(\w+)$/i) { 516 $grpName = $mieGroup = "MIE$1" . ucfirst(lc($2)); 517 } elsif (not $ifdName and /^XMP\b/i) { 518 # must load XMP table to set group1 names 519 my $table = GetTagTable('Image::ExifTool::XMP::Main'); 520 my $writeProc = $$table{WRITE_PROC}; 521 if ($writeProc) { 522 no strict 'refs'; 523 &$writeProc(); 524 } 525 } 526 # fix case for known groups 527 $wantGroup =~ s/$grpName/$grpName/i if $grpName and $grpName ne $_; 528 } 529# 530# get list of tags we want to set 531# 532 my $origTag = $tag; 533 my @matchingTags = FindTagInfo($tag); 534 until (@matchingTags) { 535 my $langCode; 536 # allow language suffix of form "-en_CA" or "-<rfc3066>" on tag name 537 if ($tag =~ /^([?*\w]+)-([a-z]{2})(_[a-z]{2})$/i or # MIE 538 $tag =~ /^([?*\w]+)-([a-z]{2,3}|[xi])(-[a-z\d]{2,8}(-[a-z\d]{1,8})*)?$/i) # XMP/PNG/QuickTime 539 { 540 $tag = $1; 541 # normalize case of language codes 542 $langCode = lc($2); 543 $langCode .= (length($3) == 3 ? uc($3) : lc($3)) if $3; 544 my @newMatches = FindTagInfo($tag); 545 foreach $tagInfo (@newMatches) { 546 # only allow language codes in tables which support them 547 next unless $$tagInfo{Table}; 548 my $langInfoProc = $$tagInfo{Table}{LANG_INFO} or next; 549 my $langInfo = &$langInfoProc($tagInfo, $langCode); 550 push @matchingTags, $langInfo if $langInfo; 551 } 552 last if @matchingTags; 553 } elsif (not $options{NoShortcut}) { 554 # look for a shortcut or alias 555 require Image::ExifTool::Shortcuts; 556 my ($match) = grep /^\Q$tag\E$/i, keys %Image::ExifTool::Shortcuts::Main; 557 undef $err; 558 if ($match) { 559 $options{NoShortcut} = $options{Sanitized} = 1; 560 foreach $tag (@{$Image::ExifTool::Shortcuts::Main{$match}}) { 561 my ($n, $e) = $self->SetNewValue($tag, $value, %options); 562 $numSet += $n; 563 $e and $err = $e; 564 } 565 undef $err if $numSet; # no error if any set successfully 566 return ($numSet, $err) if wantarray; 567 $err and warn "$err\n"; 568 return $numSet; 569 } 570 } 571 unless ($listOnly) { 572 if (not TagExists($tag)) { 573 if ($tag =~ /^[-\w*?]+$/) { 574 my $pre = $wantGroup ? $wantGroup . ':' : ''; 575 $err = "Tag '$pre${origTag}' is not defined"; 576 $err .= ' or has a bad language code' if $origTag =~ /-/; 577 if (not $pre and uc($origTag) eq 'TAG') { 578 $err .= " (specify a writable tag name, not '${origTag}' literally)" 579 } 580 } else { 581 $err = "Invalid tag name '${tag}'"; 582 $err .= " (remove the leading '\$')" if $tag =~ /^\$/; 583 } 584 } elsif ($langCode) { 585 $err = "Tag '${tag}' does not support alternate languages"; 586 } elsif ($wantGroup) { 587 $err = "Sorry, $wantGroup:$origTag doesn't exist or isn't writable"; 588 } else { 589 $err = "Sorry, $origTag is not writable"; 590 } 591 $verbose > 2 and print $out "$err\n"; 592 } 593 # all done 594 return ($numSet, $err) if wantarray; 595 $err and warn "$err\n"; 596 return $numSet; 597 } 598 # get group name that we're looking for 599 my $foundMatch = 0; 600# 601# determine the groups for all tags found, and the tag with 602# the highest priority group 603# 604 my (@tagInfoList, @writeAlsoList, %writeGroup, %preferred, %tagPriority); 605 my (%avoid, $wasProtected, $noCreate, %highestPriority, %highestQT); 606 607TAG: foreach $tagInfo (@matchingTags) { 608 $tag = $$tagInfo{Name}; # get tag name for warnings 609 my $lcTag = lc $tag; # get lower-case tag name for use in variables 610 # initialize highest priority if we are starting a new tag 611 $highestPriority{$lcTag} = -999 unless defined $highestPriority{$lcTag}; 612 my ($priority, $writeGroup); 613 my $prfTag = defined $$tagInfo{Preferred} ? $$tagInfo{Preferred} : $$tagInfo{Table}{PREFERRED}; 614 if ($wantGroup) { 615 # a WriteGroup of All is special 616 my $wgAll = ($$tagInfo{WriteGroup} and $$tagInfo{WriteGroup} eq 'All'); 617 my @grp = $self->GetGroup($tagInfo); 618 my $hiPri = 1000; 619 foreach $fg (@wantGroup) { 620 my ($fam, $lcWant) = @$fg; 621 $lcWant = $translateWantGroup{$lcWant} if $translateWantGroup{$lcWant}; 622 # only set tag in specified group 623 # bump priority of preferred tag 624 $hiPri += $prfTag if $prfTag; 625 if (not defined $fam) { 626 if ($lcWant eq lc $grp[0]) { 627 # don't go to more general write group of "All" 628 # if something more specific was wanted 629 $writeGroup = $grp[0] if $wgAll and not $writeGroup; 630 next; 631 } 632 next if $lcWant eq lc $grp[2]; 633 } elsif ($fam == 7) { 634 next if IsSameID($$tagInfo{TagID}, $lcWant); 635 } elsif ($fam != 1 and not $$tagInfo{AllowGroup}) { 636 next if $lcWant eq lc $grp[$fam]; 637 if ($wgAll and not $fam and $allFam0{$lcWant}) { 638 $writeGroup or $writeGroup = $allFam0{$lcWant}; 639 next; 640 } 641 next TAG; # wrong group 642 } 643 # handle family 1 groups specially 644 if ($grp[0] eq 'EXIF' or $grp[0] eq 'SonyIDC' or $wgAll) { 645 unless ($ifdName and $lcWant eq lc $ifdName) { 646 next TAG unless $wgAll and not $fam and $allFam0{$lcWant}; 647 $writeGroup = $allFam0{$lcWant} unless $writeGroup; 648 next; 649 } 650 next TAG if $wgAll and $allFam0{$lcWant} and $fam; 651 # can't yet write PreviewIFD tags (except for image) 652 $lcWant eq 'PreviewIFD' and ++$foundMatch, next TAG; 653 $writeGroup = $ifdName; # write to the specified IFD 654 } elsif ($grp[0] eq 'QuickTime') { 655 if ($grp[1] eq 'Track#') { 656 next TAG unless $movGroup and $lcWant eq lc($movGroup); 657 $writeGroup = $movGroup; 658 } else { 659 my $grp = $$tagInfo{Table}{WRITE_GROUP}; 660 next TAG unless $grp and $lcWant eq lc $grp; 661 $writeGroup = $grp; 662 } 663 } elsif ($grp[0] eq 'MIE') { 664 next TAG unless $mieGroup and $lcWant eq lc($mieGroup); 665 $writeGroup = $mieGroup; # write to specific MIE group 666 # set specific write group with document number if specified 667 if ($writeGroup =~ /^MIE\d+$/ and $$tagInfo{Table}{WRITE_GROUP}) { 668 $writeGroup = $$tagInfo{Table}{WRITE_GROUP}; 669 $writeGroup =~ s/^MIE/$mieGroup/; 670 } 671 } elsif (not $$tagInfo{AllowGroup} or $lcWant !~ /^$$tagInfo{AllowGroup}$/i) { 672 # allow group1 name to be specified 673 next TAG unless $lcWant eq lc $grp[1]; 674 } 675 } 676 $writeGroup or $writeGroup = ($$tagInfo{WriteGroup} || $$tagInfo{Table}{WRITE_GROUP} || $grp[0]); 677 $priority = $hiPri; # highest priority since group was specified 678 } 679 ++$foundMatch; 680 # must do a dummy call to the write proc to autoload write package 681 # before checking Writable flag 682 my $table = $$tagInfo{Table}; 683 my $writeProc = $$table{WRITE_PROC}; 684 # load source table if this was a user-defined table 685 if ($$table{SRC_TABLE}) { 686 my $src = GetTagTable($$table{SRC_TABLE}); 687 $writeProc = $$src{WRITE_PROC} unless $writeProc; 688 } 689 { 690 no strict 'refs'; 691 next unless $writeProc and &$writeProc(); 692 } 693 # must still check writable flags in case of UserDefined tags 694 my $writable = $$tagInfo{Writable}; 695 next unless $writable or ($$table{WRITABLE} and 696 not defined $writable and not $$tagInfo{SubDirectory}); 697 # set specific write group (if we didn't already) 698 if (not $writeGroup or ($translateWriteGroup{$writeGroup} and 699 (not $$tagInfo{WriteGroup} or $$tagInfo{WriteGroup} ne 'All'))) 700 { 701 # use default write group 702 $writeGroup = $$tagInfo{WriteGroup} || $$tagInfo{Table}{WRITE_GROUP}; 703 # use group 0 name if no WriteGroup specified 704 my $group0 = $self->GetGroup($tagInfo, 0); 705 $writeGroup or $writeGroup = $group0; 706 # get priority for this group 707 unless ($priority) { 708 $priority = $$self{WRITE_PRIORITY}{lc($writeGroup)}; 709 unless ($priority) { 710 $priority = $$self{WRITE_PRIORITY}{lc($group0)} || 0; 711 } 712 } 713 # adjust priority based on Preferred level for this tag 714 $priority += $prfTag if $prfTag; 715 } 716 # don't write tag if protected 717 my $prot = $$tagInfo{Protected}; 718 $prot = 1 if $noFlat and defined $$tagInfo{Flat}; 719 if ($prot) { 720 $prot &= ~$protected; 721 if ($prot) { 722 my %lkup = ( 1=>'unsafe', 2=>'protected', 3=>'unsafe and protected'); 723 $wasProtected = $lkup{$prot}; 724 if ($verbose > 1) { 725 my $wgrp1 = $self->GetWriteGroup1($tagInfo, $writeGroup); 726 print $out "Sorry, $wgrp1:$tag is $wasProtected for writing\n"; 727 } 728 next; 729 } 730 } 731 # set priority for this tag 732 $tagPriority{$tagInfo} = $priority; 733 # keep track of highest priority QuickTime tag 734 $highestQT{$lcTag} = $priority if $$table{GROUPS}{0} eq 'QuickTime' and 735 (not defined $highestQT{$lcTag} or $highestQT{$lcTag} < $priority); 736 if ($priority > $highestPriority{$lcTag}) { 737 $highestPriority{$lcTag} = $priority; 738 $preferred{$lcTag} = { $tagInfo => 1 }; 739 $avoid{$lcTag} = $$tagInfo{Avoid} ? 1 : 0; 740 } elsif ($priority == $highestPriority{$lcTag}) { 741 # create all tags with highest priority 742 $preferred{$lcTag}{$tagInfo} = 1; 743 ++$avoid{$lcTag} if $$tagInfo{Avoid}; 744 } 745 if ($$tagInfo{WriteAlso}) { 746 # store WriteAlso tags separately so we can set them first 747 push @writeAlsoList, $tagInfo; 748 } else { 749 push @tagInfoList, $tagInfo; 750 } 751 # special case to allow override of XMP WriteGroup 752 if ($writeGroup eq 'XMP') { 753 my $wg = $$tagInfo{WriteGroup} || $$table{WRITE_GROUP}; 754 $writeGroup = $wg if $wg; 755 } 756 $writeGroup{$tagInfo} = $writeGroup; 757 } 758 # sort tag info list in reverse order of priority (highest number last) 759 # so we get the highest priority error message in the end 760 @tagInfoList = sort { $tagPriority{$a} <=> $tagPriority{$b} } @tagInfoList; 761 # must write any tags which also write other tags first 762 unshift @tagInfoList, @writeAlsoList if @writeAlsoList; 763 764 # check priorities for each set of tags we are writing 765 my $lcTag; 766 foreach $lcTag (keys %preferred) { 767 # don't create tags with priority 0 if group priorities are set 768 if ($preferred{$lcTag} and $highestPriority{$lcTag} == 0 and 769 %{$$self{WRITE_PRIORITY}}) 770 { 771 delete $preferred{$lcTag} 772 } 773 # avoid creating tags with 'Avoid' flag set if there are other alternatives 774 if ($avoid{$lcTag} and $preferred{$lcTag}) { 775 if ($avoid{$lcTag} < scalar(keys %{$preferred{$lcTag}})) { 776 # just remove the 'Avoid' tags since there are other preferred tags 777 foreach $tagInfo (@tagInfoList) { 778 next unless $lcTag eq lc $$tagInfo{Name}; 779 delete $preferred{$lcTag}{$tagInfo} if $$tagInfo{Avoid}; 780 } 781 } elsif ($highestPriority{$lcTag} < 1000) { 782 # look for another priority tag to create instead 783 my $nextHighest = 0; 784 my @nextBestTags; 785 foreach $tagInfo (@tagInfoList) { 786 next unless $lcTag eq lc $$tagInfo{Name}; 787 my $priority = $tagPriority{$tagInfo} or next; 788 next if $priority == $highestPriority{$lcTag}; 789 next if $priority < $nextHighest; 790 my $permanent = $$tagInfo{Permanent}; 791 $permanent = $$tagInfo{Table}{PERMANENT} unless defined $permanent; 792 next if $$tagInfo{Avoid} or $permanent; 793 next if $writeGroup{$tagInfo} eq 'MakerNotes'; 794 if ($nextHighest < $priority) { 795 $nextHighest = $priority; 796 undef @nextBestTags; 797 } 798 push @nextBestTags, $tagInfo; 799 } 800 if (@nextBestTags) { 801 # change our preferred tags to the next best tags 802 delete $preferred{$lcTag}; 803 foreach $tagInfo (@nextBestTags) { 804 $preferred{$lcTag}{$tagInfo} = 1; 805 } 806 } 807 } 808 } 809 } 810# 811# generate new value hash for each tag 812# 813 my ($prioritySet, $createGroups, %alsoWrote); 814 815 delete $$self{CHECK_WARN}; # reset CHECK_PROC warnings 816 817 # loop through all valid tags to find the one(s) to write 818 foreach $tagInfo (@tagInfoList) { 819 next if $alsoWrote{$tagInfo}; # don't rewrite tags we already wrote 820 # only process List or non-List tags if specified 821 next if defined $listOnly and ($listOnly xor $$tagInfo{List}); 822 my $noConv; 823 my $writeGroup = $writeGroup{$tagInfo}; 824 my $permanent = $$tagInfo{Permanent}; 825 $permanent = $$tagInfo{Table}{PERMANENT} unless defined $permanent; 826 $writeGroup eq 'MakerNotes' and $permanent = 1 unless defined $permanent; 827 my $wgrp1 = $self->GetWriteGroup1($tagInfo, $writeGroup); 828 $tag = $$tagInfo{Name}; # get tag name for warnings 829 my $lcTag = lc $tag; 830 my $pref = $preferred{$lcTag} || { }; 831 my $shift = $options{Shift}; 832 my $addValue = $options{AddValue}; 833 if (defined $shift) { 834 # (can't currently shift list-type tags) 835 my $shiftable; 836 if ($$tagInfo{List}) { 837 $shiftable = ''; # can add/delete but not shift 838 } else { 839 $shiftable = $$tagInfo{Shift}; 840 unless ($shift) { 841 # set shift according to AddValue/DelValue 842 $shift = 1 if $addValue; 843 # can shift a date/time with -=, but this is 844 # a conditional delete operation for other tags 845 $shift = -1 if $options{DelValue} and defined $shiftable and $shiftable eq 'Time'; 846 } 847 if ($shift and (not defined $value or not length $value)) { 848 # (now allow -= to be used for shiftable tag - v8.05) 849 #$err = "No value for time shift of $wgrp1:$tag"; 850 #$verbose > 2 and print $out "$err\n"; 851 #next; 852 undef $shift; 853 } 854 } 855 # can't shift List-type tag 856 if ((defined $shiftable and not $shiftable) and 857 # and don't try to conditionally delete if Shift is "0" 858 ($shift or ($shiftable eq '0' and $options{DelValue}))) 859 { 860 $err = "$wgrp1:$tag is not shiftable"; 861 $verbose > 2 and print $out "$err\n"; 862 next; 863 } 864 } 865 my $val = $value; 866 if (defined $val) { 867 # check to make sure this is a List or Shift tag if adding 868 if ($addValue and not ($shift or $$tagInfo{List})) { 869 if ($addValue eq '2') { 870 undef $addValue; # quietly reset this option 871 } else { 872 $err = "Can't add $wgrp1:$tag (not a List type)"; 873 $verbose > 2 and print $out "$err\n"; 874 next; 875 } 876 } 877 if ($shift) { 878 if ($$tagInfo{Shift} and $$tagInfo{Shift} eq 'Time') { 879 # add '+' or '-' prefix to indicate shift direction 880 $val = ($shift > 0 ? '+' : '-') . $val; 881 # check the shift for validity 882 require 'Image/ExifTool/Shift.pl'; 883 my $err2 = CheckShift($$tagInfo{Shift}, $val); 884 if ($err2) { 885 $err = "$err2 for $wgrp1:$tag"; 886 $verbose > 2 and print $out "$err\n"; 887 next; 888 } 889 } elsif (IsFloat($val)) { 890 $val *= $shift; 891 } else { 892 $err = "Shift value for $wgrp1:$tag is not a number"; 893 $verbose > 2 and print $out "$err\n"; 894 next; 895 } 896 $noConv = 1; # no conversions if shifting tag 897 } elsif (not length $val and $options{DelValue}) { 898 $noConv = 1; # no conversions for deleting empty value 899 } elsif (ref $val eq 'HASH' and not $$tagInfo{Struct}) { 900 $err = "Can't write a structure to $wgrp1:$tag"; 901 $verbose > 2 and print $out "$err\n"; 902 next; 903 } 904 } elsif ($permanent) { 905 return 0 if $options{IgnorePermanent}; 906 # can't delete permanent tags, so set them to DelValue or empty string instead 907 if (defined $$tagInfo{DelValue}) { 908 $val = $$tagInfo{DelValue}; 909 $noConv = 1; # DelValue is the raw value, so no conversion necessary 910 } else { 911 $val = ''; 912 } 913 } elsif ($addValue or $options{DelValue}) { 914 $err = "No value to add or delete in $wgrp1:$tag"; 915 $verbose > 2 and print $out "$err\n"; 916 next; 917 } else { 918 if ($$tagInfo{DelCheck}) { 919 #### eval DelCheck ($self, $tagInfo, $wantGroup) 920 my $err2 = eval $$tagInfo{DelCheck}; 921 $@ and warn($@), $err2 = 'Error evaluating DelCheck'; 922 if (defined $err2) { 923 # (allow other tags to be set using DelCheck as a hook) 924 $err2 or goto WriteAlso; # GOTO! 925 $err2 .= ' for' unless $err2 =~ /delete$/; 926 $err = "$err2 $wgrp1:$tag"; 927 $verbose > 2 and print $out "$err\n"; 928 next; 929 } 930 } 931 # set group delete flag if this tag represents an entire group 932 if ($$tagInfo{DelGroup} and not $options{DelValue}) { 933 my @del = ( $tag ); 934 $$self{DEL_GROUP}{$tag} = 1; 935 # delete extra groups if necessary 936 if ($delMore{$tag}) { 937 $$self{DEL_GROUP}{$_} = 1, push(@del,$_) foreach @{$delMore{$tag}}; 938 } 939 # remove all of this group from previous new values 940 $self->RemoveNewValuesForGroup($tag); 941 $verbose and print $out " Deleting tags in: @del\n"; 942 ++$numSet; 943 next; 944 } 945 $noConv = 1; # value is not defined, so don't do conversion 946 } 947 # apply inverse PrintConv and ValueConv conversions 948 # save ValueConv setting for use in ConvInv() 949 unless ($noConv) { 950 # set default conversion type used by ConvInv() and CHECK_PROC routines 951 $$self{ConvType} = $convType; 952 my $e; 953 ($val,$e) = $self->ConvInv($val,$tagInfo,$tag,$wgrp1,$$self{ConvType},$wantGroup); 954 if (defined $e) { 955 # empty error string causes error to be ignored without setting the value 956 $e or goto WriteAlso; # GOTO! 957 $err = $e; 958 } 959 } 960 if (not defined $val and defined $value) { 961 # if value conversion failed, we must still add a NEW_VALUE 962 # entry for this tag it it was a DelValue 963 next unless $options{DelValue}; 964 $val = 'xxx never delete xxx'; 965 } 966 $$self{NEW_VALUE} or $$self{NEW_VALUE} = { }; 967 if ($options{Replace}) { 968 # delete the previous new value 969 $self->GetNewValueHash($tagInfo, $writeGroup, 'delete', $options{ProtectSaved}); 970 # also delete related tag previous new values 971 if ($$tagInfo{WriteAlso}) { 972 my ($wgrp, $wtag); 973 if ($$tagInfo{WriteGroup} and $$tagInfo{WriteGroup} eq 'All' and $writeGroup) { 974 $wgrp = $writeGroup . ':'; 975 } else { 976 $wgrp = ''; 977 } 978 foreach $wtag (keys %{$$tagInfo{WriteAlso}}) { 979 my ($n,$e) = $self->SetNewValue($wgrp . $wtag, undef, Replace=>2); 980 $numSet += $n; 981 } 982 } 983 $options{Replace} == 2 and ++$numSet, next; 984 } 985 986 if (defined $val) { 987 # we are editing this tag, so create a NEW_VALUE hash entry 988 my $nvHash = $self->GetNewValueHash($tagInfo, $writeGroup, 'create', 989 $options{ProtectSaved}, ($options{DelValue} and not $shift)); 990 # ignore new values protected with ProtectSaved 991 $nvHash or ++$numSet, next; # (increment $numSet to avoid warning) 992 $$nvHash{NoReplace} = 1 if $$tagInfo{List} and not $options{Replace}; 993 $$nvHash{WantGroup} = $wantGroup; 994 $$nvHash{EditOnly} = 1 if $editOnly; 995 # save maker note information if writing maker notes 996 if ($$tagInfo{MakerNotes}) { 997 $$nvHash{MAKER_NOTE_FIXUP} = $$self{MAKER_NOTE_FIXUP}; 998 } 999 if ($createOnly) { # create only (never edit) 1000 # empty item in DelValue list to never edit existing value 1001 $$nvHash{DelValue} = [ '' ]; 1002 $$nvHash{CreateOnly} = 1; 1003 } elsif ($options{DelValue} or $addValue or $shift) { 1004 # flag any AddValue or DelValue by creating the DelValue list 1005 $$nvHash{DelValue} or $$nvHash{DelValue} = [ ]; 1006 if ($shift) { 1007 # add shift value to list 1008 $$nvHash{Shift} = $val; 1009 } elsif ($options{DelValue}) { 1010 # don't create if we are replacing a specific value 1011 $$nvHash{IsCreating} = 0 unless $val eq '' or $$tagInfo{List}; 1012 # add delete value to list 1013 push @{$$nvHash{DelValue}}, ref $val eq 'ARRAY' ? @$val : $val; 1014 if ($verbose > 1) { 1015 my $verb = $permanent ? 'Replacing' : 'Deleting'; 1016 my $fromList = $$tagInfo{List} ? ' from list' : ''; 1017 my @vals = (ref $val eq 'ARRAY' ? @$val : $val); 1018 foreach (@vals) { 1019 if (ref $_ eq 'HASH') { 1020 require 'Image/ExifTool/XMPStruct.pl'; 1021 $_ = Image::ExifTool::XMP::SerializeStruct($_); 1022 } 1023 print $out "$verb $wgrp1:$tag$fromList if value is '${_}'\n"; 1024 } 1025 } 1026 } 1027 } 1028 # set priority flag to add only the high priority info 1029 # (will only create the priority tag if it doesn't exist, 1030 # others get changed only if they already exist) 1031 my $prf = defined $$tagInfo{Preferred} ? $$tagInfo{Preferred} : $$tagInfo{Table}{PREFERRED}; 1032 # hack to prefer only a single tag in the QuickTime group 1033 if ($$tagInfo{Table}{GROUPS}{0} eq 'QuickTime') { 1034 $prf = 0 if $tagPriority{$tagInfo} < $highestQT{$lcTag}; 1035 } 1036 if ($$pref{$tagInfo} or $prf) { 1037 if ($permanent or $shift) { 1038 # don't create permanent or Shift-ed tag but define IsCreating 1039 # so we know that it is the preferred tag 1040 $$nvHash{IsCreating} = 0; 1041 } elsif (($$tagInfo{List} and not $options{DelValue}) or 1042 not ($$nvHash{DelValue} and @{$$nvHash{DelValue}}) or 1043 # also create tag if any DelValue value is empty ('') 1044 grep(/^$/,@{$$nvHash{DelValue}})) 1045 { 1046 $$nvHash{IsCreating} = $editOnly ? 0 : ($editGroup ? 2 : 1); 1047 # add to hash of groups where this tag is being created 1048 $createGroups or $createGroups = $options{CreateGroups} || { }; 1049 $$createGroups{$self->GetGroup($tagInfo, 0)} = 1; 1050 $$nvHash{CreateGroups} = $createGroups; 1051 } 1052 } 1053 if ($$nvHash{IsCreating}) { 1054 if (%{$$self{DEL_GROUP}}) { 1055 my ($grp, @grps); 1056 foreach $grp (keys %{$$self{DEL_GROUP}}) { 1057 next if $$self{DEL_GROUP}{$grp} == 2; 1058 # set flag indicating tags were written after this group was deleted 1059 $$self{DEL_GROUP}{$grp} = 2; 1060 push @grps, $grp; 1061 } 1062 if ($verbose > 1 and @grps) { 1063 @grps = sort @grps; 1064 print $out " Writing new tags after deleting groups: @grps\n"; 1065 } 1066 } 1067 } elsif ($createOnly) { 1068 $noCreate = $permanent ? 'permanent' : ($$tagInfo{Avoid} ? 'avoided' : ''); 1069 $noCreate or $noCreate = $shift ? 'shifting' : 'not preferred'; 1070 $verbose > 2 and print $out "Not creating $wgrp1:$tag ($noCreate)\n"; 1071 next; # nothing to do (not creating and not editing) 1072 } 1073 if ($shift or not $options{DelValue}) { 1074 $$nvHash{Value} or $$nvHash{Value} = [ ]; 1075 if (not $$tagInfo{List}) { 1076 # not a List tag -- overwrite existing value 1077 $$nvHash{Value}[0] = $val; 1078 } elsif (defined $$nvHash{AddBefore} and @{$$nvHash{Value}} >= $$nvHash{AddBefore}) { 1079 # values from a later argument have been added (ie. Replace=0) 1080 # to this list, so the new values should come before these 1081 splice @{$$nvHash{Value}}, -$$nvHash{AddBefore}, 0, ref $val eq 'ARRAY' ? @$val : $val; 1082 } else { 1083 # add at end of existing list 1084 push @{$$nvHash{Value}}, ref $val eq 'ARRAY' ? @$val : $val; 1085 } 1086 if ($verbose > 1) { 1087 my $ifExists = $$nvHash{IsCreating} ? ( $createOnly ? 1088 ($$nvHash{IsCreating} == 2 ? 1089 " if $writeGroup exists and tag doesn't" : 1090 " if tag doesn't exist") : 1091 ($$nvHash{IsCreating} == 2 ? " if $writeGroup exists" : '')) : 1092 (($$nvHash{DelValue} and @{$$nvHash{DelValue}}) ? 1093 ' if tag was deleted' : ' if tag exists'); 1094 my $verb = ($shift ? 'Shifting' : ($addValue ? 'Adding' : 'Writing')); 1095 print $out "$verb $wgrp1:$tag$ifExists\n"; 1096 } 1097 } 1098 } elsif ($permanent) { 1099 $err = "Can't delete Permanent tag $wgrp1:$tag"; 1100 $verbose > 1 and print $out "$err\n"; 1101 next; 1102 } elsif ($addValue or $options{DelValue}) { 1103 $verbose > 1 and print $out "Adding/Deleting nothing does nothing\n"; 1104 next; 1105 } else { 1106 # create empty new value hash entry to delete this tag 1107 $self->GetNewValueHash($tagInfo, $writeGroup, 'delete'); 1108 my $nvHash = $self->GetNewValueHash($tagInfo, $writeGroup, 'create'); 1109 $$nvHash{WantGroup} = $wantGroup; 1110 $verbose > 1 and print $out "Deleting $wgrp1:$tag\n"; 1111 } 1112 $$setTags{$tagInfo} = 1 if $setTags; 1113 $prioritySet = 1 if $$pref{$tagInfo}; 1114WriteAlso: 1115 ++$numSet; 1116 # also write related tags 1117 my $writeAlso = $$tagInfo{WriteAlso}; 1118 if ($writeAlso) { 1119 my ($wgrp, $wtag, $n); 1120 if ($$tagInfo{WriteGroup} and $$tagInfo{WriteGroup} eq 'All' and $writeGroup) { 1121 $wgrp = $writeGroup . ':'; 1122 } else { 1123 $wgrp = ''; 1124 } 1125 local $SIG{'__WARN__'} = \&SetWarning; 1126 foreach $wtag (keys %$writeAlso) { 1127 my %opts = ( 1128 Type => 'ValueConv', 1129 Protected => $protected | 0x02, 1130 AddValue => $addValue, 1131 DelValue => $options{DelValue}, 1132 Shift => $options{Shift}, 1133 Replace => $options{Replace}, # handle lists properly 1134 CreateGroups=> $createGroups, 1135 SetTags => \%alsoWrote, # remember tags already written 1136 ); 1137 undef $evalWarning; 1138 #### eval WriteAlso ($val) 1139 my $v = eval $$writeAlso{$wtag}; 1140 # we wanted to do the eval in case there are side effect, but we 1141 # don't want to write a value for a tag that is being deleted: 1142 undef $v unless defined $val; 1143 $@ and $evalWarning = $@; 1144 unless ($evalWarning) { 1145 ($n,$evalWarning) = $self->SetNewValue($wgrp . $wtag, $v, %opts); 1146 $numSet += $n; 1147 # count this as being set if any related tag is set 1148 $prioritySet = 1 if $n and $$pref{$tagInfo}; 1149 } 1150 if ($evalWarning and (not $err or $verbose > 2)) { 1151 my $str = CleanWarning(); 1152 if ($str) { 1153 $str .= " for $wtag" unless $str =~ / for [-\w:]+$/; 1154 $str .= " in $wgrp1:$tag (WriteAlso)"; 1155 $err or $err = $str; 1156 print $out "$str\n" if $verbose > 2; 1157 } 1158 } 1159 } 1160 } 1161 } 1162 # print warning if we couldn't set our priority tag 1163 if (defined $err and not $prioritySet) { 1164 warn "$err\n" if $err and not wantarray; 1165 } elsif (not $numSet) { 1166 my $pre = $wantGroup ? $wantGroup . ':' : ''; 1167 if ($wasProtected) { 1168 $verbose = 0; # we already printed this verbose message 1169 unless ($options{Replace} and $options{Replace} == 2) { 1170 $err = "Sorry, $pre$tag is $wasProtected for writing"; 1171 } 1172 } elsif (not $listOnly) { 1173 if ($origTag =~ /[?*]/) { 1174 if ($noCreate) { 1175 $err = "No tags matching 'pre${origTag}' will be created"; 1176 $verbose = 0; # (already printed) 1177 } elsif ($foundMatch) { 1178 $err = "Sorry, no writable tags matching '$pre${origTag}'"; 1179 } else { 1180 $err = "No matching tags for '$pre${origTag}'"; 1181 } 1182 } elsif ($noCreate) { 1183 $err = "Not creating $pre$tag"; 1184 $verbose = 0; # (already printed) 1185 } elsif ($foundMatch) { 1186 $err = "Sorry, $pre$tag is not writable"; 1187 } elsif ($wantGroup and @matchingTags) { 1188 $err = "Sorry, $pre$tag doesn't exist or isn't writable"; 1189 } else { 1190 $err = "Tag '$pre${tag}' is not defined"; 1191 } 1192 } 1193 if ($err) { 1194 $verbose > 2 and print $out "$err\n"; 1195 warn "$err\n" unless wantarray; 1196 } 1197 } elsif ($$self{CHECK_WARN}) { 1198 $err = $$self{CHECK_WARN}; 1199 $verbose > 2 and print $out "$err\n"; 1200 } elsif ($err and not $verbose) { 1201 undef $err; 1202 } 1203 return ($numSet, $err) if wantarray; 1204 return $numSet; 1205} 1206 1207#------------------------------------------------------------------------------ 1208# set new values from information in specified file 1209# Inputs: 0) ExifTool object reference, 1) source file name or reference, etc 1210# 2-N) List of tags to set (or all if none specified), or reference(s) to 1211# hash for options to pass to SetNewValue. The Replace option defaults 1212# to 1 for SetNewValuesFromFile -- set this to 0 to allow multiple tags 1213# to be copied to a list 1214# Returns: Hash of information set successfully (includes Warning or Error messages) 1215# Notes: Tag names may contain a group prefix, a leading '-' to exclude from copy, 1216# and/or a trailing '#' to copy the ValueConv value. The tag name '*' may 1217# be used to represent all tags in a group. An optional destination tag 1218# may be specified with '>DSTTAG' ('DSTTAG<TAG' also works, but in this 1219# case the source tag may also be an expression involving tag names). 1220sub SetNewValuesFromFile($$;@) 1221{ 1222 local $_; 1223 my ($self, $srcFile, @setTags) = @_; 1224 my ($key, $tag, @exclude, @reqTags); 1225 1226 # get initial SetNewValuesFromFile options 1227 my %opts = ( Replace => 1 ); # replace existing list items by default 1228 while (ref $setTags[0] eq 'HASH') { 1229 $_ = shift @setTags; 1230 foreach $key (keys %$_) { 1231 $opts{$key} = $$_{$key}; 1232 } 1233 } 1234 # expand shortcuts 1235 @setTags and ExpandShortcuts(\@setTags); 1236 my $srcExifTool = new Image::ExifTool; 1237 # set flag to indicate we are being called from inside SetNewValuesFromFile() 1238 $$srcExifTool{TAGS_FROM_FILE} = 1; 1239 # synchronize and increment the file sequence number 1240 $$srcExifTool{FILE_SEQUENCE} = $$self{FILE_SEQUENCE}++; 1241 # set options for our extraction tool 1242 my $options = $$self{OPTIONS}; 1243 # copy both structured and flattened tags by default (but flattened tags are "unsafe") 1244 my $structOpt = defined $$options{Struct} ? $$options{Struct} : 2; 1245 # copy structures only if no tags specified (since flattened tags are "unsafe") 1246 $structOpt = 1 if $structOpt eq '2' and not @setTags; 1247 # +------------------------------------------+ 1248 # ! DON'T FORGET!! Must consider each new ! 1249 # ! option to decide how it is handled here. ! 1250 # +------------------------------------------+ 1251 $srcExifTool->Options( 1252 Binary => 1, 1253 Charset => $$options{Charset}, 1254 CharsetEXIF => $$options{CharsetEXIF}, 1255 CharsetFileName => $$options{CharsetFileName}, 1256 CharsetID3 => $$options{CharsetID3}, 1257 CharsetIPTC => $$options{CharsetIPTC}, 1258 CharsetPhotoshop=> $$options{CharsetPhotoshop}, 1259 Composite => $$options{Composite}, 1260 CoordFormat => $$options{CoordFormat} || '%d %d %.8f', # copy coordinates at high resolution unless otherwise specified 1261 DateFormat => $$options{DateFormat}, 1262 Duplicates => 1, 1263 Escape => $$options{Escape}, 1264 # Exclude (set below) 1265 ExtendedXMP => $$options{ExtendedXMP}, 1266 ExtractEmbedded => $$options{ExtractEmbedded}, 1267 FastScan => $$options{FastScan}, 1268 Filter => $$options{Filter}, 1269 FixBase => $$options{FixBase}, 1270 GlobalTimeShift => $$options{GlobalTimeShift}, 1271 HexTagIDs => $$options{HexTagIDs}, 1272 IgnoreMinorErrors=>$$options{IgnoreMinorErrors}, 1273 Lang => $$options{Lang}, 1274 LargeFileSupport=> $$options{LargeFileSupport}, 1275 List => 1, 1276 ListItem => $$options{ListItem}, 1277 ListSep => $$options{ListSep}, 1278 MakerNotes => $$options{FastScan} && $$options{FastScan} > 1 ? undef : 1, 1279 MDItemTags => $$options{MDItemTags}, 1280 MissingTagValue => $$options{MissingTagValue}, 1281 NoPDFList => $$options{NoPDFList}, 1282 Password => $$options{Password}, 1283 PrintConv => $$options{PrintConv}, 1284 QuickTimeUTC => $$options{QuickTimeUTC}, 1285 RequestAll => $$options{RequestAll} || 1, # (is this still necessary now that RequestTags are being set?) 1286 RequestTags => $$options{RequestTags}, 1287 SaveFormat => $$options{SaveFormat}, 1288 SavePath => $$options{SavePath}, 1289 ScanForXMP => $$options{ScanForXMP}, 1290 StrictDate => defined $$options{StrictDate} ? $$options{StrictDate} : 1, 1291 Struct => $structOpt, 1292 SystemTags => $$options{SystemTags}, 1293 TimeZone => $$options{TimeZone}, 1294 Unknown => $$options{Unknown}, 1295 UserParam => $$options{UserParam}, 1296 Validate => $$options{Validate}, 1297 XAttrTags => $$options{XAttrTags}, 1298 XMPAutoConv => $$options{XMPAutoConv}, 1299 ); 1300 $$srcExifTool{GLOBAL_TIME_OFFSET} = $$self{GLOBAL_TIME_OFFSET}; 1301 foreach $tag (@setTags) { 1302 next if ref $tag; 1303 if ($tag =~ /^-(.*)/) { 1304 # avoid extracting tags that are excluded 1305 push @exclude, $1; 1306 next; 1307 } 1308 # add specified tags to list of requested tags 1309 $_ = $tag; 1310 if (/(.+?)\s*(>|<)\s*(.+)/) { 1311 if ($2 eq '>') { 1312 $_ = $1; 1313 } else { 1314 $_ = $3; 1315 /\$/ and push(@reqTags, /\$\{?(?:[-\w]+:)*([-\w?*]+)/g), next; 1316 } 1317 } 1318 push @reqTags, $2 if /(^|:)([-\w?*]+)#?$/; 1319 } 1320 if (@exclude) { 1321 ExpandShortcuts(\@exclude, 1); 1322 $srcExifTool->Options(Exclude => \@exclude); 1323 } 1324 $srcExifTool->Options(RequestTags => \@reqTags) if @reqTags; 1325 my $printConv = $$options{PrintConv}; 1326 if ($opts{Type}) { 1327 # save source type separately because it may be different than dst Type 1328 $opts{SrcType} = $opts{Type}; 1329 # override PrintConv option with initial Type if given 1330 $printConv = ($opts{Type} eq 'PrintConv' ? 1 : 0); 1331 $srcExifTool->Options(PrintConv => $printConv); 1332 } 1333 my $srcType = $printConv ? 'PrintConv' : 'ValueConv'; 1334 1335 # get all tags from source file (including MakerNotes block) 1336 my $info = $srcExifTool->ImageInfo($srcFile); 1337 return $info if $$info{Error} and $$info{Error} eq 'Error opening file'; 1338 delete $$srcExifTool{VALUE}{Error}; # delete so we can check this later 1339 1340 # sort tags in reverse order so we get priority tag last 1341 my @tags = reverse sort keys %$info; 1342# 1343# simply transfer all tags from source image if no tags specified 1344# 1345 unless (@setTags) { 1346 # transfer maker note information to this object 1347 $$self{MAKER_NOTE_FIXUP} = $$srcExifTool{MAKER_NOTE_FIXUP}; 1348 $$self{MAKER_NOTE_BYTE_ORDER} = $$srcExifTool{MAKER_NOTE_BYTE_ORDER}; 1349 foreach $tag (@tags) { 1350 # don't try to set errors or warnings 1351 next if $tag =~ /^(Error|Warning)\b/; 1352 # get appropriate value type if necessary 1353 if ($opts{SrcType} and $opts{SrcType} ne $srcType) { 1354 $$info{$tag} = $srcExifTool->GetValue($tag, $opts{SrcType}); 1355 } 1356 # set value for this tag 1357 my ($n, $e) = $self->SetNewValue($tag, $$info{$tag}, %opts); 1358 # delete this tag if we couldn't set it 1359 $n or delete $$info{$tag}; 1360 } 1361 return $info; 1362 } 1363# 1364# transfer specified tags in the proper order 1365# 1366 # 1) loop through input list of tags to set, and build @setList 1367 my (@setList, $set, %setMatches, $t); 1368 foreach $t (@setTags) { 1369 if (ref $t eq 'HASH') { 1370 # update current options 1371 foreach $key (keys %$t) { 1372 $opts{$key} = $$t{$key}; 1373 } 1374 next; 1375 } 1376 # make a copy of the current options for this setTag 1377 # (also use this hash to store expression and wildcard flags, EXPR and WILD) 1378 my $opts = { %opts }; 1379 $tag = lc $t; # change tag/group names to all lower case 1380 my (@fg, $grp, $dst, $dstGrp, $dstTag, $isExclude); 1381 # handle redirection to another tag 1382 if ($tag =~ /(.+?)\s*(>|<)\s*(.+)/) { 1383 $dstGrp = ''; 1384 my $opt; 1385 if ($2 eq '>') { 1386 ($tag, $dstTag) = ($1, $3); 1387 # flag add and delete (eg. '+<' and '-<') redirections 1388 $opt = $1 if $tag =~ s/\s*([-+])$// or $dstTag =~ s/^([-+])\s*//; 1389 } else { 1390 ($tag, $dstTag) = ($3, $1); 1391 $opt = $1 if $dstTag =~ s/\s*([-+])$//; 1392 # handle expressions 1393 if ($tag =~ /\$/) { 1394 $tag = $t; # restore original case 1395 # recover leading whitespace (except for initial single space) 1396 $tag =~ s/(.+?)\s*(>|<) ?//; 1397 $$opts{EXPR} = 1; # flag this expression 1398 } else { 1399 $opt = $1 if $tag =~ s/^([-+])\s*//; 1400 } 1401 } 1402 # validate tag name(s) 1403 $$opts{EXPR} or ValidTagName($tag) or $self->Warn("Invalid tag name '${tag}'"), next; 1404 ValidTagName($dstTag) or $self->Warn("Invalid tag name '${dstTag}'"), next; 1405 # translate '+' and '-' to appropriate SetNewValue option 1406 if ($opt) { 1407 $$opts{{ '+' => 'AddValue', '-' => 'DelValue' }->{$opt}} = 1; 1408 $$opts{Shift} = 0; # shift if shiftable 1409 } 1410 ($dstGrp, $dstTag) = ($1, $2) if $dstTag =~ /(.*):(.+)/; 1411 # ValueConv may be specified separately on the destination with '#' 1412 $$opts{Type} = 'ValueConv' if $dstTag =~ s/#$//; 1413 # replace tag name of 'all' with '*' 1414 $dstTag = '*' if $dstTag eq 'all'; 1415 } 1416 unless ($$opts{EXPR}) { 1417 $isExclude = ($tag =~ s/^-//); 1418 if ($tag =~ /(.*):(.+)/) { 1419 ($grp, $tag) = ($1, $2); 1420 foreach (split /:/, $grp) { 1421 # save family/groups in list (ignoring 'all' and '*') 1422 next unless length($_) and /^(\d+)?(.*)/; 1423 my ($f, $g) = ($1, $2); 1424 $f = 7 if $g =~ s/^ID-//i; 1425 push @fg, [ $f, $g ] unless $g eq '*' or $g eq 'all'; 1426 } 1427 } 1428 # allow ValueConv to be specified by a '#' on the tag name 1429 if ($tag =~ s/#$//) { 1430 $$opts{SrcType} = 'ValueConv'; 1431 $$opts{Type} = 'ValueConv' unless $dstTag; 1432 } 1433 # replace 'all' with '*' in tag and group names 1434 $tag = '*' if $tag eq 'all'; 1435 # allow wildcards in tag names (handle differently from all tags: '*') 1436 if ($tag =~ /[?*]/ and $tag ne '*') { 1437 $$opts{WILD} = 1; # set flag indicating wildcards were used in source tag 1438 $tag =~ s/\*/[-\\w]*/g; 1439 $tag =~ s/\?/[-\\w]/g; 1440 } 1441 } 1442 # redirect, exclude or set this tag (Note: @fg is empty if we don't care about the group) 1443 if ($dstTag) { 1444 # redirect this tag 1445 $isExclude and return { Error => "Can't redirect excluded tag" }; 1446 # set destination group the same as source if necessary 1447 # (removed in 7.72 so '-*:*<xmp:*' will preserve XMP family 1 groups) 1448 # $dstGrp = $grp if $dstGrp eq '*' and $grp; 1449 # write to specified destination group/tag 1450 $dst = [ $dstGrp, $dstTag ]; 1451 } elsif ($isExclude) { 1452 # implicitly assume '*' if first entry is an exclusion 1453 unshift @setList, [ [ ], '*', [ '', '*' ], $opts ] unless @setList; 1454 # exclude this tag by leaving $dst undefined 1455 } else { 1456 $dst = [ $grp || '', $$opts{WILD} ? '*' : $tag ]; # use same group name for dest 1457 } 1458 # save in reverse order so we don't set tags before an exclude 1459 unshift @setList, [ \@fg, $tag, $dst, $opts ]; 1460 } 1461 # 2) initialize lists of matching tags for each setTag 1462 foreach $set (@setList) { 1463 $$set[2] and $setMatches{$set} = [ ]; 1464 } 1465 # 3) loop through all tags in source image and save tags matching each setTag 1466 my %rtnInfo; 1467 foreach $tag (@tags) { 1468 # don't try to set errors or warnings 1469 if ($tag =~ /^(Error|Warning)( |$)/) { 1470 $rtnInfo{$tag} = $$info{$tag}; 1471 next; 1472 } 1473 # only set specified tags 1474 my $lcTag = lc(GetTagName($tag)); 1475 my (@grp, %grp); 1476SET: foreach $set (@setList) { 1477 # check first for matching tag 1478 unless ($$set[1] eq $lcTag or $$set[1] eq '*') { 1479 # handle wildcards 1480 next unless $$set[3]{WILD} and $lcTag =~ /^$$set[1]$/; 1481 } 1482 # then check for matching group 1483 if (@{$$set[0]}) { 1484 # get lower case group names if not done already 1485 unless (@grp) { 1486 @grp = map(lc, $srcExifTool->GetGroup($tag)); 1487 $grp{$_} = 1 foreach @grp; 1488 } 1489 foreach (@{$$set[0]}) { 1490 my ($f, $g) = @$_; 1491 if (not defined $f) { 1492 next SET unless $grp{$g}; 1493 } elsif ($f == 7) { 1494 next SET unless IsSameID($srcExifTool->GetTagID($tag), $g); 1495 } else { 1496 next SET unless defined $grp[$f] and $g eq $grp[$f]; 1497 } 1498 } 1499 } 1500 last unless $$set[2]; # all done if we hit an exclude 1501 # add to the list of tags matching this setTag 1502 push @{$setMatches{$set}}, $tag; 1503 } 1504 } 1505 # 4) loop through each setTag in original order, setting new tag values 1506 foreach $set (reverse @setList) { 1507 # get options for SetNewValue 1508 my $opts = $$set[3]; 1509 # handle expressions 1510 if ($$opts{EXPR}) { 1511 my $val = $srcExifTool->InsertTagValues(\@tags, $$set[1], 'Error'); 1512 if ($$srcExifTool{VALUE}{Error}) { 1513 # pass on any error as a warning 1514 $tag = NextFreeTagKey(\%rtnInfo, 'Warning'); 1515 $rtnInfo{$tag} = $$srcExifTool{VALUE}{Error}; 1516 delete $$srcExifTool{VALUE}{Error}; 1517 next unless defined $val; 1518 } 1519 my ($dstGrp, $dstTag) = @{$$set[2]}; 1520 $$opts{Protected} = 1 unless $dstTag =~ /[?*]/ and $dstTag ne '*'; 1521 $$opts{Group} = $dstGrp if $dstGrp; 1522 my @rtnVals = $self->SetNewValue($dstTag, $val, %$opts); 1523 $rtnInfo{$dstTag} = $val if $rtnVals[0]; # tag was set successfully 1524 next; 1525 } 1526 foreach $tag (@{$setMatches{$set}}) { 1527 my ($val, $noWarn); 1528 if ($$opts{SrcType} and $$opts{SrcType} ne $srcType) { 1529 $val = $srcExifTool->GetValue($tag, $$opts{SrcType}); 1530 } else { 1531 $val = $$info{$tag}; 1532 } 1533 my ($dstGrp, $dstTag) = @{$$set[2]}; 1534 if ($dstGrp) { 1535 my @dstGrp = split /:/, $dstGrp; 1536 # destination group of '*' writes to same group as source tag 1537 # (family 1 unless otherwise specified) 1538 foreach (@dstGrp) { 1539 next unless /^(\d*)(all|\*)$/i; 1540 $_ = $1 . $srcExifTool->GetGroup($tag, length $1 ? $1 : 1); 1541 $noWarn = 1; # don't warn on wildcard destinations 1542 } 1543 $$opts{Group} = join ':', @dstGrp; 1544 } else { 1545 delete $$opts{Group}; 1546 } 1547 # transfer maker note information if setting this tag 1548 if ($$srcExifTool{TAG_INFO}{$tag}{MakerNotes}) { 1549 $$self{MAKER_NOTE_FIXUP} = $$srcExifTool{MAKER_NOTE_FIXUP}; 1550 $$self{MAKER_NOTE_BYTE_ORDER} = $$srcExifTool{MAKER_NOTE_BYTE_ORDER}; 1551 } 1552 if ($dstTag eq '*') { 1553 $dstTag = $tag; 1554 $noWarn = 1; 1555 } 1556 if ($$set[1] eq '*' or $$set[3]{WILD}) { 1557 # don't copy from protected binary tags when using wildcards 1558 next if $$srcExifTool{TAG_INFO}{$tag}{Protected} and 1559 $$srcExifTool{TAG_INFO}{$tag}{Binary}; 1560 # don't copy to protected tags when using wildcards 1561 delete $$opts{Protected}; 1562 # don't copy flattened tags if copying structures too when copying all 1563 $$opts{NoFlat} = $structOpt eq '2' ? 1 : 0; 1564 } else { 1565 # allow protected tags to be copied if specified explicitly 1566 $$opts{Protected} = 1 unless $dstTag =~ /[?*]/; 1567 delete $$opts{NoFlat}; 1568 } 1569 # set value(s) for this tag 1570 my ($rtn, $wrn) = $self->SetNewValue($dstTag, $val, %$opts); 1571 # this was added in version 9.14, and allowed actions like "-subject<all" to 1572 # write values of multiple tags into a list, but it had the side effect of 1573 # duplicating items if there were multiple list tags with the same name 1574 # (eg. -use mwg "-creator<creator"), so disable this as of ExifTool 9.36: 1575 # $$opts{Replace} = 0; # accumulate values from tags matching a single argument 1576 if ($wrn and not $noWarn) { 1577 # return this warning 1578 $rtnInfo{NextFreeTagKey(\%rtnInfo, 'Warning')} = $wrn; 1579 $noWarn = 1; 1580 } 1581 $rtnInfo{$tag} = $val if $rtn; # tag was set successfully 1582 } 1583 } 1584 return \%rtnInfo; # return information that we set 1585} 1586 1587#------------------------------------------------------------------------------ 1588# Get new value(s) for tag 1589# Inputs: 0) ExifTool object reference, 1) tag name (or tagInfo or nvHash ref, not public) 1590# 2) optional pointer to return new value hash reference (not part of public API) 1591# Returns: List of new Raw values (list may be empty if tag is being deleted) 1592# Notes: 1) Preferentially returns new value from Extra table if writable Extra tag exists 1593# 2) Must call AFTER IsOverwriting() returns 1 to get proper value for shifted times 1594# 3) Tag name is case sensitive and may be prefixed by family 0 or 1 group name 1595# 4) Value may have been modified by CHECK_PROC routine after ValueConv 1596sub GetNewValue($$;$) 1597{ 1598 local $_; 1599 my $self = shift; 1600 my $tag = shift; 1601 my $nvHash; 1602 if ((ref $tag eq 'HASH' and $$tag{IsNVH}) or not defined $tag) { 1603 $nvHash = $tag; 1604 } else { 1605 my $newValueHashPt = shift; 1606 if ($$self{NEW_VALUE}) { 1607 my ($group, $tagInfo); 1608 if (ref $tag) { 1609 $nvHash = $self->GetNewValueHash($tag); 1610 } elsif (defined($tagInfo = $Image::ExifTool::Extra{$tag}) and 1611 $$tagInfo{Writable}) 1612 { 1613 $nvHash = $self->GetNewValueHash($tagInfo); 1614 } else { 1615 # separate group from tag name 1616 my @groups; 1617 @groups = split ':', $1 if $tag =~ s/(.*)://; 1618 my @tagInfoList = FindTagInfo($tag); 1619 # decide which tag we want 1620GNV_TagInfo: foreach $tagInfo (@tagInfoList) { 1621 my $nvh = $self->GetNewValueHash($tagInfo) or next; 1622 # select tag in specified group(s) if necessary 1623 foreach (@groups) { 1624 next if $_ eq $$nvh{WriteGroup}; 1625 my @grps = $self->GetGroup($tagInfo); 1626 if ($grps[0] eq $$nvh{WriteGroup}) { 1627 # check family 1 group only if WriteGroup is not specific 1628 next if $_ eq $grps[1]; 1629 } else { 1630 # otherwise check family 0 group 1631 next if $_ eq $grps[0]; 1632 } 1633 # also check family 7 1634 next if /^ID-(.*)/i and IsSameID($$tagInfo{TagID}, $1); 1635 # step to next entry in list 1636 $nvh = $$nvh{Next} or next GNV_TagInfo; 1637 } 1638 $nvHash = $nvh; 1639 # give priority to the one we are creating 1640 last if defined $$nvHash{IsCreating}; 1641 } 1642 } 1643 } 1644 # return new value hash if requested 1645 $newValueHashPt and $$newValueHashPt = $nvHash; 1646 } 1647 unless ($nvHash and $$nvHash{Value}) { 1648 return () if wantarray; # return empty list 1649 return undef; 1650 } 1651 my $vals = $$nvHash{Value}; 1652 # do inverse raw conversion if necessary 1653 # - must also check after doing a Shift 1654 if ($$nvHash{TagInfo}{RawConvInv} or $$nvHash{Shift}) { 1655 my @copyVals = @$vals; # modify a copy of the values 1656 $vals = \@copyVals; 1657 my $tagInfo = $$nvHash{TagInfo}; 1658 my $conv = $$tagInfo{RawConvInv}; 1659 my $table = $$tagInfo{Table}; 1660 my ($val, $checkProc); 1661 $checkProc = $$table{CHECK_PROC} if $$nvHash{Shift} and $table; 1662 local $SIG{'__WARN__'} = \&SetWarning; 1663 undef $evalWarning; 1664 foreach $val (@$vals) { 1665 # must check value now if it was shifted 1666 if ($checkProc) { 1667 my $err = &$checkProc($self, $tagInfo, \$val); 1668 if ($err or not defined $val) { 1669 $err or $err = 'Error generating raw value'; 1670 $self->WarnOnce("$err for $$tagInfo{Name}"); 1671 @$vals = (); 1672 last; 1673 } 1674 next unless $conv; 1675 } else { 1676 last unless $conv; 1677 } 1678 # do inverse raw conversion 1679 if (ref($conv) eq 'CODE') { 1680 $val = &$conv($val, $self); 1681 } else { 1682 #### eval RawConvInv ($self, $val, $tagInfo) 1683 $val = eval $conv; 1684 $@ and $evalWarning = $@; 1685 } 1686 if ($evalWarning) { 1687 # an empty warning ("\n") ignores tag with no error 1688 if ($evalWarning ne "\n") { 1689 my $err = CleanWarning() . " in $$tagInfo{Name} (RawConvInv)"; 1690 $self->WarnOnce($err); 1691 } 1692 @$vals = (); 1693 last; 1694 } 1695 } 1696 } 1697 # return our value(s) 1698 return @$vals if wantarray; 1699 return $$vals[0]; 1700} 1701 1702#------------------------------------------------------------------------------ 1703# Return the total number of new values set 1704# Inputs: 0) ExifTool object reference 1705# Returns: Scalar context) Number of new values that have been set (incl pseudo) 1706# List context) Number of new values (incl pseudo), number of "pseudo" values 1707# ("pseudo" values are those which don't require rewriting the file to change) 1708sub CountNewValues($) 1709{ 1710 my $self = shift; 1711 my $newVal = $$self{NEW_VALUE}; 1712 my ($num, $pseudo) = (0, 0); 1713 if ($newVal) { 1714 $num = scalar keys %$newVal; 1715 my $nv; 1716 foreach $nv (values %$newVal) { 1717 my $tagInfo = $$nv{TagInfo}; 1718 # don't count tags that don't write anything 1719 $$tagInfo{WriteNothing} and --$num, next; 1720 # count the number of pseudo tags included 1721 $$tagInfo{WritePseudo} and ++$pseudo; 1722 } 1723 } 1724 $num += scalar keys %{$$self{DEL_GROUP}}; 1725 return $num unless wantarray; 1726 return ($num, $pseudo); 1727} 1728 1729#------------------------------------------------------------------------------ 1730# Save new values for subsequent restore 1731# Inputs: 0) ExifTool object reference 1732# Returns: Number of times new values have been saved 1733# Notes: increments SAVE_COUNT flag each time routine is called 1734sub SaveNewValues($) 1735{ 1736 my $self = shift; 1737 my $newValues = $$self{NEW_VALUE}; 1738 my $saveCount = ++$$self{SAVE_COUNT}; 1739 my $key; 1740 foreach $key (keys %$newValues) { 1741 my $nvHash = $$newValues{$key}; 1742 while ($nvHash) { 1743 # set Save count if not done already 1744 $$nvHash{Save} or $$nvHash{Save} = $saveCount; 1745 $nvHash = $$nvHash{Next}; 1746 } 1747 } 1748 # initialize hash for saving overwritten new values 1749 $$self{SAVE_NEW_VALUE} = { }; 1750 # make a copy of the delete group hash 1751 my %delGrp = %{$$self{DEL_GROUP}}; 1752 $$self{SAVE_DEL_GROUP} = \%delGrp; 1753 return $saveCount; 1754} 1755 1756#------------------------------------------------------------------------------ 1757# Restore new values to last saved state 1758# Inputs: 0) ExifTool object reference 1759# Notes: Restores saved new values, but currently doesn't restore them in the 1760# original order, so there may be some minor side-effects when restoring tags 1761# with overlapping groups. eg) XMP:Identifier, XMP-dc:Identifier 1762# Also, this doesn't do the right thing for list-type tags which accumulate 1763# values across a save point 1764sub RestoreNewValues($) 1765{ 1766 my $self = shift; 1767 my $newValues = $$self{NEW_VALUE}; 1768 my $savedValues = $$self{SAVE_NEW_VALUE}; 1769 my $key; 1770 # 1) remove any new values which don't have the Save flag set 1771 if ($newValues) { 1772 my @keys = keys %$newValues; 1773 foreach $key (@keys) { 1774 my $lastHash; 1775 my $nvHash = $$newValues{$key}; 1776 while ($nvHash) { 1777 if ($$nvHash{Save}) { 1778 $lastHash = $nvHash; 1779 } else { 1780 # remove this entry from the list 1781 if ($lastHash) { 1782 $$lastHash{Next} = $$nvHash{Next}; 1783 } elsif ($$nvHash{Next}) { 1784 $$newValues{$key} = $$nvHash{Next}; 1785 } else { 1786 delete $$newValues{$key}; 1787 } 1788 } 1789 $nvHash = $$nvHash{Next}; 1790 } 1791 } 1792 } 1793 # 2) restore saved new values 1794 if ($savedValues) { 1795 $newValues or $newValues = $$self{NEW_VALUE} = { }; 1796 foreach $key (keys %$savedValues) { 1797 if ($$newValues{$key}) { 1798 # add saved values to end of list 1799 my $nvHash = LastInList($$newValues{$key}); 1800 $$nvHash{Next} = $$savedValues{$key}; 1801 } else { 1802 $$newValues{$key} = $$savedValues{$key}; 1803 } 1804 } 1805 $$self{SAVE_NEW_VALUE} = { }; # reset saved new values 1806 } 1807 # 3) restore delete groups 1808 my %delGrp = %{$$self{SAVE_DEL_GROUP}}; 1809 $$self{DEL_GROUP} = \%delGrp; 1810} 1811 1812#------------------------------------------------------------------------------ 1813# Set filesystem time from from FileModifyDate or FileCreateDate tag 1814# Inputs: 0) ExifTool object reference, 1) file name or file ref 1815# 2) time (-M or -C) of original file (used for shift; obtained from file if not given) 1816# 3) tag name to write (undef for 'FileModifyDate') 1817# 4) flag set if argument 2 has already been converted to Unix seconds 1818# Returns: 1=time changed OK, 0=nothing done, -1=error setting time 1819# (increments CHANGED flag and sets corresponding WRITTEN tag) 1820sub SetFileModifyDate($$;$$$) 1821{ 1822 my ($self, $file, $originalTime, $tag, $isUnixTime) = @_; 1823 my $nvHash; 1824 $tag = 'FileModifyDate' unless defined $tag; 1825 my $val = $self->GetNewValue($tag, \$nvHash); 1826 return 0 unless defined $val; 1827 my $isOverwriting = $self->IsOverwriting($nvHash); 1828 return 0 unless $isOverwriting; 1829 # can currently only set creation date on Windows systems 1830 # (and Mac now too, but that is handled with the MacOS tags) 1831 return 0 if $tag eq 'FileCreateDate' and $^O ne 'MSWin32'; 1832 if ($isOverwriting < 0) { # are we shifting time? 1833 # use original time of this file if not specified 1834 unless (defined $originalTime) { 1835 my ($aTime, $mTime, $cTime) = $self->GetFileTime($file); 1836 $originalTime = ($tag eq 'FileCreateDate') ? $cTime : $mTime; 1837 return 0 unless defined $originalTime; 1838 $isUnixTime = 1; 1839 } 1840 $originalTime = int($^T - $originalTime*(24*3600) + 0.5) unless $isUnixTime; 1841 return 0 unless $self->IsOverwriting($nvHash, $originalTime); 1842 $val = $$nvHash{Value}[0]; # get shifted value 1843 } 1844 my ($aTime, $mTime, $cTime); 1845 if ($tag eq 'FileCreateDate') { 1846 eval { require Win32::API } or $self->WarnOnce("Install Win32::API to set $tag"), return -1; 1847 eval { require Win32API::File } or $self->WarnOnce("Install Win32API::File to set $tag"), return -1; 1848 $cTime = $val; 1849 } else { 1850 $aTime = $mTime = $val; 1851 } 1852 $self->SetFileTime($file, $aTime, $mTime, $cTime, 1) or $self->Warn("Error setting $tag"), return -1; 1853 ++$$self{CHANGED}; 1854 $$self{WRITTEN}{$tag} = $val; # remember that we wrote this tag 1855 $self->VerboseValue("+ $tag", $val); 1856 return 1; 1857} 1858 1859#------------------------------------------------------------------------------ 1860# Change file name and/or directory from FileName and Directory tags 1861# Inputs: 0) ExifTool object reference, 1) current file name (including path) 1862# 2) new name (or undef to build from FileName and Directory tags) 1863# 3) option: 'HardLink'/'SymLink' to create hard/symbolic link instead of renaming 1864# 'Test' to only print new file name 1865# 4) 0 to indicate that a file will no longer exist (used for 'Test' only) 1866# Returns: 1=name changed OK, 0=nothing changed, -1=error changing name 1867# (and increments CHANGED flag if filename changed) 1868# Notes: Will not overwrite existing file. Creates directories as necessary. 1869sub SetFileName($$;$$$) 1870{ 1871 my ($self, $file, $newName, $opt, $usedFlag) = @_; 1872 my ($nvHash, $doName, $doDir); 1873 1874 $opt or $opt = ''; 1875 # determine the new file name 1876 unless (defined $newName) { 1877 if ($opt) { 1878 if ($opt eq 'HardLink' or $opt eq 'Link') { 1879 $newName = $self->GetNewValue('HardLink'); 1880 } elsif ($opt eq 'SymLink') { 1881 $newName = $self->GetNewValue('SymLink'); 1882 } elsif ($opt eq 'Test') { 1883 $newName = $self->GetNewValue('TestName'); 1884 } 1885 return 0 unless defined $newName; 1886 } else { 1887 my $filename = $self->GetNewValue('FileName', \$nvHash); 1888 $doName = 1 if defined $filename and $self->IsOverwriting($nvHash, $file); 1889 my $dir = $self->GetNewValue('Directory', \$nvHash); 1890 $doDir = 1 if defined $dir and $self->IsOverwriting($nvHash, $file); 1891 return 0 unless $doName or $doDir; # nothing to do 1892 if ($doName) { 1893 $newName = GetNewFileName($file, $filename); 1894 $newName = GetNewFileName($newName, $dir) if $doDir; 1895 } else { 1896 $newName = GetNewFileName($file, $dir); 1897 } 1898 } 1899 } 1900 # validate new file name in Windows 1901 if ($^O eq 'MSWin32') { 1902 if ($newName =~ /[\0-\x1f<>"|*]/) { 1903 $self->Warn('New file name not allowed in Windows (contains reserved characters)'); 1904 return -1; 1905 } 1906 if ($newName =~ /:/ and $newName !~ /^[A-Z]:[^:]*$/i) { 1907 $self->Warn("New file name not allowed in Windows (contains ':')"); 1908 return -1; 1909 } 1910 if ($newName =~ /\?/ and $newName !~ m{^[\\/]{2}\?[\\/][^?]*$}) { 1911 $self->Warn("New file name not allowed in Windows (contains '?')"); 1912 return -1; 1913 } 1914 if ($newName =~ m{(^|[\\/])(CON|PRN|AUX|NUL|COM[1-9]|LPT[1-9])(\.[^.]*)?$}i) { 1915 $self->Warn('New file name not allowed in Windows (reserved device name)'); 1916 return -1; 1917 } 1918 if ($newName =~ /([. ])$/) { 1919 $self->Warn("New file name not recommended for Windows (ends with '${1}')", 2) and return -1; 1920 } 1921 if (length $newName > 259 and $newName !~ /\?/) { 1922 $self->Warn('New file name not recommended for Windows (exceeds 260 chars)', 2) and return -1; 1923 } 1924 } else { 1925 $newName =~ tr/\0//d; # make sure name doesn't contain nulls 1926 } 1927 # protect against empty file name 1928 length $newName or $self->Warn('New file name is empty'), return -1; 1929 # don't replace existing file 1930 if ($self->Exists($newName) and (not defined $usedFlag or $usedFlag)) { 1931 if ($file ne $newName or $opt =~ /Link$/) { 1932 # allow for case-insensitive filesystem 1933 if ($opt =~ /Link$/ or not $self->IsSameFile($file, $newName)) { 1934 $self->Warn("File '${newName}' already exists"); 1935 return -1; 1936 } 1937 } else { 1938 $self->Warn('File name is unchanged'); 1939 return 0; 1940 } 1941 } 1942 if ($opt eq 'Test') { 1943 my $out = $$self{OPTIONS}{TextOut}; 1944 print $out "'${file}' --> '${newName}'\n"; 1945 return 1; 1946 } 1947 # create directory for new file if necessary 1948 my $result; 1949 if (($result = $self->CreateDirectory($newName)) != 0) { 1950 if ($result < 0) { 1951 $self->Warn("Error creating directory for '${newName}'"); 1952 return -1; 1953 } 1954 $self->VPrint(0, "Created directory for '${newName}'\n"); 1955 } 1956 if ($opt eq 'HardLink' or $opt eq 'Link') { 1957 unless (link $file, $newName) { 1958 $self->Warn("Error creating hard link '${newName}'"); 1959 return -1; 1960 } 1961 ++$$self{CHANGED}; 1962 $self->VerboseValue('+ HardLink', $newName); 1963 return 1; 1964 } elsif ($opt eq 'SymLink') { 1965 $^O eq 'MSWin32' and $self->Warn('SymLink not supported in Windows'), return -1; 1966 $newName =~ s(^\./)(); # remove leading "./" from link name if it exists 1967 # path to linked file must be relative to the $newName directory, but $file 1968 # is relative to the current directory, so convert it to an absolute path 1969 # if using a relative directory and $newName isn't in the current directory 1970 if ($file !~ m(^/) and $newName =~ m(/)) { 1971 unless (eval { require Cwd }) { 1972 $self->Warn('Install Cwd to make symlinks to other directories'); 1973 return -1; 1974 } 1975 $file = eval { Cwd::abs_path($file) }; 1976 unless (defined $file) { 1977 $self->Warn('Error in Cwd::abs_path when creating symlink'); 1978 return -1; 1979 } 1980 } 1981 unless (eval { symlink $file, $newName } ) { 1982 $self->Warn("Error creating symbolic link '${newName}'"); 1983 return -1; 1984 } 1985 ++$$self{CHANGED}; 1986 $self->VerboseValue('+ SymLink', $newName); 1987 return 1; 1988 } 1989 # attempt to rename the file 1990 unless ($self->Rename($file, $newName)) { 1991 local (*EXIFTOOL_SFN_IN, *EXIFTOOL_SFN_OUT); 1992 # renaming didn't work, so copy the file instead 1993 unless ($self->Open(\*EXIFTOOL_SFN_IN, $file)) { 1994 $self->Error("Error opening '${file}'"); 1995 return -1; 1996 } 1997 unless ($self->Open(\*EXIFTOOL_SFN_OUT, $newName, '>')) { 1998 close EXIFTOOL_SFN_IN; 1999 $self->Error("Error creating '${newName}'"); 2000 return -1; 2001 } 2002 binmode EXIFTOOL_SFN_IN; 2003 binmode EXIFTOOL_SFN_OUT; 2004 my ($buff, $err); 2005 while (read EXIFTOOL_SFN_IN, $buff, 65536) { 2006 print EXIFTOOL_SFN_OUT $buff or $err = 1; 2007 } 2008 close EXIFTOOL_SFN_OUT or $err = 1; 2009 close EXIFTOOL_SFN_IN; 2010 if ($err) { 2011 $self->Unlink($newName); # erase bad output file 2012 $self->Error("Error writing '${newName}'"); 2013 return -1; 2014 } 2015 # preserve modification time 2016 my ($aTime, $mTime, $cTime) = $self->GetFileTime($file); 2017 $self->SetFileTime($newName, $aTime, $mTime, $cTime); 2018 # remove the original file 2019 $self->Unlink($file) or $self->Warn('Error removing old file'); 2020 } 2021 $$self{NewName} = $newName; # remember new file name 2022 ++$$self{CHANGED}; 2023 $self->VerboseValue('+ FileName', $newName); 2024 return 1; 2025} 2026 2027#------------------------------------------------------------------------------ 2028# Set file permissions, group/user id and various MDItem tags from new tag values 2029# Inputs: 0) ExifTool ref, 1) file name or glob (must be a name for MDItem tags) 2030# Returns: 1=something was set OK, 0=didn't try, -1=error (and warning set) 2031# Notes: There may be errors even if 1 is returned 2032sub SetSystemTags($$) 2033{ 2034 my ($self, $file) = @_; 2035 my $result = 0; 2036 2037 my $perm = $self->GetNewValue('FilePermissions'); 2038 if (defined $perm) { 2039 if (eval { chmod($perm & 07777, $file) }) { 2040 $self->VerboseValue('+ FilePermissions', $perm); 2041 $result = 1; 2042 } else { 2043 $self->WarnOnce('Error setting FilePermissions'); 2044 $result = -1; 2045 } 2046 } 2047 my $uid = $self->GetNewValue('FileUserID'); 2048 my $gid = $self->GetNewValue('FileGroupID'); 2049 if (defined $uid or defined $gid) { 2050 defined $uid or $uid = -1; 2051 defined $gid or $gid = -1; 2052 if (eval { chown($uid, $gid, $file) }) { 2053 $self->VerboseValue('+ FileUserID', $uid) if $uid >= 0; 2054 $self->VerboseValue('+ FileGroupID', $gid) if $gid >= 0; 2055 $result = 1; 2056 } else { 2057 $self->WarnOnce('Error setting FileGroup/UserID'); 2058 $result = -1 unless $result; 2059 } 2060 } 2061 my $tag; 2062 foreach $tag (@writableMacOSTags) { 2063 my $nvHash; 2064 my $val = $self->GetNewValue($tag, \$nvHash); 2065 next unless $nvHash; 2066 if ($^O eq 'darwin') { 2067 ref $file and $self->Warn('Setting MDItem tags requires a file name'), last; 2068 require Image::ExifTool::MacOS; 2069 my $res = Image::ExifTool::MacOS::SetMacOSTags($self, $file, \@writableMacOSTags); 2070 $result = $res if $res == 1 or not $result; 2071 last; 2072 } elsif ($tag ne 'FileCreateDate') { 2073 $self->WarnOnce('Can only set MDItem tags on OS X'); 2074 last; 2075 } 2076 } 2077 return $result; 2078} 2079 2080#------------------------------------------------------------------------------ 2081# Write information back to file 2082# Inputs: 0) ExifTool object reference, 2083# 1) input filename, file ref, RAF ref, or scalar ref (or '' or undef to create from scratch) 2084# 2) output filename, file ref, or scalar ref (or undef to overwrite) 2085# 3) optional output file type (required only if input file is not specified 2086# and output file is a reference) 2087# Returns: 1=file written OK, 2=file written but no changes made, 0=file write error 2088sub WriteInfo($$;$$) 2089{ 2090 local ($_, *EXIFTOOL_FILE2, *EXIFTOOL_OUTFILE); 2091 my ($self, $infile, $outfile, $outType) = @_; 2092 my (@fileTypeList, $fileType, $tiffType, $hdr, $seekErr, $type, $tmpfile); 2093 my ($inRef, $outRef, $closeIn, $closeOut, $outPos, $outBuff, $eraseIn, $raf, $fileExt); 2094 my ($hardLink, $symLink, $testName); 2095 my $oldRaf = $$self{RAF}; 2096 my $rtnVal = 0; 2097 2098 # initialize member variables 2099 $self->Init(); 2100 $$self{IsWriting} = 1; 2101 2102 # first, save original file modify date if necessary 2103 # (do this now in case we are modifying file in place and shifting date) 2104 my ($nvHash, $nvHash2, $originalTime, $createTime); 2105 my $setModDate = defined $self->GetNewValue('FileModifyDate', \$nvHash); 2106 my $setCreateDate = defined $self->GetNewValue('FileCreateDate', \$nvHash2); 2107 my ($aTime, $mTime, $cTime); 2108 if ($setModDate and $self->IsOverwriting($nvHash) < 0 and 2109 defined $infile and ref $infile ne 'SCALAR') 2110 { 2111 ($aTime, $mTime, $cTime) = $self->GetFileTime($infile); 2112 $originalTime = $mTime; 2113 } 2114 if ($setCreateDate and $self->IsOverwriting($nvHash2) < 0 and 2115 defined $infile and ref $infile ne 'SCALAR') 2116 { 2117 ($aTime, $mTime, $cTime) = $self->GetFileTime($infile) unless defined $cTime; 2118 $createTime = $cTime; 2119 } 2120# 2121# do quick in-place change of file dir/name or date if that is all we are doing 2122# 2123 my ($numNew, $numPseudo) = $self->CountNewValues(); 2124 if (not defined $outfile and defined $infile) { 2125 $hardLink = $self->GetNewValue('HardLink'); 2126 $symLink = $self->GetNewValue('SymLink'); 2127 $testName = $self->GetNewValue('TestName'); 2128 undef $hardLink if defined $hardLink and not length $hardLink; 2129 undef $symLink if defined $symLink and not length $symLink; 2130 undef $testName if defined $testName and not length $testName; 2131 my $newFileName = $self->GetNewValue('FileName', \$nvHash); 2132 my $newDir = $self->GetNewValue('Directory'); 2133 if (defined $newDir and length $newDir) { 2134 $newDir .= '/' unless $newDir =~ m{/$}; 2135 } else { 2136 undef $newDir; 2137 } 2138 if ($numNew == $numPseudo) { 2139 $rtnVal = 2; 2140 if ((defined $newFileName or defined $newDir) and not ref $infile) { 2141 my $result = $self->SetFileName($infile); 2142 if ($result > 0) { 2143 $infile = $$self{NewName}; # file name changed 2144 $rtnVal = 1; 2145 } elsif ($result < 0) { 2146 return 0; # don't try to do anything else 2147 } 2148 } 2149 if (not ref $infile or UNIVERSAL::isa($infile,'GLOB')) { 2150 $self->SetFileModifyDate($infile) > 0 and $rtnVal = 1 if $setModDate; 2151 $self->SetFileModifyDate($infile, undef, 'FileCreateDate') > 0 and $rtnVal = 1 if $setCreateDate; 2152 $self->SetSystemTags($infile) > 0 and $rtnVal = 1; 2153 } 2154 if (defined $hardLink or defined $symLink or defined $testName) { 2155 $hardLink and $self->SetFileName($infile, $hardLink, 'HardLink') and $rtnVal = 1; 2156 $symLink and $self->SetFileName($infile, $symLink, 'SymLink') and $rtnVal = 1; 2157 $testName and $self->SetFileName($infile, $testName, 'Test') and $rtnVal = 1; 2158 } 2159 return $rtnVal; 2160 } elsif (defined $newFileName and length $newFileName) { 2161 # can't simply rename file, so just set the output name if new FileName 2162 # --> in this case, must erase original copy 2163 if (ref $infile) { 2164 $outfile = $newFileName; 2165 # can't delete original 2166 } elsif ($self->IsOverwriting($nvHash, $infile)) { 2167 $outfile = GetNewFileName($infile, $newFileName); 2168 $eraseIn = 1; # delete original 2169 } 2170 } 2171 # set new directory if specified 2172 if (defined $newDir) { 2173 $outfile = $infile unless defined $outfile or ref $infile; 2174 if (defined $outfile) { 2175 $outfile = GetNewFileName($outfile, $newDir); 2176 $eraseIn = 1 unless ref $infile; 2177 } 2178 } 2179 } 2180# 2181# set up input file 2182# 2183 if (ref $infile) { 2184 $inRef = $infile; 2185 if (UNIVERSAL::isa($inRef,'GLOB')) { 2186 seek($inRef, 0, 0); # make sure we are at the start of the file 2187 } elsif (UNIVERSAL::isa($inRef,'File::RandomAccess')) { 2188 $inRef->Seek(0); 2189 $raf = $inRef; 2190 } elsif ($] >= 5.006 and (eval { require Encode; Encode::is_utf8($$inRef) } or $@)) { 2191 # convert image data from UTF-8 to character stream if necessary 2192 my $buff = $@ ? pack('C*',unpack($] < 5.010000 ? 'U0C*' : 'C0C*',$$inRef)) : Encode::encode('utf8',$$inRef); 2193 if (defined $outfile) { 2194 $inRef = \$buff; 2195 } else { 2196 $$inRef = $buff; 2197 } 2198 } 2199 } elsif (defined $infile and $infile ne '') { 2200 # write to a temporary file if no output file given 2201 $outfile = $tmpfile = "${infile}_exiftool_tmp" unless defined $outfile; 2202 if ($self->Open(\*EXIFTOOL_FILE2, $infile)) { 2203 $fileExt = GetFileExtension($infile); 2204 $fileType = GetFileType($infile); 2205 @fileTypeList = GetFileType($infile); 2206 $tiffType = $$self{FILE_EXT} = GetFileExtension($infile); 2207 $self->VPrint(0, "Rewriting $infile...\n"); 2208 $inRef = \*EXIFTOOL_FILE2; 2209 $closeIn = 1; # we must close the file since we opened it 2210 } else { 2211 $self->Error('Error opening file'); 2212 return 0; 2213 } 2214 } elsif (not defined $outfile) { 2215 $self->Error("WriteInfo(): Must specify infile or outfile\n"); 2216 return 0; 2217 } else { 2218 # create file from scratch 2219 $outType = GetFileExtension($outfile) unless $outType or ref $outfile; 2220 if (CanCreate($outType)) { 2221 if ($$self{OPTIONS}{WriteMode} =~ /g/i) { 2222 $fileType = $tiffType = $outType; # use output file type if no input file 2223 $infile = "$fileType file"; # make bogus file name 2224 $self->VPrint(0, "Creating $infile...\n"); 2225 $inRef = \ ''; # set $inRef to reference to empty data 2226 } else { 2227 $self->Error("Not creating new $outType file (disallowed by WriteMode)"); 2228 return 0; 2229 } 2230 } elsif ($outType) { 2231 $self->Error("Can't create $outType files"); 2232 return 0; 2233 } else { 2234 $self->Error("Can't create file (unknown type)"); 2235 return 0; 2236 } 2237 } 2238 unless (@fileTypeList) { 2239 if ($fileType) { 2240 @fileTypeList = ( $fileType ); 2241 } else { 2242 @fileTypeList = @fileTypes; 2243 $tiffType = 'TIFF'; 2244 } 2245 } 2246# 2247# set up output file 2248# 2249 if (ref $outfile) { 2250 $outRef = $outfile; 2251 if (UNIVERSAL::isa($outRef,'GLOB')) { 2252 binmode($outRef); 2253 $outPos = tell($outRef); 2254 } else { 2255 # initialize our output buffer if necessary 2256 defined $$outRef or $$outRef = ''; 2257 $outPos = length($$outRef); 2258 } 2259 } elsif (not defined $outfile) { 2260 # editing in place, so write to memory first 2261 # (only when infile is a file ref or scalar ref) 2262 if ($raf) { 2263 $self->Error("Can't edit File::RandomAccess object in place"); 2264 return 0; 2265 } 2266 $outBuff = ''; 2267 $outRef = \$outBuff; 2268 $outPos = 0; 2269 } elsif ($self->Exists($outfile)) { 2270 $self->Error("File already exists: $outfile"); 2271 } elsif ($self->Open(\*EXIFTOOL_OUTFILE, $outfile, '>')) { 2272 $outRef = \*EXIFTOOL_OUTFILE; 2273 $closeOut = 1; # we must close $outRef 2274 binmode($outRef); 2275 $outPos = 0; 2276 } else { 2277 my $tmp = $tmpfile ? ' temporary' : ''; 2278 $self->Error("Error creating$tmp file: $outfile"); 2279 } 2280# 2281# write the file 2282# 2283 until ($$self{VALUE}{Error}) { 2284 # create random access file object (disable seek test in case of straight copy) 2285 $raf or $raf = new File::RandomAccess($inRef, 1); 2286 $raf->BinMode(); 2287 if ($numNew == $numPseudo) { 2288 $rtnVal = 1; 2289 # just do a straight copy of the file (no "real" tags are being changed) 2290 my $buff; 2291 while ($raf->Read($buff, 65536)) { 2292 Write($outRef, $buff) or $rtnVal = -1, last; 2293 } 2294 last; 2295 } elsif (not ref $infile and ($infile eq '-' or $infile =~ /\|$/)) { 2296 # patch for Windows command shell pipe 2297 $$raf{TESTED} = -1; # force buffering 2298 } else { 2299 $raf->SeekTest(); 2300 } 2301 # $raf->Debug() and warn " RAF debugging enabled!\n"; 2302 my $inPos = $raf->Tell(); 2303 $$self{RAF} = $raf; 2304 my %dirInfo = ( 2305 RAF => $raf, 2306 OutFile => $outRef, 2307 ); 2308 $raf->Read($hdr, 1024) or $hdr = ''; 2309 $raf->Seek($inPos, 0) or $seekErr = 1; 2310 my $wrongType; 2311 until ($seekErr) { 2312 $type = shift @fileTypeList; 2313 # do quick test to see if this is the right file type 2314 if ($magicNumber{$type} and length($hdr) and $hdr !~ /^$magicNumber{$type}/s) { 2315 next if @fileTypeList; 2316 $wrongType = 1; 2317 last; 2318 } 2319 # save file type in member variable 2320 $dirInfo{Parent} = $$self{FILE_TYPE} = $$self{PATH}[0] = $type; 2321 # determine which directories we must write for this file type 2322 $self->InitWriteDirs($type); 2323 if ($type eq 'JPEG' or $type eq 'EXV') { 2324 $rtnVal = $self->WriteJPEG(\%dirInfo); 2325 } elsif ($type eq 'TIFF') { 2326 # disallow writing of some TIFF-based RAW images: 2327 if (grep /^$tiffType$/, @{$noWriteFile{TIFF}}) { 2328 $fileType = $tiffType; 2329 undef $rtnVal; 2330 } else { 2331 if ($tiffType eq 'FFF') { 2332 # (see https://exiftool.org/forum/index.php?topic=10848.0) 2333 $self->Error('Phocus may not properly update previews of edited FFF images', 1); 2334 } 2335 $dirInfo{Parent} = $tiffType; 2336 $rtnVal = $self->ProcessTIFF(\%dirInfo); 2337 } 2338 } elsif (exists $writableType{$type}) { 2339 my ($module, $func); 2340 if (ref $writableType{$type} eq 'ARRAY') { 2341 $module = $writableType{$type}[0] || $type; 2342 $func = $writableType{$type}[1]; 2343 } else { 2344 $module = $writableType{$type} || $type; 2345 } 2346 require "Image/ExifTool/$module.pm"; 2347 $func = "Image::ExifTool::${module}::" . ($func || "Process$type"); 2348 no strict 'refs'; 2349 $rtnVal = &$func($self, \%dirInfo); 2350 use strict 'refs'; 2351 } elsif ($type eq 'ORF' or $type eq 'RAW') { 2352 $rtnVal = $self->ProcessTIFF(\%dirInfo); 2353 } elsif ($type eq 'EXIF') { 2354 # go through WriteDirectory so block writes, etc are handled 2355 my $tagTablePtr = GetTagTable('Image::ExifTool::Exif::Main'); 2356 my $buff = $self->WriteDirectory(\%dirInfo, $tagTablePtr, \&WriteTIFF); 2357 if (defined $buff) { 2358 $rtnVal = Write($outRef, $buff) ? 1 : -1; 2359 } else { 2360 $rtnVal = 0; 2361 } 2362 } else { 2363 undef $rtnVal; # flag that we don't write this type of file 2364 } 2365 # all done unless we got the wrong type 2366 last if $rtnVal; 2367 last unless @fileTypeList; 2368 # seek back to original position in files for next try 2369 $raf->Seek($inPos, 0) or $seekErr = 1, last; 2370 if (UNIVERSAL::isa($outRef,'GLOB')) { 2371 seek($outRef, 0, $outPos); 2372 } else { 2373 $$outRef = substr($$outRef, 0, $outPos); 2374 } 2375 } 2376 # print file format errors 2377 unless ($rtnVal) { 2378 my $err; 2379 if ($seekErr) { 2380 $err = 'Error seeking in file'; 2381 } elsif ($fileType and defined $rtnVal) { 2382 if ($$self{VALUE}{Error}) { 2383 # existing error message will do 2384 } elsif ($fileType eq 'RAW') { 2385 $err = 'Writing this type of RAW file is not supported'; 2386 } else { 2387 if ($wrongType) { 2388 my $type = $fileExt || ($fileType eq 'TIFF' ? $tiffType : $fileType); 2389 $err = "Not a valid $type"; 2390 # do a quick check to see what this file looks like 2391 foreach $type (@fileTypes) { 2392 next unless $magicNumber{$type}; 2393 next unless $hdr =~ /^$magicNumber{$type}/s; 2394 $err .= " (looks more like a $type)"; 2395 last; 2396 } 2397 } else { 2398 $err = 'Format error in file'; 2399 } 2400 } 2401 } elsif ($fileType) { 2402 # get specific type of file from extension 2403 $fileType = GetFileExtension($infile) if $infile and GetFileType($infile); 2404 $err = "Writing of $fileType files is not yet supported"; 2405 } else { 2406 $err = 'Writing of this type of file is not supported'; 2407 } 2408 $self->Error($err) if $err; 2409 $rtnVal = 0; # (in case it was undef) 2410 } 2411 # $raf->Close(); # only used to force debug output 2412 last; # (didn't really want to loop) 2413 } 2414 # don't return success code if any error occurred 2415 if ($rtnVal > 0) { 2416 if ($outType and $type and $outType ne $type) { 2417 my @types = GetFileType($outType); 2418 unless (grep /^$type$/, @types) { 2419 $self->Error("Can't create $outType file from $type"); 2420 $rtnVal = 0; 2421 } 2422 } 2423 if ($rtnVal > 0 and not Tell($outRef) and not $$self{VALUE}{Error}) { 2424 # don't write a file with zero length 2425 if (defined $hdr and length $hdr) { 2426 $type = '<unk>' unless defined $type; 2427 $self->Error("Can't delete all meta information from $type file"); 2428 } else { 2429 $self->Error('Nothing to write'); 2430 } 2431 } 2432 $rtnVal = 0 if $$self{VALUE}{Error}; 2433 } 2434 2435 # rewrite original file in place if required 2436 if (defined $outBuff) { 2437 if ($rtnVal <= 0 or not $$self{CHANGED}) { 2438 # nothing changed, so no need to write $outBuff 2439 } elsif (UNIVERSAL::isa($inRef,'GLOB')) { 2440 my $len = length($outBuff); 2441 my $size; 2442 $rtnVal = -1 unless 2443 seek($inRef, 0, 2) and # seek to the end of file 2444 ($size = tell $inRef) >= 0 and # get the file size 2445 seek($inRef, 0, 0) and # seek back to the start 2446 print $inRef $outBuff and # write the new data 2447 ($len >= $size or # if necessary: 2448 eval { truncate($inRef, $len) }); # shorten output file 2449 } else { 2450 $$inRef = $outBuff; # replace original data 2451 } 2452 $outBuff = ''; # free memory but leave $outBuff defined 2453 } 2454 # close input file if we opened it 2455 if ($closeIn) { 2456 # errors on input file are significant if we edited the file in place 2457 $rtnVal and $rtnVal = -1 unless close($inRef) or not defined $outBuff; 2458 if ($rtnVal > 0) { 2459 # copy Mac OS resource fork if it exists 2460 if ($^O eq 'darwin' and -s "$infile/..namedfork/rsrc") { 2461 if ($$self{DEL_GROUP}{RSRC}) { 2462 $self->VPrint(0,"Deleting Mac OS resource fork\n"); 2463 ++$$self{CHANGED}; 2464 } else { 2465 $self->VPrint(0,"Copying Mac OS resource fork\n"); 2466 my ($buf, $err); 2467 local (*SRC, *DST); 2468 if ($self->Open(\*SRC, "$infile/..namedfork/rsrc")) { 2469 if ($self->Open(\*DST, "$outfile/..namedfork/rsrc", '>')) { 2470 binmode SRC; # (not necessary for Darwin, but let's be thorough) 2471 binmode DST; 2472 while (read SRC, $buf, 65536) { 2473 print DST $buf or $err = 'copying', last; 2474 } 2475 close DST or $err or $err = 'closing'; 2476 } else { 2477 # (this is normal if the destination filesystem isn't Mac OS) 2478 $self->Warn('Error creating Mac OS resource fork'); 2479 } 2480 close SRC; 2481 } else { 2482 $err = 'opening'; 2483 } 2484 $rtnVal = 0 if $err and $self->Error("Error $err Mac OS resource fork", 2); 2485 } 2486 } 2487 # erase input file if renaming while editing information in place 2488 $self->Unlink($infile) or $self->Warn('Error erasing original file') if $eraseIn; 2489 } 2490 } 2491 # close output file if we created it 2492 if ($closeOut) { 2493 # close file and set $rtnVal to -1 if there was an error 2494 $rtnVal and $rtnVal = -1 unless close($outRef); 2495 # erase the output file if we weren't successful 2496 if ($rtnVal <= 0) { 2497 $self->Unlink($outfile); 2498 # else rename temporary file if necessary 2499 } elsif ($tmpfile) { 2500 $self->CopyFileAttrs($infile, $tmpfile); # copy attributes to new file 2501 unless ($self->Rename($tmpfile, $infile)) { 2502 # some filesystems won't overwrite with 'rename', so try erasing original 2503 if (not $self->Unlink($infile)) { 2504 $self->Unlink($tmpfile); 2505 $self->Error('Error renaming temporary file'); 2506 $rtnVal = 0; 2507 } elsif (not $self->Rename($tmpfile, $infile)) { 2508 $self->Error('Error renaming temporary file after deleting original'); 2509 $rtnVal = 0; 2510 } 2511 } 2512 # the output file should now have the name of the original infile 2513 $outfile = $infile if $rtnVal > 0; 2514 } 2515 } 2516 # set filesystem attributes if requested (and if possible!) 2517 if ($rtnVal > 0 and ($closeOut or (defined $outBuff and ($closeIn or UNIVERSAL::isa($infile,'GLOB'))))) { 2518 my $target = $closeOut ? $outfile : $infile; 2519 # set file permissions if requested 2520 ++$$self{CHANGED} if $self->SetSystemTags($target) > 0; 2521 if ($closeIn) { # (no use setting file times unless the input file is closed) 2522 ++$$self{CHANGED} if $setModDate and $self->SetFileModifyDate($target, $originalTime, undef, 1) > 0; 2523 # set FileCreateDate if requested (and if possible!) 2524 ++$$self{CHANGED} if $setCreateDate and $self->SetFileModifyDate($target, $createTime, 'FileCreateDate', 1) > 0; 2525 # create hard link if requested and no output filename specified (and if possible!) 2526 ++$$self{CHANGED} if defined $hardLink and $self->SetFileName($target, $hardLink, 'HardLink'); 2527 ++$$self{CHANGED} if defined $symLink and $self->SetFileName($target, $symLink, 'SymLink'); 2528 defined $testName and $self->SetFileName($target, $testName, 'Test'); 2529 } 2530 } 2531 # check for write error and set appropriate error message and return value 2532 if ($rtnVal < 0) { 2533 $self->Error('Error writing output file') unless $$self{VALUE}{Error}; 2534 $rtnVal = 0; # return 0 on failure 2535 } elsif ($rtnVal > 0) { 2536 ++$rtnVal unless $$self{CHANGED}; 2537 } 2538 # set things back to the way they were 2539 $$self{RAF} = $oldRaf; 2540 2541 return $rtnVal; 2542} 2543 2544#------------------------------------------------------------------------------ 2545# Get list of all available tags for specified group 2546# Inputs: 0) optional group name (or string of names separated by colons) 2547# Returns: tag list (sorted alphabetically) 2548# Notes: Can't get tags for specific IFD 2549sub GetAllTags(;$) 2550{ 2551 local $_; 2552 my $group = shift; 2553 my (%allTags, @groups); 2554 @groups = split ':', $group if $group; 2555 2556 my $et = new Image::ExifTool; 2557 LoadAllTables(); # first load all our tables 2558 my @tableNames = keys %allTables; 2559 2560 # loop through all tables and save tag names to %allTags hash 2561 while (@tableNames) { 2562 my $table = GetTagTable(pop @tableNames); 2563 # generate flattened tag names for structure fields if this is an XMP table 2564 if ($$table{GROUPS} and $$table{GROUPS}{0} eq 'XMP') { 2565 Image::ExifTool::XMP::AddFlattenedTags($table); 2566 } 2567 my $tagID; 2568 foreach $tagID (TagTableKeys($table)) { 2569 my @infoArray = GetTagInfoList($table,$tagID); 2570 my $tagInfo; 2571GATInfo: foreach $tagInfo (@infoArray) { 2572 my $tag = $$tagInfo{Name}; 2573 $tag or warn("no name for tag!\n"), next; 2574 # don't list subdirectories unless they are writable 2575 next if $$tagInfo{SubDirectory} and not $$tagInfo{Writable}; 2576 next if $$tagInfo{Hidden}; # ignore hidden tags 2577 if (@groups) { 2578 my @tg = $et->GetGroup($tagInfo); 2579 foreach $group (@groups) { 2580 next GATInfo unless grep /^$group$/i, @tg; 2581 } 2582 } 2583 $allTags{$tag} = 1; 2584 } 2585 } 2586 } 2587 return sort keys %allTags; 2588} 2589 2590#------------------------------------------------------------------------------ 2591# Get list of all writable tags 2592# Inputs: 0) optional group name (or names separated by colons) 2593# Returns: tag list (sorted alphabetically) 2594sub GetWritableTags(;$) 2595{ 2596 local $_; 2597 my $group = shift; 2598 my (%writableTags, @groups); 2599 @groups = split ':', $group if $group; 2600 2601 my $et = new Image::ExifTool; 2602 LoadAllTables(); 2603 my @tableNames = keys %allTables; 2604 2605 while (@tableNames) { 2606 my $tableName = pop @tableNames; 2607 my $table = GetTagTable($tableName); 2608 # generate flattened tag names for structure fields if this is an XMP table 2609 if ($$table{GROUPS} and $$table{GROUPS}{0} eq 'XMP') { 2610 Image::ExifTool::XMP::AddFlattenedTags($table); 2611 } 2612 # attempt to load Write tables if autoloaded 2613 my @parts = split(/::/,$tableName); 2614 if (@parts > 3) { 2615 my $i = $#parts - 1; 2616 $parts[$i] = "Write$parts[$i]"; # add 'Write' before class name 2617 my $module = join('::',@parts[0..$i]); 2618 eval { require $module }; # (fails silently if nothing loaded) 2619 } 2620 my $tagID; 2621 foreach $tagID (TagTableKeys($table)) { 2622 my @infoArray = GetTagInfoList($table,$tagID); 2623 my $tagInfo; 2624GWTInfo: foreach $tagInfo (@infoArray) { 2625 my $tag = $$tagInfo{Name}; 2626 $tag or warn("no name for tag!\n"), next; 2627 my $writable = $$tagInfo{Writable}; 2628 next unless $writable or ($$table{WRITABLE} and 2629 not defined $writable and not $$tagInfo{SubDirectory}); 2630 next if $$tagInfo{Hidden}; # ignore hidden tags 2631 if (@groups) { 2632 my @tg = $et->GetGroup($tagInfo); 2633 foreach $group (@groups) { 2634 next GWTInfo unless grep /^$group$/i, @tg; 2635 } 2636 } 2637 $writableTags{$tag} = 1; 2638 } 2639 } 2640 } 2641 return sort keys %writableTags; 2642} 2643 2644#------------------------------------------------------------------------------ 2645# Get list of all group names 2646# Inputs: 0) [optional] ExifTool ref, 1) Group family number 2647# Returns: List of group names (sorted alphabetically) 2648sub GetAllGroups($;$) 2649{ 2650 local $_; 2651 my $family = shift || 0; 2652 my $self; 2653 ref $family and $self = $family, $family = shift || 0; 2654 2655 $family == 3 and return('Doc#', 'Main'); 2656 $family == 4 and return('Copy#'); 2657 $family == 5 and return('[too many possibilities to list]'); 2658 $family == 6 and return(@Image::ExifTool::Exif::formatName[1..$#Image::ExifTool::Exif::formatName]); 2659 2660 LoadAllTables(); # first load all our tables 2661 2662 my @tableNames = keys %allTables; 2663 2664 # loop through all tag tables and get all group names 2665 my %allGroups; 2666 while (@tableNames) { 2667 my $table = GetTagTable(pop @tableNames); 2668 my ($grps, $grp, $tag, $tagInfo); 2669 $allGroups{$grp} = 1 if ($grps = $$table{GROUPS}) and ($grp = $$grps{$family}); 2670 foreach $tag (TagTableKeys($table)) { 2671 my @infoArray = GetTagInfoList($table, $tag); 2672 if ($family == 7) { 2673 foreach $tagInfo (@infoArray) { 2674 my $id = $$tagInfo{TagID}; 2675 if (not defined $id) { 2676 $id = ''; # (just to be safe) 2677 } elsif ($id =~ /^\d+$/) { 2678 $id = sprintf('0x%x', $id) if $self and $$self{OPTIONS}{HexTagIDs}; 2679 } else { 2680 $id =~ s/([^-_A-Za-z0-9])/sprintf('%.2x',ord $1)/ge; 2681 } 2682 $allGroups{'ID-' . $id} = 1; 2683 } 2684 } else { 2685 foreach $tagInfo (@infoArray) { 2686 next unless ($grps = $$tagInfo{Groups}) and ($grp = $$grps{$family}); 2687 $allGroups{$grp} = 1; 2688 } 2689 } 2690 } 2691 } 2692 delete $allGroups{'*'}; # (not a real group) 2693 return sort keys %allGroups; 2694} 2695 2696#------------------------------------------------------------------------------ 2697# get priority group list for new values 2698# Inputs: 0) ExifTool object reference 2699# Returns: List of group names 2700sub GetNewGroups($) 2701{ 2702 my $self = shift; 2703 return @{$$self{WRITE_GROUPS}}; 2704} 2705 2706#------------------------------------------------------------------------------ 2707# Get list of all deletable group names 2708# Returns: List of group names (sorted alphabetically) 2709sub GetDeleteGroups() 2710{ 2711 return sort @delGroups, @delGroup2; 2712} 2713 2714#------------------------------------------------------------------------------ 2715# Add user-defined tags at run time 2716# Inputs: 0) destination table name, 1) tagID/tagInfo pairs for tags to add 2717# Returns: number of tags added 2718# Notes: will replace existing tags 2719sub AddUserDefinedTags($%) 2720{ 2721 local $_; 2722 my ($tableName, %addTags) = @_; 2723 my $table = GetTagTable($tableName) or return 0; 2724 # add tags to writer lookup 2725 Image::ExifTool::TagLookup::AddTags(\%addTags, $tableName); 2726 my $tagID; 2727 my $num = 0; 2728 foreach $tagID (keys %addTags) { 2729 next if $specialTags{$tagID}; 2730 delete $$table{$tagID}; # delete old entry if it existed 2731 AddTagToTable($table, $tagID, $addTags{$tagID}, 1); 2732 ++$num; 2733 } 2734 return $num; 2735} 2736 2737#============================================================================== 2738# Functions below this are not part of the public API 2739 2740#------------------------------------------------------------------------------ 2741# Maintain backward compatibility for old GetNewValues function name 2742sub GetNewValues($$;$) 2743{ 2744 my ($self, $tag, $nvHashPt) = @_; 2745 return $self->GetNewValue($tag, $nvHashPt); 2746} 2747 2748#------------------------------------------------------------------------------ 2749# Un-escape string according to options settings and clear UTF-8 flag 2750# Inputs: 0) ExifTool ref, 1) string ref or string ref ref 2751# Notes: also de-references SCALAR values 2752sub Sanitize($$) 2753{ 2754 my ($self, $valPt) = @_; 2755 # de-reference SCALAR references 2756 $$valPt = $$$valPt if ref $$valPt eq 'SCALAR'; 2757 # make sure the Perl UTF-8 flag is OFF for the value if perl 5.6 or greater 2758 # (otherwise our byte manipulations get corrupted!!) 2759 if ($] >= 5.006 and (eval { require Encode; Encode::is_utf8($$valPt) } or $@)) { 2760 local $SIG{'__WARN__'} = \&SetWarning; 2761 # repack by hand if Encode isn't available 2762 $$valPt = $@ ? pack('C*',unpack($] < 5.010000 ? 'U0C*' : 'C0C*',$$valPt)) : Encode::encode('utf8',$$valPt); 2763 } 2764 # un-escape value if necessary 2765 if ($$self{OPTIONS}{Escape}) { 2766 # (XMP.pm and HTML.pm were require'd as necessary when option was set) 2767 if ($$self{OPTIONS}{Escape} eq 'XML') { 2768 $$valPt = Image::ExifTool::XMP::UnescapeXML($$valPt); 2769 } elsif ($$self{OPTIONS}{Escape} eq 'HTML') { 2770 $$valPt = Image::ExifTool::HTML::UnescapeHTML($$valPt, $$self{OPTIONS}{Charset}); 2771 } 2772 } 2773} 2774 2775#------------------------------------------------------------------------------ 2776# Apply inverse conversions 2777# Inputs: 0) ExifTool ref, 1) value, 2) tagInfo (or Struct item) ref, 2778# 3) tag name, 4) group 1 name, 5) conversion type (or undef), 2779# 6) [optional] want group ("" for structure field) 2780# Returns: 0) converted value, 1) error string (or undef on success) 2781# Notes: 2782# - uses ExifTool "ConvType" member when conversion type is undef 2783# - conversion types other than 'ValueConv' and 'PrintConv' are treated as 'Raw' 2784sub ConvInv($$$$$;$$) 2785{ 2786 my ($self, $val, $tagInfo, $tag, $wgrp1, $convType, $wantGroup) = @_; 2787 my ($err, $type); 2788 2789 $convType or $convType = $$self{ConvType} || 'PrintConv'; 2790 2791Conv: for (;;) { 2792 if (not defined $type) { 2793 # split value into list if necessary 2794 if ($$tagInfo{List}) { 2795 my $listSplit = $$tagInfo{AutoSplit} || $$self{OPTIONS}{ListSplit}; 2796 if (defined $listSplit and not $$tagInfo{Struct} and 2797 ($wantGroup or not defined $wantGroup)) 2798 { 2799 $listSplit = ',?\s+' if $listSplit eq '1' and $$tagInfo{AutoSplit}; 2800 my @splitVal = split /$listSplit/, $val, -1; 2801 $val = @splitVal > 1 ? \@splitVal : @splitVal ? $splitVal[0] : ''; 2802 } 2803 } 2804 $type = $convType; 2805 } elsif ($type eq 'PrintConv') { 2806 $type = 'ValueConv'; 2807 } else { 2808 # split raw value if necessary 2809 if ($$tagInfo{RawJoin} and $$tagInfo{List} and not ref $val) { 2810 my @splitVal = split ' ', $val; 2811 $val = \@splitVal if @splitVal > 1; 2812 } 2813 # finally, do our value check 2814 my ($err2, $v); 2815 if ($$tagInfo{WriteCheck}) { 2816 #### eval WriteCheck ($self, $tagInfo, $val) 2817 $err2 = eval $$tagInfo{WriteCheck}; 2818 $@ and warn($@), $err2 = 'Error evaluating WriteCheck'; 2819 } 2820 unless ($err2) { 2821 my $table = $$tagInfo{Table}; 2822 if ($table and $$table{CHECK_PROC} and not $$tagInfo{RawConvInv}) { 2823 my $checkProc = $$table{CHECK_PROC}; 2824 if (ref $val eq 'ARRAY') { 2825 # loop through array values 2826 foreach $v (@$val) { 2827 $err2 = &$checkProc($self, $tagInfo, \$v, $convType); 2828 last if $err2; 2829 } 2830 } else { 2831 $err2 = &$checkProc($self, $tagInfo, \$val, $convType); 2832 } 2833 } 2834 } 2835 if (defined $err2) { 2836 if ($err2) { 2837 $err = "$err2 for $wgrp1:$tag"; 2838 $self->VPrint(2, "$err\n"); 2839 undef $val; # value was invalid 2840 } else { 2841 $err = $err2; # empty error (quietly don't write tag) 2842 } 2843 } 2844 last; 2845 } 2846 my $conv = $$tagInfo{$type}; 2847 my $convInv = $$tagInfo{"${type}Inv"}; 2848 # nothing to do at this level if no conversion defined 2849 next unless defined $conv or defined $convInv; 2850 2851 my (@valList, $index, $convList, $convInvList); 2852 if (ref $val eq 'ARRAY') { 2853 # handle ValueConv of ListSplit and AutoSplit values 2854 @valList = @$val; 2855 $val = $valList[$index = 0]; 2856 } elsif (ref $conv eq 'ARRAY' or ref $convInv eq 'ARRAY') { 2857 # handle conversion lists 2858 @valList = split /$listSep{$type}/, $val; 2859 $val = $valList[$index = 0]; 2860 if (ref $conv eq 'ARRAY') { 2861 $convList = $conv; 2862 $conv = $$conv[0]; 2863 } 2864 if (ref $convInv eq 'ARRAY') { 2865 $convInvList = $convInv; 2866 $convInv = $$convInv[0]; 2867 } 2868 } 2869 # loop through multiple values if necessary 2870 for (;;) { 2871 if ($convInv) { 2872 # capture eval warnings too 2873 local $SIG{'__WARN__'} = \&SetWarning; 2874 undef $evalWarning; 2875 if (ref($convInv) eq 'CODE') { 2876 $val = &$convInv($val, $self); 2877 } else { 2878 #### eval PrintConvInv/ValueConvInv ($val, $self, $wantGroup) 2879 $val = eval $convInv; 2880 $@ and $evalWarning = $@; 2881 } 2882 if ($evalWarning) { 2883 # an empty warning ("\n") ignores tag with no error 2884 if ($evalWarning eq "\n") { 2885 $err = '' unless defined $err; 2886 } else { 2887 $err = CleanWarning() . " in $wgrp1:$tag (${type}Inv)"; 2888 $self->VPrint(2, "$err\n"); 2889 } 2890 undef $val; 2891 last Conv; 2892 } elsif (not defined $val) { 2893 $err = "Error converting value for $wgrp1:$tag (${type}Inv)"; 2894 $self->VPrint(2, "$err\n"); 2895 last Conv; 2896 } 2897 } elsif ($conv) { 2898 if (ref $conv eq 'HASH' and (not exists $$tagInfo{"${type}Inv"} or $convInvList)) { 2899 my ($multi, $lc); 2900 # insert alternate language print conversions if required 2901 if ($$self{CUR_LANG} and $type eq 'PrintConv' and 2902 ref($lc = $$self{CUR_LANG}{$tag}) eq 'HASH' and 2903 ($lc = $$lc{PrintConv})) 2904 { 2905 my %newConv; 2906 foreach (keys %$conv) { 2907 my $val = $$conv{$_}; 2908 defined $$lc{$val} or $newConv{$_} = $val, next; 2909 $newConv{$_} = $self->Decode($$lc{$val}, 'UTF8'); 2910 } 2911 if ($$conv{BITMASK}) { 2912 foreach (keys %{$$conv{BITMASK}}) { 2913 my $val = $$conv{BITMASK}{$_}; 2914 defined $$lc{$val} or $newConv{BITMASK}{$_} = $val, next; 2915 $newConv{BITMASK}{$_} = $self->Decode($$lc{$val}, 'UTF8'); 2916 } 2917 } 2918 $conv = \%newConv; 2919 } 2920 undef $evalWarning; 2921 if ($$conv{BITMASK}) { 2922 my $lookupBits = $$conv{BITMASK}; 2923 my ($wbits, $tbits) = @$tagInfo{'BitsPerWord','BitsTotal'}; 2924 my ($val2, $err2) = EncodeBits($val, $lookupBits, $wbits, $tbits); 2925 if ($err2) { 2926 # ok, try matching a straight value 2927 ($val, $multi) = ReverseLookup($val, $conv); 2928 unless (defined $val) { 2929 $err = "Can't encode $wgrp1:$tag ($err2)"; 2930 $self->VPrint(2, "$err\n"); 2931 last Conv; 2932 } 2933 } elsif (defined $val2) { 2934 $val = $val2; 2935 } else { 2936 delete $$conv{BITMASK}; 2937 ($val, $multi) = ReverseLookup($val, $conv); 2938 $$conv{BITMASK} = $lookupBits; 2939 } 2940 } else { 2941 ($val, $multi) = ReverseLookup($val, $conv); 2942 } 2943 if (not defined $val) { 2944 my $prob = $evalWarning ? lcfirst CleanWarning() : ($multi ? 'matches more than one ' : 'not in ') . $type; 2945 $err = "Can't convert $wgrp1:$tag ($prob)"; 2946 $self->VPrint(2, "$err\n"); 2947 last Conv; 2948 } elsif ($evalWarning) { 2949 $self->VPrint(2, CleanWarning() . " for $wgrp1:$tag\n"); 2950 } 2951 } elsif (not $$tagInfo{WriteAlso}) { 2952 $err = "Can't convert value for $wgrp1:$tag (no ${type}Inv)"; 2953 $self->VPrint(2, "$err\n"); 2954 undef $val; 2955 last Conv; 2956 } 2957 } 2958 last unless @valList; 2959 $valList[$index] = $val; 2960 if (++$index >= @valList) { 2961 # leave AutoSplit lists in ARRAY form, or join conversion lists 2962 $val = $$tagInfo{List} ? \@valList : join ' ', @valList; 2963 last; 2964 } 2965 $conv = $$convList[$index] if $convList; 2966 $convInv = $$convInvList[$index] if $convInvList; 2967 $val = $valList[$index]; 2968 } 2969 } # end ValueConv/PrintConv loop 2970 2971 return($val, $err); 2972} 2973 2974#------------------------------------------------------------------------------ 2975# Convert tag names to values or variables in a string 2976# (eg. '${EXIF:ISO}x $$' --> '100x $' without hash ref, or "$info{'EXIF:ISO'}x $" with) 2977# Inputs: 0) ExifTool object ref, 1) reference to list of found tags 2978# 2) string with embedded tag names, 3) Options: 2979# undef - set missing tags to '' 2980# 'Error' - issue minor error on missing tag (and return undef) 2981# 'Warn' - issue minor warning on missing tag (and return undef) 2982# 'Silent' - just return undef on missing tag (no errors/warnings) 2983# Hash ref - defined to interpolate as variables in string instead of values 2984# --> receives tag/value pairs for interpolation of the variables 2985# 4) document group name if extracting from a specific document 2986# 5) hash ref to cache tag keys for subsequent calls in document loop 2987# Returns: string with embedded tag values (or '$info{TAGNAME}' entries with Hash ref option) 2988# Notes: 2989# - tag names are not case sensitive and may end with '#' for ValueConv value 2990# - uses MissingTagValue option if set 2991# - '$GROUP:all' evaluates to 1 if any tag from GROUP exists, or 0 otherwise 2992# - advanced feature allows Perl expressions inside braces (eg. '${model;tr/ //d}') 2993# - an error/warning in an advanced expression ("${TAG;EXPR}") generates an error 2994# if option set to 'Error', or a warning otherwise 2995sub InsertTagValues($$$;$$$) 2996{ 2997 local $_; 2998 my ($self, $foundTags, $line, $opt, $docGrp, $cache) = @_; 2999 my $rtnStr = ''; 3000 my ($docNum, $tag); 3001 if ($docGrp) { 3002 $docNum = $docGrp =~ /(\d+)$/ ? $1 : 0; 3003 } else { 3004 undef $cache; # no cache if no document groups 3005 } 3006 while ($line =~ s/(.*?)\$(\{\s*)?([-\w]*\w|\$|\/)//s) { 3007 my ($pre, $bra, $var) = ($1, $2, $3); 3008 my (@tags, $val, $tg, @val, $type, $expr, $didExpr, $level, $asList); 3009 # "$$" represents a "$" symbol, and "$/" is a newline 3010 if ($var eq '$' or $var eq '/') { 3011 $line =~ s/^\s*\}// if $bra; 3012 if ($var eq '/') { 3013 $var = "\n"; 3014 } elsif ($line =~ /^self\b/ and not $rtnStr =~ /\$$/) { 3015 $var = '$$'; # ("$$self{var}" in string) 3016 } 3017 $rtnStr .= "$pre$var"; 3018 next; 3019 } 3020 # allow multiple group names 3021 while ($line =~ /^:([-\w]*\w)(.*)/s) { 3022 my $group = $var; 3023 ($var, $line) = ($1, $2); 3024 $var = "$group:$var"; 3025 } 3026 # allow trailing '#' to indicate ValueConv value 3027 $type = 'ValueConv' if $line =~ s/^#//; 3028 # special advanced formatting '@' feature to evaluate list values separately 3029 if ($bra and $line =~ s/^\@(#)?//) { 3030 $asList = 1; 3031 $type = 'ValueConv' if $1; 3032 } 3033 # remove trailing bracket if there was a leading one 3034 # and extract Perl expression from inside brackets if it exists 3035 if ($bra and $line !~ s/^\s*\}// and $line =~ s/^\s*;\s*(.*?)\s*\}//s) { 3036 my $part = $1; 3037 $expr = ''; 3038 for ($level=0; ; --$level) { 3039 # increase nesting level for each opening brace 3040 ++$level while $part =~ /\{/g; 3041 $expr .= $part; 3042 last unless $level and $line =~ s/^(.*?)\s*\}//s; # get next part 3043 $part = $1; 3044 $expr .= '}'; # this brace was part of the expression 3045 } 3046 # use default Windows filename filter if expression is empty 3047 $expr = 'tr(/\\\\?*:|"<>\\0)()d' unless length $expr; 3048 } 3049 push @tags, $var; 3050 ExpandShortcuts(\@tags); 3051 @tags or $rtnStr .= $pre, next; 3052 # save advanced formatting expression to allow access by user-defined ValueConv 3053 $$self{FMT_EXPR} = $expr; 3054 3055 for (;;) { 3056 # temporarily reset ListJoin option if evaluating list values separately 3057 my $oldListJoin; 3058 $oldListJoin = $self->Options(ListJoin => undef) if $asList; 3059 $tag = shift @tags; 3060 my $lcTag = lc $tag; 3061 if ($cache and $lcTag !~ /(^|:)all$/) { 3062 # remove group from tag name (but not lower-case version) 3063 my $group; 3064 $tag =~ s/^(.*):// and $group = $1; 3065 # cache tag keys to speed processing for a large number of sub-documents 3066 # (similar to code in BuildCompositeTags(), but this is case-insensitive) 3067 my $cacheTag = $$cache{$lcTag}; 3068 unless ($cacheTag) { 3069 $cacheTag = $$cache{$lcTag} = [ ]; 3070 # find all matching keys, organize into groups, and store in cache 3071 my $ex = $$self{TAG_EXTRA}; 3072 my @matches = grep /^$tag(\s|$)/i, @$foundTags; 3073 @matches = $self->GroupMatches($group, \@matches) if defined $group; 3074 foreach (@matches) { 3075 my $doc = $$ex{$_} ? $$ex{$_}{G3} || 0 : 0; 3076 if (defined $$cacheTag[$doc]) { 3077 next unless $$cacheTag[$doc] =~ / \((\d+)\)$/; 3078 my $cur = $1; 3079 # keep the most recently extracted tag 3080 next if / \((\d+)\)$/ and $1 < $cur; 3081 } 3082 $$cacheTag[$doc] = $_; 3083 } 3084 } 3085 my $doc = $lcTag =~ /\b(main|doc(\d+)):/ ? ($2 || 0) : $docNum; 3086 if ($$cacheTag[$doc]) { 3087 $tag = $$cacheTag[$doc]; 3088 $val = $self->GetValue($tag, $type); 3089 } 3090 } else { 3091 # add document number to tag if specified and it doesn't already exist 3092 if ($docGrp and $lcTag !~ /\b(main|doc\d+):/) { 3093 $tag = $docGrp . ':' . $tag; 3094 $lcTag = lc $tag; 3095 } 3096 if ($lcTag eq 'all') { 3097 $val = 1; # always some tag available 3098 } elsif (defined $$self{OPTIONS}{UserParam}{$lcTag}) { 3099 $val = $$self{OPTIONS}{UserParam}{$lcTag}; 3100 } elsif ($tag =~ /(.*):(.+)/) { 3101 my $group; 3102 ($group, $tag) = ($1, $2); 3103 if (lc $tag eq 'all') { 3104 # see if any tag from the specified group exists 3105 my $match = $self->GroupMatches($group, $foundTags); 3106 $val = $match ? 1 : 0; 3107 } else { 3108 # find the specified tag 3109 my @matches = grep /^$tag(\s|$)/i, @$foundTags; 3110 @matches = $self->GroupMatches($group, \@matches); 3111 foreach $tg (@matches) { 3112 if (defined $val and $tg =~ / \((\d+)\)$/) { 3113 # take the most recently extracted tag 3114 my $tagNum = $1; 3115 next if $tag !~ / \((\d+)\)$/ or $1 > $tagNum; 3116 } 3117 $val = $self->GetValue($tg, $type); 3118 $tag = $tg; 3119 last unless $tag =~ / /; # all done if we got our best match 3120 } 3121 } 3122 } elsif ($tag eq 'self') { 3123 $val = $self; # ("$self{var}" or "$self->{var}" in string) 3124 } else { 3125 # get the tag value 3126 $val = $self->GetValue($tag, $type); 3127 unless (defined $val) { 3128 # check for tag name with different case 3129 ($tg) = grep /^$tag$/i, @$foundTags; 3130 if (defined $tg) { 3131 $val = $self->GetValue($tg, $type); 3132 $tag = $tg; 3133 } 3134 } 3135 } 3136 } 3137 $self->Options(ListJoin => $oldListJoin) if $asList; 3138 if (ref $val eq 'ARRAY') { 3139 push @val, @$val; 3140 undef $val; 3141 last unless @tags; 3142 } elsif (ref $val eq 'SCALAR') { 3143 if ($$self{OPTIONS}{Binary} or $$val =~ /^Binary data/) { 3144 $val = $$val; 3145 } else { 3146 $val = 'Binary data ' . length($$val) . ' bytes'; 3147 } 3148 } elsif (ref $val eq 'HASH') { 3149 require 'Image/ExifTool/XMPStruct.pl'; 3150 $val = Image::ExifTool::XMP::SerializeStruct($val); 3151 } elsif (not defined $val) { 3152 $val = $$self{OPTIONS}{MissingTagValue} if $asList; 3153 } 3154 last unless @tags; 3155 push @val, $val if defined $val; 3156 undef $val; 3157 } 3158 if (@val) { 3159 push @val, $val if defined $val; 3160 $val = join $$self{OPTIONS}{ListSep}, @val; 3161 } else { 3162 push @val, $val if defined $val; # (so the eval has access to @val if required) 3163 } 3164 # evaluate advanced formatting expression if given (eg. "${TAG;EXPR}") 3165 if (defined $expr and defined $val) { 3166 local $SIG{'__WARN__'} = \&SetWarning; 3167 undef $evalWarning; 3168 $advFmtSelf = $self; 3169 if ($asList) { 3170 foreach (@val) { 3171 #### eval advanced formatting expression ($_, $self, @val, $advFmtSelf) 3172 eval $expr; 3173 $@ and $evalWarning = $@; 3174 } 3175 # join back together if any values are still defined 3176 @val = grep defined, @val; 3177 $val = @val ? join $$self{OPTIONS}{ListSep}, @val : undef; 3178 } else { 3179 $_ = $val; 3180 #### eval advanced formatting expression ($_, $self, @val, $advFmtSelf) 3181 eval $expr; 3182 $@ and $evalWarning = $@; 3183 $val = ref $_ eq 'ARRAY' ? join($$self{OPTIONS}{ListSep}, @$_): $_; 3184 } 3185 if ($evalWarning) { 3186 my $g3 = ($docGrp and $var !~ /\b(main|doc\d+):/i) ? $docGrp . ':' : ''; 3187 my $str = CleanWarning() . " for '$g3${var}'"; 3188 if ($opt) { 3189 if ($opt eq 'Error') { 3190 $self->Error($str); 3191 } elsif ($opt ne 'Silent') { 3192 $self->Warn($str); 3193 } 3194 } 3195 } 3196 undef $advFmtSelf; 3197 $didExpr = 1; # set flag indicating an expression was evaluated 3198 } 3199 unless (defined $val or ref $opt) { 3200 $val = $$self{OPTIONS}{MissingTagValue}; 3201 unless (defined $val) { 3202 my $g3 = ($docGrp and $var !~ /\b(main|doc\d+):/i) ? $docGrp . ':' : ''; 3203 my $msg = $didExpr ? "Advanced formatting expression returned undef for '$g3${var}'" : 3204 "Tag '$g3${var}' not defined"; 3205 no strict 'refs'; 3206 $opt and ($opt eq 'Silent' or &$opt($self, $msg, 2)) and return $$self{FMT_EXPR} = undef; 3207 $val = ''; 3208 } 3209 } 3210 if (ref $opt eq 'HASH') { 3211 $var .= '#' if $type; 3212 if (defined $expr) { 3213 # generate unique variable name for this modified tag value 3214 my $i = 1; 3215 ++$i while exists $$opt{"$var.expr$i"}; 3216 $var .= '.expr' . $i; 3217 } 3218 $rtnStr .= "$pre\$info{'${var}'}"; 3219 $$opt{$var} = $val; 3220 } else { 3221 $rtnStr .= "$pre$val"; 3222 } 3223 } 3224 $$self{FMT_EXPR} = undef; 3225 return $rtnStr . $line; 3226} 3227 3228#------------------------------------------------------------------------------ 3229# Reformat date/time value in $_ based on specified format string 3230# Inputs: 0) date/time format string 3231sub DateFmt($) 3232{ 3233 my $et = bless { OPTIONS => { DateFormat => shift, StrictDate => 1 } }; 3234 my $shift; 3235 if ($advFmtSelf and defined($shift = $$advFmtSelf{OPTIONS}{GlobalTimeShift})) { 3236 $$et{OPTIONS}{GlobalTimeShift} = $shift; 3237 $$et{GLOBAL_TIME_OFFSET} = $$advFmtSelf{GLOBAL_TIME_OFFSET}; 3238 } 3239 $_ = $et->ConvertDateTime($_); 3240 defined $_ or warn "Error converting date/time\n"; 3241 $$advFmtSelf{GLOBAL_TIME_OFFSET} = $$et{GLOBAL_TIME_OFFSET} if $shift; 3242} 3243 3244#------------------------------------------------------------------------------ 3245# Utility routine to remove duplicate items from default input string 3246# Inputs: 0) true to set $_ to undef if not changed 3247# Notes: - for use only in advanced formatting expressions 3248sub NoDups 3249{ 3250 my %seen; 3251 my $sep = $advFmtSelf ? $$advFmtSelf{OPTIONS}{ListSep} : ', '; 3252 my $new = join $sep, grep { !$seen{$_}++ } split /\Q$sep\E/, $_; 3253 $_ = ($_[0] and $new eq $_) ? undef : $new; 3254} 3255 3256#------------------------------------------------------------------------------ 3257# Is specified tag writable 3258# Inputs: 0) tag name, case insensitive (optional group name currently ignored) 3259# Returns: 0=exists but not writable, 1=writable, undef=doesn't exist 3260sub IsWritable($) 3261{ 3262 my $tag = shift; 3263 $tag =~ s/^(.*)://; # ignore group name 3264 my @tagInfo = FindTagInfo($tag); 3265 unless (@tagInfo) { 3266 return 0 if TagExists($tag); 3267 return undef; 3268 } 3269 my $tagInfo; 3270 foreach $tagInfo (@tagInfo) { 3271 return $$tagInfo{Writable} ? 1 : 0 if defined $$tagInfo{Writable}; 3272 return 1 if $$tagInfo{Table}{WRITABLE}; 3273 # must call WRITE_PROC to autoload writer because this may set the writable tag 3274 my $writeProc = $$tagInfo{Table}{WRITE_PROC}; 3275 if ($writeProc) { 3276 no strict 'refs'; 3277 &$writeProc(); # dummy call to autoload writer 3278 return 1 if $$tagInfo{Writable}; 3279 } 3280 } 3281 return 0; 3282} 3283 3284#------------------------------------------------------------------------------ 3285# Check to see if these are the same file 3286# Inputs: 0) ExifTool ref, 1) first file name, 2) second file name 3287# Returns: true if file names reference the same file 3288sub IsSameFile($$$) 3289{ 3290 my ($self, $file, $file2) = @_; 3291 return 0 unless lc $file eq lc $file2; # (only looking for differences in case) 3292 my ($isSame, $interrupted); 3293 my $tmp1 = "${file}_ExifTool_tmp_$$"; 3294 my $tmp2 = "${file2}_ExifTool_tmp_$$"; 3295 { 3296 local *TMP1; 3297 local $SIG{INT} = sub { $interrupted = 1 }; 3298 if ($self->Open(\*TMP1, $tmp1, '>')) { 3299 close TMP1; 3300 $isSame = 1 if $self->Exists($tmp2); 3301 $self->Unlink($tmp1); 3302 } 3303 } 3304 if ($interrupted and $SIG{INT}) { 3305 no strict 'refs'; 3306 &{$SIG{INT}}(); 3307 } 3308 return $isSame; 3309} 3310 3311#------------------------------------------------------------------------------ 3312# Is this a raw file type? 3313# Inputs: 0) ExifTool ref 3314# Returns: true if FileType is a type of RAW image 3315sub IsRawType($) 3316{ 3317 my $self = shift; 3318 return $rawType{$$self{FileType}}; 3319} 3320 3321#------------------------------------------------------------------------------ 3322# Create directory for specified file 3323# Inputs: 0) ExifTool ref, 1) complete file name including path 3324# Returns: 1 = directory created, 0 = nothing done, -1 = error 3325my $k32CreateDir; 3326sub CreateDirectory($$) 3327{ 3328 local $_; 3329 my ($self, $file) = @_; 3330 my $rtnVal = 0; 3331 my $enc = $$self{OPTIONS}{CharsetFileName}; 3332 my $dir; 3333 ($dir = $file) =~ s/[^\/]*$//; # remove filename from path specification 3334 # recode as UTF-8 if necessary 3335 if ($dir and not $self->IsDirectory($dir)) { 3336 my @parts = split /\//, $dir; 3337 $dir = ''; 3338 foreach (@parts) { 3339 $dir .= $_; 3340 if (length $dir and not $self->IsDirectory($dir)) { 3341 # create directory since it doesn't exist 3342 my $d2 = $dir; # (must make a copy in case EncodeFileName recodes it) 3343 if ($self->EncodeFileName($d2)) { 3344 # handle Windows Unicode directory names 3345 unless (eval { require Win32::API }) { 3346 $self->Warn('Install Win32::API to create directories with Unicode names'); 3347 return -1; 3348 } 3349 unless ($k32CreateDir) { 3350 return -1 if defined $k32CreateDir; 3351 $k32CreateDir = new Win32::API('KERNEL32', 'CreateDirectoryW', 'PP', 'I'); 3352 unless ($k32CreateDir) { 3353 $self->Warn('Error calling Win32::API::CreateDirectoryW'); 3354 $k32CreateDir = 0; 3355 return -1; 3356 } 3357 } 3358 $k32CreateDir->Call($d2, 0) or return -1; 3359 } else { 3360 mkdir($d2, 0777) or return -1; 3361 } 3362 $rtnVal = 1; 3363 } 3364 $dir .= '/'; 3365 } 3366 } 3367 return $rtnVal; 3368} 3369 3370#------------------------------------------------------------------------------ 3371# Copy file attributes from one file to another 3372# Inputs: 0) ExifTool ref, 1) source file name, 2) destination file name 3373# Notes: eventually add support for extended attributes? 3374sub CopyFileAttrs($$$) 3375{ 3376 my ($self, $src, $dst) = @_; 3377 my ($mode, $uid, $gid) = (stat($src))[2, 4, 5]; 3378 # copy file attributes unless we already set them 3379 if (defined $mode and not defined $self->GetNewValue('FilePermissions')) { 3380 eval { chmod($mode & 07777, $dst) }; 3381 } 3382 my $newUid = $self->GetNewValue('FileUserID'); 3383 my $newGid = $self->GetNewValue('FileGroupID'); 3384 if (defined $uid and defined $gid and (not defined $newUid or not defined $newGid)) { 3385 defined $newGid and $gid = $newGid; 3386 defined $newUid and $uid = $newUid; 3387 eval { chown($uid, $gid, $dst) }; 3388 } 3389} 3390 3391#------------------------------------------------------------------------------ 3392# Get new file path name 3393# Inputs: 0) existing name (may contain directory), 3394# 1) new file name, new directory, or new path (dir+name) 3395# Returns: new file path name 3396sub GetNewFileName($$) 3397{ 3398 my ($oldName, $newName) = @_; 3399 my ($dir, $name) = ($oldName =~ m{(.*/)(.*)}); 3400 ($dir, $name) = ('', $oldName) unless defined $dir; 3401 if ($newName =~ m{/$}) { 3402 $newName = "$newName$name"; # change dir only 3403 } elsif ($newName !~ m{/}) { 3404 $newName = "$dir$newName"; # change name only if newname doesn't specify dir 3405 } # else change dir and name 3406 return $newName; 3407} 3408 3409#------------------------------------------------------------------------------ 3410# Get next available tag key 3411# Inputs: 0) hash reference (keys are tag keys), 1) tag name 3412# Returns: next available tag key 3413sub NextFreeTagKey($$) 3414{ 3415 my ($info, $tag) = @_; 3416 return $tag unless exists $$info{$tag}; 3417 my $i; 3418 for ($i=1; ; ++$i) { 3419 my $key = "$tag ($i)"; 3420 return $key unless exists $$info{$key}; 3421 } 3422} 3423 3424#------------------------------------------------------------------------------ 3425# Reverse hash lookup 3426# Inputs: 0) value, 1) hash reference 3427# Returns: Hash key or undef if not found (plus flag for multiple matches in list context) 3428sub ReverseLookup($$) 3429{ 3430 my ($val, $conv) = @_; 3431 return undef unless defined $val; 3432 my $multi; 3433 if ($val =~ /^Unknown\s*\((.*)\)$/i) { 3434 $val = $1; # was unknown 3435 if ($val =~ /^0x([\da-fA-F]+)$/) { 3436 # disable "Hexadecimal number > 0xffffffff non-portable" warning 3437 local $SIG{'__WARN__'} = sub { }; 3438 $val = hex($val); # convert hex value 3439 } 3440 } else { 3441 my $qval = $val; 3442 $qval =~ s/\s+$//; # remove trailing whitespace 3443 $qval = quotemeta $qval; 3444 my @patterns = ( 3445 "^$qval\$", # exact match 3446 "^(?i)$qval\$", # case-insensitive 3447 "^(?i)$qval", # beginning of string 3448 "(?i)$qval", # substring 3449 ); 3450 # hash entries to ignore in reverse lookup 3451 my ($pattern, $found, $matches); 3452PAT: foreach $pattern (@patterns) { 3453 $matches = scalar grep /$pattern/, values(%$conv); 3454 next unless $matches; 3455 # multiple matches are bad unless they were exact 3456 if ($matches > 1 and $pattern !~ /\$$/) { 3457 # don't match entries that we should ignore 3458 foreach (keys %ignorePrintConv) { 3459 --$matches if defined $$conv{$_} and $$conv{$_} =~ /$pattern/; 3460 } 3461 last if $matches > 1; 3462 } 3463 foreach (sort keys %$conv) { 3464 next if $$conv{$_} !~ /$pattern/ or $ignorePrintConv{$_}; 3465 $val = $_; 3466 $found = 1; 3467 last PAT; 3468 } 3469 } 3470 unless ($found) { 3471 # call OTHER conversion routine if available 3472 if ($$conv{OTHER}) { 3473 local $SIG{'__WARN__'} = \&SetWarning; 3474 undef $evalWarning; 3475 $val = &{$$conv{OTHER}}($val,1,$conv); 3476 } else { 3477 $val = undef; 3478 } 3479 $multi = 1 if $matches > 1; 3480 } 3481 } 3482 return ($val, $multi) if wantarray; 3483 return $val; 3484} 3485 3486#------------------------------------------------------------------------------ 3487# Return true if we are deleting or overwriting the specified tag 3488# Inputs: 0) ExifTool object ref, 1) new value hash reference 3489# 2) optional tag value (before RawConv) if deleting specific values 3490# Returns: >0 - tag should be overwritten 3491# =0 - the tag should be preserved 3492# <0 - not sure, we need the value to know 3493# Notes: $$nvHash{Value} is updated with the new value when shifting a value 3494sub IsOverwriting($$;$) 3495{ 3496 my ($self, $nvHash, $val) = @_; 3497 return 0 unless $nvHash; 3498 # overwrite regardless if no DelValues specified 3499 return 1 unless $$nvHash{DelValue}; 3500 # never overwrite if DelValue list exists but is empty 3501 my $shift = $$nvHash{Shift}; 3502 return 0 unless @{$$nvHash{DelValue}} or defined $shift; 3503 # return "don't know" if we don't have a value to test 3504 return -1 unless defined $val; 3505 # apply raw conversion if necessary 3506 my $tagInfo = $$nvHash{TagInfo}; 3507 my $conv = $$tagInfo{RawConv}; 3508 if ($conv) { 3509 local $SIG{'__WARN__'} = \&SetWarning; 3510 undef $evalWarning; 3511 if (ref $conv eq 'CODE') { 3512 $val = &$conv($val, $self); 3513 } else { 3514 my ($priority, @grps); 3515 my $tag = $$tagInfo{Name}; 3516 #### eval RawConv ($self, $val, $tag, $tagInfo, $priority, @grps) 3517 $val = eval $conv; 3518 $@ and $evalWarning = $@; 3519 } 3520 return -1 unless defined $val; 3521 } 3522 # do not overwrite if only creating 3523 return 0 if $$nvHash{CreateOnly}; 3524 # apply time/number shift if necessary 3525 if (defined $shift) { 3526 my $shiftType = $$tagInfo{Shift}; 3527 unless ($shiftType and $shiftType eq 'Time') { 3528 unless (IsFloat($val)) { 3529 # do the ValueConv to try to get a number 3530 my $conv = $$tagInfo{ValueConv}; 3531 if (defined $conv) { 3532 local $SIG{'__WARN__'} = \&SetWarning; 3533 undef $evalWarning; 3534 if (ref $conv eq 'CODE') { 3535 $val = &$conv($val, $self); 3536 } elsif (not ref $conv) { 3537 #### eval ValueConv ($val, $self) 3538 $val = eval $conv; 3539 $@ and $evalWarning = $@; 3540 } 3541 if ($evalWarning) { 3542 $self->Warn("ValueConv $$tagInfo{Name}: " . CleanWarning()); 3543 return 0; 3544 } 3545 } 3546 unless (defined $val and IsFloat($val)) { 3547 $self->Warn("Can't shift $$tagInfo{Name} (not a number)"); 3548 return 0; 3549 } 3550 } 3551 $shiftType = 'Number'; # allow any number to be shifted 3552 } 3553 require 'Image/ExifTool/Shift.pl'; 3554 my $err = $self->ApplyShift($shiftType, $shift, $val, $nvHash); 3555 if ($err) { 3556 $self->Warn("$err when shifting $$tagInfo{Name}"); 3557 return 0; 3558 } 3559 # ensure that the shifted value is valid and reformat if necessary 3560 my $checkVal = $self->GetNewValue($nvHash); 3561 return 0 unless defined $checkVal; 3562 # don't bother overwriting if value is the same 3563 return 0 if $val eq $$nvHash{Value}[0]; 3564 return 1; 3565 } 3566 # return 1 if value matches a DelValue 3567 my $delVal; 3568 foreach $delVal (@{$$nvHash{DelValue}}) { 3569 return 1 if $val eq $delVal; 3570 } 3571 return 0; 3572} 3573 3574#------------------------------------------------------------------------------ 3575# Get write group for specified tag 3576# Inputs: 0) new value hash reference 3577# Returns: Write group name 3578sub GetWriteGroup($) 3579{ 3580 return $_[0]{WriteGroup}; 3581} 3582 3583#------------------------------------------------------------------------------ 3584# Get name of write group or family 1 group 3585# Inputs: 0) ExifTool ref, 1) tagInfo ref, 2) write group name 3586# Returns: Name of group for verbose message 3587sub GetWriteGroup1($$) 3588{ 3589 my ($self, $tagInfo, $writeGroup) = @_; 3590 return $writeGroup unless $writeGroup =~ /^(MakerNotes|XMP|Composite|QuickTime)$/; 3591 return $self->GetGroup($tagInfo, 1); 3592} 3593 3594#------------------------------------------------------------------------------ 3595# Get new value hash for specified tagInfo/writeGroup 3596# Inputs: 0) ExifTool object reference, 1) reference to tag info hash 3597# 2) Write group name, 3) Options: 'delete' or 'create' new value hash 3598# 4) optional ProtectSaved value, 5) true if we are deleting a value 3599# Returns: new value hash reference for specified write group 3600# (or first new value hash in linked list if write group not specified) 3601# Notes: May return undef when 'create' is used with ProtectSaved 3602sub GetNewValueHash($$;$$$$) 3603{ 3604 my ($self, $tagInfo, $writeGroup, $opts) = @_; 3605 return undef unless $tagInfo; 3606 my $nvHash = $$self{NEW_VALUE}{$tagInfo}; 3607 3608 my %opts; # quick lookup for options 3609 $opts and $opts{$opts} = 1; 3610 $writeGroup = '' unless defined $writeGroup; 3611 3612 if ($writeGroup) { 3613 # find the new value in the list with the specified write group 3614 while ($nvHash and $$nvHash{WriteGroup} ne $writeGroup) { 3615 # QuickTime and All are special cases because all group1 tags may be updated at once 3616 last if $$nvHash{WriteGroup} =~ /^(QuickTime|All)$/; 3617 # replace existing entry if WriteGroup is 'All' (avoids confusion of forum10349) 3618 last if $$tagInfo{WriteGroup} and $$tagInfo{WriteGroup} eq 'All'; 3619 $nvHash = $$nvHash{Next}; 3620 } 3621 } 3622 # remove this entry if deleting, or if creating a new entry and 3623 # this entry is marked with "Save" flag 3624 if (defined $nvHash and ($opts{'delete'} or ($opts{'create'} and $$nvHash{Save}))) { 3625 my $protect = (defined $_[4] and defined $$nvHash{Save} and $$nvHash{Save} > $_[4]); 3626 # this is a bit tricky: we want to add to a protected nvHash only if we 3627 # are adding a conditional delete ($_[5] true or DelValue with no Shift) 3628 # or accumulating List items (NoReplace true) 3629 if ($protect and not ($opts{create} and ($$nvHash{NoReplace} or $_[5] or 3630 ($$nvHash{DelValue} and not defined $$nvHash{Shift})))) 3631 { 3632 return undef; # honour ProtectSaved value by not writing this tag 3633 } elsif ($opts{'delete'}) { 3634 $self->RemoveNewValueHash($nvHash, $tagInfo); 3635 undef $nvHash; 3636 } else { 3637 # save a copy of this new value hash 3638 my %copy = %$nvHash; 3639 # make copy of Value and DelValue lists 3640 my $key; 3641 foreach $key (keys %copy) { 3642 next unless ref $copy{$key} eq 'ARRAY'; 3643 $copy{$key} = [ @{$copy{$key}} ]; 3644 } 3645 my $saveHash = $$self{SAVE_NEW_VALUE}; 3646 # add to linked list of saved new value hashes 3647 $copy{Next} = $$saveHash{$tagInfo}; 3648 $$saveHash{$tagInfo} = \%copy; 3649 delete $$nvHash{Save}; # don't save it again 3650 $$nvHash{AddBefore} = scalar @{$$nvHash{Value}} if $protect and $$nvHash{Value}; 3651 } 3652 } 3653 if (not defined $nvHash and $opts{'create'}) { 3654 # create a new entry 3655 $nvHash = { 3656 TagInfo => $tagInfo, 3657 WriteGroup => $writeGroup, 3658 IsNVH => 1, # set flag so we can recognize a new value hash 3659 }; 3660 # add entry to our NEW_VALUE hash 3661 if ($$self{NEW_VALUE}{$tagInfo}) { 3662 # add to end of linked list 3663 my $lastHash = LastInList($$self{NEW_VALUE}{$tagInfo}); 3664 $$lastHash{Next} = $nvHash; 3665 } else { 3666 $$self{NEW_VALUE}{$tagInfo} = $nvHash; 3667 } 3668 } 3669 return $nvHash; 3670} 3671 3672#------------------------------------------------------------------------------ 3673# Load all tag tables 3674sub LoadAllTables() 3675{ 3676 return if $loadedAllTables; 3677 3678 # load all of our non-referenced tables (first our modules) 3679 my $table; 3680 foreach $table (@loadAllTables) { 3681 my $tableName = "Image::ExifTool::$table"; 3682 $tableName .= '::Main' unless $table =~ /:/; 3683 GetTagTable($tableName); 3684 } 3685 # (then our special tables) 3686 GetTagTable('Image::ExifTool::Extra'); 3687 GetTagTable('Image::ExifTool::Composite'); 3688 # recursively load all tables referenced by the current tables 3689 my @tableNames = keys %allTables; 3690 my %pushedTables; 3691 while (@tableNames) { 3692 $table = GetTagTable(shift @tableNames); 3693 # call write proc if it exists in case it adds tags to the table 3694 my $writeProc = $$table{WRITE_PROC}; 3695 if ($writeProc) { 3696 no strict 'refs'; 3697 &$writeProc(); 3698 } 3699 # recursively scan through tables in subdirectories 3700 foreach (TagTableKeys($table)) { 3701 my @infoArray = GetTagInfoList($table,$_); 3702 my $tagInfo; 3703 foreach $tagInfo (@infoArray) { 3704 my $subdir = $$tagInfo{SubDirectory} or next; 3705 my $tableName = $$subdir{TagTable} or next; 3706 # next if table already loaded or queued for loading 3707 next if $allTables{$tableName} or $pushedTables{$tableName}; 3708 push @tableNames, $tableName; # must scan this one too 3709 $pushedTables{$tableName} = 1; 3710 } 3711 } 3712 } 3713 $loadedAllTables = 1; 3714} 3715 3716#------------------------------------------------------------------------------ 3717# Remove new value hash from linked list (and save if necessary) 3718# Inputs: 0) ExifTool object reference, 1) new value hash ref, 2) tagInfo ref 3719sub RemoveNewValueHash($$$) 3720{ 3721 my ($self, $nvHash, $tagInfo) = @_; 3722 my $firstHash = $$self{NEW_VALUE}{$tagInfo}; 3723 if ($nvHash eq $firstHash) { 3724 # remove first entry from linked list 3725 if ($$nvHash{Next}) { 3726 $$self{NEW_VALUE}{$tagInfo} = $$nvHash{Next}; 3727 } else { 3728 delete $$self{NEW_VALUE}{$tagInfo}; 3729 } 3730 } else { 3731 # find the list element pointing to this hash 3732 $firstHash = $$firstHash{Next} while $$firstHash{Next} ne $nvHash; 3733 # remove from linked list 3734 $$firstHash{Next} = $$nvHash{Next}; 3735 } 3736 # save the existing entry if necessary 3737 if ($$nvHash{Save}) { 3738 my $saveHash = $$self{SAVE_NEW_VALUE}; 3739 # add to linked list of saved new value hashes 3740 $$nvHash{Next} = $$saveHash{$tagInfo}; 3741 $$saveHash{$tagInfo} = $nvHash; 3742 } 3743} 3744 3745#------------------------------------------------------------------------------ 3746# Remove all new value entries for specified group 3747# Inputs: 0) ExifTool object reference, 1) group name 3748sub RemoveNewValuesForGroup($$) 3749{ 3750 my ($self, $group) = @_; 3751 3752 return unless $$self{NEW_VALUE}; 3753 3754 # make list of all groups we must remove 3755 my @groups = ( $group ); 3756 push @groups, @{$removeGroups{$group}} if $removeGroups{$group}; 3757 3758 my ($out, @keys, $hashKey); 3759 $out = $$self{OPTIONS}{TextOut} if $$self{OPTIONS}{Verbose} > 1; 3760 3761 # loop though all new values, and remove any in this group 3762 @keys = keys %{$$self{NEW_VALUE}}; 3763 foreach $hashKey (@keys) { 3764 my $nvHash = $$self{NEW_VALUE}{$hashKey}; 3765 # loop through each entry in linked list 3766 for (;;) { 3767 my $nextHash = $$nvHash{Next}; 3768 my $tagInfo = $$nvHash{TagInfo}; 3769 my ($grp0,$grp1) = $self->GetGroup($tagInfo); 3770 my $wgrp = $$nvHash{WriteGroup}; 3771 # use group1 if write group is not specific 3772 $wgrp = $grp1 if $wgrp eq $grp0; 3773 if (grep /^($grp0|$wgrp)$/i, @groups) { 3774 $out and print $out "Removed new value for $wgrp:$$tagInfo{Name}\n"; 3775 # remove from linked list 3776 $self->RemoveNewValueHash($nvHash, $tagInfo); 3777 } 3778 $nvHash = $nextHash or last; 3779 } 3780 } 3781} 3782 3783#------------------------------------------------------------------------------ 3784# Get list of tagInfo hashes for all new data 3785# Inputs: 0) ExifTool object reference, 1) optional tag table pointer 3786# Returns: list of tagInfo hashes 3787sub GetNewTagInfoList($;$) 3788{ 3789 my ($self, $tagTablePtr) = @_; 3790 my @tagInfoList; 3791 my $nv = $$self{NEW_VALUE}; 3792 if ($nv) { 3793 my $hashKey; 3794 foreach $hashKey (keys %$nv) { 3795 my $tagInfo = $$nv{$hashKey}{TagInfo}; 3796 next if $tagTablePtr and $tagTablePtr ne $$tagInfo{Table}; 3797 push @tagInfoList, $tagInfo; 3798 } 3799 } 3800 return @tagInfoList; 3801} 3802 3803#------------------------------------------------------------------------------ 3804# Get hash of tagInfo references keyed on tagID for a specific table 3805# Inputs: 0) ExifTool object reference, 1-N) tag table pointers 3806# Returns: hash reference 3807# Notes: returns only one tagInfo ref for each conditional list 3808sub GetNewTagInfoHash($@) 3809{ 3810 my $self = shift; 3811 my (%tagInfoHash, $hashKey); 3812 my $nv = $$self{NEW_VALUE}; 3813 while ($nv) { 3814 my $tagTablePtr = shift || last; 3815 foreach $hashKey (keys %$nv) { 3816 my $tagInfo = $$nv{$hashKey}{TagInfo}; 3817 next if $tagTablePtr and $tagTablePtr ne $$tagInfo{Table}; 3818 $tagInfoHash{$$tagInfo{TagID}} = $tagInfo; 3819 } 3820 } 3821 return \%tagInfoHash; 3822} 3823 3824#------------------------------------------------------------------------------ 3825# Get a tagInfo/tagID hash for subdirectories we need to add 3826# Inputs: 0) ExifTool object reference, 1) parent tag table reference 3827# 2) parent directory name (taken from GROUP0 of tag table if not defined) 3828# Returns: Reference to Hash of subdirectory tagInfo references keyed by tagID 3829# (plus Reference to edit directory hash in list context) 3830sub GetAddDirHash($$;$) 3831{ 3832 my ($self, $tagTablePtr, $parent) = @_; 3833 $parent or $parent = $$tagTablePtr{GROUPS}{0}; 3834 my $tagID; 3835 my %addDirHash; 3836 my %editDirHash; 3837 my $addDirs = $$self{ADD_DIRS}; 3838 my $editDirs = $$self{EDIT_DIRS}; 3839 foreach $tagID (TagTableKeys($tagTablePtr)) { 3840 my @infoArray = GetTagInfoList($tagTablePtr,$tagID); 3841 my $tagInfo; 3842 foreach $tagInfo (@infoArray) { 3843 next unless $$tagInfo{SubDirectory}; 3844 # get name for this sub directory 3845 # (take directory name from SubDirectory DirName if it exists, 3846 # otherwise Group0 name of SubDirectory TagTable or tag Group1 name) 3847 my $dirName = $$tagInfo{SubDirectory}{DirName}; 3848 unless ($dirName) { 3849 # use tag name for directory name and save for next time 3850 $dirName = $$tagInfo{Name}; 3851 $$tagInfo{SubDirectory}{DirName} = $dirName; 3852 } 3853 # save this directory information if we are writing it 3854 if ($$editDirs{$dirName} and $$editDirs{$dirName} eq $parent) { 3855 $editDirHash{$tagID} = $tagInfo; 3856 $addDirHash{$tagID} = $tagInfo if $$addDirs{$dirName}; 3857 } 3858 } 3859 } 3860 return (\%addDirHash, \%editDirHash) if wantarray; 3861 return \%addDirHash; 3862} 3863 3864#------------------------------------------------------------------------------ 3865# Get localized version of tagInfo hash (used by MIE, XMP, PNG and QuickTime) 3866# Inputs: 0) tagInfo hash ref, 1) locale code (eg. "en_CA" for MIE) 3867# Returns: new tagInfo hash ref, or undef if invalid 3868# - sets LangCode member in new tagInfo 3869sub GetLangInfo($$) 3870{ 3871 my ($tagInfo, $langCode) = @_; 3872 # make a new tagInfo hash for this locale 3873 my $table = $$tagInfo{Table}; 3874 my $tagID = $$tagInfo{TagID} . '-' . $langCode; 3875 my $langInfo = $$table{$tagID}; 3876 unless ($langInfo) { 3877 # make a new tagInfo entry for this locale 3878 $langInfo = { 3879 %$tagInfo, 3880 Name => $$tagInfo{Name} . '-' . $langCode, 3881 Description => Image::ExifTool::MakeDescription($$tagInfo{Name}) . 3882 " ($langCode)", 3883 LangCode => $langCode, 3884 SrcTagInfo => $tagInfo, # save reference to original tagInfo 3885 }; 3886 AddTagToTable($table, $tagID, $langInfo); 3887 } 3888 return $langInfo; 3889} 3890 3891#------------------------------------------------------------------------------ 3892# initialize ADD_DIRS and EDIT_DIRS hashes for all directories that need 3893# to be created or will have tags changed in them 3894# Inputs: 0) ExifTool object reference, 1) file type string (or map hash ref) 3895# 2) preferred family 0 group for creating tags, 3) alternate preferred group 3896# Notes: 3897# - the ADD_DIRS and EDIT_DIRS keys are the directory names, and the values 3898# are the names of the parent directories (undefined for a top-level directory) 3899# - also initializes FORCE_WRITE lookup 3900sub InitWriteDirs($$;$$) 3901{ 3902 my ($self, $fileType, $preferredGroup, $altGroup) = @_; 3903 my $editDirs = $$self{EDIT_DIRS} = { }; 3904 my $addDirs = $$self{ADD_DIRS} = { }; 3905 my $fileDirs = $dirMap{$fileType}; 3906 unless ($fileDirs) { 3907 return unless ref $fileType eq 'HASH'; 3908 $fileDirs = $fileType; 3909 } 3910 my @tagInfoList = $self->GetNewTagInfoList(); 3911 my ($tagInfo, $nvHash); 3912 3913 # save the preferred group 3914 $$self{PreferredGroup} = $preferredGroup; 3915 3916 foreach $tagInfo (@tagInfoList) { 3917 # cycle through all hashes in linked list 3918 for ($nvHash=$self->GetNewValueHash($tagInfo); $nvHash; $nvHash=$$nvHash{Next}) { 3919 # are we creating this tag? (otherwise just deleting or editing it) 3920 my $isCreating = $$nvHash{IsCreating}; 3921 if ($preferredGroup) { 3922 my $g0 = $self->GetGroup($tagInfo, 0); 3923 if ($isCreating) { 3924 # if another group is taking priority, only create 3925 # directory if specifically adding tags to this group 3926 # or if this tag isn't being added to the priority group 3927 $isCreating = 0 if $preferredGroup ne $g0 and 3928 $$nvHash{CreateGroups}{$preferredGroup} and 3929 (not $altGroup or $altGroup ne $g0); 3930 } else { 3931 # create this directory if any tag is preferred and has a value 3932 # (unless group creation is disabled via the WriteMode option) 3933 $isCreating = 1 if $$nvHash{Value} and $preferredGroup eq $g0 and 3934 not $$nvHash{EditOnly} and $$self{OPTIONS}{WriteMode} =~ /g/; 3935 } 3936 } 3937 # tag belongs to directory specified by WriteGroup, or by 3938 # the Group0 name if WriteGroup not defined 3939 my $dirName = $$nvHash{WriteGroup}; 3940 # remove MIE copy number(s) if they exist 3941 if ($dirName =~ /^MIE\d*(-[a-z]+)?\d*$/i) { 3942 $dirName = 'MIE' . ($1 || ''); 3943 } 3944 my @dirNames; 3945 # allow a group name of '*' to force writing EXIF/IPTC/XMP/PNG (ForceWrite tag) 3946 if ($dirName eq '*' and $$nvHash{Value}) { 3947 my $val = $$nvHash{Value}[0]; 3948 if ($val) { 3949 foreach (qw(EXIF IPTC XMP PNG FixBase)) { 3950 next unless $val =~ /\b($_|All)\b/i; 3951 push @dirNames, $_; 3952 push @dirNames, 'EXIF' if $_ eq 'FixBase'; 3953 $$self{FORCE_WRITE}{$_} = 1; 3954 } 3955 } 3956 $dirName = shift @dirNames; 3957 } elsif ($dirName eq 'QuickTime') { 3958 # write to specific QuickTime group 3959 $dirName = $self->GetGroup($tagInfo, 1); 3960 } 3961 while ($dirName) { 3962 my $parent = $$fileDirs{$dirName}; 3963 if (ref $parent) { 3964 push @dirNames, reverse @$parent; 3965 $parent = pop @dirNames; 3966 } 3967 $$editDirs{$dirName} = $parent; 3968 $$addDirs{$dirName} = $parent if $isCreating and $isCreating != 2; 3969 $dirName = $parent || shift @dirNames 3970 } 3971 } 3972 } 3973 if (%{$$self{DEL_GROUP}}) { 3974 # add delete groups to list of edited groups 3975 foreach (keys %{$$self{DEL_GROUP}}) { 3976 next if /^-/; # ignore excluded groups 3977 my $dirName = $_; 3978 # translate necessary group 0 names 3979 $dirName = $translateWriteGroup{$dirName} if $translateWriteGroup{$dirName}; 3980 # convert XMP group 1 names 3981 $dirName = 'XMP' if $dirName =~ /^XMP-/; 3982 my @dirNames; 3983 while ($dirName) { 3984 my $parent = $$fileDirs{$dirName}; 3985 if (ref $parent) { 3986 push @dirNames, reverse @$parent; 3987 $parent = pop @dirNames; 3988 } 3989 $$editDirs{$dirName} = $parent; 3990 $dirName = $parent || shift @dirNames 3991 } 3992 } 3993 } 3994 # special case to edit JFIF to get resolutions if editing EXIF information 3995 if ($$editDirs{IFD0} and $$fileDirs{JFIF}) { 3996 $$editDirs{JFIF} = 'IFD1'; 3997 $$editDirs{APP0} = undef; 3998 } 3999 4000 if ($$self{OPTIONS}{Verbose}) { 4001 my $out = $$self{OPTIONS}{TextOut}; 4002 print $out " Editing tags in: "; 4003 foreach (sort keys %$editDirs) { print $out "$_ "; } 4004 print $out "\n"; 4005 return unless $$self{OPTIONS}{Verbose} > 1; 4006 print $out " Creating tags in: "; 4007 foreach (sort keys %$addDirs) { print $out "$_ "; } 4008 print $out "\n"; 4009 } 4010} 4011 4012#------------------------------------------------------------------------------ 4013# Write an image directory 4014# Inputs: 0) ExifTool object reference, 1) source directory information reference 4015# 2) tag table reference, 3) optional reference to writing procedure 4016# Returns: New directory data or undefined on error (or empty string to delete directory) 4017sub WriteDirectory($$$;$) 4018{ 4019 my ($self, $dirInfo, $tagTablePtr, $writeProc) = @_; 4020 my ($out, $nvHash, $delFlag); 4021 4022 $tagTablePtr or return undef; 4023 $out = $$self{OPTIONS}{TextOut} if $$self{OPTIONS}{Verbose}; 4024 # set directory name from default group0 name if not done already 4025 my $dirName = $$dirInfo{DirName}; 4026 my $dataPt = $$dirInfo{DataPt}; 4027 my $grp0 = $$tagTablePtr{GROUPS}{0}; 4028 $dirName or $dirName = $$dirInfo{DirName} = $grp0; 4029 if (%{$$self{DEL_GROUP}}) { 4030 my $delGroup = $$self{DEL_GROUP}; 4031 # delete entire directory if specified 4032 my $grp1 = $dirName; 4033 $delFlag = ($$delGroup{$grp0} or $$delGroup{$grp1}) unless $permanentDir{$grp0}; 4034 # (never delete an entire QuickTime group) 4035 if ($delFlag) { 4036 if (($grp0 =~ /^(MakerNotes)$/ or $grp1 =~ /^(IFD0|ExifIFD|MakerNotes)$/) and 4037 $self->IsRawType() and 4038 # allow non-permanent MakerNote directories to be deleted (ie. NikonCapture) 4039 (not $$dirInfo{TagInfo} or not defined $$dirInfo{TagInfo}{Permanent} or 4040 $$dirInfo{TagInfo}{Permanent})) 4041 { 4042 $self->WarnOnce("Can't delete $1 from $$self{FileType}",1); 4043 undef $grp1; 4044 } elsif (not $blockExifTypes{$$self{FILE_TYPE}}) { 4045 # restrict delete logic to prevent entire tiff image from being killed 4046 # (don't allow IFD0 to be deleted, and delete only ExifIFD if EXIF specified) 4047 if ($$self{FILE_TYPE} eq 'PSD') { 4048 # don't delete Photoshop directories from PSD image 4049 undef $grp1 if $grp0 eq 'Photoshop'; 4050 } elsif ($$self{FILE_TYPE} =~ /^(EPS|PS)$/) { 4051 # allow anything to be deleted from PostScript files 4052 } elsif ($grp1 eq 'IFD0') { 4053 my $type = $$self{TIFF_TYPE} || $$self{FILE_TYPE}; 4054 $$delGroup{IFD0} and $self->Warn("Can't delete IFD0 from $type",1); 4055 undef $grp1; 4056 } elsif ($grp0 eq 'EXIF' and $$delGroup{$grp0}) { 4057 undef $grp1 unless $$delGroup{$grp1} or $grp1 eq 'ExifIFD'; 4058 } 4059 } 4060 if ($grp1) { 4061 if ($dataPt or $$dirInfo{RAF}) { 4062 ++$$self{CHANGED}; 4063 $out and print $out " Deleting $grp1\n"; 4064 $self->Warn('ICC_Profile deleted. Image colors may be affected') if $grp1 eq 'ICC_Profile'; 4065 # can no longer validate TIFF_END if deleting an entire IFD 4066 delete $$self{TIFF_END} if $dirName =~ /IFD/; 4067 } 4068 # don't add back into the wrong location 4069 my $right = $$self{ADD_DIRS}{$grp1}; 4070 # (take care because EXIF directory name may be either EXIF or IFD0, 4071 # but IFD0 will be the one that appears in the directory map) 4072 $right = $$self{ADD_DIRS}{IFD0} if not $right and $grp1 eq 'EXIF'; 4073 if ($delFlag == 2 and $right) { 4074 # also check grandparent because some routines create 2 levels in 1 4075 my $right2 = $$self{ADD_DIRS}{$right} || ''; 4076 my $parent = $$dirInfo{Parent}; 4077 if (not $parent or $parent eq $right or $parent eq $right2) { 4078 # prevent duplicate directories from being recreated at the same path 4079 my $path = join '-', @{$$self{PATH}}, $dirName; 4080 $$self{Recreated} or $$self{Recreated} = { }; 4081 if ($$self{Recreated}{$path}) { 4082 my $p = $parent ? " in $parent" : ''; 4083 $self->Warn("Not recreating duplicate $grp1$p",1); 4084 return ''; 4085 } 4086 $$self{Recreated}{$path} = 1; 4087 # empty the directory 4088 my $data = ''; 4089 $$dirInfo{DataPt} = \$data; 4090 $$dirInfo{DataLen} = 0; 4091 $$dirInfo{DirStart} = 0; 4092 $$dirInfo{DirLen} = 0; 4093 delete $$dirInfo{RAF}; 4094 delete $$dirInfo{Base}; 4095 delete $$dirInfo{DataPos}; 4096 } else { 4097 $self->Warn("Not recreating $grp1 in $parent (should be in $right)",1); 4098 return ''; 4099 } 4100 } else { 4101 return '' unless $$dirInfo{NoDelete}; 4102 } 4103 } 4104 } 4105 } 4106 # use default proc from tag table if no proc specified 4107 $writeProc or $writeProc = $$tagTablePtr{WRITE_PROC} or return undef; 4108 4109 # are we rewriting a pre-existing directory? 4110 my $isRewriting = ($$dirInfo{DirLen} or (defined $dataPt and length $$dataPt) or $$dirInfo{RAF}); 4111 4112 # copy or delete new directory as a block if specified 4113 my $blockName = $dirName; 4114 $blockName = 'EXIF' if $blockName eq 'IFD0'; 4115 my $tagInfo = $Image::ExifTool::Extra{$blockName} || $$dirInfo{TagInfo}; 4116 while ($tagInfo and ($nvHash = $$self{NEW_VALUE}{$tagInfo}) and 4117 $self->IsOverwriting($nvHash) and not ($$nvHash{CreateOnly} and $isRewriting)) 4118 { 4119 # protect against writing EXIF to wrong file types, etc 4120 if ($blockName eq 'EXIF') { 4121 unless ($blockExifTypes{$$self{FILE_TYPE}}) { 4122 $self->Warn("Can't write EXIF as a block to $$self{FILE_TYPE} file"); 4123 last; 4124 } 4125 # this can happen if we call WriteDirectory for an EXIF directory without going 4126 # through WriteTIFF as the WriteProc (which happens if conditionally replacing 4127 # the EXIF block and the condition fails), but we never want to do a block write 4128 # in this case because the EXIF block would end up with two TIFF headers 4129 last unless $writeProc eq \&Image::ExifTool::WriteTIFF; 4130 } 4131 last unless $self->IsOverwriting($nvHash, $dataPt ? $$dataPt : ''); 4132 my $verb = 'Writing'; 4133 my $newVal = $self->GetNewValue($nvHash); 4134 unless (defined $newVal and length $newVal) { 4135 return '' unless $dataPt or $$dirInfo{RAF}; # nothing to do if block never existed 4136 # don't allow MakerNotes to be removed from RAW files 4137 if ($blockName eq 'MakerNotes' and $rawType{$$self{FileType}}) { 4138 $self->Warn("Can't delete MakerNotes from $$self{VALUE}{FileType}",1); 4139 return undef; 4140 } 4141 $verb = 'Deleting'; 4142 $newVal = ''; 4143 } 4144 $$dirInfo{BlockWrite} = 1; # set flag indicating we did a block write 4145 $out and print $out " $verb $blockName as a block\n"; 4146 ++$$self{CHANGED}; 4147 return $newVal; 4148 } 4149 # guard against writing the same directory twice 4150 if (defined $dataPt and defined $$dirInfo{DirStart} and defined $$dirInfo{DataPos} and 4151 not $$dirInfo{NoRefTest}) 4152 { 4153 my $addr = $$dirInfo{DirStart} + $$dirInfo{DataPos} + ($$dirInfo{Base}||0) + $$self{BASE}; 4154 # (Phase One P25 IIQ files have ICC_Profile duplicated in IFD0 and IFD1) 4155 if ($$self{PROCESSED}{$addr} and ($dirName ne 'ICC_Profile' or $$self{TIFF_TYPE} ne 'IIQ')) { 4156 if (defined $$dirInfo{DirLen} and not $$dirInfo{DirLen} and $dirName ne $$self{PROCESSED}{$addr}) { 4157 # it is hypothetically possible to have 2 different directories 4158 # with the same address if one has a length of zero 4159 } elsif ($self->Error("$dirName pointer references previous $$self{PROCESSED}{$addr} directory", 2)) { 4160 return undef; 4161 } else { 4162 $self->Warn("Deleting duplicate $dirName directory"); 4163 $out and print $out " Deleting $dirName\n"; 4164 # delete the duplicate directory (don't recreate it when writing new 4165 # tags to prevent propagating a duplicate IFD in cases like when the 4166 # same ExifIFD exists in both IFD0 and IFD1) 4167 return ''; 4168 } 4169 } else { 4170 $$self{PROCESSED}{$addr} = $dirName; 4171 } 4172 } 4173 my $oldDir = $$self{DIR_NAME}; 4174 my @save = @$self{'Compression','SubfileType'}; 4175 my $name; 4176 if ($out) { 4177 $name = ($dirName eq 'MakerNotes' and $$dirInfo{TagInfo}) ? 4178 $$dirInfo{TagInfo}{Name} : $dirName; 4179 if (not defined $oldDir or $oldDir ne $name) { 4180 my $verb = $isRewriting ? 'Rewriting' : 'Creating'; 4181 print $out " $verb $name\n"; 4182 } 4183 } 4184 my $saveOrder = GetByteOrder(); 4185 my $oldChanged = $$self{CHANGED}; 4186 $$self{DIR_NAME} = $dirName; 4187 push @{$$self{PATH}}, $dirName; 4188 $$dirInfo{IsWriting} = 1; 4189 my $newData; 4190 { 4191 no strict 'refs'; 4192 $newData = &$writeProc($self, $dirInfo, $tagTablePtr); 4193 } 4194 pop @{$$self{PATH}}; 4195 # nothing changed if error occurred or nothing was created 4196 $$self{CHANGED} = $oldChanged unless defined $newData and (length($newData) or $isRewriting); 4197 $$self{DIR_NAME} = $oldDir; 4198 @$self{'Compression','SubfileType'} = @save; 4199 SetByteOrder($saveOrder); 4200 print $out " Deleting $name\n" if $out and defined $newData and not length $newData; 4201 return $newData; 4202} 4203 4204#------------------------------------------------------------------------------ 4205# Uncommon utility routines to for reading binary data values 4206# Inputs: 0) data reference, 1) offset into data 4207sub Get64s($$) 4208{ 4209 my ($dataPt, $pos) = @_; 4210 my $pt = GetByteOrder() eq 'MM' ? 0 : 4; # get position of high word 4211 my $hi = Get32s($dataPt, $pos + $pt); # preserve sign bit of high word 4212 my $lo = Get32u($dataPt, $pos + 4 - $pt); 4213 return $hi * 4294967296 + $lo; 4214} 4215sub Get64u($$) 4216{ 4217 my ($dataPt, $pos) = @_; 4218 my $pt = GetByteOrder() eq 'MM' ? 0 : 4; # get position of high word 4219 my $hi = Get32u($dataPt, $pos + $pt); # (unsigned this time) 4220 my $lo = Get32u($dataPt, $pos + 4 - $pt); 4221 return $hi * 4294967296 + $lo; 4222} 4223sub GetFixed64s($$) 4224{ 4225 my ($dataPt, $pos) = @_; 4226 my $val = Get64s($dataPt, $pos) / 4294967296; 4227 # remove insignificant digits 4228 return int($val * 1e10 + ($val>0 ? 0.5 : -0.5)) / 1e10; 4229} 4230# Decode extended 80-bit float used by Apple SANE and Intel 8087 4231# (note: different than the IEEE standard 80-bit float) 4232sub GetExtended($$) 4233{ 4234 my ($dataPt, $pos) = @_; 4235 my $pt = GetByteOrder() eq 'MM' ? 0 : 2; # get position of exponent 4236 my $exp = Get16u($dataPt, $pos + $pt); 4237 my $sig = Get64u($dataPt, $pos + 2 - $pt); # get significand as int64u 4238 my $sign = $exp & 0x8000 ? -1 : 1; 4239 $exp = ($exp & 0x7fff) - 16383 - 63; # (-63 to fractionalize significand) 4240 return $sign * $sig * 2 ** $exp; 4241} 4242 4243#------------------------------------------------------------------------------ 4244# Dump data in hex and ASCII to console 4245# Inputs: 0) data reference, 1) length or undef, 2-N) Options: 4246# Options: Start => offset to start of data (default=0) 4247# Addr => address to print for data start (default=DataPos+Base+Start) 4248# DataPos => position of data within block (relative to Base) 4249# Base => base offset for pointers from start of file 4250# Width => width of printout (bytes, default=16) 4251# Prefix => prefix to print at start of line (default='') 4252# MaxLen => maximum length to dump 4253# Out => output file reference 4254# Len => data length 4255sub HexDump($;$%) 4256{ 4257 my $dataPt = shift; 4258 my $len = shift; 4259 my %opts = @_; 4260 my $start = $opts{Start} || 0; 4261 my $addr = $opts{Addr}; 4262 my $wid = $opts{Width} || 16; 4263 my $prefix = $opts{Prefix} || ''; 4264 my $out = $opts{Out} || \*STDOUT; 4265 my $maxLen = $opts{MaxLen}; 4266 my $datLen = length($$dataPt) - $start; 4267 my $more; 4268 $len = $opts{Len} if defined $opts{Len}; 4269 4270 $addr = $start + ($opts{DataPos} || 0) + ($opts{Base} || 0) unless defined $addr; 4271 $len = $datLen unless defined $len; 4272 if ($maxLen and $len > $maxLen) { 4273 # print one line less to allow for $more line below 4274 $maxLen = int(($maxLen - 1) / $wid) * $wid; 4275 $more = $len - $maxLen; 4276 $len = $maxLen; 4277 } 4278 if ($len > $datLen) { 4279 print $out "$prefix Warning: Attempted dump outside data\n"; 4280 print $out "$prefix ($len bytes specified, but only $datLen available)\n"; 4281 $len = $datLen; 4282 } 4283 my $format = sprintf("%%-%ds", $wid * 3); 4284 my $tmpl = 'H2' x $wid; # ('(H2)*' would have been nice, but older perl versions don't support it) 4285 my $i; 4286 for ($i=0; $i<$len; $i+=$wid) { 4287 $wid > $len-$i and $wid = $len-$i, $tmpl = 'H2' x $wid; 4288 printf $out "$prefix%8.4x: ", $addr+$i; 4289 my $dat = substr($$dataPt, $i+$start, $wid); 4290 my $s = join(' ', unpack($tmpl, $dat)); 4291 printf $out $format, $s; 4292 $dat =~ tr /\x00-\x1f\x7f-\xff/./; 4293 print $out "[$dat]\n"; 4294 } 4295 $more and print $out "$prefix [snip $more bytes]\n"; 4296} 4297 4298#------------------------------------------------------------------------------ 4299# Print verbose tag information 4300# Inputs: 0) ExifTool object reference, 1) tag ID 4301# 2) tag info reference (or undef) 4302# 3-N) extra parms: 4303# Parms: Index => Index of tag in menu (starting at 0) 4304# Value => Tag value 4305# DataPt => reference to value data block 4306# DataPos => location of data block in file 4307# Base => base added to all offsets 4308# Size => length of value data within block 4309# Format => value format string 4310# Count => number of values 4311# Extra => Extra Verbose=2 information to put after tag number 4312# Table => Reference to tag table 4313# --> plus any of these HexDump() options: Start, Addr, Width 4314sub VerboseInfo($$$%) 4315{ 4316 my ($self, $tagID, $tagInfo, %parms) = @_; 4317 my $verbose = $$self{OPTIONS}{Verbose}; 4318 my $out = $$self{OPTIONS}{TextOut}; 4319 my ($tag, $line, $hexID); 4320 4321 # generate hex number if tagID is numerical 4322 if (defined $tagID) { 4323 $tagID =~ /^\d+$/ and $hexID = sprintf("0x%.4x", $tagID); 4324 } else { 4325 $tagID = 'Unknown'; 4326 } 4327 # get tag name 4328 if ($tagInfo and $$tagInfo{Name}) { 4329 $tag = $$tagInfo{Name}; 4330 } else { 4331 my $prefix; 4332 $prefix = $parms{Table}{TAG_PREFIX} if $parms{Table}; 4333 if ($prefix or $hexID) { 4334 $prefix = 'Unknown' unless $prefix; 4335 $tag = $prefix . '_' . ($hexID ? $hexID : $tagID); 4336 } else { 4337 $tag = $tagID; 4338 } 4339 } 4340 my $dataPt = $parms{DataPt}; 4341 my $size = $parms{Size}; 4342 $size = length $$dataPt unless defined $size or not $dataPt; 4343 my $indent = $$self{INDENT}; 4344 4345 # Level 1: print tag/value information 4346 $line = $indent; 4347 my $index = $parms{Index}; 4348 if (defined $index) { 4349 $line .= $index . ') '; 4350 $line .= ' ' if length($index) < 2; 4351 $indent .= ' '; # indent everything else to align with tag name 4352 } 4353 $line .= $tag; 4354 if ($tagInfo and $$tagInfo{SubDirectory}) { 4355 $line .= ' (SubDirectory) -->'; 4356 } else { 4357 my $maxLen = 90 - length($line); 4358 my $val = $parms{Value}; 4359 if (defined $val) { 4360 $val = '[' . join(',',@$val) . ']' if ref $val eq 'ARRAY'; 4361 $line .= ' = ' . $self->Printable($val, $maxLen); 4362 } elsif ($dataPt) { 4363 my $start = $parms{Start} || 0; 4364 $line .= ' = ' . $self->Printable(substr($$dataPt,$start,$size), $maxLen); 4365 } 4366 } 4367 print $out "$line\n"; 4368 4369 # Level 2: print detailed information about the tag 4370 if ($verbose > 1 and ($parms{Extra} or $parms{Format} or 4371 $parms{DataPt} or defined $size or $tagID =~ /\//)) 4372 { 4373 $line = $indent . '- Tag '; 4374 if ($hexID) { 4375 $line .= $hexID; 4376 } else { 4377 $tagID =~ s/([\0-\x1f\x7f-\xff])/sprintf('\\x%.2x',ord $1)/ge; 4378 $line .= "'${tagID}'"; 4379 } 4380 $line .= $parms{Extra} if defined $parms{Extra}; 4381 my $format = $parms{Format}; 4382 if ($format or defined $size) { 4383 $line .= ' ('; 4384 if (defined $size) { 4385 $line .= "$size bytes"; 4386 $line .= ', ' if $format; 4387 } 4388 if ($format) { 4389 $line .= $format; 4390 $line .= '['.$parms{Count}.']' if $parms{Count}; 4391 } 4392 $line .= ')'; 4393 } 4394 $line .= ':' if $verbose > 2 and $parms{DataPt}; 4395 print $out "$line\n"; 4396 } 4397 4398 # Level 3: do hex dump of value 4399 if ($verbose > 2 and $parms{DataPt} and (not $tagInfo or not $$tagInfo{ReadFromRAF})) { 4400 $parms{Out} = $out; 4401 $parms{Prefix} = $indent; 4402 # limit dump length if Verbose < 5 4403 $parms{MaxLen} = $verbose == 3 ? 96 : 2048 if $verbose < 5; 4404 HexDump($dataPt, $size, %parms); 4405 } 4406} 4407 4408#------------------------------------------------------------------------------ 4409# Dump trailer information 4410# Inputs: 0) ExifTool object ref, 1) dirInfo hash (RAF, DirName, DataPos, DirLen) 4411# Notes: Restores current file position before returning 4412sub DumpTrailer($$) 4413{ 4414 my ($self, $dirInfo) = @_; 4415 my $raf = $$dirInfo{RAF}; 4416 my $curPos = $raf->Tell(); 4417 my $trailer = $$dirInfo{DirName} || 'Unknown'; 4418 my $pos = $$dirInfo{DataPos}; 4419 my $verbose = $$self{OPTIONS}{Verbose}; 4420 my $htmlDump = $$self{HTML_DUMP}; 4421 my ($buff, $buf2); 4422 my $size = $$dirInfo{DirLen}; 4423 $pos = $curPos unless defined $pos; 4424 4425 # get full trailer size if not specified 4426 for (;;) { 4427 unless ($size) { 4428 $raf->Seek(0, 2) or last; 4429 $size = $raf->Tell() - $pos; 4430 last unless $size; 4431 } 4432 $raf->Seek($pos, 0) or last; 4433 if ($htmlDump) { 4434 my $num = $raf->Read($buff, $size) or return; 4435 my $desc = "$trailer trailer"; 4436 $desc = "[$desc]" if $trailer eq 'Unknown'; 4437 $self->HDump($pos, $num, $desc, undef, 0x08); 4438 last; 4439 } 4440 my $out = $$self{OPTIONS}{TextOut}; 4441 printf $out "$trailer trailer (%d bytes at offset 0x%.4x):\n", $size, $pos; 4442 last unless $verbose > 2; 4443 my $num = $size; # number of bytes to read 4444 # limit size if not very verbose 4445 if ($verbose < 5) { 4446 my $limit = $verbose < 4 ? 96 : 512; 4447 $num = $limit if $num > $limit; 4448 } 4449 $raf->Read($buff, $num) == $num or return; 4450 # read the end of the trailer too if not done already 4451 if ($size > 2 * $num) { 4452 $raf->Seek($pos + $size - $num, 0); 4453 $raf->Read($buf2, $num); 4454 } elsif ($size > $num) { 4455 $raf->Seek($pos + $num, 0); 4456 $raf->Read($buf2, $size - $num); 4457 $buff .= $buf2; 4458 undef $buf2; 4459 } 4460 HexDump(\$buff, undef, Addr => $pos, Out => $out); 4461 if (defined $buf2) { 4462 print $out " [snip ", $size - $num * 2, " bytes]\n"; 4463 HexDump(\$buf2, undef, Addr => $pos + $size - $num, Out => $out); 4464 } 4465 last; 4466 } 4467 $raf->Seek($curPos, 0); 4468} 4469 4470#------------------------------------------------------------------------------ 4471# Dump unknown trailer information 4472# Inputs: 0) ExifTool ref, 1) dirInfo ref (with RAF, DataPos and DirLen defined) 4473# Notes: changes dirInfo elements 4474sub DumpUnknownTrailer($$) 4475{ 4476 my ($self, $dirInfo) = @_; 4477 my $pos = $$dirInfo{DataPos}; 4478 my $endPos = $pos + $$dirInfo{DirLen}; 4479 # account for preview/MPF image trailer 4480 my $prePos = $$self{VALUE}{PreviewImageStart} || $$self{PreviewImageStart}; 4481 my $preLen = $$self{VALUE}{PreviewImageLength} || $$self{PreviewImageLength}; 4482 my $tag = 'PreviewImage'; 4483 my $mpImageNum = 0; 4484 my (%image, $lastOne); 4485 for (;;) { 4486 # add to Preview block list if valid and in the trailer 4487 $image{$prePos} = [$tag, $preLen] if $prePos and $preLen and $prePos+$preLen > $pos; 4488 last if $lastOne; # checked all images 4489 # look for MPF images (in the the proper order) 4490 ++$mpImageNum; 4491 $prePos = $$self{VALUE}{"MPImageStart ($mpImageNum)"}; 4492 if (defined $prePos) { 4493 $preLen = $$self{VALUE}{"MPImageLength ($mpImageNum)"}; 4494 } else { 4495 $prePos = $$self{VALUE}{'MPImageStart'}; 4496 $preLen = $$self{VALUE}{'MPImageLength'}; 4497 $lastOne = 1; 4498 } 4499 $tag = "MPImage$mpImageNum"; 4500 } 4501 # dump trailer sections in order 4502 $image{$endPos} = [ '', 0 ]; # add terminator "image" 4503 foreach $prePos (sort { $a <=> $b } keys %image) { 4504 if ($pos < $prePos) { 4505 # dump unknown trailer data 4506 $$dirInfo{DirName} = 'Unknown'; 4507 $$dirInfo{DataPos} = $pos; 4508 $$dirInfo{DirLen} = $prePos - $pos; 4509 $self->DumpTrailer($dirInfo); 4510 } 4511 ($tag, $preLen) = @{$image{$prePos}}; 4512 last unless $preLen; 4513 # dump image if verbose (it is htmlDump'd by ExtractImage) 4514 if ($$self{OPTIONS}{Verbose}) { 4515 $$dirInfo{DirName} = $tag; 4516 $$dirInfo{DataPos} = $prePos; 4517 $$dirInfo{DirLen} = $preLen; 4518 $self->DumpTrailer($dirInfo); 4519 } 4520 $pos = $prePos + $preLen; 4521 } 4522} 4523 4524#------------------------------------------------------------------------------ 4525# Find last element in linked list 4526# Inputs: 0) element in list 4527# Returns: Last element in list 4528sub LastInList($) 4529{ 4530 my $element = shift; 4531 while ($$element{Next}) { 4532 $element = $$element{Next}; 4533 } 4534 return $element; 4535} 4536 4537#------------------------------------------------------------------------------ 4538# Print verbose value while writing 4539# Inputs: 0) ExifTool object ref, 1) heading "eg. '+ IPTC:Keywords', 4540# 2) value, 3) [optional] extra text after value 4541sub VerboseValue($$$;$) 4542{ 4543 return unless $_[0]{OPTIONS}{Verbose} > 1; 4544 my ($self, $str, $val, $xtra) = @_; 4545 my $out = $$self{OPTIONS}{TextOut}; 4546 $xtra or $xtra = ''; 4547 my $maxLen = 81 - length($str) - length($xtra); 4548 $val = $self->Printable($val, $maxLen); 4549 print $out " $str = '${val}'$xtra\n"; 4550} 4551 4552#------------------------------------------------------------------------------ 4553# Pack Unicode numbers into UTF8 string 4554# Inputs: 0-N) list of Unicode numbers 4555# Returns: Packed UTF-8 string 4556sub PackUTF8(@) 4557{ 4558 my @out; 4559 while (@_) { 4560 my $ch = pop; 4561 unshift(@out, $ch), next if $ch < 0x80; 4562 unshift(@out, 0x80 | ($ch & 0x3f)); 4563 $ch >>= 6; 4564 unshift(@out, 0xc0 | $ch), next if $ch < 0x20; 4565 unshift(@out, 0x80 | ($ch & 0x3f)); 4566 $ch >>= 6; 4567 unshift(@out, 0xe0 | $ch), next if $ch < 0x10; 4568 unshift(@out, 0x80 | ($ch & 0x3f)); 4569 $ch >>= 6; 4570 unshift(@out, 0xf0 | ($ch & 0x07)); 4571 } 4572 return pack('C*', @out); 4573} 4574 4575#------------------------------------------------------------------------------ 4576# Unpack numbers from UTF8 string 4577# Inputs: 0) UTF-8 string 4578# Returns: List of Unicode numbers (sets $evalWarning on error) 4579sub UnpackUTF8($) 4580{ 4581 my (@out, $pos); 4582 pos($_[0]) = $pos = 0; # start at beginning of string 4583 for (;;) { 4584 my ($ch, $newPos, $val, $byte); 4585 if ($_[0] =~ /([\x80-\xff])/g) { 4586 $ch = ord($1); 4587 $newPos = pos($_[0]) - 1; 4588 } else { 4589 $newPos = length $_[0]; 4590 } 4591 # unpack 7-bit characters 4592 my $len = $newPos - $pos; 4593 push @out, unpack("x${pos}C$len",$_[0]) if $len; 4594 last unless defined $ch; 4595 $pos = $newPos + 1; 4596 # minimum lead byte for 2-byte sequence is 0xc2 (overlong sequences 4597 # not allowed), 0xf8-0xfd are restricted by RFC 3629 (no 5 or 6 byte 4598 # sequences), and 0xfe and 0xff are not valid in UTF-8 strings 4599 if ($ch < 0xc2 or $ch >= 0xf8) { 4600 push @out, ord('?'); # invalid UTF-8 4601 $evalWarning = 'Bad UTF-8'; 4602 next; 4603 } 4604 # decode 2, 3 and 4-byte sequences 4605 my $n = 1; 4606 if ($ch < 0xe0) { 4607 $val = $ch & 0x1f; # 2-byte sequence 4608 } elsif ($ch < 0xf0) { 4609 $val = $ch & 0x0f; # 3-byte sequence 4610 ++$n; 4611 } else { 4612 $val = $ch & 0x07; # 4-byte sequence 4613 $n += 2; 4614 } 4615 unless ($_[0] =~ /\G([\x80-\xbf]{$n})/g) { 4616 pos($_[0]) = $pos; # restore position 4617 push @out, ord('?'); # invalid UTF-8 4618 $evalWarning = 'Bad UTF-8'; 4619 next; 4620 } 4621 foreach $byte (unpack 'C*', $1) { 4622 $val = ($val << 6) | ($byte & 0x3f); 4623 } 4624 push @out, $val; # save Unicode character value 4625 $pos += $n; # position at end of UTF-8 character 4626 } 4627 return @out; 4628} 4629 4630#------------------------------------------------------------------------------ 4631# Generate a new, random GUID 4632# Inputs: <none> 4633# Returns: GUID string 4634my $guidCount; 4635sub NewGUID() 4636{ 4637 my @tm = localtime time; 4638 $guidCount = 0 unless defined $guidCount and ++$guidCount < 0x100; 4639 return sprintf('%.4d%.2d%.2d%.2d%.2d%.2d%.2X%.4X%.4X%.4X%.4X', 4640 $tm[5]+1900, $tm[4]+1, $tm[3], $tm[2], $tm[1], $tm[0], $guidCount, 4641 $$ & 0xffff, rand(0x10000), rand(0x10000), rand(0x10000)); 4642} 4643 4644#------------------------------------------------------------------------------ 4645# Make TIFF header for raw data 4646# Inputs: 0) width, 1) height, 2) num colour components, 3) bits, 4) resolution 4647# 5) color-map data for palette-color image (8 or 16 bit) 4648# Returns: TIFF header 4649# Notes: Multi-byte data must be little-endian 4650sub MakeTiffHeader($$$$;$$) 4651{ 4652 my ($w, $h, $cols, $bits, $res, $cmap) = @_; 4653 $res or $res = 72; 4654 my $saveOrder = GetByteOrder(); 4655 SetByteOrder('II'); 4656 if (not $cmap) { 4657 $cmap = ''; 4658 } elsif (length $cmap == 3 * 2**$bits) { 4659 # convert to short 4660 $cmap = pack 'v*', map { $_ | ($_<<8) } unpack 'C*', $cmap; 4661 } elsif (length $cmap != 6 * 2**$bits) { 4662 $cmap = ''; 4663 } 4664 my $cmo = $cmap ? 12 : 0; # offset due to ColorMap IFD entry 4665 my $hdr = 4666 "\x49\x49\x2a\0\x08\0\0\0\x0e\0" . # 0x00 14 menu entries: 4667 "\xfe\x00\x04\0\x01\0\0\0\x00\0\0\0" . # 0x0a SubfileType = 0 4668 "\x00\x01\x04\0\x01\0\0\0" . Set32u($w) . # 0x16 ImageWidth 4669 "\x01\x01\x04\0\x01\0\0\0" . Set32u($h) . # 0x22 ImageHeight 4670 "\x02\x01\x03\0" . Set32u($cols) . # 0x2e BitsPerSample 4671 Set32u($cols == 1 ? $bits : 0xb6 + $cmo) . 4672 "\x03\x01\x03\0\x01\0\0\0\x01\0\0\0" . # 0x3a Compression = 1 4673 "\x06\x01\x03\0\x01\0\0\0" . # 0x46 PhotometricInterpretation 4674 Set32u($cmap ? 3 : $cols == 1 ? 1 : 2) . 4675 "\x11\x01\x04\0\x01\0\0\0" . # 0x52 StripOffsets 4676 Set32u(0xcc + $cmo + length($cmap)) . 4677 "\x15\x01\x03\0\x01\0\0\0" . Set32u($cols) . # 0x5e SamplesPerPixel 4678 "\x16\x01\x04\0\x01\0\0\0" . Set32u($h) . # 0x6a RowsPerStrip 4679 "\x17\x01\x04\0\x01\0\0\0" . # 0x76 StripByteCounts 4680 Set32u($w * $h * $cols * int(($bits+7)/8)) . 4681 "\x1a\x01\x05\0\x01\0\0\0" . Set32u(0xbc + $cmo) . # 0x82 XResolution 4682 "\x1b\x01\x05\0\x01\0\0\0" . Set32u(0xc4 + $cmo) . # 0x8e YResolution 4683 "\x1c\x01\x03\0\x01\0\0\0\x01\0\0\0" . # 0x9a PlanarConfiguration = 1 4684 "\x28\x01\x03\0\x01\0\0\0\x02\0\0\0" . # 0xa6 ResolutionUnit = 2 4685 ($cmap ? # 0xb2 ColorMap [optional] 4686 "\x40\x01\x03\0" . Set32u(3 * 2**$bits) . "\xd8\0\0\0" : '') . 4687 "\0\0\0\0" . # 0xb2+$cmo (no IFD1) 4688 (Set16u($bits) x 3) . # 0xb6+$cmo BitsPerSample value 4689 Set32u($res) . "\x01\0\0\0" . # 0xbc+$cmo XResolution = 72 4690 Set32u($res) . "\x01\0\0\0" . # 0xc4+$cmo YResolution = 72 4691 $cmap; # 0xcc or 0xd8 (cmap and data go here) 4692 SetByteOrder($saveOrder); 4693 return $hdr; 4694} 4695 4696#------------------------------------------------------------------------------ 4697# Return current time in EXIF format 4698# Inputs: 0) [optional] ExifTool ref, 1) flag to include timezone (0 to disable, 4699# undef or 1 to include) 4700# Returns: time string 4701# - a consistent value is returned for each processed file 4702sub TimeNow(;$$) 4703{ 4704 my ($self, $tzFlag) = @_; 4705 my $timeNow; 4706 ref $self or $tzFlag = $self, $self = { }; 4707 if ($$self{Now}) { 4708 $timeNow = $$self{Now}[0]; 4709 } else { 4710 my $time = time(); 4711 my @tm = localtime $time; 4712 my $tz = TimeZoneString(\@tm, $time); 4713 $timeNow = sprintf("%4d:%.2d:%.2d %.2d:%.2d:%.2d", 4714 $tm[5]+1900, $tm[4]+1, $tm[3], 4715 $tm[2], $tm[1], $tm[0]); 4716 $$self{Now} = [ $timeNow, $tz ]; 4717 } 4718 $timeNow .= $$self{Now}[1] if $tzFlag or not defined $tzFlag; 4719 return $timeNow; 4720} 4721 4722#------------------------------------------------------------------------------ 4723# Inverse date/time print conversion (reformat to YYYY:mm:dd HH:MM:SS[.ss][+-HH:MM|Z]) 4724# Inputs: 0) ExifTool object ref, 1) Date/Time string, 2) timezone flag: 4725# 0 - remove timezone and sub-seconds if they exist 4726# 1 - add timezone if it doesn't exist 4727# undef - leave timezone alone 4728# 3) flag to allow date-only (YYYY, YYYY:mm or YYYY:mm:dd) or time without seconds 4729# Returns: formatted date/time string (or undef and issues warning on error) 4730# Notes: currently accepts different separators, but doesn't use DateFormat yet 4731my $strptimeLib; # strptime library name if available 4732sub InverseDateTime($$;$$) 4733{ 4734 my ($self, $val, $tzFlag, $dateOnly) = @_; 4735 my ($rtnVal, $tz); 4736 my $fmt = $$self{OPTIONS}{DateFormat}; 4737 # strip off timezone first if it exists 4738 if (not $fmt and $val =~ s/([+-])(\d{1,2}):?(\d{2})\s*(DST)?$//i) { 4739 $tz = sprintf("$1%.2d:$3", $2); 4740 } elsif (not $fmt and $val =~ s/Z$//i) { 4741 $tz = 'Z'; 4742 } else { 4743 $tz = ''; 4744 # allow special value of 'now' 4745 return $self->TimeNow($tzFlag) if lc($val) eq 'now'; 4746 } 4747 # only convert date if a format was specified and the date is recognizable 4748 if ($fmt) { 4749 unless (defined $strptimeLib) { 4750 if (eval { require POSIX::strptime }) { 4751 $strptimeLib = 'POSIX::strptime'; 4752 } elsif (eval { require Time::Piece }) { 4753 $strptimeLib = 'Time::Piece'; 4754 # (call use_locale() to convert localized date/time, 4755 # only available in Time::Piece 1.32 and later) 4756 eval { Time::Piece->use_locale() }; 4757 } else { 4758 $strptimeLib = ''; 4759 } 4760 } 4761 my ($lib, $wrn, @a); 4762TryLib: for ($lib=$strptimeLib; ; $lib='') { 4763 if (not $lib) { 4764 last unless $$self{OPTIONS}{StrictDate}; 4765 warn $wrn || "Install POSIX::strptime or Time::Piece for inverse date/time conversions\n"; 4766 return undef; 4767 } elsif ($lib eq 'POSIX::strptime') { 4768 @a = eval { POSIX::strptime($val, $fmt) }; 4769 } else { 4770 # protect against a negative epoch time, it can cause a hard crash in Windows 4771 if ($^O eq 'MSWin32' and $fmt =~ /%s/ and $val =~ /-\d/) { 4772 warn "Can't convert negative epoch time\n"; 4773 return undef; 4774 } 4775 @a = eval { 4776 my $t = Time::Piece->strptime($val, $fmt); 4777 return ($t->sec, $t->min, $t->hour, $t->mday, $t->_mon, $t->_year); 4778 }; 4779 } 4780 if (defined $a[5] and length $a[5]) { 4781 $a[5] += 1900; # add 1900 to year 4782 } else { 4783 $wrn = "Invalid date/time (no year) using $lib\n"; 4784 next; 4785 } 4786 ++$a[4] if defined $a[4] and length $a[4]; # add 1 to month 4787 my $i; 4788 foreach $i (0..4) { 4789 if (not defined $a[$i] or not length $a[$i]) { 4790 if ($i < 2 or $dateOnly) { # (allow missing minutes/seconds) 4791 $a[$i] = ' '; 4792 } else { 4793 $wrn = "Incomplete date/time specification using $lib\n"; 4794 next TryLib; 4795 } 4796 } elsif (length($a[$i]) < 2) { 4797 $$a[$i] = "0$a[$i]";# pad to 2 digits if necessary 4798 } 4799 } 4800 $val = join(':', @a[5,4,3]) . ' ' . join(':', @a[2,1,0]); 4801 last; 4802 } 4803 } 4804 if ($val =~ /(\d{4})/g) { # get YYYY 4805 my $yr = $1; 4806 my @a = ($val =~ /\d{1,2}/g); # get mm, dd, HH, and maybe MM, SS 4807 length($_) < 2 and $_ = "0$_" foreach @a; # pad to 2 digits if necessary 4808 if (@a >= 3) { 4809 my $ss = $a[4]; # get SS 4810 push @a, '00' while @a < 5; # add MM, SS if not given 4811 # get sub-seconds if they exist (must be after SS, and have leading ".") 4812 my $fs = (@a > 5 and $val =~ /(\.\d+)\s*$/) ? $1 : ''; 4813 # add/remove timezone if necessary 4814 if ($tzFlag) { 4815 if (not $tz) { 4816 if (eval { require Time::Local }) { 4817 # determine timezone offset for this time 4818 my @args = ($a[4],$a[3],$a[2],$a[1],$a[0]-1,$yr); 4819 my $diff = Time::Local::timegm(@args) - TimeLocal(@args); 4820 $tz = TimeZoneString($diff / 60); 4821 } else { 4822 $tz = 'Z'; # don't know time zone 4823 } 4824 } 4825 } elsif (defined $tzFlag) { 4826 $tz = $fs = ''; # remove timezone and sub-seconds 4827 } 4828 if (defined $ss and $ss < 60) { 4829 $ss = ":$ss"; 4830 } elsif ($dateOnly) { 4831 $ss = ''; 4832 } else { 4833 $ss = ':00'; 4834 } 4835 # construct properly formatted date/time string 4836 if ($a[0] < 1 or $a[0] > 12) { 4837 warn "Month '$a[0]' out of range 1..12\n"; 4838 return undef; 4839 } 4840 if ($a[1] < 1 or $a[1] > 31) { 4841 warn "Day '$a[1]' out of range 1..31\n"; 4842 return undef; 4843 } 4844 $a[2] > 24 and warn("Hour '$a[2]' out of range 0..24\n"), return undef; 4845 $a[3] > 59 and warn("Minutes '$a[3]' out of range 0..59\n"), return undef; 4846 $rtnVal = "$yr:$a[0]:$a[1] $a[2]:$a[3]$ss$fs$tz"; 4847 } elsif ($dateOnly) { 4848 $rtnVal = join ':', $yr, @a; 4849 } 4850 } 4851 $rtnVal or warn "Invalid date/time (use YYYY:mm:dd HH:MM:SS[.ss][+/-HH:MM|Z])\n"; 4852 return $rtnVal; 4853} 4854 4855#------------------------------------------------------------------------------ 4856# Set byte order according to our current preferences 4857# Inputs: 0) ExifTool object ref, 1) default byte order 4858# Returns: new byte order ('II' or 'MM') and sets current byte order 4859# Notes: takes the first of the following that is valid: 4860# 1) ByteOrder option 4861# 2) new value for ExifByteOrder 4862# 3) default byte order passed to this routine 4863# 4) makenote byte order from last file read 4864# 5) big endian 4865sub SetPreferredByteOrder($;$) 4866{ 4867 my ($self, $default) = @_; 4868 my $byteOrder = $self->Options('ByteOrder') || 4869 $self->GetNewValue('ExifByteOrder') || 4870 $default || $$self{MAKER_NOTE_BYTE_ORDER} || 'MM'; 4871 unless (SetByteOrder($byteOrder)) { 4872 warn "Invalid byte order '${byteOrder}'\n" if $self->Options('Verbose'); 4873 $byteOrder = $$self{MAKER_NOTE_BYTE_ORDER} || 'MM'; 4874 SetByteOrder($byteOrder); 4875 } 4876 return GetByteOrder(); 4877} 4878 4879#------------------------------------------------------------------------------ 4880# Assemble a continuing fraction into a rational value 4881# Inputs: 0) numerator, 1) denominator 4882# 2-N) list of fraction denominators, deepest first 4883# Returns: numerator, denominator (in list context) 4884sub AssembleRational($$@) 4885{ 4886 @_ < 3 and return @_; 4887 my ($num, $denom, $frac) = splice(@_, 0, 3); 4888 return AssembleRational($frac*$num+$denom, $num, @_); 4889} 4890 4891#------------------------------------------------------------------------------ 4892# Convert a floating point number (or 'inf' or 'undef' or a fraction) into a rational 4893# Inputs: 0) floating point number, 1) optional maximum value (defaults to 0x7fffffff) 4894# Returns: numerator, denominator (in list context) 4895# Notes: 4896# - the returned rational will be accurate to at least 8 significant figures if possible 4897# - eg. an input of 3.14159265358979 returns a rational of 104348/33215, 4898# which equals 3.14159265392142 and is accurate to 10 significant figures 4899# - the returned rational will be reduced to the lowest common denominator except when 4900# the input is a fraction in which case the input is returned unchanged 4901# - these routines were a bit tricky, but fun to write! 4902sub Rationalize($;$) 4903{ 4904 my $val = shift; 4905 return (1, 0) if $val eq 'inf'; 4906 return (0, 0) if $val eq 'undef'; 4907 return ($1,$2) if $val =~ m{^([-+]?\d+)/(\d+)$}; # accept fractional values 4908 # Note: Just testing "if $val" doesn't work because '0.0' is true! (ugghh!) 4909 return (0, 1) if $val == 0; 4910 my $sign = $val < 0 ? ($val = -$val, -1) : 1; 4911 my ($num, $denom, @fracs); 4912 my $frac = $val; 4913 my $maxInt = shift || 0x7fffffff; 4914 for (;;) { 4915 my ($n, $d) = AssembleRational(int($frac + 0.5), 1, @fracs); 4916 if ($n > $maxInt or $d > $maxInt) { 4917 last if defined $num; 4918 return ($sign, $maxInt) if $val < 1; 4919 return ($sign * $maxInt, 1); 4920 } 4921 ($num, $denom) = ($n, $d); # save last good values 4922 my $err = ($n/$d-$val) / $val; # get error of this rational 4923 last if abs($err) < 1e-8; # all done if error is small 4924 my $int = int($frac); 4925 unshift @fracs, $int; 4926 last unless $frac -= $int; 4927 $frac = 1 / $frac; 4928 } 4929 return ($num * $sign, $denom); 4930} 4931 4932#------------------------------------------------------------------------------ 4933# Utility routines to for writing binary data values 4934# Inputs: 0) value, 1) data ref, 2) offset 4935# Notes: prototype is (@) so values can be passed from list if desired 4936sub Set16s(@) 4937{ 4938 my $val = shift; 4939 $val < 0 and $val += 0x10000; 4940 return Set16u($val, @_); 4941} 4942sub Set32s(@) 4943{ 4944 my $val = shift; 4945 $val < 0 and $val += 0xffffffff, ++$val; 4946 return Set32u($val, @_); 4947} 4948sub Set64u(@) 4949{ 4950 my $val = $_[0]; 4951 my $hi = int($val / 4294967296); 4952 my $lo = Set32u($val - $hi * 4294967296); 4953 $hi = Set32u($hi); 4954 $val = GetByteOrder() eq 'MM' ? $hi . $lo : $lo . $hi; 4955 $_[1] and substr(${$_[1]}, $_[2], length($val)) = $val; 4956 return $val; 4957} 4958sub Set64s(@) 4959{ 4960 my $val = shift; 4961 $val < 0 and $val += 4294967296 * 4294967296; # (temporary hack won't really work due to round-off errors) 4962 return Set64u($val, @_); 4963} 4964sub SetRational64u(@) { 4965 my ($numer,$denom) = Rationalize($_[0],0xffffffff); 4966 my $val = Set32u($numer) . Set32u($denom); 4967 $_[1] and substr(${$_[1]}, $_[2], length($val)) = $val; 4968 return $val; 4969} 4970sub SetRational64s(@) { 4971 my ($numer,$denom) = Rationalize($_[0]); 4972 my $val = Set32s($numer) . Set32u($denom); 4973 $_[1] and substr(${$_[1]}, $_[2], length($val)) = $val; 4974 return $val; 4975} 4976sub SetRational32u(@) { 4977 my ($numer,$denom) = Rationalize($_[0],0xffff); 4978 my $val = Set16u($numer) . Set16u($denom); 4979 $_[1] and substr(${$_[1]}, $_[2], length($val)) = $val; 4980 return $val; 4981} 4982sub SetRational32s(@) { 4983 my ($numer,$denom) = Rationalize($_[0],0x7fff); 4984 my $val = Set16s($numer) . Set16u($denom); 4985 $_[1] and substr(${$_[1]}, $_[2], length($val)) = $val; 4986 return $val; 4987} 4988sub SetFixed16u(@) { 4989 my $val = int(shift() * 0x100 + 0.5); 4990 return Set16u($val, @_); 4991} 4992sub SetFixed16s(@) { 4993 my $val = shift; 4994 return Set16s(int($val * 0x100 + ($val < 0 ? -0.5 : 0.5)), @_); 4995} 4996sub SetFixed32u(@) { 4997 my $val = int(shift() * 0x10000 + 0.5); 4998 return Set32u($val, @_); 4999} 5000sub SetFixed32s(@) { 5001 my $val = shift; 5002 return Set32s(int($val * 0x10000 + ($val < 0 ? -0.5 : 0.5)), @_); 5003} 5004sub SetFloat(@) { 5005 my $val = SwapBytes(pack('f',$_[0]), 4); 5006 $_[1] and substr(${$_[1]}, $_[2], length($val)) = $val; 5007 return $val; 5008} 5009sub SetDouble(@) { 5010 # swap 32-bit words (ARM quirk) and bytes if necessary 5011 my $val = SwapBytes(SwapWords(pack('d',$_[0])), 8); 5012 $_[1] and substr(${$_[1]}, $_[2], length($val)) = $val; 5013 return $val; 5014} 5015#------------------------------------------------------------------------------ 5016# hash lookups for writing binary data values 5017my %writeValueProc = ( 5018 int8s => \&Set8s, 5019 int8u => \&Set8u, 5020 int16s => \&Set16s, 5021 int16u => \&Set16u, 5022 int16uRev => \&Set16uRev, 5023 int32s => \&Set32s, 5024 int32u => \&Set32u, 5025 int64s => \&Set64s, 5026 int64u => \&Set64u, 5027 rational32s => \&SetRational32s, 5028 rational32u => \&SetRational32u, 5029 rational64s => \&SetRational64s, 5030 rational64u => \&SetRational64u, 5031 fixed16u => \&SetFixed16u, 5032 fixed16s => \&SetFixed16s, 5033 fixed32u => \&SetFixed32u, 5034 fixed32s => \&SetFixed32s, 5035 float => \&SetFloat, 5036 double => \&SetDouble, 5037 ifd => \&Set32u, 5038); 5039# verify that we can write floats on this platform 5040{ 5041 my %writeTest = ( 5042 float => [ -3.14159, 'c0490fd0' ], 5043 double => [ -3.14159, 'c00921f9f01b866e' ], 5044 ); 5045 my $format; 5046 my $oldOrder = GetByteOrder(); 5047 SetByteOrder('MM'); 5048 foreach $format (keys %writeTest) { 5049 my ($val, $hex) = @{$writeTest{$format}}; 5050 # add floating point entries if we can write them 5051 next if unpack('H*', &{$writeValueProc{$format}}($val)) eq $hex; 5052 delete $writeValueProc{$format}; # we can't write them 5053 } 5054 SetByteOrder($oldOrder); 5055} 5056 5057#------------------------------------------------------------------------------ 5058# write binary data value (with current byte ordering) 5059# Inputs: 0) value, 1) format string 5060# 2) number of values: 5061# undef = 1 for numerical types, or data length for string/undef types 5062# -1 = number of space-delimited values in the input string 5063# 3) optional data reference, 4) value offset (may be negative for bytes from end) 5064# Returns: packed value (and sets value in data) or undef on error 5065# Notes: May modify input value to round for integer formats 5066sub WriteValue($$;$$$$) 5067{ 5068 my ($val, $format, $count, $dataPt, $offset) = @_; 5069 my $proc = $writeValueProc{$format}; 5070 my $packed; 5071 5072 if ($proc) { 5073 my @vals = split(' ',$val); 5074 if ($count) { 5075 $count = @vals if $count < 0; 5076 } else { 5077 $count = 1; # assume 1 if count not specified 5078 } 5079 $packed = ''; 5080 while ($count--) { 5081 $val = shift @vals; 5082 return undef unless defined $val; 5083 # validate numerical formats 5084 if ($format =~ /^int/) { 5085 unless (IsInt($val) or IsHex($val)) { 5086 return undef unless IsFloat($val); 5087 # round to nearest integer 5088 $val = int($val + ($val < 0 ? -0.5 : 0.5)); 5089 $_[0] = $val; 5090 } 5091 } elsif (not IsFloat($val)) { 5092 return undef unless $format =~ /^rational/ and ($val eq 'inf' or 5093 $val eq 'undef' or IsRational($val)); 5094 } 5095 $packed .= &$proc($val); 5096 } 5097 } elsif ($format eq 'string' or $format eq 'undef') { 5098 $format eq 'string' and $val .= "\0"; # null-terminate strings 5099 if ($count and $count > 0) { 5100 my $diff = $count - length($val); 5101 if ($diff) { 5102 #warn "wrong string length!\n"; 5103 # adjust length of string to match specified count 5104 if ($diff < 0) { 5105 if ($format eq 'string') { 5106 return undef unless $count; 5107 $val = substr($val, 0, $count - 1) . "\0"; 5108 } else { 5109 $val = substr($val, 0, $count); 5110 } 5111 } else { 5112 $val .= "\0" x $diff; 5113 } 5114 } 5115 } else { 5116 $count = length($val); 5117 } 5118 $dataPt and substr($$dataPt, $offset, $count) = $val; 5119 return $val; 5120 } else { 5121 warn "Sorry, Can't write $format values on this platform\n"; 5122 return undef; 5123 } 5124 $dataPt and substr($$dataPt, $offset, length($packed)) = $packed; 5125 return $packed; 5126} 5127 5128#------------------------------------------------------------------------------ 5129# Encode bit mask (the inverse of DecodeBits()) 5130# Inputs: 0) value to encode, 1) Reference to hash for encoding (or undef) 5131# 2) optional number of bits per word (defaults to 32), 3) total bits 5132# Returns: bit mask or undef on error (plus error string in list context) 5133sub EncodeBits($$;$$) 5134{ 5135 my ($val, $lookup, $bits, $num) = @_; 5136 $bits or $bits = 32; 5137 $num or $num = $bits; 5138 my $words = int(($num + $bits - 1) / $bits); 5139 my @outVal = (0) x $words; 5140 if ($val ne '(none)') { 5141 my @vals = split /\s*,\s*/, $val; 5142 foreach $val (@vals) { 5143 my $bit; 5144 if ($lookup) { 5145 $bit = ReverseLookup($val, $lookup); 5146 # (Note: may get non-numerical $bit values from Unknown() tags) 5147 unless (defined $bit) { 5148 if ($val =~ /\[(\d+)\]/) { # numerical bit specification 5149 $bit = $1; 5150 } else { 5151 # don't return error string unless more than one value 5152 return undef unless @vals > 1 and wantarray; 5153 return (undef, "no match for '${val}'"); 5154 } 5155 } 5156 } else { 5157 $bit = $val; 5158 } 5159 unless (IsInt($bit) and $bit < $num) { 5160 return undef unless wantarray; 5161 return (undef, IsInt($bit) ? 'bit number too high' : 'not an integer'); 5162 } 5163 my $word = int($bit / $bits); 5164 $outVal[$word] |= (1 << ($bit - $word * $bits)); 5165 } 5166 } 5167 return "@outVal"; 5168} 5169 5170#------------------------------------------------------------------------------ 5171# get current position in output file (or end of file if a scalar reference) 5172# Inputs: 0) file or scalar reference 5173# Returns: Current position or -1 on error 5174sub Tell($) 5175{ 5176 my $outfile = shift; 5177 if (UNIVERSAL::isa($outfile,'GLOB')) { 5178 return tell($outfile); 5179 } else { 5180 return length($$outfile); 5181 } 5182} 5183 5184#------------------------------------------------------------------------------ 5185# write to file or memory 5186# Inputs: 0) file or scalar reference, 1-N) list of stuff to write 5187# Returns: true on success 5188sub Write($@) 5189{ 5190 my $outfile = shift; 5191 if (UNIVERSAL::isa($outfile,'GLOB')) { 5192 return print $outfile @_; 5193 } elsif (ref $outfile eq 'SCALAR') { 5194 $$outfile .= join('', @_); 5195 return 1; 5196 } 5197 return 0; 5198} 5199 5200#------------------------------------------------------------------------------ 5201# Write trailer buffer to file (applying fixups if necessary) 5202# Inputs: 0) ExifTool object ref, 1) trailer dirInfo ref, 2) output file ref 5203# Returns: 1 on success 5204sub WriteTrailerBuffer($$$) 5205{ 5206 my ($self, $trailInfo, $outfile) = @_; 5207 if ($$self{DEL_GROUP}{Trailer}) { 5208 $self->VPrint(0, " Deleting trailer ($$trailInfo{Offset} bytes)\n"); 5209 ++$$self{CHANGED}; 5210 return 1; 5211 } 5212 my $pos = Tell($outfile); 5213 my $trailPt = $$trailInfo{OutFile}; 5214 # apply fixup if necessary (AFCP requires this) 5215 if ($$trailInfo{Fixup}) { 5216 if ($pos > 0) { 5217 # shift offsets to final AFCP location and write it out 5218 $$trailInfo{Fixup}{Shift} += $pos; 5219 $$trailInfo{Fixup}->ApplyFixup($trailPt); 5220 } else { 5221 $self->Error("Can't get file position for trailer offset fixup",1); 5222 } 5223 } 5224 return Write($outfile, $$trailPt); 5225} 5226 5227#------------------------------------------------------------------------------ 5228# Add trailers as a block 5229# Inputs: 0) ExifTool object ref, 1) [optional] trailer data raf, 5230# 1 or 2-N) trailer types to add (or none to add all) 5231# Returns: new trailer ref, or undef 5232# - increments CHANGED if trailer was added 5233sub AddNewTrailers($;@) 5234{ 5235 my ($self, @types) = @_; 5236 my $trailPt; 5237 ref $types[0] and $trailPt = shift @types; 5238 $types[0] or shift @types; # (in case undef data ref is passed) 5239 # add all possible trailers if none specified (currently only CanonVRD) 5240 @types or @types = qw(CanonVRD CanonDR4); 5241 # add trailers as a block (if not done already) 5242 my $type; 5243 foreach $type (@types) { 5244 next unless $$self{NEW_VALUE}{$Image::ExifTool::Extra{$type}}; 5245 next if $$self{"Did$type"}; 5246 my $val = $self->GetNewValue($type) or next; 5247 # DR4 record must be wrapped in VRD trailer package 5248 if ($type eq 'CanonDR4') { 5249 next if $$self{DidCanonVRD}; # (only allow one VRD trailer) 5250 require Image::ExifTool::CanonVRD; 5251 $val = Image::ExifTool::CanonVRD::WrapDR4($val); 5252 $$self{DidCanonVRD} = 1; 5253 } 5254 my $verb = $trailPt ? 'Writing' : 'Adding'; 5255 $self->VPrint(0, " $verb $type as a block\n"); 5256 if ($trailPt) { 5257 $$trailPt .= $val; 5258 } else { 5259 $trailPt = \$val; 5260 } 5261 $$self{"Did$type"} = 1; 5262 ++$$self{CHANGED}; 5263 } 5264 return $trailPt; 5265} 5266 5267#------------------------------------------------------------------------------ 5268# Write segment, splitting up into multiple segments if necessary 5269# Inputs: 0) file or scalar reference, 1) segment marker 5270# 2) segment header, 3) segment data ref, 4) segment type 5271# Returns: number of segments written, or 0 on error 5272# Notes: Writes a single empty segment if data is empty 5273sub WriteMultiSegment($$$$;$) 5274{ 5275 my ($outfile, $marker, $header, $dataPt, $type) = @_; 5276 $type or $type = ''; 5277 my $len = length($$dataPt); 5278 my $hdr = "\xff" . chr($marker); 5279 my $count = 0; 5280 my $maxLen = $maxSegmentLen - length($header); 5281 $maxLen -= 2 if $type eq 'ICC'; # leave room for segment counters 5282 my $num = int(($len + $maxLen - 1) / $maxLen); # number of segments to write 5283 my $n = 0; 5284 # write data, splitting into multiple segments if necessary 5285 # (each segment gets its own header) 5286 for (;;) { 5287 ++$count; 5288 my $size = $len - $n; 5289 if ($size > $maxLen) { 5290 $size = $maxLen; 5291 # avoid starting an Extended EXIF segment with a valid TIFF header 5292 # (because we would interpret that as a separate EXIF segment) 5293 --$size if $type eq 'EXIF' and $n+$maxLen <= $len-4 and 5294 substr($$dataPt, $n+$maxLen, 4) =~ /^(MM\0\x2a|II\x2a\0)/; 5295 } 5296 my $buff = substr($$dataPt,$n,$size); 5297 $n += $size; 5298 $size += length($header); 5299 if ($type eq 'ICC') { 5300 $buff = pack('CC', $count, $num) . $buff; 5301 $size += 2; 5302 } 5303 # write the new segment with appropriate header 5304 my $segHdr = $hdr . pack('n', $size + 2); 5305 Write($outfile, $segHdr, $header, $buff) or return 0; 5306 last if $n >= $len; 5307 } 5308 return $count; 5309} 5310 5311#------------------------------------------------------------------------------ 5312# Write XMP segment(s) to JPEG file 5313# Inputs: 0) ExifTool object ref, 1) outfile ref, 2) XMP data ref, 5314# 3) extended XMP data ref, 4) 32-char extended XMP GUID (or undef if no extended data) 5315# Returns: true on success, false on write error 5316sub WriteMultiXMP($$$$$) 5317{ 5318 my ($self, $outfile, $dataPt, $extPt, $guid) = @_; 5319 my $success = 1; 5320 5321 # write main XMP segment 5322 my $size = length($$dataPt) + length($xmpAPP1hdr); 5323 if ($size > $maxXMPLen) { 5324 $self->Error("XMP block too large for JPEG segment! ($size bytes)", 1); 5325 return 1; 5326 } 5327 my $app1hdr = "\xff\xe1" . pack('n', $size + 2); 5328 Write($outfile, $app1hdr, $xmpAPP1hdr, $$dataPt) or $success = 0; 5329 # write extended XMP segment(s) if necessary 5330 if (defined $guid) { 5331 $size = length($$extPt); 5332 my $maxLen = $maxXMPLen - 75; # maximum size without 75-byte header 5333 my $off; 5334 for ($off=0; $off<$size; $off+=$maxLen) { 5335 # header(75) = signature(35) + guid(32) + size(4) + offset(4) 5336 my $len = $size - $off; 5337 $len = $maxLen if $len > $maxLen; 5338 $app1hdr = "\xff\xe1" . pack('n', $len + 75 + 2); 5339 $self->VPrint(0, "Writing extended XMP segment ($len bytes)\n"); 5340 Write($outfile, $app1hdr, $xmpExtAPP1hdr, $guid, pack('N2', $size, $off), 5341 substr($$extPt, $off, $len)) or $success = 0; 5342 } 5343 } 5344 return $success; 5345} 5346 5347#------------------------------------------------------------------------------ 5348# WriteJPEG : Write JPEG image 5349# Inputs: 0) ExifTool object reference, 1) dirInfo reference 5350# Returns: 1 on success, 0 if this wasn't a valid JPEG file, or -1 if 5351# an output file was specified and a write error occurred 5352sub WriteJPEG($$) 5353{ 5354 my ($self, $dirInfo) = @_; 5355 my $outfile = $$dirInfo{OutFile}; 5356 my $raf = $$dirInfo{RAF}; 5357 my ($ch, $s, $length,$err, %doneDir, $isEXV, $creatingEXV); 5358 my $verbose = $$self{OPTIONS}{Verbose}; 5359 my $out = $$self{OPTIONS}{TextOut}; 5360 my $rtnVal = 0; 5361 my %dumpParms = ( Out => $out ); 5362 my ($writeBuffer, $oldOutfile); # used to buffer writing until PreviewImage position is known 5363 5364 # check to be sure this is a valid JPG or EXV file 5365 unless ($raf->Read($s,2) == 2 and $s eq "\xff\xd8") { 5366 if (defined $s and length $s) { 5367 return 0 unless $s eq "\xff\x01" and $raf->Read($s,5) == 5 and $s eq 'Exiv2'; 5368 } else { 5369 return 0 unless $$self{FILE_TYPE} eq 'EXV'; 5370 $s = 'Exiv2'; 5371 $creatingEXV = 1; 5372 } 5373 Write($outfile,"\xff\x01") or $err = 1; 5374 $isEXV = 1; 5375 } 5376 $dumpParms{MaxLen} = 128 unless $verbose > 3; 5377 5378 delete $$self{PREVIEW_INFO}; # reset preview information 5379 delete $$self{DEL_PREVIEW}; # reset flag to delete preview 5380 5381 Write($outfile, $s) or $err = 1; 5382 # figure out what segments we need to write for the tags we have set 5383 my $addDirs = $$self{ADD_DIRS}; 5384 my $editDirs = $$self{EDIT_DIRS}; 5385 my $delGroup = $$self{DEL_GROUP}; 5386 my $path = $$self{PATH}; 5387 my $pn = scalar @$path; 5388 5389 # set input record separator to 0xff (the JPEG marker) to make reading quicker 5390 local $/ = "\xff"; 5391# 5392# pre-scan image to determine if any create-able segment already exists 5393# 5394 my $pos = $raf->Tell(); 5395 my ($marker, @dirOrder, %dirCount); 5396 Prescan: for (;;) { 5397 # read up to next marker (JPEG markers begin with 0xff) 5398 $raf->ReadLine($s) or last; 5399 # JPEG markers can be padded with unlimited 0xff's 5400 for (;;) { 5401 $raf->Read($ch, 1) or last Prescan; 5402 $marker = ord($ch); 5403 last unless $marker == 0xff; 5404 } 5405 my $dirName; 5406 # stop pre-scan at SOS (end of meta information) or EOI (end of image) 5407 if ($marker == 0xda or $marker == 0xd9) { 5408 $dirName = $jpegMarker{$marker}; 5409 push(@dirOrder, $dirName); 5410 $dirCount{$dirName} = 1; 5411 last; 5412 } 5413 # handle SOF markers: SOF0-SOF15, except DHT(0xc4), JPGA(0xc8) and DAC(0xcc) 5414 if (($marker & 0xf0) == 0xc0 and ($marker == 0xc0 or $marker & 0x03)) { 5415 last unless $raf->Seek(7, 1); 5416 # read data for all markers except stand-alone 5417 # markers 0x00, 0x01 and 0xd0-0xd7 (NULL, TEM, RST0-RST7) 5418 } elsif ($marker!=0x00 and $marker!=0x01 and ($marker<0xd0 or $marker>0xd7)) { 5419 # read record length word 5420 last unless $raf->Read($s, 2) == 2; 5421 my $len = unpack('n',$s); # get data length 5422 last unless defined($len) and $len >= 2; 5423 $len -= 2; # subtract size of length word 5424 if (($marker & 0xf0) == 0xe0) { # is this an APP segment? 5425 my $n = $len < 64 ? $len : 64; 5426 $raf->Read($s, $n) == $n or last; 5427 $len -= $n; 5428 # Note: only necessary to recognize APP segments that we can create, 5429 # or delete as a group (and the names below should match @delGroups) 5430 if ($marker == 0xe0) { 5431 $s =~ /^JFIF\0/ and $dirName = 'JFIF'; 5432 $s =~ /^JFXX\0\x10/ and $dirName = 'JFXX'; 5433 $s =~ /^(II|MM).{4}HEAPJPGM/s and $dirName = 'CIFF'; 5434 } elsif ($marker == 0xe1) { 5435 if ($s =~ /^(.{0,4})$exifAPP1hdr(.{1,4})/is) { 5436 $dirName = 'IFD0'; 5437 my ($junk, $bytes) = ($1, $2); 5438 # support multi-segment EXIF 5439 if (@dirOrder and $dirOrder[-1] =~ /^(IFD0|ExtendedEXIF)$/ and 5440 not length $junk and $bytes !~ /^(MM\0\x2a|II\x2a\0)/) 5441 { 5442 $dirName = 'ExtendedEXIF'; 5443 } 5444 } 5445 $s =~ /^$xmpAPP1hdr/ and $dirName = 'XMP'; 5446 $s =~ /^$xmpExtAPP1hdr/ and $dirName = 'XMP'; 5447 } elsif ($marker == 0xe2) { 5448 $s =~ /^ICC_PROFILE\0/ and $dirName = 'ICC_Profile'; 5449 $s =~ /^FPXR\0/ and $dirName = 'FlashPix'; 5450 $s =~ /^MPF\0/ and $dirName = 'MPF'; 5451 } elsif ($marker == 0xe3) { 5452 $s =~ /^(Meta|META|Exif)\0\0/ and $dirName = 'Meta'; 5453 } elsif ($marker == 0xe5) { 5454 $s =~ /^RMETA\0/ and $dirName = 'RMETA'; 5455 } elsif ($marker == 0xec) { 5456 $s =~ /^Ducky/ and $dirName = 'Ducky'; 5457 } elsif ($marker == 0xed) { 5458 $s =~ /^$psAPP13hdr/ and $dirName = 'Photoshop'; 5459 } elsif ($marker == 0xee) { 5460 $s =~ /^Adobe/ and $dirName = 'Adobe'; 5461 } 5462 # initialize doneDir as a flag that the directory exists 5463 # (unless we are deleting it anyway) 5464 $doneDir{$dirName} = 0 if defined $dirName and not $$delGroup{$dirName}; 5465 } 5466 $raf->Seek($len, 1) or last; 5467 } 5468 $dirName or $dirName = JpegMarkerName($marker); 5469 $dirCount{$dirName} = ($dirCount{$dirName} || 0) + 1; 5470 push @dirOrder, $dirName; 5471 } 5472 unless ($marker and $marker == 0xda) { 5473 $isEXV or $self->Error('Corrupted JPEG image'), return 1; 5474 $marker and $marker != 0xd9 and $self->Error('Corrupted EXV file'), return 1; 5475 } 5476 $raf->Seek($pos, 0) or $self->Error('Seek error'), return 1; 5477# 5478# re-write the image 5479# 5480 my ($combinedSegData, $segPos, $firstSegPos, %extendedXMP); 5481 my (@iccChunk, $iccChunkCount, $iccChunksTotal); 5482 # read through each segment in the JPEG file 5483 Marker: for (;;) { 5484 5485 # read up to next marker (JPEG markers begin with 0xff) 5486 my $segJunk; 5487 $raf->ReadLine($segJunk) or $segJunk = ''; 5488 # remove the 0xff but write the rest of the junk up to this point 5489 # (this will handle the data after the first 7 bytes of SOF segments) 5490 chomp($segJunk); 5491 Write($outfile, $segJunk) if length $segJunk; 5492 # JPEG markers can be padded with unlimited 0xff's 5493 for (;;) { 5494 if ($raf->Read($ch, 1)) { 5495 $marker = ord($ch); 5496 last unless $marker == 0xff; 5497 } elsif ($creatingEXV) { 5498 # create EXV from scratch 5499 $marker = 0xd9; # EOI 5500 push @dirOrder, 'EOI'; 5501 $dirCount{EOI} = 1; 5502 last; 5503 } else { 5504 $self->Error('Format error'); 5505 return 1; 5506 } 5507 } 5508 # read the segment data 5509 my $segData; 5510 # handle SOF markers: SOF0-SOF15, except DHT(0xc4), JPGA(0xc8) and DAC(0xcc) 5511 if (($marker & 0xf0) == 0xc0 and ($marker == 0xc0 or $marker & 0x03)) { 5512 last unless $raf->Read($segData, 7) == 7; 5513 # read data for all markers except stand-alone 5514 # markers 0x00, 0x01 and 0xd0-0xd7 (NULL, TEM, EOI, RST0-RST7) 5515 } elsif ($marker!=0x00 and $marker!=0x01 and $marker!=0xd9 and 5516 ($marker<0xd0 or $marker>0xd7)) 5517 { 5518 # read record length word 5519 last unless $raf->Read($s, 2) == 2; 5520 my $len = unpack('n',$s); # get data length 5521 last unless defined($len) and $len >= 2; 5522 $segPos = $raf->Tell(); 5523 $len -= 2; # subtract size of length word 5524 last unless $raf->Read($segData, $len) == $len; 5525 } 5526 # initialize variables for this segment 5527 my $hdr = "\xff" . chr($marker); # segment header 5528 my $markerName = JpegMarkerName($marker); 5529 my $dirName = shift @dirOrder; # get directory name 5530# 5531# create all segments that must come before this one 5532# (nothing comes before SOI or after SOS) 5533# 5534 while ($markerName ne 'SOI') { 5535 if (exists $$addDirs{JFIF} and not defined $doneDir{JFIF}) { 5536 $doneDir{JFIF} = 1; 5537 if (defined $doneDir{Adobe}) { 5538 # JFIF overrides Adobe APP14 colour components, so don't allow this 5539 # (ref https://docs.oracle.com/javase/8/docs/api/javax/imageio/metadata/doc-files/jpeg_metadata.html) 5540 $self->Warn('Not creating JFIF in JPEG with Adobe APP14'); 5541 } else { 5542 if ($verbose) { 5543 print $out "Creating APP0:\n"; 5544 print $out " Creating JFIF with default values\n"; 5545 } 5546 my $jfif = "\x01\x02\x01\0\x48\0\x48\0\0"; 5547 SetByteOrder('MM'); 5548 my $tagTablePtr = GetTagTable('Image::ExifTool::JFIF::Main'); 5549 my %dirInfo = ( 5550 DataPt => \$jfif, 5551 DirStart => 0, 5552 DirLen => length $jfif, 5553 Parent => 'JFIF', 5554 ); 5555 # must temporarily remove JFIF from DEL_GROUP so we can 5556 # delete JFIF and add it back again in a single step 5557 my $delJFIF = $$delGroup{JFIF}; 5558 delete $$delGroup{JFIF}; 5559 $$path[$pn] = 'JFIF'; 5560 my $newData = $self->WriteDirectory(\%dirInfo, $tagTablePtr); 5561 $$delGroup{JFIF} = $delJFIF if defined $delJFIF; 5562 if (defined $newData and length $newData) { 5563 my $app0hdr = "\xff\xe0" . pack('n', length($newData) + 7); 5564 Write($outfile,$app0hdr,"JFIF\0",$newData) or $err = 1; 5565 } 5566 } 5567 } 5568 # don't create anything before APP0 or APP1 EXIF (containing IFD0) 5569 last if $markerName eq 'APP0' or $dirCount{IFD0} or $dirCount{ExtendedEXIF}; 5570 # EXIF information must come immediately after APP0 5571 if (exists $$addDirs{IFD0} and not defined $doneDir{IFD0}) { 5572 $doneDir{IFD0} = 1; 5573 $verbose and print $out "Creating APP1:\n"; 5574 # write new EXIF data 5575 $$self{TIFF_TYPE} = 'APP1'; 5576 my $tagTablePtr = GetTagTable('Image::ExifTool::Exif::Main'); 5577 my %dirInfo = ( 5578 DirName => 'IFD0', 5579 Parent => 'APP1', 5580 ); 5581 $$path[$pn] = 'APP1'; 5582 my $buff = $self->WriteDirectory(\%dirInfo, $tagTablePtr, \&WriteTIFF); 5583 if (defined $buff and length $buff) { 5584 if (length($buff) + length($exifAPP1hdr) > $maxSegmentLen) { 5585 if ($self->Options('NoMultiExif')) { 5586 $self->Error('EXIF is too large for JPEG segment'); 5587 } else { 5588 $self->Warn('Creating multi-segment EXIF',1); 5589 } 5590 } 5591 # switch to buffered output if required 5592 if (($$self{PREVIEW_INFO} or $$self{LeicaTrailer}) and not $oldOutfile) { 5593 $writeBuffer = ''; 5594 $oldOutfile = $outfile; 5595 $outfile = \$writeBuffer; 5596 # account for segment, EXIF and TIFF headers 5597 $$self{PREVIEW_INFO}{Fixup}{Start} += 18 if $$self{PREVIEW_INFO}; 5598 $$self{LeicaTrailer}{Fixup}{Start} += 18 if $$self{LeicaTrailer}; 5599 } 5600 # write as multi-segment 5601 my $n = WriteMultiSegment($outfile, 0xe1, $exifAPP1hdr, \$buff, 'EXIF'); 5602 if (not $n) { 5603 $err = 1; 5604 } elsif ($n > 1 and $oldOutfile) { 5605 # (punt on this because updating the pointers would be a real pain) 5606 $self->Error("Can't write multi-segment EXIF with external pointers"); 5607 } 5608 ++$$self{CHANGED}; 5609 } 5610 } 5611 # APP13 Photoshop segment next 5612 last if $dirCount{Photoshop}; 5613 if (exists $$addDirs{Photoshop} and not defined $doneDir{Photoshop}) { 5614 $doneDir{Photoshop} = 1; 5615 $verbose and print $out "Creating APP13:\n"; 5616 # write new APP13 Photoshop record to memory 5617 my $tagTablePtr = GetTagTable('Image::ExifTool::Photoshop::Main'); 5618 my %dirInfo = ( 5619 Parent => 'APP13', 5620 ); 5621 $$path[$pn] = 'APP13'; 5622 my $buff = $self->WriteDirectory(\%dirInfo, $tagTablePtr); 5623 if (defined $buff and length $buff) { 5624 WriteMultiSegment($outfile, 0xed, $psAPP13hdr, \$buff) or $err = 1; 5625 ++$$self{CHANGED}; 5626 } 5627 } 5628 # then APP1 XMP segment 5629 last if $dirCount{XMP}; 5630 if (exists $$addDirs{XMP} and not defined $doneDir{XMP}) { 5631 $doneDir{XMP} = 1; 5632 $verbose and print $out "Creating APP1:\n"; 5633 # write new XMP data 5634 my $tagTablePtr = GetTagTable('Image::ExifTool::XMP::Main'); 5635 my %dirInfo = ( 5636 Parent => 'APP1', 5637 # specify MaxDataLen so XMP is split if required 5638 MaxDataLen => $maxXMPLen - length($xmpAPP1hdr), 5639 ); 5640 $$path[$pn] = 'APP1'; 5641 my $buff = $self->WriteDirectory(\%dirInfo, $tagTablePtr); 5642 if (defined $buff and length $buff) { 5643 WriteMultiXMP($self, $outfile, \$buff, $dirInfo{ExtendedXMP}, 5644 $dirInfo{ExtendedGUID}) or $err = 1; 5645 } 5646 } 5647 # then APP2 ICC_Profile segment 5648 last if $dirCount{ICC_Profile}; 5649 if (exists $$addDirs{ICC_Profile} and not defined $doneDir{ICC_Profile}) { 5650 $doneDir{ICC_Profile} = 1; 5651 next if $$delGroup{ICC_Profile} and $$delGroup{ICC_Profile} != 2; 5652 $verbose and print $out "Creating APP2:\n"; 5653 # write new ICC_Profile data 5654 my $tagTablePtr = GetTagTable('Image::ExifTool::ICC_Profile::Main'); 5655 my %dirInfo = ( 5656 Parent => 'APP2', 5657 ); 5658 $$path[$pn] = 'APP2'; 5659 my $buff = $self->WriteDirectory(\%dirInfo, $tagTablePtr); 5660 if (defined $buff and length $buff) { 5661 WriteMultiSegment($outfile, 0xe2, "ICC_PROFILE\0", \$buff, 'ICC') or $err = 1; 5662 ++$$self{CHANGED}; 5663 } 5664 } 5665 # then APP12 Ducky segment 5666 last if $dirCount{Ducky}; 5667 if (exists $$addDirs{Ducky} and not defined $doneDir{Ducky}) { 5668 $doneDir{Ducky} = 1; 5669 $verbose and print $out "Creating APP12 Ducky:\n"; 5670 # write new Ducky segment data 5671 my $tagTablePtr = GetTagTable('Image::ExifTool::APP12::Ducky'); 5672 my %dirInfo = ( 5673 Parent => 'APP12', 5674 ); 5675 $$path[$pn] = 'APP12'; 5676 my $buff = $self->WriteDirectory(\%dirInfo, $tagTablePtr); 5677 if (defined $buff and length $buff) { 5678 my $size = length($buff) + 5; 5679 if ($size <= $maxSegmentLen) { 5680 # write the new segment with appropriate header 5681 my $app12hdr = "\xff\xec" . pack('n', $size + 2); 5682 Write($outfile, $app12hdr, 'Ducky', $buff) or $err = 1; 5683 } else { 5684 $self->Warn("APP12 Ducky segment too large! ($size bytes)"); 5685 } 5686 } 5687 } 5688 # then APP14 Adobe segment 5689 last if $dirCount{Adobe}; 5690 if (exists $$addDirs{Adobe} and not defined $doneDir{Adobe}) { 5691 $doneDir{Adobe} = 1; 5692 my $buff = $self->GetNewValue('Adobe'); 5693 if ($buff) { 5694 $verbose and print $out "Creating APP14:\n Creating Adobe segment\n"; 5695 my $size = length($buff); 5696 if ($size <= $maxSegmentLen) { 5697 # write the new segment with appropriate header 5698 my $app14hdr = "\xff\xee" . pack('n', $size + 2); 5699 Write($outfile, $app14hdr, $buff) or $err = 1; 5700 ++$$self{CHANGED}; 5701 } else { 5702 $self->Warn("APP14 Adobe segment too large! ($size bytes)"); 5703 } 5704 } 5705 } 5706 # finally, COM segment 5707 last if $dirCount{COM}; 5708 if (exists $$addDirs{COM} and not defined $doneDir{COM}) { 5709 $doneDir{COM} = 1; 5710 next if $$delGroup{File} and $$delGroup{File} != 2; 5711 my $newComment = $self->GetNewValue('Comment'); 5712 if (defined $newComment) { 5713 if ($verbose) { 5714 print $out "Creating COM:\n"; 5715 $self->VerboseValue('+ Comment', $newComment); 5716 } 5717 WriteMultiSegment($outfile, 0xfe, '', \$newComment) or $err = 1; 5718 ++$$self{CHANGED}; 5719 } 5720 } 5721 last; # didn't want to loop anyway 5722 } 5723 $$path[$pn] = $markerName; 5724 # decrement counter for this directory since we are about to process it 5725 --$dirCount{$dirName}; 5726# 5727# rewrite existing segments 5728# 5729 # handle SOF markers: SOF0-SOF15, except DHT(0xc4), JPGA(0xc8) and DAC(0xcc) 5730 if (($marker & 0xf0) == 0xc0 and ($marker == 0xc0 or $marker & 0x03)) { 5731 $verbose and print $out "JPEG $markerName:\n"; 5732 Write($outfile, $hdr, $segData) or $err = 1; 5733 next; 5734 } elsif ($marker == 0xda) { # SOS 5735 pop @$path; 5736 $verbose and print $out "JPEG SOS\n"; 5737 # write SOS segment 5738 $s = pack('n', length($segData) + 2); 5739 Write($outfile, $hdr, $s, $segData) or $err = 1; 5740 my ($buff, $endPos, $trailInfo); 5741 my $delPreview = $$self{DEL_PREVIEW}; 5742 $trailInfo = IdentifyTrailer($raf) unless $$delGroup{Trailer}; 5743 my $nvTrail = $self->GetNewValueHash($Image::ExifTool::Extra{Trailer}); 5744 unless ($oldOutfile or $delPreview or $trailInfo or $$delGroup{Trailer} or $nvTrail) { 5745 # blindly copy the rest of the file 5746 while ($raf->Read($buff, 65536)) { 5747 Write($outfile, $buff) or $err = 1, last; 5748 } 5749 $rtnVal = 1; # success unless we have a file write error 5750 last; # all done 5751 } 5752 # write the rest of the image (as quickly as possible) up to the EOI 5753 my $endedWithFF; 5754 for (;;) { 5755 my $n = $raf->Read($buff, 65536) or last Marker; 5756 if (($endedWithFF and $buff =~ m/^\xd9/sg) or 5757 $buff =~ m/\xff\xd9/sg) 5758 { 5759 $rtnVal = 1; # the JPEG is OK 5760 # write up to the EOI 5761 my $pos = pos($buff); 5762 Write($outfile, substr($buff, 0, $pos)) or $err = 1; 5763 $buff = substr($buff, $pos); 5764 last; 5765 } 5766 unless ($n == 65536) { 5767 $self->Error('JPEG EOI marker not found'); 5768 last Marker; 5769 } 5770 Write($outfile, $buff) or $err = 1; 5771 $endedWithFF = substr($buff, 65535, 1) eq "\xff" ? 1 : 0; 5772 } 5773 # remember position of last data copied 5774 $endPos = $raf->Tell() - length($buff); 5775 # write new trailer if specified 5776 if ($nvTrail) { 5777 # access new value directly to avoid copying a potentially very large data block 5778 if ($$nvTrail{Value} and $$nvTrail{Value}[0]) { # (note: "0" will also delete the trailer) 5779 $self->VPrint(0, ' Writing new trailer'); 5780 Write($outfile, $$nvTrail{Value}[0]) or $err = 1; 5781 ++$$self{CHANGED}; 5782 } elsif ($raf->Seek(0, 2) and $raf->Tell() != $endPos) { 5783 $self->VPrint(0, ' Deleting trailer (', $raf->Tell() - $endPos, ' bytes)'); 5784 ++$$self{CHANGED}; # changed if there was previously a trailer 5785 } 5786 last; # all done 5787 } 5788 # rewrite existing trailers 5789 if ($trailInfo) { 5790 my $tbuf = ''; 5791 $raf->Seek(-length($buff), 1); # seek back to just after EOI 5792 $$trailInfo{OutFile} = \$tbuf; # rewrite the trailer 5793 $$trailInfo{ScanForAFCP} = 1; # scan if necessary 5794 $self->ProcessTrailers($trailInfo) or undef $trailInfo; 5795 } 5796 if (not $oldOutfile) { 5797 # do nothing special 5798 } elsif ($$self{LeicaTrailer}) { 5799 my $trailLen; 5800 if ($trailInfo) { 5801 $trailLen = $$trailInfo{DataPos} - $endPos; 5802 } else { 5803 $raf->Seek(0, 2) or $err = 1; 5804 $trailLen = $raf->Tell() - $endPos; 5805 } 5806 my $fixup = $$self{LeicaTrailer}{Fixup}; 5807 $$self{LeicaTrailer}{TrailPos} = $endPos; 5808 $$self{LeicaTrailer}{TrailLen} = $trailLen; 5809 # get _absolute_ position of new Leica trailer 5810 my $absPos = Tell($oldOutfile) + length($$outfile); 5811 require Image::ExifTool::Panasonic; 5812 my $dat = Image::ExifTool::Panasonic::ProcessLeicaTrailer($self, $absPos); 5813 # allow some junk before Leica trailer (just in case) 5814 my $junk = $$self{LeicaTrailerPos} - $endPos; 5815 # set MakerNote pointer and size (subtract 10 for segment and EXIF headers) 5816 $fixup->SetMarkerPointers($outfile, 'LeicaTrailer', length($$outfile) - 10 + $junk); 5817 # use this fixup to set the size too (sneaky) 5818 my $trailSize = defined($dat) ? length($dat) - $junk : $$self{LeicaTrailer}{Size}; 5819 $$fixup{Start} -= 4; $$fixup{Shift} += 4; 5820 $fixup->SetMarkerPointers($outfile, 'LeicaTrailer', $trailSize) if defined $trailSize; 5821 $$fixup{Start} += 4; $$fixup{Shift} -= 4; 5822 # clean up and write the buffered data 5823 $outfile = $oldOutfile; 5824 undef $oldOutfile; 5825 Write($outfile, $writeBuffer) or $err = 1; 5826 undef $writeBuffer; 5827 if (defined $dat) { 5828 Write($outfile, $dat) or $err = 1; # write new Leica trailer 5829 $delPreview = 1; # delete existing Leica trailer 5830 } 5831 } else { 5832 # locate preview image and fix up preview offsets 5833 my $scanLen = $$self{Make} =~ /^SONY/i ? 65536 : 1024; 5834 if (length($buff) < $scanLen) { # make sure we have enough trailer to scan 5835 my $buf2; 5836 $buff .= $buf2 if $raf->Read($buf2, $scanLen - length($buff)); 5837 } 5838 # get new preview image position, relative to EXIF base 5839 my $newPos = length($$outfile) - 10; # (subtract 10 for segment and EXIF headers) 5840 my $junkLen; 5841 # adjust position if image isn't at the start (eg. Olympus E-1/E-300) 5842 if ($buff =~ /(\xff\xd8\xff.|.\xd8\xff\xdb)(..)/sg) { 5843 my ($jpegHdr, $segLen) = ($1, $2); 5844 $junkLen = pos($buff) - 6; 5845 # Sony previewimage trailer has a 32 byte header 5846 if ($$self{Make} =~ /^SONY/i and $junkLen > 32) { 5847 # with some newer Sony models, the makernotes preview pointer 5848 # points to JPEG at end of EXIF inside MPImage preview (what a pain!) 5849 if ($jpegHdr eq "\xff\xd8\xff\xe1") { # is the first segment EXIF? 5850 $segLen = unpack('n', $segLen); # the EXIF segment length 5851 # Sony PreviewImage starts with last 2 bytes of EXIF segment 5852 # (and first byte is usually "\0", not "\xff", so don't check this) 5853 if (length($buff) > $junkLen + $segLen + 6 and 5854 substr($buff, $junkLen + $segLen + 3, 3) eq "\xd8\xff\xdb") 5855 { 5856 $junkLen += $segLen + 2; 5857 # (note: this will not copy the trailer after PreviewImage, 5858 # which is a 14kB block full of zeros for the A77) 5859 } 5860 } 5861 $junkLen -= 32; 5862 } 5863 $newPos += $junkLen; 5864 } 5865 # fix up the preview offsets to point to the start of the new image 5866 my $previewInfo = $$self{PREVIEW_INFO}; 5867 delete $$self{PREVIEW_INFO}; 5868 my $fixup = $$previewInfo{Fixup}; 5869 $newPos += ($$previewInfo{BaseShift} || 0); 5870 # adjust to absolute file offset if necessary (Samsung STMN) 5871 $newPos += Tell($oldOutfile) + 10 if $$previewInfo{Absolute}; 5872 if ($$previewInfo{Relative}) { 5873 # adjust for our base by looking at how far the pointer got shifted 5874 $newPos -= ($fixup->GetMarkerPointers($outfile, 'PreviewImage') || 0); 5875 } elsif ($$previewInfo{ChangeBase}) { 5876 # Leica S2 uses relative offsets for the preview only (leica sucks) 5877 my $makerOffset = $fixup->GetMarkerPointers($outfile, 'LeicaTrailer'); 5878 $newPos -= $makerOffset if $makerOffset; 5879 } 5880 $fixup->SetMarkerPointers($outfile, 'PreviewImage', $newPos); 5881 # clean up and write the buffered data 5882 $outfile = $oldOutfile; 5883 undef $oldOutfile; 5884 Write($outfile, $writeBuffer) or $err = 1; 5885 undef $writeBuffer; 5886 # write preview image 5887 if ($$previewInfo{Data} ne 'LOAD_PREVIEW') { 5888 # write any junk that existed before the preview image 5889 Write($outfile, substr($buff,0,$junkLen)) or $err = 1 if $junkLen; 5890 # write the saved preview image 5891 Write($outfile, $$previewInfo{Data}) or $err = 1; 5892 delete $$previewInfo{Data}; 5893 # (don't increment CHANGED because we could be rewriting existing preview) 5894 $delPreview = 1; # remove old preview 5895 } 5896 } 5897 # copy over preview image if necessary 5898 unless ($delPreview) { 5899 my $extra; 5900 if ($trailInfo) { 5901 # copy everything up to start of first processed trailer 5902 $extra = $$trailInfo{DataPos} - $endPos; 5903 } else { 5904 # copy everything up to end of file 5905 $raf->Seek(0, 2) or $err = 1; 5906 $extra = $raf->Tell() - $endPos; 5907 } 5908 if ($extra > 0) { 5909 if ($$delGroup{Trailer}) { 5910 $verbose and print $out " Deleting unknown trailer ($extra bytes)\n"; 5911 ++$$self{CHANGED}; 5912 } else { 5913 # copy over unknown trailer 5914 $verbose and print $out " Preserving unknown trailer ($extra bytes)\n"; 5915 $raf->Seek($endPos, 0) or $err = 1; 5916 CopyBlock($raf, $outfile, $extra) or $err = 1; 5917 } 5918 } 5919 } 5920 # write trailer if necessary 5921 if ($trailInfo) { 5922 $self->WriteTrailerBuffer($trailInfo, $outfile) or $err = 1; 5923 undef $trailInfo; 5924 } 5925 last; # all done parsing file 5926 5927 } elsif ($marker==0xd9 and $isEXV) { 5928 # write EXV EOI (any trailer will be lost) 5929 Write($outfile, "\xff\xd9") or $err = 1; 5930 $rtnVal = 1; 5931 last; 5932 5933 } elsif ($marker==0x00 or $marker==0x01 or ($marker>=0xd0 and $marker<=0xd7)) { 5934 $verbose and $marker and print $out "JPEG $markerName:\n"; 5935 # handle stand-alone markers 0x00, 0x01 and 0xd0-0xd7 (NULL, TEM, RST0-RST7) 5936 Write($outfile, $hdr) or $err = 1; 5937 next; 5938 } 5939 # 5940 # NOTE: A 'next' statement after this point will cause $$segDataPt 5941 # not to be written if there is an output file, so in this case 5942 # the $$self{CHANGED} flags must be updated 5943 # 5944 my $segDataPt = \$segData; 5945 $length = length($segData); 5946 if ($verbose) { 5947 print $out "JPEG $markerName ($length bytes):\n"; 5948 if ($verbose > 2 and $markerName =~ /^APP/) { 5949 HexDump($segDataPt, undef, %dumpParms); 5950 } 5951 } 5952 # group delete of APP segments 5953 if ($$delGroup{$dirName}) { 5954 $verbose and print $out " Deleting $dirName segment\n"; 5955 $self->Warn('ICC_Profile deleted. Image colors may be affected') if $dirName eq 'ICC_Profile'; 5956 ++$$self{CHANGED}; 5957 next Marker; 5958 } 5959 my ($segType, $del); 5960 # rewrite this segment only if we are changing a tag which is contained in its 5961 # directory (or deleting '*', in which case we need to identify the segment type) 5962 while (exists $$editDirs{$markerName} or $$delGroup{'*'}) { 5963 if ($marker == 0xe0) { # APP0 (JFIF, CIFF) 5964 if ($$segDataPt =~ /^JFIF\0/) { 5965 $segType = 'JFIF'; 5966 $$delGroup{JFIF} and $del = 1, last; 5967 last unless $$editDirs{JFIF}; 5968 SetByteOrder('MM'); 5969 my $tagTablePtr = GetTagTable('Image::ExifTool::JFIF::Main'); 5970 my %dirInfo = ( 5971 DataPt => $segDataPt, 5972 DataPos => $segPos, 5973 DataLen => $length, 5974 DirStart => 5, # directory starts after identifier 5975 DirLen => $length-5, 5976 Parent => $markerName, 5977 ); 5978 my $newData = $self->WriteDirectory(\%dirInfo, $tagTablePtr); 5979 if (defined $newData and length $newData) { 5980 $$segDataPt = "JFIF\0" . $newData; 5981 } 5982 } elsif ($$segDataPt =~ /^JFXX\0\x10/) { 5983 $segType = 'JFXX'; 5984 $$delGroup{JFIF} and $del = 1; 5985 } elsif ($$segDataPt =~ /^(II|MM).{4}HEAPJPGM/s) { 5986 $segType = 'CIFF'; 5987 $$delGroup{CIFF} and $del = 1, last; 5988 last unless $$editDirs{CIFF}; 5989 my $newData = ''; 5990 my %dirInfo = ( 5991 RAF => new File::RandomAccess($segDataPt), 5992 OutFile => \$newData, 5993 ); 5994 require Image::ExifTool::CanonRaw; 5995 if (Image::ExifTool::CanonRaw::WriteCRW($self, \%dirInfo) > 0) { 5996 if (length $newData) { 5997 $$segDataPt = $newData; 5998 } else { 5999 undef $segDataPt; 6000 $del = 1; # delete this segment 6001 } 6002 } 6003 } 6004 } elsif ($marker == 0xe1) { # APP1 (EXIF, XMP) 6005 # check for EXIF data 6006 if ($$segDataPt =~ /^(.{0,4})$exifAPP1hdr/is) { 6007 my $hdrLen = length $exifAPP1hdr; 6008 if (length $1) { 6009 $hdrLen += length $1; 6010 $self->Error('Unknown garbage at start of EXIF segment',1); 6011 } elsif ($$segDataPt !~ /^Exif\0/) { 6012 $self->Error('Incorrect EXIF segment identifier',1); 6013 } 6014 $segType = 'EXIF'; 6015 last unless $$editDirs{IFD0}; 6016 # add this data to the combined data if it exists 6017 if (defined $combinedSegData) { 6018 $combinedSegData .= substr($$segDataPt,$hdrLen); 6019 $segDataPt = \$combinedSegData; 6020 $segPos = $firstSegPos; 6021 $length = length $combinedSegData; # update length 6022 } 6023 # peek ahead to see if the next segment is extended EXIF 6024 if ($dirOrder[0] eq 'ExtendedEXIF') { 6025 # initialize combined data if necessary 6026 unless (defined $combinedSegData) { 6027 $combinedSegData = $$segDataPt; 6028 $firstSegPos = $segPos; 6029 $self->Warn('File contains multi-segment EXIF',1); 6030 } 6031 next Marker; # get the next segment to combine 6032 } 6033 $doneDir{IFD0} and $self->Warn('Multiple APP1 EXIF records'); 6034 $doneDir{IFD0} = 1; 6035 # check del groups now so we can change byte order in one step 6036 if ($$delGroup{IFD0} or $$delGroup{EXIF}) { 6037 delete $doneDir{IFD0}; # delete so we will create a new one 6038 $del = 1; 6039 last; 6040 } 6041 # rewrite EXIF as if this were a TIFF file in memory 6042 my %dirInfo = ( 6043 DataPt => $segDataPt, 6044 DataPos => -$hdrLen, # (remember: relative to Base!) 6045 DirStart => $hdrLen, 6046 Base => $segPos + $hdrLen, 6047 Parent => $markerName, 6048 DirName => 'IFD0', 6049 ); 6050 # write new EXIF data to memory 6051 my $tagTablePtr = GetTagTable('Image::ExifTool::Exif::Main'); 6052 my $buff = $self->WriteDirectory(\%dirInfo, $tagTablePtr, \&WriteTIFF); 6053 if (defined $buff) { 6054 undef $$segDataPt; # free the old buffer 6055 $segDataPt = \$buff; 6056 } else { 6057 last Marker unless $self->Options('IgnoreMinorErrors'); 6058 } 6059 # delete segment if IFD contains no entries 6060 length $$segDataPt or $del = 1, last; 6061 if (length($$segDataPt) + length($exifAPP1hdr) > $maxSegmentLen) { 6062 if ($self->Options('NoMultiExif')) { 6063 $self->Error('EXIF is too large for JPEG segment'); 6064 } else { 6065 $self->Warn('Writing multi-segment EXIF',1); 6066 } 6067 } 6068 # switch to buffered output if required 6069 if (($$self{PREVIEW_INFO} or $$self{LeicaTrailer}) and not $oldOutfile) { 6070 $writeBuffer = ''; 6071 $oldOutfile = $outfile; 6072 $outfile = \$writeBuffer; 6073 # must account for segment, EXIF and TIFF headers 6074 $$self{PREVIEW_INFO}{Fixup}{Start} += 18 if $$self{PREVIEW_INFO}; 6075 $$self{LeicaTrailer}{Fixup}{Start} += 18 if $$self{LeicaTrailer}; 6076 } 6077 # write as multi-segment 6078 my $n = WriteMultiSegment($outfile, $marker, $exifAPP1hdr, $segDataPt, 'EXIF'); 6079 if (not $n) { 6080 $err = 1; 6081 } elsif ($n > 1 and $oldOutfile) { 6082 # (punt on this because updating the pointers would be a real pain) 6083 $self->Error("Can't write multi-segment EXIF with external pointers"); 6084 } 6085 undef $combinedSegData; 6086 undef $$segDataPt; 6087 next Marker; 6088 # check for XMP data 6089 } elsif ($$segDataPt =~ /^($xmpAPP1hdr|$xmpExtAPP1hdr)/) { 6090 $segType = 'XMP'; 6091 $$delGroup{XMP} and $del = 1, last; 6092 $doneDir{XMP} = ($doneDir{XMP} || 0) + 1; 6093 last unless $$editDirs{XMP}; 6094 if ($doneDir{XMP} + $dirCount{XMP} > 1) { 6095 # must assemble all XMP segments before writing 6096 my ($guid, $extXMP); 6097 if ($$segDataPt =~ /^$xmpExtAPP1hdr/) { 6098 # save extended XMP data 6099 if (length $$segDataPt < 75) { 6100 $extendedXMP{Error} = 'Truncated data'; 6101 } else { 6102 my ($size, $off) = unpack('x67N2', $$segDataPt); 6103 $guid = substr($$segDataPt, 35, 32); 6104 if ($guid =~ /[^A-Za-z0-9]/) { # (technically, should be uppercase) 6105 $extendedXMP{Error} = 'Invalid GUID'; 6106 } else { 6107 # remember extended data for each GUID 6108 $extXMP = $extendedXMP{$guid}; 6109 if ($extXMP) { 6110 $size == $$extXMP{Size} or $extendedXMP{Error} = 'Inconsistent size'; 6111 } else { 6112 $extXMP = $extendedXMP{$guid} = { }; 6113 } 6114 $$extXMP{Size} = $size; 6115 $$extXMP{$off} = substr($$segDataPt, 75); 6116 } 6117 } 6118 } else { 6119 # save all main XMP segments (should normally be only one) 6120 $extendedXMP{Main} = [] unless $extendedXMP{Main}; 6121 push @{$extendedXMP{Main}}, substr($$segDataPt, length $xmpAPP1hdr); 6122 } 6123 # continue processing only if we have read all the segments 6124 next Marker if $dirCount{XMP}; 6125 # reconstruct an XMP super-segment 6126 $$segDataPt = $xmpAPP1hdr; 6127 my $goodGuid = ''; 6128 foreach (@{$extendedXMP{Main}}) { 6129 # get the HasExtendedXMP GUID if it exists 6130 if (/:HasExtendedXMP\s*(=\s*['"]|>)(\w{32})/) { 6131 # warn of subsequent XMP blocks specifying a different 6132 # HasExtendedXMP (have never seen this) 6133 if ($goodGuid and $goodGuid ne $2) { 6134 $self->WarnOnce('Multiple XMP segments specifying different extended XMP GUID'); 6135 } 6136 $goodGuid = $2; # GUID for the standard extended XMP 6137 } 6138 $$segDataPt .= $_; 6139 } 6140 # GUID of the extended XMP that we want to read 6141 my $readGuid = $$self{OPTIONS}{ExtendedXMP} || 0; 6142 $readGuid = $goodGuid if $readGuid eq '1'; 6143 foreach $guid (sort keys %extendedXMP) { 6144 next unless length $guid == 32; # ignore other (internal) keys 6145 if ($guid ne $readGuid and $readGuid ne '2') { 6146 my $non = $guid eq $goodGuid ? '' : 'non-'; 6147 $self->Warn("Ignored ${non}standard extended XMP (GUID $guid)"); 6148 next; 6149 } 6150 if ($guid ne $goodGuid) { 6151 $self->Warn("Reading non-standard extended XMP (GUID $guid)"); 6152 } 6153 $extXMP = $extendedXMP{$guid}; 6154 next unless ref $extXMP eq 'HASH'; # (just to be safe) 6155 my $size = $$extXMP{Size}; 6156 my (@offsets, $off); 6157 for ($off=0; $off<$size; ) { 6158 last unless defined $$extXMP{$off}; 6159 push @offsets, $off; 6160 $off += length $$extXMP{$off}; 6161 } 6162 if ($off == $size) { 6163 # add all XMP to super-segment 6164 $$segDataPt .= $$extXMP{$_} foreach @offsets; 6165 } else { 6166 $self->Error("Incomplete extended XMP (GUID $guid)", 1); 6167 } 6168 } 6169 $self->Error("$extendedXMP{Error} in extended XMP", 1) if $extendedXMP{Error}; 6170 } 6171 my $start = length $xmpAPP1hdr; 6172 my $tagTablePtr = GetTagTable('Image::ExifTool::XMP::Main'); 6173 my %dirInfo = ( 6174 DataPt => $segDataPt, 6175 DirStart => $start, 6176 Parent => $markerName, 6177 # limit XMP size and create extended XMP if necessary 6178 MaxDataLen => $maxXMPLen - length($xmpAPP1hdr), 6179 ); 6180 my $newData = $self->WriteDirectory(\%dirInfo, $tagTablePtr); 6181 if (defined $newData) { 6182 undef %extendedXMP; 6183 if (length $newData) { 6184 # write multi-segment XMP (XMP plus extended XMP if necessary) 6185 WriteMultiXMP($self, $outfile, \$newData, $dirInfo{ExtendedXMP}, 6186 $dirInfo{ExtendedGUID}) or $err = 1; 6187 undef $$segDataPt; # free the old buffer 6188 next Marker; 6189 } else { 6190 $$segDataPt = ''; # delete the XMP 6191 } 6192 } else { 6193 $verbose and print $out " [XMP rewritten with no changes]\n"; 6194 if ($doneDir{XMP} > 1) { 6195 # re-write original multi-segment XMP 6196 my ($dat, $guid, $extXMP, $off); 6197 foreach $dat (@{$extendedXMP{Main}}) { # main XMP 6198 next unless length $dat; 6199 $s = pack('n', length($xmpAPP1hdr) + length($dat) + 2); 6200 Write($outfile, $hdr, $s, $xmpAPP1hdr, $dat) or $err = 1; 6201 } 6202 foreach $guid (sort keys %extendedXMP) { # extended XMP 6203 next unless length $guid == 32; 6204 $extXMP = $extendedXMP{$guid}; 6205 next unless ref $extXMP eq 'HASH'; 6206 my $size = $$extXMP{Size} or next; 6207 for ($off=0; defined $$extXMP{$off}; $off += length $$extXMP{$off}) { 6208 $s = pack('n', length($xmpExtAPP1hdr) + length($$extXMP{$off}) + 42); 6209 Write($outfile, $hdr, $s, $xmpExtAPP1hdr, $guid, 6210 pack('N2', $size, $off), $$extXMP{$off}) or $err = 1; 6211 } 6212 } 6213 undef $$segDataPt; # free the old buffer 6214 undef %extendedXMP; 6215 next Marker; 6216 } 6217 # continue on to re-write original single-segment XMP 6218 } 6219 $del = 1 unless length $$segDataPt; 6220 } elsif ($$segDataPt =~ /^http/ or $$segDataPt =~ /<exif:/) { 6221 $self->Warn('Ignored APP1 XMP segment with non-standard header', 1); 6222 } 6223 } elsif ($marker == 0xe2) { # APP2 (ICC Profile, FPXR, MPF) 6224 if ($$segDataPt =~ /^ICC_PROFILE\0/ and $length >= 14) { 6225 $segType = 'ICC_Profile'; 6226 $$delGroup{ICC_Profile} and $del = 1, last; 6227 # must concatenate blocks of profile 6228 my $chunkNum = Get8u($segDataPt, 12); 6229 my $chunksTot = Get8u($segDataPt, 13); 6230 if (defined $iccChunksTotal) { 6231 # abort parsing ICC_Profile if the total chunk count is inconsistent 6232 if ($chunksTot != $iccChunksTotal and defined $iccChunkCount) { 6233 # an error because the accumulated profile data will be lost 6234 $self->Error('Inconsistent ICC_Profile chunk count', 1); 6235 undef $iccChunkCount; # abort ICC_Profile parsing 6236 undef $chunkNum; # avoid 2nd warning below 6237 ++$$self{CHANGED}; # we are deleting the bad chunks before this one 6238 } 6239 } else { 6240 $iccChunkCount = 0; 6241 $iccChunksTotal = $chunksTot; 6242 $self->Warn('ICC_Profile chunk count is zero') if !$chunksTot; 6243 } 6244 if (defined $iccChunkCount) { 6245 # save this chunk 6246 if (defined $iccChunk[$chunkNum]) { 6247 $self->Warn("Duplicate ICC_Profile chunk number $chunkNum"); 6248 $iccChunk[$chunkNum] .= substr($$segDataPt, 14); 6249 } else { 6250 $iccChunk[$chunkNum] = substr($$segDataPt, 14); 6251 } 6252 # continue accumulating chunks unless we have all of them 6253 next Marker unless ++$iccChunkCount >= $iccChunksTotal; 6254 undef $iccChunkCount; # prevent reprocessing 6255 $doneDir{ICC_Profile} = 1; 6256 # combine the ICC_Profile chunks 6257 my $icc_profile = ''; 6258 defined $_ and $icc_profile .= $_ foreach @iccChunk; 6259 undef @iccChunk; # free memory 6260 $segDataPt = \$icc_profile; 6261 $length = length $icc_profile; 6262 my $tagTablePtr = GetTagTable('Image::ExifTool::ICC_Profile::Main'); 6263 my %dirInfo = ( 6264 DataPt => $segDataPt, 6265 DataPos => $segPos + 14, 6266 DataLen => $length, 6267 DirStart => 0, 6268 DirLen => $length, 6269 Parent => $markerName, 6270 ); 6271 my $newData = $self->WriteDirectory(\%dirInfo, $tagTablePtr); 6272 if (defined $newData) { 6273 undef $$segDataPt; # free the old buffer 6274 $segDataPt = \$newData; 6275 } 6276 length $$segDataPt or $del = 1, last; 6277 # write as ICC multi-segment 6278 WriteMultiSegment($outfile, $marker, "ICC_PROFILE\0", $segDataPt, 'ICC') or $err = 1; 6279 undef $$segDataPt; 6280 next Marker; 6281 } elsif (defined $chunkNum) { 6282 $self->WarnOnce('Invalid or extraneous ICC_Profile chunk(s)'); 6283 # fall through to preserve this extra profile... 6284 } 6285 } elsif ($$segDataPt =~ /^FPXR\0/) { 6286 $segType = 'FPXR'; 6287 $$delGroup{FlashPix} and $del = 1; 6288 } elsif ($$segDataPt =~ /^MPF\0/) { 6289 $segType = 'MPF'; 6290 $$delGroup{MPF} and $del = 1; 6291 } 6292 } elsif ($marker == 0xe3) { # APP3 (Kodak Meta) 6293 if ($$segDataPt =~ /^(Meta|META|Exif)\0\0/) { 6294 $segType = 'Kodak Meta'; 6295 $$delGroup{Meta} and $del = 1, last; 6296 $doneDir{Meta} and $self->Warn('Multiple APP3 Meta segments'); 6297 $doneDir{Meta} = 1; 6298 last unless $$editDirs{Meta}; 6299 # rewrite Meta IFD as if this were a TIFF file in memory 6300 my %dirInfo = ( 6301 DataPt => $segDataPt, 6302 DataPos => -6, # (remember: relative to Base!) 6303 DirStart => 6, 6304 Base => $segPos + 6, 6305 Parent => $markerName, 6306 DirName => 'Meta', 6307 ); 6308 # write new data to memory 6309 my $tagTablePtr = GetTagTable('Image::ExifTool::Kodak::Meta'); 6310 my $buff = $self->WriteDirectory(\%dirInfo, $tagTablePtr, \&WriteTIFF); 6311 if (defined $buff) { 6312 # update segment with new data 6313 $$segDataPt = substr($$segDataPt,0,6) . $buff; 6314 } else { 6315 last Marker unless $self->Options('IgnoreMinorErrors'); 6316 } 6317 # delete segment if IFD contains no entries 6318 $del = 1 unless length($$segDataPt) > 6; 6319 } 6320 } elsif ($marker == 0xe5) { # APP5 (Ricoh RMETA) 6321 if ($$segDataPt =~ /^RMETA\0/) { 6322 $segType = 'Ricoh RMETA'; 6323 $$delGroup{RMETA} and $del = 1; 6324 } 6325 } elsif ($marker == 0xec) { # APP12 (Ducky) 6326 if ($$segDataPt =~ /^Ducky/) { 6327 $segType = 'Ducky'; 6328 $$delGroup{Ducky} and $del = 1, last; 6329 $doneDir{Ducky} and $self->Warn('Multiple APP12 Ducky segments'); 6330 $doneDir{Ducky} = 1; 6331 last unless $$editDirs{Ducky}; 6332 my $tagTablePtr = GetTagTable('Image::ExifTool::APP12::Ducky'); 6333 my %dirInfo = ( 6334 DataPt => $segDataPt, 6335 DataPos => $segPos, 6336 DataLen => $length, 6337 DirStart => 5, # directory starts after identifier 6338 DirLen => $length-5, 6339 Parent => $markerName, 6340 ); 6341 my $newData = $self->WriteDirectory(\%dirInfo, $tagTablePtr); 6342 if (defined $newData) { 6343 undef $$segDataPt; # free the old buffer 6344 # add header to new segment unless empty 6345 $newData = 'Ducky' . $newData if length $newData; 6346 $segDataPt = \$newData; 6347 } 6348 $del = 1 unless length $$segDataPt; 6349 } 6350 } elsif ($marker == 0xed) { # APP13 (Photoshop) 6351 if ($$segDataPt =~ /^$psAPP13hdr/) { 6352 $segType = 'Photoshop'; 6353 # add this data to the combined data if it exists 6354 if (defined $combinedSegData) { 6355 $combinedSegData .= substr($$segDataPt,length($psAPP13hdr)); 6356 $segDataPt = \$combinedSegData; 6357 $length = length $combinedSegData; # update length 6358 } 6359 # peek ahead to see if the next segment is photoshop data too 6360 if ($dirOrder[0] eq 'Photoshop') { 6361 # initialize combined data if necessary 6362 $combinedSegData = $$segDataPt unless defined $combinedSegData; 6363 next Marker; # get the next segment to combine 6364 } 6365 if ($doneDir{Photoshop}) { 6366 $self->Warn('Multiple Photoshop records'); 6367 # only rewrite the first Photoshop segment when deleting this group 6368 # (to remove multiples when deleting and adding back in one step) 6369 $$delGroup{Photoshop} and $del = 1, last; 6370 } 6371 $doneDir{Photoshop} = 1; 6372 # process APP13 Photoshop record 6373 my $tagTablePtr = GetTagTable('Image::ExifTool::Photoshop::Main'); 6374 my %dirInfo = ( 6375 DataPt => $segDataPt, 6376 DataPos => $segPos, 6377 DataLen => $length, 6378 DirStart => 14, # directory starts after identifier 6379 DirLen => $length-14, 6380 Parent => $markerName, 6381 ); 6382 my $newData = $self->WriteDirectory(\%dirInfo, $tagTablePtr); 6383 if (defined $newData) { 6384 undef $$segDataPt; # free the old buffer 6385 $segDataPt = \$newData; 6386 } 6387 length $$segDataPt or $del = 1, last; 6388 # write as multi-segment 6389 WriteMultiSegment($outfile, $marker, $psAPP13hdr, $segDataPt) or $err = 1; 6390 undef $combinedSegData; 6391 undef $$segDataPt; 6392 next Marker; 6393 } 6394 } elsif ($marker == 0xee) { # APP14 (Adobe) 6395 if ($$segDataPt =~ /^Adobe/) { 6396 $segType = 'Adobe'; 6397 # delete it and replace it later if editing 6398 if ($$delGroup{Adobe} or $$editDirs{Adobe}) { 6399 $del = 1; 6400 undef $doneDir{Adobe}; # so we can add it back again above 6401 } 6402 } 6403 } elsif ($marker == 0xfe) { # COM (JPEG comment) 6404 my $newComment; 6405 unless ($doneDir{COM}) { 6406 $doneDir{COM} = 1; 6407 unless ($$delGroup{File} and $$delGroup{File} != 2) { 6408 my $tagInfo = $Image::ExifTool::Extra{Comment}; 6409 my $nvHash = $self->GetNewValueHash($tagInfo); 6410 my $val = $segData; 6411 $val =~ s/\0+$//; # allow for stupid software that adds NULL terminator 6412 if ($self->IsOverwriting($nvHash, $val) or $$delGroup{File}) { 6413 $newComment = $self->GetNewValue($nvHash); 6414 } else { 6415 delete $$editDirs{COM}; # we aren't editing COM after all 6416 last; 6417 } 6418 } 6419 } 6420 $self->VerboseValue('- Comment', $$segDataPt); 6421 if (defined $newComment) { 6422 # write out the comments 6423 $self->VerboseValue('+ Comment', $newComment); 6424 WriteMultiSegment($outfile, 0xfe, '', \$newComment) or $err = 1; 6425 } else { 6426 $verbose and print $out " Deleting COM segment\n"; 6427 } 6428 ++$$self{CHANGED}; # increment the changed flag 6429 undef $segDataPt; # don't write existing comment 6430 } 6431 last; # didn't want to loop anyway 6432 } 6433 6434 # delete necessary segments (including unknown segments if deleting all) 6435 if ($del or ($$delGroup{'*'} and not $segType and $marker>=0xe0 and $marker<=0xef)) { 6436 $segType = 'unknown' unless $segType; 6437 $verbose and print $out " Deleting $markerName $segType segment\n"; 6438 ++$$self{CHANGED}; 6439 next Marker; 6440 } 6441 # write out this segment if $segDataPt is still defined 6442 if (defined $segDataPt and defined $$segDataPt) { 6443 # write the data for this record (the data could have been 6444 # modified, so recalculate the length word) 6445 my $size = length($$segDataPt); 6446 if ($size > $maxSegmentLen) { 6447 $segType or $segType = 'Unknown'; 6448 $self->Error("$segType $markerName segment too large! ($size bytes)"); 6449 $err = 1; 6450 } else { 6451 $s = pack('n', length($$segDataPt) + 2); 6452 Write($outfile, $hdr, $s, $$segDataPt) or $err = 1; 6453 } 6454 undef $$segDataPt; # free the buffer 6455 undef $segDataPt; 6456 } 6457 } 6458 # make sure the ICC_Profile was complete 6459 $self->Error('Incomplete ICC_Profile record', 1) if defined $iccChunkCount; 6460 pop @$path if @$path > $pn; 6461 # if oldOutfile is still set, there was an error copying the JPEG 6462 $oldOutfile and return 0; 6463 if ($rtnVal) { 6464 # add any new trailers we are creating 6465 my $trailPt = $self->AddNewTrailers(); 6466 Write($outfile, $$trailPt) or $err = 1 if $trailPt; 6467 } 6468 # set return value to -1 if we only had a write error 6469 $rtnVal = -1 if $rtnVal and $err; 6470 if ($creatingEXV and $rtnVal > 0 and not $$self{CHANGED}) { 6471 $self->Error('Nothing written'); 6472 $rtnVal = -1; 6473 } 6474 return $rtnVal; 6475} 6476 6477#------------------------------------------------------------------------------ 6478# Validate an image for writing 6479# Inputs: 0) ExifTool object reference, 1) raw value reference 6480# Returns: error string or undef on success 6481sub CheckImage($$) 6482{ 6483 my ($self, $valPtr) = @_; 6484 if (length($$valPtr) and $$valPtr!~/^\xff\xd8/ and not 6485 $self->Options('IgnoreMinorErrors')) 6486 { 6487 return '[Minor] Not a valid image'; 6488 } 6489 return undef; 6490} 6491 6492#------------------------------------------------------------------------------ 6493# check a value for validity 6494# Inputs: 0) value reference, 1) format string, 2) optional count 6495# Returns: error string, or undef on success 6496# Notes: May modify value (if a count is specified for a string, it is null-padded 6497# to the specified length, and floating point values are rounded to integer if required) 6498sub CheckValue($$;$) 6499{ 6500 my ($valPtr, $format, $count) = @_; 6501 my (@vals, $val, $n); 6502 6503 if ($format eq 'string' or $format eq 'undef') { 6504 return undef unless $count and $count > 0; 6505 my $len = length($$valPtr); 6506 if ($format eq 'string') { 6507 $len >= $count and return 'String too long'; 6508 } else { 6509 $len > $count and return 'Data too long'; 6510 } 6511 if ($len < $count) { 6512 $$valPtr .= "\0" x ($count - $len); 6513 } 6514 return undef; 6515 } 6516 if ($count and $count != 1) { 6517 @vals = split(' ',$$valPtr); 6518 $count < 0 and ($count = @vals or return undef); 6519 } else { 6520 $count = 1; 6521 @vals = ( $$valPtr ); 6522 } 6523 if (@vals != $count) { 6524 my $str = @vals > $count ? 'Too many' : 'Not enough'; 6525 return "$str values specified ($count required)"; 6526 } 6527 for ($n=0; $n<$count; ++$n) { 6528 $val = shift @vals; 6529 if ($format =~ /^int/) { 6530 # make sure the value is integer 6531 unless (IsInt($val)) { 6532 if (IsHex($val)) { 6533 $val = $$valPtr = hex($val); 6534 } else { 6535 # round single floating point values to the nearest integer 6536 return 'Not an integer' unless IsFloat($val) and $count == 1; 6537 $val = $$valPtr = int($val + ($val < 0 ? -0.5 : 0.5)); 6538 } 6539 } 6540 my $rng = $intRange{$format} or return "Bad int format: $format"; 6541 return "Value below $format minimum" if $val < $$rng[0]; 6542 # (allow 0xfeedfeed code as value for 16-bit pointers) 6543 return "Value above $format maximum" if $val > $$rng[1] and $val != 0xfeedfeed; 6544 } elsif ($format =~ /^rational/ or $format eq 'float' or $format eq 'double') { 6545 # make sure the value is a valid floating point number 6546 unless (IsFloat($val)) { 6547 # allow 'inf', 'undef' and fractional rational values 6548 if ($format =~ /^rational/) { 6549 next if $val eq 'inf' or $val eq 'undef'; 6550 if ($val =~ m{^([-+]?\d+)/(\d+)$}) { 6551 next unless $1 < 0 and $format =~ /u$/; 6552 return 'Must be an unsigned rational'; 6553 } 6554 } 6555 return 'Not a floating point number'; 6556 } 6557 if ($format =~ /^rational\d+u$/ and $val < 0) { 6558 return 'Must be a positive number'; 6559 } 6560 } 6561 } 6562 return undef; # success! 6563} 6564 6565#------------------------------------------------------------------------------ 6566# check new value for binary data block 6567# Inputs: 0) ExifTool object ref, 1) tagInfo hash ref, 2) raw value ref 6568# Returns: error string or undef (and may modify value) on success 6569sub CheckBinaryData($$$) 6570{ 6571 my ($self, $tagInfo, $valPtr) = @_; 6572 my $format = $$tagInfo{Format}; 6573 unless ($format) { 6574 my $table = $$tagInfo{Table}; 6575 if ($table and $$table{FORMAT}) { 6576 $format = $$table{FORMAT}; 6577 } else { 6578 # use default 'int8u' unless specified 6579 $format = 'int8u'; 6580 } 6581 } 6582 my $count; 6583 if ($format =~ /(.*)\[(.*)\]/) { 6584 $format = $1; 6585 $count = $2; 6586 # can't evaluate $count now because we don't know $size yet 6587 undef $count if $count =~ /\$size/; 6588 } 6589 return CheckValue($valPtr, $format, $count); 6590} 6591 6592#------------------------------------------------------------------------------ 6593# Rename a file (with patch for Windows Unicode file names, and other problem) 6594# Inputs: 0) ExifTool ref, 1) old name, 2) new name 6595# Returns: true on success 6596sub Rename($$$) 6597{ 6598 my ($self, $old, $new) = @_; 6599 my ($result, $try, $winUni); 6600 6601 if ($self->EncodeFileName($old)) { 6602 $self->EncodeFileName($new, 1); 6603 $winUni = 1; 6604 } elsif ($self->EncodeFileName($new)) { 6605 $old = $_[1]; 6606 $self->EncodeFileName($old, 1); 6607 $winUni = 1; 6608 } 6609 for (;;) { 6610 if ($winUni) { 6611 $result = eval { Win32API::File::MoveFileExW($old, $new, 6612 Win32API::File::MOVEFILE_REPLACE_EXISTING() | 6613 Win32API::File::MOVEFILE_COPY_ALLOWED()) }; 6614 } else { 6615 $result = rename($old, $new); 6616 } 6617 last if $result or $^O ne 'MSWin32'; 6618 # keep trying for up to 0.5 seconds 6619 # (patch for Windows denial-of-service susceptibility) 6620 $try = ($try || 1) + 1; 6621 last if $try > 50; 6622 select(undef,undef,undef,0.01); # sleep for 0.01 sec 6623 } 6624 return $result; 6625} 6626 6627#------------------------------------------------------------------------------ 6628# Delete a file (with patch for Windows Unicode file names) 6629# Inputs: 0) ExifTool ref, 1-N) names of files to delete 6630# Returns: number of files deleted 6631sub Unlink($@) 6632{ 6633 my $self = shift; 6634 my $result = 0; 6635 while (@_) { 6636 my $file = shift; 6637 if ($self->EncodeFileName($file)) { 6638 ++$result if eval { Win32API::File::DeleteFileW($file) }; 6639 } else { 6640 ++$result if unlink $file; 6641 } 6642 } 6643 return $result; 6644} 6645 6646#------------------------------------------------------------------------------ 6647# Set file times (Unix seconds since the epoch) 6648# Inputs: 0) ExifTool ref, 1) file name or ref, 2) access time, 3) modification time, 6649# 4) inode change or creation time (or undef for any time to avoid setting) 6650# 5) flag to suppress warning 6651# Returns: 1 on success, 0 on error 6652my $k32SetFileTime; 6653sub SetFileTime($$;$$$$) 6654{ 6655 my ($self, $file, $atime, $mtime, $ctime, $noWarn) = @_; 6656 my $saveFile; 6657 local *FH; 6658 6659 # open file by name if necessary 6660 unless (ref $file) { 6661 # (file will be automatically closed when *FH goes out of scope) 6662 unless ($self->Open(\*FH, $file, '+<')) { 6663 my $success; 6664 if (defined $atime or defined $mtime) { 6665 my ($a, $m, $c) = $self->GetFileTime($file); 6666 $atime = $a unless defined $atime; 6667 $mtime = $m unless defined $mtime; 6668 $success = eval { utime($atime, $mtime, $file) } if defined $atime and defined $mtime; 6669 } 6670 $self->Warn('Error opening file for update') unless $success; 6671 return $success; 6672 } 6673 $saveFile = $file; 6674 $file = \*FH; 6675 } 6676 # on Windows, try to work around incorrect file times when daylight saving time is in effect 6677 if ($^O eq 'MSWin32') { 6678 if (not eval { require Win32::API }) { 6679 $self->WarnOnce('Install Win32::API for proper handling of Windows file times'); 6680 } elsif (not eval { require Win32API::File }) { 6681 $self->WarnOnce('Install Win32API::File for proper handling of Windows file times'); 6682 } else { 6683 # get Win32 handle, needed for SetFileTime 6684 my $win32Handle = eval { Win32API::File::GetOsFHandle($file) }; 6685 unless ($win32Handle) { 6686 $self->Warn('Win32API::File::GetOsFHandle returned invalid handle'); 6687 return 0; 6688 } 6689 # convert Unix seconds to FILETIME structs 6690 my $time; 6691 foreach $time ($atime, $mtime, $ctime) { 6692 # set to NULL if not defined (i.e. do not change) 6693 defined $time or $time = 0, next; 6694 # convert to 100 ns intervals since 0:00 UTC Jan 1, 1601 6695 # (89 leap years between 1601 and 1970) 6696 my $wt = ($time + (((1970-1601)*365+89)*24*3600)) * 1e7; 6697 my $hi = int($wt / 4294967296); 6698 $time = pack 'LL', int($wt - $hi * 4294967296), $hi; # pack FILETIME struct 6699 } 6700 unless ($k32SetFileTime) { 6701 return 0 if defined $k32SetFileTime; 6702 $k32SetFileTime = new Win32::API('KERNEL32', 'SetFileTime', 'NPPP', 'I'); 6703 unless ($k32SetFileTime) { 6704 $self->Warn('Error calling Win32::API::SetFileTime'); 6705 $k32SetFileTime = 0; 6706 return 0; 6707 } 6708 } 6709 unless ($k32SetFileTime->Call($win32Handle, $ctime, $atime, $mtime)) { 6710 $self->Warn('Win32::API::SetFileTime returned ' . Win32::GetLastError()); 6711 return 0; 6712 } 6713 return 1; 6714 } 6715 } 6716 # other OS (or Windows fallback) 6717 if (defined $atime and defined $mtime) { 6718 my $success; 6719 local $SIG{'__WARN__'} = \&SetWarning; # (this may not be necessary) 6720 for (;;) { 6721 undef $evalWarning; 6722 # (this may fail on the first try if futimes is not implemented) 6723 $success = eval { utime($atime, $mtime, $file) }; 6724 last if $success or not defined $saveFile; 6725 close $file; 6726 $file = $saveFile; 6727 undef $saveFile; 6728 } 6729 unless ($noWarn) { 6730 if ($@ or $evalWarning) { 6731 $self->Warn(CleanWarning($@ || $evalWarning)); 6732 } elsif (not $success) { 6733 $self->Warn('Error setting file time'); 6734 } 6735 } 6736 return $success; 6737 } 6738 return 1; # (nothing to do) 6739} 6740 6741#------------------------------------------------------------------------------ 6742# Copy data block from RAF to output file in max 64kB chunks 6743# Inputs: 0) RAF ref, 1) outfile ref, 2) block size 6744# Returns: 1 on success, 0 on read error, undef on write error 6745sub CopyBlock($$$) 6746{ 6747 my ($raf, $outfile, $size) = @_; 6748 my $buff; 6749 for (;;) { 6750 last unless $size > 0; 6751 my $n = $size > 65536 ? 65536 : $size; 6752 $raf->Read($buff, $n) == $n or return 0; 6753 Write($outfile, $buff) or return undef; 6754 $size -= $n; 6755 } 6756 return 1; 6757} 6758 6759#------------------------------------------------------------------------------ 6760# Copy image data from one file to another 6761# Inputs: 0) ExifTool object reference 6762# 1) reference to list of image data [ position, size, pad bytes ] 6763# 2) output file ref 6764# Returns: true on success 6765sub CopyImageData($$$) 6766{ 6767 my ($self, $imageDataBlocks, $outfile) = @_; 6768 my $raf = $$self{RAF}; 6769 my ($dataBlock, $err); 6770 my $num = @$imageDataBlocks; 6771 $self->VPrint(0, " Copying $num image data blocks\n") if $num; 6772 foreach $dataBlock (@$imageDataBlocks) { 6773 my ($pos, $size, $pad) = @$dataBlock; 6774 $raf->Seek($pos, 0) or $err = 'read', last; 6775 my $result = CopyBlock($raf, $outfile, $size); 6776 $result or $err = defined $result ? 'read' : 'writ'; 6777 # pad if necessary 6778 Write($outfile, "\0" x $pad) or $err = 'writ' if $pad; 6779 last if $err; 6780 } 6781 if ($err) { 6782 $self->Error("Error ${err}ing image data"); 6783 return 0; 6784 } 6785 return 1; 6786} 6787 6788#------------------------------------------------------------------------------ 6789# Write to binary data block 6790# Inputs: 0) ExifTool object ref, 1) source dirInfo ref, 2) tag table ref 6791# Returns: Binary data block or undefined on error 6792sub WriteBinaryData($$$) 6793{ 6794 my ($self, $dirInfo, $tagTablePtr) = @_; 6795 $self or return 1; # allow dummy access to autoload this package 6796 6797 # get default format ('int8u' unless specified) 6798 my $dataPt = $$dirInfo{DataPt} or return undef; 6799 my $defaultFormat = $$tagTablePtr{FORMAT} || 'int8u'; 6800 my $increment = FormatSize($defaultFormat); 6801 unless ($increment) { 6802 warn "Unknown format $defaultFormat\n"; 6803 return undef; 6804 } 6805 # extract data members first if necessary 6806 my @varOffsets; 6807 if ($$tagTablePtr{DATAMEMBER}) { 6808 $$dirInfo{DataMember} = $$tagTablePtr{DATAMEMBER}; 6809 $$dirInfo{VarFormatData} = \@varOffsets; 6810 $self->ProcessBinaryData($dirInfo, $tagTablePtr); 6811 delete $$dirInfo{DataMember}; 6812 delete $$dirInfo{VarFormatData}; 6813 } 6814 my $dirStart = $$dirInfo{DirStart} || 0; 6815 my $dirLen = $$dirInfo{DirLen} || length($$dataPt) - $dirStart; 6816 my $newData = substr($$dataPt, $dirStart, $dirLen) or return undef; 6817 my $dirName = $$dirInfo{DirName}; 6818 my $varSize = 0; 6819 my @varInfo = @varOffsets; 6820 my $tagInfo; 6821 $dataPt = \$newData; 6822 foreach $tagInfo (sort { $$a{TagID} <=> $$b{TagID} } $self->GetNewTagInfoList($tagTablePtr)) { 6823 my $tagID = $$tagInfo{TagID}; 6824 # evaluate conditional tags now if necessary 6825 if (ref $$tagTablePtr{$tagID} eq 'ARRAY' or $$tagInfo{Condition}) { 6826 my $writeInfo = $self->GetTagInfo($tagTablePtr, $tagID); 6827 next unless $writeInfo and $writeInfo eq $tagInfo; 6828 } 6829 # add offsets for variable-sized tags if necessary 6830 while (@varInfo and $varInfo[0][0] < $tagID) { 6831 $varSize = $varInfo[0][1]; # get accumulated variable size 6832 shift @varInfo; 6833 } 6834 my $count = 1; 6835 my $format = $$tagInfo{Format}; 6836 my $entry = int($tagID) * $increment + $varSize; # relative offset of this entry 6837 if ($format) { 6838 if ($format =~ /(.*)\[(.*)\]/) { 6839 $format = $1; 6840 $count = $2; 6841 my $size = $dirLen; # used in eval 6842 # evaluate count to allow count to be based on previous values 6843 #### eval Format size ($size, $self) - NOTE: %val not supported for writing 6844 $count = eval $count; 6845 $@ and warn($@), next; 6846 } elsif ($format eq 'string') { 6847 # string with no specified count runs to end of block 6848 $count = ($dirLen > $entry) ? $dirLen - $entry : 0; 6849 } 6850 } else { 6851 $format = $defaultFormat; 6852 } 6853 # read/write using variable format if changed in Hook 6854 $format = $varInfo[0][2] if @varInfo and $varInfo[0][0] == $tagID; 6855 my $val = ReadValue($dataPt, $entry, $format, $count, $dirLen-$entry); 6856 next unless defined $val; 6857 my $nvHash = $self->GetNewValueHash($tagInfo, $$self{CUR_WRITE_GROUP}); 6858 next unless $self->IsOverwriting($nvHash, $val) > 0; 6859 my $newVal = $self->GetNewValue($nvHash); 6860 next unless defined $newVal; # can't delete from a binary table 6861 # update DataMember with new value if necessary 6862 $$self{$$tagInfo{DataMember}} = $newVal if $$tagInfo{DataMember}; 6863 # only write masked bits if specified 6864 my $mask = $$tagInfo{Mask}; 6865 $newVal = (($newVal << $$tagInfo{BitShift}) & $mask) | ($val & ~$mask) if $mask; 6866 # set the size 6867 if ($$tagInfo{DataTag} and not $$tagInfo{IsOffset}) { 6868 warn 'Internal error' unless $newVal == 0xfeedfeed; 6869 my $data = $self->GetNewValue($$tagInfo{DataTag}); 6870 $newVal = length($data) if defined $data; 6871 my $format = $$tagInfo{Format} || $$tagTablePtr{FORMAT} || 'int32u'; 6872 if ($format =~ /^int16/ and $newVal > 0xffff) { 6873 $self->Error("$$tagInfo{DataTag} is too large (64 kB max. for this file)"); 6874 } 6875 } 6876 my $rtnVal = WriteValue($newVal, $format, $count, $dataPt, $entry); 6877 if (defined $rtnVal) { 6878 $self->VerboseValue("- $dirName:$$tagInfo{Name}", $val); 6879 $self->VerboseValue("+ $dirName:$$tagInfo{Name}", $newVal); 6880 ++$$self{CHANGED}; 6881 } 6882 } 6883 # add necessary fixups for any offsets 6884 if ($$tagTablePtr{IS_OFFSET} and $$dirInfo{Fixup}) { 6885 $varSize = 0; 6886 @varInfo = @varOffsets; 6887 my $fixup = $$dirInfo{Fixup}; 6888 my $tagID; 6889 foreach $tagID (@{$$tagTablePtr{IS_OFFSET}}) { 6890 $tagInfo = $self->GetTagInfo($tagTablePtr, $tagID) or next; 6891 while (@varInfo and $varInfo[0][0] < $tagID) { 6892 $varSize = $varInfo[0][1]; 6893 shift @varInfo; 6894 } 6895 my $entry = $tagID * $increment + $varSize; # (no offset to dirStart for new dir data) 6896 next unless $entry <= $dirLen - 4; 6897 # (Ricoh has 16-bit preview image offsets, so can't just assume int32u) 6898 my $format = $$tagInfo{Format} || $$tagTablePtr{FORMAT} || 'int32u'; 6899 my $offset = ReadValue($dataPt, $entry, $format, 1, $dirLen-$entry); 6900 # ignore if offset is zero (eg. Ricoh DNG uses this to indicate no preview) 6901 next unless $offset; 6902 $fixup->AddFixup($entry, $$tagInfo{DataTag}, $format); 6903 # handle the preview image now if this is a JPEG file 6904 next unless $$self{FILE_TYPE} eq 'JPEG' and $$tagInfo{DataTag} and 6905 $$tagInfo{DataTag} eq 'PreviewImage' and defined $$tagInfo{OffsetPair}; 6906 # NOTE: here we assume there are no var-sized tags between the 6907 # OffsetPair tags. If this ever becomes possible we must recalculate 6908 # $varSize for the OffsetPair tag here! 6909 $entry = $$tagInfo{OffsetPair} * $increment + $varSize; 6910 my $size = ReadValue($dataPt, $entry, $format, 1, $dirLen-$entry); 6911 my $previewInfo = $$self{PREVIEW_INFO}; 6912 $previewInfo or $previewInfo = $$self{PREVIEW_INFO} = { 6913 Fixup => new Image::ExifTool::Fixup, 6914 }; 6915 # set flag indicating we are using short pointers 6916 $$previewInfo{IsShort} = 1 unless $format eq 'int32u'; 6917 $$previewInfo{Absolute} = 1 if $$tagInfo{IsOffset} and $$tagInfo{IsOffset} eq '3'; 6918 # get the value of the Composite::PreviewImage tag 6919 $$previewInfo{Data} = $self->GetNewValue(GetCompositeTagInfo('PreviewImage')); 6920 unless (defined $$previewInfo{Data}) { 6921 if ($offset >= 0 and $offset + $size <= $$dirInfo{DataLen}) { 6922 $$previewInfo{Data} = substr(${$$dirInfo{DataPt}},$offset,$size); 6923 } else { 6924 $$previewInfo{Data} = 'LOAD_PREVIEW'; # flag to load preview later 6925 } 6926 } 6927 } 6928 } 6929 # write any necessary SubDirectories 6930 if ($$tagTablePtr{IS_SUBDIR}) { 6931 $varSize = 0; 6932 @varInfo = @varOffsets; 6933 my $tagID; 6934 foreach $tagID (@{$$tagTablePtr{IS_SUBDIR}}) { 6935 my $tagInfo = $self->GetTagInfo($tagTablePtr, $tagID); 6936 next unless defined $tagInfo; 6937 while (@varInfo and $varInfo[0][0] < $tagID) { 6938 $varSize = $varInfo[0][1]; 6939 shift @varInfo; 6940 } 6941 my $entry = int($tagID) * $increment + $varSize; 6942 last if $entry >= $dirLen; 6943 # get value for Condition if necessary 6944 unless ($tagInfo) { 6945 my $more = $dirLen - $entry; 6946 $more = 128 if $more > 128; 6947 my $v = substr($newData, $entry, $more); 6948 $tagInfo = $self->GetTagInfo($tagTablePtr, $tagID, \$v); 6949 next unless $tagInfo; 6950 } 6951 next unless $$tagInfo{SubDirectory}; # (just to be safe) 6952 my %subdirInfo = ( DataPt => \$newData, DirStart => $entry ); 6953 my $subTablePtr = GetTagTable($$tagInfo{SubDirectory}{TagTable}); 6954 my $dat = $self->WriteDirectory(\%subdirInfo, $subTablePtr); 6955 substr($newData, $entry) = $dat if defined $dat and length $dat; 6956 } 6957 } 6958 return $newData; 6959} 6960 6961#------------------------------------------------------------------------------ 6962# Write TIFF as a directory 6963# Inputs: 0) ExifTool object ref, 1) dirInfo ref, 2) tag table ref 6964# Returns: New directory data or undefined on error 6965sub WriteTIFF($$$) 6966{ 6967 my ($self, $dirInfo, $tagTablePtr) = @_; 6968 $self or return 1; # allow dummy access 6969 my $buff = ''; 6970 $$dirInfo{OutFile} = \$buff; 6971 return $buff if $self->ProcessTIFF($dirInfo, $tagTablePtr) > 0; 6972 return undef; 6973} 6974 69751; # end 6976 6977__END__ 6978 6979=head1 NAME 6980 6981Image::ExifTool::Writer.pl - ExifTool routines for writing meta information 6982 6983=head1 SYNOPSIS 6984 6985These routines are autoloaded by Image::ExifTool when required. 6986 6987=head1 DESCRIPTION 6988 6989This module contains ExifTool write routines and other infrequently 6990used routines. 6991 6992=head1 AUTHOR 6993 6994Copyright 2003-2021, Phil Harvey (philharvey66 at gmail.com) 6995 6996This library is free software; you can redistribute it and/or modify it 6997under the same terms as Perl itself. 6998 6999=head1 SEE ALSO 7000 7001L<Image::ExifTool(3pm)|Image::ExifTool> 7002 7003=cut 7004