r7927 - in /trunk/libnet-sip-perl: ./ debian/ lib/Net/ lib/Net/SIP/ lib/Net/SIP/Dispatcher/ lib/Net/SIP/Simple/ samples/bench/ t/
rmayorga-guest at users.alioth.debian.org
rmayorga-guest at users.alioth.debian.org
Tue Sep 25 03:28:38 UTC 2007
Author: rmayorga-guest
Date: Tue Sep 25 03:28:38 2007
New Revision: 7927
URL: http://svn.debian.org/wsvn/?sc=1&rev=7927
Log:
* New Upstream version
* Moving Homepage as a valid control field
Added:
trunk/libnet-sip-perl/t/07_call_on_hold.t
- copied unchanged from r7926, branches/upstream/libnet-sip-perl/current/t/07_call_on_hold.t
trunk/libnet-sip-perl/t/08_register_with_auth.t
- copied unchanged from r7926, branches/upstream/libnet-sip-perl/current/t/08_register_with_auth.t
trunk/libnet-sip-perl/t/09_fdleak.t
- copied unchanged from r7926, branches/upstream/libnet-sip-perl/current/t/09_fdleak.t
trunk/libnet-sip-perl/t/10_fdleak.t
- copied unchanged from r7926, branches/upstream/libnet-sip-perl/current/t/10_fdleak.t
Removed:
trunk/libnet-sip-perl/t/07_call_on_hold.pl
trunk/libnet-sip-perl/t/08_register_with_auth.pl
Modified:
trunk/libnet-sip-perl/Changes
trunk/libnet-sip-perl/MANIFEST
trunk/libnet-sip-perl/META.yml
trunk/libnet-sip-perl/debian/changelog
trunk/libnet-sip-perl/debian/control
trunk/libnet-sip-perl/lib/Net/SIP.pm
trunk/libnet-sip-perl/lib/Net/SIP/Dispatcher.pm
trunk/libnet-sip-perl/lib/Net/SIP/Dispatcher.pod
trunk/libnet-sip-perl/lib/Net/SIP/Dispatcher/Eventloop.pm
trunk/libnet-sip-perl/lib/Net/SIP/Endpoint.pm
trunk/libnet-sip-perl/lib/Net/SIP/SDP.pm
trunk/libnet-sip-perl/lib/Net/SIP/Simple.pm
trunk/libnet-sip-perl/lib/Net/SIP/Simple.pod
trunk/libnet-sip-perl/lib/Net/SIP/Simple/Call.pm
trunk/libnet-sip-perl/lib/Net/SIP/Simple/Call.pod
trunk/libnet-sip-perl/lib/Net/SIP/Simple/RTP.pm
trunk/libnet-sip-perl/samples/bench/call.pl
trunk/libnet-sip-perl/t/testlib.pl
Modified: trunk/libnet-sip-perl/Changes
URL: http://svn.debian.org/wsvn/trunk/libnet-sip-perl/Changes?rev=7927&op=diff
==============================================================================
--- trunk/libnet-sip-perl/Changes (original)
+++ trunk/libnet-sip-perl/Changes Tue Sep 25 03:28:38 2007
@@ -1,4 +1,22 @@
Revision history for Net::SIP
+
+0.37
+ - Endpoint::close_context now cancel all outstanding deliveries
+ for this context in the dispatcher. Extented queue objects
+ and Dispatcher::cancel_delivery to make this possible
+ - tests for file descriptor leaks (09_fdleak.t,10_fdleak.t)
+ - some more Scalar::Util::weaken for callbacks in Simple::Call
+ to stop circular references
+
+0.36
+ - small performance improvements for Net::SIP::Simple::RTP
+ and samples/bench
+ - fixed race condition on Net::SIP::Dispatcher::Eventloop (e.g
+ one callback disabled fd, but it tried to call callback for the
+ disabled fd)
+ - added Net::SIP::Simple::cleanup and made some references to the
+ objects within callbacks weak, so that no objects and file
+ descriptors would leak if properly used
0.35
- Net::SIP::Simple::Call - close call context in $call->cleanup,
Modified: trunk/libnet-sip-perl/MANIFEST
URL: http://svn.debian.org/wsvn/trunk/libnet-sip-perl/MANIFEST?rev=7927&op=diff
==============================================================================
--- trunk/libnet-sip-perl/MANIFEST (original)
+++ trunk/libnet-sip-perl/MANIFEST Tue Sep 25 03:28:38 2007
@@ -60,8 +60,10 @@
t/04_call_with_rtp.t
t/05_call_with_stateless_proxy.t
t/06_call_with_reinvite.t
-t/07_call_on_hold.pl
-t/08_register_with_auth.pl
+t/07_call_on_hold.t
+t/08_register_with_auth.t
+t/09_fdleak.t
+t/10_fdleak.t
t/testlib.pl
samples/README
samples/invite_and_recv.pl
Modified: trunk/libnet-sip-perl/META.yml
URL: http://svn.debian.org/wsvn/trunk/libnet-sip-perl/META.yml?rev=7927&op=diff
==============================================================================
--- trunk/libnet-sip-perl/META.yml (original)
+++ trunk/libnet-sip-perl/META.yml Tue Sep 25 03:28:38 2007
@@ -1,7 +1,7 @@
# 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.35
+version: 0.37
version_from: lib/Net/SIP.pm
installdirs: site
requires:
Modified: trunk/libnet-sip-perl/debian/changelog
URL: http://svn.debian.org/wsvn/trunk/libnet-sip-perl/debian/changelog?rev=7927&op=diff
==============================================================================
--- trunk/libnet-sip-perl/debian/changelog (original)
+++ trunk/libnet-sip-perl/debian/changelog Tue Sep 25 03:28:38 2007
@@ -1,3 +1,11 @@
+libnet-sip-perl (0.37-1) unstable; urgency=low
+
+ * New upstream release
+ * Promote Homepage as a valid control field in debian/control
+
+
+ -- Rene Mayorga <rmayorga at debian.org.sv> Mon, 24 Sep 2007 21:22:09 -0600
+
libnet-sip-perl (0.35-1) unstable; urgency=low
* New upstream release
Modified: trunk/libnet-sip-perl/debian/control
URL: http://svn.debian.org/wsvn/trunk/libnet-sip-perl/debian/control?rev=7927&op=diff
==============================================================================
--- trunk/libnet-sip-perl/debian/control (original)
+++ trunk/libnet-sip-perl/debian/control Tue Sep 25 03:28:38 2007
@@ -6,6 +6,7 @@
Build-Depends: debhelper (>= 5)
Build-Depends-Indep: perl (>= 5.8.1), libnet-dns-perl, net-tools, netbase
Standards-Version: 3.7.2
+Homepage: http://search.cpan.org/dist/Net-SIP/
XS-Vcs-Svn: svn://svn.debian.org/pkg-perl/trunk/libnet-sip-perl/
XS-Vcs-Browser: http://svn.debian.org/wsvn/pkg-perl/trunk/libnet-sip-perl/
@@ -16,5 +17,3 @@
Description: SIP handler Perl module
Net::SIP module provides a tool to write SIP endpoints (e.g
phones, answer machines), SIP proxies and registrars.
- .
- Homepage: http://search.cpan.org/dist/Net-SIP/
Modified: trunk/libnet-sip-perl/lib/Net/SIP.pm
URL: http://svn.debian.org/wsvn/trunk/libnet-sip-perl/lib/Net/SIP.pm?rev=7927&op=diff
==============================================================================
--- trunk/libnet-sip-perl/lib/Net/SIP.pm (original)
+++ trunk/libnet-sip-perl/lib/Net/SIP.pm Tue Sep 25 03:28:38 2007
@@ -4,7 +4,7 @@
require 5.008;
package Net::SIP;
-our $VERSION = '0.35';
+our $VERSION = '0.37';
# this includes nearly everything else
use Net::SIP::Simple ();
Modified: trunk/libnet-sip-perl/lib/Net/SIP/Dispatcher.pm
URL: http://svn.debian.org/wsvn/trunk/libnet-sip-perl/lib/Net/SIP/Dispatcher.pm?rev=7927&op=diff
==============================================================================
--- trunk/libnet-sip-perl/lib/Net/SIP/Dispatcher.pm (original)
+++ trunk/libnet-sip-perl/lib/Net/SIP/Dispatcher.pm Tue Sep 25 03:28:38 2007
@@ -24,6 +24,7 @@
'outgoing_leg', # Leg for outgoing_proxy
'queue', # \@list of outstanding Net::SIP::Dispatcher::Packet
'response_cache', # Cache of responses, used to reply to retransmits
+ 'disp_expire', # expire/retransmit timer
);
use Net::SIP::Leg;
@@ -34,6 +35,7 @@
use Net::DNS;
use Carp 'croak';
use Net::SIP::Debug;
+use Scalar::Util 'weaken';
###########################################################################
@@ -101,10 +103,16 @@
# regularly prune queue
my $sub = sub {
- my ($self,$loop) = @_;
- $self->queue_expire($loop->looptime);
+ my ($self,$timer) = @_;
+ if ( $self ) {
+ $self->queue_expire( $self->{eventloop}->looptime );
+ } else {
+ $timer->cancel;
+ }
};
- $self->add_timer( 1,[ $sub,$self,$eventloop ],1,'disp_expire' );
+ my $cb = [ $sub,$self ];
+ weaken( $cb->[1] );
+ $self->{disp_expire} = $self->add_timer( 1,$cb,1,'disp_expire' );
return $self;
}
@@ -115,16 +123,22 @@
# Args: ($self,$receiver)
# $receiver: object which has receive( Net::SIP::Leg,Net::SIP::Packet )
# method to handle incoming SIP packets or callback
+# might be undef - in this case the existing receiver will be removed
# Returns: NONE
###########################################################################
sub set_receiver {
my Net::SIP::Dispatcher $self = shift;
- my $receiver = shift;
- if ( my $sub = UNIVERSAL::can($receiver,'receive' )) {
- # Object with method receive()
- $receiver = [ $sub,$receiver ]
- }
- $self->{receiver} = $receiver;
+ if ( my $receiver = shift ) {
+ if ( my $sub = UNIVERSAL::can($receiver,'receive' )) {
+ # Object with method receive()
+ $receiver = [ $sub,$receiver ]
+ }
+ $self->{receiver} = $receiver;
+ } else {
+ # remove receiver
+ $self->{receiver} = undef
+ }
+
}
###########################################################################
@@ -162,6 +176,7 @@
if ( my $fd = $leg->fd ) {
my $cb = sub {
my ($self,$leg) = @_;
+ $self || return;
# leg->receive might return undef if the packet wasnt
# read successfully. for tcp connections the receive
@@ -176,7 +191,9 @@
# handle received packet
$self->receive( $packet,$leg,$from );
};
- $self->{eventloop}->addFD( $fd, [ $cb,$self,$leg ]);
+ $cb = [ $cb,$self,$leg ];
+ weaken( $cb->[1] );
+ $self->{eventloop}->addFD( $fd, $cb );
}
}
}
@@ -298,22 +315,45 @@
###########################################################################
# cancel delivery of all packets with specific id
-# Args: ($self,$id)
+# Args: ($self,$typ?,$id)
+# $typ: what to cancel, e.g. 'id','callid' or 'qentry', optional,
+# defaults to 'id' if $id is not ref or 'qentry' if $id is ref
# $id: id to cancel, can also be queue entry
# Returns: NONE
###########################################################################
sub cancel_delivery {
my Net::SIP::Dispatcher $self = shift;
- my ($id) = @_;
+ my ($callid,$id,$qentry);
+ if ( @_ == 2 ) {
+ my $typ = shift;
+ if ( $typ eq 'callid' ) { $callid = shift }
+ elsif ( $typ eq 'id' ) { $id = shift }
+ elsif ( $typ eq 'qentry' ) { $qentry = shift }
+ else {
+ croak( "bad typ '$typ', should be id|callid|qentry" );
+ }
+ } else {
+ $id = shift;
+ if ( ref($id)) {
+ $qentry = $id;
+ $id = undef;
+ }
+ }
my $q = $self->{queue};
- if ( ref($id)) {
+ if ( $qentry ) {
# it's a *::Dispatcher::Packet
- DEBUG( 100,"cancel packet $id: $id->{id}" );
- @$q = grep { $_ != $id } @$q;
+ DEBUG( 100,"cancel packet id: $qentry->{id}" );
+ @$q = grep { $_ != $qentry } @$q;
+ } elsif ( defined $id ) {
+ no warnings; # $_->{id} can be undef
+ DEBUG( 100, "cancel packet id $id" );
+ @$q = grep { $_->{id} ne $id } @$q;
+ } elsif ( defined $callid ) {
+ no warnings; # $_->{callid} can be undef
+ DEBUG( 100, "cancel packet callid $callid" );
+ @$q = grep { $_->{callid} ne $callid } @$q;
} else {
- no warnings; # $_->{id} can be undef
- DEBUG( 100, "cancel packet $id" );
- @$q = grep { $_->{id} ne $id } @$q;
+ croak( "cancel_delivery w/o id" );
}
}
@@ -476,6 +516,7 @@
# I have leg and addr, send packet thru leg to addr
my $cb = sub {
my ($self,$qentry,$error) = @_;
+ $self || return;
if ( !$error && $qentry->{retransmits} ) {
# remove from queue even if timeout
$self->cancel_delivery( $qentry );
@@ -486,7 +527,10 @@
# adds via on cloned packet, calls cb if definite success (tcp)
# or error
DEBUG( 50,"deliver through leg $leg \@$dst_addr" );
- $leg->deliver( $qentry->{packet},$dst_addr, [ $cb,$self,$qentry ] );
+ weaken( my $rself = \$self );
+ $cb = [ $cb,$self,$qentry ];
+ weaken( $cb->[1] );
+ $leg->deliver( $qentry->{packet},$dst_addr,$cb );
if ( !$qentry->{retransmits} ) {
# remove from queue if no timeout
@@ -766,6 +810,7 @@
package Net::SIP::Dispatcher::Packet;
use fields (
'id', # transaction id, used for canceling delivery if response came in
+ 'callid', # callid, used for canceling all deliveries for this call
'packet', # the packet which nees to be delivered
'dst_addr', # to which adress the packet gets delivered, is array-ref because
# the DNS/SRV lookup might return multiple addresses and protocols
@@ -796,6 +841,7 @@
my $self = fields::new( $class );
%$self = %args;
$self->{id} ||= $self->{packet}->tid;
+ $self->{callid} ||= $self->{packet}->callid;
if ( my $addr = $self->{dst_addr} ) {
$self->{dst_addr} = [ $addr ] if !ref($addr)
Modified: trunk/libnet-sip-perl/lib/Net/SIP/Dispatcher.pod
URL: http://svn.debian.org/wsvn/trunk/libnet-sip-perl/lib/Net/SIP/Dispatcher.pod?rev=7927&op=diff
==============================================================================
--- trunk/libnet-sip-perl/lib/Net/SIP/Dispatcher.pod (original)
+++ trunk/libnet-sip-perl/lib/Net/SIP/Dispatcher.pod Tue Sep 25 03:28:38 2007
@@ -157,6 +157,12 @@
ID for packet, used in B<cancel_delivery>. If not given the transaction
ID of PACKET given by method B<tid> will be used.
+=item callid
+
+Call-ID for packet, used in B<cancel_delivery> to cancel all deliveries for
+a specific call. If not given the Call-Id of PACKET given by method B<callid>
+will be used.
+
=item callback
callback which will be called on definite delivery of packet (only possible
@@ -265,11 +271,18 @@
=back
-=item cancel_delivery ( ID )
+=item cancel_delivery ( TYP?,ID )
Cancels retransmission of packet with id ID. Called from endpoint
if response to packet came in, which means that the packet was
successfully delivered.
+
+If TYP given packets can be canceled by something else. TYP can be
+C<callid>, in which case all deliveries for a specific call will be
+canceled. It can be C<id> which will cancel the packet with id ID.
+Or itcan be C<qentry> in which case ID will be interpreted as
+the L<Net::SIP::Dispatcher::Packet> object in the queue and it will
+cancel this packet.
=item receive ( PACKET, LEG, FROM )
Modified: trunk/libnet-sip-perl/lib/Net/SIP/Dispatcher/Eventloop.pm
URL: http://svn.debian.org/wsvn/trunk/libnet-sip-perl/lib/Net/SIP/Dispatcher/Eventloop.pm?rev=7927&op=diff
==============================================================================
--- trunk/libnet-sip-perl/lib/Net/SIP/Dispatcher/Eventloop.pm (original)
+++ trunk/libnet-sip-perl/lib/Net/SIP/Dispatcher/Eventloop.pm Tue Sep 25 03:28:38 2007
@@ -164,13 +164,13 @@
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;
- my @can_read = grep { vec($rout,fileno($_->[0]),1) } @to_read;
- DEBUG( 100, "can_read=".join( " ",map { fileno($_->[0]) } @can_read ));
-
# returned from select
$looptime = $self->{now} = gettimeofday();
-
- foreach my $fd_data (@can_read) {
+ DEBUG( 100, "can_read=".join( " ",map { $_ } grep { $fds->[$_] && vec($rout,$_,1) } (0..$#$fds)));
+ for( my $fn=0;$fn<@$fds;$fn++ ) {
+ vec($rout,$fn,1) or next;
+ my $fd_data = $fds->[$fn] or next;
+ DEBUG( 1,"fn=$fn" );
invoke_callback( $fd_data->[1],$fd_data->[0] );
}
} else {
Modified: trunk/libnet-sip-perl/lib/Net/SIP/Endpoint.pm
URL: http://svn.debian.org/wsvn/trunk/libnet-sip-perl/lib/Net/SIP/Endpoint.pm?rev=7927&op=diff
==============================================================================
--- trunk/libnet-sip-perl/lib/Net/SIP/Endpoint.pm (original)
+++ trunk/libnet-sip-perl/lib/Net/SIP/Endpoint.pm Tue Sep 25 03:28:38 2007
@@ -18,6 +18,7 @@
use Net::SIP::Debug;
use Net::SIP::Endpoint::Context;
use Net::SIP::Util qw(invoke_callback);
+use Scalar::Util 'weaken';
############################################################################
# create a new endpoint
@@ -34,7 +35,9 @@
# announce myself as upper layer for incoming packets to
# the dispatcher
- $dispatcher->set_receiver( $self );
+ my $cb = [ \&receive,$self ];
+ weaken( $cb->[1] );
+ $dispatcher->set_receiver( $cb );
return $self;
}
@@ -196,7 +199,7 @@
}
############################################################################
-# remove context from Endpoint
+# remove context from Endpoint and cancel all outstanding deliveries
# Args: ($self,$id)
# $id: either id for ctx or context object or SIP packet
# Returns: $ctx
@@ -211,6 +214,8 @@
DEBUG( 50,"no context for call-id $id found" );
return;
};
+ # cancel all outstanding deliveries
+ $self->{dispatcher}->cancel_delivery( callid => $id );
return $ctx;
}
@@ -225,7 +230,7 @@
# Returns: NONE
############################################################################
sub receive {
- my Net::SIP::Endpoint $self = shift;
+ my Net::SIP::Endpoint $self = shift || return;
my ($packet,$leg,$from) = @_;
return $packet->is_response
? $self->receive_response( $packet,$leg,$from )
Modified: trunk/libnet-sip-perl/lib/Net/SIP/SDP.pm
URL: http://svn.debian.org/wsvn/trunk/libnet-sip-perl/lib/Net/SIP/SDP.pm?rev=7927&op=diff
==============================================================================
--- trunk/libnet-sip-perl/lib/Net/SIP/SDP.pm (original)
+++ trunk/libnet-sip-perl/lib/Net/SIP/SDP.pm Tue Sep 25 03:28:38 2007
@@ -157,7 +157,8 @@
my ($class,$string) = @_;
# split into lines
- Carp::confess('bla' ) if ref( $string ) eq 'HASH';
+ Carp::confess('expected string or ARRAY ref' )
+ if ref($string) && ref( $string ) ne 'ARRAY';
my @lines = ref($string)
? @$string
: split( m{\r?\n}, $string );
Modified: trunk/libnet-sip-perl/lib/Net/SIP/Simple.pm
URL: http://svn.debian.org/wsvn/trunk/libnet-sip-perl/lib/Net/SIP/Simple.pm?rev=7927&op=diff
==============================================================================
--- trunk/libnet-sip-perl/lib/Net/SIP/Simple.pm (original)
+++ trunk/libnet-sip-perl/lib/Net/SIP/Simple.pm Tue Sep 25 03:28:38 2007
@@ -1,4 +1,4 @@
-###########################################################################
+#########################################################################
# Net::SIP::Simple
# simple methods for creation of UAC,UAS
# - register register Address
@@ -24,6 +24,7 @@
'domain', # default domain for SIP addresses
'last_error', # last error
'options', # hash with field,values for response to OPTIONS request
+ 'ua_cleanup', # cleanup callbacks
);
use Carp qw(croak);
@@ -88,6 +89,9 @@
if $from !~m{\s} && $from !~m{\@};
}
+ my $ua_cleanup = [];
+ my $self = fields::new( $class );
+
my $options = delete $args{options} || {};
{
@{$options}{ map { lc } keys(%$options) } = values(%$options); # lc keys
@@ -152,10 +156,16 @@
domain2proxy => $d2p,
);
}
+ push @$ua_cleanup, [
+ sub {
+ my ($self,$legs) = @_;
+ $self->{dispatcher}->remove_leg(@$legs);
+ },
+ $self,$legs
+ ] if @$legs;
my $endpoint = Net::SIP::Endpoint->new( $disp );
- my $self = fields::new( $class );
my $routes = delete $args{routes} || delete $args{route};
%$self = (
auth => $auth,
@@ -167,8 +177,22 @@
loop => $loop,
route => $routes,
options => $options,
+ ua_cleanup => $ua_cleanup,
);
return $self;
+}
+
+###########################################################################
+# cleanup object, e.g. remove legs it added to dispatcher
+# Args: ($self)
+# Returns: NONE
+###########################################################################
+sub cleanup {
+ my Net::SIP::Simple $self = shift;
+ while ( my $cb = shift @{ $self->{ua_cleanup} } ) {
+ invoke_callback($cb,$self)
+ }
+ %$self = ();
}
###########################################################################
Modified: trunk/libnet-sip-perl/lib/Net/SIP/Simple.pod
URL: http://svn.debian.org/wsvn/trunk/libnet-sip-perl/lib/Net/SIP/Simple.pod?rev=7927&op=diff
==============================================================================
--- trunk/libnet-sip-perl/lib/Net/SIP/Simple.pod (original)
+++ trunk/libnet-sip-perl/lib/Net/SIP/Simple.pod Tue Sep 25 03:28:38 2007
@@ -41,7 +41,14 @@
=item new ( %ARGS )
-Creates new Net::SIP::Simple object. %ARGS can be:
+Creates new Net::SIP::Simple object.
+
+It will return the new object for further operations, but the object itself will
+contain back references to itself in the form of callbacks into the eventloop
+and dispatcher. This means that that object will not self-destroy, but you need
+to call B<cleanup> if you want it to go away.
+
+%ARGS can be:
=over 8
@@ -115,6 +122,12 @@
=head1 METHODS
=over 4
+
+=item cleanup
+
+Cleans up object, removes legs it added from the dispatcher.
+Needs to be called if you want to destroy the object, because it will not
+self-destroy (see B<new>).
=item error ( ERROR )
Modified: trunk/libnet-sip-perl/lib/Net/SIP/Simple/Call.pm
URL: http://svn.debian.org/wsvn/trunk/libnet-sip-perl/lib/Net/SIP/Simple/Call.pm?rev=7927&op=diff
==============================================================================
--- trunk/libnet-sip-perl/lib/Net/SIP/Simple/Call.pm (original)
+++ trunk/libnet-sip-perl/lib/Net/SIP/Simple/Call.pm Tue Sep 25 03:28:38 2007
@@ -52,6 +52,7 @@
use Socket;
use Storable 'dclone';
use Carp 'croak';
+use Scalar::Util 'weaken';
###########################################################################
# create a new call based on a controller
@@ -66,6 +67,7 @@
my ($class,$control,$ctx,$param) = @_;
my $self = fields::new( $class );
%$self = %$control;
+ $self->{ua_cleanup} = [];
$self->{ctx} = ref($ctx) ? $ctx : {
to => $ctx,
from => $self->{from},
@@ -94,8 +96,8 @@
if ( my $ctx = $self->{ctx} ) {
$self->{endpoint}->close_context( $ctx );
}
- %$self = ();
- DEBUG( 100,"done" );
+ $self->{param} = {};
+ $self->SUPER::cleanup;
}
sub rtp_cleanup {
@@ -173,7 +175,7 @@
# predefined callback
my $cb = sub {
- my Net::SIP::Simple::Call $self = shift;
+ my Net::SIP::Simple::Call $self = shift || return;
my ($endpoint,$ctx,$errno,$code,$packet,$leg,$from,$ack) = @_;
if ( $errno ) {
@@ -212,13 +214,14 @@
}
invoke_callback( $param->{cb_final},'OK',$self );
invoke_callback( $param->{init_media},$self,$param );
-
};
my $stopvar = 0;
$param->{cb_final} ||= \$stopvar;
+ $cb = [ $cb,$self ];
+ weaken( $cb->[1] );
$self->{ctx} = $self->{endpoint}->invite(
- $ctx, [ $cb,$self ], $sdp,
+ $ctx, $cb, $sdp,
$param->{sip_header} ? %{ $param->{sip_header} } : ()
);
if ( $param->{cb_final} == \$stopvar ) {
@@ -250,7 +253,8 @@
my $bye_cb = [
sub {
- my ($self,$cb,$args,$endpoint,$ctx,$error,$code) = @_;
+ 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
@@ -265,6 +269,7 @@
},
$self,$cb,\%args
];
+ weaken( $bye_cb->[1] );
$self->{endpoint}->new_request( 'BYE',$self->{ctx}, $bye_cb );
}
Modified: trunk/libnet-sip-perl/lib/Net/SIP/Simple/Call.pod
URL: http://svn.debian.org/wsvn/trunk/libnet-sip-perl/lib/Net/SIP/Simple/Call.pod?rev=7927&op=diff
==============================================================================
--- trunk/libnet-sip-perl/lib/Net/SIP/Simple/Call.pod (original)
+++ trunk/libnet-sip-perl/lib/Net/SIP/Simple/Call.pod Tue Sep 25 03:28:38 2007
@@ -166,8 +166,11 @@
Will be called to clean up the call. Necessary because callbacks etc can cause
cyclic references which need to be broken.
Calls B<rtp_cleanup> too.
-
-Works be invoking all callbacks which are stored as \@list in C<< $self->{call_cleanup} >>.
+Works by invoking all callbacks which are stored as \@list in C<< $self->{call_cleanup} >>.
+
+This will called automatically at a clean end of a call (e.g. on BYE or CANCEL, either
+issued locally or received from the peer). If there is not clean end and one wants
+to destroy the call unclean one need to call this method manually.
=item rtp_cleanup
Modified: trunk/libnet-sip-perl/lib/Net/SIP/Simple/RTP.pm
URL: http://svn.debian.org/wsvn/trunk/libnet-sip-perl/lib/Net/SIP/Simple/RTP.pm?rev=7927&op=diff
==============================================================================
--- trunk/libnet-sip-perl/lib/Net/SIP/Simple/RTP.pm (original)
+++ trunk/libnet-sip-perl/lib/Net/SIP/Simple/RTP.pm Tue Sep 25 03:28:38 2007
@@ -47,24 +47,29 @@
my @delay_buffer;
my $echo_back = sub {
my ($s_sock,$remote,$delay_buffer,$delay,$writeto,$targs,$didit,$sock) = @_;
- my $buf = _receive_rtp( $sock,$writeto,$targs,$didit );
- #DEBUG( "$didit=$$didit" );
- $$didit = 1;
- return if $delay<0;
- return if ! $remote; # call on hold ?
- push @$delay_buffer, $buf;
- while ( @$delay_buffer > $delay ) {
- send( $s_sock,shift(@$delay_buffer),0,$remote );
+ while (1) {
+ my $buf = _receive_rtp( $sock,$writeto,$targs,$didit );
+ defined($buf) or last;
+ #DEBUG( "$didit=$$didit" );
+ $$didit = 1;
+ next if $delay<0;
+ next if ! $remote; # call on hold ?
+ push @$delay_buffer, $buf;
+ while ( @$delay_buffer > $delay ) {
+ send( $s_sock,shift(@$delay_buffer),0,$remote );
+ }
}
};
$call->{loop}->addFD( $sock,
[ $echo_back,$s_sock,$addr,\@delay_buffer,$delay || 0,$writeto,{},\$didit ] );
+ my $was_blocking = $s_sock->blocking(0);
push @{ $call->{ rtp_cleanup }}, [ sub {
- my ($call,$sock) = @_;
+ my ($call,$sock,$blocking) = @_;
DEBUG( 100,"rtp_cleanup: remove socket %d",fileno($sock));
$call->{loop}->delFD( $sock );
- }, $call,$sock ];
+ $sock->blocking(1) if $blocking;
+ }, $call,$sock,$was_blocking ];
}
# on RTP inactivity for at least 10 seconds close connection
@@ -126,8 +131,15 @@
$addr = $addr->[0] if ref($addr);
# recv once I get an event on RTP socket
- my $receive = sub { my $sock = pop; _receive_rtp( $sock, at _ ); };
+ my $receive = sub {
+ my ($writeto,$targs,$didit,$sock) = @_;
+ while (1) {
+ my $buf = _receive_rtp( $sock,$writeto,$targs,$didit );
+ defined($buf) or return;
+ }
+ };
$call->{loop}->addFD( $sock, [ $receive,$writeto,{},\$didit ] );
+ my $was_blocking = $sock->blocking(0);
# sending need to be done with a timer
# ! $addr == call on hold
@@ -135,7 +147,7 @@
my $cb_done = $args->{cb_rtp_done} || sub { shift->bye };
my $timer = $call->{dispatcher}->add_timer(
0, # start immediatly
- [ \&_send_rtp,$s_sock,$addr,$readfrom, {
+ [ \&_send_rtp,$s_sock,$call->{loop},$addr,$readfrom, {
repeat => $repeat || 1,
cb_done => [ sub { invoke_callback(@_) }, $cb_done, $call ]
}],
@@ -144,10 +156,11 @@
);
push @{ $call->{ rtp_cleanup }}, [ sub {
- my ($call,$sock,$timer) = @_;
+ my ($call,$sock,$timer,$wb) = @_;
$call->{loop}->delFD( $sock );
+ $sock->blocking(1) if $wb;
$timer->cancel();
- }, $call,$sock,$timer ];
+ }, $call,$sock,$timer,$was_blocking ];
}
}
@@ -187,8 +200,8 @@
my ($sock,$writeto,$targs,$didit) = @_;
my $from = recv( $sock,my $buf,2**16,0 );
+ return if ! $from || !defined($buf) || $buf eq '';
DEBUG( 50,"received %d bytes from RTP", length($buf));
- $buf || return;
if(0) {
use Socket;
@@ -229,7 +242,7 @@
if ( ref($writeto)) {
# callback
- invoke_callback( $writeto,$payload );
+ invoke_callback( $writeto,$payload,$seq,$tstamp );
} elsif ( $writeto ) {
# save into file
my $fd = $targs->{fdr};
@@ -246,8 +259,9 @@
###########################################################################
# Helper to read RTP data from file (PCMU 8000) and send them through
# the RTP socket
-# Args: ($sock,$addr,$readfrom,$targs)
+# Args: ($sock,$loop,$addr,$readfrom,$targs)
# $sock: RTP socket
+# $loop: event loop (used for looptime for timestamp)
# $addr: where to send data
# $readfrom: filename for reading or callback which will return payload
# $targs: \%hash to hold state info between calls of this function
@@ -257,11 +271,10 @@
# 'repeat' makes only sense if $readfrom is filename
# Return: NONE
###########################################################################
-use Time::HiRes 'gettimeofday';
sub _send_rtp {
- my ($sock,$addr,$readfrom,$targs,$timer) = @_;
-
- my $buf;
+ my ($sock,$loop,$addr,$readfrom,$targs,$timer) = @_;
+
+ my ($buf);
if ( ref($readfrom) ) {
# payload by callback
$buf = invoke_callback( $readfrom );
@@ -299,22 +312,23 @@
$buf || die $!;
# add RTP header
- my ($high,$low) = gettimeofday();
- my $timestamp = ( $high << 16 ) | ( $low >> 16 );
+ my $now = $loop->looptime;
+ my $timestamp = ( $now * 10_000 ) % 2**32; # 10*ms precision in 32 bit
$targs->{wseq}++;
-
- {
+ my $seq = $targs->{wseq};
+
+ if (0) {
my ($fp,$fa) = unpack_sockaddr_in( getsockname($sock) );
$fa = inet_ntoa($fa);
my ($tp,$ta) = unpack_sockaddr_in( $addr );
$ta = inet_ntoa($ta);
- DEBUG( 50, "$fa:$fp -> $ta:$tp seq=$targs->{wseq} ts=%x",$timestamp );
+ DEBUG( 50, "$fa:$fp -> $ta:$tp seq=$seq ts=%x",$timestamp );
}
my $header = pack('CCnNN',
0b10000000, # Version 2
0b00000000, # PMCU 8000
- $targs->{wseq}, # sequence
+ $seq, # sequence
$timestamp,
0x1234, # source ID
);
Modified: trunk/libnet-sip-perl/samples/bench/call.pl
URL: http://svn.debian.org/wsvn/trunk/libnet-sip-perl/samples/bench/call.pl?rev=7927&op=diff
==============================================================================
--- trunk/libnet-sip-perl/samples/bench/call.pl (original)
+++ trunk/libnet-sip-perl/samples/bench/call.pl Tue Sep 25 03:28:38 2007
@@ -1,6 +1,5 @@
use strict;
use Net::SIP qw(:all);
-use Time::HiRes 'gettimeofday';
use Getopt::Long qw(:config posix_default bundling);
my $debug;
@@ -21,42 +20,11 @@
) || usage( 'bad options' );
Debug->level( $debug || 1 ) if defined $debug;
-sub usage {
- print STDERR "ERROR: @_\n" if @_;
- print STDERR <<USAGE;
-
-
-Makes N parallel calls from FROM to TO and writes statistics about received, lost
-packets and delays. Does not send real RTP, but hides non-RTP data within RTP frames
-to compute statistics.
-Usage: $0 options
-Options:
- -h|--help This usage
- -d|--debug Switch on debugging with optional level
- -F|--from local address, default $from
- -T|--to peer address, default $to
- -P|--proxy Adress of target or proxy on path to target, default $outgoing_proxy
- -N|--parallel Number of parallel calls, default $ncalls
- -S|--stat-timer How often to print statistics, default every $stat_timer seconds
-
-The statistics look like this:
-
- 28 pkt=1005/0/0 delay(ms)=5.68/1.08/41.79
- | | | | | | |
- | | | | ---------------- avg/min/max delay in ms
- | | | |---------------------------- ignored packets (retransmits..)
- | | |------------------------------ lost packets (or received out of order)
- | |---------------------------------- good packets received
- |------------------------------------------ seconds since start
-
-USAGE
- exit(2);
-}
-
-
+my $loop = Net::SIP::Dispatcher::Eventloop->new;
my $ua = Simple->new(
from => $from,
outgoing_proxy => $outgoing_proxy,
+ loop => $loop,
);
my (@connected,$start_bench,$min_delay,$max_delay);
@@ -101,7 +69,9 @@
sub send_rtp {
my $rseq = shift;
- my ($sec,$msec) = gettimeofday();
+ my $now = $loop->looptime;
+ my $sec = int($now);
+ my $msec = ( $now - $sec ) * 1_000_000;
my $seq = $start_bench ? $$rseq++ : 0;
return pack( "NNN",$seq,$sec,$msec ) . ( ' ' x 148 );
}
@@ -122,7 +92,7 @@
$lost += $diff-1;
$$rseq = $seq;
$ok++;
- my $now = gettimeofday();
+ my $now = $loop->looptime;
my $then = $sec + $msec/10**6;
my $delay = $now - $then;
die "now=".localtime($now)." then=".localtime($then) if $delay<0;
@@ -130,3 +100,37 @@
$min_delay = $delay if ! defined $min_delay || $min_delay > $delay;
$max_delay = $delay if ! defined $max_delay || $max_delay < $delay;
}
+
+sub usage {
+ print STDERR "ERROR: @_\n" if @_;
+ print STDERR <<USAGE;
+
+
+Makes N parallel calls from FROM to TO and writes statistics about received, lost
+packets and delays. Does not send real RTP, but hides non-RTP data within RTP frames
+to compute statistics.
+Usage: $0 options
+Options:
+ -h|--help This usage
+ -d|--debug Switch on debugging with optional level
+ -F|--from local address, default $from
+ -T|--to peer address, default $to
+ -P|--proxy Adress of target or proxy on path to target, default $outgoing_proxy
+ -N|--parallel Number of parallel calls, default $ncalls
+ -S|--stat-timer How often to print statistics, default every $stat_timer seconds
+
+The statistics look like this:
+
+ 28 pkt=1005/0/0 delay(ms)=5.68/1.08/41.79
+ | | | | | | |
+ | | | | ---------------- avg/min/max delay in ms
+ | | | |---------------------------- ignored packets (retransmits..)
+ | | |------------------------------ lost packets (or received out of order)
+ | |---------------------------------- good packets received
+ |------------------------------------------ seconds since start
+
+USAGE
+ exit(2);
+}
+
+
Modified: trunk/libnet-sip-perl/t/testlib.pl
URL: http://svn.debian.org/wsvn/trunk/libnet-sip-perl/t/testlib.pl?rev=7927&op=diff
==============================================================================
--- trunk/libnet-sip-perl/t/testlib.pl (original)
+++ trunk/libnet-sip-perl/t/testlib.pl Tue Sep 25 03:28:38 2007
@@ -7,6 +7,20 @@
# small test lib for common tasks:
#
############################################################################
+
+# small implementations if not used from Test::More (09_fdleak.t)
+if ( ! defined &ok ) {
+ no strict 'refs';
+ *{'ok'} = sub {
+ my ($bool,$desc) = @_;
+ print $bool ? "ok ":"not ok ", '# ',$desc || '',"\n";
+ };
+ *{'diag'} = sub { print STDERR "@_\n"; };
+ *{'like'} = sub {
+ my ( $data,$rx,$desc ) = @_;
+ ok( $data =~ $rx ? 1:0, $desc );
+ };
+}
$SIG{ __DIE__ } = sub {
ok( 0,"@_" );
@@ -138,7 +152,7 @@
sub fd_grep_ok {
my $pattern = shift;
my ($rv,$name) = fd_grep( $pattern, @_ );
- local $Test::Builder::Level = $Test::Builder::Level+1;
+ local $Test::Builder::Level = $Test::Builder::Level || 0 +1;
ok( $rv,"[$name] $pattern" );
die "fatal error" if !$rv && ! defined wantarray;
return $rv;
@@ -242,4 +256,6 @@
return $self->SUPER::deliver( $packet,$to,$callback );
}
+
+
1;
More information about the Pkg-perl-cvs-commits
mailing list