File Coverage

blib/lib/Audio/Wav/Write/Header.pm
Criterion Covered Total %
statement 183 190 96.3
branch 31 50 62.0
condition 2 6 33.3
subroutine 17 18 94.4
pod 0 7 0.0
total 233 271 85.9


line stmt bran cond sub pod time code
1             package Audio::Wav::Write::Header;
2              
3 1     1   8 use strict;
  1         3  
  1         61  
4             eval { require warnings; }; #it's ok if we can't load warnings
5              
6 1     1   7 use vars qw( $VERSION );
  1         2  
  1         2495  
7             $VERSION = '0.14';
8              
9             sub new {
10 2     2 0 4 my ($class, $file, $details, $tools, $handle) = @_;
11 2         13 my $self = {
12             'file' => $file,
13             'data' => undef,
14             'details' => $details,
15             'tools' => $tools,
16             'handle' => $handle,
17             'whole_offset' => 4,
18             };
19 2         6 bless $self, $class;
20 2         6 return $self;
21             }
22              
23             sub start {
24 2     2 0 3 my $self = shift;
25 2         4 my $output = 'RIFF';
26 2         5 $output .= pack 'V', 0;
27 2         3 $output .= 'WAVE';
28              
29 2         11 my $format = $self -> _format();
30 2         10 $output .= 'fmt ' . pack( 'V', length $format ) . $format;
31 2         4 $output .= 'data';
32 2         3 my $data_off = length $output;
33 2         4 $output .= pack 'V', 0;
34              
35 2         4 $self -> {'data_offset'} = $data_off;
36 2         8 $self -> {'total'} = length( $output ) - 8;
37              
38 2         7 return $output;
39             }
40              
41             sub finish {
42 2     2 0 3 my $self = shift;
43 2         10 my $data_size = shift;
44 2         4 my $handle = $self -> {'handle'};
45              
46             # padding data chunk
47 2         4 my $data_pad=0;
48 2 50       8 if ( $data_size % 2 ) {
49 0         0 my $pad = "\0";
50 0         0 syswrite $handle, $pad, 1;
51 0         0 $data_pad = 1; # to add to whole_num, not data_num
52             }
53              
54 2         10 my $extra = $self -> _write_list_info();
55 2         8 $extra += $self -> _write_cues();
56 2         8 $extra += $self -> _write_list_adtl();
57 2         8 $extra += $self -> _write_display();
58 2         6 $extra += $self -> _write_sampler_info();
59              
60 2         9 my $whole_num = pack 'V', $self -> {'total'} + $data_size + $data_pad + $extra; #includes padding
61 2         3 my $len_long = length $whole_num;
62              
63             # RIFF-length
64 2         5 my $seek_to = $self -> {'whole_offset'};
65 2 50       20 seek( $handle, $seek_to, 0 ) || return $self -> _error( "unable to seek to $seek_to ($!)" );
66 2         19 syswrite $handle, $whole_num, $len_long;
67              
68             # data-length
69 2         10 $seek_to = $self -> {'data_offset'};
70 2 50       16 seek( $handle, $seek_to, 0 ) || return $self -> _error( "unable to seek to $seek_to ($!)" );
71 2         6 my $data_num = pack 'V', $data_size;
72 2         18 syswrite $handle, $data_num, $len_long;
73 2         13 return 1;
74             }
75              
76             sub add_cue {
77 6     6 0 12 my $self = shift;
78 6         8 my $record = shift;
79 6         7 push @{ $self -> {'cues'} }, $record;
  6         13  
80 6         21 return 1;
81             }
82              
83             sub add_display {
84 2     2 0 5 my ($self, %hash) = @_;
85 2 50 33     13 unless ( exists $hash{'id'} && exists $hash{'data'} ) {
86 0         0 return $self -> _error( 'I need fields id & data to add a display block' );
87             }
88 2         4 push @{ $self -> {'display'} }, { map { $_ => $hash{$_} } qw( id data ) };
  2         5  
  4         32  
89 2         9 return 1;
90             }
91              
92             sub set_sampler_info {
93 2     2 0 9 my ($self, %hash) = @_;
94 2         11 my %defaults = $self -> {'tools'} -> get_sampler_defaults();
95 2         8 foreach my $key ( keys %defaults ) {
96 16 100       32 next if exists $hash{$key};
97 8         22 $hash{$key} = $defaults{$key};
98             }
99 2         11 $hash{'sample_loops'} = 0;
100 2         6 $hash{'loop'} = [];
101 2         6 $self -> {'sampler'} = \%hash;
102 2         8 return 1;
103             }
104              
105             sub add_sampler_loop {
106 2     2 0 7 my ($self, %hash) = @_;
107 2         4 foreach my $need ( qw( start end ) ) {
108 4 50       10 if ( exists $hash{$need} ) {
109 4         9 $hash{$need} = int $hash{$need};
110             } else {
111 0         0 return $self -> _error( "missing $need field from add_sampler_loop" );
112             }
113             }
114 2         13 my %defaults = $self -> {'tools'} -> get_sampler_loop_defaults();
115 2         6 foreach my $key ( keys %defaults ) {
116 4 100       11 next if exists $hash{$key};
117 2         5 $hash{$key} = $defaults{$key};
118             }
119 2 100       10 unless ( exists $self -> {'sampler'} ) {
120 1         5 $self -> set_sampler_info();
121             }
122 2         5 my $sampler = $self -> {'sampler'};
123 2         3 my $id = scalar( @{ $sampler -> {'loop'} } ) + 1;
  2         6  
124 2         4 foreach my $key ( qw( id play_count ) ) {
125 4 100       11 next if exists $hash{$key};
126 2         7 $hash{$key} = $id;
127             }
128 2         4 push @{ $sampler -> {'loop'} }, \%hash;
  2         4  
129 2         3 $sampler -> {'sample_loops'} ++;
130 2         9 return 1;
131             }
132              
133             sub _write_list_adtl {
134 2     2   4 my $self = shift;
135 2 50       14 return 0 unless $self -> {'cues'};
136 2         4 my $cues = $self -> {'cues'};
137 2         4 my %adtl;
138 2         4 foreach my $id ( 0 .. $#{$cues} ) {
  2         5  
139 6         9 my $cue = $cues -> [$id];
140 6         9 my $cue_id = $id + 1;
141 6 50       17 if ( exists $cue -> {'label'} ) {
142 6         18 $adtl{'labl'} -> {$cue_id} = $cue -> {'label'};
143             }
144 6 50       17 if ( exists $cue -> {'note'} ) {
145 6         18 $adtl{'note'} -> {$cue_id} = $cue -> {'note'};
146             }
147             }
148              
149 2 50       7 return 0 unless ( keys %adtl );
150 2         3 my $adtl = 'adtl';
151              
152 2         12 foreach my $type ( sort keys %adtl ) {
153 4         6 foreach my $id ( sort { $a <=> $b } keys %{ $adtl{$type} } ) {
  11         22  
  4         20  
154 12         42 $adtl .= $self -> _make_chunk( $type, pack( 'V', $id ) . $adtl{$type} -> {$id} . "\0" );
155             }
156             }
157 2         8 return $self -> _write_block( 'LIST', $adtl );
158             }
159              
160             sub _write_list_info {
161 2     2   3 my $self = shift;
162 2 50       4 return 0 unless keys %{ $self -> {'details'} -> {'info'} };
  2         11  
163 2         6 my $info = $self -> {'details'} -> {'info'};
164 2         9 my %allowed = $self -> {'tools'} -> get_rev_info_fields();
165 2         9 my $list='INFO';
166 2         4 foreach my $key ( keys %{$info} ) {
  2         6  
167 2 50       5 next unless $allowed{$key}; # don't write unknown info-chunks
168 2         11 $list .= $self -> _make_chunk( $allowed{$key}, $info -> {$key} . "\0" );
169             }
170 2         8 return $self -> _write_block( 'LIST', $list );
171             }
172              
173             sub _write_cues {
174 2     2   4 my $self = shift;
175 2 50       8 return 0 unless $self -> {'cues'};
176 2         4 my $cues = $self -> {'cues'};
177 2         48 my @fields = qw( id position chunk cstart bstart offset );
178 2         7 my %plain = ( 'chunk' => 1 );
179 2         2 my %defaults;
180 2         3 my $output = pack 'V', scalar @{$cues};
  2         8  
181 2         5 foreach my $id ( 0 .. $#{$cues} ) {
  2         6  
182 6         9 my $cue = $cues -> [$id];
183 6         11 my $pos = $cue -> {'pos'};
184 6         28 my %record = (
185             'id' => $id + 1,
186             'position' => $pos,
187             'chunk' => 'data',
188             'cstart' => 0,
189             'bstart' => 0,
190             'offset' => $pos,
191             );
192 6         9 foreach my $field ( @fields ) {
193 36         49 my $data = $record{$field};
194 36 100       91 $data = pack 'V', $data unless exists $plain{$field};
195 36         67 $output .= $data;
196             }
197             }
198 2         5 my $data_len = length $output;
199 2 50       5 return 0 unless $data_len;
200 2         8 $output = 'cue ' . pack( 'V', $data_len ) . $output;
201 2         3 $data_len += 8;
202 2         29 syswrite $self -> {'handle'}, $output, $data_len;
203 2         7 return $data_len;
204             }
205              
206             sub _write_sampler_info {
207 2     2   4 my $self = shift;
208 2 50       6 return 0 unless exists $self -> {'sampler'};
209 2         4 my $sampler = $self -> {'sampler'};
210 2         8 my %sampler_fields = $self -> {'tools'} -> get_sampler_fields();
211 2         5 my $output = '';
212 2         4 foreach my $field ( @{ $sampler_fields{'fields'} } ) {
  2         4  
213 18         33 $output .= pack 'V', $sampler -> {$field};
214             }
215 2         4 foreach my $loop ( @{ $sampler -> {'loop'} } ) {
  2         5  
216 2         2 foreach my $loop_field ( @{ $sampler_fields{'loop'} } ) {
  2         4  
217 12         26 $output .= pack 'V', $loop -> {$loop_field};
218             }
219             }
220 2         7 return $self -> _write_block( 'smpl', $output );
221             }
222              
223             sub _write_display {
224 2     2   4 my $self = shift;
225 2 50       20 return 0 unless exists $self -> {'display'};
226 2         5 my $total = 0;
227 2         2 foreach my $display ( @{ $self -> {'display'} } ) {
  2         6  
228 2         4 my $data = $display -> {'data'};
229 2         5 my $output = pack( 'V', $display -> {'id'} ) . $data;
230 2         4 my $data_size = length $data;
231 2         3 $total .= $self -> _write_block( 'DISP', $output );
232             }
233 2         6 return $total;
234             }
235              
236             sub _write_block {
237 8     8   19 my $self = shift;
238 8         11 my $header = shift;
239 8         9 my $output = shift;
240 8 50       16 return unless $output;
241 8         20 $output = $self->_make_chunk( $header, $output );
242 8         129 return syswrite $self -> {'handle'}, $output, length $output;
243             }
244              
245             sub _make_chunk {
246 22     22   25 my $self = shift;
247 22         24 my $header = shift;
248 22         28 my $output = shift;
249 22         26 my $data_len = length $output;
250 22 50       43 return '' unless $data_len;
251 22 100       47 $output .= "\0" if $data_len % 2; # pad byte
252 22         97 return $header . pack( 'V', $data_len ) . $output;
253             }
254              
255             sub _format {
256 2     2   4 my $self = shift;
257 2         8 my $details = $self -> {'details'};
258 2         11 my $types = $self -> {'tools'} -> get_wav_pack();
259 2 50 33     13 my $wave_ex = exists( $details -> {'wave-ex'} ) && $details -> {'wave-ex'} ? 1 : 0;
260 2 50       5 $details -> {'format'} = $wave_ex ? 65534 : 1;
261 2         4 my $output;
262 2         2 foreach my $type ( @{ $types -> {'order'} } ) {
  2         5  
263 12         36 $output .= pack $types -> {'types'} -> {$type}, $details -> {$type};
264             }
265 2         12 return $output;
266             }
267              
268             sub _error {
269 0     0     my ($self, @args) = @_;
270 0           return $self -> {'tools'} -> error( $self -> {'file'}, @args );
271             }
272              
273             1;