###########################################################################
# Net::SIP::DTMF
# implements DTMF handling (audio and rfc2833)
###########################################################################
use strict;
use warnings;
package Net::SIP::DTMF;
use base 'Exporter';
our @EXPORT = qw(dtmf_generator dtmf_extractor);
use Net::SIP::Debug;
use Time::HiRes 'gettimeofday';
use Carp 'croak';
###########################################################################
# sub dtmf_generator returns a sub, which is used to generate RTP packet
# for DTMF events
# Args: ($event,$duration,%args)
# $event: DTMF event ([0-9A-D*#]), anything else will be pause
# $duration: duration in ms
# %args:
# rfc2833_type => $rtptype: if defined will generate RFC2833 RTP events
# audio_type => $rtptype: if defined will generate audio
# volume => volume for rfc2833 events (default 10)
# Returns: $sub
# $sub: sub which returns @rtp_packets when called with
# $sub->($seq,$timestamp,$srcid)
# if $sub returns () the DTMF event is finished (>duration)
# if $sub returns ('') no data are produced (pause between events)
# usually sub will return just one packet, but for RTP event ends it
# will return 3 to make sure that at least one gets received
#
###########################################################################
sub dtmf_generator {
my ($event,$duration,%pargs) = @_;
# empty or invalid stuff will cause pause/silence
$event = '' if ! defined $event or $event !~m{(\d)|([A-D])|(\*)|(\#)}i;
if ( defined( my $type = $pargs{rfc2833_type} )) {
# create RFC2833 payload
return _dtmf_gen_rtpevent($event,$type,$duration,%pargs);
} elsif ( defined($type = $pargs{audio_type})) {
# create audio payload
return _dtmf_gen_audio($event,$type,$duration,%pargs);
} else {
croak "neither rfc2833 nor audio RTP type defined"
}
}
###########################################################################
# sub dtmf_extractor creates sub to extract DTMF from RTP
# Args: (%pargs)
# %pargs: rfc2833_type, audio_type like in dtmf_generator
# will try to extract DTMF from RTP packets for any type set, e.g.
# RFC2833 and audio can be done in parallel
# Returns: $sub
# $sub: should be called with ($packet,[$time]), if $time not
# given current time will be used. The $sub itself will return () if no
# event (end) was found and ($event,$duration,$type) if event was detected.
# $event is [0-9A-D*#], $type rfc2833|audio
# Comment: FIXME - maybe disable audio detection if a rfc2833 event was
# received. In this case the peer obviously uses rfc2833
###########################################################################
sub dtmf_extractor {
my %pargs = @_;
my %sub;
if ( defined( my $type = delete $pargs{rfc2833_type} )) {
# extract from RFC2833 payload
$sub{$type} = _dtmf_xtc_rtpevent(%pargs);
}
if ( defined( my $type = delete $pargs{audio_type})) {
# extract from audio payload
$sub{$type} = _dtmf_xtc_audio(%pargs);
}
croak "neither rfc2833 nor audio RTP type defined" if ! %sub;
return sub {
my ($pkt,$time) = @_;
my ($ver,$type,$seq,$tstamp,$srcid,$payload) = unpack('CCnNNa*',$pkt);
$ver == 0b10000000 or return;
my $marker;
if ($type & 0b10000000) {
$marker = 1;
$type &= 0b01111111;
}
my $sub = $sub{$type} or return;
my ($event,$duration,$media) = $sub->($payload,$time,$marker) or return;
return ($event, int(1000*$duration),$media);
};
}
###########################################################################
# END OF PUBLIC INTERFACE
###########################################################################
###########################################################################
#
# RTP DTMF events
#
###########################################################################
# mapping between event string and integer for RTP events
my %event2i;
{ my $i=0; %event2i = map { $_ => $i++ } split('','0123456789*#ABCD'); }
my %i2event = reverse %event2i;
###########################################################################
# generate DTMF RTP events according to rfc2833
# Args: $event,$duration,%args
# %args: volume => v will be used to set volume of RTP event, default 10
# Returns: $sub for $event
# Comment: the sub should then be called with $sub->($seq,$timstamp,$srcid)
# This will generate the RTP packet.
# If $event is no DTMF event it will return '' to indicate pause
###########################################################################
sub _dtmf_gen_rtpevent {
my ($event,$type,$duration,%args) = @_;
my $volume = $args{volume} || 10;
$duration/=1000; # ms ->s
my $start = gettimeofday();
my $end = 0;
my $first = 1;
my $initial_timestamp;
return sub {
my ($seq,$timestamp,$srcid) = @_;
# all packets get timestamp from start of event
if ( ! $initial_timestamp ) {
$initial_timestamp = $timestamp;
return ''; # need another call to get duration
}
if ( gettimeofday() - $start > $duration ) {
return if $end; # end already sent
$end = 1;
}
return '' if $event eq '';
my $pt = $type;
if ( $first ) {
$first = 0;
$pt |= 0b10000000; # marker bit set on first packet of event
}
return pack('CCnNNCCn',
0b10000000,
$pt,
$seq,
$initial_timestamp,
$srcid,
$event2i{$event},
($end<<7) | $volume,
$timestamp > $initial_timestamp
? $timestamp - $initial_timestamp
: 0x10000 - $initial_timestamp + $timestamp,
);
}
}
###########################################################################
# returns sub to extract DTMF events from RTP telephone-event/8000 payload
# Args: NONE
# Returns: $sub
# $sub - will be called with ($rtp_payload,[$time],$marker)
# will return ($event,$duration) if DTMF event was found
###########################################################################
sub _dtmf_xtc_rtpevent {
my $current_event;
return sub {
my ($payload,$time,$marker) = @_;
my ($event,$volume,$duration) = unpack('CCn',$payload);
$event = $i2event{$event};
my $end;
if ( $volume & 0b10000000 ) {
$end = 1;
$volume &= 0b01111111
}
if ( ! $current_event ) {
return if $end; # probably repeated send of end
# we don't look at the marker for initial packet, because maybe
# the initial packet got lost
$current_event = [ $event,$time||gettimeofday(),$volume ];
} elsif ( $event eq $current_event->[0] ) {
if ( $end ) {
# explicit end of event
my $ce = $current_event;
$current_event = undef;
$time ||= gettimeofday();
return ($ce->[0],$time - $ce->[1],'rfc2833');
}
} else {
# implicit end because we get another event
my $ce = $current_event;
$time||= gettimeofday();
$current_event = [ $event,$time,$volume ];
return if ! $ce->[2]; # volume == 0
return ($ce->[0],$time - $ce->[1],'rfc2833');
}
return;
};
}
###########################################################################
#
# RTP DTMF audio
#
###########################################################################
# mapping between frequence and key for audio
my @freq1 = (697,770,852,941);
my @freq2 = (1209,1336,1477,1633);
my @keys = '123A 456B 789C *0#D' =~m{(\S)}g;
my (%event2f,@f2event);
for( my $i=0;$i<@keys;$i++ ) {
my $freq1 = $freq1[ $i/4 ];
my $freq2 = $freq2[ $i%4 ];
$event2f{$keys[$i]} = [$freq1,$freq2];
$f2event[$freq1][$freq2] = $keys[$i];
}
# basic paramter, PCMU/8000 160 samples per RTP packet
my $volume = 100;
my $samples4s = 8000;
my $samples4pkt = 160;
use constant PI => 3.14159265358979323846;
# tables for audio processing get computed on first use
# cosinus is precomputed. How exakt a cos will be depends on
# the size of the table $tabsize
my $tabsize = 256;
my @costab;
# tables for PCMU u-law compression
my @ulaw_expandtab;
my @ulaw_compresstab;
# Goertzel algorithm
my $gzpkts = 3; # 3 RTP packets = 60ms
my %coeff;
my @blackman; # exact blackman
# precompute stuff into tables for faster operation
sub _init_audio_processing {
# audio generation
@costab and return;
for(my $i=0;$i<$tabsize;$i++) {
$costab[$i] = $volume/100*16383*cos(2*PI*$i/$tabsize);
}
# PCMU/8000 u-law (de)compression
for( my $i=0;$i<128;$i++) {
$ulaw_expandtab[$i] = int( (256**($i/127) - 1) / 255 * 32767 );
}
my $j = 0;
for( my $i=0;$i<32768;$i++ ) {
$ulaw_compresstab[$i] = $j;
$j++ if $j<127 and $ulaw_expandtab[$j+1] - $i < $i - $ulaw_expandtab[$j];
}
for my $freq (@freq1,@freq2) {
my $k = int(0.5+$samples4pkt*$freq/$samples4s);
my $w = 2*PI/$samples4pkt*$k;
$coeff{$freq} = 2*cos($w);
}
my $n = $samples4pkt*$gzpkts;
for( my $i=0;$i<$n;$i++) {
$blackman[$i] = 0.426591 - 0.496561*cos(2*PI*$i/$n) +0.076848*cos(4*PI*$i/$n)
}
}
###########################################################################
# sub _dtmf_gen_audio returns a sub to generate audio/silence for DTMF in
# any duration
# Args: $event,$duration
# Returns: $sub for $event
# Comment: the sub should then be called with $sub->($seq,$timstamp,$srcid)
# This will generate the RTP packet.
# If $event is no DTMF event it will return a sub which gives silence.
# Data returned from the subs are PCMU/8000, 160 samples per packet
###########################################################################
sub _dtmf_gen_audio {
my ($event,$type,$duration) = @_;
$duration/=1000; # ms ->s
my $start = gettimeofday();
my $f = $event2f{$event};
if ( ! $f ) {
# generate silence
return sub {
my ($seq,$timestamp,$srcid) = @_;
return if gettimeofday() - $start > $duration; # done
return pack('CCnNNa*',
0b10000000,
$type,
$seq,
$timestamp,
$srcid,
pack('C',128) x $samples4pkt,
);
}
}
_init_audio_processing() if !@costab;
my ($f1,$f2) = @$f;
$f1*= $tabsize;
$f2*= $tabsize;
my $d1 = int($f1/$samples4s);
my $d2 = int($f2/$samples4s);
my $g1 = $f1 % $samples4s;
my $g2 = $f2 % $samples4s;
my $e1 = int($samples4s/2);
my $e2 = int($samples4s/2);
my $i1 = my $i2 = 0;
return sub {
my ($seq,$timestamp,$srcid) = @_;
return if gettimeofday() - $start > $duration; # done
my $samples = $samples4pkt;
my $buf = '';
while ( $samples-- > 0 ) {
my $val = $costab[$i1]+$costab[$i2];
my $c = $val>=0 ? 255-$ulaw_compresstab[$val] : 127-$ulaw_compresstab[-$val];
$buf .= pack('C',$c);
$e1+= $samples4s, $i1++ if $e1<0;
$i1 = ($i1+$d1) % $tabsize;
$e1-= $g1;
$e2+= $samples4s, $i2++ if $e2<0;
$i2 = ($i2+$d2) % $tabsize;
$e2-= $g2;
}
return pack('CCnNNa*',
0b10000000,
$type,
$seq,
$timestamp,
$srcid,
$buf,
);
}
}
###########################################################################
# returns sub to extract DTMF events from RTP PCMU/8000 payload
# Args: NONE
# Returns: $sub
# $sub - will be called with ($rtp_payload,[$time])
# will return ($event,$duration) if DTMF event was found, event being 0..15
###########################################################################
sub _dtmf_xtc_audio {
_init_audio_processing() if !@costab;
my (%d1,%d2,@time,@lastev);
return sub {
my ($payload,$time) = @_;
$time ||= gettimeofday();
my @samples = map {
( $_<128 ? -$ulaw_expandtab[127-$_] : $ulaw_expandtab[255-$_] )/32768
} unpack('C*',$payload);
@samples == $samples4pkt or return; # unexpected sample size
unshift @time, $time;
for my $f (@freq1,@freq2) {
my $coeff = $coeff{$f};
my $da1 = $d1{$f} ||= [];
my $da2 = $d2{$f} ||= [];
unshift @$da1,0;
unshift @$da2,0;
for(my $gzi=0;$gzi<@$da1;$gzi++) {
my $d1 = $da1->[$gzi];
my $d2 = $da2->[$gzi];
my $o = $gzi*$samples4pkt;
for( my $i=0;$i<@samples;$i++) {
($d2,$d1) = ($d1, $samples[$i]*$blackman[$i+$o] + $coeff*$d1 - $d2);
}
$da1->[$gzi] = $d1;
$da2->[$gzi] = $d2;
}
}
return if @time < $gzpkts;
$time = pop @time;
my @r;
for my $f (@freq1,@freq2) {
my $d1 = pop(@{$d1{$f}});
my $d2 = pop(@{$d2{$f}});
push @r, [ $f, $d1*$d1+$d2*$d2-$d1*$d2*$coeff{$f} ];
}
# the highest two freq should be significantly higher then rest
@r = sort { $b->[1] <=> $a->[1] } @r; # sort by magnitude, largest first
my $event;
if ( @r and ! $r[2][1] || $r[1][1]/$r[2][1]> 5 ) {
$event = $f2event[ $r[0][0] ][ $r[1][0] ];
$event = $f2event[ $r[1][0] ][ $r[0][0] ] if ! defined $event;
}
$event = '' if ! defined $event;
push @lastev,[$event,$time];
# remove pause from start of lastev
shift(@lastev) while (@lastev && $lastev[0][0] eq '');
# if last event same as first wait for more
if ( ! @lastev ) {
# return; # no events detected
} elsif ( $event eq $lastev[0][0] ) {
return; # event not finished
} else {
my @ev = shift(@lastev);
while (@lastev and $lastev[0][0] eq $ev[0][0]) {
push @ev,shift(@lastev);
}
# get the event at least 2 times
return if @ev == 1;
return ($ev[0][0],$ev[-1][1]-$ev[0][1],'audio'); # event,duration
}
return;
};
}
1;