File Coverage

blib/lib/Net/SIP/SDP.pm

Criterion	Covered	Total	%
statement	162	223	72.6
branch	56	132	42.4
condition	13	45	28.8
subroutine	17	19	89.4
pod	8	8	100.0
total	256	427	59.9

###########################################################################
# Net::SIP::SDP
# parse and manipulation of SDP packets in the context relevant for SIP
# Spec:
# RFC2327 - base RFC for SDP
# RFC3264 - offer/answer model with SDP (used in SIP RFC3261)
# RFC3266 - IP6 in SDP
# RFC3605 - "a=rtcp:port" attribute UNSUPPORTED!!!!
###########################################################################

use strict;
use warnings;
package Net::SIP::SDP;
use Hash::Util qw(lock_keys);
use Net::SIP::Debug;
use Net::SIP::Util qw(ip_is_v4 ip_is_v6);
use Socket;
use Scalar::Util 'looks_like_number';


###########################################################################
# create new Net::SIP::SDP packet from string or parts
# Args: see new_from_parts|new_from_string
# Returns: $self
###########################################################################
sub new {
    my $class = shift;
    return $class->new_from_parts(@_) if @_>1;
    my $data = shift;
    return ( !ref($data) || UNIVERSAL::isa( $data,'ARRAY' ))
	?  $class->new_from_string( $data )
	: $class->new_from_parts( $data );
}

###########################################################################
# create new Net::SIP::SDP packet from parts
# Args: ($class,$global,@media)
#   $global: \%hash of (key,val) for global section, val can be
#       scalar or array-ref (for multiple val). keys can be the
#       on-letter SDP keys and the special key 'addr' for constructing
#       a connection-field
#   @media: list of \%hashes. val in hash can be scalar or array-ref
#       (for multiple val), keys can be on-letter SDP keys or the special
#       keys addr (for connection-field), port,range,proto,media,fmt (for
#       media description)
# Returns: $self
###########################################################################
sub new_from_parts {
    my ($class,$global,@media) = @_;

    my %g = %$global;
    my $g_addr = delete $g{addr};
    die "no support for time rates" if $g{r};

    my $atyp;
    if ($g_addr && !$g{c}) {
	$atyp = ip_is_v4($g_addr) ? 'IP4':'IP6';
	$g{c} = "IN $atyp $g_addr";
    }
    $g{t} = "0 0" if !$g{t};

    my @gl;
    my %global_self = ( lines => \@gl, addr => $g_addr );
    lock_keys(%global_self);

    my @media_self;
    my $self = bless {
	global => \%global_self,
	addr => $g_addr,
	media => \@media_self
    },$class;
    lock_keys(%$self);

    # first comes the version
    push @gl,[ 'v',delete($g{v}) || 0 ];

    # then the origin
    my $o = delete($g{o});
    if ( !$o ) {
	my $t = time();
	$atyp ||= $g{c} =~m{^IN (IP4|IP6) } && $1;
	$o = "anonymous $t $t IN $atyp ".( $g_addr
	    || ($atyp eq 'IP4' ? '127.0.0.1' : '::1') );
    }
    push @gl,[ 'o',$o ];

    # session name
    push @gl,[ 's', delete($g{s}) || 'session' ];

    # various headers in the right order
    foreach my $key (qw( i u e p c b t z k a )) {
	my $v = delete $g{$key};
	defined($v) || next;
	foreach ( ref($v) ? @$v:($v) ) {
	    push @gl, [ $key,$_ ];
	}
    }

    # die on unknown keys
    die "bad keys in global: ".join( ' ',keys(%g)) if %g;

    # media descriptions
    foreach my $m (@media) {
	DEBUG_DUMP( 100,$m );
	my %m = %$m;
	delete $m{lines};
	my @lines;
	my %m_self = ( lines => \@lines );

	# extract from 'm' line or from other args
	if ( my $mline = delete $m{m} ) {
	    push @lines,[ 'm',$mline ];
	    @m_self{qw(media port range proto fmt)} = _split_m( $mline );
	} else {
	    foreach (qw( port media proto )) {
		defined( $m_self{$_} = delete $m{$_} )
		    || die "no $_ in media description";
	    }
	    $m_self{range} = delete($m{range})
		|| ( $m_self{proto} =~m{^RTP/} ? 2:1 );
	    defined( my $fmt = $m_self{fmt} = delete $m{fmt} )
		|| die "no fmt in media description";
	    my $mline = _join_m( @m_self{qw(media port range proto)},$fmt );
	    push @lines, [ 'm',$mline ];
	}

	# if no connection line given construct one, if addr ne g_addr
	if ( !$m{c} ) {
	    if ( my $addr = delete $m{addr} ) {
		$m_self{addr} = $addr;
		$m{c} = _join_c($addr) if $addr ne $g_addr;
	    } elsif ( $g_addr ) {
		$m_self{addr} = $g_addr;
	    } else {
		die "neither local nor global address for media";
	    }
	} else {
	    $m_self{addr} = _split_c($m{c});
	}

	# various headers in the right order
	foreach my $key (qw( i c b k a )) {
	    my $v = delete $m{$key};
	    defined($v) || next;
	    foreach ( ref($v) ? @$v:($v) ) {
		push @lines, [ $key,$_ ];
	    }
	}
	# die on unknown keys
	die "bad keys in media: ".join( ' ',keys(%m)) if %m;

	lock_keys(%m_self);
	push @media_self,\%m_self;
    }

    return $self;
}


###########################################################################
# create new Net::SIP::SDP packet from string or lines
# Args: ($class,$string)
#    $string: either scalar or \@list_of_lines_in_string
# Returns: $self
###########################################################################
sub new_from_string {
    my ($class,$string) = @_;

    # split into lines
    Carp::confess('expected string or ARRAY ref' )
	if ref($string) && ref( $string ) ne 'ARRAY';
    my @lines = ref($string)
	? @$string
	: split( m{\r?\n}, $string );

    # split lines into key,val
    foreach my $l (@lines) {
	my ($key,$val) = $l=~m{^([a-z])=(.*)}
	    or die "bad SDP line '$l'";
	$l = [ $key,$val ];
    }

    # SELF:
    # global {
    #   lines => [],
    #   addr     # globally defined addr (if any)
    # }
    # media [
    #   {
    #     lines => [],
    #     addr   # addr for ports
    #     port   # starting port
    #     range  # range of ports (1..)
    #     proto  # udp, RTP/AVP,..
    #     media  # audio|video|data...
    #   }
    # ]

    my (%global,@media);
    my $self = bless {
	global => \%global,
	addr => undef,
	session_id => undef,
	session_version => undef,
	media => \@media
    }, $class;
    lock_keys(%$self);
    my $gl = $global{lines} = [];

    # first line must be version
    my $line = shift(@lines);
    $line->[0] eq 'v' || die "missing version";
    $line->[1] eq '0' || die "bad SDP version $line->[1]";
    push @$gl,$line;

    # second line must be origin
    # "o=" username sess-id sess-version nettype addrtype addr
    $line = shift(@lines);
    $line->[0] eq 'o' || die "missing origin";
    (undef,$self->{session_id},$self->{session_version})
	= split( ' ',$line->[1] );
    push @$gl,$line;

    # skip until c or m line
    my $have_c =0;
    while ( $line = shift(@lines) ) {

	# end of global section, beginning of media section
	last if $line->[0] eq 'm';

	push @$gl,$line;
	if ( $line->[0] eq 'c' ) {
	    # "c=" nettype addrtype connection-address
	    $have_c++ && die "multiple global [c]onnection fields";
	    $global{addr} = _split_c( $line->[1] );
	}
    }

    # parse media section(s)
    # $line has already first m-Element in it

    while ($line) {

	$line->[0] eq 'm' || die "expected [m]edia line";
	# "m=" media port ["/" integer] proto 1*fmt
	my ($media,$port,$range,$proto,$fmt) = _split_m( $line->[1] );

	my $ml = [ $line ];
	my %m = (
	    lines => $ml,
	    addr  => $global{addr},
	    port  => $port,
	    range => $range || 1,
	    media => $media,
	    proto => $proto,
	    fmt   => $fmt,
	);
	lock_keys(%m);
	push @media,\%m;

	# find out connection
	my $have_c = 0;
	while ( $line = shift(@lines) ) {

	    # next media section
	    last if $line->[0] eq 'm';

	    push @$ml,$line;
	    if ( $line->[0] eq 'c' ) {
		# connection-field
		$have_c++ && die "multiple [c]onnection fields in media section $#media";
		$m{addr} = _split_c( $line->[1] );
	    }
	}
    }

    return $self;
}


###########################################################################
# get SDP data as string
# Args: $self
# Returns: $string
###########################################################################
sub as_string {
    my $self = shift;
    my $data = '';
    foreach (@{ $self->{global}{lines}} ) {
	$data .= $_->[0].'='.$_->[1]."\r\n";
    }
    if ( my $media = $self->{media} ) {
	foreach my $m (@$media) {
	    foreach (@{ $m->{lines} }) {
		$data .= $_->[0].'='.$_->[1]."\r\n";
	    }
	}
    }
    return $data;
}

sub content_type { return 'application/sdp' };

###########################################################################
# extracts media infos
# Args: $self
# Returns: @media|$media
#  @media: list of hashes with the following keys:
#     addr:  IP4/IP6 addr
#     port:  the starting port number
#     range: number, how many ports starting with port should be allocated
#     proto: media proto, e.g. udp or RTP/AVP
#     media: audio|video|data|... from the media description
#     fmt:   format(s) from media line
#     lines: \@list with all lines from media description as [ key,value ]
#            useful to access [a]ttributes or encryption [k]eys
#  $media: \@media if in scalar context
# Comment: do not manipulate the result!!!
###########################################################################
sub get_media {
    my $self = shift;
    my $m = $self->{media} || [];
    return wantarray ? @$m : $m;
}

###########################################################################
# returns type number to RTP codec name, e.g. 'telephone-event/8000' -> 101
# Args: ($self,$name,[$index])
#  $name: name of codec
#  $index: index or type of media description, default 0, e.g. the first
#   channel. 'audio' would specify the first audio channel
# Returns: type number|undef
###########################################################################
sub name2int {
    my ($self,$name,$index) = @_;
    $index = 0 if ! defined $index;
    my $m = $self->{media};
    if ( ! looks_like_number($index)) {
	# look for media type
	my @i = grep { $m->[$_]{media} eq $index } (0..$#$m) or return;
	$index = $i[0];
    }
    $m = $m->[$index] or return;
    for my $l (@{$m->{lines}}) {
	$l->[0] eq 'a' or next;
	$l->[1] =~m{^rtpmap:(\d+)\s+(\S+)} or next;
	return $1 if $2 eq $name;
    }
    return;
}

###########################################################################
# replace the addr and port (eg where it will listen) from the media in
# the SDP packet
# used for remapping by a proxy for NAT or inspection etc.
# Args: ($self,@replace)
#   @replace: @list of [ addr,port ] or list with single array-ref to such list
#      size of list must be the same like one gets from get_media, e.g.
#      there must be a mapping for each media
# Comment: die() on error
###########################################################################
sub replace_media_listen {
    my ($self,@replace) = @_;

    if (@replace == 1) {
	# check if [ $pair1,$pair2,.. ] instead of ( $pair1,.. )
	@replace = @{$replace[0]} if ref($replace[0][0]);
    }

    my $media = $self->{media} || [];
    die "media count mismatch in replace_media_listen" if @replace != @$media;

    my $global = $self->{global};
    my $g_addr = $global->{addr};

    # try to remap global connection-field
    if ( $g_addr ) {

	# find mappings old -> new
	my %addr_old2new;
	for( my $i=0;$i<@$media;$i++ ) {
	    $addr_old2new{ $media->[$i]{addr} }{ $replace[$i][0] }++
	}
	my $h = $addr_old2new{ $g_addr };

	if ( $h && keys(%$h) == 1 ) {
	    # there is a uniq mapping from old to new address
	    my $new_addr = (keys(%$h))[0];
	    if ( $g_addr ne $new_addr ) {
		$g_addr = $global->{addr} = $new_addr;

		# find connection-field and replace address
		foreach my $line (@{ $global->{lines} }) {
		    if ( $line->[0] eq 'c' ) {
			$line->[1] = _join_c( $new_addr );
			last; # there is only one connection-field
		    }
		}
	    }

	} else {
	    # the is no uniq mapping from old to new
	    # this can be because old connection-field was never used
	    # (because each media section had it's own) or that
	    # different new addr gets used for the same old addr
	    # -> remove global connection line

	    $g_addr = $global->{addr} = undef;
	    my $l = $global->{lines};
	    @$l = grep { $_->[0] ne 'c' } @$l;
	}
    }

    # remap addr,port in each media section
    # if new addr is != $g_addr and I had no connection-field
    # before I need to add one
    for( my $i=0;$i<@$media;$i++ ) {

	my $m = $media->[$i];
	my $r = $replace[$i];

	# replace port in media line
	if ( $r->[1] != $m->{port} ) {
	    $m->{port} = $r->[1];

	    # [m]edia line should be the first
	    my $line = $m->{lines}[0];
	    $line->[0] eq 'm' || die "[m]edia line is not first";

	    # media port(/range)...
	    if ( $r->[1] ) {
		# port!=0: replace port only
		$line->[1] =~s{^(\S+\s+)\d+}{$1$r->[1]};
	    } else {
		# port == 0: replace port and range with '0'
		$line->[1] =~s{^(\S+\s+)\S+}{${1}0};
	    }
	}

	# replace addr in connection line
	if ( $r->[0] ne $m->{addr} ) {
	    $m->{addr} = $r->[0];
	    my $have_c = 0;
	    foreach my $line (@{ $m->{lines} }) {
		if ( $line->[0] eq 'c' ) {
		    $have_c++;
		    $line->[1] = _join_c($r->[0]);
		    last; # there is only one connection-field
		}
	    }
	    if ( !$have_c && ( ! $g_addr || $r->[0] ne $g_addr )) {
		# there was no connection-field before
		# and the media addr is different from the global
		push @{ $m->{lines} },[ 'c', _join_c( $r->[0] ) ];
	    }
	}
    }
}


###########################################################################
# extract addr from [c]connection field and back
###########################################################################

sub _split_c {
    my ($ntyp,$atyp,$addr) = split( ' ',shift,3 );
    $ntyp eq 'IN'  or die "nettype $ntyp not supported";
    if ( $atyp eq 'IP4' ) {
	die "bad IP4 address: '$addr'" if ! ip_is_v4($addr);
    } elsif ( $atyp eq 'IP6' ) {
	die "bad IP6 address: '$addr'" if ! ip_is_v6($addr);
    } else {
	die "addrtype $atyp not supported"
    }
    return $addr;
}
sub _join_c {
    my $addr = shift;
    my $atyp = $addr =~m{:} ? 'IP6':'IP4';
    return "IN $atyp $addr";
}


###########################################################################
# extract data from [m]edia field and back
###########################################################################
sub _split_m {
    my $mline = shift;
    my ($media,$port,$range,$proto,$fmt) =
	$mline =~m{^(\w+)\s+(\d+)(?:/(\d+))?\s+(\S+)((?:\s+\S+)+)}
	or die "bad [m]edia: '$mline'";
    $range ||= 1;
    $range *=2 if $proto =~m{^RTP/}; # RTP+RTCP
    return ($media,$port,$range,$proto, [ split( ' ',$fmt) ]);
}

sub _join_m {
    my ($media,$port,$range,$proto,@fmt) = @_;
    @fmt = @{$fmt[0]} if @fmt == 1 && ref($fmt[0]);
    $range /= 2 if $proto =~m{^RTP/};
    $port .= "/$range" if $range>1;
    return join( ' ',$media,$port,$proto,@fmt );
}

1;