File Coverage

blib/lib/Net/SIP/NATHelper/Server.pm
Criterion Covered Total %
statement 21 107 19.6
branch 0 38 0.0
condition 0 11 0.0
subroutine 7 15 46.6
pod 7 7 100.0
total 35 178 19.6


line stmt bran cond sub pod time code
1 4     4   1702 use strict;
  4         9  
  4         963  
2 4     4   17 use warnings;
  4         8  
  4         142  
3              
4             ############################################################################
5             #
6             # wrap Net::SIP::NATHelper::Base
7             # read commands from socket and propagete them to NATHelper, send
8             # replies back
9             #
10             ############################################################################
11              
12             package Net::SIP::NATHelper::Server;
13 4     4   18 use fields qw( helper callbacks cfd commands );
  4         8  
  4         18  
14              
15 4     4   312 use Net::SIP qw(invoke_callback :debug);
  4         7  
  4         23  
16 4     4   59 use Net::SIP::NATHelper::Base;
  4         8  
  4         103  
17 4     4   19 use Storable qw(thaw nfreeze);
  4         5  
  4         162  
18 4     4   19 use Data::Dumper;
  4         11  
  4         3866  
19              
20             my %default_commands = (
21             allocate => sub { shift->allocate_sockets(@_) },
22             activate => sub { shift->activate_session(@_) },
23             close => sub { shift->close_session(@_) },
24             );
25              
26              
27             ############################################################################
28             # new NAThelper
29             # Args: ($class,?$helper,@socket)
30             # $helper: Net::SIP::NATHelper::Base object, will be created if not given
31             # @socket: SOCK_STREAM sockets for communication SIP proxies
32             # Returns: $self
33             ############################################################################
34             sub new {
35 0     0 1   my $class = shift;
36 0           my $helper;
37 0 0 0       if ( @_ && UNIVERSAL::isa( $_[0],'Net::SIP::NATHelper::Base' )) {
38 0           $helper = shift;
39             } else {
40 0           $helper = Net::SIP::NATHelper::Base->new;
41             }
42 0           my $self = fields::new( $class );
43 0           %$self = (
44             helper => $helper,
45             callbacks => [],
46             cfd => \@_,
47             commands => { %default_commands },
48             );
49 0           return $self,
50             }
51              
52             ############################################################################
53             # read + execute command
54             # command is transported as [ $cmd,@args ] using Storable::nfreeze
55             # and reply is transported back using nfreeze too
56             # Args: $self
57             # Returns: NONE
58             ############################################################################
59             sub do_command {
60 0     0 1   my Net::SIP::NATHelper::Server $self = shift;
61 0           my $cfd = shift;
62              
63 0   0       my $sock = $cfd->accept || do {
64             DEBUG( 50,"accept failed: $!" );
65             return;
66             };
67 0           $sock->autoflush;
68              
69 0 0         read( $sock,my $buf, 4 ) || do {
70 0           DEBUG( 50, "read of 4 bytes len failed: $!" );
71 0           return;
72             };
73 0           my $len = unpack( "N",$buf );
74 0           DEBUG( 50, "len=$len" );
75 0 0         if ( $len > 32768 ) {
76 0           warn( "tooo much data to read, unbelievable len=$len" );
77 0           return;
78             }
79 0 0         read( $sock,$buf, $len ) || do {
80 0           DEBUG( 50,"read of $len bytes failed: $!" );
81 0           return;
82             };
83              
84 0 0         my ($cmd,@args) = eval { @{ thaw( $buf ) } } or do {
  0            
  0            
85 0           DEBUG( 50,"thaw failed: $@" );
86 0           return;
87             };
88              
89 0           DEBUG( 100, "request=".Dumper([$cmd,@args]));
90 0 0         my $cb = $self->{commands}{$cmd} or do {
91 0           DEBUG( 10,"unknown command: $cmd" );
92 0           return;
93             };
94 0           my $reply = invoke_callback($cb,$self,@args);
95 0 0         unless ( defined( $reply )) {
96 0           DEBUG( 10, "no reply for $cmd" );
97             }
98              
99 0           DEBUG( 100, "reply=".Dumper($reply));
100              
101             # nfreeze needs reference!
102 0           print $sock pack( "N/a*",nfreeze(\$reply));
103 0           close($sock);
104             }
105              
106              
107             ############################################################################
108             # loop:
109             # * if received new command execute it
110             # * if receive data on RTP sockets forward them
111             # Args: $self
112             # Returns: NEVER
113             ############################################################################
114             sub loop {
115 0     0 1   my Net::SIP::NATHelper::Server $self = shift;
116              
117 0           my $rin; # select mask
118 0           my $last_expire = 0;
119 0           my $helper = $self->{helper};
120              
121 0           while (1) {
122              
123             # @$callbacks get set to empty in _update_callbacks which get
124             # called if something on the sockets changed. In this case
125             # recompute the callbacks. This is not the fastest method, but
126             # easy to understand :)
127              
128 0           my $callbacks = $self->{callbacks};
129 0           my $timeout = 1;
130 0 0         if ( !@$callbacks ) {
131             # recompute callbacks:
132             # - add callbacks from NATHelper
133 0           foreach ( $helper->callbacks ) {
134 0           my ($fd,$cb) = @$_;
135 0           $callbacks->[ fileno($fd) ] = $cb;
136             }
137              
138             # if nothing to do on helper set timeout to infinite
139 0 0 0       if ( !@$callbacks && ! $helper->number_of_calls ) {
140 0           $timeout = undef;
141 0           DEBUG( 50,"no RTP socks: set timeout to infinite" );
142             }
143              
144             # - and for command sockets
145 0           foreach my $cfd ( @{ $self->{cfd} } ) {
  0            
146 0           $callbacks->[ fileno($cfd) ] = [ \&do_command, $self,$cfd ];
147             }
148              
149             # recompute select mask
150 0           $rin = '';
151 0           for( my $i=0;$i<@$callbacks;$i++ ) {
152 0 0         vec( $rin,$i,1 ) = 1 if $callbacks->[$i]
153             }
154              
155             }
156              
157             # select which sockets got readable or timeout
158 0 0         $rin || die;
159 0 0         defined( select( my $rout = $rin,undef,undef,$timeout ) ) || die $!;
160 0           my $now = time();
161              
162             # handle callbacks on sockets
163 0 0         if ( $rout ) {
164 0           for( my $i=0;$i<@$callbacks;$i++ ) {
165 0 0         invoke_callback( $callbacks->[$i] ) if vec( $rout,$i,1 );
166             }
167             }
168              
169             # handle expires
170 0 0         if ( $now - $last_expire >= 1 ) {
171 0           $last_expire = $now;
172 0           $self->expire;
173 0           DEBUG( 100, $helper->dump );
174             }
175             }
176             }
177              
178             ############################################################################
179             # wrap methods in helper to call _update_callbacks when appropriate
180             ############################################################################
181             sub expire {
182 0     0 1   my Net::SIP::NATHelper::Server $self = shift;
183 0           my @expired = $self->{helper}->expire(@_);
184 0 0         @expired && $self->_update_callbacks;
185 0           return int(@expired);
186             }
187              
188             sub allocate_sockets {
189 0     0 1   my Net::SIP::NATHelper::Server $self = shift;
190 0   0       my $media = $self->{helper}->allocate_sockets(@_) || return;
191             #$self->_update_callbacks;
192 0           return $media;
193             }
194              
195             sub activate_session {
196 0     0 1   my Net::SIP::NATHelper::Server $self = shift;
197 0 0         my ($info,$duplicate) = $self->{helper}->activate_session(@_)
198             or return;
199 0           $self->_update_callbacks;
200 0 0         return $duplicate ? -1:1;
201             }
202              
203             sub close_session {
204 0     0 1   my Net::SIP::NATHelper::Server $self = shift;
205 0 0         my @info = $self->{helper}->close_session(@_) or return;
206 0           $self->_update_callbacks;
207 0           return scalar(@info);
208             }
209              
210              
211             sub _update_callbacks {
212 0     0     my Net::SIP::NATHelper::Server $self = shift;
213 0           @{ $self->{callbacks} } = ();
  0            
214             }
215              
216             1;