1# Copyright (C) 2005-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#http://flac.sourceforge.net/format.html 9package Tag::Flac; 10use strict; 11use warnings; 12use Encode qw(decode encode); 13use MIME::Base64; 14our @ISA=('Tag::OGG'); 15 16use constant 17{ STREAMINFO => 0, 18 PADDING => 1, 19 APPLICATION => 2, 20 SEEKTABLE => 3, 21 VORBIS_COMMENT=> 4, 22 CUESHEET => 5, 23 PICTURE => 6, 24}; 25 26sub new 27{ my ($class,$file)=@_; 28 my $self=bless {}, $class; 29 local $_; 30 # check that the file exists 31 unless (-e $file) 32 { warn "File '$file' does not exist.\n"; 33 return undef; 34 } 35 $self->{filename} = $file; 36 $self->{startaudio}=0; #start of flac stream (in case an id3v2 tag is at the beginning of the file) 37 my $fh=$self->_open or return undef; 38 39 my $buffer; 40 { last unless read($fh,$buffer,4)==4; 41 if ($buffer=~m/^ID3/) 42 { my $tag=Tag::ID3v2->new_from_file($self); 43 $self->{startaudio}+=$tag->{size}; 44 redo; 45 } 46 } 47 unless ($buffer && $buffer eq 'fLaC') 48 { warn "flac: Not a flac header\n"; $self->_close; return undef; } 49 50 my $last; 51 my @pictures; 52 while ( !$last && read($fh,$buffer,4)==4 ) 53 { $buffer=unpack 'N',$buffer; 54 my $size=$buffer & 0xffffff; 55 my $pos=tell $fh; 56 my $type=($buffer >> 24) & 0x7f; 57 $last=$buffer >>31; 58 unless (read($fh,$buffer,$size)==$size) 59 { warn "flac: Premature end of file\n"; $self->_close; return undef; } 60 if ($type==STREAMINFO) {$self->{info}=_ReadInfo(\$buffer);} 61 elsif ($type==VORBIS_COMMENT) {$self->{comments}=_UnpackComments($self,\$buffer); $self->{comment_offset}=$pos-4} 62 elsif ($type==PICTURE) {my $pic=_ReadPicture(\$buffer); push @pictures,$pic if $pic;} 63 } 64 my $audiosize=(stat $fh)[7]-tell($fh); 65 $self->_close; 66 unless ($self->{info}) 67 { warn "error, can't read file or not a valid flac file\n"; 68 return undef; 69 } 70 $self->{info}{bitrate}= $self->{info}{seconds} ? $audiosize*8/$self->{info}{seconds} : 0; 71 unless ($self->{comments}) 72 { $self->{vorbis_string}='gmusicbrowser'; #FIXME 73 $self->{CommentsOrder}=[]; 74 $self->{comments}={}; 75 } 76 for my $pic (@pictures) 77 { push @{ $self->{comments}{metadata_block_picture} }, $pic; 78 push @{ $self->{CommentsOrder} }, 'metadata_block_picture', 79 } 80 return $self; 81 82} 83 84sub write_file 85{ my $self=shift; 86 local $_; 87 my ($INfh,$OUTfh); 88 my $pictures=''; 89 if (my $list=$self->{comments}{metadata_block_picture}) 90 { for my $pic (grep defined, @$list) 91 { my $packet= _PackPicture($pic); 92 my $head=pack 'N', (PICTURE<<24)+length $$packet; 93 $pictures.= $head.$$packet; 94 } 95 @$list=(); #remove the pictures from vorbis comments 96 } 97 my $newcom_packref=_PackComments($self); 98 my $fh=$self->_open or return undef; 99 my $buffer; my $last; my $towrite='fLaC'; my $padding=0; 100 seek $fh,$self->{startaudio} ,0; #skip extra tags 101 return undef unless (read($fh,$buffer,4)==4 && $buffer eq 'fLaC'); 102 while ( !$last && read($fh,$buffer,4)==4 ) 103 { $buffer=unpack 'N',$buffer; 104 my $size=$buffer & 0xffffff; 105 my $type=($buffer >> 24) & 0x7f; 106 $last=$buffer >>31; 107 if ($type!=VORBIS_COMMENT && $type!=PADDING && $type!=PICTURE) 108 { $buffer&=0x7fffffff; #set Last-metadata-block flag to 0 109 $towrite.=pack 'N',$buffer; 110 unless (read($fh,$towrite,$size,length($towrite))==$size) 111 { warn "flac: Premature end of file\n"; return undef; } 112 } 113 else {$padding+=$size+4; seek $fh,$size,1; } 114 } 115 $padding-= 4 + length($$newcom_packref) + length $pictures; 116 my $header=VORBIS_COMMENT; 117 my $inplace=($padding==0 || ($padding>3 && $padding<8192) ); 118 if ($padding==0) {$header+=0x80;$padding='';} 119 else 120 { $padding=$inplace? $padding-4 : 256; 121 $padding=pack "Nx$padding",((0x80+PADDING)<<24)+$padding; 122 } 123 $header=pack 'N',($header<<24)+length $$newcom_packref; 124 if ($inplace) 125 { $self->_close; 126 $fh=$self->_openw or return undef; 127 seek $fh,$self->{startaudio} ,0; 128 print $fh $towrite.$pictures.$header.$$newcom_packref.$padding or warn $!; 129 $self->_close; 130 } 131 else 132 { my $tmpfh=$self->_openw(1) or return undef; 133 if ($self->{startaudio}) 134 { seek $fh,0,0; 135 read($fh,$buffer,$self->{startaudio}); 136 print $tmpfh $buffer or warn $!; 137 } 138 print $tmpfh $towrite.$pictures.$header.$$newcom_packref.$padding or warn $!; 139 while (read($fh,$buffer,1048576)) 140 { print $tmpfh $buffer or warn $!; } 141 $self->_close; 142 close $tmpfh; 143 warn "replacing old file with new file.\n"; 144 unlink $self->{filename} && rename $self->{filename}.'.TEMP',$self->{filename}; 145 } 146 %$self=(); #destroy the object to make sure it is not reused as many of its data are now invalid 147 return 1; 148} 149 150sub _close 151{ my $self=shift; 152 close delete($self->{fileHandle}); 153} 154 155sub _ReadInfo 156{ my $packref=$_[0]; 157 my @v=unpack 'nn CnCn nCCN',$$packref; 158 #A16 B16 C8 C16 D8 D16 E16 EEEEFFFG GGGGHHHH H32 I128 159 #A <16> The minimum block size (in samples) used in the stream 160 #B <16> The maximum block size (in samples) used in the stream. (Minimum blocksize == maximum blocksize) implies a fixed-blocksize stream. 161 #C <24> The minimum frame size (in bytes) used in the stream. May be 0 to imply the value is not known. 162 #D <24> The maximum frame size (in bytes) used in the stream. May be 0 to imply the value is not known. 163 #E <20> Sample rate in Hz. Though 20 bits are available, the maximum sample rate is limited by the structure of frame headers to 1048570Hz. Also, a value of 0 is invalid. 164 #F <3> (number of channels)-1. FLAC supports from 1 to 8 channels 165 #G <5> (bits per sample)-1. FLAC supports from 4 to 32 bits per sample. Currently the reference encoder and decoders only support up to 24 bits per sample 166 #H <36> Total samples in stream. 'Samples' means inter-channel sample, i.e. one second of 44.1Khz audio will have 44100 samples regardless of the number of channels. A value of zero here means the number of total samples is unknown. 167 #I <128> MD5 signature of the unencoded audio data 168 my %info; 169 $info{min_block_size}=$v[0]; 170 $info{max_block_size}=$v[1]; 171 $info{min_frame_size}=($v[2]<<16)+$v[3]; 172 $info{max_frame_size}=($v[4]<<16)+$v[5]; 173 $info{rate}=($v[6]<<4)+($v[7]>>4); 174 $info{channels}=1+( ($v[7] & 0b1110)>>1 ); 175 $info{bit_per_sample}=1+( ($v[7] & 0b1)<<5 )+( $v[8] >>4 ); 176 $info{seconds}=( $v[9]+($v[8] & 0b1111)*2**32 )/$info{rate}; 177 return \%info; 178} 179 180sub _ReadPicture 181{ my $packref=$_[0]; 182 my $ret; 183 eval 184 { my ($type,$mime,$desc,undef,undef,undef,undef,$data) 185 =unpack 'N N/a N/a NNNN N/a',$$packref; 186 $ret=[$mime,$type,$desc,$data]; 187 }; 188 if ($@) { warn "invalid picture block - skipped\n"; } 189 return $ret; 190} 191sub _PackPicture 192{ my $pic=shift; 193 if (!ref $pic) { my $packet=decode_base64($pic); return \$packet; } 194 my ($mime,$type,$desc,$data)=@$pic; 195 my $packet= pack 'N N/a N/a NNNN N/a', ($type||0),$mime,$desc,0,0,0,0, $data; 196 return \$packet; 197} 198 199sub _UnpackComments 200{ my ($self,$packref)=@_; 201 my ($vstring,@comlist)= eval { unpack 'V/a V/(V/a)',$$packref; }; 202 if ($@) { warn "Comments corrupted\n"; return undef; } 203 $self->{vorbis_string}=$vstring; 204 my %comments; 205 for my $kv (@comlist) 206 { unless ($kv=~m/^([^=]+)=(.*)$/s) { warn "comment invalid - skipped\n"; next; } 207 my $key=$1; 208 my $val=decode('utf-8', $2); 209 #warn "$key = $val\n"; 210 push @{ $comments{lc$key} },$val; 211 push @{$self->{CommentsOrder}}, $key; 212 } 213 return \%comments; 214} 215sub _PackComments 216{ my $self=$_[0]; 217 my @comments; 218 my %count; 219 for my $key ( @{$self->{CommentsOrder}} ) 220 { my $nb=$count{lc$key}++ || 0; 221 my $val=$self->{comments}{lc$key}[$nb]; 222 next unless defined $val; 223 $key=encode('ascii',$key); 224 $key=~tr/\x20-\x7D/?/c; $key=~tr/=/?/; #replace characters that are not allowed by '?' 225 push @comments,$key.'='.encode('utf8',$val); 226 } 227 my $packet=pack 'V/a* V (V/a*)*',$self->{vorbis_string},scalar @comments, @comments; 228 #$packet.="\x01"; #framing_flag #gstreamer doesn't like it and not needed anyway 229 return \$packet; 230} 231 2321; 233