File Coverage

blib/lib/Net/SIP/Dispatcher/Eventloop.pm
Criterion Covered Total %
statement 148 155 95.4
branch 42 64 65.6
condition 23 32 71.8
subroutine 23 23 100.0
pod 6 6 100.0
total 242 280 86.4


line stmt bran cond sub pod time code
1              
2             ###########################################################################
3             # package Net::SIP::Dispatcher::Eventloop
4             # simple event loop for Net::SIP
5             ###########################################################################
6              
7 43     43   262 use strict;
  43         80  
  43         1184  
8 43     43   564 use warnings;
  43         73  
  43         1657  
9              
10             package Net::SIP::Dispatcher::Eventloop;
11 43     43   196 use fields qw( fd vec just_dropped timer now );
  43         73  
  43         176  
12 43     43   2954 use Time::HiRes qw(gettimeofday);
  43         76  
  43         320  
13 43     43   3823 use Socket;
  43         70  
  43         19653  
14 43     43   279 use List::Util qw(first);
  43         71  
  43         3757  
15 43     43   248 use Net::SIP::Util ':all';
  43         61  
  43         7174  
16 43     43   284 use Net::SIP::Debug;
  43         73  
  43         250  
17 43     43   280 use Carp 'confess';
  43         72  
  43         1771  
18 43     43   211 use Errno 'EINTR';
  43         72  
  43         1590  
19              
20              
21             # constants for read/write events
22 43     43   204 use Exporter 'import';
  43         76  
  43         2059  
23             our @EXPORT = qw(EV_READ EV_WRITE);
24 43     43   265 use constant EV_READ => 0;
  43         119  
  43         3213  
25 43     43   276 use constant EV_WRITE => 1;
  43         118  
  43         48924  
26              
27             ###########################################################################
28             # creates new event loop
29             # Args: $class
30             # Returns: $self
31             ###########################################################################
32             sub new {
33 57     57 1 301 my $class = shift;
34 57         190 my $self = fields::new($class);
35 57         7335 %$self = (
36             fd => [], # {fd}[fn][rw] -> [fd,callback,name]
37             vec => [ '','' ], # read|write vec(..) for select
38             just_dropped => undef, # dropped fn inside current select
39             timer => [], # list of TimerEvent objects
40             now => scalar(gettimeofday()), # time after select
41             );
42 57         293 return $self;
43             }
44              
45             ###########################################################################
46             # adds callback for the event, that FD is readable
47             # Args: ($self,$fd,$rw,$callback,?$name)
48             # $fd: file descriptor
49             # $rw: if the callback is for read(0) or write(1)
50             # $callback: callback to be called, when fd is readable, will be called
51             # with fd as argument
52             # $name: optional name for callback, used for debugging
53             # Returns: NONE
54             ###########################################################################
55             sub addFD {
56 165     165 1 446 my Net::SIP::Dispatcher::Eventloop $self = shift;
57 165         676 my ($fd,$rw,$callback,$name) = @_;
58 165 50       755 ref($callback) or confess("wrong usage");
59 165 50       711 defined( my $fn = fileno($fd)) || return;
60             $DEBUG && DEBUG(99, "$self added fn=$fn rw($rw) sock="
61 165 50       637 . eval { ip_sockaddr2string(getsockname($fd)) });
  0         0  
62 165   100     1699 $self->{fd}[$fn][$rw] = [ $fd,$callback,$name || '' ];
63 165         959 vec($self->{vec}[$rw],$fn,1) = 1;
64 165 50       1098 $DEBUG && DEBUG(100, "maxfd=%d",0+@{$self->{fd}});
  0         0  
65             }
66              
67             ###########################################################################
68             # removes callback for readable for FD
69             # Args: ($self,$fd,?$rw)
70             # $fd: file descriptor
71             # $rw: if disable for read(0) or write(1). Disables both if not given
72             # Returns: NONE
73             ###########################################################################
74             sub delFD {
75 159     159 1 480 my Net::SIP::Dispatcher::Eventloop $self = shift;
76 159         253 my $fd = shift;
77 159 50 33     2242 defined( my $fn = $fd && fileno($fd)) || return;
78 159 100       843 if (!@_) {
79             $DEBUG && DEBUG(99, "$self delete fn=$fn sock="
80 126 50       432 . eval { ip_sockaddr2string(getsockname($fd)) });
  0         0  
81 126         1174 delete $self->{fd}[$fn];
82 126         703 vec($self->{vec}[0],$fn,1) = 0;
83 126         444 vec($self->{vec}[1],$fn,1) = 0;
84             # mark both read and write as dropped so we don't process events for the
85             # fd inside the same loop
86 126 50       525 $self->{just_dropped}[$fn] = [1,1] if $self->{just_dropped};
87              
88             } else {
89 33         226 for my $rw (@_) {
90             $DEBUG && DEBUG(99, "$self disable rw($rw) fn=$fn sock="
91 33 50       98 . eval { ip_sockaddr2string(getsockname($fd)) });
  0         0  
92 33         141 delete $self->{fd}[$fn][$rw];
93 33         169 vec($self->{vec}[$rw],$fn,1) = 0;
94             # mark $rw handler as dropped so we don't process events for the fd
95             # inside the same loop
96 33 50       175 $self->{just_dropped}[$fn][$rw] = 1 if $self->{just_dropped};
97             }
98             }
99 159 50       686 $DEBUG && DEBUG(100, "maxfd=%d",0+@{$self->{fd}});
  0         0  
100             }
101              
102             ###########################################################################
103             # add timer
104             # Args: ($self,$when,$callback;$repeat,$name)
105             # $when: absolute time_t or relative (smaller than a year), can be
106             # subsecond resolution
107             # $callback: callback to be called, gets timer object as argument
108             # $repeat: interval for repeated callbacks, optional
109             # $name: optional name for debugging
110             # Returns: $timer object
111             ###########################################################################
112             sub add_timer {
113 149     149 1 424 my Net::SIP::Dispatcher::Eventloop $self = shift;
114 149         893 my ($when,$callback,$repeat,$name ) = @_;
115 149 50       751 $when += $self->{now} if $when < 3600*24*365;
116              
117 149         1784 my $timer = Net::SIP::Dispatcher::Eventloop::TimerEvent->new(
118             $when, $repeat, $callback,$name );
119 149         250 push @{ $self->{timer}}, $timer;
  149         575  
120 149         502 return $timer;
121             }
122              
123             ###########################################################################
124             # return time of currentloop, e.g. when select(2) returned
125             # Args: ()
126             # Returns: time
127             ###########################################################################
128             sub looptime {
129 412     412 1 1103 my Net::SIP::Dispatcher::Eventloop $self = shift;
130             return $self->{now}
131 412         2995 }
132              
133              
134             ###########################################################################
135             # simple mainloop
136             # Args: ($self;$timeout,@stop)
137             # $timeout: if 0 just poll once, if undef never return, otherwise return
138             # after $timeout seconds
139             # @stop: \@array of Scalar-REF, if one gets true the eventloop will be stopped
140             # Returns: NONE
141             ###########################################################################
142             sub loop {
143 148     148 1 431 my Net::SIP::Dispatcher::Eventloop $self = shift;
144 148         442 my ($timeout,@stop) = @_;
145              
146             # looptime for this run
147 148         669 my $looptime = $self->{now} = gettimeofday();
148              
149             # if timeout defined and != 0 set $end to now+timeout
150             # otherwise set end to undef|0 depending on timeout
151 148 100       841 my $end = $timeout ? $looptime + $timeout : $timeout;
152 148         378 my $to = $timeout;
153              
154 148   100     1460 while ( !$to || $to>0 ) {
155              
156 7408 100       96045 DEBUG( 100, "timeout = ".( defined($to) ? $to: '' ));
157             # handle timers
158 7408         23267 my $timer = $self->{timer};
159              
160 7408         14268 my $do_timer = 1;
161 7408   66     47179 while ( @$timer && $do_timer ) {
162 11172         37088 $do_timer = 0;
163 11172         56094 @$timer = sort { $a->{expire} <=> $b->{expire} } @$timer;
  35510         115012  
164              
165             # delete canceled timers
166 11172   66     59272 shift(@$timer) while ( @$timer && !$timer->[0]{expire} );
167              
168             # run expired timers
169 11172   66     87190 while ( @$timer && $timer->[0]{expire} <= $looptime ) {
170 3809         11284 my $t = shift(@$timer);
171             DEBUG( 50, "trigger timer(%s) %s repeat=%s",
172 3809   50     18036 $t->name,$t->{expire} || '', $t->{repeat} || '' );
      50        
173 3809         22704 invoke_callback( $t->{callback},$t );
174 3809 50 66     42501 if ( $t->{expire} && $t->{repeat} ) {
175 3797         15451 $t->{expire} += $t->{repeat};
176 3797         15234 DEBUG( 100, "timer(%s) gets repeated at %d",$t->name,$t->{expire} );
177 3797         9457 push @$timer,$t;
178 3797         29989 $do_timer = 1; # rerun loop
179             }
180             }
181             }
182              
183             # adjust timeout for select based on when next timer expires
184 7408 50       22513 if ( @$timer ) {
185 7408         17569 my $next_timer = $timer->[0]{expire} - $looptime;
186 7408 100 100     35027 $to = $next_timer if !defined($to) || $to>$next_timer;
187             }
188 7408 50       82629 DEBUG( 100, "timeout = ".( defined($to) ? $to: '' ));
189              
190 7408 100       19251 if ( grep { ${$_} } @stop ) {
  7355         13724  
  7355         30847  
191 122         364 DEBUG( 50, "stopvar triggered" );
192 122         871 return;
193             }
194              
195             # wait for selected fds
196 7286         19577 my $fds = $self->{fd};
197 7286         13137 my @vec = @{$self->{vec}};
  7286         23792  
198 7286 50       30581 $DEBUG && DEBUG(100,"BEFORE read=%s write=%s",
199             unpack("b*",$vec[0]), unpack("b*",$vec[1]));
200 7286         141247359 my $nfound = select($vec[0],$vec[1], undef, $to);
201 7286 50       68986 $DEBUG && DEBUG(100,"AFTER read=%s write=%s nfound=%d",
202             unpack("b*",$vec[0]), unpack("b*",$vec[1]), $nfound);
203 7286 50       33315 if ($nfound<0) {
204 0 0       0 next if $! == EINTR;
205 0         0 die $!
206             };
207              
208 7286         59664 $looptime = $self->{now} = gettimeofday();
209 7286         47860 $self->{just_dropped} = [];
210              
211 7286   100     48334 for(my $i=0; $nfound>0 && $i<@$fds; $i++) {
212 30802 100       120031 next if !$fds->[$i];
213 10114         23076 for my $rw (0,1) {
214 20228 100       77749 vec($vec[$rw],$i,1) or next;
215 4667         13097 $nfound--;
216 4667 100       26532 next if $self->{just_dropped}[$i][$rw];
217 4665 50       12981 $DEBUG && DEBUG(50,"call cb on fn=$i rw=$rw ".$fds->[$i][$rw][2]);
218 4665         11812 invoke_callback(@{ $fds->[$i][$rw] }[1,0]);
  4665         33590  
219             }
220             }
221              
222 7286 100       24279 if ( defined($timeout)) {
223 4880 50       17253 last if !$timeout;
224 4880         61583 $to = $end - $looptime;
225             } else {
226 2406         16777 $to = undef
227             }
228             }
229             }
230              
231              
232             ##########################################################################
233             # Timer object which gets returned from add_timer and has method for
234             # canceling the timer (by setting expire to 0)
235             ##########################################################################
236             package Net::SIP::Dispatcher::Eventloop::TimerEvent;
237 43     43   298 use fields qw( expire repeat callback name );
  43         114  
  43         173  
238              
239             ##########################################################################
240             # create new timer object, see add_timer for description of Args
241             # Args: ($class,$expire,$repeat,$callback)
242             # Returns: $self
243             ##########################################################################
244             sub new {
245 149     149   682 my ($class,$expire,$repeat,$callback,$name) = @_;
246 149         468 my $self = fields::new( $class );
247 149 100       11209 unless ( $name ) {
248             # check with caller until I find a function which is not
249             # named 'add_timer'
250 3         7 for( my $i=1;1;$i++ ) {
251 9 50       124 my (undef,undef,undef,$sub) = caller($i) or last;
252 9 100       64 next if $sub =~m{::add_timer$};
253 3         16 my $line = (caller($i-1))[2];
254 3         11 $name = "${sub}[$line]";
255 3         7 last;
256             }
257             }
258 149         754 %$self = (
259             expire => $expire,
260             repeat => $repeat,
261             callback => $callback,
262             name => $name
263             );
264 149         416 return $self;
265             }
266              
267             ##########################################################################
268             # cancel timer by setting expire to 0, it will be deleted next time
269             # the timer queue is scanned in loop
270             # Args: $self
271             # Returns: NONE
272             ##########################################################################
273             sub cancel {
274 104     104   364 my Net::SIP::Dispatcher::Eventloop::TimerEvent $self = shift;
275 104         230 $self->{expire} = 0;
276 104         656 $self->{callback} = undef;
277             }
278              
279             ##########################################################################
280             # returns name for debugging
281             # Args: $self
282             # Returns: $name
283             ##########################################################################
284             sub name {
285 7606     7606   15450 my Net::SIP::Dispatcher::Eventloop::TimerEvent $self = shift;
286 7606   50     59104 return $self->{name} || 'NONAME'
287             }
288              
289             1;