File Coverage

blib/lib/Audio/Wav/Write.pm

Criterion	Covered	Total	%
statement	146	168	86.9
branch	40	62	64.5
condition	5	9	55.5
subroutine	19	22	86.3
pod	10	11	90.9
total	220	272	80.8

package Audio::Wav::Write;

use strict;
eval { require warnings; }; #it's ok if we can't load warnings

use FileHandle;
use Audio::Wav::Write::Header;

use vars qw( $VERSION );
$VERSION = '0.14';

=head1 NAME

Audio::Wav::Write - Module for writing Microsoft WAV files.

=head1 SYNOPSIS

    use Audio::Wav;

    my $wav = new Audio::Wav;

    my $sample_rate = 44100;
    my $bits_sample = 16;

    my $details = {
	'bits_sample'	=> $bits_sample,
	'sample_rate'	=> $sample_rate,
	'channels'	=> 1,
	# if you'd like this module not to use a write cache, uncomment the next line
	#'no_cache'	=> 1,

    };

    my $write = $wav -> write( 'testout.wav', $details );

    &add_sine( 200, 1 );

    sub add_sine {
	my $hz = shift;
	my $length = shift;
	my $pi = ( 22 / 7 ) * 2;
	$length *= $sample_rate;
	my $max_no =  ( 2 ** $bits_sample ) / 2 - 1;
	for my $pos ( 0 .. $length ) {
	    $time = $pos / $sample_rate;
	    $time *= $hz;
	    my $val = sin $pi * $time;
	    my $samp = $val * $max_no;
	    $write -> write( $samp );
	}
    }

    $write -> finish();

=head1 DESCRIPTION

Currently only writes to a file.

=head1 SEE ALSO

L

L

=head1 NOTES

This module shouldn't be used directly, a blessed object can be returned from L.

=head1 METHODS

=cut

sub new {
    my $class = shift;
    my $out_file = shift;
    my $details = shift;
    my $tools = shift;

    my $handle = (ref $out_file eq 'GLOB') ? $out_file : new FileHandle ">$out_file";

    my $use_cache = 1;
    if ( ref $details eq 'HASH' && exists $details -> {no_cache} ) {
        my $no_cache = delete $details -> {no_cache};
        $use_cache = 0 if $no_cache;
    }

    my $self = {
        'use_cache'   => $use_cache,
        'write_cache' => undef,
        'out_file'    => $out_file,
        'cache_size'  => 4096,
        'handle'      => $handle,
        'details'     => $details,
        'block_align' => $details -> {block_align},
        'tools'       => $tools,
        'done_finish' => 0,
    };

    bless $self, $class;

    unless ( defined $handle ) {
        my $error = $!;
        chomp $error;
        $self -> _error( "unable to open file ($error)" );
        return $self;
    }

    binmode $handle;

    $self -> _init();
    $self -> _start_file();
    $self -> _examine_details( $details );

    if ( $self -> {details} -> {bits_sample} <= 8 ) {
        $self -> {use_offset} = ( 2 ** $self -> {details} -> {bits_sample} ) / 2;
    } else {
        $self -> {use_offset} = 0;
    }

    return $self;
}

sub DESTROY {
    my $self = shift;
    return unless $self;
    return if $self -> {done_finish};
    $self -> finish();
}

=head2 finish

Finishes off & closes the current wav file.

    $write -> finish();

=cut

sub finish {
    my $self = shift;
    $self -> _purge_cache() if $self -> {use_cache};
    $self -> {header} -> finish( $self -> {pos} );
    $self -> {handle} -> close();
    $self -> {done_finish} = 1;
}

=head2 add_cue

Adds a cue point to the wav file. If $sample is undefined then the position will be the current position (end of all data written so far).

    # $byte_offset for 01 compatibility mode
    $write -> add_cue( $sample, "label", "note"  );

=cut

sub add_cue {
    my $self = shift;
    my $pos = shift;
    my $label = shift;
    my $note = shift;
    my $block_align = $self -> {details} -> {block_align};
    if ( defined $pos ) {
        $pos /= $block_align if $self -> {tools} -> is_01compatible();
    } else {
        $pos = $self -> {pos} / $block_align;
    }
    my $output = {
        'pos' => $pos,
    };
    $output -> {label} = $label if $label;
    $output -> {note} = $note if $note;
    $self -> {header} -> add_cue( $output );
}

=head2 set_sampler_info

All parameters are optional.

    my %info = (
        'midi_pitch_fraction' => 0,
        'smpte_format'        => 0,
        'smpte_offset'        => 0,
        'product'             => 0,
        'sample_period'       => 0,
        'manufacturer'        => 0,
        'sample_data'         => 0,
        'midi_unity_note'     => 65,
    );
    $write -> set_sampler_info( %info );

=cut

sub set_sampler_info {
    my ($self, @args) = @_;
    return $self -> {header} -> set_sampler_info( @args );
}

=head2 add_sampler_loop

All parameters are optional except start & end.

    my $length = $read -> length_samples();
    my( $third, $twothirds ) = map int( $length / $_ ), ( 3, 1.5 );
    my %loop = (
	'start'			=> $third,
	'end'			=> $twothirds,
	'fraction'		=> 0,
	'type'			=> 0,
    );
    $write -> add_sampler_loop( %loop );

=cut

sub add_sampler_loop {
    my ($self, @args) = @_;
    return $self -> {header} -> add_sampler_loop( @args );
}

=head2 add_display

=cut

sub add_display {
    my ($self, @args) = @_;
    return $self -> {header} -> add_display( @args );
}

=head2 set_info

Sets information to be contained in the wav file.

    $write -> set_info( 'artist' => 'Nightmares on Wax', 'name' => 'Mission Venice' );

=cut

sub set_info {
    my ($self, %info) = @_;
    $self -> {details} -> {info} = { %{ $self -> {details} -> {info} }, %info };
}

=head2 file_name

Returns the current filename.

    my $file = $write -> file_name();

=cut

sub file_name {
    my $self = shift;
    return $self -> {out_file};
}

=head2 write

Adds a sample to the current file.

    $write -> write( @sample_channels );

Each element in @sample_channels should be in the range of;

    where $samp_max = ( 2 ** bits_per_sample ) / 2
    -$samp_max to +$samp_max

=cut

sub write {
    my ($self, @args) = @_;
    my $channels = $self -> {details} -> {channels};
    if ( $self -> {use_offset} ) {
        return $self -> write_raw( pack 'C'.$channels, map { $_ + $self -> {use_offset} } @args );
    } else {
        #TODO: performance: when we move to _init_write_sub, just use:
        #32: pack 'V1', ...
        #24: substr pack('V1', ...), 3
        #16: pack 'v1', ...
        my $bytes_per_sample = $self->{details}->{bits_sample} >> 3;
        use bytes;
        my @samples = map { substr pack('V1', $_), 0, $bytes_per_sample } @args;
#warn "bits/sample: $self->{details}->{bits_sample}, bytes/sample: $bytes_per_sample";
#warn "output samples(".scalar @samples."): ".join "-", map ord, split //, join '', @samples;
        return $self -> write_raw( join '', @samples );
    }
}

=head2 write_raw

Adds some pre-packed data to the current file.

    $write -> write_raw( $data, $data_length );

Where;

    $data is the packed data
    $data_length (optional) is the length in bytes of the data

=cut

sub write_raw {
    my $self = shift;
    my $data = shift;
    my $len = shift;
    $len = length $data unless $len;
    return unless $len;
    my $wrote = $len;
    if ( $self -> {use_cache} ) {
        $self -> {write_cache} .= $data;
        my $cache_len = length $self -> {write_cache};
        $self -> _purge_cache( $cache_len ) unless $cache_len < $self -> {cache_size};
    } else {
        $wrote = syswrite $self -> {handle}, $data, $len;
    }

    $self -> {pos} += $wrote;
    return $wrote;
}

=head2 write_raw_samples

Adds some pre-packed data to the current file, returns number of samples written.

    $write -> write_raw_samples( $data, $data_length );

Where;

    $data is the packed data
    $data_length (optional) is the length in bytes of the data

=cut

sub write_raw_samples {
    my ($self, @args) = @_;
    my $written = $self -> write_raw( @args );
    return $written / $self -> {details} -> {block_align};
}

####################

sub _start_file {
    my $self = shift;
    my( $file, $details, $tools, $handle ) = map { $self -> {$_} } qw( out_file details tools handle );
    my $header = Audio::Wav::Write::Header -> new( $file, $details, $tools, $handle );
    $self -> {header} = $header;
    my $data = $header -> start();
    $self -> write_raw( $data );
    $self -> {pos} = 0;
}

sub _purge_cache {
    my $self = shift;
    my $len = shift;
    return unless $self -> {write_cache};
    my $cache = $self -> {write_cache};
    $len = length $cache unless $len;
    my $res = syswrite $self -> {handle}, $cache, $len;
    $self -> {write_cache} = undef;
}

sub _init {
    my $self = shift;
    my $details = $self -> {details};
    my $output = {};
    my @missing;
    my @needed = qw ( bits_sample channels sample_rate );
    my @wanted = qw ( block_align bytes_sec info wave-ex );

    foreach my $need ( @needed ) {
        if ( exists( $details -> {$need} ) && $details -> {$need} ) {
            $output -> {$need} = $details -> {$need};
        } else {
            push @missing, $need;
        }
    }
    return $self -> _error('I need the following parameters supplied: ' . join ', ', @missing ) if @missing;
    foreach my $want ( @wanted ) {
        next unless ( exists( $details -> {$want} ) && $details -> {$want} );
        $output -> {$want} = $details -> {$want};
    }
    unless ( exists $details -> {block_align} ) {
        my( $channels, $bits ) = map { $output -> {$_} } qw( channels bits_sample );
        my $mod_bits = $bits % 8 ? 1 : 0;
        $mod_bits += int $bits / 8;
        $output -> {block_align} = $channels * $mod_bits;
    }
    unless ( exists $output -> {bytes_sec} ) {
        my( $rate, $block ) = map { $output -> {$_} } qw( sample_rate block_align );
        $output -> {bytes_sec} = $rate * $block;
    }
    unless ( exists $output -> {info} ) {
        $output -> {info} = {};
    }

    $self -> {details} = $output;
}

sub _examine_details {
    my $self = shift;
    my $details = shift;
    my( $cue, $label, $note ) =
        map { exists( $details -> {$_} ) ? $details -> {$_} : {} }
        qw( cue labl note );
    my $block_align = $self -> {details} -> {block_align};
    my $tools = $self -> {tools};
    foreach my $id ( sort keys %{$cue} ) {       # <-- Thanks to [e-mail]
        my $pos = $cue -> {$id} -> {position};
        $pos *= $block_align if $tools -> is_01compatible();
        my( $in_label, $in_note ) =
            map { exists( $_ -> {$id} ) ? $_ -> {$id} : '' }
            ( $label, $note );
        $self -> add_cue( $pos, $in_label, $in_note );
    }
    if ( exists $details -> {sampler} ) {
        my $sampler = $details -> {sampler};
        my $loops = delete $sampler -> {loop};
        $self -> set_sampler_info( %{$sampler} );
        foreach my $loop ( @{$loops} ) {
            $self -> add_sampler_loop( %{$loop} );
        }
    }
    if ( exists $details -> {display} ) {
        my @display = @{ $details -> {display} };
        my @fields = qw( id data );
        $self -> add_display( map { $fields[$_] => $display[$_] } 0, 1 );
    }
}

sub _error {
    my ($self, @args) = @_;
    return $self -> {tools} -> error( $self -> {out_file}, @args );
}

=head1 AUTHORS

    Nick Peskett (see http://www.peskett.co.uk/ for contact details).
    Kurt George Gjerde . (0.02-0.03)

=cut

1;