File Coverage

blib/lib/Net/SIP/SDP.pm
Criterion Covered Total %
statement 197 223 88.3
branch 69 132 52.2
condition 17 45 37.7
subroutine 19 19 100.0
pod 8 8 100.0
total 310 427 72.6


line stmt bran cond sub pod time code
1             ###########################################################################
2             # Net::SIP::SDP
3             # parse and manipulation of SDP packets in the context relevant for SIP
4             # Spec:
5             # RFC2327 - base RFC for SDP
6             # RFC3264 - offer/answer model with SDP (used in SIP RFC3261)
7             # RFC3266 - IP6 in SDP
8             # RFC3605 - "a=rtcp:port" attribute UNSUPPORTED!!!!
9             ###########################################################################
10              
11 44     44   257 use strict;
  44         81  
  44         9311  
12 44     44   209 use warnings;
  44         79  
  44         1813  
13             package Net::SIP::SDP;
14 44     44   21684 use Hash::Util qw(lock_keys);
  44         103257  
  44         250  
15 44     44   3210 use Net::SIP::Debug;
  44         108  
  44         239  
16 44     44   656 use Net::SIP::Util qw(ip_is_v4 ip_is_v6);
  44         123  
  44         1880  
17 44     44   234 use Socket;
  44         82  
  44         18193  
18 44     44   324 use Scalar::Util 'looks_like_number';
  44         83  
  44         105105  
19              
20              
21             ###########################################################################
22             # create new Net::SIP::SDP packet from string or parts
23             # Args: see new_from_parts|new_from_string
24             # Returns: $self
25             ###########################################################################
26             sub new {
27 100     100 1 273 my $class = shift;
28 100 100       701 return $class->new_from_parts(@_) if @_>1;
29 48         110 my $data = shift;
30 48 50 33     477 return ( !ref($data) || UNIVERSAL::isa( $data,'ARRAY' ))
31             ? $class->new_from_string( $data )
32             : $class->new_from_parts( $data );
33             }
34              
35             ###########################################################################
36             # create new Net::SIP::SDP packet from parts
37             # Args: ($class,$global,@media)
38             # $global: \%hash of (key,val) for global section, val can be
39             # scalar or array-ref (for multiple val). keys can be the
40             # on-letter SDP keys and the special key 'addr' for constructing
41             # a connection-field
42             # @media: list of \%hashes. val in hash can be scalar or array-ref
43             # (for multiple val), keys can be on-letter SDP keys or the special
44             # keys addr (for connection-field), port,range,proto,media,fmt (for
45             # media description)
46             # Returns: $self
47             ###########################################################################
48             sub new_from_parts {
49 52     52 1 180 my ($class,$global,@media) = @_;
50              
51 52         230 my %g = %$global;
52 52         181 my $g_addr = delete $g{addr};
53 52 50       179 die "no support for time rates" if $g{r};
54              
55 52         94 my $atyp;
56 52 50 33     639 if ($g_addr && !$g{c}) {
57 52 50       305 $atyp = ip_is_v4($g_addr) ? 'IP4':'IP6';
58 52         372 $g{c} = "IN $atyp $g_addr";
59             }
60 52 50       648 $g{t} = "0 0" if !$g{t};
61              
62 52         149 my @gl;
63 52         247 my %global_self = ( lines => \@gl, addr => $g_addr );
64 52         244 lock_keys(%global_self);
65              
66 52         604 my @media_self;
67 52         650 my $self = bless {
68             global => \%global_self,
69             addr => $g_addr,
70             media => \@media_self
71             },$class;
72 52         317 lock_keys(%$self);
73              
74             # first comes the version
75 52   50     1131 push @gl,[ 'v',delete($g{v}) || 0 ];
76              
77             # then the origin
78 52         150 my $o = delete($g{o});
79 52 50       147 if ( !$o ) {
80 52         104 my $t = time();
81 52   0     147 $atyp ||= $g{c} =~m{^IN (IP4|IP6) } && $1;
      33        
82 52   33     295 $o = "anonymous $t $t IN $atyp ".( $g_addr
83             || ($atyp eq 'IP4' ? '127.0.0.1' : '::1') );
84             }
85 52         149 push @gl,[ 'o',$o ];
86              
87             # session name
88 52   50     889 push @gl,[ 's', delete($g{s}) || 'session' ];
89              
90             # various headers in the right order
91 52         219 foreach my $key (qw( i u e p c b t z k a )) {
92 520         745 my $v = delete $g{$key};
93 520 100       965 defined($v) || next;
94 104 50       278 foreach ( ref($v) ? @$v:($v) ) {
95 104         368 push @gl, [ $key,$_ ];
96             }
97             }
98              
99             # die on unknown keys
100 52 50       202 die "bad keys in global: ".join( ' ',keys(%g)) if %g;
101              
102             # media descriptions
103 52         222 foreach my $m (@media) {
104 52         523 DEBUG_DUMP( 100,$m );
105 52         304 my %m = %$m;
106 52         129 delete $m{lines};
107 52         79 my @lines;
108 52         204 my %m_self = ( lines => \@lines );
109              
110             # extract from 'm' line or from other args
111 52 50       182 if ( my $mline = delete $m{m} ) {
112 0         0 push @lines,[ 'm',$mline ];
113 0         0 @m_self{qw(media port range proto fmt)} = _split_m( $mline );
114             } else {
115 52         186 foreach (qw( port media proto )) {
116 156 50       501 defined( $m_self{$_} = delete $m{$_} )
117             || die "no $_ in media description";
118             }
119             $m_self{range} = delete($m{range})
120 52   66     1066 || ( $m_self{proto} =~m{^RTP/} ? 2:1 );
121             defined( my $fmt = $m_self{fmt} = delete $m{fmt} )
122 52 50       267 || die "no fmt in media description";
123 52         734 my $mline = _join_m( @m_self{qw(media port range proto)},$fmt );
124 52         232 push @lines, [ 'm',$mline ];
125             }
126              
127             # if no connection line given construct one, if addr ne g_addr
128 52 50       198 if ( !$m{c} ) {
129 52 50       198 if ( my $addr = delete $m{addr} ) {
    50          
130 0         0 $m_self{addr} = $addr;
131 0 0       0 $m{c} = _join_c($addr) if $addr ne $g_addr;
132             } elsif ( $g_addr ) {
133 52         140 $m_self{addr} = $g_addr;
134             } else {
135 0         0 die "neither local nor global address for media";
136             }
137             } else {
138 0         0 $m_self{addr} = _split_c($m{c});
139             }
140              
141             # various headers in the right order
142 52         179 foreach my $key (qw( i c b k a )) {
143 260         355 my $v = delete $m{$key};
144 260 100       560 defined($v) || next;
145 52 50       261 foreach ( ref($v) ? @$v:($v) ) {
146 104         441 push @lines, [ $key,$_ ];
147             }
148             }
149             # die on unknown keys
150 52 50       189 die "bad keys in media: ".join( ' ',keys(%m)) if %m;
151              
152 52         196 lock_keys(%m_self);
153 52         613 push @media_self,\%m_self;
154             }
155              
156 52         632 return $self;
157             }
158              
159              
160             ###########################################################################
161             # create new Net::SIP::SDP packet from string or lines
162             # Args: ($class,$string)
163             # $string: either scalar or \@list_of_lines_in_string
164             # Returns: $self
165             ###########################################################################
166             sub new_from_string {
167 48     48 1 224 my ($class,$string) = @_;
168              
169             # split into lines
170 48 50 33     208 Carp::confess('expected string or ARRAY ref' )
171             if ref($string) && ref( $string ) ne 'ARRAY';
172 48 50       869 my @lines = ref($string)
173             ? @$string
174             : split( m{\r?\n}, $string );
175              
176             # split lines into key,val
177 48         282 foreach my $l (@lines) {
178 384 50       1636 my ($key,$val) = $l=~m{^([a-z])=(.*)}
179             or die "bad SDP line '$l'";
180 384         1037 $l = [ $key,$val ];
181             }
182              
183             # SELF:
184             # global {
185             # lines => [],
186             # addr # globally defined addr (if any)
187             # }
188             # media [
189             # {
190             # lines => [],
191             # addr # addr for ports
192             # port # starting port
193             # range # range of ports (1..)
194             # proto # udp, RTP/AVP,..
195             # media # audio|video|data...
196             # }
197             # ]
198              
199 48         110 my (%global,@media);
200 48         546 my $self = bless {
201             global => \%global,
202             addr => undef,
203             session_id => undef,
204             session_version => undef,
205             media => \@media
206             }, $class;
207 48         280 lock_keys(%$self);
208 48         626 my $gl = $global{lines} = [];
209              
210             # first line must be version
211 48         141 my $line = shift(@lines);
212 48 50       540 $line->[0] eq 'v' || die "missing version";
213 48 50       204 $line->[1] eq '0' || die "bad SDP version $line->[1]";
214 48         122 push @$gl,$line;
215              
216             # second line must be origin
217             # "o=" username sess-id sess-version nettype addrtype addr
218 48         94 $line = shift(@lines);
219 48 50       170 $line->[0] eq 'o' || die "missing origin";
220             (undef,$self->{session_id},$self->{session_version})
221 48         263 = split( ' ',$line->[1] );
222 48         128 push @$gl,$line;
223              
224             # skip until c or m line
225 48         103 my $have_c =0;
226 48         170 while ( $line = shift(@lines) ) {
227              
228             # end of global section, beginning of media section
229 192 100       444 last if $line->[0] eq 'm';
230              
231 144         250 push @$gl,$line;
232 144 100       391 if ( $line->[0] eq 'c' ) {
233             # "c=" nettype addrtype connection-address
234 48 50       141 $have_c++ && die "multiple global [c]onnection fields";
235 48         784 $global{addr} = _split_c( $line->[1] );
236             }
237             }
238              
239             # parse media section(s)
240             # $line has already first m-Element in it
241              
242 48         139 while ($line) {
243              
244 48 50       164 $line->[0] eq 'm' || die "expected [m]edia line";
245             # "m=" media port ["/" integer] proto 1*fmt
246 48         456 my ($media,$port,$range,$proto,$fmt) = _split_m( $line->[1] );
247              
248 48         130 my $ml = [ $line ];
249             my %m = (
250             lines => $ml,
251             addr => $global{addr},
252 48   50     482 port => $port,
253             range => $range || 1,
254             media => $media,
255             proto => $proto,
256             fmt => $fmt,
257             );
258 48         198 lock_keys(%m);
259 48         594 push @media,\%m;
260              
261             # find out connection
262 48         98 my $have_c = 0;
263 48         197 while ( $line = shift(@lines) ) {
264              
265             # next media section
266 96 50       231 last if $line->[0] eq 'm';
267              
268 96         174 push @$ml,$line;
269 96 50       329 if ( $line->[0] eq 'c' ) {
270             # connection-field
271 0 0       0 $have_c++ && die "multiple [c]onnection fields in media section $#media";
272 0         0 $m{addr} = _split_c( $line->[1] );
273             }
274             }
275             }
276              
277 48         327 return $self;
278             }
279              
280              
281             ###########################################################################
282             # get SDP data as string
283             # Args: $self
284             # Returns: $string
285             ###########################################################################
286             sub as_string {
287 74     74 1 154 my $self = shift;
288 74         350 my $data = '';
289 74         159 foreach (@{ $self->{global}{lines}} ) {
  74         258  
290 370         985 $data .= $_->[0].'='.$_->[1]."\r\n";
291             }
292 74 50       260 if ( my $media = $self->{media} ) {
293 74         477 foreach my $m (@$media) {
294 74         153 foreach (@{ $m->{lines} }) {
  74         189  
295 222         568 $data .= $_->[0].'='.$_->[1]."\r\n";
296             }
297             }
298             }
299 74         313 return $data;
300             }
301              
302 56     56 1 859 sub content_type { return 'application/sdp' };
303              
304             ###########################################################################
305             # extracts media infos
306             # Args: $self
307             # Returns: @media|$media
308             # @media: list of hashes with the following keys:
309             # addr: IP4/IP6 addr
310             # port: the starting port number
311             # range: number, how many ports starting with port should be allocated
312             # proto: media proto, e.g. udp or RTP/AVP
313             # media: audio|video|data|... from the media description
314             # fmt: format(s) from media line
315             # lines: \@list with all lines from media description as [ key,value ]
316             # useful to access [a]ttributes or encryption [k]eys
317             # $media: \@media if in scalar context
318             # Comment: do not manipulate the result!!!
319             ###########################################################################
320             sub get_media {
321 64     64 1 125 my $self = shift;
322 64   50     269 my $m = $self->{media} || [];
323 64 50       610 return wantarray ? @$m : $m;
324             }
325              
326             ###########################################################################
327             # returns type number to RTP codec name, e.g. 'telephone-event/8000' -> 101
328             # Args: ($self,$name,[$index])
329             # $name: name of codec
330             # $index: index or type of media description, default 0, e.g. the first
331             # channel. 'audio' would specify the first audio channel
332             # Returns: type number|undef
333             ###########################################################################
334             sub name2int {
335 12     12 1 193 my ($self,$name,$index) = @_;
336 12 50       56 $index = 0 if ! defined $index;
337 12         36 my $m = $self->{media};
338 12 50       81 if ( ! looks_like_number($index)) {
339             # look for media type
340 12 50       49 my @i = grep { $m->[$_]{media} eq $index } (0..$#$m) or return;
  12         88  
341 12         32 $index = $i[0];
342             }
343 12 50       44 $m = $m->[$index] or return;
344 12         23 for my $l (@{$m->{lines}}) {
  12         84  
345 30 100       89 $l->[0] eq 'a' or next;
346 18 100       138 $l->[1] =~m{^rtpmap:(\d+)\s+(\S+)} or next;
347 12 100       96 return $1 if $2 eq $name;
348             }
349 6         58 return;
350             }
351              
352             ###########################################################################
353             # replace the addr and port (eg where it will listen) from the media in
354             # the SDP packet
355             # used for remapping by a proxy for NAT or inspection etc.
356             # Args: ($self,@replace)
357             # @replace: @list of [ addr,port ] or list with single array-ref to such list
358             # size of list must be the same like one gets from get_media, e.g.
359             # there must be a mapping for each media
360             # Comment: die() on error
361             ###########################################################################
362             sub replace_media_listen {
363 1     1 1 6 my ($self,@replace) = @_;
364              
365 1 50       5 if (@replace == 1) {
366             # check if [ $pair1,$pair2,.. ] instead of ( $pair1,.. )
367 1 50       4 @replace = @{$replace[0]} if ref($replace[0][0]);
  0         0  
368             }
369              
370 1   50     6 my $media = $self->{media} || [];
371 1 50       5 die "media count mismatch in replace_media_listen" if @replace != @$media;
372              
373 1         2 my $global = $self->{global};
374 1         3 my $g_addr = $global->{addr};
375              
376             # try to remap global connection-field
377 1 50       5 if ( $g_addr ) {
378              
379             # find mappings old -> new
380 1         2 my %addr_old2new;
381 1         4 for( my $i=0;$i<@$media;$i++ ) {
382 1         8 $addr_old2new{ $media->[$i]{addr} }{ $replace[$i][0] }++
383             }
384 1         2 my $h = $addr_old2new{ $g_addr };
385              
386 1 50 33     18 if ( $h && keys(%$h) == 1 ) {
387             # there is a uniq mapping from old to new address
388 1         5 my $new_addr = (keys(%$h))[0];
389 1 50       6 if ( $g_addr ne $new_addr ) {
390 1         4 $g_addr = $global->{addr} = $new_addr;
391              
392             # find connection-field and replace address
393 1         2 foreach my $line (@{ $global->{lines} }) {
  1         10  
394 4 100       12 if ( $line->[0] eq 'c' ) {
395 1         4 $line->[1] = _join_c( $new_addr );
396 1         5 last; # there is only one connection-field
397             }
398             }
399             }
400              
401             } else {
402             # the is no uniq mapping from old to new
403             # this can be because old connection-field was never used
404             # (because each media section had it's own) or that
405             # different new addr gets used for the same old addr
406             # -> remove global connection line
407              
408 0         0 $g_addr = $global->{addr} = undef;
409 0         0 my $l = $global->{lines};
410 0         0 @$l = grep { $_->[0] ne 'c' } @$l;
  0         0  
411             }
412             }
413              
414             # remap addr,port in each media section
415             # if new addr is != $g_addr and I had no connection-field
416             # before I need to add one
417 1         5 for( my $i=0;$i<@$media;$i++ ) {
418              
419 1         2 my $m = $media->[$i];
420 1         3 my $r = $replace[$i];
421              
422             # replace port in media line
423 1 50       5 if ( $r->[1] != $m->{port} ) {
424 0         0 $m->{port} = $r->[1];
425              
426             # [m]edia line should be the first
427 0         0 my $line = $m->{lines}[0];
428 0 0       0 $line->[0] eq 'm' || die "[m]edia line is not first";
429              
430             # media port(/range)...
431 0 0       0 if ( $r->[1] ) {
432             # port!=0: replace port only
433 0         0 $line->[1] =~s{^(\S+\s+)\d+}{$1$r->[1]};
434             } else {
435             # port == 0: replace port and range with '0'
436 0         0 $line->[1] =~s{^(\S+\s+)\S+}{${1}0};
437             }
438             }
439              
440             # replace addr in connection line
441 1 50       4 if ( $r->[0] ne $m->{addr} ) {
442 1         2 $m->{addr} = $r->[0];
443 1         2 my $have_c = 0;
444 1         3 foreach my $line (@{ $m->{lines} }) {
  1         4  
445 3 50       7 if ( $line->[0] eq 'c' ) {
446 0         0 $have_c++;
447 0         0 $line->[1] = _join_c($r->[0]);
448 0         0 last; # there is only one connection-field
449             }
450             }
451 1 50 33     109 if ( !$have_c && ( ! $g_addr || $r->[0] ne $g_addr )) {
      33        
452             # there was no connection-field before
453             # and the media addr is different from the global
454 0         0 push @{ $m->{lines} },[ 'c', _join_c( $r->[0] ) ];
  0         0  
455             }
456             }
457             }
458             }
459              
460              
461             ###########################################################################
462             # extract addr from [c]connection field and back
463             ###########################################################################
464              
465             sub _split_c {
466 48     48   411 my ($ntyp,$atyp,$addr) = split( ' ',shift,3 );
467 48 50       231 $ntyp eq 'IN' or die "nettype $ntyp not supported";
468 48 50       180 if ( $atyp eq 'IP4' ) {
    0          
469 48 50       398 die "bad IP4 address: '$addr'" if ! ip_is_v4($addr);
470             } elsif ( $atyp eq 'IP6' ) {
471 0 0       0 die "bad IP6 address: '$addr'" if ! ip_is_v6($addr);
472             } else {
473 0         0 die "addrtype $atyp not supported"
474             }
475 48         205 return $addr;
476             }
477             sub _join_c {
478 1     1   2 my $addr = shift;
479 1 50       12 my $atyp = $addr =~m{:} ? 'IP6':'IP4';
480 1         7 return "IN $atyp $addr";
481             }
482              
483              
484             ###########################################################################
485             # extract data from [m]edia field and back
486             ###########################################################################
487             sub _split_m {
488 48     48   133 my $mline = shift;
489 48 50       844 my ($media,$port,$range,$proto,$fmt) =
490             $mline =~m{^(\w+)\s+(\d+)(?:/(\d+))?\s+(\S+)((?:\s+\S+)+)}
491             or die "bad [m]edia: '$mline'";
492 48   50     360 $range ||= 1;
493 48 50       267 $range *=2 if $proto =~m{^RTP/}; # RTP+RTCP
494 48         325 return ($media,$port,$range,$proto, [ split( ' ',$fmt) ]);
495             }
496              
497             sub _join_m {
498 52     52   349 my ($media,$port,$range,$proto,@fmt) = @_;
499 52 50 33     624 @fmt = @{$fmt[0]} if @fmt == 1 && ref($fmt[0]);
  52         212  
500 52 50       706 $range /= 2 if $proto =~m{^RTP/};
501 52 50       271 $port .= "/$range" if $range>1;
502 52         349 return join( ' ',$media,$port,$proto,@fmt );
503             }
504              
505             1;