m4aheader.pm

# Copyright (C) 2009 Quentin Sculo <squentin@free.fr>
#
# This file is part of Gmusicbrowser.
# Gmusicbrowser is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License version 3, as
# published by the Free Software Foundation

#based on :
#http://atomicparsley.sourceforge.net/mpeg-4files.html
#http://wiki.multimedia.cx/index.php?title=QuickTime_container
#http://www.geocities.com/xhelmboyx/quicktime/formats/mp4-layout.txt
#
#blame Apple for the absence of official specs for metadata :(

#usage :
#my $tag=Tag::M4A->new($file);
#if ($tag)
#{	$tag->add(name => 'value');
#	$tag->insert('org.gmusicbrowser----mytag' => 'mytagvalue');
#	$tag->remove_all('disk');
#	$tag->write_file;
#}
#
# uses @Tag::MP3::Genres for numeric genres

package Tag::M4A;
use strict;
use warnings;
use Encode qw(decode encode);

my %IsParent;
INIT
{ $IsParent{$_}=0 for qw/moov trak udta mdia minf stbl ilst moof traf/; # unused parent atoms : tref imap edts mdra rmra imag vnrp dinf
  $IsParent{meta}=4;	#4 bytes version/flags = byte hex version + 24-bit hex flags  (current = 0)
}

sub new
{	my ($class,$file)=@_;
	my $self=bless {}, $class;

	# check that the file exists
	unless (-e $file)
	{	warn "File '$file' does not exist.\n";
	    return undef;
	}
	$self->{filename} = $file;
	$self->_open or return undef;

	$self->ParseAtomTree;
	$self->_close;

	unless ($self->{info} && $self->{ilst})
	{	warn "error, can't read file or not a valid m4a file\n";
		return undef;
	}
	return $self;
}

sub _open
{	my $self=shift;
	my $file=$self->{filename};
	open my$fh,'<',$file or warn "can't open $file : $!\n" and return undef;
	binmode $fh;
	$self->{fileHandle} = $fh;
	return $fh;
}
sub _openw
{	my ($self,$tmp)=@_;
	my $file=$self->{filename};
	my $m='+<';
	if ($tmp) {$file.='.TEMP';$m='>';}
	my $fh;
	until (open $fh,$m,$file)
	{	my $err="Error opening '$file' for writing :\n$!";
		warn $err."\n";
		return undef unless $self->{errorsub} && $self->{errorsub}($!,'openwrite',$file) eq 'retry';
	}
	binmode $fh;
	unless ($tmp)
	{ $self->{fileHandle} = $fh;
	}
	return $fh;
}
sub _close
{	my $self=shift;
	close delete($self->{fileHandle});
}

sub edit
{	my ($self,$key,$nb,$val)=@_;
	$nb||=0;
	my $aref=$self->{ilst}{$key};
	return undef unless $aref &&  @$aref >=$nb;
	my $old=$aref->[$nb];
	$aref->[$nb]=$val;
	return $old;
}
sub add
{	my ($self,$key,$val)=@_;
	$key=~s/^----/com.apple.iTunes----/;
	push @{ $self->{ilst}{$key} },$val;
	push @{$self->{ilst_order}}, $key;
	return 1;
}
sub insert	#same as add but put it first (of its kind)
{	my ($self,$key,$val)=@_;
	$key=~s/^----/com.apple.iTunes----/;
	unshift @{ $self->{ilst}{$key} },$val;
	push @{$self->{ilst_order}}, $key;
	return 1;
}

sub remove_all
{	my ($self,$key)=@_;
	return unless defined $key;
	my $ilst=$self->{ilst};
	my @arrays;
	if ($key=~m/^(.*)----(.*)$/)
	{	my $appid=$1;
		my $subkey=$2;
		my $re= $appid eq '' ? qr/^.*----\Q$subkey\E$/i : qr/^(?:\Q$appid\E)?----\Q$subkey\E$/i;
		@arrays= map $ilst->{$_}, grep m/$re/, keys %$ilst;
	}
	elsif (my $array=$ilst->{$key})
	{	@arrays=($array);
	}
	for my $array (@arrays)
	{	$_=undef for @$array;
	}
	return 1;
}
sub remove
{	my ($self,$key,$nb)=@_;
	return undef unless defined $key and $nb=~m/^\d*$/;
	$nb||=0;
	my $val=$self->{ilst}{$key}[$nb];
	unless (defined $val) {warn "tag to delete not found\n"; return undef; }
	$self->{ilst}{$key}[$nb]=undef;
	#return 1;
	return $val;
}

sub get_keys
{	keys %{ $_[0]{ilst} };
}
sub get_values
{	my ($self,$key)=@_;
	my $ilst=$self->{ilst};
	if ($key=~m/^(.*)----(.*)$/)
	{	my $appid=$1;
		my $subkey=$2;
		my $re= $appid eq '' ? qr/^.*----\Q$subkey\E$/i : qr/^(?:\Q$appid\E)?----\Q$subkey\E$/i;
		return map @{$ilst->{$_}}, grep m/$re/, keys %$ilst;
	}
	my $v= $ilst->{$key};
	return $v ? (grep defined, @$v) : ();
}

sub get_field_info
{	my $key=shift;
	my $type= $key=~s/^Unknown tag with flag=\d+ and key=// ? 'u':
		  $key eq 'covr' ?		'p':
		  $key=~m/^cpil$|^pgap$|^pcst$/?'f':
		  				't';
	if ($key=~m/^(.*)----(.*)$/)
	{	return 'tt'.$type,'----',$key,$1,$2;
	}
	return $type,undef,$key;
}

sub ParseAtomTree
{	my $self=shift;
	my $fh=$self->{fileHandle};
	my $buffer;
	my (@toplevels,$stco,@left,@parents,@poffset,@psize);
	my (%info,@ilst,$ilst_data,$otherkey);
	while (read($fh,$buffer,8)==8)
	{	while (@left && $left[-1]<=0)
		{	pop @parents;
			pop @left;
			pop @poffset;
			pop @psize;
		}
		my ($length,$name)=unpack 'NA4',$buffer;
		my $offset=tell($fh)-8;
		my $headsize=8;
		if ($length==1)	# $length==1 means 64-bit length follow
		{	read($fh,$buffer,8);
			my ($length1,$length2)=unpack 'NN',$buffer;
			if ($length1>0) { warn "atom '$name' has a size >4GB, unsupported => can't read file\n"; return }
			$length=$length2;
			$headsize=16;
		}
		#FIXME if length==0 : open-ended, extends to the end of the file
		if ($length<$headsize) { warn "error atom '$name' has an invalid size of $length bytes";return }
#warn join('.',@parents,$name)."\n";#warn "left:@left\n";
		push @toplevels, $name,$offset,$length,$stco=[] unless @parents;
		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]; }
		$left[-1]-=$length if @left;
		my $datalength=$length-$headsize;
		my $isparent= $IsParent{$name};
		$isparent=0 if @parents && $parents[-1] eq 'ilst';  #0 but defined : children of ilst are parents
		if (defined $isparent)
		{	push @left,$datalength;
			push @parents,$name;
			push @poffset,$offset;
			push @psize,$length;
			if ($name eq 'ilst')
			{	push @{$self->{ilstparents}},[@poffset],[@psize];
				push @ilst, $ilst_data=[];
			}
			if (my $offset=$isparent) #for atom 'meta'
			{	seek $fh,$offset,1;
				$left[-1]-=$offset;
			}
			$otherkey=undef;
		}
		elsif (@parents>1 && $parents[-2] eq 'ilst') #in moov.udta.meta.ilst.XXXX
		{	my $key=$parents[-1];
			read($fh,my($data),$datalength);
			if ($key eq '----') #freeform tag
			{	unless ($otherkey) { push @$ilst_data, $key,$otherkey={}; }
				$otherkey->{$name}=$data;
			}
			elsif ($name eq 'data')
			{	push @$ilst_data,$key,$data;
			}
		}
		elsif ($name eq 'mvhd')
		{	read($fh,$buffer,$datalength);
			my ($version,$timescale,$duration)=unpack 'Cx3x4x4NN',$buffer;
			if ($version==1)
			{	($timescale,$duration,my $duration2)=unpack 'x4x8x8NNN',$buffer;
				$info{seconds}= ($duration* 2**32 + $duration2)/$timescale;
			}
			else { $info{seconds}= $duration/$timescale; }
		}
		elsif ($name eq 'stsd')
		{	read($fh,$buffer,$datalength);
			my ($type,$channels,$bitspersample,$samplerate)=unpack 'x4x4x4A4x16nnx2N',$buffer;
			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 ?)
			{	$info{channels}=$channels;
				$info{rate}=$samplerate;
				$info{bitspersample}=$bitspersample;
				#warn "channel=$channels bitspersample=$bitspersample samplerate=$samplerate\n";
				$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
			}
			$info{traktype}||=$type;
		}
		elsif ($name eq 'cmov')
		{	warn "Compressed moov atom found, unsupported"; return;
		}
		else
		{	if    ($name eq 'mdat')	{ $info{audiodatasize}+=$datalength; }
			elsif ($name=~m/^stco|^co64|^tfhd/) { push @$stco,$name,$offset-$poffset[0]; $self->{nofullrewrite}=1 unless $name eq 'stco'; }
			unless (seek $fh,$datalength,1) { warn $!; return undef }
		}
	}
	if (!$info{audiodatasize}) { warn "Error reading m4a file : no mdat atom found\n"; return }
	$self->{toplevels}=\@toplevels;
	$info{bitrate_calculated}= 8*$info{audiodatasize}/$info{seconds};
	$self->{info}=\%info;

	#warn "$_ => $info{$_}\n" for sort keys %info;

	return unless $ilst[0];

	@ilst=@{$ilst[0]}; #ignore an eventual 2nd ilst
	while (@ilst)
	{	my ($key,$data)=splice @ilst,0,2;
		if ($key eq '----')
		{	$key= substr($data->{mean},4).'----'.substr($data->{name},4);
			$data=$data->{data};
			next unless defined $data;
		}
		my $val= substr $data,8;
		my $flag=unpack 'x3C',$data;
		if ($flag==1)				{ $val=decode('utf-8',$val); }
		elsif ($key eq 'trkn' || $key eq 'disk'){ $val=join '/',unpack 'x2nn',$val; }
		elsif ($key eq 'gnre')			{ $val=unpack 'xC',$val; $val= $val ? $Tag::MP3::Genres[$val-1] : ''; $key="\xa9gen"; }	#gnre uses id3 genre number +1
		elsif ($key eq 'covr')			{  } #nothing to do, $val contains the binary data of the picture
		elsif ($key eq 'tmpo')			{ $val=unpack 'n',$val; }
		elsif ($key=~m/^cpil$|^pgap$|^pcst$/)	{ $val=unpack 'C',$val; }
		else					{ $key='Unknown tag with flag='.$flag.' and key='.$key; }
		push @{$self->{ilst}{$key}}, $val;
		push @{$self->{ilst_order}}, $key;
	}
}

sub Make_ilst
{	my $self=shift;
	my $ilst="\x00\x00\x00\x00ilst";
	for my $key (@{ $self->{ilst_order} })
	{	my $val=shift @{$self->{ilst}{$key}};
		next unless defined $val;
		my $data;
		if ($key eq 'covr')
		{	for my $val (grep defined, $val,@{$self->{ilst}{covr}})		#there can be multiple covers
			{	my $flags=13;		#default to jpg
				if ($val=~m/^\x89PNG\x0D\x0A\x1A\x0A/) {$flags=14}	#for png
				#elsif ($val!=~m/^\xff\xd8\xff\xe0..JFIF\x00/s) {warn "picture in unknown format, should be jpg or png"}
				$data.= pack('NA4x3Cx4a*', 16+length $val, 'data',$flags).$val;
			}
			$self->{ilst}{covr}=[];
		}
		else
		{	my $flags=1;
			if ($key=~m/^Unknown tag with flag=(\d+) and key=(.*)$/)	{$key=$2; $flags=$1;}
			if (ref $val || $key=~m/^(.*)----(.*)$/)
			{	my ($mean,$name)= ref $val ? @$val : ($1,$2);
				$val=$val->[2] if ref $val;
				$key='----';
				$data=pack 'NA4x4a*NA4x4a*', (12+length $mean), 'mean', $mean, (12+length $name), 'name',$name;
			}
			if ($key eq 'trkn' || $key eq 'disk')
			{	next unless $val=~m#(\d+)(?:/(\d+))?#;
				$flags=0;
				$val=pack 'x2nn',$1,($2||0);
				$val.="\x00\x00" if $key eq 'trkn';
			}
			elsif ($key eq 'tmpo')			{ $val=pack 'n',$val; $flags=21; }
			elsif ($key=~m/^cpil$|^pgap$|^pcst$/)	{ $val=pack 'C',$val; $flags=21; }
			elsif ($key eq "\xA9gen" && grep $val eq $_, @Tag::MP3::Genres)
			{	$key='gnre'; $flags=0;
				$val=::first {$val eq $Tag::MP3::Genres[$_]} 0..$#Tag::MP3::Genres;
				$val=pack 'xC',$val+1;	#gnre uses id3 genre number +1
			}
			elsif ($flags==1)			{ $val=encode('utf-8',$val); }

			$data.= pack 'NA4x3Cx4a*', (16+length $val), 'data', $flags, $val;
		}
		$ilst.= pack 'NA4a*', (8+length $data),$key,$data;
	}
	substr $ilst,0,4,pack('N', length $ilst );	#set size of the new ilst
	return $ilst;
}

sub write_file
{	my $self=shift;
	my $fh=$self->_open;
	unless ($self->{ilstparents}) { warn "ilst not found"; return }
	my ($poffset,$psize)=@{$self->{ilstparents}};
	my $oldsize=pop @$psize;
	my $ilst_offset= pop @$poffset;
	my $moov_offset=$poffset->[0];
	$ilst_offset-=$moov_offset;
	seek $fh,$moov_offset,0;
	read $fh,my($moov),$psize->[0];
	my $free_after_moov=0;
	if (8==read $fh,my($buffer),8)
	{	my ($length,$name)=unpack 'NA4',$buffer;
		if ($length==1 && 8==read($fh,$buffer,8))	# $length==1 means 64-bit length follow
		{	my ($length1,$length2)=unpack 'NN',$buffer;
			if ($length1==0 && $length2>=16) { $length=$length2; }
		}
		$free_after_moov=$length if $name eq 'free' && $length>=8;
	}
	$self->_close;
	my $oldilst= substr $moov,$ilst_offset,$oldsize;
	my $newilst= $self->Make_ilst;
	#look if ilst's parent has a 'free' child right after ilst
	if ($poffset->[-1]-$moov_offset+$psize->[-1] > $ilst_offset+$oldsize)
	{	my ($length,$name)=unpack 'NA4', substr $moov,$ilst_offset+$oldsize,8;
		if ($length==1)	# $length==1 means 64-bit length follow
		{	my ($length1,$length2)=unpack 'NN', substr $moov,$ilst_offset+$oldsize+8,8;
			if ($length1==0 && $length2>=16) { $length=$length2; }
		}
		$oldsize+=$length if $name eq 'free' && $length>=8;
	}
	my $free=$oldsize - length $newilst;  #warn "  free1=$free\n";
	if ($free>=2**32) { warn "file too big, size>4GB are not supported\n"; return 0; }
	elsif ($free==0 || ($free>=8 && ($free<2048 || $self->{nofullrewrite})))
	{	warn "in place editing1.\n";
		$newilst.= pack('NA4',$free,'free') . "\x00"x ($free-8) if $free;
		$fh=$self->_openw or return 0;
		seek $fh,$ilst_offset+$moov_offset,0;
		print $fh $newilst or warn $!;
		#warn "endwrite1=".tell($fh);			#DEBUG
		$self->_close;
	}
	else	# too much or not enough padding -> set padding to 1024 and resize
	{	$newilst.= pack('NA4',1024,'free') . "\x00"x (1024-8);
		my $delta1=1024-$free;
		#replace old ilst by new ilst in $moov
		substr $moov,$ilst_offset,$oldsize, $newilst;
		for my $i (0..$#$poffset)	#resize ilst's parents
		{	substr $moov,$poffset->[$i]-$moov_offset,4, pack('N', $psize->[$i]+=$delta1 );
		}
		my $free= $free_after_moov - $delta1; #warn "  free2=$free\n";
		if ($free==0 || ($free>=8 && ($free<20480 || $self->{nofullrewrite})))
		{	warn "in place editing2.\n";
			$moov.= pack('NA4',$free,'free') . "\x00"x ($free-8) if $free;
			$fh=$self->_openw or return 0;
			seek $fh,$poffset->[0],0;
			print $fh $moov or warn $!;
			#warn "endwrite2=".tell($fh);			#DEBUG
			$self->_close;
		}
		elsif ($self->{nofullrewrite})
		{	warn "file contains a co64 or tfhd atom, adding metadata bigger than the free space is not supported.\n";
			return 0;
		}
		else
		{	my $delta2=4096-$free;		#warn "delta2=$delta2\n";
			$moov.= pack('NA4',4096,'free') . "\x00"x (4096-8);
			my $INfh=$self->_open or return 0;
			my $OUTfh=$self->_openw(1) or return 0;	#open .TEMP file
			my $werr;

			my $toplevels=$self->{toplevels};
			while (@$toplevels)
			{	my ($name,$o,$s,$stco)=splice @$toplevels,0,4;
				if ($o==$moov_offset)	#$name eq 'moov'
				{	for (my $i=1; $i<=$#$stco; $i+=2) { $stco->[$i]+=$delta1 if $stco->[$i]>$ilst_offset; } #fix offset for stco after ilst
					_UpdateStco($stco,\$moov,$moov_offset,$delta2);
					print $OUTfh $moov  or warn $! and $werr++;
					splice @$toplevels,0,4 if @$toplevels && $toplevels->[0] eq 'free';
				}
				elsif ($name eq 'mdat')
				{	seek $INfh,$o,0;
					while ($s>0)
					{	my $size=($s>1048576)? 1048576 : $s;
						read $INfh,my($buffer),$size;
						print $OUTfh $buffer  or warn $! and $werr++;
						$s-=$size;
					}
				}
				else
				{	seek $INfh,$o,0;
					read $INfh,my($buffer),$s;
					_UpdateStco($stco,\$buffer,$moov_offset,$delta2);
					print $OUTfh $buffer  or warn $! and $werr++;
				}
				last if $werr;
			}
			$self->_close;
			close $OUTfh;
			if ($werr) {warn "write errors... aborting.\n"; unlink $self->{filename}.'.TEMP'; return 0; }
			warn "replacing old file with new file.\n";
			unlink $self->{filename} && rename $self->{filename}.'.TEMP',$self->{filename};
		}
	}
	%$self=(); #destroy the object to make sure it is not reused as many of its data are now invalid
	return 1;
}

sub _UpdateStco
{	my ($stco,$chunckdataref,$change_position,$delta)=@_;
	while (@$stco)
	{	my ($atom,$offset)=splice @$stco,0,2;
		if ($atom eq 'stco')
		{	my $nb=unpack 'N',substr $$chunckdataref,$offset+12; #number of 4-bytes offset
			my @offsets=unpack 'N*',substr $$chunckdataref,$offset+16,$nb*4;
			$_ = $_ > $change_position ? $_+$delta : $_ for @offsets;
			substr $$chunckdataref,$offset+16, 4*@offsets, pack 'N*',@offsets;
		}
		#updating co64 and tfhd is not supported, will abort before reaching this point because of $self->{nofullrewrite}
		#elsif ($atom eq 'co64')
		#{
		#}
		##elsif ($atom eq 'tfhd')
		#{
		#}
	}
}

1;