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