File Coverage

blib/lib/Net/SIP/DTMF.pm
Criterion Covered Total %
statement 191 201 95.0
branch 72 94 76.6
condition 23 39 58.9
subroutine 20 20 100.0
pod 2 2 100.0
total 308 356 86.5


line stmt bran cond sub pod time code
1             ###########################################################################
2             # Net::SIP::DTMF
3             # implements DTMF handling (audio and rfc2833)
4             ###########################################################################
5              
6 41     41   300 use strict;
  41         83  
  41         1172  
7 41     41   212 use warnings;
  41         85  
  41         1457  
8             package Net::SIP::DTMF;
9 41     41   232 use base 'Exporter';
  41         113  
  41         6162  
10             our @EXPORT = qw(dtmf_generator dtmf_extractor);
11              
12 41     41   303 use Net::SIP::Debug;
  41         87  
  41         287  
13 41     41   302 use Time::HiRes 'gettimeofday';
  41         78  
  41         484  
14 41     41   4165 use Carp 'croak';
  41         128  
  41         47867  
15              
16             ###########################################################################
17             # sub dtmf_generator returns a sub, which is used to generate RTP packet
18             # for DTMF events
19             # Args: ($event,$duration,%args)
20             # $event: DTMF event ([0-9A-D*#]), anything else will be pause
21             # $duration: duration in ms
22             # %args:
23             # rfc2833_type => $rtptype: if defined will generate RFC2833 RTP events
24             # audio_type => $rtptype: if defined will generate audio
25             # volume => volume for rfc2833 events (default 10)
26             # Returns: $sub
27             # $sub: sub which returns @rtp_packets when called with
28             # $sub->($seq,$timestamp,$srcid)
29             # if $sub returns () the DTMF event is finished (>duration)
30             # if $sub returns ('') no data are produced (pause between events)
31             # usually sub will return just one packet, but for RTP event ends it
32             # will return 3 to make sure that at least one gets received
33             #
34             ###########################################################################
35             sub dtmf_generator {
36 84     84 1 694 my ($event,$duration,%pargs) = @_;
37              
38             # empty or invalid stuff will cause pause/silence
39 84 100 66     924 $event = '' if ! defined $event or $event !~ m{[\dA-D\*\#]}i;
40              
41 84 100       444 if ( defined( my $type = $pargs{rfc2833_type} )) {
    50          
42             # create RFC2833 payload
43 42         226 return _dtmf_gen_rtpevent($event,$type,$duration,%pargs);
44             } elsif ( defined($type = $pargs{audio_type})) {
45             # create audio payload
46 42         249 return _dtmf_gen_audio($event,$type,$duration,%pargs);
47             } else {
48 0         0 croak "neither rfc2833 nor audio RTP type defined"
49             }
50             }
51              
52             ###########################################################################
53             # sub dtmf_extractor creates sub to extract DTMF from RTP
54             # Args: (%pargs)
55             # %pargs: rfc2833_type, audio_type like in dtmf_generator
56             # will try to extract DTMF from RTP packets for any type set, e.g.
57             # RFC2833 and audio can be done in parallel
58             # Returns: $sub
59             # $sub: should be called with ($packet,[$time]), if $time not
60             # given current time will be used. The $sub itself will return () if no
61             # event (end) was found and ($event,$duration,$type) if event was detected.
62             # $event is [0-9A-D*#], $type rfc2833|audio
63             # Comment: FIXME - maybe disable audio detection if a rfc2833 event was
64             # received. In this case the peer obviously uses rfc2833
65             ###########################################################################
66             sub dtmf_extractor {
67 9     9 1 52 my %pargs = @_;
68 9         31 my %sub;
69 9 50       46 if ( defined( my $type = delete $pargs{rfc2833_type} )) {
70             # extract from RFC2833 payload
71 9         54 $sub{$type} = _dtmf_xtc_rtpevent(%pargs);
72             }
73 9 50       87 if ( defined( my $type = delete $pargs{audio_type})) {
74             # extract from audio payload
75 9         78 $sub{$type} = _dtmf_xtc_audio(%pargs);
76             }
77 9 50       76 croak "neither rfc2833 nor audio RTP type defined" if ! %sub;
78              
79 9         25 my $lastseq;
80             return sub {
81 4208     4208   10896 my ($pkt,$time) = @_;
82 4208         25923 my ($ver,$type,$seq,$tstamp,$srcid,$payload) = unpack('CCnNNa*',$pkt);
83 4208 50       14121 $ver == 0b10000000 or return;
84 4208         6951 my $marker;
85 4208 100       10609 if ($type & 0b10000000) {
86 36         85 $marker = 1;
87 36         104 $type &= 0b01111111;
88             }
89              
90 4208         6289 my $seqdiff;
91 4208 100       9545 if (defined $lastseq) {
92 4199         9652 $seqdiff = (2**16 + $seq - $lastseq) & 0xffff;
93 4199 50       13720 if (!$seqdiff) {
    50          
94 0 0       0 $DEBUG && DEBUG(20,"dropping duplicate RTP");
95 0         0 return;
96             } elsif ($seqdiff>2**15) {
97 0 0       0 $DEBUG && DEBUG(20,"dropping out of order RTP");
98 0         0 return;
99             } else {
100 4199 50 33     11762 $DEBUG && $seqdiff>1 && DEBUG(30,'lost %d packets (%d-%d)',
101             $seqdiff-1,$lastseq+1,$seq-1);
102             }
103             }
104 4208         6963 $lastseq = $seq;
105              
106 4208 50       16685 my $sub = $sub{$type} or return;
107 4208 100       12078 my ($event,$duration,$media) = $sub->($payload,$time,$marker,$seqdiff)
108             or return;
109 72         664 return ($event, int(1000*$duration),$media);
110 9         341 };
111             }
112              
113              
114             ###########################################################################
115             # END OF PUBLIC INTERFACE
116             ###########################################################################
117              
118             ###########################################################################
119             #
120             # RTP DTMF events
121             #
122             ###########################################################################
123             # mapping between event string and integer for RTP events
124             my %event2i;
125             { my $i=0; %event2i = map { $_ => $i++ } split('','0123456789*#ABCD'); }
126             my %i2event = reverse %event2i;
127              
128              
129             ###########################################################################
130             # generate DTMF RTP events according to rfc2833
131             # Args: $event,$duration,%args
132             # %args: volume => v will be used to set volume of RTP event, default 10
133             # Returns: $sub for $event
134             # Comment: the sub should then be called with $sub->($seq,$timstamp,$srcid)
135             # This will generate the RTP packet.
136             # If $event is no DTMF event it will return '' to indicate pause
137             ###########################################################################
138             sub _dtmf_gen_rtpevent {
139 42     42   252 my ($event,$type,$duration,%args) = @_;
140 42   50     275 my $volume = $args{volume} || 10;
141              
142 42         143 $duration/=1000; # ms ->s
143 42         161 my $start = gettimeofday();
144 42         114 my $end = 0;
145 42         116 my $first = 1;
146 42         121 my $initial_timestamp;
147              
148             return sub {
149 777     777   2731 my ($seq,$timestamp,$srcid) = @_;
150              
151             # all packets get timestamp from start of event
152 777 100       2365 if ( ! $initial_timestamp ) {
153 42         137 $initial_timestamp = $timestamp;
154 42         213 return ''; # need another call to get duration
155             }
156              
157 735 100       3744 if ( gettimeofday() - $start > $duration ) {
158 84 100       471 return if $end; # end already sent
159 42         122 $end = 1;
160             }
161              
162 693 100       2526 return '' if $event eq '';
163              
164 639         1595 my $pt = $type;
165 639 100       2106 if ( $first ) {
166 24         56 $first = 0;
167 24         105 $pt |= 0b10000000; # marker bit set on first packet of event
168             }
169             return pack('CCnNNCCn',
170             0b10000000,
171             $pt,
172             $seq,
173             $initial_timestamp,
174             $srcid,
175 639 50       9322 $event2i{$event},
176             ($end<<7) | $volume,
177             $timestamp > $initial_timestamp
178             ? $timestamp - $initial_timestamp
179             : 0x10000 - $initial_timestamp + $timestamp,
180             );
181             }
182 42         648 }
183              
184             ###########################################################################
185             # returns sub to extract DTMF events from RTP telephone-event/8000 payload
186             # Args: NONE
187             # Returns: $sub
188             # $sub - will be called with ($rtp_payload,[$time],$marker)
189             # will return ($event,$duration) if DTMF event was found
190             ###########################################################################
191             sub _dtmf_xtc_rtpevent {
192 9     9   14 my $current_event;
193             return sub {
194 956     956   3308 my ($payload,$time,$marker) = @_;
195 956         3459 my ($event,$volume,$duration) = unpack('CCn',$payload);
196 956         3725 $event = $i2event{$event};
197 956         1879 my $end;
198 956 100       3310 if ( $volume & 0b10000000 ) {
199 36         95 $end = 1;
200 36         79 $volume &= 0b01111111
201             }
202 956 100       5034 if ( ! $current_event ) {
    50          
203 36 50       126 return if $end; # probably repeated send of end
204             # we don't look at the marker for initial packet, because maybe
205             # the initial packet got lost
206 36   33     431 $current_event = [ $event,$time||gettimeofday(),$volume ];
207             } elsif ( $event eq $current_event->[0] ) {
208 920 100       2951 if ( $end ) {
209             # explicit end of event
210 36         220 my $ce = $current_event;
211 36         93 $current_event = undef;
212 36   33     567 $time ||= gettimeofday();
213 36         684 return ($ce->[0],$time - $ce->[1],'rfc2833');
214             }
215             } else {
216             # implicit end because we got another event
217 0         0 my $ce = $current_event;
218 0   0     0 $time||= gettimeofday();
219 0         0 $current_event = [ $event,$time,$volume ];
220 0 0       0 return if ! $ce->[2]; # volume == 0
221 0         0 return ($ce->[0],$time - $ce->[1],'rfc2833');
222             }
223 920         7870 return;
224 9         337 };
225             }
226              
227             ###########################################################################
228             #
229             # RTP DTMF audio
230             #
231             ###########################################################################
232              
233             # mapping between frequence and key for audio
234             my @freq1 = (697,770,852,941);
235             my @freq2 = (1209,1336,1477,1633);
236             my @keys = '123A 456B 789C *0#D' =~m{(\S)}g;
237              
238             my (%event2f,@f2event);
239             for( my $i=0;$i<@keys;$i++ ) {
240             my $freq1 = $freq1[ $i/4 ];
241             my $freq2 = $freq2[ $i%4 ];
242             $event2f{$keys[$i]} = [$freq1,$freq2];
243             $f2event[$freq1][$freq2] = $keys[$i];
244             }
245              
246             # basic paramter, PCMU/8000 160 samples per RTP packet
247             my $volume = 100;
248             my $samples4s = 8000;
249             my $samples4pkt = 160;
250              
251 41     41   347 use constant PI => 3.14159265358979323846;
  41         85  
  41         56605  
252              
253             # tables for audio processing get computed on first use
254             # cosinus is precomputed. How exakt a cos will be depends on
255             # the size of the table $tabsize
256             my $tabsize = 256;
257             my @costab;
258              
259             # tables for PCMU u-law compression
260             my @ulaw_expandtab;
261             my @ulaw_compresstab;
262              
263             # Goertzel algorithm
264             my $gzpkts = 3; # 3 RTP packets = 60ms
265             my %coeff;
266             my @blackman; # exact blackman
267              
268             # precompute stuff into tables for faster operation
269             sub _init_audio_processing {
270              
271             # audio generation
272 4 50   4   18 @costab and return;
273 4         20 for(my $i=0;$i<$tabsize;$i++) {
274 1024         2713 $costab[$i] = $volume/100*16383*cos(2*PI*$i/$tabsize);
275             }
276              
277             # PCMU/8000 u-law (de)compression
278 4         33 for( my $i=0;$i<128;$i++) {
279 512         1248 $ulaw_expandtab[$i] = int( (256**($i/127) - 1) / 255 * 32767 );
280             }
281 4         40 my $j = 0;
282 4         35 for( my $i=0;$i<32768;$i++ ) {
283 131072         171852 $ulaw_compresstab[$i] = $j;
284 131072 100 100     389528 $j++ if $j<127 and $ulaw_expandtab[$j+1] - $i < $i - $ulaw_expandtab[$j];
285             }
286              
287 4         55 for my $freq (@freq1,@freq2) {
288 32         93 my $k = int(0.5+$samples4pkt*$freq/$samples4s);
289 32         56 my $w = 2*PI/$samples4pkt*$k;
290 32         159 $coeff{$freq} = 2*cos($w);
291             }
292              
293 4         10 my $n = $samples4pkt*$gzpkts;
294 4         61 for( my $i=0;$i<$n;$i++) {
295 1920         4459 $blackman[$i] = 0.426591 - 0.496561*cos(2*PI*$i/$n) +0.076848*cos(4*PI*$i/$n)
296             }
297             }
298              
299              
300             ###########################################################################
301             # sub _dtmf_gen_audio returns a sub to generate audio/silence for DTMF in
302             # any duration
303             # Args: $event,$duration
304             # Returns: $sub for $event
305             # Comment: the sub should then be called with $sub->($seq,$timstamp,$srcid)
306             # This will generate the RTP packet.
307             # If $event is no DTMF event it will return a sub which gives silence.
308             # Data returned from the subs are PCMU/8000, 160 samples per packet
309             ###########################################################################
310             sub _dtmf_gen_audio {
311 42     42   227 my ($event,$type,$duration) = @_;
312              
313 42         133 $duration/=1000; # ms ->s
314 42         145 my $start = gettimeofday();
315              
316 42         306 my $f = $event2f{$event};
317 42 100       171 if ( ! $f ) {
318             # generate silence
319             return sub {
320 72     72   195 my ($seq,$timestamp,$srcid) = @_;
321 72 100       365 return if gettimeofday() - $start > $duration; # done
322 54         515 return pack('CCnNNa*',
323             0b10000000,
324             $type,
325             $seq,
326             $timestamp,
327             $srcid,
328             pack('C',128) x $samples4pkt,
329             );
330             }
331 18         394 }
332              
333 24 50       92 _init_audio_processing() if !@costab;
334              
335 24         82 my ($f1,$f2) = @$f;
336 24         55 $f1*= $tabsize;
337 24         53 $f2*= $tabsize;
338 24         94 my $d1 = int($f1/$samples4s);
339 24         55 my $d2 = int($f2/$samples4s);
340 24         76 my $g1 = $f1 % $samples4s;
341 24         53 my $g2 = $f2 % $samples4s;
342 24         87 my $e1 = int($samples4s/2);
343 24         69 my $e2 = int($samples4s/2);
344 24         70 my $i1 = my $i2 = 0;
345              
346             return sub {
347 638     638   1931 my ($seq,$timestamp,$srcid) = @_;
348 638 100       3178 return if gettimeofday() - $start > $duration; # done
349              
350 614         1271 my $samples = $samples4pkt;
351 614         1443 my $buf = '';
352 614         1914 while ( $samples-- > 0 ) {
353 98240         139875 my $val = $costab[$i1]+$costab[$i2];
354 98240 100       209235 my $c = $val>=0 ? 255-$ulaw_compresstab[$val] : 127-$ulaw_compresstab[-$val];
355 98240         142191 $buf .= pack('C',$c);
356              
357 98240 100       151390 $e1+= $samples4s, $i1++ if $e1<0;
358 98240         130418 $i1 = ($i1+$d1) % $tabsize;
359 98240         116305 $e1-= $g1;
360              
361 98240 100       150048 $e2+= $samples4s, $i2++ if $e2<0;
362 98240         124115 $i2 = ($i2+$d2) % $tabsize;
363 98240         155066 $e2-= $g2;
364             }
365 614         4929 return pack('CCnNNa*',
366             0b10000000,
367             $type,
368             $seq,
369             $timestamp,
370             $srcid,
371             $buf,
372             );
373             }
374 24         554 }
375              
376              
377              
378             ###########################################################################
379             # returns sub to extract DTMF events from RTP PCMU/8000 payload
380             # Args: NONE
381             # Returns: $sub
382             # $sub - will be called with ($rtp_payload,[$time])
383             # will return ($event,$duration) if DTMF event was found, event being 0..15
384             ###########################################################################
385             sub _dtmf_xtc_audio {
386 9 100   9   76 _init_audio_processing() if !@costab;
387 9         47 my (%d1,%d2,@time,@lastev);
388             return sub {
389 3252     3252   6987 my ($payload,$time) = @_;
390 3252   33     18266 $time ||= gettimeofday();
391             my @samples = map {
392 3252 100       30255 ( $_<128 ? -$ulaw_expandtab[127-$_] : $ulaw_expandtab[255-$_] )/32768
  520320         937130  
393             } unpack('C*',$payload);
394 3252 50       21337 @samples == $samples4pkt or return; # unexpected sample size
395              
396 3252         7738 unshift @time, $time;
397              
398 3252         9402 for my $f (@freq1,@freq2) {
399 26016         46414 my $coeff = $coeff{$f};
400              
401 26016   100     58092 my $da1 = $d1{$f} ||= [];
402 26016   100     51746 my $da2 = $d2{$f} ||= [];
403 26016         43320 unshift @$da1,0;
404 26016         36164 unshift @$da2,0;
405              
406 26016         49821 for(my $gzi=0;$gzi<@$da1;$gzi++) {
407 77832         106123 my $d1 = $da1->[$gzi];
408 77832         97681 my $d2 = $da2->[$gzi];
409 77832         102479 my $o = $gzi*$samples4pkt;
410 77832         131838 for( my $i=0;$i<@samples;$i++) {
411 12453120         24830065 ($d2,$d1) = ($d1, $samples[$i]*$blackman[$i+$o] + $coeff*$d1 - $d2);
412             }
413 77832         112873 $da1->[$gzi] = $d1;
414 77832         165862 $da2->[$gzi] = $d2;
415             }
416             }
417              
418 3252 100       8520 return if @time < $gzpkts;
419              
420 3234         7540 $time = pop @time;
421 3234         5114 my @r;
422 3234         7845 for my $f (@freq1,@freq2) {
423 25872         33511 my $d1 = pop(@{$d1{$f}});
  25872         41847  
424 25872         32122 my $d2 = pop(@{$d2{$f}});
  25872         38373  
425 25872         75295 push @r, [ $f, $d1*$d1+$d2*$d2-$d1*$d2*$coeff{$f} ];
426             }
427              
428              
429             # the highest two freq should be significantly higher then rest
430 3234         16329 @r = sort { $b->[1] <=> $a->[1] } @r; # sort by magnitude, largest first
  44267         70999  
431 3234         5759 my $event;
432 3234 100 66     23603 if ( @r and ! $r[2][1] || $r[1][1]/$r[2][1]> 5 ) {
      66        
433 930         3076 $event = $f2event[ $r[0][0] ][ $r[1][0] ];
434 930 100       3375 $event = $f2event[ $r[1][0] ][ $r[0][0] ] if ! defined $event;
435             }
436              
437 3234 100       9524 $event = '' if ! defined $event;
438 3234         9397 push @lastev,[$event,$time];
439             # remove pause from start of lastev
440 3234   100     19780 shift(@lastev) while (@lastev && $lastev[0][0] eq '');
441              
442             # if last event same as first wait for more
443 3234 100       9979 if ( ! @lastev ) {
    100          
444             # return; # no events detected
445             } elsif ( $event eq $lastev[0][0] ) {
446 930         12328 return; # event not finished
447             } else {
448 36         121 my @ev = shift(@lastev);
449 36   66     413 while (@lastev and $lastev[0][0] eq $ev[0][0]) {
450 894         2918 push @ev,shift(@lastev);
451             }
452             # get the event at least 2 times
453 36 50       145 return if @ev == 1;
454 36         700 return ($ev[0][0],$ev[-1][1]-$ev[0][1],'audio'); # event,duration
455             }
456              
457 2268         27517 return;
458 9         356 };
459             }
460              
461             1;