WriteQuickTime.pl 14 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358
  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. use strict;
  10. # map for adding directories to QuickTime-format files
  11. my %movMap = (
  12. # MOV (no 'ftyp', or 'ftyp'='qt ') -> 'moov'-'udta'-'XMP_'
  13. XMP => 'UserData',
  14. UserData => 'Movie',
  15. Movie => 'MOV',
  16. );
  17. my %mp4Map = (
  18. # MP4 ('ftyp' compatible brand 'mp41', 'mp42' or 'f4v ') -> top level 'uuid'
  19. XMP => 'MOV',
  20. );
  21. my %dirMap = (
  22. MOV => \%movMap,
  23. MP4 => \%mp4Map,
  24. );
  25. #------------------------------------------------------------------------------
  26. # Check to see if path is current
  27. # Inputs: 0) ExifTool object ref, 1) directory name
  28. # Returns: true if current path is the root of the specified directory
  29. sub IsCurPath($$)
  30. {
  31. local $_;
  32. my ($et, $dir) = @_;
  33. $dir = $$et{DirMap}{$dir} and $dir eq $_ or last foreach reverse @{$$et{PATH}};
  34. return($dir and $dir eq 'MOV');
  35. }
  36. #------------------------------------------------------------------------------
  37. # Write a series of QuickTime atoms from file or in memory
  38. # Inputs: 0) ExifTool ref, 1) dirInfo ref, 2) tag table ref
  39. # Returns: A) if dirInfo contains DataPt: new directory data
  40. # B) otherwise: true on success, 0 if a write error occurred
  41. # (true but sets an Error on a file format error)
  42. sub WriteQuickTime($$$)
  43. {
  44. my ($et, $dirInfo, $tagTablePtr) = @_;
  45. my ($foundMDAT, @hold, $track);
  46. my $outfile = $$dirInfo{OutFile} or return 0;
  47. my $raf = $$dirInfo{RAF};
  48. my $dataPt = $$dirInfo{DataPt};
  49. my $dirName = $$dirInfo{DirName};
  50. my $parent = $$dirInfo{Parent};
  51. my $addDirs = $$et{ADD_DIRS};
  52. my $rtnVal = 1;
  53. if ($dataPt) {
  54. $raf = new File::RandomAccess($dataPt);
  55. my $outBuff = '';
  56. $outfile = \$outBuff;
  57. } else {
  58. return 0 unless $raf;
  59. }
  60. for (;;) {
  61. my ($hdr, $buff);
  62. my $n = $raf->Read($hdr, 8);
  63. unless ($n == 8) {
  64. if ($n == 4 and $hdr eq "\0\0\0\0") {
  65. # "for historical reasons" the udta is optionally terminated by 4 zeros (ref 1)
  66. # --> hold this terminator to the end
  67. push @hold, $hdr;
  68. } elsif ($n != 0) {
  69. $et->Error('File format error');
  70. }
  71. last;
  72. }
  73. my ($size, $tag) = unpack('Na4', $hdr);
  74. if ($size >= 8) {
  75. $size -= 8;
  76. } elsif ($size == 1) {
  77. # read the extended size
  78. $raf->Read($buff, 8) == 8 or $et->Error('Truncated extended atom'), last;
  79. $hdr .= $buff;
  80. my ($hi, $lo) = unpack('NN', $buff);
  81. $size = $hi * 4294967296 + $lo - 16;
  82. $size < 0 and $et->Error('Invalid extended atom size'), last;
  83. } elsif (not $size and not $dataPt) {
  84. # size of zero is only valid for top-level atom, and
  85. # indicates the atom extends to the end of file
  86. if (not $raf->{FILE_PT}) {
  87. # get file size from image in memory
  88. $size = length ${$$raf{BUFF_PT}};
  89. } else {
  90. $size = -s $$raf{FILE_PT};
  91. }
  92. if ($size and ($size -= $raf->Tell()) >= 0 and $size <= 0x7fffffff) {
  93. Set32u($size + 8, \$hdr, 0);
  94. } elsif (@hold) {
  95. $et->Error("Sorry, can't yet add tags to this type of QuickTime file");
  96. return $rtnVal;
  97. } else {
  98. # blindly copy the rest of the file
  99. Write($outfile, $hdr) or $rtnVal = 0;
  100. while ($raf->Read($buff, 65536)) {
  101. Write($outfile, $buff) or $rtnVal = 0, last;
  102. }
  103. return $rtnVal;
  104. }
  105. } else {
  106. $et->Error('Invalid atom size');
  107. last;
  108. }
  109. # set flag if we have passed the 'mdat' atom
  110. $foundMDAT = 1 if $tag eq 'mdat';
  111. # rewrite this atom
  112. my $tagInfo = $et->GetTagInfo($tagTablePtr, $tag);
  113. if (defined $tagInfo and not $tagInfo) {
  114. my $n = $size < 256 ? $size : 256;
  115. unless ($raf->Read($buff, $n) == $n and $raf->Seek(-$n, 1)) {
  116. $et->Error("Read/seek error in $tag atom");
  117. last;
  118. }
  119. $tagInfo = $et->GetTagInfo($tagTablePtr, $tag, \$buff);
  120. }
  121. if ($tagInfo) {
  122. if ($$tagInfo{Unknown}) {
  123. undef $tagInfo;
  124. } elsif ($size > 100000000) {
  125. # limit maximum size of atom that we load into memory
  126. my $mb = $size / 0x100000;
  127. $et->Warn("Not editing metadata in $tag atom. $mb MB is too big");
  128. undef $tagInfo;
  129. }
  130. }
  131. if ($tagInfo) {
  132. # read the atom data
  133. $raf->Read($buff, $size) == $size or $et->Error("Error reading $tag data"), last;
  134. my $subdir = $$tagInfo{SubDirectory};
  135. my $newData;
  136. if ($subdir) {
  137. my $subName = $$subdir{DirName} || $$tagInfo{Name};
  138. my $start = $$subdir{Start} || 0;
  139. my $base = ($$dirInfo{Base} || 0) + $raf->Tell() - $size;
  140. my $dPos = 0;
  141. my $hdrLen = $start;
  142. if ($$subdir{Base}) {
  143. my $localBase = eval $$subdir{Base};
  144. $dPos -= $localBase;
  145. $base -= $dPos;
  146. # get length of header before base offset
  147. $hdrLen -= $localBase if $localBase <= $hdrLen;
  148. }
  149. my %subdirInfo = (
  150. Parent => $dirName,
  151. DirName => $subName,
  152. DataPt => \$buff,
  153. DataLen => $size,
  154. DataPos => $dPos,
  155. DirStart => $start,
  156. DirLen => $size - $start,
  157. Base => $base,
  158. HasData => $$subdir{HasData}, # necessary?
  159. Multi => $$subdir{Multi}, # necessary?
  160. OutFile => $outfile,
  161. );
  162. # pass the header pointer if necessary (for EXIF IFD's
  163. # where the Base offset is at the end of the header)
  164. if ($hdrLen and $hdrLen < $size) {
  165. my $header = substr($buff,0,$hdrLen);
  166. $subdirInfo{HeaderPtr} = \$header;
  167. }
  168. SetByteOrder('II') if $$subdir{ByteOrder} and $$subdir{ByteOrder} =~ /^Little/;
  169. my $oldWriteGroup = $$et{CUR_WRITE_GROUP};
  170. if ($subName eq 'Track') {
  171. $track or $track = 0;
  172. $$et{CUR_WRITE_GROUP} = 'Track' . (++$track);
  173. }
  174. my $subTable = GetTagTable($$subdir{TagTable});
  175. # demote non-QuickTime errors to warnings
  176. $$et{DemoteErrors} = 1 unless $$subTable{GROUPS}{0} eq 'QuickTime';
  177. my $oldChanged = $$et{CHANGED};
  178. $newData = $et->WriteDirectory(\%subdirInfo, $subTable);
  179. if ($$et{DemoteErrors}) {
  180. # just copy existing subdirectory a non-quicktime error occurred
  181. $$et{CHANGED} = $oldChanged if $$et{DemoteErrors} > 1;
  182. delete $$et{DemoteErrors};
  183. }
  184. undef $newData if $$et{CHANGED} == $oldChanged; # don't change unless necessary
  185. $$et{CUR_WRITE_GROUP} = $oldWriteGroup;
  186. SetByteOrder('MM');
  187. # add back header if necessary
  188. if ($start and defined $newData and length $newData) {
  189. $newData = substr($buff,0,$start) . $newData;
  190. }
  191. # the directory exists, so we don't need to add it
  192. delete $$addDirs{$subName} if IsCurPath($et, $subName);
  193. } else {
  194. # --> this is where individual QuickTime tags would be edited,
  195. # (this is such a can of worms, so don't implement this for now)
  196. }
  197. if (defined $newData) {
  198. my $len = length $newData;
  199. $len > 0x7ffffff7 and $et->Error("$tag to large to write"), last;
  200. if ($len == $size or $dataPt or $foundMDAT) {
  201. # write the updated directory now
  202. Write($outfile, Set32u($len+8), $tag, $newData) or $rtnVal = 0, last;
  203. next;
  204. } else {
  205. # bad things happen if 'mdat' atom is moved (eg. Adobe Bridge crashes --
  206. # there must be some absolute offsets somewhere that point into mdat),
  207. # so hold this atom and write it out later
  208. if ($len) {
  209. push @hold, Set32u($len+8), $tag, $newData;
  210. $et->VPrint(0," Moving '$tag' atom to after 'mdat'");
  211. } else {
  212. $et->VPrint(0," Freeing '$tag' atom (and zeroing data)");
  213. }
  214. # write a 'free' atom here to keep 'mdat' at the same offset
  215. substr($hdr, 4, 4) = 'free';
  216. $buff = "\0" x length($buff); # zero out old data
  217. }
  218. }
  219. # write out the existing atom (or 'free' padding)
  220. Write($outfile, $hdr, $buff) or $rtnVal = 0, last;
  221. } else {
  222. # write the unknown/large atom header
  223. Write($outfile, $hdr) or $rtnVal = 0, last;
  224. next unless $size;
  225. # copy the atom data
  226. my $result = Image::ExifTool::CopyBlock($raf, $outfile, $size);
  227. defined $result or $rtnVal = 0, last;
  228. $result or $et->Error("Truncated $tag atom"), last;
  229. }
  230. }
  231. # add new directories at this level if necessary
  232. if (exists $$et{EDIT_DIRS}{$dirName}) {
  233. # get a hash of tagInfo references to add to this directory
  234. my $dirs = $et->GetAddDirHash($tagTablePtr, $dirName);
  235. # make sorted list of new tags to be added
  236. my @addTags = sort keys(%$dirs);
  237. my $tag;
  238. foreach $tag (@addTags) {
  239. my $tagInfo = $$dirs{$tag};
  240. my $subdir = $$tagInfo{SubDirectory} or next;
  241. my $subName = $$subdir{DirName} || $$tagInfo{Name};
  242. # QuickTime hierarchy is complex, so check full directory path before adding
  243. next unless IsCurPath($et, $subName);
  244. delete $$addDirs{$subName}; # add only once
  245. my $buff = ''; # write from scratch
  246. my %subdirInfo = (
  247. Parent => $dirName,
  248. DirName => $subName,
  249. DataPt => \$buff,
  250. DirStart => 0,
  251. OutFile => $outfile,
  252. );
  253. my $subTable = GetTagTable($$subdir{TagTable});
  254. my $newData = $et->WriteDirectory(\%subdirInfo, $subTable);
  255. if ($newData and length($newData) <= 0x7ffffff7) {
  256. my $uuid = '';
  257. # add atom ID if necessary (obtain from Condition expression)
  258. if ($$subdir{Start}) {
  259. my $cond = $$tagInfo{Condition};
  260. $uuid = eval qq("$1") if $cond and $cond =~ m{=~\s*\/\^(.*)/};
  261. length($uuid) == $$subdir{Start} or $et->Error('Internal UUID error');
  262. }
  263. my $newHdr = Set32u(8+length($newData)+length($uuid)) . $tag . $uuid;
  264. Write($outfile, $newHdr, $newData) or $rtnVal = 0;
  265. }
  266. }
  267. }
  268. # write out any atoms that we are holding until the end
  269. Write($outfile, @hold) or $rtnVal = 0 if @hold;
  270. # issue minor error if we didn't find an 'mdat' atom
  271. # (we could duplicate atoms indefinitely through repeated editing if we
  272. # held back some atoms here, so in this case it isn't a minor error)
  273. $dataPt or $foundMDAT or $et->Error('No mdat atom found', @hold ? 0 : 1);
  274. return $dataPt ? ($rtnVal ? $$outfile : undef) : $rtnVal;
  275. }
  276. #------------------------------------------------------------------------------
  277. # Write QuickTime-format MOV/MP4 file
  278. # Inputs: 0) ExifTool ref, 1) dirInfo ref
  279. # Returns: 1 on success, 0 if this wasn't a valid QuickTime file,
  280. # or -1 if a write error occurred
  281. sub WriteMOV($$)
  282. {
  283. my ($et, $dirInfo) = @_;
  284. $et or return 1;
  285. my $raf = $$dirInfo{RAF} or return 0;
  286. my ($buff, $ftype);
  287. # read the first atom header
  288. return 0 unless $raf->Read($buff, 8) == 8;
  289. my ($size, $tag) = unpack('Na4', $buff);
  290. return 0 if $size < 8 and $size != 1;
  291. # validate the file format
  292. my $tagTablePtr = GetTagTable('Image::ExifTool::QuickTime::Main');
  293. return 0 unless $$tagTablePtr{$tag};
  294. # determine the file type
  295. if ($tag eq 'ftyp' and $size >= 12 and $size < 100000 and
  296. $raf->Read($buff, $size-8) == $size-8 and
  297. $buff !~ /^(....)+(qt )/s)
  298. {
  299. # file is MP4 format if 'ftyp' exists without 'qt ' as a compatible brand
  300. $ftype = 'MP4';
  301. } else {
  302. $ftype = 'MOV';
  303. }
  304. $et->SetFileType($ftype); # need to set "FileType" tag for a Condition
  305. $et->InitWriteDirs($dirMap{$ftype}, 'XMP');
  306. $$et{DirMap} = $dirMap{$ftype}; # need access to directory map when writing
  307. SetByteOrder('MM');
  308. $raf->Seek(0,0);
  309. # write the file
  310. $$dirInfo{Parent} = '';
  311. $$dirInfo{DirName} = 'MOV';
  312. return WriteQuickTime($et, $dirInfo, $tagTablePtr) ? 1 : -1;
  313. }
  314. 1; # end
  315. __END__
  316. =head1 NAME
  317. Image::ExifTool::WriteQuickTime.pl - Write XMP to QuickTime (MOV and MP4) files
  318. =head1 SYNOPSIS
  319. These routines are autoloaded by Image::ExifTool::QuickTime.
  320. =head1 DESCRIPTION
  321. This file contains routines used by ExifTool to write XMP metadata to
  322. QuickTime-based file formats like MOV and MP4.
  323. =head1 AUTHOR
  324. Copyright 2003-2016, Phil Harvey (phil at owl.phy.queensu.ca)
  325. This library is free software; you can redistribute it and/or modify it
  326. under the same terms as Perl itself.
  327. =head1 SEE ALSO
  328. L<Image::ExifTool::QuickTime(3pm)|Image::ExifTool::QuickTime>,
  329. L<Image::ExifTool(3pm)|Image::ExifTool>
  330. =cut