Audio-Wav-0.13/0000755000175000017500000000000011735421365011376 5ustar skiskiAudio-Wav-0.13/MANIFEST0000644000175000017500000000043311735421365012527 0ustar skiskiCOPYRIGHT Changes MANIFEST README LICENSE META.yml Makefile.PL TODO Wav.pm test.pl test_tone.wav Wav/Read.pm Wav/Write.pm Wav/Tools.pm Wav/Write/Header.pm xt/perlcritic.t xt/pod-coverage.t xt/pod.t META.json Module JSON meta-data (added by MakeMaker) Audio-Wav-0.13/Changes0000644000175000017500000001132611735421347012674 0ustar skiskiRevision history for Perl extension Audio::Wav. 0.13 Fri Mar 30 21:17:18 GMT 2012 - read: don't call close() at DESTROY time when the file handle creationfailed during new() (Murali Ramanathan) https://rt.cpan.org/Ticket/Display.html?id=71462 - apply patch to allow read/write of files from handle https://rt.cpan.org/Ticket/Display.html?id=71715 - fix problem with $^X under mod_perl (thanks, mario and david!) https://rt.cpan.org/Ticket/Display.html?id=62060 - fix bug in perldoc (Sergei Steshenko) https://rt.cpan.org/Ticket/Display.html?id=57114 - fix problem with writing 24,32 bps files reported by Sergei Steshenko: http://rt.cpan.org/Public/Bug/Display.html?id=57093 - spelling fixes from debian http://rt.cpan.org/Public/Bug/Display.html?id=69644 0.12 Sun May 30 08:45:03 GMT 2010 - don't use values > MAXINT. +2147483648 is not a valid unsigned int32 (it's MAXINT+1). while we're at it, put all constants in the XS in hex format for clarity. possibly fixes: http://www.cpantesters.org/cpan/report/6945385 - fall back to pureperl when Inline::C is installed but not functional as reported by Michel Lanne. 0.11 Fri Mar 12 04:12:44 GMT 2010 - fix two bugs triggered with inline on win32 - one related to assuming C99 support and one related to lack of stdint.h or equivalent. tested with strawberry perl, should work with msvc too. bug report here: http://www.cpantesters.org/cpan/report/6920668 same smoker reports tests with 0.11 here: http://www.cpantesters.org/cpan/report/6930825 0.10 Sun Feb 14 04:09:00 GMT 2010 - add COPYRIGHT information for debian folks - include xt/ 0.09 Thu Feb 11 14:58:37 GMT 2010 - Support 24 and 32 bit wav reading w/o Inline::C (from Wolfram humann) ( see https://rt.cpan.org/Public/Bug/Display.html?id=36452 ) - add a META.yml and some other easy kwalitee tweaks - Audio::Wav::Read::_has_inline moved to Audio::Wav::_has_inline so it can be queried before instantiating a reader (and later be used internally for Audio::Wav::Write) 0.08 Tue Feb 09 06:29:43 GMT 2010 - fix regression: read() returned bogus samples when Inline::C not available 0.07 Sun Feb 07 18:05:41 GMT 2010 - change API so you can call Audio::Wav->{read|write} w/o new() if preferred - increase pure perl read speed by a factor of ~2.4 * remove unnecessary bounds check * put block in closure, avoiding double hash lookup * put $block assign in _init_read_sub, put read_sub in closure, too * pull $handle into closure: * get rid of closure, and get rid of read() - inline it with $read_sub - use Inline::C (if available) to increase read speed by a factor of ~2.3 - experimental support for reading 24- and 32- bit data (suspected to work on little endian machines that use Inline::C) 0.06 Wed Mar 22 12:00:00 2006 - Fixed a circular reference in Audio::Wav::Write::Header that was causing memory to leak (thanks Sumitro Chowdhury). - Tidied up bits and pieces. - Added very basic support for WAVEFORMATEXTENSIBLE. - When writing files, finish() will now be called by DESTROY if necessary. 0.05 Tue Oct 25 12:20:00 2005 - Audio::Wav::Read::position_samples should have divided by block_align rather than multiplied (thanks David Brandt). - Fixed bug where unknown blocks weren't skipped (thanks Robert Hiller). 0.04 Thu Dec 30 07:47:00 2004 - fixed a bug in Audio::Wav::Read::move_to, now adds where the data actually starts to the position given. - Audio::Wav::Read::move_to now rereads data length to see if file has grown since this was last read. - added method Audio::Wav::Read::reread_length, rereads the length of the file in case it is being written to as we are reading it. - added method Audio::Wav::Read::read_raw_samples which will read X samples in raw format. - added method Audio::Wav::Read::position_samples which returns the current audio data position in samples. - in method Audio::Wav::Write::add_cue, if sample position supplied is undefined, then the position will be the current position (end of all data written so far). - in method Audio::Wav::Write, moved the option of not caching data from the write_raw method to new. 0.03 Fri Jun 11 13:29:00 2004 - minor bug fix to pass tests with Perl 5.8.3 (thanks to Jeremy Devenport). 0.02 Sat Sep 01 15:15:00 2001 - works on big endian machines! - no need for Audio::Tools anymore - added support for info & sampler blocks. - now honours padding bytes - read & read_raw no longer return non-audio data. - added error handler. - slight speed improvement for read & write methods - some other fixes. 0.01 Fri Dec 11 05:54:22 1998 - original version; created by h2xs 1.18 Audio-Wav-0.13/test_tone.wav0000644000175000017500000001010011676757152014123 0ustar skiskiRIFF8WAVEfmt @@data €~}|{{|}|{|{{{{{||}|{yyzzzyyxzyyxwyzz|}€~|}}{||{zzzz{z{{zzz{{|||||}{{yxyyz|||||{{{{z{zyy{{|}||||~||{yz{|}|}}~|~~~~}}~}|~}}}~|}}~}{}|~€€€€€€€‚‚‚ƒƒ„„ƒ„„„††……„ƒ„ƒƒ‚€€€€~|}{{|||}{z{{z{{{{|}}}||}}||}~€‚‚„„…„…„„ƒƒ„ƒ‚€€‚ƒ……†„„„…†…„„…„„†………‡‡†…„„‚€ƒ„…„„ƒ………†††„…†…„……„ƒ‚ƒ‚ƒ„……„ƒ‚‚‚‚‚ƒ‚‚‚‚€€€€€‚ƒ‚€~}|~|z{}~~~~~~~~€€€€€~~€€‚‚ƒ€€€~~~~~}|}{z{}}||{|{{{{|{|~~~}}~~}}|{{z{zxxxyzzzzyxyxxxwwwxxxwvvtvxxxwvuuvvuvvwwutttuuuvvvuxvwyyyz{z{{}|{||||{{{{|}~}}||}}}}~€ƒ„ƒƒ„„ƒƒ…ƒ„†…„ƒ‚ƒƒƒ…„ƒ…†ˆ‰‰Š‰ŠŠŠ‰Š‹ŠŠ‹ŠŠŠ‹‰‰Š‰ˆˆˆ‡‰ˆ‡‡ˆˆ‡‡ˆˆˆ‰‰‰ˆ‡‡‡‡‡‡…„…†…††‡‰Š‰‡ˆ‡ˆŠ‰Š‰ŠŠˆ‰Š‹‰‹Š‰ŠŠ‹‹‹ŒŒŒ‹Œ‹Šˆˆ†††‡ˆ‡ˆ‡ˆˆˆ‰‹ŠŠŠŒ‹‹ŠŠˆ‰ˆ‰ŠŠŠ‰Š‰‰Š‹Š‹ŽŽŽŒŽ‹ŒŒ‹‹‹‹Š‹‹ŠŠŒ‹ŠŠŠ‹‹ŒŒŒ‹‰ˆ‰‰‰ˆ‰ˆˆŠ‹Š‰‰‰‰‰ˆ‡‡ˆ‰ˆˆ‡‡‡†‡……ƒ„…„„„„„…ƒ‚‚€€~|zzyyyyxyzzyyzzywwwxyyzzyzyxvvwwwxxwwwwyxxxwwuwwyy{|{{{{||zz{zz{{{{zzzyyyzzyyxvvvtuuuwvvvuvstuvwyyyxz{{{}}}}~~€€€~}}~~~|{{zzz{zz{z{{{z{zyzy{z{xyzyyz{|{zyxvuttuuwwwxzyxxyyy{{{{{|||}|||}€‚ƒ„‚‚‚‚€€‚‚‚€€ƒ‚ƒ‚‚€‚‚ƒƒƒ„‚‚€~~~€~~}}|{zyxxxxvxyxy{{{yyzzyzyxyxxyzzz|}}~}}}|}}|zzyzyyxvvusuvuwxyxwwxwvttstusrsuvvuvwvvvxvuvwxyyyxxxxywwvvwwxxyxyzxy{{yxz{z{||}~~~~€€‚ƒ‚ƒƒ……ƒƒƒ‚€‚ƒ‚‚ƒ€}€~~}|}~€~€€~||~~€€€~~~€~~}}|{}~~€~€€€€‚€€}}}{zyxxyywwvvutsusrrsrpopnporrrsqrrpqpqqqrrsrrrqqqqpnmmlklmmnnmmmlklmlkijjlljjikmmmlllmnmmklklkkkklnnpoqrsrspqqqqqqqprrqqqqqqqqqrrqrpqqrrrsrrqqpqrtsrsuuwxxyzxxxuvxz{yxwwwxxxxwwzxxxxyxxxwwyzzzxxyxyzzxxxwxz|}~€‚‚ƒ„††…„„†‡‡‰‰‹Š‰‰ˆˆ‰‰‰‰‡‰ŠŠ‹ŒŠˆˆ‡‡…„……„‚‚‚‚‚€€}~|~}|{|zzzxwywwyxyzz{{|||{{{}}~€€€€€€~}||{|{|}|{|{{zyzzyxxxwustvvuvuustssqqqprqqpoopoonoooqoopooponmnnnmnnooooooooppqppppopoonnoonnnlnopopqqrrprssssrstuttrpppqponooppqpoomonopoqpprsuuttsstvvwxwvuttttutsrqrppprrqonmlllmnmmomlklmmmllmklmnqrsstsrqqrssssspqrpponnnppppppprrsstsrqppooponnmmlmmnoooppqqppnnoprponnpoononoonoonoprsstuvwwwwwvvuwvwxwvvvvutuvvxxxyzz{zzyzxyz{{|{{zzzyyzz|}|||||{zzy{|{z{|z|}}~||{yyyzzz{zyzz{|}||{z|}~}}}||||}{yzzyzyxzyxxvxwutututuwwwwxvvwwuvussruttuuvvwxxvwwvvvxyyyywywvutsqpopoqpnmmnoppooomnnooopooqrsrtsssttstuuvttutssrssssttssrtutsttuvvutuuvuuuvvuuutssqrrqqrrrpopopppooppqpopqqrpppqrrsqpqqpqppqprsttsrrrrtvvusttsssrtttuststsstssrqqrqqpponnoonnlmlklmmmmlmnooopqprtuuvtvwwxvvtttuttttsrrssrstvwutttvttrqqrqprqqpqpppqpqppqrrsrrrqstssuwy{z{|zzzzyywvwwyxxzz|{{}}~~~€~~€}||{|{{{zz{|}~~}}|}~|~~€€~~|}||~}}}}}|}|{z|z{{{|{{|{|~‚ƒ‚ƒ€‚‚ƒ€~~€‚ƒ…„„ƒ…†‡………‡…†……††…„‚‚‚ƒ„„††††‡‰ˆ‡‡‡‡††‡‡‡‡„‚‚ƒ„„‚‚‚‚€~~~€€€€€‚ƒ‚‚„ƒ…†‡‡ˆŠ‹‹ŽŽŽŽŽŽŽŽŽŽŽŽŽ‘‘‘’’‘‘‘‘‘‘‘’‘‘’‘“’‘ŽŒŒ‹ŠŠ‹ŒŒŒŒŒŒŒ‹ŒŽŽŽŽŽŒ‰‡‡†‡‡…„„„ƒ‚‚ƒ‚€}}|||{|~~}}|}|}}|zz|}|{zyzzzzzyyyxyxwvuuuuwutvtstrqrqoopnnmnnmlllklkkklmnonmnmnoqqqqrtstsssuuwvwwvutsuvvvuvxwwwwxwxwvuvuuwxvxyxxwvuvvtvtrqsttttstrrqqstuutttttstsrrrsttuuuuvvvvwwwxvuvtutstvwwxzxyxyxvwyz{zzyz{{{z|~€€~~||{z{zzyzyxxxvuutuvwvuttttrqqqqppqrstustrppqqpqrqstuuwxwwxxyyzyxxvxxxyxxyyvvxwwyxxyzxxxxxzzxyyyyz||zzz|~~}~}€€€€}~}|~€€‚„„…†…ƒƒƒƒƒ‚||}}}~|~~}~~|{zxzzz{zzzyxwyxy{}|~}}}}|}}}~}~€€€‚‚ƒ‚‚€}}|||||~}}€‚„„…ƒ~}}}€‚‚ƒ‚€‚€‚‚€€~~}}}}|}|}|}||{{zyzxxxwxxyyxyzyxwvxy{{{|~}~€€€‚‚€}{}~~}{{yzz{{|||~~~~}~}}}||}}|~}~~}~€€~}}}|{}|}}{|z{{|{zyxzzyzzyzxwyxxvuwwvututssssrqqrrsrrsttssqrrsrqpqprrsqrqpqqqqqpqrssuuttsstttstvuuutttutrrrrqqqoppqpqpoonnnpppopqrstutvuwyyzzz{|}}{|{|||{||{zyxyz|}~}|z{zzywxxyxyyzz{}|~}~~~~}|}|{{zz|{z}}|{}||||~}||}~}}~}~~}|}~~}}}~~}||zyyyxxwwvvuvuuvuuuwxuussrqprrqopqopppomlljjjhiijiijljkllmkiighfhhfeccddbbbaca`___`___^_``bccddeeggfefdecceecdcdefgeeedcbabaa_``_ab`aaaaaaa_a`abcbcbaa``abcedfgfffgggfedacddddeghgghggfgfgfhghijhijjjiiihhgfedeccccdcbabb`abba```__`_`_``bbccb``_`__]\\[[[]]\]^acbbccccca``aabbaab`_^^^```_^```aabdefffghjiggghijihfhhhhhghjijjiijjijkkjjiiiifgghhgghhigedfedcdcbbccaabcba`__]\^]]]]^]\[ZYZ\\\ZZYYXXVWWVUTTTUUXVUUSUUUUTSTUVWWXYXXYXWWVVWXXWXWXXXZ[Z\\^_^^]\ZZZZZY[[\]\\\\[ZZYXWVVWXZ[[ZZYYZ[\]]]\[]]]]\[\]^^^``acca`aaaaa__`_`aa`aa`cbbaa``baaaba``__^_`_`aaacbcaccb```_aba`a_`bcdefdcdbbbcababaa`_```aaa```a`bcbddeffgfghhjlmmlllmopprrrrsrsutvcue ƒdataƒLISTHadtlltxtrgn labl Cue 1notecue pointAudio-Wav-0.13/LICENSE0000644000175000017500000000015511676757152012416 0ustar skiskiThis program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Audio-Wav-0.13/TODO0000644000175000017500000000072611676757153012106 0ustar skiski- bugfix: stereo 16,24,32 bit code fails make test - 8 bit stereo, all mono ok - revamp testing code. include 8, 16, 24, 32 bit, mono+stereo testing. - check the above with and without inline - check the above on big-endian platforms (so far just tested on little) - re: 0x80000000 bug: can reproduce warning using 32 bit cc - optimize Wav/Write as was done for Wav/Read - use _init_write_sub() first, then Inline::C - use XS instead of Inline for portability if time Audio-Wav-0.13/xt/0000755000175000017500000000000011735421365012031 5ustar skiskiAudio-Wav-0.13/xt/perlcritic.t0000644000175000017500000000031611676757153014371 0ustar skiski#!perl -w use strict; use Test::More; eval "use Test::Perl::Critic (-severity => 1)"; plan skip_all => "Test::Perl::Critic required for testing PBP compliance" if $@; Test::Perl::Critic::all_critic_ok(); Audio-Wav-0.13/xt/pod-coverage.t0000644000175000017500000000033711676757153014607 0ustar skiski#!perl -Tw use strict; use Test::More; eval "use Test::Pod::Coverage 1.04"; plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage" if $@; all_pod_coverage_ok( { also_private => [ 'pp_pexists' ] } ); Audio-Wav-0.13/xt/pod.t0000644000175000017500000000023111676757153013007 0ustar skiski#!perl -Tw use strict; use Test::More; eval "use Test::Pod 1.14"; plan skip_all => "Test::Pod 1.14 required for testing POD" if $@; all_pod_files_ok(); Audio-Wav-0.13/META.json0000664000175000017500000000141711735421365013024 0ustar skiski{ "abstract" : "unknown", "author" : [ "unknown" ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 6.62, CPAN::Meta::Converter version 2.112150", "license" : [ "unknown" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Audio-Wav", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : 0 } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : 0 } }, "runtime" : { "requires" : {} } }, "release_status" : "stable", "version" : "0.13" } Audio-Wav-0.13/test.pl0000755000175000017500000001223511676757153012733 0ustar skiskiuse 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 () { $data_orig.=$_; } close ORIG; open COPY, $file_copy or die "Can't open file '$file_copy': $!\n"; binmode COPY; my $data_copy; while () { $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; } Audio-Wav-0.13/Wav/0000755000175000017500000000000011735421365012133 5ustar skiskiAudio-Wav-0.13/Wav/Write/0000755000175000017500000000000011735421365013225 5ustar skiskiAudio-Wav-0.13/Wav/Write/Header.pm0000644000175000017500000001754611676757153015003 0ustar skiskipackage 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; Audio-Wav-0.13/Wav/Tools.pm0000644000175000017500000001030711676757153013605 0ustar skiskipackage Audio::Wav::Tools; 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, %options) = @_; my $self = { 'errorHandler' => undef, }; foreach my $key ( qw( .01compatible oldcooledithack debug ) ) { $self -> {$key} = exists( $options{$key} ) && $options{$key} ? 1 : 0; } bless $self, $class; return $self; } sub is_debug { my $self = shift; return $self -> {'debug'}; } sub is_01compatible { my $self = shift; return $self -> {'.01compatible'}; } sub is_oldcooledithack { my $self = shift; return $self -> {'oldcooledithack'}; } sub set_error_handler { my $self = shift; my $handler = shift; unless ( ref( $handler ) eq 'CODE' ) { die 'set_error_handler is expecting a reference to a sub routine'; } $self -> {'errorHandler'} = $handler; } sub is_big_endian { my $self = shift; return $self -> {'is_big_endian'} if exists $self -> {'is_big_endian'}; my $VALUE = 1801677134; my $nativeLong = pack 'L', $VALUE; # 'kciN' (big) or 'Nick' (little) my $bigLong = pack 'N', $VALUE; # should return 'kciN' $self -> {'is_big_endian'} = $nativeLong eq $bigLong ? 1 : 0; return $self -> {'is_big_endian'}; } sub get_info_fields { return ( 'IARL' => 'archivallocation', 'IART' => 'artist', 'ICMS' => 'commissioned', 'ICMT' => 'comments', 'ICOP' => 'copyright', 'ICRD' => 'creationdate', 'IENG' => 'engineers', 'IGNR' => 'genre', 'IKEY' => 'keywords', 'IMED' => 'medium', 'INAM' => 'name', 'IPRD' => 'product', 'ISBJ' => 'subject', 'ISFT' => 'software', 'ISRC' => 'supplier', 'ISRF' => 'source', 'ITCH' => 'digitizer', ); } sub get_rev_info_fields { my $self = shift; return %{ $self -> {'rev_info_fields'} } if exists $self -> {'rev_info_fields'}; my %info_fields = $self -> get_info_fields(); my %rev_info; foreach my $key ( keys %info_fields ) { $rev_info{ $info_fields{$key} } = $key; } $self -> {'rev_info_fields'} = \%rev_info; return %rev_info; } sub get_sampler_fields { # dwManufacturer dwProduct dwSamplePeriod dwMIDIUnityNote dwMIDIPitchFraction dwSMPTEFormat dwSMPTEOffset cSampleLoops cbSamplerData # ) struct dwIdentifier; dwType; dwStart; dwEnd; dwFraction; dwPlayCount; return ( 'fields' => [ qw( manufacturer product sample_period midi_unity_note midi_pitch_fraction smpte_format smpte_offset sample_loops sample_data ) ], 'loop' => [ qw( id type start end fraction play_count ) ], 'extra' => [], # 'extra' => [ map 'unknown' . $_, 1 .. 3 ], ); } sub get_sampler_defaults { return ( 'midi_pitch_fraction' => 0, 'smpte_format' => 0, 'smpte_offset' => 0, 'product' => 0, 'sample_period' => 0, # 22675, 'manufacturer' => 0, 'sample_data' => 0, 'midi_unity_note' => 65 ); } sub get_sampler_loop_defaults { return ( 'fraction' => 0, 'type' => 0 ); } sub error { my $self = shift; my $filename = shift; my $msg = shift; my $type = shift; my $handler = $self -> {'errorHandler'}; if ( $handler ) { my %hash = ( 'filename' => $filename, 'message' => $msg ? $msg : '', ); $hash{'warning'} = 1 if $type eq 'warn'; &$handler( %hash ); } else { my $txt = $filename ? "$filename: $msg\n" : "$msg\n"; if ( $type && $type eq 'warn' ) { warn $txt; } else { die $txt; } } return; } sub get_wav_pack { my $self = shift; return { 'order' => [ qw( format channels sample_rate bytes_sec block_align bits_sample ) ], 'types' => { 'format' => 'v', 'channels' => 'v', 'sample_rate' => 'V', 'bytes_sec' => 'V', 'block_align' => 'v', 'bits_sample' => 'v', }, }; } 1; Audio-Wav-0.13/Wav/Read.pm0000644000175000017500000005766411735420753013366 0ustar skiskipackage Audio::Wav::Read; use strict; eval { require warnings; }; #it's ok if we can't load warnings use FileHandle; use vars qw( $VERSION ); $VERSION = '0.13'; =head1 NAME Audio::Wav::Read - Module for reading Microsoft WAV files. =head1 SYNOPSIS use Audio::Wav; my $wav = new Audio::Wav; my $read = $wav -> read( 'filename.wav' ); #OR my $read = Audio::Wav -> read( 'filename.wav' ); my $details = $read -> details(); =head1 DESCRIPTION Reads Microsoft Wav files. =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 $file = shift; my $tools = shift; $file =~ s#//#/#g; my $size = -s $file; my $handle = (ref $file eq 'GLOB') ? $file : new FileHandle "<$file"; my $self = { 'real_size' => $size, 'file' => $file, 'handle' => $handle, 'tools' => $tools, }; bless $self, $class; unless ( defined $handle ) { $self -> _error( "unable to open file ($!)" ); return $self; } binmode $handle; if( $Audio::Wav::_has_inline ) { local $/ = undef; my $c_string = ; Inline->import(C => $c_string); } else { #TODO: do we have a reference to $tools here if using shortcuts? if( $tools && $tools -> is_debug() ) { warn "can't load Inline, using slow pure perl reads\n"; } } $self -> {data} = $self -> _read_file(); my $details = $self -> details(); $self -> _init_read_sub(); $self -> {pos} = $details -> {data_start}; $self -> move_to(); return $self; } # just in case there are any memory leaks sub DESTROY { my $self = shift; return unless $self; if ( exists $self->{handle} && defined $self->{handle} ) { $self->{handle}->close(); } if ( exists $self->{tools} ) { delete $self->{tools}; } } =head2 file_name Returns the file name. my $file = $read -> file_name(); =cut sub file_name { my $self = shift; return $self -> {file}; } =head2 get_info Returns information contained within the wav file. my $info = $read -> get_info(); Returns a reference to a hash containing; (for example, a file marked up for use in Audio::Mix) { 'keywords' => 'bpm:126 key:a', 'name' => 'Mission Venice', 'artist' => 'Nightmares on Wax' }; =cut sub get_info { my $self = shift; return unless exists $self -> {data} -> {info}; return $self -> {data} -> {info}; } =head2 get_cues Returns the cuepoints marked within the wav file. my $cues = $read -> get_cues(); Returns a reference to a hash containing; (for example, a file marked up for use in Audio::Mix) (position is sample position) { 1 => { label => 'sig', position => 764343, note => 'first', }, 2 => { label => 'fade_in', position => 1661774, note => 'trig', }, 3 => { label => 'sig', position => 18033735, note => 'last', }, 4 => { label => 'fade_out', position => 17145150, note => 'trig', }, 5 => { label => 'end', position => 18271676, } } =cut sub get_cues { my $self = shift; return unless exists $self -> {data} -> {cue}; my $data = $self -> {data}; my $cues = $data -> {cue}; my $output = {}; foreach my $id ( keys %{$cues} ) { my $pos = $cues -> {$id} -> {position}; my $record = { 'position' => $pos }; $record -> {label} = $data -> {labl} -> {$id} if ( exists $data -> {labl} -> {$id} ); $record -> {note} = $data -> {note} -> {$id} if ( exists $data -> {note} -> {$id} ); $output -> {$id} = $record; } return $output; } =head2 read_raw Reads raw packed bytes from the current audio data position in the file. my $data = $self -> read_raw( $byte_length ); =cut sub read_raw { my $self = shift; my $len = shift; my $data_finish = $self -> {data} -> {data_finish}; if ( $self -> {pos} + $len > $data_finish ) { $len = $data_finish - $self -> {pos}; } return $self -> _read_raw( $len ); } =head2 read_raw_samples Reads raw packed samples from the current audio data position in the file. my $data = $self -> read_raw_samples( $samples ); =cut sub read_raw_samples { my $self = shift; my $len = shift; $len *= $self -> {data} -> {block_align}; return $self -> read_raw( $len ); } sub _read_raw { my $self = shift; my $len = shift; my $data; return unless $len && $len > 0; $self -> {pos} += read $self -> {handle}, $data, $len; return $data; } =head2 read Returns the current audio data position sample across all channels. my @channels = $self -> read(); Returns an array of unpacked samples. Each element is a channel i.e ( left, right ). The numbers will be in the range; where $samp_max = ( 2 ** bits_per_sample ) / 2 -$samp_max to +$samp_max =cut # read is generated by _init_read_sub sub read { die "ERROR: can't call read without first calling _init_read_sub"; }; sub _init_read_sub { my $self = shift; my $handle = $self -> {handle}; my $details = $self -> {data}; my $channels = $details -> {channels}; my $block = $details -> {block_align}; my $read_op; #TODO: we try to do something if we have bits_per_sample != multiple of 8? if ( $details -> {bits_sample} <= 8 ) { # Data in .wav-files with <= 8 bits is unsigned. >8 bits is signed my $offset = 2 ** ($details -> {bits_sample}-1); $read_op = q[ return map $_ - ] . $offset . q[, unpack( 'C'.$channels, $val ); ]; } elsif ( $details -> {bits_sample} == 16 ) { # 16 bits could be handled by general case below, but this is faster if ( $self -> {tools} -> is_big_endian() ) { $read_op = q[ return unpack 's' . $channels, # 3. unpack native as signed short pack 'S' . $channels, # 2. pack native unsigned short unpack 'v' . $channels, $val; # 1. unpack little-endian unsigned short ]; } else { $read_op = q[ return unpack( 's' . $channels, $val ); ]; } } elsif ( $details -> {bits_sample} <= 32 ) { my $bytes = $details -> {block_align} / $channels; my $fill = 4 - $bytes; my $limit = 2 ** ($details -> {bits_sample}-1); my $offset = 2 ** $details -> {bits_sample}; #warn "b: $bytes, f: $fill"; $read_op = q[ return map {$_ & ] . $limit . q[ ? # 4. If sign bit is set $_ - ] . $offset . q[ : $_} # convert to negative number unpack 'V*', # 3. unpack as little-endian unsigned long pack "(a] . $bytes.'x'.$fill . q[)*", # 2. fill with \0 to 4-byte-blocks and repack unpack "(a] . $bytes . q[)*", $val; # 1. unpack to elements sized "$bytes"-bytes ]; # $sub = sub # { return map {$_ & $limit ? # 4. If sign bit is set # $_ - $offset : $_} # convert to negative number # unpack 'V*', # 3. unpack as little-endian unsigned long # pack "(a${bytes}x${fill})*", # 2. fill with \0 to 4-byte-blocks and repack # unpack "(a$bytes)*", shift() # 1. unpack to elements sized "$bytes"-bytes # }; } else { $self->_error("Unpacking elements with more than 32 ($details->{bits_sample}) bits per sample not supported!"); } $self -> {read_sub_string} = q[ sub { my $val; $self -> {pos} += read( $handle, $val, $block ); return unless defined $val; ] . $read_op . q[ }; ]; if( $Audio::Wav::_has_inline ) { init( $handle, $details->{bits_sample}/8, $channels, $self -> {tools} -> is_big_endian() ? 1 : 0); *read = \&read_c; } else { my $read_sub = eval $self -> {read_sub_string}; die "eval of read_sub failed: $@\n" if($@); $self -> {read_sub} = $read_sub; #in case any legacy code peaked at that *read = \&$read_sub; } #warn $self -> {read_sub_string}; } =head2 position Returns the current audio data position (as byte offset). my $byte_offset = $read -> position(); =cut sub position { my $self = shift; return $self -> {pos} - $self -> {data} -> {data_start}; } =head2 position_samples Returns the current audio data position (in samples). my $samples = $read -> position_samples(); =cut sub position_samples { my $self = shift; return ( $self -> {pos} - $self -> {data} -> {data_start} ) / $self -> {data} -> {block_align}; } =head2 move_to Moves the current audio data position to byte offset. $read -> move_to( $byte_offset ); =cut sub move_to { my $self = shift; my $pos = shift; my $data_start = $self -> {data} -> {data_start}; if ( $pos ) { $pos = 0 if $pos < 0; } else { $pos = 0; } $pos += $data_start; if ( $pos > $self -> {pos} ) { my $max_pos = $self -> reread_length() + $data_start; $pos = $max_pos if $pos > $max_pos; } if ( seek $self -> {handle}, $pos, 0 ) { $self -> {pos} = $pos; return 1; } else { return $self -> _error( "can't move to position '$pos'" ); } } =head2 move_to_sample Moves the current audio data position to sample offset. $read -> move_to_sample( $sample_offset ); =cut sub move_to_sample { my $self = shift; my $pos = shift; return $self -> move_to() unless defined $pos ; return $self -> move_to( $pos * $self -> {data} -> {block_align} ); } =head2 length Returns the number of bytes of audio data in the file. my $audio_bytes = $read -> length(); =cut sub length { my $self = shift; return $self -> {data} -> {data_length}; } =head2 length_samples Returns the number of samples of audio data in the file. my $audio_samples = $read -> length_samples(); =cut sub length_samples { my $self = shift; my $data = $self -> {data}; return $data -> {data_length} / $data -> {block_align}; } =head2 length_seconds Returns the number of seconds of audio data in the file. my $audio_seconds = $read -> length_seconds(); =cut sub length_seconds { my $self = shift; my $data = $self -> {data}; return $data -> {data_length} / $data -> {bytes_sec}; } =head2 details Returns a reference to a hash of lots of details about the file. Too many to list here, try it with Data::Dumper..... use Data::Dumper; my $details = $read -> details(); print Data::Dumper->Dump([ $details ]); =cut sub details { my $self = shift; return $self -> {data}; } =head2 reread_length Rereads the length of the file in case it is being written to as we are reading it. my $new_data_length = $read -> reread_length(); =cut sub reread_length { my $self = shift; my $handle = $self -> {handle}; my $old_pos = $self -> {pos}; my $data = $self -> {data}; my $data_start = $data -> {data_start}; seek $handle, $data_start - 4, 0; my $new_length = $self -> _read_long(); seek $handle, $old_pos, 0; $data -> {data_length} = $new_length; return $new_length; } ######### sub _read_file { my $self = shift; my $handle = $self -> {handle}; my %details; my $type = $self -> _read_raw( 4 ); my $length = $self -> _read_long( ); my $subtype = $self -> _read_raw( 4 ); my $tools = $self -> {tools}; my $old_cooledit = $tools -> is_oldcooledithack(); my $debug = $tools -> is_debug(); $details{total_length} = $length; unless ( $type eq 'RIFF' && $subtype eq 'WAVE' ) { return $self -> _error( "doesn't seem to be a wav file" ); } my $walkover; # for fixing cooledit 96 data-chunk bug while ( ! eof $handle && $self -> {pos} < $length ) { my $head; if ( $walkover ) { # rectify cooledit 96 data-chunk bug $head = $walkover . $self -> _read_raw( 3 ); $walkover = undef; print "debug: CoolEdit 96 data-chunk bug detected!\n" if $debug; } else { $head = $self -> _read_raw( 4 ); } my $chunk_len = $self -> _read_long(); printf "debug: head: '$head' at %6d (%6d bytes)\n", $self->{pos}, $chunk_len if $debug; if ( $head eq 'fmt ' ) { my $format = $self -> _read_fmt( $chunk_len ); my $comp = delete $format -> {format}; if ( $comp == 65534 ) { $format -> {'wave-ex'} = 1; } elsif ( $comp != 1 ) { return $self -> _error( "seems to be compressed, I can't handle anything other than uncompressed PCM" ); } else { $format -> {'wave-ex'} = 0; } %details = ( %details, %{$format} ); next; } elsif ( $head eq 'cue ' ) { $details{cue} = $self -> _read_cue( $chunk_len, \%details ); next; } elsif ( $head eq 'smpl' ) { $details{sampler} = $self -> _read_sampler( $chunk_len ); next; } elsif ( $head eq 'LIST' ) { my $list = $self -> _read_list( $chunk_len, \%details ); next; } elsif ( $head eq 'DISP' ) { $details{display} = $self -> _read_disp( $chunk_len ); next; } elsif ( $head eq 'data' ) { $details{data_start} = $self -> {pos}; $details{data_length} = $chunk_len; } else { $head =~ s/[^\w]+//g; $self -> _error( "ignored unknown block type: $head at $self->{pos} for $chunk_len", 'warn' ); } seek $handle, $chunk_len, 1; $self -> {pos} += $chunk_len; # read padding if ($chunk_len % 2) { my $pad = $self->_read_raw(1); if ( ($pad =~ /\w/) && $old_cooledit && ($head eq 'data') ) { # Oh no, this file was written by cooledit 96... # This is not a pad byte but the first letter of the next head. $walkover = $pad; } } #unless ( $old_cooledit ) { # $chunk_len += 1 if $chunk_len % 2; # padding #} #seek $handle, $chunk_len, 1; #$self -> {pos} += $chunk_len; } if ( exists $details{data_start} ) { $details{length} = $details{data_length} / $details{bytes_sec}; $details{data_finish} = $details{data_start} + $details{data_length}; } else { $details{data_start} = 0; $details{data_length} = 0; $details{length} = 0; $details{data_finish} = 0; } return \%details; } sub _read_list { my $self = shift; my $length = shift; my $details = shift; my $note = $self -> _read_raw( 4 ); my $pos = 4; if ( $note eq 'adtl' ) { my %allowed = map { $_ => 1 } qw( ltxt note labl ); while ( $pos < $length ) { my $head = $self -> _read_raw( 4 ); $pos += 4; if ( $head eq 'ltxt' ) { my $record = $self -> _decode_block( [ 1 .. 6 ] ); $pos += 24; } else { my $bits = $self -> _read_long(); $pos += $bits + 4; if ( $head eq 'labl' || $head eq 'note' ) { my $id = $self -> _read_long(); my $text = $self -> _read_raw( $bits - 4 ); $text =~ s/\0+$//; $details -> {$head} -> {$id} = $text; } else { my $unknown = $self -> _read_raw ( $bits ); # skip unknown chunk } if ($bits % 2) { # eat padding my $padding = $self -> _read_raw(1); $pos++; } } } # if it's a broken file and we've read too much then go back if ( $pos > $length ) { seek $self->{handle}, $length-$pos, 1; } } elsif ( $note eq 'INFO' ) { my %allowed = $self -> {tools} -> get_info_fields(); while ( $pos < $length ) { my $head = $self -> _read_raw( 4 ); $pos += 4; my $bits = $self -> _read_long(); $pos += $bits + 4; my $text = $self -> _read_raw( $bits ); if ( $allowed{$head} ) { $text =~ s/\0+$//; $details -> {info} -> { $allowed{$head} } = $text; } if ($bits % 2) { # eat padding my $padding = $self -> _read_raw(1); $pos++; } } } else { my $data = $self -> _read_raw( $length - 4 ); } } sub _read_cue { my $self = shift; my $length = shift; my $details = shift; my $cues = $self -> _read_long(); my @fields = qw( id position chunk cstart bstart offset ); my @plain = qw( chunk ); my $output; for ( 1 .. $cues ) { my $record = $self -> _decode_block( \@fields, \@plain ); my $id = delete $record -> {id}; $output -> {$id} = $record; } return $output; } sub _read_disp { my $self = shift; my $length = shift; my $type = $self -> _read_long(); my $data = $self -> _read_raw( $length - 4 + ($length%2) ); $data =~ s/\0+$//; return [ $type, $data ]; } sub _read_sampler { my $self = shift; my $length = shift; my %sampler_fields = $self -> {tools} -> get_sampler_fields(); my $record = $self -> _decode_block( $sampler_fields{fields} ); for my $id ( 1 .. $record -> {sample_loops} ) { push @{ $record -> {loop} }, $self -> _decode_block( $sampler_fields{loop} ); } $record -> {sample_specific_data} = _read_raw( $record -> {sample_data} ); my $read_bytes = 9 * 4 # sampler info + 6 * 4 * $record -> {sample_loops} # loops + $record -> {sample_data}; # specific data # read any junk if ($read_bytes < $length ) { my $junk = $self->_read_raw( $length - $read_bytes ); } if ( $length % 2 ) { my $pad = $self -> _read_raw( 1 ); } # temporary nasty hack to gooble the last bogus 12 bytes #my $extra = $self -> _decode_block( $sampler_fields{extra} ); return $record; } sub _decode_block { my $self = shift; my $fields = shift; my $plain = shift; my %plain; if ( $plain ) { foreach my $field ( @{$plain} ) { for my $id ( 0 .. $#{$fields} ) { next unless $fields -> [$id] eq $field; $plain{$id} = 1; } } } my $no_fields = scalar @{$fields}; my %record; for my $id ( 0 .. $#{$fields} ) { if ( exists $plain{$id} ) { $record{ $fields -> [$id] } = $self -> _read_raw( 4 ); } else { $record{ $fields -> [$id] } = $self -> _read_long(); } } return \%record; } sub _read_fmt { my $self = shift; my $length = shift; my $data = $self -> _read_raw( $length ); my $types = $self -> {tools} -> get_wav_pack(); my $pack_str = ''; my $fields = $types -> {order}; foreach my $type ( @{$fields} ) { $pack_str .= $types -> {types} -> {$type}; } my @data = unpack $pack_str, $data; my %record; for my $id ( 0 .. $#{$fields} ) { $record{ $fields -> [$id] } = $data[$id]; } return { %record }; } sub _read_long { my $self = shift; my $data = $self -> _read_raw( 4 ); return unpack 'V', $data; } sub _error { my ($self, @args) = @_; return $self -> {tools} -> error( $self -> {file}, @args ); } =head1 AUTHORS Nick Peskett (see http://www.peskett.co.uk/ for contact details). Brian Szymanski (0.07-0.13) Wolfram humann (pureperl 24 and 32 bit read support in 0.09) Kurt George Gjerde . (0.02-0.03) =cut 1; __DATA__ #ifdef WIN32 // Note: if it becomes a problem that Visual Studio 6 and // Embedded Visual C++ 4 dont realize that char has the same // size as int8_t, check for #if (_MSC_VER < 1300) and use // signed __int8, unsigned __int16, etc. as in: // http://msinttypes.googlecode.com/svn/trunk/stdint.h typedef signed char int8_t; typedef signed short int16_t; typedef signed int int32_t; typedef unsigned char uint8_t; typedef unsigned short uint16_t; typedef unsigned int uint32_t; #endif //NOTE: 16, 32 bit audio do *NOT* work on big-endian platforms yet! //verified formats (output is identical output to pureperl): // 1 channel signed 16 little endian // 2 channel signed 16 little endian // 1 channel unsigned 8 little endian // 2 channel unsigned 8 little endian //verified "looks right" on these formats: // 1 channel signed 32 little endian // 2 channel signed 32 little endian // 1 channel signed 24 little endian // 2 channel signed 24 little endian //maximum number of channels per audio stream #define MAX_CHANNELS 10 //maximum number of bytes per sample (in one channel) #define MAX_SAMPLE 4 FILE *handle; int sample_size; int channels; int big_end; int is_signed; char buf[MAX_SAMPLE]; SV* retvals[MAX_CHANNELS]; void init(FILE *fh, int ss, int ch, int be) { int i; handle = fh; sample_size = ss; channels = ch; big_end = be; is_signed = (ss != 1); //TODO: is this really right? for(i=0; i> 8; } else { s = s & 0x00ffffff; } //make negative via 2s compliment if data is signed //and the sign bit is set if ( is_signed ) { if ( s & 0x00800000 ) { s = -((~s & 0x00ffffff)+1); } } else { //we *always* return signed data s += -0x800000; } break; case 2: if(big_end) { s = buf[0]; buf[0] = buf[1]; buf[1] = s; } s = is_signed ? *((int16_t *)buf) : *((uint16_t *)buf) + -0x8000; break; case 1: //note: Audio::Wav *always* returns signed data s = is_signed ? *((int8_t *)buf) : *((uint8_t *)buf) + -0x80; break; } sv_setiv(retvals[i], s); Inline_Stack_Push(retvals[i]); } Inline_Stack_Done; } Audio-Wav-0.13/Wav/Write.pm0000644000175000017500000002530411735421001013552 0ustar skiskipackage 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.13'; =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( @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 jeremyd713@hotmail.com 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; Audio-Wav-0.13/Makefile.PL0000755000175000017500000000023211676757153013363 0ustar skiskiuse ExtUtils::MakeMaker; my %makefile = ( NAME => 'Audio::Wav', VERSION_FROM => 'Wav.pm', # finds $VERSION ); WriteMakefile(%makefile); Audio-Wav-0.13/README0000644000175000017500000003356511676757153012305 0ustar skiski--------------------------------------------------------------------- README file for Audio::Wav (0.11). --------------------------------------------------------------------- Modules for reading & writing Microsoft WAV files. --------------------------------------------------------------------- INSTALLATION --------------------------------------------------------------------- tar zxvf Audio-Wav-0.06.tar.gz cd Audio-Wav-0.06 perl Makefile.PL make test make install --------------------------------------------------------------------- LICENSE AND COPYRIGHT --------------------------------------------------------------------- his program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Copyright (c) 2010 Brian Szymanski Copyright (c) 1999-2001,2004-2006 Nick Peskett (http://www.peskett.co.uk/) Copyright (c) 2004 Kurt George Gjerde --------------------------------------------------------------------- DOCUMENTATION --------------------------------------------------------------------- Audio::Wav Modules for reading & writing Microsoft WAV files. --------------------------------------------------------------------- NAME Audio::Wav - Modules for reading & writing Microsoft WAV files. SYNOPSIS # copying a file and adding some cue points to the output file use Audio::Wav; my $wav = new Audio::Wav; my $read = $wav -> read( 'input.wav' ); my $write = $wav -> write( 'output.wav', $read -> details() ); print "input is ", $read -> length_seconds(), " seconds long\n"; $write -> set_info( 'software' => 'Audio::Wav' ); my $data; #read 512 bytes while ( defined( $data = $read -> read_raw( 512 ) ) ) { $write -> write_raw( $data ); } my $length = $read -> length_samples(); my( $third, $half, $twothirds ) = map int( $length / $_ ), ( 3, 2, 1.5 ); my %samp_loop = ( 'start' => $third, 'end' => $twothirds, ); $write -> add_sampler_loop( %samp_loop ); $write -> add_cue( $half, "cue label 1", "cue note 1" ); $write -> finish(); # splitting a multi-channel file to seperate mono files (slowly!); use Audio::Wav; my $read = $wav -> read( '4ch.wav' ); my $details = $read -> details(); my %out_details = map { $_ => $details -> {$_} } 'bits_sample', 'sample_rate'; $out_details{'channels'} = 1; my @out_files; my $in_channels = $details -> {'channels'}; foreach my $channel ( 1 .. $in_channels ) { push @out_files, $wav -> write( 'multi_' . $channel . '.wav', \%out_details ); } while ( 1 ) { my @channels = $read -> read(); last unless @channels; foreach my $channel_id ( 0 .. $#channels ) { $out_files[$channel_id] -> write( $channels[$channel_id] ); } } # not entirely neccessary as finish is done in DESTROY now (if the file hasn't been finished already). foreach my $write ( @out_files ) { $write -> finish(); } NOTES All sample positions are now in sample offsets (unless option '.01compatible' is true). There is now *very* basic support for WAVEFORMATEXTENSIBLE (in fact it only recognises that the file is in this format). The key 'wave-ex' is used in the detail hash to denote this format when reading or writing. I'd like to do more with this, but don't have any hardware or software to test these files, also don't really have any spare time to do the implementation at present. One day I plan to learn enough C to do the sample reading/ writing in XS, but for the time being it's done using pack/ unpack in Perl and is slow. Working with the raw format doesn't suffer in this way. It's likely that reading/ writing files with bit-depth greater than 16 won't work properly, I need to look at this at some point. DESCRIPTION These modules provide a method of reading & writing uncompressed Microsoft WAV files. METHODS new Returns a blessed Audio::Wav object. All the parameters are optional and default to 0 my %options = ( '.01compatible' => 0, 'oldcooledithack' => 0, 'debug' => 0, ); my $wav = Audio::Wav -> new( %options ); write Returns a blessed Audio::Wav::Write object. my $details = { 'bits_sample' => 16, 'sample_rate' => 44100, 'channels' => 2, }; my $write = $wav -> write( 'testout.wav', $details ); See Audio::Wav::Write for methods. read Returns a blessed Audio::Wav::Read object. my $read = $wav -> read( 'testout.wav' ); See Audio::Wav::Read for methods. set_error_handler Specifies a subroutine for catching errors. The subroutine should take a hash as input. The keys in the hash are 'filename', 'message' (error message), and 'warning'. If no error handler is set, die and warn will be used. sub myErrorHandler { my( %parameters ) = @_; if ( $parameters{'warning'} ) { # This is a non-critical warning warn "Warning: $parameters{'filename'}: $parameters{'message'}\n"; } else { # Critical error! die "ERROR: $parameters{'filename'}: $parameters{'message'}\n"; } } $wav -> set_error_handler( \&myErrorHandler ); --------------------------------------------------------------------- Audio::Wav::Read Module for reading Microsoft WAV files. --------------------------------------------------------------------- NAME Audio::Wav::Read - Module for reading Microsoft WAV files. SYNOPSIS use Audio::Wav; my $wav = new Audio::Wav; my $read = $wav -> read( 'filename.wav' ); OR my $read = Audio::Wav -> read( 'filename.wav' ); my $details = $read -> details(); DESCRIPTION Reads Microsoft Wav files. SEE ALSO Audio::Wav Audio::Wav::Write NOTES This module shouldn't be used directly, a blessed object can be returned from Audio::Wav. METHODS file_name Returns the file name. my $file = $read -> file_name(); get_info Returns information contained within the wav file. my $info = $read -> get_info(); Returns a reference to a hash containing; (for example, a file marked up for use in Audio::Mix) { 'keywords' => 'bpm:126 key:a', 'name' => 'Mission Venice', 'artist' => 'Nightmares on Wax' }; get_cues Returns the cuepoints marked within the wav file. my $cues = $read -> get_cues(); Returns a reference to a hash containing; (for example, a file marked up for use in Audio::Mix) (position is sample position) { 1 => { label => 'sig', position => 764343, note => 'first' }, 2 => { label => 'fade_in', position => 1661774, note => 'trig' }, 3 => { label => 'sig', position => 18033735, note => 'last' }, 4 => { label => 'fade_out', position => 17145150, note => 'trig' }, 5 => { label => 'end', position => 18271676 } } read_raw Reads raw packed bytes from the current audio data position in the file. my $data = $self -> read_raw( $byte_length ); read_raw_samples Reads raw packed samples from the current audio data position in the file. my $data = $self -> read_raw_samples( $samples ); read Returns the current audio data position sample across all channels. my @channels = $self -> read(); Returns an array of unpacked samples. Each element is a channel i.e ( left, right ). The numbers will be in the range; where $samp_max = ( 2 ** bits_per_sample ) / 2 -$samp_max to +$samp_max position Returns the current audio data position (as byte offset). my $byte_offset = $read -> position(); position_samples Returns the current audio data position (in samples). my $samples = $read -> position_samples(); move_to Moves the current audio data position to byte offset. $read -> move_to( $byte_offset ); move_to_sample Moves the current audio data position to sample offset. $read -> move_to_sample( $sample_offset ); length Returns the number of bytes of audio data in the file. my $audio_bytes = $read -> length(); length_samples Returns the number of samples of audio data in the file. my $audio_samples = $read -> length_samples(); length_seconds Returns the number of seconds of audio data in the file. my $audio_seconds = $read -> length_seconds(); details Returns a reference to a hash of lots of details about the file. Too many to list here, try it with Data::Dumper..... use Data::Dumper; my $details = $read -> details(); print Data::Dumper->Dump([ $details ]); reread_length Rereads the length of the file in case it is being written to as we are reading it. my $new_data_length = $read -> reread_length(); --------------------------------------------------------------------- Audio::Wav::Write Module for writing Microsoft WAV files. --------------------------------------------------------------------- NAME Audio::Wav::Write - Module for writing Microsoft WAV files. 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; 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(); DESCRIPTION Currently only writes to a file. SEE ALSO Audio::Wav Audio::Wav::Read NOTES This module shouldn't be used directly, a blessed object can be returned from Audio::Wav. METHODS finish Finishes off & closes the current wav file. $write -> finish(); 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" ); 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 ); 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 ); add_display set_info Sets information to be contained in the wav file. $write -> set_info( 'artist' => 'Nightmares on Wax', 'name' => 'Mission Venice' ); file_name Returns the current filename. my $file = $write -> file_name(); 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 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 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 --------------------------------------------------------------------- AUTHORS --------------------------------------------------------------------- Nick Peskett (see http://www.peskett.co.uk/ for contact details). Brian Szymanski (0.07-0.11) Wolfram humann (pureperl 24 and 32 bit read support in 0.09) Kurt George Gjerde . (0.02-0.03) --------------------------------------------------------------------- END --------------------------------------------------------------------- Audio-Wav-0.13/META.yml0000664000175000017500000000065111735421365012653 0ustar skiski--- abstract: unknown author: - unknown build_requires: ExtUtils::MakeMaker: 0 configure_requires: ExtUtils::MakeMaker: 0 dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 6.62, CPAN::Meta::Converter version 2.112150' license: unknown meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Audio-Wav no_index: directory: - t - inc requires: {} version: 0.13 Audio-Wav-0.13/Wav.pm0000644000175000017500000001610111735421102012455 0ustar skiskipackage Audio::Wav; use strict; eval { require warnings; }; #it's ok if we can't load warnings use Audio::Wav::Tools; use vars qw( $VERSION ); $VERSION = '0.13'; BEGIN { eval { require Inline::C }; if($@) { $Audio::Wav::_has_inline = 0; } else { # Inline::C is confused with multiple import calls - it seems to # result in errors about @INC. hack around this by launching a # seperate process instead of simply checking $@ after: # eval { Inline->import(C => "int foo() { return 0; }\n"); }; use Config; # don't use $^X, which breaks mod_perl - https://rt.cpan.org/Ticket/Display.html?id=62060 my $path = $Config{perlpath}; if ($^O ne 'VMS') { $path .= $Config{_exe} unless $path =~ m/$Config{_exe}$/i; } my $inline_c_ok = `$path -e "require Inline::C; eval { Inline->import(C => q[int foo() { return 0; }]) }; print \\\$\@ ? 0 : 1"`; if($inline_c_ok) { $Audio::Wav::_has_inline = 1; } else { warn "Inline::C installed, but your C compiler doesn't seem to work with it\n"; $Audio::Wav::_has_inline = 0; } } } =head1 NAME Audio::Wav - Modules for reading & writing Microsoft WAV files. =head1 SYNOPSIS # copying a file and adding some cue points to the output file use Audio::Wav; my $wav = new Audio::Wav; my $read = $wav -> read( 'input.wav' ); my $write = $wav -> write( 'output.wav', $read -> details() ); print "input is ", $read -> length_seconds(), " seconds long\n"; $write -> set_info( 'software' => 'Audio::Wav' ); my $data; #read 512 bytes while ( defined( $data = $read -> read_raw( 512 ) ) ) { $write -> write_raw( $data ); } my $length = $read -> length_samples(); my( $third, $half, $twothirds ) = map int( $length / $_ ), ( 3, 2, 1.5 ); my %samp_loop = ( 'start' => $third, 'end' => $twothirds, ); $write -> add_sampler_loop( %samp_loop ); $write -> add_cue( $half, "cue label 1", "cue note 1" ); $write -> finish(); # splitting a multi-channel file to separate mono files (slowly!); use Audio::Wav; my $read = $wav -> read( '4ch.wav' ); my $details = $read -> details(); my %out_details = map { $_ => $details -> {$_} } 'bits_sample', 'sample_rate'; $out_details{channels} = 1; my @out_files; my $in_channels = $details -> {channels}; foreach my $channel ( 1 .. $in_channels ) { push @out_files, $wav -> write( 'multi_' . $channel . '.wav', \%out_details ); } while ( 1 ) { my @channels = $read -> read(); last unless @channels; foreach my $channel_id ( 0 .. $#channels ) { $out_files[$channel_id] -> write( $channels[$channel_id] ); } } # not entirely necessary as finish is done in DESTROY now (if the file hasn't been finished already). foreach my $write ( @out_files ) { $write -> finish(); } =head1 NOTES All sample positions are now in sample offsets (unless option '.01compatible' is true). There is now *very* basic support for WAVEFORMATEXTENSIBLE (in fact it only recognises that the file is in this format). The key 'wave-ex' is used in the detail hash to denote this format when reading or writing. I'd like to do more with this, but don't have any hardware or software to test these files, also don't really have any spare time to do the implementation at present. One day I plan to learn enough C to do the sample reading/ writing in XS, but for the time being it's done using pack/ unpack in Perl and is slow. Working with the raw format doesn't suffer in this way. It's likely that reading/ writing files with bit-depth greater than 16 won't work properly, I need to look at this at some point. =head1 DESCRIPTION These modules provide a method of reading & writing uncompressed Microsoft WAV files. =head1 SEE ALSO L L =head1 METHODS =head2 new Returns a blessed Audio::Wav object. All the parameters are optional and default to 0 my %options = ( '.01compatible' => 0, 'oldcooledithack' => 0, 'debug' => 0, ); my $wav = Audio::Wav -> new( %options ); =cut sub new { my ($class, @args) = @_; my $tools = Audio::Wav::Tools -> new( @args ); my $self = { 'tools' => $tools, }; bless $self, $class; return $self; } =head2 write Returns a blessed Audio::Wav::Write object. my $details = { 'bits_sample' => 16, 'sample_rate' => 44100, 'channels' => 2, }; my $write = $wav -> write( 'testout.wav', $details ); my $write = Audio::Wav -> write( 'testout.wav', $details); my $write = Audio::Wav -> write( 'testout.wav', $details, %options ); where %options is in the form of arguments for L. See L for methods. =cut sub write { my ($self, $file, $details, @args) = @_; require Audio::Wav::Write; my $write; if(ref $self) { $write = Audio::Wav::Write -> new( $file, $details, $self -> {tools} ); } else { $write = Audio::Wav::Write -> new( $file, Audio::Wav::Tools -> new( @args ) ); } return $write; } =head2 read Returns a blessed Audio::Wav::Read object. my $read = $wav -> read( 'testin.wav' ); my $read = Audio::Wav -> read( 'testin.wav' ); my $read = Audio::Wav -> read( 'testin.wav', %options ); where %options is in the form of arguments for L. See L for methods. =cut sub read { my ($self, $file, @args) = @_; require Audio::Wav::Read; my $read; if(ref $self) { $read = Audio::Wav::Read -> new( $file, $self -> {tools} ); } else { $read = Audio::Wav::Read -> new( $file, Audio::Wav::Tools -> new( @args ) ); } return $read; } =head2 set_error_handler Specifies a subroutine for catching errors. The subroutine should take a hash as input. The keys in the hash are 'filename', 'message' (error message), and 'warning'. If no error handler is set, die and warn will be used. sub myErrorHandler { my( %parameters ) = @_; if ( $parameters{warning} ) { # This is a non-critical warning warn "Warning: $parameters{filename}: $parameters{message}\n"; } else { # Critical error! die "ERROR: $parameters{filename}: $parameters{message}\n"; } } $wav -> set_error_handler( \&myErrorHandler ); =cut sub set_error_handler { my ($self, @args) = @_; $self -> {tools} -> set_error_handler( @args ); } =head1 COPYRIGHT Copyright (c) 2007-2012 Brian Szymanski Copyright (c) 1998-2006 Nick Peskett Copyright (c) 2001 Kurt George Gjerde =head1 AUTHORS Nick Peskett (see http://www.peskett.co.uk/ for contact details). Brian Szymanski (0.07-0.13) Wolfram humann (pureperl 24 and 32 bit read support in 0.09) Kurt George Gjerde . (0.02-0.03) see also Changes file =cut 1; __END__ Audio-Wav-0.13/COPYRIGHT0000644000175000017500000000025611676757153012707 0ustar skiskiCopyright (c) 2007,2010 Brian Szymanski Copyright (c) 1998-2006 Nick Peskett Copyright (c) 2001 Kurt George Gjerde