Permalink
Fetching contributors…
Cannot retrieve contributors at this time
551 lines (510 sloc) 17 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://xiph.org/vorbis/doc/framing.html
#http://xiph.org/vorbis/doc/v-comment.html
package Tag::OGG;
use strict;
use warnings;
use Encode qw(decode encode);
use MIME::Base64;
use constant
{ PACKET_INFO => 1,
PACKET_COMMENT => 3,
PACKET_SETUP => 5,
};
my @crc_lookup;
my $digestcrc;
INIT
{ eval
{ require Digest::CRC;
$digestcrc=Digest::CRC->new(width=>32, init=>0, xorout=>0, poly=>0x04C11DB7, refin=>0, refout=>0);
warn "oggheader.pm : using Digest::CRC\n" if $::debug;
};
if ($@)
{ warn "oggheader.pm : Digest::CRC not found, using slow pure-perl replacement.\n" if $::debug;
@crc_lookup=
(0x00000000,0x04c11db7,0x09823b6e,0x0d4326d9,
0x130476dc,0x17c56b6b,0x1a864db2,0x1e475005,
0x2608edb8,0x22c9f00f,0x2f8ad6d6,0x2b4bcb61,
0x350c9b64,0x31cd86d3,0x3c8ea00a,0x384fbdbd,
0x4c11db70,0x48d0c6c7,0x4593e01e,0x4152fda9,
0x5f15adac,0x5bd4b01b,0x569796c2,0x52568b75,
0x6a1936c8,0x6ed82b7f,0x639b0da6,0x675a1011,
0x791d4014,0x7ddc5da3,0x709f7b7a,0x745e66cd,
0x9823b6e0,0x9ce2ab57,0x91a18d8e,0x95609039,
0x8b27c03c,0x8fe6dd8b,0x82a5fb52,0x8664e6e5,
0xbe2b5b58,0xbaea46ef,0xb7a96036,0xb3687d81,
0xad2f2d84,0xa9ee3033,0xa4ad16ea,0xa06c0b5d,
0xd4326d90,0xd0f37027,0xddb056fe,0xd9714b49,
0xc7361b4c,0xc3f706fb,0xceb42022,0xca753d95,
0xf23a8028,0xf6fb9d9f,0xfbb8bb46,0xff79a6f1,
0xe13ef6f4,0xe5ffeb43,0xe8bccd9a,0xec7dd02d,
0x34867077,0x30476dc0,0x3d044b19,0x39c556ae,
0x278206ab,0x23431b1c,0x2e003dc5,0x2ac12072,
0x128e9dcf,0x164f8078,0x1b0ca6a1,0x1fcdbb16,
0x018aeb13,0x054bf6a4,0x0808d07d,0x0cc9cdca,
0x7897ab07,0x7c56b6b0,0x71159069,0x75d48dde,
0x6b93dddb,0x6f52c06c,0x6211e6b5,0x66d0fb02,
0x5e9f46bf,0x5a5e5b08,0x571d7dd1,0x53dc6066,
0x4d9b3063,0x495a2dd4,0x44190b0d,0x40d816ba,
0xaca5c697,0xa864db20,0xa527fdf9,0xa1e6e04e,
0xbfa1b04b,0xbb60adfc,0xb6238b25,0xb2e29692,
0x8aad2b2f,0x8e6c3698,0x832f1041,0x87ee0df6,
0x99a95df3,0x9d684044,0x902b669d,0x94ea7b2a,
0xe0b41de7,0xe4750050,0xe9362689,0xedf73b3e,
0xf3b06b3b,0xf771768c,0xfa325055,0xfef34de2,
0xc6bcf05f,0xc27dede8,0xcf3ecb31,0xcbffd686,
0xd5b88683,0xd1799b34,0xdc3abded,0xd8fba05a,
0x690ce0ee,0x6dcdfd59,0x608edb80,0x644fc637,
0x7a089632,0x7ec98b85,0x738aad5c,0x774bb0eb,
0x4f040d56,0x4bc510e1,0x46863638,0x42472b8f,
0x5c007b8a,0x58c1663d,0x558240e4,0x51435d53,
0x251d3b9e,0x21dc2629,0x2c9f00f0,0x285e1d47,
0x36194d42,0x32d850f5,0x3f9b762c,0x3b5a6b9b,
0x0315d626,0x07d4cb91,0x0a97ed48,0x0e56f0ff,
0x1011a0fa,0x14d0bd4d,0x19939b94,0x1d528623,
0xf12f560e,0xf5ee4bb9,0xf8ad6d60,0xfc6c70d7,
0xe22b20d2,0xe6ea3d65,0xeba91bbc,0xef68060b,
0xd727bbb6,0xd3e6a601,0xdea580d8,0xda649d6f,
0xc423cd6a,0xc0e2d0dd,0xcda1f604,0xc960ebb3,
0xbd3e8d7e,0xb9ff90c9,0xb4bcb610,0xb07daba7,
0xae3afba2,0xaafbe615,0xa7b8c0cc,0xa379dd7b,
0x9b3660c6,0x9ff77d71,0x92b45ba8,0x9675461f,
0x8832161a,0x8cf30bad,0x81b02d74,0x857130c3,
0x5d8a9099,0x594b8d2e,0x5408abf7,0x50c9b640,
0x4e8ee645,0x4a4ffbf2,0x470cdd2b,0x43cdc09c,
0x7b827d21,0x7f436096,0x7200464f,0x76c15bf8,
0x68860bfd,0x6c47164a,0x61043093,0x65c52d24,
0x119b4be9,0x155a565e,0x18197087,0x1cd86d30,
0x029f3d35,0x065e2082,0x0b1d065b,0x0fdc1bec,
0x3793a651,0x3352bbe6,0x3e119d3f,0x3ad08088,
0x2497d08d,0x2056cd3a,0x2d15ebe3,0x29d4f654,
0xc5a92679,0xc1683bce,0xcc2b1d17,0xc8ea00a0,
0xd6ad50a5,0xd26c4d12,0xdf2f6bcb,0xdbee767c,
0xe3a1cbc1,0xe760d676,0xea23f0af,0xeee2ed18,
0xf0a5bd1d,0xf464a0aa,0xf9278673,0xfde69bc4,
0x89b8fd09,0x8d79e0be,0x803ac667,0x84fbdbd0,
0x9abc8bd5,0x9e7d9662,0x933eb0bb,0x97ffad0c,
0xafb010b1,0xab710d06,0xa6322bdf,0xa2f33668,
0xbcb4666d,0xb8757bda,0xb5365d03,0xb1f740b4
);}
}
#hash fields :
# filename
# fileHandle
# serial serial number (binary 4 bytes)
# seg_table segmentation table of last read page
# granule granule of last read page
# info -> hash containing : version channels rate bitrate_upper bitrate_nominal bitrate_lower seconds
# comments -> hash of arrays (lowercase keys)
# CommentsOrder -> list of keys (mixed-case keys)
# commentpack_size
# vorbis_string
# stream_vers
# end
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->{info}=_ReadInfo($self);
last unless $self->{info};
$self->{comments}=_ReadComments($self);
last unless $self->{comments};
$self->{end}=_skip_to_last_page($self);
_read_packet($self,0) unless $self->{end};
warn "file truncated or corrupted.\n" unless $self->{end};
#calulate length
last unless $self->{info}{rate};# && $self->{end};
my @granule=unpack 'C*',$self->{granule};
my $l=0;
$l=$l*256+$_ for reverse @granule;
$self->{info}{seconds}=my$s=$l/$self->{info}{rate};
}
$self->_close;
unless ($self->{info} && $self->{comments})
{ warn "error, can't read file or not a valid ogg 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;
$self->{seg_table} = [];
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;
$self->{seg_table} = [];
}
return $fh;
}
sub _close
{ my $self=shift;
$self->{seg_table} = undef;
close delete($self->{fileHandle});
}
sub write_file
{ my $self=shift;
my $newcom_packref=_PackComments($self);
#warn "old size $self->{commentpack_size}, need : ".length($$newcom_packref)."\n";
if ( $self->{commentpack_size} >= length $$newcom_packref)
{ warn "in place editing.\n";
my $left=length $$newcom_packref;
my $offset2=0;
my $fh=$self->_openw or return;
_read_packet($self,PACKET_INFO); #skip first page
while ($left)
{ my $pos=tell $fh;
my ($pageref,$offset,$size)=_ReadPage($self);
seek $fh,$pos,0;
if ($left<$size) {$size=$left; $left=0;}
else {$left-=$size}
substr $$pageref,$offset,$size,substr($$newcom_packref,$offset2,$size);
$offset2+=$size;
_recompute_page_crc($pageref);
print $fh $$pageref or warn $!;
}
$self->_close;
return;
}
my $INfh=$self->_open or return;
my $OUTfh=$self->_openw(1) or return; #open .TEMP file
my $version=chr $self->{stream_vers};
my $serial=$self->{serial};
my $pageref=_ReadPage($self); #read the first page
die unless $pageref; #FIXME check serial, OggS ...
print $OUTfh $$pageref or warn $!; #write the first page unmodified
my $pagenb=1;
#skip the comment packet in the original file
die unless _read_packet($self,PACKET_COMMENT);
#concatenate newly generated comment packet and setup packet from the original file in $data, and compute the segments in @segments
my $data;
my @segments;
for my $packref ( $newcom_packref , _read_packet($self,PACKET_SETUP) )
{ $data.=$$packref;
my $size=length $$packref;
push @segments, (255)x int($size/255), $size%255;
}
#separate $data in pages and write them
my $data_offset=0;
my $continued=0;
{ my $size=0;
my $segments;
my $nbseg=0;
my $seg;
while ($size<4096) # make page of max 4095+255 bytes
{ last unless @segments;
$seg=shift @segments;
$size+=$seg;
$segments.=chr $seg;
$nbseg++;
}
#warn unpack('C*',$segments),"\n";
#warn "$size ",length($data)-$data_offset,"\n";
warn "writing page $pagenb\n" if $::debug;
my $page=pack('a4aa x8 a4 V x4 C','OggS',$version,$continued,$serial,$pagenb++,$nbseg).$segments.substr($data,$data_offset,$size);
_recompute_page_crc(\$page);
print $OUTfh $page or warn $!;
$data_offset+=$size;
$continued=($seg==255)? "\x01" : "\x00";
redo if @segments;
}
# copy AUDIO data
my $pos=tell $INfh; read $INfh,$data,27; seek $INfh,$pos,0;
#warn "first audio data on page ".unpack('x18V',$data)."\n";
# fast raw copy by 1M chunks if page numbers haven't changed
if ( substr($data,0,4) eq 'OggS' && unpack('x18V',$data) eq $pagenb)
{ my $buffer;
print $OUTfh $buffer or warn $! while read $INfh,$buffer,1048576;
}
# __SLOW__ copy if page number must be changed -> and crc recomputed
else
{ warn "must recompute crc for the whole file, this may take a while (install Digest::CRC to make it fast) ...\n" unless $digestcrc;
while (my $pageref=_ReadPage($self)) # read each page
{ substr $$pageref,18,4,pack('V',$pagenb++); #replace page number
_recompute_page_crc($pageref); #recompute crc
print $OUTfh $$pageref or warn $!; #write page
}
}
$self->_close;
close $OUTfh;
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 _ReadPage
{ my $self=shift;
my $fh=$self->{fileHandle};
my $page;
my $r=read $fh,$page,27; #read page header
return undef unless $r==27 && substr($page,0,4) eq 'OggS';
my $segments=vec $page,26,8;
$r=read $fh,$page,$segments,27; #read segment table
return undef unless $r==$segments;
my $size;
#$size+=ord substr($page,$_,1) for (27..$segments+26);
$size+=vec($page,$_,8) for (27..$segments+26);
$r=read $fh,$page,$size,27+$segments; #read page data
return undef unless $r==$size;
return wantarray ? (\$page,27+$segments,$size) : \$page;
}
sub _ReadInfo
{ my $self=shift;
#$self->{startaudio}=0;
# 1) [vorbis_version] = read 32 bits as unsigned integer
# 2) [audio_channels] = read 8 bit integer as unsigned
# 3) [audio_sample_rate] = read 32 bits as unsigned integer
# 4) [bitrate_maximum] = read 32 bits as signed integer
# 5) [bitrate_nominal] = read 32 bits as signed integer
# 6) [bitrate_minimum] = read 32 bits as signed integer
# 7) [blocksize_0] = 2 exponent (read 4 bits as unsigned integer)
# 8) [blocksize_1] = 2 exponent (read 4 bits as unsigned integer)
# 9) [framing_flag] = read one bit
if ( my $packref=_read_packet($self,PACKET_INFO) )
{ my %info;
@info{qw/version channels rate bitrate_upper bitrate_nominal bitrate_lower/}= unpack 'x7 VCV V3 C',$$packref;
return \%info;
}
else
{ warn "Can't read info\n";
return undef;
}
}
sub _ReadComments
{ my $self=$_[0];
if ( my $packref= _read_packet($self,PACKET_COMMENT) )
{ $self->{commentpack_size}=length $$packref;
my ($vstring,@comlist)=eval { unpack 'x7 V/a V/(V/a)',$$packref; };
if ($@) { warn "Comments corrupted\n"; return undef; }
# Comments vendor strings I have found
# 'Xiph.Org libVorbis I 20030909' : 1.0.1
# 'Xiph.Org libVorbis I 20020717' : 1.0 release of libvorbis
# 'Xiphophorus libVorbis I 200xxxxx' : 1.0_beta1 to 1.0_rc3
# 'AO; aoTuV b3 [20041120] (based on Xiph.Org's libVorbis)'
$self->{vorbis_string}=$vstring;
if ($::debug && $vstring!~m/^Xiph.* libVorbis I (\d{8})/)
{ warn "unknown comments vendor string : $vstring\n"; }
my %comments;
my @order;
$self->{CommentsOrder}=\@order;
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 @order, $key;
}
if (my $covers=$comments{coverart}) #upgrade old embedded pictures format to metadata_block_picture
{ @order= grep !m/^coverart/i, @order;
for my $i (0..$#$covers)
{ my $data= $comments{"coverart"}[$i];
next unless $data;
my @val= ( map( $comments{"coverart$_"}[$i], qw/mime type description/ ), decode_base64($data) );
push @{$comments{metadata_block_picture}}, \@val;
push @order, 'METADATA_BLOCK_PICTURE';
}
delete $comments{"coverart$_"} for qw/mime type description/,'';
}
return \%comments;
}
else
{ warn "Can't find comments\n";
return undef;
}
}
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 '?'
if (uc$key eq 'METADATA_BLOCK_PICTURE' && ref $val)
{ $val= Tag::Flac::_PackPicture($val);
$val= encode_base64($$val);
}
push @comments,$key.'='.encode('utf8',$val);
}
my $packet=pack 'Ca6 V/a* V (V/a*)*',PACKET_COMMENT,'vorbis',$self->{vorbis_string},scalar @comments, @comments;
$packet.="\x01"; #framing_flag
return \$packet;
}
sub edit
{ my ($self,$key,$nb,$val)=@_;
$nb||=0;
my $aref=$self->{comments}{lc$key};
return unless $aref && @$aref >=$nb;
$aref->[$nb]= $val;
return 1;
}
sub add
{ my ($self,$key,$val)=@_;
push @{ $self->{comments}{lc$key} }, $val;
push @{$self->{CommentsOrder}}, $key;
return 1;
}
sub insert #same as add but put it first (of its kind)
{ my ($self,$key,$val)=@_;
unshift @{ $self->{comments}{lc$key} }, $val;
push @{$self->{CommentsOrder}}, $key;
return 1;
}
sub remove_all
{ my ($self,$key)=@_;
return undef unless defined $key;
$key=lc$key;
$_=undef for @{ $self->{comments}{$key} };
return 1;
}
sub get_keys
{ keys %{ $_[0]{comments} };
}
sub get_values
{ my ($self,$key)=($_[0],lc$_[1]);
my $v= $self->{comments}{$key};
return () unless $v;
if ($key eq 'metadata_block_picture')
{ for my $val (@$v)
{ next if ref $val or !defined $val;
my $dec=decode_base64($val);
$val= $dec ? Tag::Flac::_ReadPicture(\$dec) : undef;
}
}
return grep defined, @$v;
}
sub remove
{ my ($self,$key,$nb)=@_;
return undef unless defined $key and $nb=~m/^\d*$/;
$nb||=0;
$key=lc$key;
my $val=$self->{comments}{$key}[$nb];
unless (defined $val) {warn "comment to delete not found\n"; return undef; }
$self->{comments}{$key}[$nb]=undef;
return 1;
}
sub _read_packet
{ my $self=shift;
my $wantedtype=shift; #wanted type, 0 to read all packets until eof
my $fh=$self->{fileHandle};
my $packet;
do
{ my $lpacket=0;
my $seg_table=$self->{seg_table};
my $lastseg;
until ($lastseg)
{ my $size;
unless ( @$seg_table ) { _read_page_header($self) || return undef }
while (defined( my $byte=shift @$seg_table ))
{ $size+=$byte;
unless ($byte==255) { $lastseg=1; last; }
}
next unless $size;
my $read=read $fh,$packet,$size,$lpacket;
return undef unless $size==$read;
$lpacket+=$read;
}
} until ($wantedtype || $self->{end});
my ($type,$vorbis)=unpack 'Ca6',$packet;
warn "read packet : $type $vorbis length=".length($packet)."\n" if $::debug;
if ( $type==$wantedtype && $vorbis eq 'vorbis') { return \$packet; }
else { return undef; }
}
sub _read_page_header
{ my $self=shift;
my $fh=$self->{fileHandle};
my $buf;
my $r=read $fh,$buf,27;
return 0 unless $r==27;
#http://www.xiph.org/ogg/vorbis/doc/framing.html
# 'OggS' 4 bytes capture_pattern 0
# 0x00 1 byte stream_structure_version 1
# 1 byte header_type_flag 2
# 8 bytes absolute granule position 3
# 4 bytes stream serial number 4
# 4 bytes page sequence no 5
# 4 bytes page checksum 6
# 1 byte page_segments 7
#
#warn "OggS : ".join(' ',unpack('a4CC a8 VVVC',$buf))."\n";
my ($captpat,$ver,$flags,$granule,$sn,$nbseg)=unpack 'a4CC a8 a4 x8 C',$buf;
return undef unless $captpat eq 'OggS' and $ver eq 0;
if ($self->{serial} && $self->{serial} ne $sn) {warn "corrupted page : serial number doesn't match\n";return undef}
$self->{end}=$flags & 4;
$self->{serial}=$sn;
$self->{stream_vers}=$ver;
$self->{granule}=$granule;
return undef unless read($fh,$buf,$nbseg)==$nbseg;
@{ $self->{seg_table} }=unpack 'C*',$buf;
#warn " seg_table: ".join(' ',@{ $self->{seg_table} })."\n";
return 1;
}
sub _recompute_page_crc
{ my $pageref=$_[0];
#warn 'old crc : ',unpack('V',substr($$pageref,22,4)),"\n";
substr $$pageref,22,4,"\x00\x00\x00\x00";
my $crc=0;
if ($digestcrc) { $digestcrc->add($$pageref); $crc=$digestcrc->digest; }
else # pure-perl : SLOW
{ #$crc=($crc<<8)^vec($crc_lookup, ($crc>>24)^vec($$pageref,$_,8) ,32); # a bit slower
#$crc=($crc<<8)^$crc_lookup[ ($crc>>24)^vec($$pageref,$_,8) ] #doesn't work if perl use 64bits
$crc=(($crc<<8)&0xffffffff)^$crc_lookup[ ($crc>>24)^vec($$pageref,$_,8) ]
for (0 .. length($$pageref)-1);
}
#warn "new crc : $crc\n";
substr $$pageref,22,4,pack('V',$crc);
}
sub _skip_to_last_page
{ my $self=shift;
my $fh=$self->{fileHandle};
my $pos=tell $fh;
seek $fh,-10000,2;
read $fh,my$buf,10000;
my $sn=$self->{serial};
my $granule;
while ($buf=~m/OggS\x00(.)(.{8})(.{4})/gs)
{ #@_=unpack "a4CC a8 VVVC",$1;
next unless $sn eq $3; #check serial number
$granule=$2 unless $2 eq "\xff\xff\xff\xff\xff\xff\xff\xff"; #granule==-1 => no packets finish on this page
next unless vec $1,2,1; #last page of logical bitstream
last unless defined $granule;
# found last page -> save granule
$self->{granule}=$granule;
return 1;
}
#didn't find last page
seek $fh,$pos,0;
return 0;
}
1;