Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tree: 3d21002bf1
Fetching contributors…

Cannot retrieve contributors at this time

233 lines (220 sloc) 7.976 kb
# Copyright (C) 2005-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
#http://flac.sourceforge.net/format.html
package Tag::Flac;
use strict;
use warnings;
use Encode qw(decode encode);
use MIME::Base64;
our @ISA=('Tag::OGG');
use constant
{ STREAMINFO => 0,
PADDING => 1,
APPLICATION => 2,
SEEKTABLE => 3,
VORBIS_COMMENT=> 4,
CUESHEET => 5,
PICTURE => 6,
};
sub new
{ my ($class,$file)=@_;
my $self=bless {}, $class;
local $_;
# check that the file exists
unless (-e $file)
{ warn "File '$file' does not exist.\n";
return undef;
}
$self->{filename} = $file;
$self->{startaudio}=0; #start of flac stream (in case an id3v2 tag is at the beginning of the file)
my $fh=$self->_open or return undef;
my $buffer;
{ last unless read($fh,$buffer,4)==4;
if ($buffer=~m/^ID3/)
{ my $tag=Tag::ID3v2->new_from_file($self);
$self->{startaudio}+=$tag->{size};
redo;
}
}
unless ($buffer && $buffer eq 'fLaC')
{ warn "flac: Not a flac header\n"; $self->_close; return undef; }
my $last;
my @pictures;
while ( !$last && read($fh,$buffer,4)==4 )
{ $buffer=unpack 'N',$buffer;
my $size=$buffer & 0xffffff;
my $pos=tell $fh;
my $type=($buffer >> 24) & 0x7f;
$last=$buffer >>31;
unless (read($fh,$buffer,$size)==$size)
{ warn "flac: Premature end of file\n"; $self->_close; return undef; }
if ($type==STREAMINFO) {$self->{info}=_ReadInfo(\$buffer);}
elsif ($type==VORBIS_COMMENT) {$self->{comments}=_UnpackComments($self,\$buffer); $self->{comment_offset}=$pos-4}
elsif ($type==PICTURE) {my $pic=_ReadPicture(\$buffer); push @pictures,$pic if $pic;}
}
my $audiosize=(stat $fh)[7]-tell($fh);
$self->_close;
unless ($self->{info})
{ warn "error, can't read file or not a valid flac file\n";
return undef;
}
$self->{info}{bitrate}= $self->{info}{seconds} ? $audiosize*8/$self->{info}{seconds} : 0;
unless ($self->{comments})
{ $self->{vorbis_string}='gmusicbrowser'; #FIXME
$self->{CommentsOrder}=[];
$self->{comments}={};
}
for my $pic (@pictures)
{ push @{ $self->{comments}{metadata_block_picture} }, $pic;
push @{ $self->{CommentsOrder} }, 'metadata_block_picture',
}
return $self;
}
sub write_file
{ my $self=shift;
local $_;
my ($INfh,$OUTfh);
my $pictures='';
if (my $list=$self->{comments}{metadata_block_picture})
{ for my $pic (grep defined, @$list)
{ my $packet= _PackPicture($pic);
my $head=pack 'N', (PICTURE<<24)+length $$packet;
$pictures.= $head.$$packet;
}
@$list=(); #remove the pictures from vorbis comments
}
my $newcom_packref=_PackComments($self);
my $fh=$self->_open or return undef;
my $buffer; my $last; my $towrite='fLaC'; my $padding=0;
seek $fh,$self->{startaudio} ,0; #skip extra tags
return undef unless (read($fh,$buffer,4)==4 && $buffer eq 'fLaC');
while ( !$last && read($fh,$buffer,4)==4 )
{ $buffer=unpack 'N',$buffer;
my $size=$buffer & 0xffffff;
my $type=($buffer >> 24) & 0x7f;
$last=$buffer >>31;
if ($type!=VORBIS_COMMENT && $type!=PADDING && $type!=PICTURE)
{ $buffer&=0x7fffffff; #set Last-metadata-block flag to 0
$towrite.=pack 'N',$buffer;
unless (read($fh,$towrite,$size,length($towrite))==$size)
{ warn "flac: Premature end of file\n"; return undef; }
}
else {$padding+=$size+4; seek $fh,$size,1; }
}
$padding-= 4 + length($$newcom_packref) + length $pictures;
my $header=VORBIS_COMMENT;
my $inplace=($padding==0 || ($padding>3 && $padding<8192) );
if ($padding==0) {$header+=0x80;$padding='';}
else
{ $padding=$inplace? $padding-4 : 256;
$padding=pack "Nx$padding",((0x80+PADDING)<<24)+$padding;
}
$header=pack 'N',($header<<24)+length $$newcom_packref;
if ($inplace)
{ $self->_close;
$fh=$self->_openw or return undef;
seek $fh,$self->{startaudio} ,0;
print $fh $towrite.$pictures.$header.$$newcom_packref.$padding or warn $!;
$self->_close;
}
else
{ my $tmpfh=$self->_openw(1) or return undef;
if ($self->{startaudio})
{ seek $fh,0,0;
read($fh,$buffer,$self->{startaudio});
print $tmpfh $buffer or warn $!;
}
print $tmpfh $towrite.$pictures.$header.$$newcom_packref.$padding or warn $!;
while (read($fh,$buffer,1048576))
{ print $tmpfh $buffer or warn $!; }
$self->_close;
close $tmpfh;
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 _close
{ my $self=shift;
close delete($self->{fileHandle});
}
sub _ReadInfo
{ my $packref=$_[0];
my @v=unpack 'nn CnCn nCCN',$$packref;
#A16 B16 C8 C16 D8 D16 E16 EEEEFFFG GGGGHHHH H32 I128
#A <16> The minimum block size (in samples) used in the stream
#B <16> The maximum block size (in samples) used in the stream. (Minimum blocksize == maximum blocksize) implies a fixed-blocksize stream.
#C <24> The minimum frame size (in bytes) used in the stream. May be 0 to imply the value is not known.
#D <24> The maximum frame size (in bytes) used in the stream. May be 0 to imply the value is not known.
#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.
#F <3> (number of channels)-1. FLAC supports from 1 to 8 channels
#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
#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.
#I <128> MD5 signature of the unencoded audio data
my %info;
$info{min_block_size}=$v[0];
$info{max_block_size}=$v[1];
$info{min_frame_size}=($v[2]<<16)+$v[3];
$info{max_frame_size}=($v[4]<<16)+$v[5];
$info{rate}=($v[6]<<4)+($v[7]>>4);
$info{channels}=1+( ($v[7] & 0b1110)>>1 );
$info{bit_per_sample}=1+( ($v[7] & 0b1)<<5 )+( $v[8] >>4 );
$info{seconds}=( $v[9]+($v[8] & 0b1111)*2**32 )/$info{rate};
return \%info;
}
sub _ReadPicture
{ my $packref=$_[0];
my $ret;
eval
{ my ($type,$mime,$desc,undef,undef,undef,undef,$data)
=unpack 'N N/a N/a NNNN N/a',$$packref;
$ret=[$mime,$type,$desc,$data];
};
if ($@) { warn "invalid picture block - skipped\n"; }
return $ret;
}
sub _PackPicture
{ my $pic=shift;
if (!ref $pic) { my $packet=decode_base64($pic); return \$packet; }
my ($mime,$type,$desc,$data)=@$pic;
my $packet= pack 'N N/a N/a NNNN N/a', ($type||0),$mime,$desc,0,0,0,0, $data;
return \$packet;
}
sub _UnpackComments
{ my ($self,$packref)=@_;
my ($vstring,@comlist)= eval { unpack 'V/a V/(V/a)',$$packref; };
if ($@) { warn "Comments corrupted\n"; return undef; }
$self->{vorbis_string}=$vstring;
my %comments;
for my $kv (@comlist)
{ unless ($kv=~m/^([^=]+)=(.*)$/s) { warn "comment invalid - skipped\n"; next; }
my $key=$1;
my $val=decode('utf-8', $2);
#warn "$key = $val\n";
push @{ $comments{lc$key} },$val;
push @{$self->{CommentsOrder}}, $key;
}
return \%comments;
}
sub _PackComments
{ my $self=$_[0];
my @comments;
my %count;
for my $key ( @{$self->{CommentsOrder}} )
{ my $nb=$count{lc$key}++ || 0;
my $val=$self->{comments}{lc$key}[$nb];
next unless defined $val;
$key=encode('ascii',$key);
$key=~tr/\x20-\x7D/?/c; $key=~tr/=/?/; #replace characters that are not allowed by '?'
push @comments,$key.'='.encode('utf8',$val);
}
my $packet=pack 'V/a* V (V/a*)*',$self->{vorbis_string},scalar @comments, @comments;
#$packet.="\x01"; #framing_flag #gstreamer doesn't like it and not needed anyway
return \$packet;
}
1;
Jump to Line
Something went wrong with that request. Please try again.