| 1 | #------------------------------------------------------------------------------
|
|---|
| 2 | # File: WriteQuickTime.pl
|
|---|
| 3 | #
|
|---|
| 4 | # Description: Write XMP to QuickTime (MOV and MP4) files
|
|---|
| 5 | #
|
|---|
| 6 | # Revisions: 2013-10-29 - P. Harvey Created
|
|---|
| 7 | #------------------------------------------------------------------------------
|
|---|
| 8 | package Image::ExifTool::QuickTime;
|
|---|
| 9 |
|
|---|
| 10 | use strict;
|
|---|
| 11 |
|
|---|
| 12 | # maps for adding metadata to various QuickTime-based file types
|
|---|
| 13 | my %movMap = (
|
|---|
| 14 | # MOV (no 'ftyp', or 'ftyp'='qt ') -> XMP in 'moov'-'udta'-'XMP_'
|
|---|
| 15 | QuickTime => 'ItemList', # (default location for QuickTime tags)
|
|---|
| 16 | ItemList => 'Meta', # MOV-Movie-UserData-Meta-ItemList
|
|---|
| 17 | Keys => 'Movie', # MOV-Movie-Meta-Keys !! (hack due to different Meta location)
|
|---|
| 18 | Meta => 'UserData',
|
|---|
| 19 | XMP => 'UserData', # MOV-Movie-UserData-XMP
|
|---|
| 20 | UserData => 'Movie', # MOV-Movie-UserData
|
|---|
| 21 | Movie => 'MOV',
|
|---|
| 22 | GSpherical => 'SphericalVideoXML', # MOV-Movie-Track-SphericalVideoXML
|
|---|
| 23 | SphericalVideoXML => 'Track', # (video track specifically, don't create if it doesn't exist)
|
|---|
| 24 | Track => 'Movie',
|
|---|
| 25 | );
|
|---|
| 26 | my %mp4Map = (
|
|---|
| 27 | # MP4 ('ftyp' compatible brand 'mp41', 'mp42' or 'f4v ') -> XMP at top level
|
|---|
| 28 | QuickTime => 'ItemList', # (default location for QuickTime tags)
|
|---|
| 29 | ItemList => 'Meta', # MOV-Movie-UserData-Meta-ItemList
|
|---|
| 30 | Keys => 'Movie', # MOV-Movie-Meta-Keys !! (hack due to different Meta location)
|
|---|
| 31 | Meta => 'UserData',
|
|---|
| 32 | UserData => 'Movie', # MOV-Movie-UserData
|
|---|
| 33 | Movie => 'MOV',
|
|---|
| 34 | XMP => 'MOV', # MOV-XMP
|
|---|
| 35 | GSpherical => 'SphericalVideoXML', # MOV-Movie-Track-SphericalVideoXML
|
|---|
| 36 | SphericalVideoXML => 'Track', # (video track specifically, don't create if it doesn't exist)
|
|---|
| 37 | Track => 'Movie',
|
|---|
| 38 | );
|
|---|
| 39 | my %heicMap = (
|
|---|
| 40 | # HEIC/HEIF/AVIF ('ftyp' compatible brand 'heic','mif1','avif') -> XMP/EXIF in top level 'meta'
|
|---|
| 41 | Meta => 'MOV',
|
|---|
| 42 | ItemInformation => 'Meta',
|
|---|
| 43 | ItemPropertyContainer => 'Meta',
|
|---|
| 44 | XMP => 'ItemInformation',
|
|---|
| 45 | EXIF => 'ItemInformation',
|
|---|
| 46 | ICC_Profile => 'ItemPropertyContainer',
|
|---|
| 47 | IFD0 => 'EXIF',
|
|---|
| 48 | IFD1 => 'IFD0',
|
|---|
| 49 | ExifIFD => 'IFD0',
|
|---|
| 50 | GPS => 'IFD0',
|
|---|
| 51 | SubIFD => 'IFD0',
|
|---|
| 52 | GlobParamIFD => 'IFD0',
|
|---|
| 53 | PrintIM => 'IFD0',
|
|---|
| 54 | InteropIFD => 'ExifIFD',
|
|---|
| 55 | MakerNotes => 'ExifIFD',
|
|---|
| 56 | );
|
|---|
| 57 | my %cr3Map = (
|
|---|
| 58 | # CR3 ('ftyp' compatible brand 'crx ') -> XMP at top level
|
|---|
| 59 | Movie => 'MOV',
|
|---|
| 60 | XMP => 'MOV',
|
|---|
| 61 | 'UUID-Canon'=>'Movie',
|
|---|
| 62 | ExifIFD => 'UUID-Canon',
|
|---|
| 63 | IFD0 => 'UUID-Canon',
|
|---|
| 64 | GPS => 'UUID-Canon',
|
|---|
| 65 | #MakerNoteCanon => 'UUID-Canon', # (doesn't yet work -- goes into ExifIFD instead)
|
|---|
| 66 | 'UUID-Canon2' => 'MOV',
|
|---|
| 67 | CanonVRD => 'UUID-Canon2',
|
|---|
| 68 | );
|
|---|
| 69 | my %dirMap = (
|
|---|
| 70 | MOV => \%movMap,
|
|---|
| 71 | MP4 => \%mp4Map,
|
|---|
| 72 | CR3 => \%cr3Map,
|
|---|
| 73 | HEIC => \%heicMap,
|
|---|
| 74 | );
|
|---|
| 75 |
|
|---|
| 76 | # convert ExifTool Format to QuickTime type
|
|---|
| 77 | my %qtFormat = (
|
|---|
| 78 | 'undef' => 0x00, string => 0x01,
|
|---|
| 79 | int8s => 0x15, int16s => 0x15, int32s => 0x15,
|
|---|
| 80 | int8u => 0x16, int16u => 0x16, int32u => 0x16,
|
|---|
| 81 | float => 0x17, double => 0x18,
|
|---|
| 82 | );
|
|---|
| 83 | my $undLang = 0x55c4; # numeric code for default ('und') language
|
|---|
| 84 |
|
|---|
| 85 | my $maxReadLen = 100000000; # maximum size of atom to read into memory (100 MB)
|
|---|
| 86 |
|
|---|
| 87 | # boxes that may exist in an "empty" Meta box:
|
|---|
| 88 | my %emptyMeta = (
|
|---|
| 89 | hdlr => 'Handler', 'keys' => 'Keys', lang => 'Language', ctry => 'Country', free => 'Free',
|
|---|
| 90 | );
|
|---|
| 91 |
|
|---|
| 92 | # lookup for CTBO ID number based on uuid for Canon CR3 files
|
|---|
| 93 | my %ctboID = (
|
|---|
| 94 | "\xbe\x7a\xcf\xcb\x97\xa9\x42\xe8\x9c\x71\x99\x94\x91\xe3\xaf\xac" => 1, # XMP
|
|---|
| 95 | "\xea\xf4\x2b\x5e\x1c\x98\x4b\x88\xb9\xfb\xb7\xdc\x40\x6e\x4d\x16" => 2, # PreviewImage
|
|---|
| 96 | # ID 3 is used for 'mdat' atom (not a uuid)
|
|---|
| 97 | );
|
|---|
| 98 |
|
|---|
| 99 | # mark UserData tags that don't have ItemList counterparts as Preferred
|
|---|
| 100 | # - and set Preferred to 0 for any Avoid-ed tag
|
|---|
| 101 | # - also, for now, set Writable to 0 for any tag with a RawConv and no RawConvInv
|
|---|
| 102 | {
|
|---|
| 103 | my $itemList = \%Image::ExifTool::QuickTime::ItemList;
|
|---|
| 104 | my $userData = \%Image::ExifTool::QuickTime::UserData;
|
|---|
| 105 | my (%pref, $tag);
|
|---|
| 106 | foreach $tag (TagTableKeys($itemList)) {
|
|---|
| 107 | my $tagInfo = $$itemList{$tag};
|
|---|
| 108 | if (ref $tagInfo ne 'HASH') {
|
|---|
| 109 | next if ref $tagInfo;
|
|---|
| 110 | $tagInfo = $$itemList{$tag} = { Name => $tagInfo };
|
|---|
| 111 | } else {
|
|---|
| 112 | $$tagInfo{Writable} = 0 if $$tagInfo{RawConv} and not $$tagInfo{RawConvInv};
|
|---|
| 113 | $$tagInfo{Avoid} and $$tagInfo{Preferred} = 0, next;
|
|---|
| 114 | next if defined $$tagInfo{Preferred} and not $$tagInfo{Preferred};
|
|---|
| 115 | }
|
|---|
| 116 | $pref{$$tagInfo{Name}} = 1;
|
|---|
| 117 | }
|
|---|
| 118 | foreach $tag (TagTableKeys($userData)) {
|
|---|
| 119 | my $tagInfo = $$userData{$tag};
|
|---|
| 120 | if (ref $tagInfo ne 'HASH') {
|
|---|
| 121 | next if ref $tagInfo;
|
|---|
| 122 | $tagInfo = $$userData{$tag} = { Name => $tagInfo };
|
|---|
| 123 | } else {
|
|---|
| 124 | $$tagInfo{Writable} = 0 if $$tagInfo{RawConv} and not $$tagInfo{RawConvInv};
|
|---|
| 125 | $$tagInfo{Avoid} and $$tagInfo{Preferred} = 0, next;
|
|---|
| 126 | next if defined $$tagInfo{Preferred} or $pref{$$tagInfo{Name}};
|
|---|
| 127 | }
|
|---|
| 128 | $$tagInfo{Preferred} = 1;
|
|---|
| 129 | }
|
|---|
| 130 | }
|
|---|
| 131 |
|
|---|
| 132 | #------------------------------------------------------------------------------
|
|---|
| 133 | # Format GPSCoordinates for writing
|
|---|
| 134 | # Inputs: 0) PrintConv value
|
|---|
| 135 | # Returns: ValueConv value
|
|---|
| 136 | sub PrintInvGPSCoordinates($)
|
|---|
| 137 | {
|
|---|
| 138 | my ($val, $et) = @_;
|
|---|
| 139 | my @v = split /, */, $val;
|
|---|
| 140 | if (@v == 2 or @v == 3) {
|
|---|
| 141 | my $below = ($v[2] and $v[2] =~ /below/i);
|
|---|
| 142 | $v[0] = Image::ExifTool::GPS::ToDegrees($v[0], 1);
|
|---|
| 143 | $v[1] = Image::ExifTool::GPS::ToDegrees($v[1], 1);
|
|---|
| 144 | $v[2] = Image::ExifTool::ToFloat($v[2]) * ($below ? -1 : 1) if @v == 3;
|
|---|
| 145 | return "@v";
|
|---|
| 146 | }
|
|---|
| 147 | return $val if $val =~ /^([-+]\d+(\.\d*)?){2,3}(CRS.*)?\/?$/; # already in ISO6709 format?
|
|---|
| 148 | return undef;
|
|---|
| 149 | }
|
|---|
| 150 |
|
|---|
| 151 | #------------------------------------------------------------------------------
|
|---|
| 152 | # Convert GPS coordinates back to ISO6709 format
|
|---|
| 153 | # Inputs: 0) ValueConv value
|
|---|
| 154 | # Returns: ISO6709 coordinates
|
|---|
| 155 | sub ConvInvISO6709($)
|
|---|
| 156 | {
|
|---|
| 157 | local $_;
|
|---|
| 158 | my $val = shift;
|
|---|
| 159 | my @a = split ' ', $val;
|
|---|
| 160 | if (@a == 2 or @a == 3) {
|
|---|
| 161 | # latitude must have 2 digits before the decimal, and longitude 3,
|
|---|
| 162 | # and all values must start with a "+" or "-", and Google Photos
|
|---|
| 163 | # requires at least 3 digits after the decimal point
|
|---|
| 164 | my @fmt = ('%s%02d.%s%s','%s%03d.%s%s','%s%d.%s%s');
|
|---|
| 165 | foreach (@a) {
|
|---|
| 166 | return undef unless Image::ExifTool::IsFloat($_);
|
|---|
| 167 | $_ =~ s/^([-+]?)(\d+)\.?(\d*)/sprintf(shift(@fmt),$1||'+',$2,$3,length($3)<3 ? '0'x(3-length($3)) : '')/e;
|
|---|
| 168 | }
|
|---|
| 169 | return join '', @a, '/';
|
|---|
| 170 | }
|
|---|
| 171 | return $val if $val =~ /^([-+]\d+(\.\d*)?){2,3}(CRS.*)?\/?$/; # already in ISO6709 format?
|
|---|
| 172 | return undef;
|
|---|
| 173 | }
|
|---|
| 174 |
|
|---|
| 175 | #------------------------------------------------------------------------------
|
|---|
| 176 | # Handle offsets in iloc (ItemLocation) atom when writing (ref ISO 14496-12:2015 pg.79)
|
|---|
| 177 | # Inputs: 0) ExifTool ref, 1) dirInfo ref, 2) data ref, 3) output buffer ref
|
|---|
| 178 | # Returns: true on success
|
|---|
| 179 | # Notes: see also ParseItemLocation() in QuickTime.pm
|
|---|
| 180 | # (variable names with underlines correspond to names in ISO 14496-12)
|
|---|
| 181 | sub Handle_iloc($$$$)
|
|---|
| 182 | {
|
|---|
| 183 | my ($et, $dirInfo, $dataPt, $outfile) = @_;
|
|---|
| 184 | my ($i, $j, $num, $pos, $id);
|
|---|
| 185 |
|
|---|
| 186 | my $off = $$dirInfo{ChunkOffset};
|
|---|
| 187 | my $len = length $$dataPt;
|
|---|
| 188 | return 0 if $len < 8;
|
|---|
| 189 | my $ver = Get8u($dataPt, 0);
|
|---|
| 190 | my $siz = Get16u($dataPt, 4);
|
|---|
| 191 | my $noff = ($siz >> 12);
|
|---|
| 192 | my $nlen = ($siz >> 8) & 0x0f;
|
|---|
| 193 | my $nbas = ($siz >> 4) & 0x0f;
|
|---|
| 194 | my $nind = $siz & 0x0f;
|
|---|
| 195 | my %ok = ( 0 => 1, 4 => 1, 8 => 8 );
|
|---|
| 196 | return 0 unless $ok{$noff} and $ok{$nlen} and $ok{$nbas} and $ok{$nind};
|
|---|
| 197 | # piggy-back on existing code to fix up stco/co64 4/8-byte offsets
|
|---|
| 198 | my $tag = $noff == 4 ? 'stco_iloc' : 'co64_iloc';
|
|---|
| 199 | if ($ver < 2) {
|
|---|
| 200 | $num = Get16u($dataPt, 6);
|
|---|
| 201 | $pos = 8;
|
|---|
| 202 | } else {
|
|---|
| 203 | return 0 if $len < 10;
|
|---|
| 204 | $num = Get32u($dataPt, 6);
|
|---|
| 205 | $pos = 10;
|
|---|
| 206 | }
|
|---|
| 207 | for ($i=0; $i<$num; ++$i) {
|
|---|
| 208 | if ($ver < 2) {
|
|---|
| 209 | return 0 if $pos + 2 > $len;
|
|---|
| 210 | $id = Get16u($dataPt, $pos);
|
|---|
| 211 | $pos += 2;
|
|---|
| 212 | } else {
|
|---|
| 213 | return 0 if $pos + 4 > $len;
|
|---|
| 214 | $id = Get32u($dataPt, $pos);
|
|---|
| 215 | $pos += 4;
|
|---|
| 216 | }
|
|---|
| 217 | my ($constOff, @offBase, @offItem, $minOffset);
|
|---|
| 218 | if ($ver == 1 or $ver == 2) {
|
|---|
| 219 | return 0 if $pos + 2 > $len;
|
|---|
| 220 | # offsets are absolute only if ConstructionMethod is 0, otherwise
|
|---|
| 221 | # the relative offsets are constant as far as we are concerned
|
|---|
| 222 | $constOff = Get16u($dataPt, $pos) & 0x0f;
|
|---|
| 223 | $pos += 2;
|
|---|
| 224 | }
|
|---|
| 225 | return 0 if $pos + 2 > $len;
|
|---|
| 226 | my $drefIdx = Get16u($dataPt, $pos);
|
|---|
| 227 | if ($drefIdx) {
|
|---|
| 228 | if ($$et{QtDataRef} and $$et{QtDataRef}[$drefIdx - 1]) {
|
|---|
| 229 | my $dref = $$et{QtDataRef}[$drefIdx - 1];
|
|---|
| 230 | # these offsets are constant unless the data is in this file
|
|---|
| 231 | $constOff = 1 unless $$dref[1] == 1 and $$dref[0] ne 'rsrc';
|
|---|
| 232 | } else {
|
|---|
| 233 | $et->Error("No data reference for iloc entry $i");
|
|---|
| 234 | return 0;
|
|---|
| 235 | }
|
|---|
| 236 | }
|
|---|
| 237 | $pos += 2;
|
|---|
| 238 | # get base offset and save its location if in this file
|
|---|
| 239 | my $base_offset = GetVarInt($dataPt, $pos, $nbas);
|
|---|
| 240 | if ($base_offset and not $constOff) {
|
|---|
| 241 | my $tg = ($nbas == 4 ? 'stco' : 'co64') . '_iloc';
|
|---|
| 242 | push @offBase, [ $tg, length($$outfile) + 8 + $pos - $nbas, $nbas, 0, $id ];
|
|---|
| 243 | }
|
|---|
| 244 | return 0 if $pos + 2 > $len;
|
|---|
| 245 | my $ext_num = Get16u($dataPt, $pos);
|
|---|
| 246 | $pos += 2;
|
|---|
| 247 | my $listStartPos = $pos;
|
|---|
| 248 | # run through the item list to get offset locations and the minimum offset in this file
|
|---|
| 249 | for ($j=0; $j<$ext_num; ++$j) {
|
|---|
| 250 | $pos += $nind if $ver == 1 or $ver == 2;
|
|---|
| 251 | my $extent_offset = GetVarInt($dataPt, $pos, $noff);
|
|---|
| 252 | return 0 unless defined $extent_offset;
|
|---|
| 253 | unless ($constOff) {
|
|---|
| 254 | push @offItem, [ $tag, length($$outfile) + 8 + $pos - $noff, $noff, 0, $id ] if $noff;
|
|---|
| 255 | $minOffset = $extent_offset if not defined $minOffset or $minOffset > $extent_offset;
|
|---|
| 256 | }
|
|---|
| 257 | return 0 if $pos + $nlen > length $$dataPt;
|
|---|
| 258 | $pos += $nlen;
|
|---|
| 259 | }
|
|---|
| 260 | # decide whether to fix up the base offset or individual item offsets
|
|---|
| 261 | # (adjust the one that is larger)
|
|---|
| 262 | if (defined $minOffset and $minOffset > $base_offset) {
|
|---|
| 263 | $$_[3] = $base_offset foreach @offItem;
|
|---|
| 264 | push @$off, @offItem;
|
|---|
| 265 | } else {
|
|---|
| 266 | $$_[3] = $minOffset foreach @offBase;
|
|---|
| 267 | push @$off, @offBase;
|
|---|
| 268 | }
|
|---|
| 269 | }
|
|---|
| 270 | return 1;
|
|---|
| 271 | }
|
|---|
| 272 |
|
|---|
| 273 | #------------------------------------------------------------------------------
|
|---|
| 274 | # Get localized version of tagInfo hash
|
|---|
| 275 | # Inputs: 0) tagInfo hash ref, 1) language code (eg. "fra-FR")
|
|---|
| 276 | # Returns: new tagInfo hash ref, or undef if invalid or no language code
|
|---|
| 277 | sub GetLangInfo($$)
|
|---|
| 278 | {
|
|---|
| 279 | my ($tagInfo, $langCode) = @_;
|
|---|
| 280 | return undef unless $langCode;
|
|---|
| 281 | # only allow alternate language tags in lang-alt lists
|
|---|
| 282 | my $writable = $$tagInfo{Writable};
|
|---|
| 283 | $writable = $$tagInfo{Table}{WRITABLE} unless defined $writable;
|
|---|
| 284 | return undef unless $writable;
|
|---|
| 285 | $langCode =~ tr/_/-/; # RFC 3066 specifies '-' as a separator
|
|---|
| 286 | my $langInfo = Image::ExifTool::GetLangInfo($tagInfo, $langCode);
|
|---|
| 287 | return $langInfo;
|
|---|
| 288 | }
|
|---|
| 289 |
|
|---|
| 290 | #------------------------------------------------------------------------------
|
|---|
| 291 | # validate raw values for writing
|
|---|
| 292 | # Inputs: 0) ExifTool ref, 1) tagInfo hash ref, 2) raw value ref
|
|---|
| 293 | # Returns: error string or undef (and possibly changes value) on success
|
|---|
| 294 | sub CheckQTValue($$$)
|
|---|
| 295 | {
|
|---|
| 296 | my ($et, $tagInfo, $valPtr) = @_;
|
|---|
| 297 | my $format = $$tagInfo{Format} || $$tagInfo{Table}{FORMAT};
|
|---|
| 298 | return undef unless $format;
|
|---|
| 299 | return Image::ExifTool::CheckValue($valPtr, $format, $$tagInfo{Count});
|
|---|
| 300 | }
|
|---|
| 301 |
|
|---|
| 302 | #------------------------------------------------------------------------------
|
|---|
| 303 | # Format QuickTime value for writing
|
|---|
| 304 | # Inputs: 0) ExifTool ref, 1) value ref, 2) Format (or undef), 3) Writable (or undef)
|
|---|
| 305 | # Returns: Flags for QT data type, and reformats value as required
|
|---|
| 306 | sub FormatQTValue($$;$$)
|
|---|
| 307 | {
|
|---|
| 308 | my ($et, $valPt, $format, $writable) = @_;
|
|---|
| 309 | my $flags;
|
|---|
| 310 | if ($format and $format ne 'string') {
|
|---|
| 311 | $$valPt = WriteValue($$valPt, $format);
|
|---|
| 312 | if ($writable and $qtFormat{$writable}) {
|
|---|
| 313 | $flags = $qtFormat{$writable};
|
|---|
| 314 | } else {
|
|---|
| 315 | $flags = $qtFormat{$format} || 0;
|
|---|
| 316 | }
|
|---|
| 317 | } elsif ($$valPt =~ /^\xff\xd8\xff/) {
|
|---|
| 318 | $flags = 0x0d; # JPG
|
|---|
| 319 | } elsif ($$valPt =~ /^(\x89P|\x8aM|\x8bJ)NG\r\n\x1a\n/) {
|
|---|
| 320 | $flags = 0x0e; # PNG
|
|---|
| 321 | } elsif ($$valPt =~ /^BM.{15}\0/s) {
|
|---|
| 322 | $flags = 0x1b; # BMP
|
|---|
| 323 | } else {
|
|---|
| 324 | $flags = 0x01; # UTF8
|
|---|
| 325 | $$valPt = $et->Encode($$valPt, 'UTF8');
|
|---|
| 326 | }
|
|---|
| 327 | return $flags;
|
|---|
| 328 | }
|
|---|
| 329 |
|
|---|
| 330 | #------------------------------------------------------------------------------
|
|---|
| 331 | # Set variable-length integer (used by WriteItemInfo)
|
|---|
| 332 | # Inputs: 0) value, 1) integer size in bytes (0, 4 or 8),
|
|---|
| 333 | # Returns: packed integer
|
|---|
| 334 | sub SetVarInt($$)
|
|---|
| 335 | {
|
|---|
| 336 | my ($val, $n) = @_;
|
|---|
| 337 | if ($n == 4) {
|
|---|
| 338 | return Set32u($val);
|
|---|
| 339 | } elsif ($n == 8) {
|
|---|
| 340 | return Set64u($val);
|
|---|
| 341 | }
|
|---|
| 342 | return '';
|
|---|
| 343 | }
|
|---|
| 344 |
|
|---|
| 345 | #------------------------------------------------------------------------------
|
|---|
| 346 | # Write Meta Keys to add/delete entries as necessary ('mdta' handler) (ref PH)
|
|---|
| 347 | # Inputs: 0) ExifTool object ref, 1) dirInfo ref, 2) tag table ref
|
|---|
| 348 | # Returns: updated keys box data
|
|---|
| 349 | sub WriteKeys($$$)
|
|---|
| 350 | {
|
|---|
| 351 | my ($et, $dirInfo, $tagTablePtr) = @_;
|
|---|
| 352 | $et or return 1; # allow dummy access to autoload this package
|
|---|
| 353 | my $dataPt = $$dirInfo{DataPt};
|
|---|
| 354 | my $dirLen = length $$dataPt;
|
|---|
| 355 | my $outfile = $$dirInfo{OutFile};
|
|---|
| 356 | my ($tag, %done, %remap, %info, %add, $i);
|
|---|
| 357 |
|
|---|
| 358 | $dirLen < 8 and $et->Warn('Short Keys box'), $dirLen = 8, $$dataPt = "\0" x 8;
|
|---|
| 359 | if ($$et{DEL_GROUP}{Keys}) {
|
|---|
| 360 | $dirLen = 8; # delete all existing keys
|
|---|
| 361 | # deleted keys are identified by a zero entry in the Remap lookup
|
|---|
| 362 | my $n = Get32u($dataPt, 4);
|
|---|
| 363 | for ($i=1; $i<=$n; ++$i) { $remap{$i} = 0; }
|
|---|
| 364 | $et->VPrint(0, " [deleting $n Keys entr".($n==1 ? 'y' : 'ies')."]\n");
|
|---|
| 365 | ++$$et{CHANGED};
|
|---|
| 366 | }
|
|---|
| 367 | my $pos = 8;
|
|---|
| 368 | my $newTags = $et->GetNewTagInfoHash($tagTablePtr);
|
|---|
| 369 | my $newData = substr($$dataPt, 0, $pos);
|
|---|
| 370 |
|
|---|
| 371 | my $newIndex = 1;
|
|---|
| 372 | my $index = 1;
|
|---|
| 373 | while ($pos < $dirLen - 4) {
|
|---|
| 374 | my $len = unpack("x${pos}N", $$dataPt);
|
|---|
| 375 | last if $len < 8 or $pos + $len > $dirLen;
|
|---|
| 376 | my $ns = substr($$dataPt, $pos + 4, 4);
|
|---|
| 377 | $tag = substr($$dataPt, $pos + 8, $len - 8);
|
|---|
| 378 | $tag =~ s/\0.*//s; # truncate at null
|
|---|
| 379 | $tag =~ s/^com\.apple\.quicktime\.// if $ns eq 'mdta'; # remove apple quicktime domain
|
|---|
| 380 | $tag = "Tag_$ns" unless $tag;
|
|---|
| 381 | $done{$tag} = 1; # set flag to avoid creating this tag
|
|---|
| 382 | my $tagInfo = $et->GetTagInfo($tagTablePtr, $tag);
|
|---|
| 383 | if ($tagInfo) {
|
|---|
| 384 | $info{$index} = $tagInfo;
|
|---|
| 385 | if ($$newTags{$tag}) {
|
|---|
| 386 | my $nvHash = $et->GetNewValueHash($tagInfo);
|
|---|
| 387 | # drop this tag if it is being deleted
|
|---|
| 388 | if ($nvHash and $et->IsOverwriting($nvHash) > 0 and not defined $et->GetNewValue($nvHash)) {
|
|---|
| 389 | # don't delete this key if we could be writing any alternate-language version of this tag
|
|---|
| 390 | my ($t, $dontDelete);
|
|---|
| 391 | foreach $t (keys %$newTags) {
|
|---|
| 392 | next unless $$newTags{$t}{SrcTagInfo} and $$newTags{$t}{SrcTagInfo} eq $tagInfo;
|
|---|
| 393 | my $nv = $et->GetNewValueHash($$newTags{$t});
|
|---|
| 394 | next unless $et->IsOverwriting($nv) and defined $et->GetNewValue($nv);
|
|---|
| 395 | $dontDelete = 1;
|
|---|
| 396 | last;
|
|---|
| 397 | }
|
|---|
| 398 | unless ($dontDelete) {
|
|---|
| 399 | # delete this key
|
|---|
| 400 | $et->VPrint(1, "$$et{INDENT}\[deleting Keys entry $index '${tag}']\n");
|
|---|
| 401 | $pos += $len;
|
|---|
| 402 | $remap{$index++} = 0;
|
|---|
| 403 | ++$$et{CHANGED};
|
|---|
| 404 | next;
|
|---|
| 405 | }
|
|---|
| 406 | }
|
|---|
| 407 | }
|
|---|
| 408 | }
|
|---|
| 409 | # add to the Keys box data
|
|---|
| 410 | $newData .= substr($$dataPt, $pos, $len);
|
|---|
| 411 | $remap{$index++} = $newIndex++;
|
|---|
| 412 | $pos += $len;
|
|---|
| 413 | }
|
|---|
| 414 | # add keys for any tags we need to create
|
|---|
| 415 | foreach $tag (sort keys %$newTags) {
|
|---|
| 416 | my $tagInfo = $$newTags{$tag};
|
|---|
| 417 | my $id;
|
|---|
| 418 | if ($$tagInfo{LangCode} and $$tagInfo{SrcTagInfo}) {
|
|---|
| 419 | $id = $$tagInfo{SrcTagInfo}{TagID};
|
|---|
| 420 | } else {
|
|---|
| 421 | $id = $tag;
|
|---|
| 422 | }
|
|---|
| 423 | next if $done{$id};
|
|---|
| 424 | my $nvHash = $et->GetNewValueHash($tagInfo);
|
|---|
| 425 | next unless $$nvHash{IsCreating} and $et->IsOverwriting($nvHash) and
|
|---|
| 426 | defined $et->GetNewValue($nvHash);
|
|---|
| 427 | # add new entry to 'keys' data
|
|---|
| 428 | my $val = $id =~ /^com\./ ? $id : "com.apple.quicktime.$id";
|
|---|
| 429 | $newData .= Set32u(8 + length($val)) . 'mdta' . $val;
|
|---|
| 430 | $et->VPrint(1, "$$et{INDENT}\[adding Keys entry $newIndex '${id}']\n");
|
|---|
| 431 | $add{$newIndex++} = $tagInfo;
|
|---|
| 432 | ++$$et{CHANGED};
|
|---|
| 433 | }
|
|---|
| 434 | my $num = $newIndex - 1;
|
|---|
| 435 | if ($num) {
|
|---|
| 436 | Set32u($num, \$newData, 4); # update count in header
|
|---|
| 437 | } else {
|
|---|
| 438 | $newData = ''; # delete empty Keys box
|
|---|
| 439 | }
|
|---|
| 440 | # save temporary variables for use when writing ItemList:
|
|---|
| 441 | # Remap - lookup for remapping Keys ID numbers (0 if item is deleted)
|
|---|
| 442 | # Info - Keys tag information, based on old index value
|
|---|
| 443 | # Add - Keys items deleted, based on old index value
|
|---|
| 444 | # Num - Number of items in edited Keys box
|
|---|
| 445 | $$et{Keys} = { Remap => \%remap, Info => \%info, Add => \%add, Num => $num };
|
|---|
| 446 |
|
|---|
| 447 | return $newData; # return updated Keys box
|
|---|
| 448 | }
|
|---|
| 449 |
|
|---|
| 450 | #------------------------------------------------------------------------------
|
|---|
| 451 | # Write ItemInformation in HEIC files
|
|---|
| 452 | # Inputs: 0) ExifTool ref, 1) dirInfo ref (with BoxPos entry), 2) output buffer ref
|
|---|
| 453 | # Returns: mdat edit list ref (empty if nothing changed)
|
|---|
| 454 | sub WriteItemInfo($$$)
|
|---|
| 455 | {
|
|---|
| 456 | my ($et, $dirInfo, $outfile) = @_;
|
|---|
| 457 | my $boxPos = $$dirInfo{BoxPos}; # hash of [length,position] for each box
|
|---|
| 458 | my $raf = $$et{RAF};
|
|---|
| 459 | my $items = $$et{ItemInfo};
|
|---|
| 460 | my (%did, @mdatEdit, $name);
|
|---|
| 461 |
|
|---|
| 462 | return () unless $items and $raf;
|
|---|
| 463 |
|
|---|
| 464 | # extract information from EXIF/XMP metadata items
|
|---|
| 465 | my $primary = $$et{PrimaryItem};
|
|---|
| 466 | my $curPos = $raf->Tell();
|
|---|
| 467 | my $id;
|
|---|
| 468 | foreach $id (sort { $a <=> $b } keys %$items) {
|
|---|
| 469 | $primary = $id unless defined $primary; # assume primary is lowest-number item if pitm missing
|
|---|
| 470 | my $item = $$items{$id};
|
|---|
| 471 | # only edit primary EXIF/XMP metadata
|
|---|
| 472 | next unless $$item{RefersTo} and $$item{RefersTo}{$primary};
|
|---|
| 473 | my $type = $$item{ContentType} || $$item{Type} || next;
|
|---|
| 474 | # get ExifTool name for this item
|
|---|
| 475 | $name = { Exif => 'EXIF', 'application/rdf+xml' => 'XMP' }->{$type};
|
|---|
| 476 | next unless $name; # only care about EXIF and XMP
|
|---|
| 477 | next unless $$et{EDIT_DIRS}{$name};
|
|---|
| 478 | $did{$name} = 1; # set flag to prevent creating this metadata
|
|---|
| 479 | my ($warn, $extent, $buff, @edit);
|
|---|
| 480 | $warn = 'Missing iloc box' unless $$boxPos{iloc};
|
|---|
| 481 | $warn = "No Extents for $type item" unless $$item{Extents} and @{$$item{Extents}};
|
|---|
| 482 | $warn = "Can't currently decode encoded $type metadata" if $$item{ContentEncoding};
|
|---|
| 483 | $warn = "Can't currently decode protected $type metadata" if $$item{ProtectionIndex};
|
|---|
| 484 | $warn = "Can't currently extract $type with construction method $$item{ConstructionMethod}" if $$item{ConstructionMethod};
|
|---|
| 485 | $warn = "$type metadata is not this file" if $$item{DataReferenceIndex};
|
|---|
| 486 | $warn and $et->Warn($warn), next;
|
|---|
| 487 | my $base = $$item{BaseOffset} || 0;
|
|---|
| 488 | my $val = '';
|
|---|
| 489 | foreach $extent (@{$$item{Extents}}) {
|
|---|
| 490 | $val .= $buff if defined $buff;
|
|---|
| 491 | my $pos = $$extent[1] + $base;
|
|---|
| 492 | if ($$extent[2]) {
|
|---|
| 493 | $raf->Seek($pos, 0) or last;
|
|---|
| 494 | $raf->Read($buff, $$extent[2]) or last;
|
|---|
| 495 | } else {
|
|---|
| 496 | $buff = '';
|
|---|
| 497 | }
|
|---|
| 498 | push @edit, [ $pos, $pos + $$extent[2] ]; # replace or delete this if changed
|
|---|
| 499 | }
|
|---|
| 500 | next unless defined $buff;
|
|---|
| 501 | $buff = $val . $buff if length $val;
|
|---|
| 502 | my ($hdr, $subTable, $proc);
|
|---|
| 503 | if ($name eq 'EXIF') {
|
|---|
| 504 | if (not length $buff) {
|
|---|
| 505 | # create EXIF from scratch
|
|---|
| 506 | $hdr = "\0\0\0\x06Exif\0\0";
|
|---|
| 507 | } elsif ($buff =~ /^(MM\0\x2a|II\x2a\0)/) {
|
|---|
| 508 | $et->Warn('Missing Exif header');
|
|---|
| 509 | $hdr = '';
|
|---|
| 510 | } elsif (length($buff) >= 4 and length($buff) >= 4 + unpack('N',$buff)) {
|
|---|
| 511 | $hdr = substr($buff, 0, 4 + unpack('N',$buff));
|
|---|
| 512 | } else {
|
|---|
| 513 | $et->Warn('Invalid Exif header');
|
|---|
| 514 | next;
|
|---|
| 515 | }
|
|---|
| 516 | $subTable = GetTagTable('Image::ExifTool::Exif::Main');
|
|---|
| 517 | $proc = \&Image::ExifTool::WriteTIFF;
|
|---|
| 518 | } else {
|
|---|
| 519 | $hdr = '';
|
|---|
| 520 | $subTable = GetTagTable('Image::ExifTool::XMP::Main');
|
|---|
| 521 | }
|
|---|
| 522 | my %dirInfo = (
|
|---|
| 523 | DataPt => \$buff,
|
|---|
| 524 | DataLen => length $buff,
|
|---|
| 525 | DirStart => length $hdr,
|
|---|
| 526 | DirLen => length($buff) - length $hdr,
|
|---|
| 527 | );
|
|---|
| 528 | my $changed = $$et{CHANGED};
|
|---|
| 529 | my $newVal = $et->WriteDirectory(\%dirInfo, $subTable, $proc);
|
|---|
| 530 | if (defined $newVal and $changed ne $$et{CHANGED} and
|
|---|
| 531 | # nothing changed if deleting an empty directory
|
|---|
| 532 | ($dirInfo{DirLen} or length $newVal))
|
|---|
| 533 | {
|
|---|
| 534 | $newVal = $hdr . $newVal if length $hdr and length $newVal;
|
|---|
| 535 | $edit[0][2] = \$newVal; # replace the old chunk with the new data
|
|---|
| 536 | $edit[0][3] = $id; # mark this chunk with the item ID
|
|---|
| 537 | push @mdatEdit, @edit;
|
|---|
| 538 | # update item extent_length
|
|---|
| 539 | my $n = length $newVal;
|
|---|
| 540 | foreach $extent (@{$$item{Extents}}) {
|
|---|
| 541 | my ($nlen, $lenPt) = @$extent[3,4];
|
|---|
| 542 | if ($nlen == 8) {
|
|---|
| 543 | Set64u($n, $outfile, $$boxPos{iloc}[0] + 8 + $lenPt);
|
|---|
| 544 | } elsif ($n <= 0xffffffff) {
|
|---|
| 545 | Set32u($n, $outfile, $$boxPos{iloc}[0] + 8 + $lenPt);
|
|---|
| 546 | } else {
|
|---|
| 547 | $et->Error("Can't yet promote iloc length to 64 bits");
|
|---|
| 548 | return ();
|
|---|
| 549 | }
|
|---|
| 550 | $n = 0;
|
|---|
| 551 | }
|
|---|
| 552 | if (@{$$item{Extents}} != 1) {
|
|---|
| 553 | $et->Error("Can't yet handle $name in multiple parts. Please submit sample for testing");
|
|---|
| 554 | }
|
|---|
| 555 | }
|
|---|
| 556 | $$et{CHANGED} = $changed; # (will set this later if successful in editing mdat)
|
|---|
| 557 | }
|
|---|
| 558 | $raf->Seek($curPos, 0); # seek back to original position
|
|---|
| 559 |
|
|---|
| 560 | # add necessary metadata types if they didn't already exist
|
|---|
| 561 | my ($countNew, %add, %usedID);
|
|---|
| 562 | foreach $name ('EXIF','XMP') {
|
|---|
| 563 | next if $did{$name} or not $$et{ADD_DIRS}{$name};
|
|---|
| 564 | my @missing;
|
|---|
| 565 | $$boxPos{$_} or push @missing, $_ foreach qw(iinf iloc);
|
|---|
| 566 | if (@missing) {
|
|---|
| 567 | my $str = @missing > 1 ? join(' and ', @missing) . ' boxes' : "@missing box";
|
|---|
| 568 | $et->Warn("Can't create $name. Missing expected $str");
|
|---|
| 569 | last;
|
|---|
| 570 | }
|
|---|
| 571 | unless (defined $$et{PrimaryItem}) {
|
|---|
| 572 | unless (defined $primary) {
|
|---|
| 573 | $et->Warn("Can't create $name. No items to reference");
|
|---|
| 574 | last;
|
|---|
| 575 | }
|
|---|
| 576 | # add new primary item reference box after hdrl box
|
|---|
| 577 | if ($primary < 0x10000) {
|
|---|
| 578 | $add{hdlr} = pack('Na4Nn', 14, 'pitm', 0, $primary);
|
|---|
| 579 | } else {
|
|---|
| 580 | $add{hdlr} = pack('Na4CCCCN', 16, 'pitm', 1, 0, 0, 0, $primary);
|
|---|
| 581 | }
|
|---|
| 582 | $et->Warn("Added missing PrimaryItemReference (for item $primary)", 1);
|
|---|
| 583 | }
|
|---|
| 584 | my $buff = '';
|
|---|
| 585 | my ($hdr, $subTable, $proc);
|
|---|
| 586 | if ($name eq 'EXIF') {
|
|---|
| 587 | $hdr = "\0\0\0\x06Exif\0\0";
|
|---|
| 588 | $subTable = GetTagTable('Image::ExifTool::Exif::Main');
|
|---|
| 589 | $proc = \&Image::ExifTool::WriteTIFF;
|
|---|
| 590 | } else {
|
|---|
| 591 | $hdr = '';
|
|---|
| 592 | $subTable = GetTagTable('Image::ExifTool::XMP::Main');
|
|---|
| 593 | }
|
|---|
| 594 | my %dirInfo = (
|
|---|
| 595 | DataPt => \$buff,
|
|---|
| 596 | DataLen => 0,
|
|---|
| 597 | DirStart => 0,
|
|---|
| 598 | DirLen => 0,
|
|---|
| 599 | );
|
|---|
| 600 | my $changed = $$et{CHANGED};
|
|---|
| 601 | my $newVal = $et->WriteDirectory(\%dirInfo, $subTable, $proc);
|
|---|
| 602 | if (defined $newVal and $changed ne $$et{CHANGED}) {
|
|---|
| 603 | my $irefVer;
|
|---|
| 604 | if ($$boxPos{iref}) {
|
|---|
| 605 | $irefVer = Get8u($outfile, $$boxPos{iref}[0] + 8);
|
|---|
| 606 | } else {
|
|---|
| 607 | # create iref box after end of iinf box (and save version in boxPos list)
|
|---|
| 608 | $irefVer = ($primary < 0x10000 ? 0 : 1);
|
|---|
| 609 | $$boxPos{iref} = [ $$boxPos{iinf}[0] + $$boxPos{iinf}[1], 0, $irefVer ];
|
|---|
| 610 | }
|
|---|
| 611 | $newVal = $hdr . $newVal if length $hdr;
|
|---|
| 612 | # add new infe to iinf
|
|---|
| 613 | $add{iinf} = $add{iref} = $add{iloc} = '' unless defined $add{iinf};
|
|---|
| 614 | my ($type, $mime);
|
|---|
| 615 | if ($name eq 'XMP') {
|
|---|
| 616 | $type = "mime\0";
|
|---|
| 617 | $mime = "application/rdf+xml\0";
|
|---|
| 618 | } else {
|
|---|
| 619 | $type = "Exif\0";
|
|---|
| 620 | $mime = '';
|
|---|
| 621 | }
|
|---|
| 622 | my $id = 1;
|
|---|
| 623 | ++$id while $$items{$id} or $usedID{$id}; # find next unused item ID
|
|---|
| 624 | my $n = length($type) + length($mime) + 16;
|
|---|
| 625 | if ($id < 0x10000) {
|
|---|
| 626 | $add{iinf} .= pack('Na4CCCCnn', $n, 'infe', 2, 0, 0, 1, $id, 0) . $type . $mime;
|
|---|
| 627 | } else {
|
|---|
| 628 | $n += 2;
|
|---|
| 629 | $add{iinf} .= pack('Na4CCCCNn', $n, 'infe', 3, 0, 0, 1, $id, 0) . $type . $mime;
|
|---|
| 630 | }
|
|---|
| 631 | # add new cdsc to iref
|
|---|
| 632 | if ($irefVer) {
|
|---|
| 633 | $add{iref} .= pack('Na4NnN', 18, 'cdsc', $id, 1, $primary);
|
|---|
| 634 | } else {
|
|---|
| 635 | $add{iref} .= pack('Na4nnn', 14, 'cdsc', $id, 1, $primary);
|
|---|
| 636 | }
|
|---|
| 637 | # add new entry to iloc table (see ISO14496-12:2015 pg.79)
|
|---|
| 638 | my $ilocVer = Get8u($outfile, $$boxPos{iloc}[0] + 8);
|
|---|
| 639 | my $siz = Get16u($outfile, $$boxPos{iloc}[0] + 12); # get size information
|
|---|
| 640 | my $noff = ($siz >> 12);
|
|---|
| 641 | my $nlen = ($siz >> 8) & 0x0f;
|
|---|
| 642 | my $nbas = ($siz >> 4) & 0x0f;
|
|---|
| 643 | my $nind = $siz & 0x0f;
|
|---|
| 644 | my ($pbas, $poff);
|
|---|
| 645 | if ($ilocVer == 0) {
|
|---|
| 646 | # set offset to 0 as flag that this is a new idat chunk being added
|
|---|
| 647 | $pbas = length($add{iloc}) + 4;
|
|---|
| 648 | $poff = $pbas + $nbas + 2;
|
|---|
| 649 | $add{iloc} .= pack('nn',$id,0) . SetVarInt(0,$nbas) . Set16u(1) .
|
|---|
| 650 | SetVarInt(0,$noff) . SetVarInt(length($newVal),$nlen);
|
|---|
| 651 | } elsif ($ilocVer == 1) {
|
|---|
| 652 | $pbas = length($add{iloc}) + 6;
|
|---|
| 653 | $poff = $pbas + $nbas + 2 + $nind;
|
|---|
| 654 | $add{iloc} .= pack('nnn',$id,0,0) . SetVarInt(0,$nbas) . Set16u(1) . SetVarInt(0,$nind) .
|
|---|
| 655 | SetVarInt(0,$noff) . SetVarInt(length($newVal),$nlen);
|
|---|
| 656 | } elsif ($ilocVer == 2) {
|
|---|
| 657 | $pbas = length($add{iloc}) + 8;
|
|---|
| 658 | $poff = $pbas + $nbas + 2 + $nind;
|
|---|
| 659 | $add{iloc} .= pack('Nnn',$id,0,0) . SetVarInt(0,$nbas) . Set16u(1) . SetVarInt(0,$nind) .
|
|---|
| 660 | SetVarInt(0,$noff) . SetVarInt(length($newVal),$nlen);
|
|---|
| 661 | } else {
|
|---|
| 662 | $et->Warn("Can't create $name. Unsupported iloc version $ilocVer");
|
|---|
| 663 | last;
|
|---|
| 664 | }
|
|---|
| 665 | # add new ChunkOffset entry to update this new offset
|
|---|
| 666 | my $off = $$dirInfo{ChunkOffset} or $et->Warn('Internal error. Missing ChunkOffset'), last;
|
|---|
| 667 | my $newOff;
|
|---|
| 668 | if ($noff == 4) {
|
|---|
| 669 | $newOff = [ 'stco_iloc', $$boxPos{iloc}[0] + $$boxPos{iloc}[1] + $poff, $noff, 0, $id ];
|
|---|
| 670 | } elsif ($noff == 8) {
|
|---|
| 671 | $newOff = [ 'co64_iloc', $$boxPos{iloc}[0] + $$boxPos{iloc}[1] + $poff, $noff, 0, $id ];
|
|---|
| 672 | } elsif ($noff == 0) {
|
|---|
| 673 | # offset_size is zero, so store the offset in base_offset instead
|
|---|
| 674 | if ($nbas == 4) {
|
|---|
| 675 | $newOff = [ 'stco_iloc', $$boxPos{iloc}[0] + $$boxPos{iloc}[1] + $pbas, $nbas, 0, $id ];
|
|---|
| 676 | } elsif ($nbas == 8) {
|
|---|
| 677 | $newOff = [ 'co64_iloc', $$boxPos{iloc}[0] + $$boxPos{iloc}[1] + $pbas, $nbas, 0, $id ];
|
|---|
| 678 | } else {
|
|---|
| 679 | $et->Warn("Can't create $name. Invalid iloc offset+base size");
|
|---|
| 680 | last;
|
|---|
| 681 | }
|
|---|
| 682 | } else {
|
|---|
| 683 | $et->Warn("Can't create $name. Invalid iloc offset size");
|
|---|
| 684 | last;
|
|---|
| 685 | }
|
|---|
| 686 | # add directory as a new mdat chunk
|
|---|
| 687 | push @$off, $newOff;
|
|---|
| 688 | push @mdatEdit, [ 0, 0, \$newVal, $id ];
|
|---|
| 689 | $usedID{$id} = 1;
|
|---|
| 690 | $countNew = ($countNew || 0) + 1;
|
|---|
| 691 | $$et{CHANGED} = $changed; # set this later if successful in editing mdat
|
|---|
| 692 | }
|
|---|
| 693 | }
|
|---|
| 694 | if ($countNew) {
|
|---|
| 695 | # insert new entries into iinf, iref and iloc boxes,
|
|---|
| 696 | # and add new pitm box after hdlr if necessary
|
|---|
| 697 | my $added = 0;
|
|---|
| 698 | my $tag;
|
|---|
| 699 | foreach $tag (sort { $$boxPos{$a}[0] <=> $$boxPos{$b}[0] } keys %$boxPos) {
|
|---|
| 700 | next unless $add{$tag};
|
|---|
| 701 | my $pos = $$boxPos{$tag}[0] + $added;
|
|---|
| 702 | unless ($$boxPos{$tag}[1]) {
|
|---|
| 703 | $tag eq 'iref' or $et->Error('Internal error adding iref box'), last;
|
|---|
| 704 | # create new iref box
|
|---|
| 705 | $add{$tag} = Set32u(12 + length $add{$tag}) . $tag .
|
|---|
| 706 | Set8u($$boxPos{$tag}[2]) . "\0\0\0" . $add{$tag};
|
|---|
| 707 | } elsif ($tag ne 'hdlr') {
|
|---|
| 708 | my $n = Get32u($outfile, $pos);
|
|---|
| 709 | Set32u($n + length($add{$tag}), $outfile, $pos); # increase box size
|
|---|
| 710 | }
|
|---|
| 711 | if ($tag eq 'iinf') {
|
|---|
| 712 | my $iinfVer = Get8u($outfile, $pos + 8);
|
|---|
| 713 | if ($iinfVer == 0) {
|
|---|
| 714 | my $n = Get16u($outfile, $pos + 12);
|
|---|
| 715 | Set16u($n + $countNew, $outfile, $pos + 12); # incr count
|
|---|
| 716 | } else {
|
|---|
| 717 | my $n = Get32u($outfile, $pos + 12);
|
|---|
| 718 | Set32u($n + $countNew, $outfile, $pos + 12); # incr count
|
|---|
| 719 | }
|
|---|
| 720 | } elsif ($tag eq 'iref') {
|
|---|
| 721 | # nothing more to do
|
|---|
| 722 | } elsif ($tag eq 'iloc') {
|
|---|
| 723 | my $ilocVer = Get8u($outfile, $pos + 8);
|
|---|
| 724 | if ($ilocVer < 2) {
|
|---|
| 725 | my $n = Get16u($outfile, $pos + 14);
|
|---|
| 726 | Set16u($n + $countNew, $outfile, $pos + 14); # incr count
|
|---|
| 727 | } else {
|
|---|
| 728 | my $n = Get32u($outfile, $pos + 14);
|
|---|
| 729 | Set32u($n + $countNew, $outfile, $pos + 14); # incr count
|
|---|
| 730 | }
|
|---|
| 731 | # must also update pointer locations in this box
|
|---|
| 732 | if ($added) {
|
|---|
| 733 | $$_[1] += $added foreach @{$$dirInfo{ChunkOffset}};
|
|---|
| 734 | }
|
|---|
| 735 | } elsif ($tag ne 'hdlr') {
|
|---|
| 736 | next;
|
|---|
| 737 | }
|
|---|
| 738 | # add new entries to this box (or add pitm after hdlr)
|
|---|
| 739 | substr($$outfile, $pos + $$boxPos{$tag}[1], 0) = $add{$tag};
|
|---|
| 740 | $added += length $add{$tag}; # positions are shifted by length of new entries
|
|---|
| 741 | }
|
|---|
| 742 | }
|
|---|
| 743 | delete $$et{ItemInfo};
|
|---|
| 744 | return @mdatEdit ? \@mdatEdit : undef;
|
|---|
| 745 | }
|
|---|
| 746 |
|
|---|
| 747 | #------------------------------------------------------------------------------
|
|---|
| 748 | # Write a series of QuickTime atoms from file or in memory
|
|---|
| 749 | # Inputs: 0) ExifTool ref, 1) dirInfo ref, 2) tag table ref
|
|---|
| 750 | # Returns: A) if dirInfo contains DataPt: new directory data
|
|---|
| 751 | # B) otherwise: true on success, 0 if a write error occurred
|
|---|
| 752 | # (true but sets an Error on a file format error)
|
|---|
| 753 | # Notes: Yes, this is a real mess. Just like the QuickTime metadata situation.
|
|---|
| 754 | sub WriteQuickTime($$$)
|
|---|
| 755 | {
|
|---|
| 756 | local $_;
|
|---|
| 757 | my ($et, $dirInfo, $tagTablePtr) = @_;
|
|---|
| 758 | $et or return 1; # allow dummy access to autoload this package
|
|---|
| 759 | my ($mdat, @mdat, @mdatEdit, $edit, $track, $outBuff, $co, $term, $delCount);
|
|---|
| 760 | my (%langTags, $canCreate, $delGrp, %boxPos, %didDir, $writeLast, $err, $atomCount);
|
|---|
| 761 | my $outfile = $$dirInfo{OutFile} || return 0;
|
|---|
| 762 | my $raf = $$dirInfo{RAF}; # (will be null for lower-level atoms)
|
|---|
| 763 | my $dataPt = $$dirInfo{DataPt}; # (will be null for top-level atoms)
|
|---|
| 764 | my $dirName = $$dirInfo{DirName};
|
|---|
| 765 | my $dirStart = $$dirInfo{DirStart} || 0;
|
|---|
| 766 | my $parent = $$dirInfo{Parent};
|
|---|
| 767 | my $addDirs = $$et{ADD_DIRS};
|
|---|
| 768 | my $didTag = $$et{DidTag};
|
|---|
| 769 | my $newTags = { };
|
|---|
| 770 | my $createKeys = 0;
|
|---|
| 771 | my ($rtnVal, $rtnErr) = $dataPt ? (undef, undef) : (1, 0);
|
|---|
| 772 |
|
|---|
| 773 | if ($dataPt) {
|
|---|
| 774 | $raf = new File::RandomAccess($dataPt);
|
|---|
| 775 | } else {
|
|---|
| 776 | return 0 unless $raf;
|
|---|
| 777 | }
|
|---|
| 778 | # use buffered output for everything but 'mdat' atoms
|
|---|
| 779 | $outBuff = '';
|
|---|
| 780 | $outfile = \$outBuff;
|
|---|
| 781 |
|
|---|
| 782 | $raf->Seek($dirStart, 1) if $dirStart; # skip header if it exists
|
|---|
| 783 |
|
|---|
| 784 | my $curPath = join '-', @{$$et{PATH}};
|
|---|
| 785 | my ($dir, $writePath) = ($dirName, $dirName);
|
|---|
| 786 | $writePath = "$dir-$writePath" while defined($dir = $$et{DirMap}{$dir});
|
|---|
| 787 | # hack to create Keys directories if necessary (its containing Meta is in a different location)
|
|---|
| 788 | if ($$addDirs{Keys} and $curPath =~ /^MOV-Movie(-Meta)?$/) {
|
|---|
| 789 | $createKeys = 1; # create new Keys directories
|
|---|
| 790 | } elsif ($curPath eq 'MOV-Movie-Meta-ItemList') {
|
|---|
| 791 | $createKeys = 2; # create new Keys tags
|
|---|
| 792 | my $keys = $$et{Keys};
|
|---|
| 793 | if ($keys) {
|
|---|
| 794 | # add new tag entries for existing Keys tags, now that we know their ID's
|
|---|
| 795 | # - first make lookup to convert Keys tagInfo ref to index number
|
|---|
| 796 | my ($index, %keysInfo);
|
|---|
| 797 | foreach $index (keys %{$$keys{Info}}) {
|
|---|
| 798 | $keysInfo{$$keys{Info}{$index}} = $index if $$keys{Remap}{$index};
|
|---|
| 799 | }
|
|---|
| 800 | my $keysTable = GetTagTable('Image::ExifTool::QuickTime::Keys');
|
|---|
| 801 | my $newKeysTags = $et->GetNewTagInfoHash($keysTable);
|
|---|
| 802 | foreach (keys %$newKeysTags) {
|
|---|
| 803 | my $tagInfo = $$newKeysTags{$_};
|
|---|
| 804 | $index = $keysInfo{$tagInfo} || ($$tagInfo{SrcTagInfo} and $keysInfo{$$tagInfo{SrcTagInfo}});
|
|---|
| 805 | next unless $index;
|
|---|
| 806 | my $id = Set32u($index);
|
|---|
| 807 | if ($$tagInfo{LangCode}) {
|
|---|
| 808 | # add to lookup of language tags we are writing with this ID
|
|---|
| 809 | $langTags{$id} = { } unless $langTags{$id};
|
|---|
| 810 | $langTags{$id}{$_} = $tagInfo;
|
|---|
| 811 | $id .= '-' . $$tagInfo{LangCode};
|
|---|
| 812 | }
|
|---|
| 813 | $$newTags{$id} = $tagInfo;
|
|---|
| 814 | }
|
|---|
| 815 | }
|
|---|
| 816 | } else {
|
|---|
| 817 | # get hash of new tags to edit/create in this directory
|
|---|
| 818 | $newTags = $et->GetNewTagInfoHash($tagTablePtr);
|
|---|
| 819 | # make lookup of language tags for each ID
|
|---|
| 820 | foreach (keys %$newTags) {
|
|---|
| 821 | next unless $$newTags{$_}{LangCode} and $$newTags{$_}{SrcTagInfo};
|
|---|
| 822 | my $id = $$newTags{$_}{SrcTagInfo}{TagID};
|
|---|
| 823 | $langTags{$id} = { } unless $langTags{$id};
|
|---|
| 824 | $langTags{$id}{$_} = $$newTags{$_};
|
|---|
| 825 | }
|
|---|
| 826 | }
|
|---|
| 827 | if ($curPath eq $writePath or $createKeys) {
|
|---|
| 828 | $canCreate = 1;
|
|---|
| 829 | $delGrp = $$et{DEL_GROUP}{$dirName};
|
|---|
| 830 | }
|
|---|
| 831 | $atomCount = $$tagTablePtr{VARS}{ATOM_COUNT} if $$tagTablePtr{VARS};
|
|---|
| 832 |
|
|---|
| 833 | for (;;) { # loop through all atoms at this level
|
|---|
| 834 | if (defined $atomCount and --$atomCount < 0 and $dataPt) {
|
|---|
| 835 | # stop processing now and just copy the rest of the atom
|
|---|
| 836 | Write($outfile, substr($$dataPt, $raf->Tell())) or $rtnVal=$rtnErr, $err=1;
|
|---|
| 837 | last;
|
|---|
| 838 | }
|
|---|
| 839 | my ($hdr, $buff, $keysIndex);
|
|---|
| 840 | my $n = $raf->Read($hdr, 8);
|
|---|
| 841 | unless ($n == 8) {
|
|---|
| 842 | if ($n == 4 and $hdr eq "\0\0\0\0") {
|
|---|
| 843 | # "for historical reasons" the udta is optionally terminated by 4 zeros (ref 1)
|
|---|
| 844 | # --> hold this terminator to the end
|
|---|
| 845 | $term = $hdr;
|
|---|
| 846 | } elsif ($n != 0) {
|
|---|
| 847 | $et->Error('File format error');
|
|---|
| 848 | }
|
|---|
| 849 | last;
|
|---|
| 850 | }
|
|---|
| 851 | my $size = Get32u(\$hdr, 0) - 8; # (atom size without 8-byte header)
|
|---|
| 852 | my $tag = substr($hdr, 4, 4);
|
|---|
| 853 | if ($size == -7) {
|
|---|
| 854 | # read the extended size
|
|---|
| 855 | $raf->Read($buff, 8) == 8 or $et->Error('Truncated extended atom'), last;
|
|---|
| 856 | $hdr .= $buff;
|
|---|
| 857 | my ($hi, $lo) = unpack('NN', $buff);
|
|---|
| 858 | if ($hi or $lo > 0x7fffffff) {
|
|---|
| 859 | if ($hi > 0x7fffffff) {
|
|---|
| 860 | $et->Error('Invalid atom size');
|
|---|
| 861 | last;
|
|---|
| 862 | } elsif (not $et->Options('LargeFileSupport')) {
|
|---|
| 863 | $et->Error('End of processing at large atom (LargeFileSupport not enabled)');
|
|---|
| 864 | last;
|
|---|
| 865 | }
|
|---|
| 866 | }
|
|---|
| 867 | $size = $hi * 4294967296 + $lo - 16;
|
|---|
| 868 | $size < 0 and $et->Error('Invalid extended atom size'), last;
|
|---|
| 869 | } elsif ($size == -8) {
|
|---|
| 870 | if ($dataPt) {
|
|---|
| 871 | last if $$dirInfo{DirName} eq 'CanonCNTH'; # (this is normal for Canon CNTH atom)
|
|---|
| 872 | my $pos = $raf->Tell() - 4;
|
|---|
| 873 | $raf->Seek(0,2);
|
|---|
| 874 | my $str = $$dirInfo{DirName} . ' with ' . ($raf->Tell() - $pos) . ' bytes';
|
|---|
| 875 | $et->Error("Terminator found in $str remaining", 1);
|
|---|
| 876 | } else {
|
|---|
| 877 | # size of zero is only valid for top-level atom, and
|
|---|
| 878 | # indicates the atom extends to the end of file
|
|---|
| 879 | # (save in mdat list to write later; with zero end position to copy rest of file)
|
|---|
| 880 | push @mdat, [ $raf->Tell(), 0, $hdr ];
|
|---|
| 881 | }
|
|---|
| 882 | last;
|
|---|
| 883 | } elsif ($size < 0) {
|
|---|
| 884 | $et->Error('Invalid atom size');
|
|---|
| 885 | last;
|
|---|
| 886 | }
|
|---|
| 887 |
|
|---|
| 888 | # keep track of 'mdat' atom locations for writing later
|
|---|
| 889 | if ($tag eq 'mdat') {
|
|---|
| 890 | if ($dataPt) {
|
|---|
| 891 | $et->Error("'mdat' not at top level");
|
|---|
| 892 | last;
|
|---|
| 893 | }
|
|---|
| 894 | push @mdat, [ $raf->Tell(), $raf->Tell() + $size, $hdr ];
|
|---|
| 895 | $raf->Seek($size, 1) or $et->Error("Seek error in mdat atom"), return $rtnVal;
|
|---|
| 896 | next;
|
|---|
| 897 | } elsif ($tag eq 'cmov') {
|
|---|
| 898 | $et->Error("Can't yet write compressed movie metadata");
|
|---|
| 899 | return $rtnVal;
|
|---|
| 900 | } elsif ($tag eq 'wide') {
|
|---|
| 901 | next; # drop 'wide' tag
|
|---|
| 902 | }
|
|---|
| 903 |
|
|---|
| 904 | # read the atom data
|
|---|
| 905 | my $got;
|
|---|
| 906 | if (not $size) {
|
|---|
| 907 | $buff = '';
|
|---|
| 908 | $got = 0;
|
|---|
| 909 | } else {
|
|---|
| 910 | # read the atom data (but only first 64kB if data is huge)
|
|---|
| 911 | $got = $raf->Read($buff, $size > $maxReadLen ? 0x10000 : $size);
|
|---|
| 912 | }
|
|---|
| 913 | if ($got != $size) {
|
|---|
| 914 | # ignore up to 256 bytes of garbage at end of file
|
|---|
| 915 | if ($got <= 256 and $size >= 1024 and $tag ne 'mdat') {
|
|---|
| 916 | my $bytes = $got + length $hdr;
|
|---|
| 917 | if ($$et{OPTIONS}{IgnoreMinorErrors}) {
|
|---|
| 918 | $et->Warn("Deleted garbage at end of file ($bytes bytes)");
|
|---|
| 919 | $buff = $hdr = '';
|
|---|
| 920 | } else {
|
|---|
| 921 | $et->Error("Possible garbage at end of file ($bytes bytes)", 1);
|
|---|
| 922 | return $rtnVal;
|
|---|
| 923 | }
|
|---|
| 924 | } else {
|
|---|
| 925 | $tag = PrintableTagID($tag,3);
|
|---|
| 926 | if ($size > $maxReadLen and $got == 0x10000) {
|
|---|
| 927 | my $mb = int($size / 0x100000 + 0.5);
|
|---|
| 928 | $et->Error("'${tag}' atom is too large for rewriting ($mb MB)");
|
|---|
| 929 | } else {
|
|---|
| 930 | $et->Error("Truncated '${tag}' atom");
|
|---|
| 931 | }
|
|---|
| 932 | return $rtnVal;
|
|---|
| 933 | }
|
|---|
| 934 | }
|
|---|
| 935 | # save the handler type for this track
|
|---|
| 936 | if ($tag eq 'hdlr' and length $buff >= 12) {
|
|---|
| 937 | my $hdlr = substr($buff,8,4);
|
|---|
| 938 | $$et{HandlerType} = $hdlr if $hdlr =~ /^(vide|soun)$/;
|
|---|
| 939 | }
|
|---|
| 940 |
|
|---|
| 941 | # if this atom stores offsets, save its location so we can fix up offsets later
|
|---|
| 942 | # (are there any other atoms that may store absolute file offsets?)
|
|---|
| 943 | if ($tag =~ /^(stco|co64|iloc|mfra|moof|sidx|saio|gps |CTBO|uuid)$/) {
|
|---|
| 944 | # (note that we only need to do this if the media data is stored in this file)
|
|---|
| 945 | my $flg = $$et{QtDataFlg};
|
|---|
| 946 | if ($tag eq 'mfra' or $tag eq 'moof') {
|
|---|
| 947 | $et->Error("Can't yet handle movie fragments when writing");
|
|---|
| 948 | return $rtnVal;
|
|---|
| 949 | } elsif ($tag eq 'sidx' or $tag eq 'saio') {
|
|---|
| 950 | $et->Error("Can't yet handle $tag box when writing");
|
|---|
| 951 | return $rtnVal;
|
|---|
| 952 | } elsif ($tag eq 'iloc') {
|
|---|
| 953 | Handle_iloc($et, $dirInfo, \$buff, $outfile) or $et->Error('Error parsing iloc atom');
|
|---|
| 954 | } elsif ($tag eq 'gps ') {
|
|---|
| 955 | # (only care about the 'gps ' box in 'moov')
|
|---|
| 956 | if ($$dirInfo{DirID} and $$dirInfo{DirID} eq 'moov' and length $buff > 8) {
|
|---|
| 957 | my $off = $$dirInfo{ChunkOffset};
|
|---|
| 958 | my $num = Get32u(\$buff, 4);
|
|---|
| 959 | $num = int((length($buff) - 8) / 8) if $num * 8 + 8 > length($buff);
|
|---|
| 960 | my $i;
|
|---|
| 961 | for ($i=0; $i<$num; ++$i) {
|
|---|
| 962 | push @$off, [ 'stco_gps ', length($$outfile) + length($hdr) + 8 + $i * 8, 4 ];
|
|---|
| 963 | }
|
|---|
| 964 | }
|
|---|
| 965 | } elsif ($tag eq 'CTBO' or $tag eq 'uuid') { # hack for updating CR3 CTBO offsets
|
|---|
| 966 | push @{$$dirInfo{ChunkOffset}}, [ $tag, length($$outfile), length($hdr) + $size ];
|
|---|
| 967 | } elsif (not $flg) {
|
|---|
| 968 | my $grp = $$et{CUR_WRITE_GROUP} || $parent;
|
|---|
| 969 | $et->Error("Can't locate data reference to update offsets for $grp");
|
|---|
| 970 | return $rtnVal;
|
|---|
| 971 | } elsif ($flg == 3) {
|
|---|
| 972 | $et->Error("Can't write files with mixed internal/external media data");
|
|---|
| 973 | return $rtnVal;
|
|---|
| 974 | } elsif ($flg == 1) {
|
|---|
| 975 | # must update offsets since the data is in this file
|
|---|
| 976 | push @{$$dirInfo{ChunkOffset}}, [ $tag, length($$outfile) + length($hdr), $size ];
|
|---|
| 977 | }
|
|---|
| 978 | }
|
|---|
| 979 |
|
|---|
| 980 | # rewrite this atom
|
|---|
| 981 | my $tagInfo = $et->GetTagInfo($tagTablePtr, $tag, \$buff);
|
|---|
| 982 |
|
|---|
| 983 | # call write hook if it exists
|
|---|
| 984 | &{$$tagInfo{WriteHook}}($buff,$et) if $tagInfo and $$tagInfo{WriteHook};
|
|---|
| 985 |
|
|---|
| 986 | # allow numerical tag ID's (ItemList entries defined by Keys)
|
|---|
| 987 | if (not $tagInfo and $dirName eq 'ItemList' and $$et{Keys}) {
|
|---|
| 988 | $keysIndex = unpack('N', $tag);
|
|---|
| 989 | my $newIndex = $$et{Keys}{Remap}{$keysIndex};
|
|---|
| 990 | if (defined $newIndex) {
|
|---|
| 991 | $tagInfo = $$et{Keys}{Info}{$keysIndex};
|
|---|
| 992 | unless ($newIndex) {
|
|---|
| 993 | if ($tagInfo) {
|
|---|
| 994 | $et->VPrint(1," - Keys:$$tagInfo{Name}");
|
|---|
| 995 | } else {
|
|---|
| 996 | $delCount = ($delCount || 0) + 1;
|
|---|
| 997 | }
|
|---|
| 998 | ++$$et{CHANGED};
|
|---|
| 999 | next;
|
|---|
| 1000 | }
|
|---|
| 1001 | # use the new Keys index of this item if it changed
|
|---|
| 1002 | unless ($keysIndex == $newIndex) {
|
|---|
| 1003 | $tag = Set32u($newIndex);
|
|---|
| 1004 | substr($hdr, 4, 4) = $tag;
|
|---|
| 1005 | }
|
|---|
| 1006 | } else {
|
|---|
| 1007 | undef $keysIndex;
|
|---|
| 1008 | }
|
|---|
| 1009 | }
|
|---|
| 1010 | # delete all ItemList tags when deleting group, but take care not to delete UserData Meta
|
|---|
| 1011 | if ($delGrp) {
|
|---|
| 1012 | if ($dirName eq 'ItemList') {
|
|---|
| 1013 | $delCount = ($delCount || 0) + 1;
|
|---|
| 1014 | ++$$et{CHANGED};
|
|---|
| 1015 | next;
|
|---|
| 1016 | } elsif ($dirName eq 'UserData' and (not $tagInfo or not $$tagInfo{SubDirectory})) {
|
|---|
| 1017 | $delCount = ($delCount || 0) + 1;
|
|---|
| 1018 | ++$$et{CHANGED};
|
|---|
| 1019 | next;
|
|---|
| 1020 | }
|
|---|
| 1021 | }
|
|---|
| 1022 | undef $tagInfo if $tagInfo and $$tagInfo{Unknown};
|
|---|
| 1023 |
|
|---|
| 1024 | if ($tagInfo and (not defined $$tagInfo{Writable} or $$tagInfo{Writable})) {
|
|---|
| 1025 | my $subdir = $$tagInfo{SubDirectory};
|
|---|
| 1026 | my ($newData, @chunkOffset);
|
|---|
| 1027 |
|
|---|
| 1028 | if ($subdir) { # process atoms in this container from a buffer in memory
|
|---|
| 1029 |
|
|---|
| 1030 | undef $$et{HandlerType} if $tag eq 'trak'; # init handler type for this track
|
|---|
| 1031 |
|
|---|
| 1032 | my $subName = $$subdir{DirName} || $$tagInfo{Name};
|
|---|
| 1033 | my $start = $$subdir{Start} || 0;
|
|---|
| 1034 | my $base = ($$dirInfo{Base} || 0) + $raf->Tell() - $size;
|
|---|
| 1035 | my $dPos = 0;
|
|---|
| 1036 | my $hdrLen = $start;
|
|---|
| 1037 | if ($$subdir{Base}) {
|
|---|
| 1038 | my $localBase = eval $$subdir{Base};
|
|---|
| 1039 | $dPos -= $localBase;
|
|---|
| 1040 | $base -= $dPos;
|
|---|
| 1041 | # get length of header before base offset
|
|---|
| 1042 | $hdrLen -= $localBase if $localBase <= $hdrLen;
|
|---|
| 1043 | }
|
|---|
| 1044 | my %subdirInfo = (
|
|---|
| 1045 | Parent => $dirName,
|
|---|
| 1046 | DirName => $subName,
|
|---|
| 1047 | Name => $$tagInfo{Name},
|
|---|
| 1048 | DirID => $tag,
|
|---|
| 1049 | DataPt => \$buff,
|
|---|
| 1050 | DataLen => $size,
|
|---|
| 1051 | DataPos => $dPos,
|
|---|
| 1052 | DirStart => $start,
|
|---|
| 1053 | DirLen => $size - $start,
|
|---|
| 1054 | Base => $base,
|
|---|
| 1055 | HasData => $$subdir{HasData},
|
|---|
| 1056 | Multi => $$subdir{Multi}, # necessary?
|
|---|
| 1057 | OutFile => $outfile,
|
|---|
| 1058 | NoRefTest=> 1, # don't check directory references
|
|---|
| 1059 | WriteGroup => $$tagInfo{WriteGroup},
|
|---|
| 1060 | # initialize array to hold details about chunk offset table
|
|---|
| 1061 | # (each entry has 3-5 items: 0=atom type, 1=table offset, 2=table size,
|
|---|
| 1062 | # 3=optional base offset, 4=optional item ID)
|
|---|
| 1063 | ChunkOffset => \@chunkOffset,
|
|---|
| 1064 | );
|
|---|
| 1065 | # pass the header pointer if necessary (for EXIF IFD's
|
|---|
| 1066 | # where the Base offset is at the end of the header)
|
|---|
| 1067 | if ($hdrLen and $hdrLen < $size) {
|
|---|
| 1068 | my $header = substr($buff,0,$hdrLen);
|
|---|
| 1069 | $subdirInfo{HeaderPtr} = \$header;
|
|---|
| 1070 | }
|
|---|
| 1071 | SetByteOrder('II') if $$subdir{ByteOrder} and $$subdir{ByteOrder} =~ /^Little/;
|
|---|
| 1072 | my $oldWriteGroup = $$et{CUR_WRITE_GROUP};
|
|---|
| 1073 | if ($subName eq 'Track') {
|
|---|
| 1074 | $track or $track = 0;
|
|---|
| 1075 | $$et{CUR_WRITE_GROUP} = 'Track' . (++$track);
|
|---|
| 1076 | }
|
|---|
| 1077 | my $subTable = GetTagTable($$subdir{TagTable});
|
|---|
| 1078 | # demote non-QuickTime errors to warnings
|
|---|
| 1079 | $$et{DemoteErrors} = 1 unless $$subTable{GROUPS}{0} eq 'QuickTime';
|
|---|
| 1080 | my $oldChanged = $$et{CHANGED};
|
|---|
| 1081 | $newData = $et->WriteDirectory(\%subdirInfo, $subTable, $$subdir{WriteProc});
|
|---|
| 1082 | if ($$et{DemoteErrors}) {
|
|---|
| 1083 | # just copy existing subdirectory if a non-quicktime error occurred
|
|---|
| 1084 | $$et{CHANGED} = $oldChanged if $$et{DemoteErrors} > 1;
|
|---|
| 1085 | delete $$et{DemoteErrors};
|
|---|
| 1086 | }
|
|---|
| 1087 | if (defined $newData and not length $newData and $$tagTablePtr{PERMANENT}) {
|
|---|
| 1088 | # do nothing if trying to delete tag from a PERMANENT table
|
|---|
| 1089 | $$et{CHANGED} = $oldChanged;
|
|---|
| 1090 | undef $newData;
|
|---|
| 1091 | }
|
|---|
| 1092 | $$et{CUR_WRITE_GROUP} = $oldWriteGroup;
|
|---|
| 1093 | SetByteOrder('MM');
|
|---|
| 1094 | # add back header if necessary
|
|---|
| 1095 | if ($start and defined $newData and length $newData) {
|
|---|
| 1096 | $newData = substr($buff,0,$start) . $newData;
|
|---|
| 1097 | $$_[1] += $start foreach @chunkOffset;
|
|---|
| 1098 | }
|
|---|
| 1099 | # the directory exists, so we don't need to add it
|
|---|
| 1100 | if ($curPath eq $writePath and $$addDirs{$subName} and $$addDirs{$subName} eq $dirName) {
|
|---|
| 1101 | delete $$addDirs{$subName};
|
|---|
| 1102 | }
|
|---|
| 1103 | $didDir{$tag} = 1; # (note: keyed by tag ID)
|
|---|
| 1104 |
|
|---|
| 1105 | } else { # modify existing QuickTime tags in various formats
|
|---|
| 1106 |
|
|---|
| 1107 | my $nvHash = $et->GetNewValueHash($tagInfo);
|
|---|
| 1108 | if ($nvHash or $langTags{$tag} or $delGrp) {
|
|---|
| 1109 | my $nvHashNoLang = $nvHash;
|
|---|
| 1110 | my ($val, $len, $lang, $type, $flags, $ctry, $charsetQuickTime);
|
|---|
| 1111 | my $format = $$tagInfo{Format};
|
|---|
| 1112 | my $hasData = ($$dirInfo{HasData} and $buff =~ /\0...data\0/s);
|
|---|
| 1113 | my $langInfo = $tagInfo;
|
|---|
| 1114 | if ($hasData) {
|
|---|
| 1115 | my $pos = 0;
|
|---|
| 1116 | for (;;$pos+=$len) {
|
|---|
| 1117 | if ($pos + 16 > $size) {
|
|---|
| 1118 | # add any new alternate language tags now
|
|---|
| 1119 | if ($langTags{$tag}) {
|
|---|
| 1120 | my $tg;
|
|---|
| 1121 | foreach $tg ('', sort keys %{$langTags{$tag}}) {
|
|---|
| 1122 | my $ti = $tg ? $langTags{$tag}{$tg} : $nvHashNoLang;
|
|---|
| 1123 | $nvHash = $et->GetNewValueHash($ti);
|
|---|
| 1124 | next unless $nvHash and not $$didTag{$nvHash};
|
|---|
| 1125 | $$didTag{$nvHash} = 1;
|
|---|
| 1126 | next unless $$nvHash{IsCreating} and $et->IsOverwriting($nvHash);
|
|---|
| 1127 | my $newVal = $et->GetNewValue($nvHash);
|
|---|
| 1128 | next unless defined $newVal;
|
|---|
| 1129 | my $prVal = $newVal;
|
|---|
| 1130 | my $flags = FormatQTValue($et, \$newVal, $format, $$tagInfo{Writable});
|
|---|
| 1131 | next unless defined $newVal;
|
|---|
| 1132 | my ($ctry, $lang) = (0, 0);
|
|---|
| 1133 | if ($$ti{LangCode}) {
|
|---|
| 1134 | unless ($$ti{LangCode} =~ /^([A-Z]{3})?[-_]?([A-Z]{2})?$/i) {
|
|---|
| 1135 | $et->Warn("Invalid language code for $$ti{Name}");
|
|---|
| 1136 | next;
|
|---|
| 1137 | }
|
|---|
| 1138 | # pack language and country codes
|
|---|
| 1139 | if ($1 and $1 ne 'und') {
|
|---|
| 1140 | $lang = ($lang << 5) | ($_ - 0x60) foreach unpack 'C*', lc($1);
|
|---|
| 1141 | }
|
|---|
| 1142 | $ctry = unpack('n', pack('a2',uc($2))) if $2 and $2 ne 'ZZ';
|
|---|
| 1143 | }
|
|---|
| 1144 | $newData = substr($buff, 0, $pos) unless defined $newData;
|
|---|
| 1145 | $newData .= pack('Na4Nnn',16+length($newVal),'data',$flags,$ctry,$lang).$newVal;
|
|---|
| 1146 | my $grp = $et->GetGroup($ti, 1);
|
|---|
| 1147 | $et->VerboseValue("+ $grp:$$ti{Name}", $prVal);
|
|---|
| 1148 | ++$$et{CHANGED};
|
|---|
| 1149 | }
|
|---|
| 1150 | }
|
|---|
| 1151 | last;
|
|---|
| 1152 | }
|
|---|
| 1153 | ($len, $type, $flags, $ctry, $lang) = unpack("x${pos}Na4Nnn", $buff);
|
|---|
| 1154 | $lang or $lang = $undLang; # treat both 0 and 'und' as 'und'
|
|---|
| 1155 | $langInfo = $tagInfo;
|
|---|
| 1156 | my $delTag = $delGrp;
|
|---|
| 1157 | my $newVal;
|
|---|
| 1158 | my $langCode = GetLangCode($lang, $ctry, 1);
|
|---|
| 1159 | for (;;) {
|
|---|
| 1160 | $langInfo = GetLangInfo($tagInfo, $langCode);
|
|---|
| 1161 | $nvHash = $et->GetNewValueHash($langInfo);
|
|---|
| 1162 | last if $nvHash or not $ctry or $lang ne $undLang or length($langCode)==2;
|
|---|
| 1163 | # check to see if tag was written with a 2-char country code only
|
|---|
| 1164 | $langCode = lc unpack('a2',pack('n',$ctry));
|
|---|
| 1165 | }
|
|---|
| 1166 | # set flag to delete language tag when writing default
|
|---|
| 1167 | # (except for a default-language Keys entry)
|
|---|
| 1168 | if (not $nvHash and $nvHashNoLang) {
|
|---|
| 1169 | if ($lang eq $undLang and not $ctry and not $$didTag{$nvHashNoLang}) {
|
|---|
| 1170 | $nvHash = $nvHashNoLang; # write existing default
|
|---|
| 1171 | } else {
|
|---|
| 1172 | $delTag = 1; # delete tag
|
|---|
| 1173 | }
|
|---|
| 1174 | }
|
|---|
| 1175 | last if $pos + $len > $size;
|
|---|
| 1176 | if ($type eq 'data' and $len >= 16) {
|
|---|
| 1177 | $pos += 16;
|
|---|
| 1178 | $len -= 16;
|
|---|
| 1179 | $val = substr($buff, $pos, $len);
|
|---|
| 1180 | # decode value (see QuickTime.pm for an explanation)
|
|---|
| 1181 | if ($stringEncoding{$flags}) {
|
|---|
| 1182 | $val = $et->Decode($val, $stringEncoding{$flags});
|
|---|
| 1183 | $val =~ s/\0$// unless $$tagInfo{Binary};
|
|---|
| 1184 | $flags = 0x01; # write all strings as UTF-8
|
|---|
| 1185 | } else {
|
|---|
| 1186 | if ($format) {
|
|---|
| 1187 | # update flags for the format we are writing
|
|---|
| 1188 | if ($$tagInfo{Writable} and $qtFormat{$$tagInfo{Writable}}) {
|
|---|
| 1189 | $flags = $qtFormat{$$tagInfo{Writable}};
|
|---|
| 1190 | } elsif ($qtFormat{$format}) {
|
|---|
| 1191 | $flags = $qtFormat{$format};
|
|---|
| 1192 | }
|
|---|
| 1193 | } else {
|
|---|
| 1194 | $format = QuickTimeFormat($flags, $len);
|
|---|
| 1195 | }
|
|---|
| 1196 | $val = ReadValue(\$val, 0, $format, $$tagInfo{Count}, $len) if $format;
|
|---|
| 1197 | }
|
|---|
| 1198 | if (($nvHash and $et->IsOverwriting($nvHash, $val)) or $delTag) {
|
|---|
| 1199 | $newVal = $et->GetNewValue($nvHash) if defined $nvHash;
|
|---|
| 1200 | if ($delTag or not defined $newVal or $$didTag{$nvHash}) {
|
|---|
| 1201 | # delete the tag
|
|---|
| 1202 | my $grp = $et->GetGroup($langInfo, 1);
|
|---|
| 1203 | $et->VerboseValue("- $grp:$$langInfo{Name}", $val);
|
|---|
| 1204 | # copy data up to start of this tag to delete this value
|
|---|
| 1205 | $newData = substr($buff, 0, $pos-16) unless defined $newData;
|
|---|
| 1206 | ++$$et{CHANGED};
|
|---|
| 1207 | next;
|
|---|
| 1208 | }
|
|---|
| 1209 | my $prVal = $newVal;
|
|---|
| 1210 | # format new value for writing (and get new flags)
|
|---|
| 1211 | $flags = FormatQTValue($et, \$newVal, $format, $$tagInfo{Writable});
|
|---|
| 1212 | my $grp = $et->GetGroup($langInfo, 1);
|
|---|
| 1213 | $et->VerboseValue("- $grp:$$langInfo{Name}", $val);
|
|---|
| 1214 | $et->VerboseValue("+ $grp:$$langInfo{Name}", $prVal);
|
|---|
| 1215 | $newData = substr($buff, 0, $pos-16) unless defined $newData;
|
|---|
| 1216 | my $wLang = $lang eq $undLang ? 0 : $lang;
|
|---|
| 1217 | $newData .= pack('Na4Nnn', length($newVal)+16, $type, $flags, $ctry, $wLang);
|
|---|
| 1218 | $newData .= $newVal;
|
|---|
| 1219 | ++$$et{CHANGED};
|
|---|
| 1220 | } elsif (defined $newData) {
|
|---|
| 1221 | $newData .= substr($buff, $pos-16, $len+16);
|
|---|
| 1222 | }
|
|---|
| 1223 | } elsif (defined $newData) {
|
|---|
| 1224 | $newData .= substr($buff, $pos, $len);
|
|---|
| 1225 | }
|
|---|
| 1226 | $$didTag{$nvHash} = 1 if $nvHash;
|
|---|
| 1227 | }
|
|---|
| 1228 | $newData .= substr($buff, $pos) if defined $newData and $pos < $size;
|
|---|
| 1229 | undef $val; # (already constructed $newData)
|
|---|
| 1230 | } elsif ($format) {
|
|---|
| 1231 | $val = ReadValue(\$buff, 0, $format, undef, $size);
|
|---|
| 1232 | } elsif (($tag =~ /^\xa9/ or $$tagInfo{IText}) and $size >= ($$tagInfo{IText} || 4)) {
|
|---|
| 1233 | if ($$tagInfo{IText} and $$tagInfo{IText} == 6) {
|
|---|
| 1234 | $lang = unpack('x4n', $buff);
|
|---|
| 1235 | $len = $size - 6;
|
|---|
| 1236 | $val = substr($buff, 6, $len);
|
|---|
| 1237 | } else {
|
|---|
| 1238 | ($len, $lang) = unpack('nn', $buff);
|
|---|
| 1239 | $len -= 4 if 4 + $len > $size; # (see QuickTime.pm for explanation)
|
|---|
| 1240 | $len = $size - 4 if $len > $size - 4 or $len < 0;
|
|---|
| 1241 | $val = substr($buff, 4, $len);
|
|---|
| 1242 | }
|
|---|
| 1243 | $lang or $lang = $undLang; # treat both 0 and 'und' as 'und'
|
|---|
| 1244 | if ($lang < 0x400 and $val !~ /^\xfe\xff/) {
|
|---|
| 1245 | $charsetQuickTime = $et->Options('CharsetQuickTime');
|
|---|
| 1246 | $val = $et->Decode($val, $charsetQuickTime);
|
|---|
| 1247 | } else {
|
|---|
| 1248 | my $enc = $val=~s/^\xfe\xff// ? 'UTF16' : 'UTF8';
|
|---|
| 1249 | $val = $et->Decode($val, $enc);
|
|---|
| 1250 | }
|
|---|
| 1251 | $val =~ s/\0+$//; # remove trailing nulls if they exist
|
|---|
| 1252 | my $langCode = UnpackLang($lang, 1);
|
|---|
| 1253 | $langInfo = GetLangInfo($tagInfo, $langCode);
|
|---|
| 1254 | $nvHash = $et->GetNewValueHash($langInfo);
|
|---|
| 1255 | if (not $nvHash and $nvHashNoLang) {
|
|---|
| 1256 | if ($lang eq $undLang and not $$didTag{$nvHashNoLang}) {
|
|---|
| 1257 | $nvHash = $nvHashNoLang;
|
|---|
| 1258 | } elsif ($canCreate) {
|
|---|
| 1259 | # delete other languages when writing default
|
|---|
| 1260 | my $grp = $et->GetGroup($langInfo, 1);
|
|---|
| 1261 | $et->VerboseValue("- $grp:$$langInfo{Name}", $val);
|
|---|
| 1262 | ++$$et{CHANGED};
|
|---|
| 1263 | next;
|
|---|
| 1264 | }
|
|---|
| 1265 | }
|
|---|
| 1266 | } else {
|
|---|
| 1267 | $val = $buff;
|
|---|
| 1268 | }
|
|---|
| 1269 | if ($nvHash and defined $val) {
|
|---|
| 1270 | if ($et->IsOverwriting($nvHash, $val)) {
|
|---|
| 1271 | $newData = $et->GetNewValue($nvHash);
|
|---|
| 1272 | $newData = '' unless defined $newData or $canCreate;
|
|---|
| 1273 | ++$$et{CHANGED};
|
|---|
| 1274 | my $grp = $et->GetGroup($langInfo, 1);
|
|---|
| 1275 | $et->VerboseValue("- $grp:$$langInfo{Name}", $val);
|
|---|
| 1276 | next unless defined $newData and not $$didTag{$nvHash};
|
|---|
| 1277 | $et->VerboseValue("+ $grp:$$langInfo{Name}", $newData);
|
|---|
| 1278 | # add back necessary header and encode as necessary
|
|---|
| 1279 | if (defined $lang) {
|
|---|
| 1280 | $newData = $et->Encode($newData, $lang < 0x400 ? $charsetQuickTime : 'UTF8');
|
|---|
| 1281 | my $wLang = $lang eq $undLang ? 0 : $lang;
|
|---|
| 1282 | if ($$tagInfo{IText} and $$tagInfo{IText} == 6) {
|
|---|
| 1283 | $newData = pack('Nn', 0, $wLang) . $newData . "\0";
|
|---|
| 1284 | } else {
|
|---|
| 1285 | $newData = pack('nn', length($newData), $wLang) . $newData;
|
|---|
| 1286 | }
|
|---|
| 1287 | } elsif (not $format or $format =~ /^string/ and
|
|---|
| 1288 | not $$tagInfo{Binary} and not $$tagInfo{ValueConv})
|
|---|
| 1289 | {
|
|---|
| 1290 | # write all strings as UTF-8
|
|---|
| 1291 | $newData = $et->Encode($newData, 'UTF8');
|
|---|
| 1292 | } elsif ($format and not $$tagInfo{Binary}) {
|
|---|
| 1293 | # format new value for writing
|
|---|
| 1294 | $newData = WriteValue($newData, $format);
|
|---|
| 1295 | }
|
|---|
| 1296 | }
|
|---|
| 1297 | $$didTag{$nvHash} = 1; # set flag so we don't add this tag again
|
|---|
| 1298 | }
|
|---|
| 1299 | }
|
|---|
| 1300 | }
|
|---|
| 1301 | # write the new atom if it was modified
|
|---|
| 1302 | if (defined $newData) {
|
|---|
| 1303 | my $len = length($newData) + 8;
|
|---|
| 1304 | $len > 0x7fffffff and $et->Error("$$tagInfo{Name} to large to write"), last;
|
|---|
| 1305 | # update size in ChunkOffset list for modified 'uuid' atom
|
|---|
| 1306 | $$dirInfo{ChunkOffset}[-1][2] = $len if $tag eq 'uuid';
|
|---|
| 1307 | next unless $len > 8; # don't write empty atom header
|
|---|
| 1308 | # maintain pointer to chunk offsets if necessary
|
|---|
| 1309 | if (@chunkOffset) {
|
|---|
| 1310 | $$_[1] += 8 + length $$outfile foreach @chunkOffset;
|
|---|
| 1311 | push @{$$dirInfo{ChunkOffset}}, @chunkOffset;
|
|---|
| 1312 | }
|
|---|
| 1313 | if ($$tagInfo{WriteLast}) {
|
|---|
| 1314 | $writeLast = ($writeLast || '') . Set32u($len) . $tag . $newData;
|
|---|
| 1315 | } else {
|
|---|
| 1316 | $boxPos{$tag} = [ length($$outfile), length($newData) + 8 ];
|
|---|
| 1317 | # write the updated directory with its atom header
|
|---|
| 1318 | Write($outfile, Set32u($len), $tag, $newData) or $rtnVal=$rtnErr, $err=1, last;
|
|---|
| 1319 | }
|
|---|
| 1320 | next;
|
|---|
| 1321 | }
|
|---|
| 1322 | }
|
|---|
| 1323 | # keep track of data references in this track
|
|---|
| 1324 | if ($tag eq 'dinf') {
|
|---|
| 1325 | $$et{QtDataRef} = [ ]; # initialize list of data references
|
|---|
| 1326 | } elsif ($parent eq 'DataInfo' and length($buff) >= 4) {
|
|---|
| 1327 | # save data reference type and version/flags
|
|---|
| 1328 | push @{$$et{QtDataRef}}, [ $tag, Get32u(\$buff,0) ];
|
|---|
| 1329 | } elsif ($tag eq 'stsd' and length($buff) >= 8) {
|
|---|
| 1330 | my $n = Get32u(\$buff, 4); # get number of sample descriptions in table
|
|---|
| 1331 | my ($pos, $flg) = (8, 0);
|
|---|
| 1332 | my ($i, $msg);
|
|---|
| 1333 | for ($i=0; $i<$n; ++$i) { # loop through sample descriptions
|
|---|
| 1334 | $pos + 16 <= length($buff) or $msg = 'Truncated sample table', last;
|
|---|
| 1335 | my $siz = Get32u(\$buff, $pos);
|
|---|
| 1336 | $pos + $siz <= length($buff) or $msg = 'Truncated sample table', last;
|
|---|
| 1337 | my $drefIdx = Get16u(\$buff, $pos + 14);
|
|---|
| 1338 | my $drefTbl = $$et{QtDataRef};
|
|---|
| 1339 | if (not $drefIdx) {
|
|---|
| 1340 | $flg |= 0x01; # in this file if data reference index is 0 (if like iloc)
|
|---|
| 1341 | } elsif ($drefTbl and $$drefTbl[$drefIdx-1]) {
|
|---|
| 1342 | my $dref = $$drefTbl[$drefIdx-1];
|
|---|
| 1343 | # $flg = 0x01-in this file, 0x02-in some other file
|
|---|
| 1344 | $flg |= ($$dref[1] == 1 and $$dref[0] ne 'rsrc') ? 0x01 : 0x02;
|
|---|
| 1345 | } else {
|
|---|
| 1346 | $msg = "No data reference for sample description $i";
|
|---|
| 1347 | last;
|
|---|
| 1348 | }
|
|---|
| 1349 | $pos += $siz;
|
|---|
| 1350 | }
|
|---|
| 1351 | if ($msg) {
|
|---|
| 1352 | my $grp = $$et{CUR_WRITE_GROUP} || $parent;
|
|---|
| 1353 | $et->Error("$msg for $grp");
|
|---|
| 1354 | return $rtnErr;
|
|---|
| 1355 | }
|
|---|
| 1356 | $$et{QtDataFlg} = $flg;
|
|---|
| 1357 | }
|
|---|
| 1358 | if ($tagInfo and $$tagInfo{WriteLast}) {
|
|---|
| 1359 | $writeLast = ($writeLast || '') . $hdr . $buff;
|
|---|
| 1360 | } else {
|
|---|
| 1361 | # save position of this box in the output buffer
|
|---|
| 1362 | $boxPos{$tag} = [ length($$outfile), length($hdr) + length($buff) ];
|
|---|
| 1363 | # copy the existing atom
|
|---|
| 1364 | Write($outfile, $hdr, $buff) or $rtnVal=$rtnErr, $err=1, last;
|
|---|
| 1365 | }
|
|---|
| 1366 | }
|
|---|
| 1367 | $et->VPrint(0, " [deleting $delCount $dirName tag".($delCount==1 ? '' : 's')."]\n") if $delCount;
|
|---|
| 1368 |
|
|---|
| 1369 | $createKeys &= ~0x01 unless $$addDirs{Keys}; # (Keys may have been written)
|
|---|
| 1370 |
|
|---|
| 1371 | # add new directories/tags at this level if necessary
|
|---|
| 1372 | if ($canCreate and (exists $$et{EDIT_DIRS}{$dirName} or $createKeys)) {
|
|---|
| 1373 | # get a hash of tagInfo references to add to this directory
|
|---|
| 1374 | my $dirs = $et->GetAddDirHash($tagTablePtr, $dirName);
|
|---|
| 1375 | # make sorted list of new tags to be added
|
|---|
| 1376 | my @addTags = sort(keys(%$dirs), keys %$newTags);
|
|---|
| 1377 | my ($tag, $index);
|
|---|
| 1378 | # add Keys tags if necessary
|
|---|
| 1379 | if ($createKeys) {
|
|---|
| 1380 | if ($curPath eq 'MOV-Movie') {
|
|---|
| 1381 | # add Meta for Keys if necessary
|
|---|
| 1382 | unless ($didDir{meta}) {
|
|---|
| 1383 | $$dirs{meta} = $Image::ExifTool::QuickTime::Movie{meta};
|
|---|
| 1384 | push @addTags, 'meta';
|
|---|
| 1385 | }
|
|---|
| 1386 | } elsif ($curPath eq 'MOV-Movie-Meta') {
|
|---|
| 1387 | # special case for Keys Meta -- reset directories and start again
|
|---|
| 1388 | undef @addTags;
|
|---|
| 1389 | $dirs = { };
|
|---|
| 1390 | foreach ('keys','ilst') {
|
|---|
| 1391 | next if $didDir{$_}; # don't add again
|
|---|
| 1392 | $$dirs{$_} = $Image::ExifTool::QuickTime::Meta{$_};
|
|---|
| 1393 | push @addTags, $_;
|
|---|
| 1394 | }
|
|---|
| 1395 | } elsif ($curPath eq 'MOV-Movie-Meta-ItemList' and $$et{Keys}) {
|
|---|
| 1396 | foreach $index (sort { $a <=> $b } keys %{$$et{Keys}{Add}}) {
|
|---|
| 1397 | my $id = Set32u($index);
|
|---|
| 1398 | $$newTags{$id} = $$et{Keys}{Add}{$index};
|
|---|
| 1399 | push @addTags, $id;
|
|---|
| 1400 | }
|
|---|
| 1401 | } else {
|
|---|
| 1402 | $dirs = $et->GetAddDirHash($tagTablePtr, $dirName);
|
|---|
| 1403 | push @addTags, sort keys %$dirs;
|
|---|
| 1404 | }
|
|---|
| 1405 | }
|
|---|
| 1406 | # (note that $tag may be a binary Keys index here)
|
|---|
| 1407 | foreach $tag (@addTags) {
|
|---|
| 1408 | my $tagInfo = $$dirs{$tag} || $$newTags{$tag};
|
|---|
| 1409 | next if defined $$tagInfo{CanCreate} and not $$tagInfo{CanCreate};
|
|---|
| 1410 | next if defined $$tagInfo{HandlerType} and
|
|---|
| 1411 | (not $$et{HandlerType} or $$et{HandlerType} ne $$tagInfo{HandlerType});
|
|---|
| 1412 | my $subdir = $$tagInfo{SubDirectory};
|
|---|
| 1413 | unless ($subdir) {
|
|---|
| 1414 | my $nvHash = $et->GetNewValueHash($tagInfo);
|
|---|
| 1415 | next unless $nvHash and not $$didTag{$nvHash};
|
|---|
| 1416 | next unless $$nvHash{IsCreating} and $et->IsOverwriting($nvHash);
|
|---|
| 1417 | my $newVal = $et->GetNewValue($nvHash);
|
|---|
| 1418 | next unless defined $newVal;
|
|---|
| 1419 | my $prVal = $newVal;
|
|---|
| 1420 | my $flags = FormatQTValue($et, \$newVal, $$tagInfo{Format}, $$tagInfo{Writable});
|
|---|
| 1421 | next unless defined $newVal;
|
|---|
| 1422 | my ($ctry, $lang) = (0, 0);
|
|---|
| 1423 | # handle alternate languages
|
|---|
| 1424 | if ($$tagInfo{LangCode}) {
|
|---|
| 1425 | $tag = substr($tag, 0, 4); # strip language code from tag ID
|
|---|
| 1426 | unless ($$tagInfo{LangCode} =~ /^([A-Z]{3})?[-_]?([A-Z]{2})?$/i) {
|
|---|
| 1427 | $et->Warn("Invalid language code for $$tagInfo{Name}");
|
|---|
| 1428 | next;
|
|---|
| 1429 | }
|
|---|
| 1430 | # pack language and country codes
|
|---|
| 1431 | if ($1 and $1 ne 'und') {
|
|---|
| 1432 | $lang = ($lang << 5) | ($_ - 0x60) foreach unpack 'C*', lc($1);
|
|---|
| 1433 | }
|
|---|
| 1434 | $ctry = unpack('n', pack('a2',uc($2))) if $2 and $2 ne 'ZZ';
|
|---|
| 1435 | }
|
|---|
| 1436 | if ($$dirInfo{HasData}) {
|
|---|
| 1437 | # add 'data' header
|
|---|
| 1438 | $newVal = pack('Na4Nnn',16+length($newVal),'data',$flags,$ctry,$lang).$newVal;
|
|---|
| 1439 | } elsif ($tag =~ /^\xa9/ or $$tagInfo{IText}) {
|
|---|
| 1440 | if ($ctry) {
|
|---|
| 1441 | my $grp = $et->GetGroup($tagInfo,1);
|
|---|
| 1442 | $et->Warn("Can't use country code for $grp:$$tagInfo{Name}");
|
|---|
| 1443 | next;
|
|---|
| 1444 | } elsif ($$tagInfo{IText} and $$tagInfo{IText} == 6) {
|
|---|
| 1445 | # add 6-byte langText header and trailing null
|
|---|
| 1446 | $newVal = pack('Nn',0,$lang) . $newVal . "\0";
|
|---|
| 1447 | } else {
|
|---|
| 1448 | # add IText header
|
|---|
| 1449 | $newVal = pack('nn',length($newVal),$lang) . $newVal;
|
|---|
| 1450 | }
|
|---|
| 1451 | } elsif ($ctry or $lang) {
|
|---|
| 1452 | my $grp = $et->GetGroup($tagInfo,1);
|
|---|
| 1453 | $et->Warn("Can't use language code for $grp:$$tagInfo{Name}");
|
|---|
| 1454 | next;
|
|---|
| 1455 | }
|
|---|
| 1456 | if ($$tagInfo{WriteLast}) {
|
|---|
| 1457 | $writeLast = ($writeLast || '') . Set32u(8+length($newVal)) . $tag . $newVal;
|
|---|
| 1458 | } else {
|
|---|
| 1459 | $boxPos{$tag} = [ length($$outfile), 8 + length($newVal) ];
|
|---|
| 1460 | Write($outfile, Set32u(8+length($newVal)), $tag, $newVal) or $rtnVal=$rtnErr, $err=1;
|
|---|
| 1461 | }
|
|---|
| 1462 | my $grp = $et->GetGroup($tagInfo, 1);
|
|---|
| 1463 | $et->VerboseValue("+ $grp:$$tagInfo{Name}", $prVal);
|
|---|
| 1464 | $$didTag{$nvHash} = 1;
|
|---|
| 1465 | ++$$et{CHANGED};
|
|---|
| 1466 | next;
|
|---|
| 1467 | }
|
|---|
| 1468 | my $subName = $$subdir{DirName} || $$tagInfo{Name};
|
|---|
| 1469 | # QuickTime hierarchy is complex, so check full directory path before adding
|
|---|
| 1470 | my $buff;
|
|---|
| 1471 | if ($createKeys and $curPath eq 'MOV-Movie' and $subName eq 'Meta') {
|
|---|
| 1472 | $et->VPrint(0, " Creating Meta with mdta Handler and Keys\n");
|
|---|
| 1473 | # init Meta box for Keys tags with mdta Handler and empty Keys+ItemList
|
|---|
| 1474 | $buff = "\0\0\0\x20hdlr\0\0\0\0\0\0\0\0mdta\0\0\0\0\0\0\0\0\0\0\0\0" .
|
|---|
| 1475 | "\0\0\0\x10keys\0\0\0\0\0\0\0\0" .
|
|---|
| 1476 | "\0\0\0\x08ilst";
|
|---|
| 1477 | } elsif ($createKeys and $curPath eq 'MOV-Movie-Meta') {
|
|---|
| 1478 | $buff = ($subName eq 'Keys' ? "\0\0\0\0\0\0\0\0" : '');
|
|---|
| 1479 | } elsif ($subName eq 'Meta' and $$et{OPTIONS}{QuickTimeHandler}) {
|
|---|
| 1480 | $et->VPrint(0, " Creating Meta with mdir Handler\n");
|
|---|
| 1481 | # init Meta box for ItemList tags with mdir Handler
|
|---|
| 1482 | $buff = "\0\0\0\x20hdlr\0\0\0\0\0\0\0\0mdir\0\0\0\0\0\0\0\0\0\0\0\0";
|
|---|
| 1483 | } else {
|
|---|
| 1484 | next unless $curPath eq $writePath and $$addDirs{$subName} and $$addDirs{$subName} eq $dirName;
|
|---|
| 1485 | $buff = ''; # write from scratch
|
|---|
| 1486 | }
|
|---|
| 1487 | my %subdirInfo = (
|
|---|
| 1488 | Parent => $dirName,
|
|---|
| 1489 | DirName => $subName,
|
|---|
| 1490 | DataPt => \$buff,
|
|---|
| 1491 | DirStart => 0,
|
|---|
| 1492 | HasData => $$subdir{HasData},
|
|---|
| 1493 | OutFile => $outfile,
|
|---|
| 1494 | ChunkOffset => [ ], # (just to be safe)
|
|---|
| 1495 | WriteGroup => $$tagInfo{WriteGroup},
|
|---|
| 1496 | );
|
|---|
| 1497 | my $subTable = GetTagTable($$subdir{TagTable});
|
|---|
| 1498 | my $newData = $et->WriteDirectory(\%subdirInfo, $subTable, $$subdir{WriteProc});
|
|---|
| 1499 | if ($newData and length($newData) <= 0x7ffffff7) {
|
|---|
| 1500 | my $prefix = '';
|
|---|
| 1501 | # add atom version or ID if necessary
|
|---|
| 1502 | if ($$subdir{Start}) {
|
|---|
| 1503 | if ($$subdir{Start} == 4) {
|
|---|
| 1504 | $prefix = "\0\0\0\0"; # a simple version number
|
|---|
| 1505 | } else {
|
|---|
| 1506 | # get UUID from Condition expression
|
|---|
| 1507 | my $cond = $$tagInfo{Condition};
|
|---|
| 1508 | $prefix = eval qq("$1") if $cond and $cond =~ m{=~\s*\/\^(.*)/};
|
|---|
| 1509 | length($prefix) == $$subdir{Start} or $et->Error('Internal UUID error');
|
|---|
| 1510 | }
|
|---|
| 1511 | }
|
|---|
| 1512 | my $newHdr = Set32u(8+length($newData)+length($prefix)) . $tag . $prefix;
|
|---|
| 1513 | if ($$tagInfo{WriteLast}) {
|
|---|
| 1514 | $writeLast = ($writeLast || '') . $newHdr . $newData;
|
|---|
| 1515 | } else {
|
|---|
| 1516 | if ($tag eq 'uuid') {
|
|---|
| 1517 | # add offset for new uuid (needed for CR3 CTBO offsets)
|
|---|
| 1518 | my $off = $$dirInfo{ChunkOffset};
|
|---|
| 1519 | push @$off, [ $tag, length($$outfile), length($newHdr) + length($newData) ];
|
|---|
| 1520 | }
|
|---|
| 1521 | $boxPos{$tag} = [ length($$outfile), length($newHdr) + length($newData) ];
|
|---|
| 1522 | Write($outfile, $newHdr, $newData) or $rtnVal=$rtnErr, $err=1;
|
|---|
| 1523 | }
|
|---|
| 1524 | }
|
|---|
| 1525 | # add only once (must delete _after_ call to WriteDirectory())
|
|---|
| 1526 | # (Keys is a special case, and will be removed after Meta is processed)
|
|---|
| 1527 | delete $$addDirs{$subName} unless $subName eq 'Keys';
|
|---|
| 1528 | }
|
|---|
| 1529 | }
|
|---|
| 1530 | # write HEIC metadata after top-level 'meta' box has been processed if editing this information
|
|---|
| 1531 | if ($curPath eq 'MOV-Meta' and $$et{EDIT_DIRS}{ItemInformation}) {
|
|---|
| 1532 | $$dirInfo{BoxPos} = \%boxPos;
|
|---|
| 1533 | my $mdatEdit = WriteItemInfo($et, $dirInfo, $outfile);
|
|---|
| 1534 | if ($mdatEdit) {
|
|---|
| 1535 | $et->Error('Multiple top-level Meta containers') if $$et{mdatEdit};
|
|---|
| 1536 | $$et{mdatEdit} = $mdatEdit;
|
|---|
| 1537 | }
|
|---|
| 1538 | }
|
|---|
| 1539 | # write out any necessary terminator
|
|---|
| 1540 | Write($outfile, $term) or $rtnVal=$rtnErr, $err=1 if $term and length $$outfile;
|
|---|
| 1541 |
|
|---|
| 1542 | # delete temporary Keys variables after Meta is processed
|
|---|
| 1543 | if ($dirName eq 'Meta') {
|
|---|
| 1544 | # delete any Meta box with no useful information (ie. only 'hdlr','keys','lang','ctry')
|
|---|
| 1545 | my $isEmpty = 1;
|
|---|
| 1546 | $emptyMeta{$_} or $isEmpty = 0, last foreach keys %boxPos;
|
|---|
| 1547 | if ($isEmpty) {
|
|---|
| 1548 | $et->VPrint(0,' Deleting ' . join('+', sort map { $emptyMeta{$_} } keys %boxPos)) if %boxPos;
|
|---|
| 1549 | $$outfile = '';
|
|---|
| 1550 | ++$$et{CHANGED};
|
|---|
| 1551 | }
|
|---|
| 1552 | if ($curPath eq 'MOV-Movie-Meta') {
|
|---|
| 1553 | delete $$addDirs{Keys}; # prevent creation of another Meta for Keys tags
|
|---|
| 1554 | delete $$et{Keys};
|
|---|
| 1555 | }
|
|---|
| 1556 | }
|
|---|
| 1557 |
|
|---|
| 1558 | # return now if writing subdirectory
|
|---|
| 1559 | if ($dataPt) {
|
|---|
| 1560 | $et->Error("Internal error: WriteLast not on top-level atom!\n") if $writeLast;
|
|---|
| 1561 | return $err ? undef : $$outfile;
|
|---|
| 1562 | }
|
|---|
| 1563 |
|
|---|
| 1564 | # issue minor error if we didn't find an 'mdat' atom
|
|---|
| 1565 | my $off = $$dirInfo{ChunkOffset};
|
|---|
| 1566 | if (not @mdat) {
|
|---|
| 1567 | foreach $co (@$off) {
|
|---|
| 1568 | next if $$co[0] eq 'uuid';
|
|---|
| 1569 | $et->Error('Media data referenced but not found');
|
|---|
| 1570 | return $rtnVal;
|
|---|
| 1571 | }
|
|---|
| 1572 | $et->Warn('No media data', 1);
|
|---|
| 1573 | }
|
|---|
| 1574 |
|
|---|
| 1575 | # edit mdat blocks as required
|
|---|
| 1576 | # (0=old pos [0 if creating], 1=old end [0 if creating], 2=new data ref or undef to delete,
|
|---|
| 1577 | # 3=new data item id)
|
|---|
| 1578 | if ($$et{mdatEdit}) {
|
|---|
| 1579 | @mdatEdit = @{$$et{mdatEdit}};
|
|---|
| 1580 | delete $$et{mdatEdit};
|
|---|
| 1581 | }
|
|---|
| 1582 | foreach $edit (@mdatEdit) {
|
|---|
| 1583 | my (@thisMdat, @newMdat, $changed);
|
|---|
| 1584 | foreach $mdat (@mdat) {
|
|---|
| 1585 | # keep track of all chunks for the mdat with this header
|
|---|
| 1586 | if (length $$mdat[2]) {
|
|---|
| 1587 | push @newMdat, @thisMdat;
|
|---|
| 1588 | undef @thisMdat;
|
|---|
| 1589 | }
|
|---|
| 1590 | push @thisMdat, $mdat;
|
|---|
| 1591 | # is this edit inside this mdat chunk?
|
|---|
| 1592 | # - $$edit[0] and $$edit[1] will both be zero if we are creating a new chunk
|
|---|
| 1593 | # - $$mdat[1] is zero if mdat runs to end of file
|
|---|
| 1594 | # - $$edit[0] == $$edit[1] == $$mdat[0] if reviving a deleted chunk
|
|---|
| 1595 | # - $$mdat[5] is defined if this was a newly added/edited chunk
|
|---|
| 1596 | next if defined $$mdat[5] or $changed; # don't replace a newly added chunk
|
|---|
| 1597 | if (not $$edit[0] or # (newly created chunk)
|
|---|
| 1598 | # (edit is inside chunk)
|
|---|
| 1599 | ((($$edit[0] < $$mdat[1] or not $$mdat[1]) and $$edit[1] > $$mdat[0]) or
|
|---|
| 1600 | # (edit inserted at start or end of chunk)
|
|---|
| 1601 | ($$edit[0] == $$edit[1] and ($$edit[0] == $$mdat[0] or $$edit[0] == $$mdat[1]))))
|
|---|
| 1602 | {
|
|---|
| 1603 | if (not $$edit[0]) {
|
|---|
| 1604 | $$edit[0] = $$edit[1] = $$mdat[0]; # insert at start of this mdat
|
|---|
| 1605 | } elsif ($$edit[0] < $$mdat[0] or ($$edit[1] > $$mdat[1] and $$mdat[1])) {
|
|---|
| 1606 | $et->Error('ItemInfo runs across mdat boundary');
|
|---|
| 1607 | return $rtnVal;
|
|---|
| 1608 | }
|
|---|
| 1609 | my $hdrChunk = $thisMdat[0];
|
|---|
| 1610 | $hdrChunk or $et->Error('Internal error finding mdat header'), return $rtnVal;
|
|---|
| 1611 | # calculate difference in mdat size
|
|---|
| 1612 | my $diff = ($$edit[2] ? length(${$$edit[2]}) : 0) - ($$edit[1] - $$edit[0]);
|
|---|
| 1613 | # edit size of mdat in header if necessary
|
|---|
| 1614 | if ($diff) {
|
|---|
| 1615 | if (length($$hdrChunk[2]) == 8) {
|
|---|
| 1616 | my $size = Get32u(\$$hdrChunk[2], 0) + $diff;
|
|---|
| 1617 | $size > 0xffffffff and $et->Error("Can't yet grow mdat across 4GB boundary"), return $rtnVal;
|
|---|
| 1618 | Set32u($size, \$$hdrChunk[2], 0);
|
|---|
| 1619 | } elsif (length($$hdrChunk[2]) == 16) {
|
|---|
| 1620 | my $size = Get64u(\$$hdrChunk[2], 8) + $diff;
|
|---|
| 1621 | Set64u($size, \$$hdrChunk[2], 8);
|
|---|
| 1622 | } else {
|
|---|
| 1623 | $et->Error('Internal error. Invalid mdat header');
|
|---|
| 1624 | return $rtnVal;
|
|---|
| 1625 | }
|
|---|
| 1626 | }
|
|---|
| 1627 | $changed = 1;
|
|---|
| 1628 | # remove the edited section of this chunk (if any) and replace with new data (if any)
|
|---|
| 1629 | if ($$edit[0] > $$mdat[0]) {
|
|---|
| 1630 | push @thisMdat, [ $$edit[0], $$edit[1], '', 0, $$edit[2], $$edit[3] ] if $$edit[2];
|
|---|
| 1631 | # add remaining data after edit (or empty stub in case it is referenced by an offset)
|
|---|
| 1632 | push @thisMdat, [ $$edit[1], $$mdat[1], '' ];
|
|---|
| 1633 | $$mdat[1] = $$edit[0]; # now ends at start of edit
|
|---|
| 1634 | } else {
|
|---|
| 1635 | if ($$edit[2]) {
|
|---|
| 1636 | # insert the new chunk before this chunk, moving the header to the new chunk
|
|---|
| 1637 | splice @thisMdat, -1, 0, [ $$edit[0],$$edit[1],$$mdat[2],0,$$edit[2],$$edit[3] ];
|
|---|
| 1638 | $$mdat[2] = ''; # (header was moved to new chunk)
|
|---|
| 1639 | # initialize ChunkOffset pointer if necessary
|
|---|
| 1640 | if ($$edit[3]) {
|
|---|
| 1641 | my $n = 0;
|
|---|
| 1642 | foreach $co (@$off) {
|
|---|
| 1643 | next unless defined $$co[4] and $$co[4] == $$edit[3];
|
|---|
| 1644 | ++$n;
|
|---|
| 1645 | if ($$co[0] eq 'stco_iloc') {
|
|---|
| 1646 | Set32u($$mdat[0], $outfile, $$co[1]);
|
|---|
| 1647 | } else {
|
|---|
| 1648 | Set64u($$mdat[0], $outfile, $$co[1]);
|
|---|
| 1649 | }
|
|---|
| 1650 | }
|
|---|
| 1651 | $n == 1 or $et->Error('Internal error updating chunk offsets');
|
|---|
| 1652 | }
|
|---|
| 1653 | }
|
|---|
| 1654 | $$mdat[0] = $$edit[1]; # remove old data
|
|---|
| 1655 | }
|
|---|
| 1656 | }
|
|---|
| 1657 | }
|
|---|
| 1658 | if ($changed) {
|
|---|
| 1659 | @mdat = ( @newMdat, @thisMdat );
|
|---|
| 1660 | ++$$et{CHANGED};
|
|---|
| 1661 | } else {
|
|---|
| 1662 | $et->Error('Internal error modifying mdat');
|
|---|
| 1663 | }
|
|---|
| 1664 | }
|
|---|
| 1665 |
|
|---|
| 1666 | # determine our new mdat positions
|
|---|
| 1667 | # (0=old pos, 1=old end, 2=mdat header, 3=new pos, 4=new data ref if changed, 5=new item ID)
|
|---|
| 1668 | my $pos = length $$outfile;
|
|---|
| 1669 | foreach $mdat (@mdat) {
|
|---|
| 1670 | $pos += length $$mdat[2];
|
|---|
| 1671 | $$mdat[3] = $pos;
|
|---|
| 1672 | $pos += $$mdat[4] ? length(${$$mdat[4]}) : $$mdat[1] - $$mdat[0];
|
|---|
| 1673 | }
|
|---|
| 1674 |
|
|---|
| 1675 | # fix up offsets for new mdat position(s) (and uuid positions in CR3 images)
|
|---|
| 1676 | foreach $co (@$off) {
|
|---|
| 1677 | my ($type, $ptr, $len, $base, $id) = @$co;
|
|---|
| 1678 | $base = 0 unless $base;
|
|---|
| 1679 | unless ($type =~ /^(stco|co64)_?(.*)$/) {
|
|---|
| 1680 | next if $type eq 'uuid';
|
|---|
| 1681 | $type eq 'CTBO' or $et->Error('Internal error fixing offsets'), last;
|
|---|
| 1682 | # update 'CTBO' item offsets/sizes in Canon CR3 images
|
|---|
| 1683 | $$co[2] > 12 or $et->Error('Invalid CTBO atom'), last;
|
|---|
| 1684 | @mdat or $et->Error('Missing CR3 image data'), last;
|
|---|
| 1685 | my $n = Get32u($outfile, $$co[1] + 8);
|
|---|
| 1686 | $$co[2] < $n * 20 + 12 and $et->Error('Truncated CTBO atom'), last;
|
|---|
| 1687 | my (%ctboOff, $i);
|
|---|
| 1688 | # determine uuid types, and build an offset lookup based on CTBO ID number
|
|---|
| 1689 | foreach (@$off) {
|
|---|
| 1690 | next unless $$_[0] eq 'uuid' and $$_[2] >= 24; # (ignore undersized and deleted uuid boxes)
|
|---|
| 1691 | my $pos = $$_[1];
|
|---|
| 1692 | next if $pos + 24 > length $$outfile; # (will happen for WriteLast uuid tags)
|
|---|
| 1693 | my $siz = Get32u($outfile, $pos); # get size of uuid atom
|
|---|
| 1694 | if ($siz == 1) { # check for extended (8-byte) size
|
|---|
| 1695 | next unless $$_[2] >= 32;
|
|---|
| 1696 | $pos += 8;
|
|---|
| 1697 | }
|
|---|
| 1698 | # get CTBO entry ID based on 16-byte UUID identifier
|
|---|
| 1699 | my $id = $ctboID{substr($$outfile, $pos+8, 16)};
|
|---|
| 1700 | $ctboOff{$id} = $_ if defined $id;
|
|---|
| 1701 | }
|
|---|
| 1702 | # calculate new offset for the first mdat (size of -1 indicates it didn't change)
|
|---|
| 1703 | $ctboOff{3} = [ 'mdat', $mdat[0][3] - length $mdat[0][2], -1 ];
|
|---|
| 1704 | for ($i=0; $i<$n; ++$i) {
|
|---|
| 1705 | my $pos = $$co[1] + 12 + $i * 20;
|
|---|
| 1706 | my $id = Get32u($outfile, $pos);
|
|---|
| 1707 | # ignore if size is zero unless we can add this entry
|
|---|
| 1708 | # (note: can't yet add/delete PreviewImage, but leave this possibility open)
|
|---|
| 1709 | next unless Get64u($outfile, $pos + 12) or $id == 1 or $id == 2;
|
|---|
| 1710 | if (not defined $ctboOff{$id}) {
|
|---|
| 1711 | $id==1 or $id==2 or $et->Error("Can't handle CR3 CTBO ID number $id"), last;
|
|---|
| 1712 | # XMP or PreviewImage was deleted -- set offset and size to zero
|
|---|
| 1713 | $ctboOff{$id} = [ 'uuid', 0, 0 ];
|
|---|
| 1714 | }
|
|---|
| 1715 | # update the new offset and size of this entry
|
|---|
| 1716 | Set64u($ctboOff{$id}[1], $outfile, $pos + 4);
|
|---|
| 1717 | Set64u($ctboOff{$id}[2], $outfile, $pos + 12) unless $ctboOff{$id}[2] < 0;
|
|---|
| 1718 | }
|
|---|
| 1719 | next;
|
|---|
| 1720 | }
|
|---|
| 1721 | my $siz = $1 eq 'co64' ? 8 : 4;
|
|---|
| 1722 | my ($n, $tag);
|
|---|
| 1723 | if ($2) { # is this an offset in an iloc or 'gps ' atom?
|
|---|
| 1724 | $n = 1;
|
|---|
| 1725 | $type = $1;
|
|---|
| 1726 | $tag = $2;
|
|---|
| 1727 | } else { # this is an stco or co84 atom
|
|---|
| 1728 | next if $len < 8;
|
|---|
| 1729 | $n = Get32u($outfile, $ptr + 4); # get number of entries in table
|
|---|
| 1730 | $ptr += 8;
|
|---|
| 1731 | $len -= 8;
|
|---|
| 1732 | $tag = $1;
|
|---|
| 1733 | }
|
|---|
| 1734 | my $end = $ptr + $n * $siz;
|
|---|
| 1735 | $end > $ptr + $len and $et->Error("Invalid $tag table"), return $rtnVal;
|
|---|
| 1736 | for (; $ptr<$end; $ptr+=$siz) {
|
|---|
| 1737 | my ($ok, $i);
|
|---|
| 1738 | my $val = $type eq 'co64' ? Get64u($outfile, $ptr) : Get32u($outfile, $ptr);
|
|---|
| 1739 | for ($i=0; $i<@mdat; ++$i) {
|
|---|
| 1740 | $mdat = $mdat[$i];
|
|---|
| 1741 | my $pos = $val + $base;
|
|---|
| 1742 | if (defined $$mdat[5]) { # is this chunk associated with an item we edited?
|
|---|
| 1743 | # set offset only for the corresponding new chunk
|
|---|
| 1744 | unless (defined $id and $id == $$mdat[5]) {
|
|---|
| 1745 | # could have pointed to empty chunk before inserted chunk
|
|---|
| 1746 | next unless $pos == $$mdat[0] and $$mdat[0] != $$mdat[1];
|
|---|
| 1747 | }
|
|---|
| 1748 | } else {
|
|---|
| 1749 | # (have seen $pos == $$mdat[1], which is a real PITA)
|
|---|
| 1750 | next unless $pos >= $$mdat[0] and ($pos <= $$mdat[1] or not $$mdat[1]);
|
|---|
| 1751 | # step to next chunk if contiguous and at the end of this one
|
|---|
| 1752 | next if $pos == $$mdat[1] and $i+1 < @mdat and $pos == $mdat[$i+1][0];
|
|---|
| 1753 | }
|
|---|
| 1754 | $val += $$mdat[3] - $$mdat[0];
|
|---|
| 1755 | if ($val < 0) {
|
|---|
| 1756 | $et->Error("Error fixing up $tag offset");
|
|---|
| 1757 | return $rtnVal;
|
|---|
| 1758 | }
|
|---|
| 1759 | if ($type eq 'co64') {
|
|---|
| 1760 | Set64u($val, $outfile, $ptr);
|
|---|
| 1761 | } elsif ($val <= 0xffffffff) {
|
|---|
| 1762 | Set32u($val, $outfile, $ptr);
|
|---|
| 1763 | } else {
|
|---|
| 1764 | $et->Error("Can't yet promote $tag offset to 64 bits");
|
|---|
| 1765 | return $rtnVal;
|
|---|
| 1766 | }
|
|---|
| 1767 | $ok = 1;
|
|---|
| 1768 | last;
|
|---|
| 1769 | }
|
|---|
| 1770 | unless ($ok) {
|
|---|
| 1771 | $et->Error("Chunk offset in $tag atom is outside media data");
|
|---|
| 1772 | return $rtnVal;
|
|---|
| 1773 | }
|
|---|
| 1774 | }
|
|---|
| 1775 | }
|
|---|
| 1776 |
|
|---|
| 1777 | # switch back to actual output file
|
|---|
| 1778 | $outfile = $$dirInfo{OutFile};
|
|---|
| 1779 |
|
|---|
| 1780 | # write the metadata
|
|---|
| 1781 | Write($outfile, $outBuff) or $rtnVal = 0;
|
|---|
| 1782 |
|
|---|
| 1783 | # write the media data
|
|---|
| 1784 | foreach $mdat (@mdat) {
|
|---|
| 1785 | Write($outfile, $$mdat[2]) or $rtnVal = 0; # write mdat header
|
|---|
| 1786 | if ($$mdat[4]) {
|
|---|
| 1787 | Write($outfile, ${$$mdat[4]}) or $rtnVal = 0;
|
|---|
| 1788 | } else {
|
|---|
| 1789 | $raf->Seek($$mdat[0], 0) or $et->Error('Seek error'), last;
|
|---|
| 1790 | if ($$mdat[1]) {
|
|---|
| 1791 | my $result = Image::ExifTool::CopyBlock($raf, $outfile, $$mdat[1] - $$mdat[0]);
|
|---|
| 1792 | defined $result or $rtnVal = 0, last;
|
|---|
| 1793 | $result or $et->Error("Truncated mdat atom"), last;
|
|---|
| 1794 | } else {
|
|---|
| 1795 | # mdat continues to end of file
|
|---|
| 1796 | my $buff;
|
|---|
| 1797 | while ($raf->Read($buff, 65536)) {
|
|---|
| 1798 | Write($outfile, $buff) or $rtnVal = 0, last;
|
|---|
| 1799 | }
|
|---|
| 1800 | }
|
|---|
| 1801 | }
|
|---|
| 1802 | }
|
|---|
| 1803 |
|
|---|
| 1804 | # write the stuff that must come last
|
|---|
| 1805 | Write($outfile, $writeLast) or $rtnVal = 0 if $writeLast;
|
|---|
| 1806 |
|
|---|
| 1807 | return $rtnVal;
|
|---|
| 1808 | }
|
|---|
| 1809 |
|
|---|
| 1810 | #------------------------------------------------------------------------------
|
|---|
| 1811 | # Write QuickTime-format MOV/MP4 file
|
|---|
| 1812 | # Inputs: 0) ExifTool ref, 1) dirInfo ref
|
|---|
| 1813 | # Returns: 1 on success, 0 if this wasn't a valid QuickTime file,
|
|---|
| 1814 | # or -1 if a write error occurred
|
|---|
| 1815 | sub WriteMOV($$)
|
|---|
| 1816 | {
|
|---|
| 1817 | my ($et, $dirInfo) = @_;
|
|---|
| 1818 | $et or return 1; # allow dummy access to autoload this package
|
|---|
| 1819 | my $raf = $$dirInfo{RAF} or return 0;
|
|---|
| 1820 | my ($buff, $ftype);
|
|---|
| 1821 |
|
|---|
| 1822 | # read the first atom header
|
|---|
| 1823 | return 0 unless $raf->Read($buff, 8) == 8;
|
|---|
| 1824 | my ($size, $tag) = unpack('Na4', $buff);
|
|---|
| 1825 | return 0 if $size < 8 and $size != 1;
|
|---|
| 1826 |
|
|---|
| 1827 | # validate the file format
|
|---|
| 1828 | my $tagTablePtr = GetTagTable('Image::ExifTool::QuickTime::Main');
|
|---|
| 1829 | return 0 unless $$tagTablePtr{$tag};
|
|---|
| 1830 |
|
|---|
| 1831 | # determine the file type (by default, assume MP4 if 'ftyp' exists
|
|---|
| 1832 | # without 'qt ' as a compatible brand, but HEIC is an exception)
|
|---|
| 1833 | if ($tag eq 'ftyp' and $size >= 12 and $size < 100000 and
|
|---|
| 1834 | $raf->Read($buff, $size-8) == $size-8 and
|
|---|
| 1835 | $buff !~ /^(....)+(qt )/s)
|
|---|
| 1836 | {
|
|---|
| 1837 | if ($buff =~ /^crx /) {
|
|---|
| 1838 | $ftype = 'CR3',
|
|---|
| 1839 | } elsif ($buff =~ /^(heic|mif1|msf1|heix|hevc|hevx|avif)/) {
|
|---|
| 1840 | $ftype = 'HEIC';
|
|---|
| 1841 | } else {
|
|---|
| 1842 | $ftype = 'MP4';
|
|---|
| 1843 | }
|
|---|
| 1844 | } else {
|
|---|
| 1845 | $ftype = 'MOV';
|
|---|
| 1846 | }
|
|---|
| 1847 | $et->SetFileType($ftype); # need to set "FileType" tag for a Condition
|
|---|
| 1848 | $et->InitWriteDirs($dirMap{$ftype}, 'XMP', 'QuickTime');
|
|---|
| 1849 | $$et{DirMap} = $dirMap{$ftype}; # need access to directory map when writing
|
|---|
| 1850 | # track tags globally to avoid creating multiple tags in the case of duplicate directories
|
|---|
| 1851 | $$et{DidTag} = { };
|
|---|
| 1852 | SetByteOrder('MM');
|
|---|
| 1853 | $raf->Seek(0,0);
|
|---|
| 1854 |
|
|---|
| 1855 | # write the file
|
|---|
| 1856 | $$dirInfo{Parent} = '';
|
|---|
| 1857 | $$dirInfo{DirName} = 'MOV';
|
|---|
| 1858 | $$dirInfo{ChunkOffset} = [ ]; # (just to be safe)
|
|---|
| 1859 | return WriteQuickTime($et, $dirInfo, $tagTablePtr) ? 1 : -1;
|
|---|
| 1860 | }
|
|---|
| 1861 |
|
|---|
| 1862 | 1; # end
|
|---|
| 1863 |
|
|---|
| 1864 | __END__
|
|---|
| 1865 |
|
|---|
| 1866 | =head1 NAME
|
|---|
| 1867 |
|
|---|
| 1868 | Image::ExifTool::WriteQuickTime.pl - Write XMP to QuickTime (MOV and MP4) files
|
|---|
| 1869 |
|
|---|
| 1870 | =head1 SYNOPSIS
|
|---|
| 1871 |
|
|---|
| 1872 | These routines are autoloaded by Image::ExifTool::QuickTime.
|
|---|
| 1873 |
|
|---|
| 1874 | =head1 DESCRIPTION
|
|---|
| 1875 |
|
|---|
| 1876 | This file contains routines used by ExifTool to write XMP metadata to
|
|---|
| 1877 | QuickTime-based file formats like MOV and MP4.
|
|---|
| 1878 |
|
|---|
| 1879 | =head1 AUTHOR
|
|---|
| 1880 |
|
|---|
| 1881 | Copyright 2003-2021, Phil Harvey (philharvey66 at gmail.com)
|
|---|
| 1882 |
|
|---|
| 1883 | This library is free software; you can redistribute it and/or modify it
|
|---|
| 1884 | under the same terms as Perl itself.
|
|---|
| 1885 |
|
|---|
| 1886 | =head1 SEE ALSO
|
|---|
| 1887 |
|
|---|
| 1888 | L<Image::ExifTool::QuickTime(3pm)|Image::ExifTool::QuickTime>,
|
|---|
| 1889 | L<Image::ExifTool(3pm)|Image::ExifTool>
|
|---|
| 1890 |
|
|---|
| 1891 | =cut
|
|---|
