1# Copyright (C) 2009 Quentin Sculo <squentin@free.fr>
2#
3# This file is part of Gmusicbrowser.
4# Gmusicbrowser is free software; you can redistribute it and/or modify
5# it under the terms of the GNU General Public License version 3, as
6# published by the Free Software Foundation
7
8#based on :
9#http://atomicparsley.sourceforge.net/mpeg-4files.html
10#http://wiki.multimedia.cx/index.php?title=QuickTime_container
11#http://www.geocities.com/xhelmboyx/quicktime/formats/mp4-layout.txt
12#
13#blame Apple for the absence of official specs for metadata :(
14
15#usage :
16#my $tag=Tag::M4A->new($file);
17#if ($tag)
18#{	$tag->add(name => 'value');
19#	$tag->insert('org.gmusicbrowser----mytag' => 'mytagvalue');
20#	$tag->remove_all('disk');
21#	$tag->write_file;
22#}
23#
24# uses @Tag::MP3::Genres for numeric genres
25
26package Tag::M4A;
27use strict;
28use warnings;
29use Encode qw(decode encode);
30
31my %IsParent;
32INIT
33{ $IsParent{$_}=0 for qw/moov trak udta mdia minf stbl ilst moof traf/; # unused parent atoms : tref imap edts mdra rmra imag vnrp dinf
34  $IsParent{meta}=4;	#4 bytes version/flags = byte hex version + 24-bit hex flags  (current = 0)
35}
36
37sub new
38{	my ($class,$file)=@_;
39	my $self=bless {}, $class;
40
41	# check that the file exists
42	unless (-e $file)
43	{	warn "File '$file' does not exist.\n";
44	    return undef;
45	}
46	$self->{filename} = $file;
47	$self->_open or return undef;
48
49	$self->ParseAtomTree;
50	$self->_close;
51
52	unless ($self->{info} && $self->{ilst})
53	{	warn "error, can't read file or not a valid m4a file\n";
54		return undef;
55	}
56	return $self;
57}
58
59sub _open
60{	my $self=shift;
61	my $file=$self->{filename};
62	open my$fh,'<',$file or warn "can't open $file : $!\n" and return undef;
63	binmode $fh;
64	$self->{fileHandle} = $fh;
65	return $fh;
66}
67sub _openw
68{	my ($self,$tmp)=@_;
69	my $file=$self->{filename};
70	my $m='+<';
71	if ($tmp) {$file.='.TEMP';$m='>';}
72	my $fh;
73	until (open $fh,$m,$file)
74	{	my $err="Error opening '$file' for writing :\n$!";
75		warn $err."\n";
76		return undef unless $self->{errorsub} && $self->{errorsub}($!,'openwrite',$file) eq 'retry';
77	}
78	binmode $fh;
79	unless ($tmp)
80	{ $self->{fileHandle} = $fh;
81	}
82	return $fh;
83}
84sub _close
85{	my $self=shift;
86	close delete($self->{fileHandle});
87}
88
89sub edit
90{	my ($self,$key,$nb,$val)=@_;
91	$nb||=0;
92	my $aref=$self->{ilst}{$key};
93	return undef unless $aref &&  @$aref >=$nb;
94	my $old=$aref->[$nb];
95	$aref->[$nb]=$val;
96	return $old;
97}
98sub add
99{	my ($self,$key,$val)=@_;
100	$key=~s/^----/com.apple.iTunes----/;
101	push @{ $self->{ilst}{$key} },$val;
102	push @{$self->{ilst_order}}, $key;
103	return 1;
104}
105sub insert	#same as add but put it first (of its kind)
106{	my ($self,$key,$val)=@_;
107	$key=~s/^----/com.apple.iTunes----/;
108	unshift @{ $self->{ilst}{$key} },$val;
109	push @{$self->{ilst_order}}, $key;
110	return 1;
111}
112
113sub remove_all
114{	my ($self,$key)=@_;
115	return unless defined $key;
116	my $ilst=$self->{ilst};
117	my @arrays;
118	if ($key=~m/^(.*)----(.*)$/)
119	{	my $appid=$1;
120		my $subkey=$2;
121		my $re= $appid eq '' ? qr/^.*----\Q$subkey\E$/i : qr/^(?:\Q$appid\E)?----\Q$subkey\E$/i;
122		@arrays= map $ilst->{$_}, grep m/$re/, keys %$ilst;
123	}
124	elsif (my $array=$ilst->{$key})
125	{	@arrays=($array);
126	}
127	for my $array (@arrays)
128	{	$_=undef for @$array;
129	}
130	return 1;
131}
132sub remove
133{	my ($self,$key,$nb)=@_;
134	return undef unless defined $key and $nb=~m/^\d*$/;
135	$nb||=0;
136	my $val=$self->{ilst}{$key}[$nb];
137	unless (defined $val) {warn "tag to delete not found\n"; return undef; }
138	$self->{ilst}{$key}[$nb]=undef;
139	#return 1;
140	return $val;
141}
142
143sub get_keys
144{	keys %{ $_[0]{ilst} };
145}
146sub get_values
147{	my ($self,$key)=@_;
148	my $ilst=$self->{ilst};
149	if ($key=~m/^(.*)----(.*)$/)
150	{	my $appid=$1;
151		my $subkey=$2;
152		my $re= $appid eq '' ? qr/^.*----\Q$subkey\E$/i : qr/^(?:\Q$appid\E)?----\Q$subkey\E$/i;
153		return map @{$ilst->{$_}}, grep m/$re/, keys %$ilst;
154	}
155	my $v= $ilst->{$key};
156	return $v ? (grep defined, @$v) : ();
157}
158
159sub get_field_info
160{	my $key=shift;
161	my $type= $key=~s/^Unknown tag with flag=\d+ and key=// ? 'u':
162		  $key eq 'covr' ?		'p':
163		  $key=~m/^cpil$|^pgap$|^pcst$/?'f':
164		  				't';
165	if ($key=~m/^(.*)----(.*)$/)
166	{	return 'tt'.$type,'----',$key,$1,$2;
167	}
168	return $type,undef,$key;
169}
170
171sub ParseAtomTree
172{	my $self=shift;
173	my $fh=$self->{fileHandle};
174	my $buffer;
175	my (@toplevels,$stco,@left,@parents,@poffset,@psize);
176	my (%info,@ilst,$ilst_data,$otherkey);
177	while (read($fh,$buffer,8)==8)
178	{	while (@left && $left[-1]<=0)
179		{	pop @parents;
180			pop @left;
181			pop @poffset;
182			pop @psize;
183		}
184		my ($length,$name)=unpack 'NA4',$buffer;
185		my $offset=tell($fh)-8;
186		my $headsize=8;
187		if ($length==1)	# $length==1 means 64-bit length follow
188		{	read($fh,$buffer,8);
189			my ($length1,$length2)=unpack 'NN',$buffer;
190			if ($length1>0) { warn "atom '$name' has a size >4GB, unsupported => can't read file\n"; return }
191			$length=$length2;
192			$headsize=16;
193		}
194		#FIXME if length==0 : open-ended, extends to the end of the file
195		if ($length<$headsize) { warn "error atom '$name' has an invalid size of $length bytes";return }
196#warn join('.',@parents,$name)."\n";#warn "left:@left\n";
197		push @toplevels, $name,$offset,$length,$stco=[] unless @parents;
198		if (@left && $length>$left[-1]) { warn "Premature end of atom, parent '$parents[-1]' has only ".$left[-1]." bytes left, but child '$name' says it is $length bytes long\n"; $length=$left[-1]; }
199		$left[-1]-=$length if @left;
200		my $datalength=$length-$headsize;
201		my $isparent= $IsParent{$name};
202		$isparent=0 if @parents && $parents[-1] eq 'ilst';  #0 but defined : children of ilst are parents
203		if (defined $isparent)
204		{	push @left,$datalength;
205			push @parents,$name;
206			push @poffset,$offset;
207			push @psize,$length;
208			if ($name eq 'ilst')
209			{	push @{$self->{ilstparents}},[@poffset],[@psize];
210				push @ilst, $ilst_data=[];
211			}
212			if (my $offset=$isparent) #for atom 'meta'
213			{	seek $fh,$offset,1;
214				$left[-1]-=$offset;
215			}
216			$otherkey=undef;
217		}
218		elsif (@parents>1 && $parents[-2] eq 'ilst') #in moov.udta.meta.ilst.XXXX
219		{	my $key=$parents[-1];
220			read($fh,my($data),$datalength);
221			if ($key eq '----') #freeform tag
222			{	unless ($otherkey) { push @$ilst_data, $key,$otherkey={}; }
223				$otherkey->{$name}=$data;
224			}
225			elsif ($name eq 'data')
226			{	push @$ilst_data,$key,$data;
227			}
228		}
229		elsif ($name eq 'mvhd')
230		{	read($fh,$buffer,$datalength);
231			my ($version,$timescale,$duration)=unpack 'Cx3x4x4NN',$buffer;
232			if ($version==1)
233			{	($timescale,$duration,my $duration2)=unpack 'x4x8x8NNN',$buffer;
234				$info{seconds}= ($duration* 2**32 + $duration2)/$timescale;
235			}
236			else { $info{seconds}= $duration/$timescale; }
237		}
238		elsif ($name eq 'stsd')
239		{	read($fh,$buffer,$datalength);
240			my ($type,$channels,$bitspersample,$samplerate)=unpack 'x4x4x4A4x16nnx2N',$buffer;
241			if (($type eq 'mp4a' || $type eq 'alac') && !$info{traktype}) #ignore if non mp4a/alac, and only read the first one if more than one (can it happen ?)
242			{	$info{channels}=$channels;
243				$info{rate}=$samplerate;
244				$info{bitspersample}=$bitspersample;
245				#warn "channel=$channels bitspersample=$bitspersample samplerate=$samplerate\n";
246				$info{bitrate}=unpack 'N',$1 if $buffer=~m/^.{48}esds.{4}\x03(?:\x80\x80\x80)?.{4}\x04(?:\x80\x80\x80)?.{10}(.{4})/s; # doesn't seem to work for alac files, will use calculated bitrate instead
247			}
248			$info{traktype}||=$type;
249		}
250		elsif ($name eq 'cmov')
251		{	warn "Compressed moov atom found, unsupported"; return;
252		}
253		else
254		{	if    ($name eq 'mdat')	{ $info{audiodatasize}+=$datalength; }
255			elsif ($name=~m/^stco|^co64|^tfhd/) { push @$stco,$name,$offset-$poffset[0]; $self->{nofullrewrite}=1 unless $name eq 'stco'; }
256			unless (seek $fh,$datalength,1) { warn $!; return undef }
257		}
258	}
259	if (!$info{audiodatasize}) { warn "Error reading m4a file : no mdat atom found\n"; return }
260	$self->{toplevels}=\@toplevels;
261	$info{bitrate_calculated}= 8*$info{audiodatasize}/$info{seconds};
262	$info{bitrate}||=$info{bitrate_calculated};
263	$self->{info}=\%info;
264
265	#warn "$_ => $info{$_}\n" for sort keys %info;
266
267	return unless $ilst[0];
268
269	@ilst=@{$ilst[0]}; #ignore an eventual 2nd ilst
270	while (@ilst)
271	{	my ($key,$data)=splice @ilst,0,2;
272		if ($key eq '----')
273		{	$key= substr($data->{mean},4).'----'.substr($data->{name},4);
274			$data=$data->{data};
275			next unless defined $data;
276		}
277		my $val= substr $data,8;
278		my $flag=unpack 'x3C',$data;
279		if ($flag==1)				{ $val=decode('utf-8',$val); }
280		elsif ($key eq 'trkn' || $key eq 'disk'){ $val=join '/',unpack 'x2nn',$val; }
281		elsif ($key eq 'gnre')			{ $val=unpack 'xC',$val; $val= $val ? $Tag::MP3::Genres[$val-1] : ''; $key="\xa9gen"; }	#gnre uses id3 genre number +1
282		elsif ($key eq 'covr')			{  } #nothing to do, $val contains the binary data of the picture
283		elsif ($key eq 'tmpo')			{ $val=unpack 'n',$val; }
284		elsif ($key=~m/^cpil$|^pgap$|^pcst$/)	{ $val=unpack 'C',$val; }
285		else					{ $key='Unknown tag with flag='.$flag.' and key='.$key; }
286		push @{$self->{ilst}{$key}}, $val;
287		push @{$self->{ilst_order}}, $key;
288	}
289}
290
291sub Make_ilst
292{	my $self=shift;
293	my $ilst="\x00\x00\x00\x00ilst";
294	for my $key (@{ $self->{ilst_order} })
295	{	my $val=shift @{$self->{ilst}{$key}};
296		next unless defined $val;
297		my $data;
298		if ($key eq 'covr')
299		{	for my $val (grep defined, $val,@{$self->{ilst}{covr}})		#there can be multiple covers
300			{	my $flags=13;		#default to jpg
301				if ($val=~m/^\x89PNG\x0D\x0A\x1A\x0A/) {$flags=14}	#for png
302				#elsif ($val!=~m/^\xff\xd8\xff\xe0..JFIF\x00/s) {warn "picture in unknown format, should be jpg or png"}
303				$data.= pack('NA4x3Cx4a*', 16+length $val, 'data',$flags).$val;
304			}
305			$self->{ilst}{covr}=[];
306		}
307		else
308		{	my $flags=1;
309			if ($key=~m/^Unknown tag with flag=(\d+) and key=(.*)$/)	{$key=$2; $flags=$1;}
310			if (ref $val || $key=~m/^(.*)----(.*)$/)
311			{	my ($mean,$name)= ref $val ? @$val : ($1,$2);
312				$val=$val->[2] if ref $val;
313				$key='----';
314				$data=pack 'NA4x4a*NA4x4a*', (12+length $mean), 'mean', $mean, (12+length $name), 'name',$name;
315			}
316			if ($key eq 'trkn' || $key eq 'disk')
317			{	next unless $val=~m#(\d+)(?:/(\d+))?#;
318				$flags=0;
319				$val=pack 'x2nn',$1,($2||0);
320				$val.="\x00\x00" if $key eq 'trkn';
321			}
322			elsif ($key eq 'tmpo')			{ $val=pack 'n',$val; $flags=21; }
323			elsif ($key=~m/^cpil$|^pgap$|^pcst$/)	{ $val=pack 'C',$val; $flags=21; }
324			elsif ($key eq "\xA9gen" && grep $val eq $_, @Tag::MP3::Genres)
325			{	$key='gnre'; $flags=0;
326				$val=::first {$val eq $Tag::MP3::Genres[$_]} 0..$#Tag::MP3::Genres;
327				$val=pack 'xC',$val+1;	#gnre uses id3 genre number +1
328			}
329			elsif ($flags==1)			{ $val=encode('utf-8',$val); }
330
331			$data.= pack 'NA4x3Cx4a*', (16+length $val), 'data', $flags, $val;
332		}
333		$ilst.= pack 'NA4a*', (8+length $data),$key,$data;
334	}
335	substr $ilst,0,4,pack('N', length $ilst );	#set size of the new ilst
336	return $ilst;
337}
338
339sub write_file
340{	my $self=shift;
341	my $fh=$self->_open;
342	unless ($self->{ilstparents}) { warn "ilst not found"; return }
343	my ($poffset,$psize)=@{$self->{ilstparents}};
344	my $oldsize=pop @$psize;
345	my $ilst_offset= pop @$poffset;
346	my $moov_offset=$poffset->[0];
347	$ilst_offset-=$moov_offset;
348	seek $fh,$moov_offset,0;
349	read $fh,my($moov),$psize->[0];
350	my $free_after_moov=0;
351	if (8==read $fh,my($buffer),8)
352	{	my ($length,$name)=unpack 'NA4',$buffer;
353		if ($length==1 && 8==read($fh,$buffer,8))	# $length==1 means 64-bit length follow
354		{	my ($length1,$length2)=unpack 'NN',$buffer;
355			if ($length1==0 && $length2>=16) { $length=$length2; }
356		}
357		$free_after_moov=$length if $name eq 'free' && $length>=8;
358	}
359	$self->_close;
360	my $oldilst= substr $moov,$ilst_offset,$oldsize;
361	my $newilst= $self->Make_ilst;
362	#look if ilst's parent has a 'free' child right after ilst
363	if ($poffset->[-1]-$moov_offset+$psize->[-1] > $ilst_offset+$oldsize)
364	{	my ($length,$name)=unpack 'NA4', substr $moov,$ilst_offset+$oldsize,8;
365		if ($length==1)	# $length==1 means 64-bit length follow
366		{	my ($length1,$length2)=unpack 'NN', substr $moov,$ilst_offset+$oldsize+8,8;
367			if ($length1==0 && $length2>=16) { $length=$length2; }
368		}
369		$oldsize+=$length if $name eq 'free' && $length>=8;
370	}
371	my $free=$oldsize - length $newilst;  #warn "  free1=$free\n";
372	if ($free>=2**32) { warn "file too big, size>4GB are not supported\n"; return 0; }
373	elsif ($free==0 || ($free>=8 && ($free<2048 || $self->{nofullrewrite})))
374	{	warn "in place editing1.\n";
375		$newilst.= pack('NA4',$free,'free') . "\x00"x ($free-8) if $free;
376		$fh=$self->_openw or return 0;
377		seek $fh,$ilst_offset+$moov_offset,0;
378		print $fh $newilst or warn $!;
379		#warn "endwrite1=".tell($fh);			#DEBUG
380		$self->_close;
381	}
382	else	# too much or not enough padding -> set padding to 1024 and resize
383	{	$newilst.= pack('NA4',1024,'free') . "\x00"x (1024-8);
384		my $delta1=1024-$free;
385		#replace old ilst by new ilst in $moov
386		substr $moov,$ilst_offset,$oldsize, $newilst;
387		for my $i (0..$#$poffset)	#resize ilst's parents
388		{	substr $moov,$poffset->[$i]-$moov_offset,4, pack('N', $psize->[$i]+=$delta1 );
389		}
390		my $free= $free_after_moov - $delta1; #warn "  free2=$free\n";
391		if ($free==0 || ($free>=8 && ($free<20480 || $self->{nofullrewrite})))
392		{	warn "in place editing2.\n";
393			$moov.= pack('NA4',$free,'free') . "\x00"x ($free-8) if $free;
394			$fh=$self->_openw or return 0;
395			seek $fh,$poffset->[0],0;
396			print $fh $moov or warn $!;
397			#warn "endwrite2=".tell($fh);			#DEBUG
398			$self->_close;
399		}
400		elsif ($self->{nofullrewrite})
401		{	warn "file contains a co64 or tfhd atom, adding metadata bigger than the free space is not supported.\n";
402			return 0;
403		}
404		else
405		{	my $delta2=4096-$free;		#warn "delta2=$delta2\n";
406			$moov.= pack('NA4',4096,'free') . "\x00"x (4096-8);
407			my $INfh=$self->_open or return 0;
408			my $OUTfh=$self->_openw(1) or return 0;	#open .TEMP file
409			my $werr;
410
411			my $toplevels=$self->{toplevels};
412			while (@$toplevels)
413			{	my ($name,$o,$s,$stco)=splice @$toplevels,0,4;
414				if ($o==$moov_offset)	#$name eq 'moov'
415				{	for (my $i=1; $i<=$#$stco; $i+=2) { $stco->[$i]+=$delta1 if $stco->[$i]>$ilst_offset; } #fix offset for stco after ilst
416					_UpdateStco($stco,\$moov,$moov_offset,$delta2);
417					print $OUTfh $moov  or warn $! and $werr++;
418					splice @$toplevels,0,4 if @$toplevels && $toplevels->[0] eq 'free';
419				}
420				elsif ($name eq 'mdat')
421				{	seek $INfh,$o,0;
422					while ($s>0)
423					{	my $size=($s>1048576)? 1048576 : $s;
424						read $INfh,my($buffer),$size;
425						print $OUTfh $buffer  or warn $! and $werr++;
426						$s-=$size;
427					}
428				}
429				else
430				{	seek $INfh,$o,0;
431					read $INfh,my($buffer),$s;
432					_UpdateStco($stco,\$buffer,$moov_offset,$delta2);
433					print $OUTfh $buffer  or warn $! and $werr++;
434				}
435				last if $werr;
436			}
437			$self->_close;
438			close $OUTfh;
439			if ($werr) {warn "write errors... aborting.\n"; unlink $self->{filename}.'.TEMP'; return 0; }
440			warn "replacing old file with new file.\n";
441			unlink $self->{filename} && rename $self->{filename}.'.TEMP',$self->{filename};
442		}
443	}
444	%$self=(); #destroy the object to make sure it is not reused as many of its data are now invalid
445	return 1;
446}
447
448sub _UpdateStco
449{	my ($stco,$chunckdataref,$change_position,$delta)=@_;
450	while (@$stco)
451	{	my ($atom,$offset)=splice @$stco,0,2;
452		if ($atom eq 'stco')
453		{	my $nb=unpack 'N',substr $$chunckdataref,$offset+12; #number of 4-bytes offset
454			my @offsets=unpack 'N*',substr $$chunckdataref,$offset+16,$nb*4;
455			$_ = $_ > $change_position ? $_+$delta : $_ for @offsets;
456			substr $$chunckdataref,$offset+16, 4*@offsets, pack 'N*',@offsets;
457		}
458		#updating co64 and tfhd is not supported, will abort before reaching this point because of $self->{nofullrewrite}
459		#elsif ($atom eq 'co64')
460		#{
461		#}
462		##elsif ($atom eq 'tfhd')
463		#{
464		#}
465	}
466}
467
4681;
469