package Audio::Wav::Write::Header;
use strict;
eval { require warnings; }; #it's ok if we can't load warnings
use vars qw( $VERSION );
$VERSION = '0.13';
sub new {
my ($class, $file, $details, $tools, $handle) = @_;
my $self = {
'file' => $file,
'data' => undef,
'details' => $details,
'tools' => $tools,
'handle' => $handle,
'whole_offset' => 4,
};
bless $self, $class;
return $self;
}
sub start {
my $self = shift;
my $output = 'RIFF';
$output .= pack 'V', 0;
$output .= 'WAVE';
my $format = $self -> _format();
$output .= 'fmt ' . pack( 'V', length $format ) . $format;
$output .= 'data';
my $data_off = length $output;
$output .= pack 'V', 0;
$self -> {'data_offset'} = $data_off;
$self -> {'total'} = length( $output ) - 8;
return $output;
}
sub finish {
my $self = shift;
my $data_size = shift;
my $handle = $self -> {'handle'};
# padding data chunk
my $data_pad=0;
if ( $data_size % 2 ) {
my $pad = "\0";
syswrite $handle, $pad, 1;
$data_pad = 1; # to add to whole_num, not data_num
}
my $extra = $self -> _write_list_info();
$extra += $self -> _write_cues();
$extra += $self -> _write_list_adtl();
$extra += $self -> _write_display();
$extra += $self -> _write_sampler_info();
my $whole_num = pack 'V', $self -> {'total'} + $data_size + $data_pad + $extra; #includes padding
my $len_long = length $whole_num;
# RIFF-length
my $seek_to = $self -> {'whole_offset'};
seek( $handle, $seek_to, 0 ) || return $self -> _error( "unable to seek to $seek_to ($!)" );
syswrite $handle, $whole_num, $len_long;
# data-length
$seek_to = $self -> {'data_offset'};
seek( $handle, $seek_to, 0 ) || return $self -> _error( "unable to seek to $seek_to ($!)" );
my $data_num = pack 'V', $data_size;
syswrite $handle, $data_num, $len_long;
return 1;
}
sub add_cue {
my $self = shift;
my $record = shift;
push @{ $self -> {'cues'} }, $record;
return 1;
}
sub add_display {
my ($self, %hash) = @_;
unless ( exists $hash{'id'} && exists $hash{'data'} ) {
return $self -> _error( 'I need fields id & data to add a display block' );
}
push @{ $self -> {'display'} }, { map { $_ => $hash{$_} } qw( id data ) };
return 1;
}
sub set_sampler_info {
my ($self, %hash) = @_;
my %defaults = $self -> {'tools'} -> get_sampler_defaults();
foreach my $key ( keys %defaults ) {
next if exists $hash{$key};
$hash{$key} = $defaults{$key};
}
$hash{'sample_loops'} = 0;
$hash{'loop'} = [];
$self -> {'sampler'} = \%hash;
return 1;
}
sub add_sampler_loop {
my ($self, %hash) = @_;
foreach my $need ( qw( start end ) ) {
if ( exists $hash{$need} ) {
$hash{$need} = int $hash{$need};
} else {
return $self -> _error( "missing $need field from add_sampler_loop" );
}
}
my %defaults = $self -> {'tools'} -> get_sampler_loop_defaults();
foreach my $key ( keys %defaults ) {
next if exists $hash{$key};
$hash{$key} = $defaults{$key};
}
unless ( exists $self -> {'sampler'} ) {
$self -> set_sampler_info();
}
my $sampler = $self -> {'sampler'};
my $id = scalar( @{ $sampler -> {'loop'} } ) + 1;
foreach my $key ( qw( id play_count ) ) {
next if exists $hash{$key};
$hash{$key} = $id;
}
push @{ $sampler -> {'loop'} }, \%hash;
$sampler -> {'sample_loops'} ++;
return 1;
}
sub _write_list_adtl {
my $self = shift;
return 0 unless $self -> {'cues'};
my $cues = $self -> {'cues'};
my %adtl;
foreach my $id ( 0 .. $#{$cues} ) {
my $cue = $cues -> [$id];
my $cue_id = $id + 1;
if ( exists $cue -> {'label'} ) {
$adtl{'labl'} -> {$cue_id} = $cue -> {'label'};
}
if ( exists $cue -> {'note'} ) {
$adtl{'note'} -> {$cue_id} = $cue -> {'note'};
}
}
return 0 unless ( keys %adtl );
my $adtl = 'adtl';
foreach my $type ( sort keys %adtl ) {
foreach my $id ( sort { $a <=> $b } keys %{ $adtl{$type} } ) {
$adtl .= $self -> _make_chunk( $type, pack( 'V', $id ) . $adtl{$type} -> {$id} . "\0" );
}
}
return $self -> _write_block( 'LIST', $adtl );
}
sub _write_list_info {
my $self = shift;
return 0 unless keys %{ $self -> {'details'} -> {'info'} };
my $info = $self -> {'details'} -> {'info'};
my %allowed = $self -> {'tools'} -> get_rev_info_fields();
my $list='INFO';
foreach my $key ( keys %{$info} ) {
next unless $allowed{$key}; # don't write unknown info-chunks
$list .= $self -> _make_chunk( $allowed{$key}, $info -> {$key} . "\0" );
}
return $self -> _write_block( 'LIST', $list );
}
sub _write_cues {
my $self = shift;
return 0 unless $self -> {'cues'};
my $cues = $self -> {'cues'};
my @fields = qw( id position chunk cstart bstart offset );
my %plain = ( 'chunk' => 1 );
my %defaults;
my $output = pack 'V', scalar @{$cues};
foreach my $id ( 0 .. $#{$cues} ) {
my $cue = $cues -> [$id];
my $pos = $cue -> {'pos'};
my %record = (
'id' => $id + 1,
'position' => $pos,
'chunk' => 'data',
'cstart' => 0,
'bstart' => 0,
'offset' => $pos,
);
foreach my $field ( @fields ) {
my $data = $record{$field};
$data = pack 'V', $data unless exists $plain{$field};
$output .= $data;
}
}
my $data_len = length $output;
return 0 unless $data_len;
$output = 'cue ' . pack( 'V', $data_len ) . $output;
$data_len += 8;
syswrite $self -> {'handle'}, $output, $data_len;
return $data_len;
}
sub _write_sampler_info {
my $self = shift;
return 0 unless exists $self -> {'sampler'};
my $sampler = $self -> {'sampler'};
my %sampler_fields = $self -> {'tools'} -> get_sampler_fields();
my $output = '';
foreach my $field ( @{ $sampler_fields{'fields'} } ) {
$output .= pack 'V', $sampler -> {$field};
}
foreach my $loop ( @{ $sampler -> {'loop'} } ) {
foreach my $loop_field ( @{ $sampler_fields{'loop'} } ) {
$output .= pack 'V', $loop -> {$loop_field};
}
}
return $self -> _write_block( 'smpl', $output );
}
sub _write_display {
my $self = shift;
return 0 unless exists $self -> {'display'};
my $total = 0;
foreach my $display ( @{ $self -> {'display'} } ) {
my $data = $display -> {'data'};
my $output = pack( 'V', $display -> {'id'} ) . $data;
my $data_size = length $data;
$total .= $self -> _write_block( 'DISP', $output );
}
return $total;
}
sub _write_block {
my $self = shift;
my $header = shift;
my $output = shift;
return unless $output;
$output = $self->_make_chunk( $header, $output );
return syswrite $self -> {'handle'}, $output, length $output;
}
sub _make_chunk {
my $self = shift;
my $header = shift;
my $output = shift;
my $data_len = length $output;
return '' unless $data_len;
$output .= "\0" if $data_len % 2; # pad byte
return $header . pack( 'V', $data_len ) . $output;
}
sub _format {
my $self = shift;
my $details = $self -> {'details'};
my $types = $self -> {'tools'} -> get_wav_pack();
my $wave_ex = exists( $details -> {'wave-ex'} ) && $details -> {'wave-ex'} ? 1 : 0;
$details -> {'format'} = $wave_ex ? 65534 : 1;
my $output;
foreach my $type ( @{ $types -> {'order'} } ) {
$output .= pack $types -> {'types'} -> {$type}, $details -> {$type};
}
return $output;
}
sub _error {
my ($self, @args) = @_;
return $self -> {'tools'} -> error( $self -> {'file'}, @args );
}
1;