The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
use strict;

$| = 1;

my $started = time;

my $out_dir = 'test_output';

unless ( -d $out_dir ) {
    mkdir( $out_dir, 0777 ) ||
	die "unable to make test output directory '$out_dir' - ($!)";
}

use Audio::Wav;

my $cnt = 0;

print "1..4\n\n";

print "NOTE: ".($Audio::Wav::_has_inline ? 'YES' : 'NOT')." using inline\n";

### Wav Creation

print "\nTesting wav creation\n";

my %wav_options = ( # these are optional & default to 0
    '.01compatible'   => 0,
    'oldcooledithack' => 0,
    'debug'           => 0,
);


my $wav = Audio::Wav -> new( %wav_options );

my $file_out = $out_dir . '/testout.wav';
my $file_copy = $out_dir . '/testcopy.wav';
my $sample_rate = 11025;
my $bits_sample = 8;
#my $bits_sample = 32; warn "non-8-bit test";
my $length = 2;
my $channels = 1;
#my $channels = 2; warn "stereo test";

my $details =	{
    'bits_sample'	=> $bits_sample,
    'sample_rate'	=> $sample_rate,
    'channels'		=> $channels,
};

my $write = $wav -> write( $file_out, $details );

&add_slide( 50, 300, $length );

$write -> set_info( 'software' => 'Audio::Wav' );

my $marks = $length / 3;
foreach my $xpos ( 1 .. 2 ) {
    my $ypos = &seconds_to_samples( $xpos * $marks );
    $write -> add_cue( $ypos, "label $xpos", "note $xpos" );
    print "Cue $xpos at $ypos\n";
}

my $sec_samps = &seconds_to_samples( 1 );
$write -> add_cue( $sec_samps, "onesec", "one second" );
print "Cue 3 at $sec_samps\n";

my %samp_loop = (
    'start'	=> &seconds_to_samples( $length * .25 ),
    'end'	=> &seconds_to_samples( $length * .75 ),
);

$write -> add_sampler_loop( %samp_loop );

my %display = (
    'id'	=> 1,
    'data'	=> 'Submarine Captain',
);

$write -> add_display( %display );

$write -> finish();

$cnt ++;
print "ok $cnt\n";

### Wav Copying

print "\nTesting wav copying and shortcut syntax\n";

my $read = Audio::Wav -> read( $file_out );

# print Data::Dumper->Dump([ $read -> details() ]);

$write = $wav -> write( $file_copy, $read -> details() );

my $cues = $read -> get_cues();

for my $id ( 1 .. 3 ) {
    print "Cue $id at ", $cues -> {$id} -> {'position'}, "\n";
}

my $buffer = 512;
my $total = 0;
$length = $read -> length();

while ( $total < $length ) {
    my $left = $length - $total;
    $buffer = $left unless $left > $buffer;
    my $data = $read -> read_raw( $buffer );
    last unless defined( $data );
    $write -> write_raw( $data, $buffer );
    $total += $buffer;
}

$write -> finish();

$cnt ++;
print "ok $cnt\n";

### Wav Comparing

print "\nComparing wav files $file_out & $file_copy\n";

my $file_orig = $file_out;

open ORIG, $file_orig or die "Can't open file '$file_orig': $!\n";
binmode ORIG;

my $data_orig;
while (<ORIG>) {
  $data_orig.=$_;
}
close ORIG;

open COPY, $file_copy or die "Can't open file '$file_copy': $!\n";
binmode COPY;

my $data_copy;
while (<COPY>) {
  $data_copy.=$_;
}
close COPY;


if (length($data_copy) ne length($data_orig)) {
    die "Wav files ARE NOT identical; they are of different lengths";
}


if ($data_copy ne $data_orig) {
    die "Wav files ARE NOT identical";
}

$cnt ++;
print "ok $cnt\n";

print "\nTesting sample wav file\n";

if ( &test_wav() ) {
    print "sample wav file was read correctly\n";
} else {
    die "sample wav file was not read correctly\n";
}

$cnt ++;
print "ok $cnt\n";

print "took ", int( time - $started ), " seconds";

sub test_wav {
    my $file = 'test_tone.wav';
    my $cued_sample = -12;
    my %match_details = (
	'bits_sample'	=> 8,
	'length'	=> '0.5',
	'block_align'	=> 1,
	'bytes_sec'	=> 8000,
	'total_length'	=> 4152,
	'channels'	=> 1,
	'sample_rate'	=> 8000,
	'data_length'	=> 4000,
	'data_start'	=> '44',
    );
    my $read = $wav -> read( $file );
    my $details = $read -> details();
    foreach my $key ( keys %match_details ) {
	my( $want, $is ) = ( $details -> {$key}, $match_details{$key} );
	next if $details -> {$key} eq $match_details{$key};
	warn "mismatched value for $key, wanted $want, but got $is\n";
	return 0;
    }
    my $cues = $read -> get_cues();
    unless ( exists $cues -> {'1'} ) {
	warn "no cues found in $file\n";
	return 0;
    }
    my $pos = $cues -> {'1'} -> {'position'};
    unless ( $read -> move_to( $pos ) ) {
	warn "unable to move to sample $pos\n";
	return 0;
    }
    my( $sample ) = $read -> read();
    unless ( $cued_sample == $sample ) {
	warn "sample at position $pos does not match $cued_sample (should be $sample)\n";
	return 0;
    }
    return 1;
}

sub add_slide {
    my $from_hz = shift;
    my $to_hz = shift;
    my $length = shift;
    my $volume = .5;
    my $diff_hz = $to_hz - $from_hz;
    my $pi = ( 22 / 7 ) * 2;
    $length *= $sample_rate;
    my $max_no =  ( 2 ** $bits_sample ) / 2;
    my $half = int( $length / 2 );
    my $pos = 0;
    foreach my $rev ( 0, 1 ) {
	my $target = $half;
	$target *= 2 if $rev;
	while ( $pos < $target ) {
	    $pos ++;
	    my $rev_pos = $rev ? ( $half - ( $pos - $half ) ) : $pos;
	    my $prog = $rev_pos / $half;
	    my $hz = $from_hz + ( $diff_hz * $prog );
	    my $cycle = $sample_rate / $hz;
	    my $mult = $rev_pos / $cycle;
	    my $samp = sin( $pi * $mult ) * $max_no;
	    $samp *= $volume;
	    $write -> write( map $samp, 1 .. $channels );
	}
    }

}

sub seconds_to_samples {
    my $time = shift;
    return $time * $sample_rate;
}