########################################################################### # package Net::SIP::Dispatcher::Eventloop # simple event loop for Net::SIP ########################################################################### use strict; use warnings; package Net::SIP::Dispatcher::Eventloop; use fields qw( fd timer now ); use Time::HiRes qw(gettimeofday); use Socket; use List::Util qw(first); use Net::SIP::Util 'invoke_callback'; use Net::SIP::Debug; use Errno 'EINTR'; ########################################################################### # creates new event loop # Args: $class # Returns: $self ########################################################################### sub new { my $class = shift; my $self = fields::new($class); %$self = ( fd => [], timer => [], now => scalar(gettimeofday()), ); return $self; } ########################################################################### # adds callback for the event, that FD is readable # Args: ($self,$fd,$callback,?$name) # $fd: file descriptor # $callback: callback to be called, when fd is readable, will be called # with fd as argument # $name: optional name for callback, used for debugging # Returns: NONE ########################################################################### sub addFD { my Net::SIP::Dispatcher::Eventloop $self = shift; my ($fd,$callback,$name) = @_; defined( my $fn = fileno($fd)) || return; #DEBUG( 100, "$self added fn=$fn sock=".eval { my ($port,$addr) = unpack_sockaddr_in( getsockname($fd)); inet_ntoa($addr).':'.$port } ); $self->{fd}[$fn] = [ $fd,$callback,$name ]; } ########################################################################### # removes callback for readable for FD # Args: ($self,$fd) # $fd: file descriptor # Returns: NONE ########################################################################### sub delFD { my Net::SIP::Dispatcher::Eventloop $self = shift; my ($fd) = @_; defined( my $fn = fileno($fd)) || return; #DEBUG( 100, "$self delete fn=$fn sock=".eval { my ($port,$addr) = unpack_sockaddr_in( getsockname($fd)); inet_ntoa($addr).':'.$port } ); delete $self->{fd}[$fn]; } ########################################################################### # add timer # Args: ($self,$when,$callback;$repeat,$name) # $when: absolute time_t or relative (smaller than a year), can be # subsecond resolution # $callback: callback to be called, gets timer object as argument # $repeat: interval for repeated callbacks, optional # $name: optional name for debugging # Returns: $timer object ########################################################################### sub add_timer { my Net::SIP::Dispatcher::Eventloop $self = shift; my ($when,$callback,$repeat,$name ) = @_; $when += $self->{now} if $when < 3600*24*365; my $timer = Net::SIP::Dispatcher::Eventloop::TimerEvent->new( $when, $repeat, $callback,$name ); push @{ $self->{timer}}, $timer; return $timer; } ########################################################################### # return time of currentloop, e.g. when select(2) returned # Args: () # Returns: time ########################################################################### sub looptime { my Net::SIP::Dispatcher::Eventloop $self = shift; return $self->{now} } ########################################################################### # simple mainloop # Args: ($self;$timeout,@stop) # $timeout: if 0 just poll once, if undef never return, otherwise return # after $timeout seconds # @stop: \@array of Scalar-REF, if one gets true the eventloop will be stopped # Returns: NONE ########################################################################### sub loop { my Net::SIP::Dispatcher::Eventloop $self = shift; my ($timeout,@stop) = @_; # looptime for this run my $looptime = $self->{now} = gettimeofday(); # if timeout defined and != 0 set $end to now+timeout # otherwise set end to undef|0 depending on timeout my $end = $timeout ? $looptime + $timeout : $timeout; my $to = $timeout; while ( !$to || $to>0 ) { DEBUG( 100, "timeout = ".( defined($to) ? $to: '<undef>' )); # handle timers my $timer = $self->{timer}; my $do_timer = 1; while ( @$timer && $do_timer ) { $do_timer = 0; @$timer = sort { $a->{expire} <=> $b->{expire} } @$timer; # delete canceled timers shift(@$timer) while ( @$timer && !$timer->[0]{expire} ); # run expired timers while ( @$timer && $timer->[0]{expire} <= $looptime ) { my $t = shift(@$timer); DEBUG( 50, "trigger timer(%s) %s repeat=%s", $t->name,$t->{expire} || '<undef>', $t->{repeat} || '<undef>' ); invoke_callback( $t->{callback},$t ); if ( $t->{expire} && $t->{repeat} ) { $t->{expire} += $t->{repeat}; DEBUG( 100, "timer(%s) gets repeated at %d",$t->name,$t->{expire} ); push @$timer,$t; $do_timer = 1; # rerun loop } } } # adjust timeout for select based on when next timer expires if ( @$timer ) { my $next_timer = $timer->[0]{expire} - $looptime; $to = $next_timer if !defined($to) || $to>$next_timer; } DEBUG( 100, "timeout = ".( defined($to) ? $to: '<undef>' )); if ( grep { ${$_} } @stop ) { DEBUG( 50, "stopvar triggered" ); return; } # wait for selected fds my $fds = $self->{fd}; my $rin; if ( my @to_read = grep { $_ } @$fds ) { # Select which fds are readable or timeout my $rin = ''; map { vec( $rin,fileno($_->[0]),1 ) = 1 } @to_read; DEBUG( 100, "handles=".join( " ",map { fileno($_->[0]) } @to_read )); 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))); for( my $fn=0;$fn<@$fds;$fn++ ) { vec($rout,$fn,1) or next; my $fd_data = $fds->[$fn] or next; DEBUG( 50,"call cb on fn=$fn ".( $fd_data->[2] || '') ); invoke_callback( $fd_data->[1],$fd_data->[0] ); } } else { DEBUG( 50, "no handles, sleeping for %s", defined($to) ? $to : '<endless>' ); select(undef,undef,undef,$to ) } if ( defined($timeout)) { last if !$timeout; $to = $end - $looptime; } else { $to = undef } } } ########################################################################## # Timer object which gets returned from add_timer and has method for # canceling the timer (by setting expire to 0) ########################################################################## package Net::SIP::Dispatcher::Eventloop::TimerEvent; use fields qw( expire repeat callback name ); ########################################################################## # create new timer object, see add_timer for description of Args # Args: ($class,$expire,$repeat,$callback) # Returns: $self ########################################################################## sub new { my ($class,$expire,$repeat,$callback,$name) = @_; my $self = fields::new( $class ); unless ( $name ) { # check with caller until I find a function which is not # named 'add_timer' for( my $i=1;1;$i++ ) { my (undef,undef,undef,$sub) = caller($i) or last; next if $sub =~m{::add_timer$}; my $line = (caller($i-1))[2]; $name = "${sub}[$line]"; last; } } %$self = ( expire => $expire, repeat => $repeat, callback => $callback, name => $name ); return $self; } ########################################################################## # cancel timer by setting expire to 0, it will be deleted next time # the timer queue is scanned in loop # Args: $self # Returns: NONE ########################################################################## sub cancel { my Net::SIP::Dispatcher::Eventloop::TimerEvent $self = shift; $self->{expire} = 0; $self->{callback} = undef; } ########################################################################## # returns name for debugging # Args: $self # Returns: $name ########################################################################## sub name { my Net::SIP::Dispatcher::Eventloop::TimerEvent $self = shift; return $self->{name} || 'NONAME' } 1;