This file is indexed.

/usr/share/perl5/Net/SIP/DTMF.pm is in libnet-sip-perl 0.66-1.

This file is owned by root:root, with mode 0o644.

The actual contents of the file can be viewed below.

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
###########################################################################
# 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;