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   269 use strict;
  43         77  
  43         1194  
8 43     43   195 use warnings;
  43         67  
  43         1518  
9              
10             package Net::SIP::Dispatcher::Eventloop;
11 43     43   192 use fields qw( fd vec just_dropped timer now );
  43         73  
  43         179  
12 43     43   3105 use Time::HiRes qw(gettimeofday);
  43         69  
  43         312  
13 43     43   3714 use Socket;
  43         77  
  43         17967  
14 43     43   273 use List::Util qw(first);
  43         78  
  43         3897  
15 43     43   252 use Net::SIP::Util ':all';
  43         70  
  43         7029  
16 43     43   279 use Net::SIP::Debug;
  43         72  
  43         213  
17 43     43   275 use Carp 'confess';
  43         81  
  43         1856  
18 43     43   224 use Errno 'EINTR';
  43         84  
  43         1527  
19              
20              
21             # constants for read/write events
22 43     43   201 use Exporter 'import';
  43         87  
  43         2074  
23             our @EXPORT = qw(EV_READ EV_WRITE);
24 43     43   328 use constant EV_READ => 0;
  43         123  
  43         3120  
25 43     43   232 use constant EV_WRITE => 1;
  43         115  
  43         48574  
26              
27             ###########################################################################
28             # creates new event loop
29             # Args: $class
30             # Returns: $self
31             ###########################################################################
32             sub new {
33 57     57 1 271 my $class = shift;
34 57         202 my $self = fields::new($class);
35 57         6536 %$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         276 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 166     166 1 472 my Net::SIP::Dispatcher::Eventloop $self = shift;
57 166         753 my ($fd,$rw,$callback,$name) = @_;
58 166 50       555 ref($callback) or confess("wrong usage");
59 166 50       730 defined( my $fn = fileno($fd)) || return;
60             $DEBUG && DEBUG(99, "$self added fn=$fn rw($rw) sock="
61 166 50       629 . eval { ip_sockaddr2string(getsockname($fd)) });
  0         0  
62 166   100     1738 $self->{fd}[$fn][$rw] = [ $fd,$callback,$name || '' ];
63 166         1011 vec($self->{vec}[$rw],$fn,1) = 1;
64 166 50       1007 $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 160     160 1 351 my Net::SIP::Dispatcher::Eventloop $self = shift;
76 160         297 my $fd = shift;
77 160 50 33     1559 defined( my $fn = $fd && fileno($fd)) || return;
78 160 100       976 if (!@_) {
79             $DEBUG && DEBUG(99, "$self delete fn=$fn sock="
80 126 50       307 . eval { ip_sockaddr2string(getsockname($fd)) });
  0         0  
81 126         1160 delete $self->{fd}[$fn];
82 126         506 vec($self->{vec}[0],$fn,1) = 0;
83 126         382 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 34         199 for my $rw (@_) {
90             $DEBUG && DEBUG(99, "$self disable rw($rw) fn=$fn sock="
91 34 50       130 . eval { ip_sockaddr2string(getsockname($fd)) });
  0         0  
92 34         95 delete $self->{fd}[$fn][$rw];
93 34         156 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 34 50       179 $self->{just_dropped}[$fn][$rw] = 1 if $self->{just_dropped};
97             }
98             }
99 160 50       735 $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 348 my Net::SIP::Dispatcher::Eventloop $self = shift;
114 149         744 my ($when,$callback,$repeat,$name ) = @_;
115 149 50       749 $when += $self->{now} if $when < 3600*24*365;
116              
117 149         1724 my $timer = Net::SIP::Dispatcher::Eventloop::TimerEvent->new(
118             $when, $repeat, $callback,$name );
119 149         253 push @{ $self->{timer}}, $timer;
  149         607  
120 149         585 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 410     410 1 1014 my Net::SIP::Dispatcher::Eventloop $self = shift;
130             return $self->{now}
131 410         2563 }
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 434 my Net::SIP::Dispatcher::Eventloop $self = shift;
144 148         452 my ($timeout,@stop) = @_;
145              
146             # looptime for this run
147 148         843 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       581 my $end = $timeout ? $looptime + $timeout : $timeout;
152 148         351 my $to = $timeout;
153              
154 148   100     1104 while ( !$to || $to>0 ) {
155              
156 8437 100       98461 DEBUG( 100, "timeout = ".( defined($to) ? $to: '' ));
157             # handle timers
158 8437         23058 my $timer = $self->{timer};
159              
160 8437         16092 my $do_timer = 1;
161 8437   66     46201 while ( @$timer && $do_timer ) {
162 12204         22181 $do_timer = 0;
163 12204         65252 @$timer = sort { $a->{expire} <=> $b->{expire} } @$timer;
  38671         105629  
164              
165             # delete canceled timers
166 12204   66     58254 shift(@$timer) while ( @$timer && !$timer->[0]{expire} );
167              
168             # run expired timers
169 12204   66     64784 while ( @$timer && $timer->[0]{expire} <= $looptime ) {
170 3804         10163 my $t = shift(@$timer);
171             DEBUG( 50, "trigger timer(%s) %s repeat=%s",
172 3804   50     18207 $t->name,$t->{expire} || '', $t->{repeat} || '' );
      50        
173 3804         28583 invoke_callback( $t->{callback},$t );
174 3804 50 66     35772 if ( $t->{expire} && $t->{repeat} ) {
175 3792         11133 $t->{expire} += $t->{repeat};
176 3792         23150 DEBUG( 100, "timer(%s) gets repeated at %d",$t->name,$t->{expire} );
177 3792         11741 push @$timer,$t;
178 3792         27296 $do_timer = 1; # rerun loop
179             }
180             }
181             }
182              
183             # adjust timeout for select based on when next timer expires
184 8437 50       23491 if ( @$timer ) {
185 8437         18734 my $next_timer = $timer->[0]{expire} - $looptime;
186 8437 100 100     39720 $to = $next_timer if !defined($to) || $to>$next_timer;
187             }
188 8437 50       74350 DEBUG( 100, "timeout = ".( defined($to) ? $to: '' ));
189              
190 8437 100       22867 if ( grep { ${$_} } @stop ) {
  8383         14160  
  8383         32674  
191 122         413 DEBUG( 50, "stopvar triggered" );
192 122         615 return;
193             }
194              
195             # wait for selected fds
196 8315         19164 my $fds = $self->{fd};
197 8315         16215 my @vec = @{$self->{vec}};
  8315         30200  
198 8315 50       20207 $DEBUG && DEBUG(100,"BEFORE read=%s write=%s",
199             unpack("b*",$vec[0]), unpack("b*",$vec[1]));
200 8315         144734211 my $nfound = select($vec[0],$vec[1], undef, $to);
201 8315 50       72317 $DEBUG && DEBUG(100,"AFTER read=%s write=%s nfound=%d",
202             unpack("b*",$vec[0]), unpack("b*",$vec[1]), $nfound);
203 8315 50       31950 if ($nfound<0) {
204 0 0       0 next if $! == EINTR;
205 0         0 die $!
206             };
207              
208 8315         72756 $looptime = $self->{now} = gettimeofday();
209 8315         40368 $self->{just_dropped} = [];
210              
211 8315   100     55914 for(my $i=0; $nfound>0 && $i<@$fds; $i++) {
212 33778 100       111981 next if !$fds->[$i];
213 11142         22802 for my $rw (0,1) {
214 22284 100       84543 vec($vec[$rw],$i,1) or next;
215 5132         11205 $nfound--;
216 5132 100       24133 next if $self->{just_dropped}[$i][$rw];
217 5130 50       14723 $DEBUG && DEBUG(50,"call cb on fn=$i rw=$rw ".$fds->[$i][$rw][2]);
218 5130         11071 invoke_callback(@{ $fds->[$i][$rw] }[1,0]);
  5130         41414  
219             }
220             }
221              
222 8315 100       27971 if ( defined($timeout)) {
223 5736 50       18517 last if !$timeout;
224 5736         54058 $to = $end - $looptime;
225             } else {
226 2579         16923 $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   304 use fields qw( expire repeat callback name );
  43         175  
  43         210  
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   668 my ($class,$expire,$repeat,$callback,$name) = @_;
246 149         494 my $self = fields::new( $class );
247 149 100       11107 unless ( $name ) {
248             # check with caller until I find a function which is not
249             # named 'add_timer'
250 3         9 for( my $i=1;1;$i++ ) {
251 9 50       113 my (undef,undef,undef,$sub) = caller($i) or last;
252 9 100       71 next if $sub =~m{::add_timer$};
253 3         17 my $line = (caller($i-1))[2];
254 3         19 $name = "${sub}[$line]";
255 3         7 last;
256             }
257             }
258 149         755 %$self = (
259             expire => $expire,
260             repeat => $repeat,
261             callback => $callback,
262             name => $name
263             );
264 149         411 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   200 my Net::SIP::Dispatcher::Eventloop::TimerEvent $self = shift;
275 104         223 $self->{expire} = 0;
276 104         644 $self->{callback} = undef;
277             }
278              
279             ##########################################################################
280             # returns name for debugging
281             # Args: $self
282             # Returns: $name
283             ##########################################################################
284             sub name {
285 7596     7596   15338 my Net::SIP::Dispatcher::Eventloop::TimerEvent $self = shift;
286 7596   50     62123 return $self->{name} || 'NONAME'
287             }
288              
289             1;