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