The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/bin/perl

use strict;
use warnings;
use Test::More tests => 12;
do './testlib.pl' || do './t/testlib.pl' || die "no testlib";

use Net::SIP ':all';
use Net::SIP::SDP;
use Data::Dumper;

my $HOST = '127.0.0.1';

my ($luac,$luas,$lproxy);
for ( $luac,$luas,$lproxy) {
	my ($sock,$addr) = create_socket_to( $HOST );
	$_ = { sock => $sock, addr => $addr };
}

diag( "UAS   on $luas->{addr} " );
diag( "UAC   on $luac->{addr} " );
diag( "PROXY on $lproxy->{addr} " );

# start Proxy
my $proxy = fork_sub( 'proxy', $lproxy );
fd_grep_ok( 'Listening',$proxy );

# start UAS
my $uas = fork_sub( 'uas', $luas, $lproxy->{addr} );
fd_grep_ok( 'Listening',$uas );

# start UAC once UAS is ready
my $uac = fork_sub( 'uac', $luac, $lproxy->{addr} );
fd_grep_ok( 'Started',$uac );
fd_grep_ok( 'Call accepted',$uas );

# then re-invite
fd_grep_ok( 'Starting ReInvite', $uas );
fd_grep_ok( 'Got ReInvite', $uac );

# BYE from UAS
fd_grep_ok( 'Send BYE',$uas );
fd_grep_ok( 'Received BYE',$uac );
fd_grep_ok( 'BYE done',$uas );

killall();

# --------------------------------------------------------------
#            PROXY
# --------------------------------------------------------------
sub proxy {
	my $lsock = shift;
	my $proxy = Net::SIP::Simple->new( leg => $lsock );
	$proxy->create_chain([
		$proxy->create_registrar,
		$proxy->create_stateless_proxy,
	]);
	print "Listening\n";
	$proxy->loop;
}

# --------------------------------------------------------------
#            UAC
# --------------------------------------------------------------

sub uac {
	my ($lsock,$paddr) = @_;

	my $ua = Simple->new(
		leg => $lsock->{leg},
		outgoing_proxy => $paddr,
		from => "sip:uac\@$paddr",
	);
	print "Started\n";

	my ($call,$reinvite);
	$ua->invite( "sip:uas\@$paddr", cb_established => sub { 
		(undef,$call) = @_;
		$reinvite = 1;
	}) || die;

	# wait for reinvite done
	$reinvite = 0;
	$ua->loop( 10,\$reinvite );
	$reinvite || die;
	print "Got ReInvite\n";

	# wait for BYE
	$call->set_param( recv_bye => \( my $recv_bye ));
	$ua->loop( 5,\$recv_bye );
	print "Received BYE\n" if $recv_bye;
}

# --------------------------------------------------------------
#            UAS
# --------------------------------------------------------------

sub uas {
	my ($lsock,$paddr) = @_;
	my $ua = Simple->new(
		domain => $paddr,
		registrar => $paddr,
		outgoing_proxy => $paddr,
		leg => $lsock->{leg},
		from => "sip:uas\@$paddr",
	);

	# registration
	$ua->register;
	die "registration failed: ".$ua->error if $ua->error;

	# accept call and send some data, set $stop once
	# the call was established
	my $stop = 0;
	my $call;
	$ua->listen( cb_established => sub {
		(undef,$call) = @_;
		$stop = 1
	});
	print "Listening\n";
	$ua->loop( \$stop );
	print "Call accepted\n";

	# Reinvite 
	print "Starting ReInvite\n";
	$stop = 0;
	$call->reinvite( cb_final => \$stop );
	$ua->loop( 10,\$stop );

	# Bug fixed in 0.51:
	# to of context should be uas, from should be uac, context should be incoming
	die "from is $call->{ctx}{from}" if $call->{ctx}{from} !~m{uac\@};
	die "from is $call->{ctx}{to}" if $call->{ctx}{to} !~m{uas\@};
	die "ctx is not incoming" if ! $call->{ctx}{incoming};

	# and bye
	print "Send BYE\n";
	$call->bye( cb_final => \( my $bye_ok ));
	$ua->loop( 10,\$bye_ok );
	print "BYE done\n" if $bye_ok;
}