r22169 - in /branches/upstream/libnet-sip-perl/current: ./ lib/Net/ lib/Net/SIP/ lib/Net/SIP/Dispatcher/ lib/Net/SIP/Endpoint/ lib/Net/SIP/Simple/ samples/ t/
dmn at users.alioth.debian.org
dmn at users.alioth.debian.org
Thu Jun 26 06:35:42 UTC 2008
Author: dmn
Date: Thu Jun 26 06:35:42 2008
New Revision: 22169
URL: http://svn.debian.org/wsvn/?sc=1&rev=22169
Log:
[svn-upgrade] Integrating new upstream version, libnet-sip-perl (0.45.3)
Added:
branches/upstream/libnet-sip-perl/current/t/11_invite_timeout.t
Modified:
branches/upstream/libnet-sip-perl/current/Changes
branches/upstream/libnet-sip-perl/current/MANIFEST
branches/upstream/libnet-sip-perl/current/META.yml
branches/upstream/libnet-sip-perl/current/lib/Net/SIP.pm
branches/upstream/libnet-sip-perl/current/lib/Net/SIP/Dispatcher/Eventloop.pm
branches/upstream/libnet-sip-perl/current/lib/Net/SIP/Endpoint.pm
branches/upstream/libnet-sip-perl/current/lib/Net/SIP/Endpoint.pod
branches/upstream/libnet-sip-perl/current/lib/Net/SIP/Endpoint/Context.pm
branches/upstream/libnet-sip-perl/current/lib/Net/SIP/Endpoint/Context.pod
branches/upstream/libnet-sip-perl/current/lib/Net/SIP/Simple.pm
branches/upstream/libnet-sip-perl/current/lib/Net/SIP/Simple/Call.pm
branches/upstream/libnet-sip-perl/current/lib/Net/SIP/Simple/Call.pod
branches/upstream/libnet-sip-perl/current/samples/invite_and_send.pl
branches/upstream/libnet-sip-perl/current/t/09_fdleak.t
branches/upstream/libnet-sip-perl/current/t/10_fdleak.t
Modified: branches/upstream/libnet-sip-perl/current/Changes
URL: http://svn.debian.org/wsvn/branches/upstream/libnet-sip-perl/current/Changes?rev=22169&op=diff
==============================================================================
--- branches/upstream/libnet-sip-perl/current/Changes (original)
+++ branches/upstream/libnet-sip-perl/current/Changes Thu Jun 26 06:35:42 2008
@@ -1,4 +1,18 @@
Revision history for Net::SIP
+
+0.45_3
+ - support for canceling a call after some time of ringing based on
+ input from http://rt.cpan.org/Ticket/Display.html?id=34576
+ see Net::SIP::Simple::Call documentation for sub reinvite, parameters
+ ring_time, cb_noanswer. See also method cancel in this package
+ feature gets used in samples/invite_and_send.pl too
+ - fix for t/*_fdleak for platforms, which use 2 fd for tempfiles (see
+ http://rt.cpan.org/Ticket/Display.html?id=35485). Now it allocates a
+ new fd simply by dup()ing STDOUT
+ - fix in Net::SIP::Dispatcher::Eventloop in case the select returned
+ because of EINTR
+ - fixes in handling response in Net::SIP::Endpoint::Context for the case,
+ that multiple requests shared the same tid (e.g. INVITE,CANCEL)
0.45
- Net::SIP::Packet::sdp_body - content type is case insensitive,
Modified: branches/upstream/libnet-sip-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/branches/upstream/libnet-sip-perl/current/MANIFEST?rev=22169&op=diff
==============================================================================
--- branches/upstream/libnet-sip-perl/current/MANIFEST (original)
+++ branches/upstream/libnet-sip-perl/current/MANIFEST Thu Jun 26 06:35:42 2008
@@ -64,6 +64,7 @@
t/08_register_with_auth.t
t/09_fdleak.t
t/10_fdleak.t
+t/11_invite_timeout.t
t/testlib.pl
samples/README
samples/invite_and_recv.pl
Modified: branches/upstream/libnet-sip-perl/current/META.yml
URL: http://svn.debian.org/wsvn/branches/upstream/libnet-sip-perl/current/META.yml?rev=22169&op=diff
==============================================================================
--- branches/upstream/libnet-sip-perl/current/META.yml (original)
+++ branches/upstream/libnet-sip-perl/current/META.yml Thu Jun 26 06:35:42 2008
@@ -1,13 +1,11 @@
---- #YAML:1.0
-name: Net-SIP
-version: 0.45
-abstract: ~
-license: ~
-author: ~
-generated_by: ExtUtils::MakeMaker version 6.42
-distribution_type: module
-requires:
+# http://module-build.sourceforge.net/META-spec.html
+#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX#
+name: Net-SIP
+version: 0.45_3
+version_from: lib/Net/SIP.pm
+installdirs: site
+requires:
Net::DNS: 0.56
-meta-spec:
- url: http://module-build.sourceforge.net/META-spec-v1.3.html
- version: 1.3
+
+distribution_type: module
+generated_by: ExtUtils::MakeMaker version 6.30_01
Modified: branches/upstream/libnet-sip-perl/current/lib/Net/SIP.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libnet-sip-perl/current/lib/Net/SIP.pm?rev=22169&op=diff
==============================================================================
--- branches/upstream/libnet-sip-perl/current/lib/Net/SIP.pm (original)
+++ branches/upstream/libnet-sip-perl/current/lib/Net/SIP.pm Thu Jun 26 06:35:42 2008
@@ -4,7 +4,7 @@
require 5.008;
package Net::SIP;
-our $VERSION = '0.45';
+our $VERSION = '0.45_3';
# this includes nearly everything else
use Net::SIP::Simple ();
Modified: branches/upstream/libnet-sip-perl/current/lib/Net/SIP/Dispatcher/Eventloop.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libnet-sip-perl/current/lib/Net/SIP/Dispatcher/Eventloop.pm?rev=22169&op=diff
==============================================================================
--- branches/upstream/libnet-sip-perl/current/lib/Net/SIP/Dispatcher/Eventloop.pm (original)
+++ branches/upstream/libnet-sip-perl/current/lib/Net/SIP/Dispatcher/Eventloop.pm Thu Jun 26 06:35:42 2008
@@ -14,6 +14,7 @@
use List::Util qw(first);
use Net::SIP::Util 'invoke_callback';
use Net::SIP::Debug;
+use Errno 'EINTR';
###########################################################################
# creates new event loop
@@ -164,7 +165,10 @@
my $rin = '';
map { vec( $rin,fileno($_->[0]),1 ) = 1 } @to_read;
DEBUG( 100, "handles=".join( " ",map { fileno($_->[0]) } @to_read ));
- die $! if select( my $rout = $rin,undef,undef,$to ) < 0;
+ select( my $rout = $rin,undef,undef,$to ) < 0 and do {
+ next if $! == EINTR;
+ die $!
+ };
# returned from select
$looptime = $self->{now} = gettimeofday();
DEBUG( 100, "can_read=".join( " ",map { $_ } grep { $fds->[$_] && vec($rout,$_,1) } (0..$#$fds)));
Modified: branches/upstream/libnet-sip-perl/current/lib/Net/SIP/Endpoint.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libnet-sip-perl/current/lib/Net/SIP/Endpoint.pm?rev=22169&op=diff
==============================================================================
--- branches/upstream/libnet-sip-perl/current/lib/Net/SIP/Endpoint.pm (original)
+++ branches/upstream/libnet-sip-perl/current/lib/Net/SIP/Endpoint.pm Thu Jun 26 06:35:42 2008
@@ -174,6 +174,26 @@
}
############################################################################
+# Cancel last pending INVITE request
+# Args: ($self,$ctx,$request,$cb)
+# $ctx: context for call
+# $request: request to cancel, will only cancel it, if request is
+# outstanding in context, will cancel latest INVITE if not given
+# $cb: callback for generated CANCEL request
+# Returns: number of requests canceled (e.g 0 if no outstanding INVITE)
+############################################################################
+sub cancel_invite {
+ my Net::SIP::Endpoint $self = shift;
+ my Net::SIP::Endpoint::Context $ctx = shift;
+ my ($request,$callback) = @_;
+ my ($pkt) = $ctx->find_outstanding_requests(
+ $request ? ( request => $request ) : ( method => 'INVITE' )
+ ) or return;
+ $self->new_request( $pkt->create_cancel, $ctx, $callback );
+ return 1;
+}
+
+############################################################################
# internal callback used for delivery
# will be called from dispatcher if the request was definitly successfully
# delivered (tcp only) or an error occurred
@@ -319,7 +339,7 @@
# deliver a response packet
# Args: ($self,$ctx,$response,$leg,$addr)
# $ctx : Net::SIP::Endpoint::Context which generated response
-# $response: Net::SIP::Respone packet
+# $response: Net::SIP::Response packet
# $leg : leg to send out response, eg where the request came in
# $addr : where to send respone (ip:port), eg where the request came from
# Returns: NONE
Modified: branches/upstream/libnet-sip-perl/current/lib/Net/SIP/Endpoint.pod
URL: http://svn.debian.org/wsvn/branches/upstream/libnet-sip-perl/current/lib/Net/SIP/Endpoint.pod?rev=22169&op=diff
==============================================================================
--- branches/upstream/libnet-sip-perl/current/lib/Net/SIP/Endpoint.pod (original)
+++ branches/upstream/libnet-sip-perl/current/lib/Net/SIP/Endpoint.pod Thu Jun 26 06:35:42 2008
@@ -190,6 +190,15 @@
request which can be then used for further requests in the same
call.
+=item cancel_invite ( CTX, REQUEST, CALLBACK )
+
+Cancel the given request within the given context (e.g send CANCEL request).
+If no REQUEST is given it will cancel the most recent INVITE. Returns the
+number of requests canceled, e.g. 0 or 1.
+
+CALLBACK will be used as the callback for the CANCEL request it sends using
+B<new_request>.
+
=item close_context ( CTX )
Delete L<Net::SIP::Endpoint::Context> object CTX from the list
Modified: branches/upstream/libnet-sip-perl/current/lib/Net/SIP/Endpoint/Context.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libnet-sip-perl/current/lib/Net/SIP/Endpoint/Context.pm?rev=22169&op=diff
==============================================================================
--- branches/upstream/libnet-sip-perl/current/lib/Net/SIP/Endpoint/Context.pm (original)
+++ branches/upstream/libnet-sip-perl/current/lib/Net/SIP/Endpoint/Context.pm Thu Jun 26 06:35:42 2008
@@ -84,8 +84,12 @@
return $self
}
-sub DESTROY {
- DEBUG( 100,"DESTROY context $_[0] callid=$_[0]->{callid}" ) if $_[0];
+# destroying of fields in perl5.8 cleanup can cause strange errors, where
+# it complains, that it cannot coerce array into hash. So use this function
+# on your own risks and rename it to DETSTROY if you want to have debugging
+# info
+sub _DESTROY {
+ DEBUG( 100,"DESTROY context $_[0] callid=$_[0]->{callid}" );
}
############################################################################
@@ -109,6 +113,30 @@
my $peer = $self->{incoming} ? $self->{from} : $self->{to};
my ($data) = sip_hdrval2parts( from => $peer ); # strip parameters like tag etc
return $data;
+}
+
+############################################################################
+# return list of outstanding requests matching filter, if no filter is given
+# returns all requests
+# Args: ($self,%filter)
+# %filter
+# method => name: filter for requests with given method
+# request => packet: filter for packet, e.g. finds if packet is outstanding
+# Returns: @requests
+# returns all matching requests (Net::SIP::Request objects), newest
+# requests first
+############################################################################
+sub find_outstanding_requests {
+ my Net::SIP::Endpoint::Context $self = shift;
+ my %filter = @_;
+ my @trans = @{$self->{_transactions}} or return;
+ if ( my $pkt = $filter{request} ) {
+ @trans = grep { $pkt == $_->{request} } @trans or return;
+ }
+ if ( my $method = $filter{method} ) {
+ @trans = grep { $method eq $_->{request}->method } @trans or return;
+ }
+ return map { $_->{request} } @trans;
}
############################################################################
@@ -182,7 +210,6 @@
return $request;
}
-
############################################################################
# set callback for context
# Args: ($self,$cb)
@@ -243,10 +270,11 @@
# if response does not terminates transaction one need to add
# it again
my $tid = $response->tid;
+ my $method = $response->method;
my $trans = $self->{_transactions};
my (@ntrans,$tr);
foreach my $t (@$trans) {
- if ( $t->{tid} eq $tid ) {
+ if ( !$tr and $t->{tid} eq $tid and $method eq $t->{request}->method) {
$tr = $t;
} else {
push @ntrans,$t
@@ -268,18 +296,6 @@
DEBUG( 10,"response came in through the wrong leg" );
return;
};
-
-
- # check if it's a response to the current method in the
- # transaction (ACK,CANCEL,INVITE share the same transaction,
- # but are different methods)
-
- my $method = $tr->{request}->method;
- $response->cseq =~m{^\d+\s+(\w+)};
- if ($method ne $1 ) {
- DEBUG( 10,"got response to method $1 but current method is $method. DROP" );
- return;
- }
my $cb = $tr->{callback};
my @arg = ($endpoint,$self);
Modified: branches/upstream/libnet-sip-perl/current/lib/Net/SIP/Endpoint/Context.pod
URL: http://svn.debian.org/wsvn/branches/upstream/libnet-sip-perl/current/lib/Net/SIP/Endpoint/Context.pod?rev=22169&op=diff
==============================================================================
--- branches/upstream/libnet-sip-perl/current/lib/Net/SIP/Endpoint/Context.pod (original)
+++ branches/upstream/libnet-sip-perl/current/lib/Net/SIP/Endpoint/Context.pod Thu Jun 26 06:35:42 2008
@@ -111,6 +111,17 @@
It returns the created request object.
+=item find_outstanding_requests ( %FILTER )
+
+Returns list of outstanding requests (e.g INVITE w/o reply) for this
+context. Returns a list of outstanding request (L<Net::SIP::Request>
+objects) with the most recent requests first.
+
+FILTER might be used to restrict the search. With key B<request> a
+L<Net::SIP::Request> object is expected and it will restrict the search to
+this object (e.g. it will return the object if it is outstanding). With key
+B<method> a method can be specified and only requests with this method will
+be returned.
=item set_callback ( CALLBACK )
Modified: branches/upstream/libnet-sip-perl/current/lib/Net/SIP/Simple.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libnet-sip-perl/current/lib/Net/SIP/Simple.pm?rev=22169&op=diff
==============================================================================
--- branches/upstream/libnet-sip-perl/current/lib/Net/SIP/Simple.pm (original)
+++ branches/upstream/libnet-sip-perl/current/lib/Net/SIP/Simple.pm Thu Jun 26 06:35:42 2008
@@ -382,7 +382,9 @@
# if regex only from matching regex gets accepted
# if sub and sub returns 1 call gets accepted, if sub returns 0 it gets rejected
# cb_create: optional callback called on creation of newly created
-# Net::SIP::Simple::Call
+# Net::SIP::Simple::Call. If returns false the call will be closed.
+# If returns a callback (e.g some ref) it will be used instead of
+# Net::SIP::Simple::Call to handle the data
# cb_established: callback called after receiving ACK
# cb_cleanup: called on destroy of call object
# for all other args see Net::SIP::Simple::Call....
@@ -422,10 +424,13 @@
# notify caller about new call
if ( my $cbc = $args->{cb_create} ) {
- if ( ! invoke_callback( $cbc, $call, $request,$leg,$from ) ) {
+ my $cbx =invoke_callback( $cbc, $call, $request,$leg,$from );
+ if ( ! $cbx ) {
DEBUG( 1, "call from '$ctx->{from}' rejected in cb_create" );
$self->{endpoint}->close_context( $ctx );
return;
+ } elsif ( ref($cbx) ) {
+ $cb = $cbx
}
}
if ( my $ccb = $args->{cb_cleanup} ) {
Modified: branches/upstream/libnet-sip-perl/current/lib/Net/SIP/Simple/Call.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libnet-sip-perl/current/lib/Net/SIP/Simple/Call.pm?rev=22169&op=diff
==============================================================================
--- branches/upstream/libnet-sip-perl/current/lib/Net/SIP/Simple/Call.pm (original)
+++ branches/upstream/libnet-sip-perl/current/lib/Net/SIP/Simple/Call.pm Thu Jun 26 06:35:42 2008
@@ -224,6 +224,7 @@
invoke_callback( $param->{init_media},$self,$param );
};
+
my $stopvar = 0;
$param->{cb_final} ||= \$stopvar;
$cb = [ $cb,$self ];
@@ -232,14 +233,87 @@
$ctx, $cb, $sdp,
$param->{sip_header} ? %{ $param->{sip_header} } : ()
);
+
if ( $param->{cb_final} == \$stopvar ) {
- # wait until final response
- $self->loop( \$stopvar );
+
+ # This callback will be called on timeout or response to cancel which
+ # got send after ring_time was over
+ my $noanswercb;
+ if ( $param->{ring_time} ) {
+ $noanswercb = sub {
+ my Net::SIP::Simple::Call $self = shift || return;
+ my ($endpoint,$ctx,$errno,$code,$packet,$leg,$from,$ack) = @_;
+
+ $stopvar = 'NOANSWER' ;
+ my $param = $self->{param};
+ invoke_callback( $param->{cb_noanswer}, 'NOANSWER',$self,
+ errno => $errno,code => $code,packet => $packet );
+
+ if ( $code =~ m{^2\d\d} ) {
+ DEBUG(10,"got response of %s|%s to CANCEL",$code,$packet->msg );
+ invoke_callback( $param->{cb_final},'NOANSWER',$self,code => $code );
+ }
+ };
+ $noanswercb = [ $noanswercb,$self ];
+ weaken( $noanswercb->[1] );
+
+ # wait until final response
+ $self->loop( $param->{ring_time}, \$stopvar );
+
+ unless ($stopvar) { # timed out
+ $self->{endpoint}->cancel_invite( $self->{ctx},undef, $noanswercb );
+ $self->loop( \$stopvar );
+ }
+ } else {
+ # wait until final response
+ $self->loop( \$stopvar );
+ }
+
$param->{cb_final} = undef;
}
return $self->{ctx};
}
+
+###########################################################################
+# cancel call
+# Args: ($self,%args)
+# %args:
+# cb_final: callback when CANCEL was delivered. If not given send_cancel
+# callback on Call object will be used
+# Returns: true if call could be canceled
+# Comment: cb_final gets triggered if the reply for the CANCEL is received
+# or waiting for the reply timed out
+###########################################################################
+sub cancel {
+ my Net::SIP::Simple::Call $self = shift;
+ my %args = @_;
+
+ my $cb = delete $args{cb_final};
+ %args = ( %{ $self->{param} }, %args );
+ $cb ||= $args{send_cancel};
+
+ my $cancel_cb = [
+ sub {
+ my Net::SIP::Simple::Call $self = shift || return;
+ my ($cb,$args,$endpoint,$ctx,$error,$code) = @_;
+ # we don't care about the cause of this callback
+ # it might be a successful or failed reply packet or no reply
+ # packet at all (timeout) - the call is considered closed
+ # in any case except for 1xx responses
+ if ( $code && $code =~m{^1\d\d} ) {
+ DEBUG( 10,"got prelimary response for CANCEL" );
+ return;
+ }
+ invoke_callback( $cb,$args );
+ $self->cleanup;
+ },
+ $self,$cb,\%args
+ ];
+ weaken( $cancel_cb->[1] );
+
+ return $self->{endpoint}->cancel_invite( $self->{ctx}, undef, $cancel_cb );
+}
###########################################################################
# end call
Modified: branches/upstream/libnet-sip-perl/current/lib/Net/SIP/Simple/Call.pod
URL: http://svn.debian.org/wsvn/branches/upstream/libnet-sip-perl/current/lib/Net/SIP/Simple/Call.pod?rev=22169&op=diff
==============================================================================
--- branches/upstream/libnet-sip-perl/current/lib/Net/SIP/Simple/Call.pod (original)
+++ branches/upstream/libnet-sip-perl/current/lib/Net/SIP/Simple/Call.pod Thu Jun 26 06:35:42 2008
@@ -203,7 +203,11 @@
successful.
If no B<cb_final> callback was given it will wait in the event loop until a final
-response was received.
+response was received. Only in this case it will also use the param
+B<ring_time> which specifies the time it will wait for a final response. If
+no final response came in within this time it will send a CANCEL request for
+this call to close it. In this case a callback specified with B<cb_noanswer>
+will be called after the CANCEL was delivered (or delivery failed).
Returns the connection context as L<Net::SIP::Endpoint::Context> object.
@@ -211,6 +215,16 @@
L<Net::SIP::Simple::Call> object to create the first SDP session. Changes on the
SDP session will be done by calling this method on the L<Net::SIP::Simple::Call>
object C<$self>.
+
+=item cancel ( %ARGS )
+
+Closes a pending call by sending a CANCEL request.
+Returns true if call was pending and could be canceled.
+
+If %ARGS contains B<cb_final> it will be used as a callback and invoked once it gets
+the response for the CANCEL (which might be a response packet or a timeout).
+The rest of %ARGS will be merged with the connection parameter and given as an argument
+to the B<cb_final> callback (as hash reference).
=item bye ( %ARGS )
Modified: branches/upstream/libnet-sip-perl/current/samples/invite_and_send.pl
URL: http://svn.debian.org/wsvn/branches/upstream/libnet-sip-perl/current/samples/invite_and_send.pl?rev=22169&op=diff
==============================================================================
--- branches/upstream/libnet-sip-perl/current/samples/invite_and_send.pl (original)
+++ branches/upstream/libnet-sip-perl/current/samples/invite_and_send.pl Thu Jun 26 06:35:42 2008
@@ -33,6 +33,7 @@
-R|--registrar host[:port] register at given address
-S|--send filename send content of file, can be given multiple times
-L|--leg ip[:port] use given local ip[:port] for outgoing leg
+ -T|--timeout T timeout and cancel invite after T seconds, default 30
--username name username for authorization
--password pass password for authorization
@@ -50,6 +51,7 @@
# Get options
###################################################
+my $ring_time = 30;
my ($proxy, at files,$registrar,$username,$password,$local_leg);
my ($debug,$hangup);
GetOptions(
@@ -59,6 +61,7 @@
'R|registrar=s' => \$registrar,
'S|send=s' => \@files,
'L|leg=s' => \$local_leg,
+ 'T|timeout=s' => \$ring_time,
'username=s' =>\$username,
'password=s' =>\$password,
) || usage( "bad option" );
@@ -142,17 +145,22 @@
# invite peer, send first file
my $peer_hangup; # did peer hang up?
+my $no_answer; # or didn't it even answer?
my $rtp_done; # was sending file completed?
my $call = $ua->invite( $to,
# echo back, use -1 instead of 0 for not echoing back
init_media => $ua->rtp( 'send_recv', $files[0] ),
cb_rtp_done => \$rtp_done,
recv_bye => \$peer_hangup,
+ cb_noanswer => \$no_answer,
+ ring_time => $ring_time,
) || die "invite failed: ".$ua->error;
die "invite failed(call): ".$call->error if $call->error;
-DEBUG( "sending first file $files[0]" );
-$ua->loop( \$rtp_done,\$peer_hangup );
+DEBUG( "Call established (maybe), sending first file $files[0]" );
+$ua->loop( \$rtp_done,\$peer_hangup,\$no_answer );
+
+die "Ooops, no answer." if $no_answer;
# mainloop until other party hangs up or we are done
# send one file after the other using re-invites
Modified: branches/upstream/libnet-sip-perl/current/t/09_fdleak.t
URL: http://svn.debian.org/wsvn/branches/upstream/libnet-sip-perl/current/t/09_fdleak.t?rev=22169&op=diff
==============================================================================
--- branches/upstream/libnet-sip-perl/current/t/09_fdleak.t (original)
+++ branches/upstream/libnet-sip-perl/current/t/09_fdleak.t Thu Jun 26 06:35:42 2008
@@ -74,11 +74,9 @@
-my $id;
-use File::Temp 'tempfile';
sub newfd {
- $id++;
- my $tfd = tempfile( "t_$id-XXXXXXXXXX" );
- return $tfd;
+ # dup STDOUT to create new fd
+ open( my $fd,'>&STDOUT' );
+ return $fd;
}
Modified: branches/upstream/libnet-sip-perl/current/t/10_fdleak.t
URL: http://svn.debian.org/wsvn/branches/upstream/libnet-sip-perl/current/t/10_fdleak.t?rev=22169&op=diff
==============================================================================
--- branches/upstream/libnet-sip-perl/current/t/10_fdleak.t (original)
+++ branches/upstream/libnet-sip-perl/current/t/10_fdleak.t Thu Jun 26 06:35:42 2008
@@ -88,12 +88,9 @@
}
-
-my $id;
-use File::Temp 'tempfile';
sub newfd {
- $id++;
- my $tfd = tempfile( "t_$id-XXXXXXXXXX" );
- return $tfd;
+ # dup STDOUT to create new fd
+ open( my $fd,'>&STDOUT' );
+ return $fd;
}
Added: branches/upstream/libnet-sip-perl/current/t/11_invite_timeout.t
URL: http://svn.debian.org/wsvn/branches/upstream/libnet-sip-perl/current/t/11_invite_timeout.t?rev=22169&op=file
==============================================================================
--- branches/upstream/libnet-sip-perl/current/t/11_invite_timeout.t (added)
+++ branches/upstream/libnet-sip-perl/current/t/11_invite_timeout.t Thu Jun 26 06:35:42 2008
@@ -1,0 +1,122 @@
+#!/usr/bin/perl
+
+###########################################################################
+# creates a UAC and a UAS using Net::SIP::Simple
+# and makes call from UAC to UAS,
+# Call does not involve transfer of RTP data
+# UAS will on ring, but never 200 Ok, UAC will cancel call
+###########################################################################
+
+use strict;
+use warnings;
+use Test::More tests => 7;
+
+use Net::SIP;
+use Net::SIP::Util ':all';
+use IO::Socket;
+
+# create leg for UAS on dynamic port
+my $sock_uas = IO::Socket::INET->new(
+ Proto => 'udp',
+ LocalAddr => '127.0.0.1',
+ LocalPort => 0, # let system pick one
+);
+ok( $sock_uas, 'create UAS socket' );
+
+# get address for UAS
+my $uas_addr = do {
+ my ($port,$host) = unpack_sockaddr_in ( getsockname($sock_uas));
+ inet_ntoa( $host ).":$port"
+};
+
+
+# fork UAS and make call from UAC to UAS
+pipe( my $read,my $write); # to sync UAC with UAS
+my $pid = fork();
+if ( defined($pid) && $pid == 0 ) {
+ close($read);
+ $write->autoflush;
+ uas( $sock_uas, $write );
+ exit(0);
+}
+
+ok( $pid, "fork successful" );
+close( $sock_uas );
+close($write);
+
+alarm(15);
+$SIG{__DIE__} = $SIG{ALRM} = sub { kill 9,$pid; ok( 0,'died' ) };
+
+uac( $uas_addr,$read );
+ok( <$read>, "done" );
+wait;
+
+###############################################
+# UAC
+###############################################
+
+sub uac {
+ my ($peer_addr,$pipe) = @_;
+ Net::SIP::Debug->set_prefix( "DEBUG(uac):" );
+
+ ok( <$pipe>, "UAS created\n" ); # wait until UAS is ready
+ my $uac = Net::SIP::Simple->new(
+ from => 'me.uac at example.com',
+ leg => scalar(create_socket_to( $peer_addr )),
+ domain2proxy => { 'example.com' => $peer_addr },
+ );
+ ok( $uac, 'UAC created' );
+
+ ok( <$pipe>, "UAS ready\n" ); # wait until UAS is ready
+ my $canceled = 0;
+ my $call = $uac->invite(
+ 'you.uas at example.com',
+ cb_noanswer => \$canceled,
+ ring_time => 3,
+ );
+ ok( $canceled,"request was canceled" );
+}
+
+###############################################
+# UAS
+###############################################
+
+sub uas {
+ my ($sock,$pipe) = @_;
+ Net::SIP::Debug->set_prefix( "DEBUG(uas):" );
+ my $uas = Net::SIP::Simple->new(
+ domain => 'example.com',
+ leg => $sock
+ ) || die $!;
+ print $pipe "UAS created\n";
+
+ my $timer;
+ my $got_cancel;
+ my $my_receive = sub {
+ my ($self,$endpoint,$ctx,$error,$code,$packet,$leg,$from) = @_;
+ if ( $packet->is_request && $packet->method eq 'INVITE' ) {
+ # just ring
+ my $ring = $packet->create_response( 180,'Ringing' );
+ $timer ||= $endpoint->{dispatcher}->add_timer( 1,
+ sub { $endpoint->new_response( $ctx,$ring,$leg,$from ) },
+ 1 );
+ return;
+ }
+ if ( $timer && $packet->is_request && $packet->method eq 'CANCEL' ) {
+ $timer->cancel;
+ $got_cancel =1;
+ }
+ goto &Net::SIP::Simple::Call::receive;
+ };
+
+ # Listen
+ $uas->listen( cb_create => sub { return $my_receive } );
+
+ # notify UAC process that I'm listening
+ print $pipe "UAS ready\n";
+
+ # Loop at most 10 seconds
+ $uas->loop( 10,\$got_cancel );
+ $uas->loop( 1 );
+ print $pipe "UAS done\n";
+}
More information about the Pkg-perl-cvs-commits
mailing list