359 lines
14 KiB
Perl
359 lines
14 KiB
Perl
|
#------------------------------------------------------------------------------
|
||
|
|
# 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
|