view release on metacpan or  search on metacpan

t/testlib.pl  view on Meta::CPAN

############################################################################
# dump media information on SIP packet to STDOUT
# Args: (@prefix,$packet,$from)
# Returns: NONE
############################################################################
sub sip_dump_media {
	my $from = pop;
	my $packet = pop;
	my $dump = @_ ? "@_ ":'';
	$dump .= "$from ";
	if ( $packet->is_request ) {
		$dump .= sprintf "REQ(%s) ",$packet->method;
	} else {
		$dump .= sprintf "RSP(%s,%s) ",$packet->method,$packet->code;
	}
	if ( my $sdp = $packet->sdp_body ) {
		$dump .= "SDP:";
		foreach my $m ( $sdp->get_media ) {
			$dump .= sprintf " %s=%s:%d/%d", @{$m}{qw( media addr port range )};
		}
	} else {
		$dump .= "NO SDP";
	}
	print $dump."\n";
}

############################################################################
# create isocket on IP
# return socket and ip:port
############################################################################
sub create_socket {
	my ($addr,$port,$proto) = @_;
	$addr ||= '127.0.0.1';
	$proto ||= 'udp';
	$port ||= 0;
	my $sock = IO::Socket::INET->new(
		Proto => $proto,
		$proto eq 'tcp' ? ( Listen => 10 ):(),
		LocalAddr => $addr,
		LocalPort => $port,
	) || die $!;
	($port,$addr) = unpack_sockaddr_in( getsockname($sock) );
	return wantarray ? ( $sock, inet_ntoa($addr).':'.$port ) : $sock;
}

############################################################################
# redefined Leg for Tests:
# - can have explicit destination
# - can intercept receive and deliver for printing out packets
############################################################################
package TestLeg;
use base 'Net::SIP::Leg';
use fields qw( can_deliver_to dump_incoming dump_outgoing );
use Net::SIP 'invoke_callback';

sub new {
	my ($class,%args) = @_;
	my @lfields = qw( can_deliver_to dump_incoming dump_outgoing );
	my %largs = map { $_ => delete $args{$_} } @lfields;
	my $self = $class->SUPER::new( %args );
	if ( my $ct = delete $largs{can_deliver_to} ) {
		$self->{can_deliver_to} = _parse_addr($ct);
	}
	%$self = ( %$self, %largs );
	return $self;
}
sub can_deliver_to {
	my $self = shift;
	my $spec = @_ == 1 ? _parse_addr( $_[0] ) : { @_ };
	my $ct = $self->{can_deliver_to};
	if ( $ct ) {
		foreach (qw( addr proto port )) {
			next if ! $spec->{$_} || ! $ct->{$_};
			return if $spec->{$_} ne $ct->{$_};
		}
	}
	return $self->SUPER::can_deliver_to( @_ );
}

sub _parse_addr {
	my $addr = shift;
	$addr =~m{^(?:(udp|tcp):)?([\w\.-]+)(?::(\d+))?$} || die $addr;
	return { proto => $1, addr => $2, port => $3 }
}

sub receive {
	my $self = shift;
	my @rv = $self->SUPER::receive(@_) or return;
	invoke_callback( $self->{dump_incoming},@rv );
	return @rv;
}

sub deliver {
	my ($self,$packet,$to,$callback) = @_;
	invoke_callback( $self->{dump_outgoing},$packet,$to );
	return $self->SUPER::deliver( $packet,$to,$callback );
}



1;