123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358 |
- #------------------------------------------------------------------------------
- # File: WriteQuickTime.pl
- #
- # Description: Write XMP to QuickTime (MOV and MP4) files
- #
- # Revisions: 2013-10-29 - P. Harvey Created
- #------------------------------------------------------------------------------
- package Image::ExifTool::QuickTime;
- use strict;
- # map for adding directories to QuickTime-format files
- my %movMap = (
- # MOV (no 'ftyp', or 'ftyp'='qt ') -> 'moov'-'udta'-'XMP_'
- XMP => 'UserData',
- UserData => 'Movie',
- Movie => 'MOV',
- );
- my %mp4Map = (
- # MP4 ('ftyp' compatible brand 'mp41', 'mp42' or 'f4v ') -> top level 'uuid'
- XMP => 'MOV',
- );
- my %dirMap = (
- MOV => \%movMap,
- MP4 => \%mp4Map,
- );
- #------------------------------------------------------------------------------
- # Check to see if path is current
- # Inputs: 0) ExifTool object ref, 1) directory name
- # Returns: true if current path is the root of the specified directory
- sub IsCurPath($$)
- {
- local $_;
- my ($et, $dir) = @_;
- $dir = $$et{DirMap}{$dir} and $dir eq $_ or last foreach reverse @{$$et{PATH}};
- return($dir and $dir eq 'MOV');
- }
- #------------------------------------------------------------------------------
- # Write a series of QuickTime atoms from file or in memory
- # Inputs: 0) ExifTool ref, 1) dirInfo ref, 2) tag table ref
- # Returns: A) if dirInfo contains DataPt: new directory data
- # B) otherwise: true on success, 0 if a write error occurred
- # (true but sets an Error on a file format error)
- sub WriteQuickTime($$$)
- {
- my ($et, $dirInfo, $tagTablePtr) = @_;
- my ($foundMDAT, @hold, $track);
- my $outfile = $$dirInfo{OutFile} or return 0;
- my $raf = $$dirInfo{RAF};
- my $dataPt = $$dirInfo{DataPt};
- my $dirName = $$dirInfo{DirName};
- my $parent = $$dirInfo{Parent};
- my $addDirs = $$et{ADD_DIRS};
- my $rtnVal = 1;
- if ($dataPt) {
- $raf = new File::RandomAccess($dataPt);
- my $outBuff = '';
- $outfile = \$outBuff;
- } else {
- return 0 unless $raf;
- }
- for (;;) {
- my ($hdr, $buff);
- my $n = $raf->Read($hdr, 8);
- unless ($n == 8) {
- if ($n == 4 and $hdr eq "\0\0\0\0") {
- # "for historical reasons" the udta is optionally terminated by 4 zeros (ref 1)
- # --> hold this terminator to the end
- push @hold, $hdr;
- } elsif ($n != 0) {
- $et->Error('File format error');
- }
- last;
- }
- my ($size, $tag) = unpack('Na4', $hdr);
- if ($size >= 8) {
- $size -= 8;
- } elsif ($size == 1) {
- # read the extended size
- $raf->Read($buff, 8) == 8 or $et->Error('Truncated extended atom'), last;
- $hdr .= $buff;
- my ($hi, $lo) = unpack('NN', $buff);
- $size = $hi * 4294967296 + $lo - 16;
- $size < 0 and $et->Error('Invalid extended atom size'), last;
- } elsif (not $size and not $dataPt) {
- # size of zero is only valid for top-level atom, and
- # indicates the atom extends to the end of file
- if (not $raf->{FILE_PT}) {
- # get file size from image in memory
- $size = length ${$$raf{BUFF_PT}};
- } else {
- $size = -s $$raf{FILE_PT};
- }
- if ($size and ($size -= $raf->Tell()) >= 0 and $size <= 0x7fffffff) {
- Set32u($size + 8, \$hdr, 0);
- } elsif (@hold) {
- $et->Error("Sorry, can't yet add tags to this type of QuickTime file");
- return $rtnVal;
- } else {
- # blindly copy the rest of the file
- Write($outfile, $hdr) or $rtnVal = 0;
- while ($raf->Read($buff, 65536)) {
- Write($outfile, $buff) or $rtnVal = 0, last;
- }
- return $rtnVal;
- }
- } else {
- $et->Error('Invalid atom size');
- last;
- }
- # set flag if we have passed the 'mdat' atom
- $foundMDAT = 1 if $tag eq 'mdat';
- # rewrite this atom
- my $tagInfo = $et->GetTagInfo($tagTablePtr, $tag);
- if (defined $tagInfo and not $tagInfo) {
- my $n = $size < 256 ? $size : 256;
- unless ($raf->Read($buff, $n) == $n and $raf->Seek(-$n, 1)) {
- $et->Error("Read/seek error in $tag atom");
- last;
- }
- $tagInfo = $et->GetTagInfo($tagTablePtr, $tag, \$buff);
- }
- if ($tagInfo) {
- if ($$tagInfo{Unknown}) {
- undef $tagInfo;
- } elsif ($size > 100000000) {
- # limit maximum size of atom that we load into memory
- my $mb = $size / 0x100000;
- $et->Warn("Not editing metadata in $tag atom. $mb MB is too big");
- undef $tagInfo;
- }
- }
- if ($tagInfo) {
- # read the atom data
- $raf->Read($buff, $size) == $size or $et->Error("Error reading $tag data"), last;
- my $subdir = $$tagInfo{SubDirectory};
- my $newData;
- if ($subdir) {
- my $subName = $$subdir{DirName} || $$tagInfo{Name};
- my $start = $$subdir{Start} || 0;
- my $base = ($$dirInfo{Base} || 0) + $raf->Tell() - $size;
- my $dPos = 0;
- my $hdrLen = $start;
- if ($$subdir{Base}) {
- my $localBase = eval $$subdir{Base};
- $dPos -= $localBase;
- $base -= $dPos;
- # get length of header before base offset
- $hdrLen -= $localBase if $localBase <= $hdrLen;
- }
- my %subdirInfo = (
- Parent => $dirName,
- DirName => $subName,
- DataPt => \$buff,
- DataLen => $size,
- DataPos => $dPos,
- DirStart => $start,
- DirLen => $size - $start,
- Base => $base,
- HasData => $$subdir{HasData}, # necessary?
- Multi => $$subdir{Multi}, # necessary?
- OutFile => $outfile,
- );
- # pass the header pointer if necessary (for EXIF IFD's
- # where the Base offset is at the end of the header)
- if ($hdrLen and $hdrLen < $size) {
- my $header = substr($buff,0,$hdrLen);
- $subdirInfo{HeaderPtr} = \$header;
- }
- SetByteOrder('II') if $$subdir{ByteOrder} and $$subdir{ByteOrder} =~ /^Little/;
- my $oldWriteGroup = $$et{CUR_WRITE_GROUP};
- if ($subName eq 'Track') {
- $track or $track = 0;
- $$et{CUR_WRITE_GROUP} = 'Track' . (++$track);
- }
- my $subTable = GetTagTable($$subdir{TagTable});
- # demote non-QuickTime errors to warnings
- $$et{DemoteErrors} = 1 unless $$subTable{GROUPS}{0} eq 'QuickTime';
- my $oldChanged = $$et{CHANGED};
- $newData = $et->WriteDirectory(\%subdirInfo, $subTable);
- if ($$et{DemoteErrors}) {
- # just copy existing subdirectory a non-quicktime error occurred
- $$et{CHANGED} = $oldChanged if $$et{DemoteErrors} > 1;
- delete $$et{DemoteErrors};
- }
- undef $newData if $$et{CHANGED} == $oldChanged; # don't change unless necessary
- $$et{CUR_WRITE_GROUP} = $oldWriteGroup;
- SetByteOrder('MM');
- # add back header if necessary
- if ($start and defined $newData and length $newData) {
- $newData = substr($buff,0,$start) . $newData;
- }
- # the directory exists, so we don't need to add it
- delete $$addDirs{$subName} if IsCurPath($et, $subName);
- } else {
- # --> this is where individual QuickTime tags would be edited,
- # (this is such a can of worms, so don't implement this for now)
- }
- if (defined $newData) {
- my $len = length $newData;
- $len > 0x7ffffff7 and $et->Error("$tag to large to write"), last;
- if ($len == $size or $dataPt or $foundMDAT) {
- # write the updated directory now
- Write($outfile, Set32u($len+8), $tag, $newData) or $rtnVal = 0, last;
- next;
- } else {
- # bad things happen if 'mdat' atom is moved (eg. Adobe Bridge crashes --
- # there must be some absolute offsets somewhere that point into mdat),
- # so hold this atom and write it out later
- if ($len) {
- push @hold, Set32u($len+8), $tag, $newData;
- $et->VPrint(0," Moving '$tag' atom to after 'mdat'");
- } else {
- $et->VPrint(0," Freeing '$tag' atom (and zeroing data)");
- }
- # write a 'free' atom here to keep 'mdat' at the same offset
- substr($hdr, 4, 4) = 'free';
- $buff = "\0" x length($buff); # zero out old data
- }
- }
- # write out the existing atom (or 'free' padding)
- Write($outfile, $hdr, $buff) or $rtnVal = 0, last;
- } else {
- # write the unknown/large atom header
- Write($outfile, $hdr) or $rtnVal = 0, last;
- next unless $size;
- # copy the atom data
- my $result = Image::ExifTool::CopyBlock($raf, $outfile, $size);
- defined $result or $rtnVal = 0, last;
- $result or $et->Error("Truncated $tag atom"), last;
- }
- }
- # add new directories at this level if necessary
- if (exists $$et{EDIT_DIRS}{$dirName}) {
- # get a hash of tagInfo references to add to this directory
- my $dirs = $et->GetAddDirHash($tagTablePtr, $dirName);
- # make sorted list of new tags to be added
- my @addTags = sort keys(%$dirs);
- my $tag;
- foreach $tag (@addTags) {
- my $tagInfo = $$dirs{$tag};
- my $subdir = $$tagInfo{SubDirectory} or next;
- my $subName = $$subdir{DirName} || $$tagInfo{Name};
- # QuickTime hierarchy is complex, so check full directory path before adding
- next unless IsCurPath($et, $subName);
- delete $$addDirs{$subName}; # add only once
- my $buff = ''; # write from scratch
- my %subdirInfo = (
- Parent => $dirName,
- DirName => $subName,
- DataPt => \$buff,
- DirStart => 0,
- OutFile => $outfile,
- );
- my $subTable = GetTagTable($$subdir{TagTable});
- my $newData = $et->WriteDirectory(\%subdirInfo, $subTable);
- if ($newData and length($newData) <= 0x7ffffff7) {
- my $uuid = '';
- # add atom ID if necessary (obtain from Condition expression)
- if ($$subdir{Start}) {
- my $cond = $$tagInfo{Condition};
- $uuid = eval qq("$1") if $cond and $cond =~ m{=~\s*\/\^(.*)/};
- length($uuid) == $$subdir{Start} or $et->Error('Internal UUID error');
- }
- my $newHdr = Set32u(8+length($newData)+length($uuid)) . $tag . $uuid;
- Write($outfile, $newHdr, $newData) or $rtnVal = 0;
- }
- }
- }
- # write out any atoms that we are holding until the end
- Write($outfile, @hold) or $rtnVal = 0 if @hold;
- # issue minor error if we didn't find an 'mdat' atom
- # (we could duplicate atoms indefinitely through repeated editing if we
- # held back some atoms here, so in this case it isn't a minor error)
- $dataPt or $foundMDAT or $et->Error('No mdat atom found', @hold ? 0 : 1);
- return $dataPt ? ($rtnVal ? $$outfile : undef) : $rtnVal;
- }
- #------------------------------------------------------------------------------
- # Write QuickTime-format MOV/MP4 file
- # Inputs: 0) ExifTool ref, 1) dirInfo ref
- # Returns: 1 on success, 0 if this wasn't a valid QuickTime file,
- # or -1 if a write error occurred
- sub WriteMOV($$)
- {
- my ($et, $dirInfo) = @_;
- $et or return 1;
- my $raf = $$dirInfo{RAF} or return 0;
- my ($buff, $ftype);
- # read the first atom header
- return 0 unless $raf->Read($buff, 8) == 8;
- my ($size, $tag) = unpack('Na4', $buff);
- return 0 if $size < 8 and $size != 1;
- # validate the file format
- my $tagTablePtr = GetTagTable('Image::ExifTool::QuickTime::Main');
- return 0 unless $$tagTablePtr{$tag};
- # determine the file type
- if ($tag eq 'ftyp' and $size >= 12 and $size < 100000 and
- $raf->Read($buff, $size-8) == $size-8 and
- $buff !~ /^(....)+(qt )/s)
- {
- # file is MP4 format if 'ftyp' exists without 'qt ' as a compatible brand
- $ftype = 'MP4';
- } else {
- $ftype = 'MOV';
- }
- $et->SetFileType($ftype); # need to set "FileType" tag for a Condition
- $et->InitWriteDirs($dirMap{$ftype}, 'XMP');
- $$et{DirMap} = $dirMap{$ftype}; # need access to directory map when writing
- SetByteOrder('MM');
- $raf->Seek(0,0);
- # write the file
- $$dirInfo{Parent} = '';
- $$dirInfo{DirName} = 'MOV';
- return WriteQuickTime($et, $dirInfo, $tagTablePtr) ? 1 : -1;
- }
- 1; # end
- __END__
- =head1 NAME
- Image::ExifTool::WriteQuickTime.pl - Write XMP to QuickTime (MOV and MP4) files
- =head1 SYNOPSIS
- These routines are autoloaded by Image::ExifTool::QuickTime.
- =head1 DESCRIPTION
- This file contains routines used by ExifTool to write XMP metadata to
- QuickTime-based file formats like MOV and MP4.
- =head1 AUTHOR
- Copyright 2003-2016, Phil Harvey (phil at owl.phy.queensu.ca)
- This library is free software; you can redistribute it and/or modify it
- under the same terms as Perl itself.
- =head1 SEE ALSO
- L<Image::ExifTool::QuickTime(3pm)|Image::ExifTool::QuickTime>,
- L<Image::ExifTool(3pm)|Image::ExifTool>
- =cut
|