view release on metacpan or  search on metacpan

local/lib/perl5/IO/Async/Loop/Poll.pm  view on Meta::CPAN

   # attempt to fire any waiting timeout events anyway
   $count += $self->_manage_queues;

   alarm( 0 ) if WATCHDOG_ENABLE;

   return $count;
}

=head2 loop_once

   $count = $loop->loop_once( $timeout )

This method calls the C<poll> method on the stored C<IO::Poll> object,
passing in the value of C<$timeout>, and then runs the C<post_poll> method
on itself. It returns the total number of callbacks invoked by the 
C<post_poll> method, or C<undef> if the underlying C<poll> method returned
an error.

=cut

sub loop_once
{
   my $self = shift;
   my ( $timeout ) = @_;

   $self->_adjust_timeout( \$timeout );

   $timeout = 0 if FAKE_ISREG_READY and keys %{ $self->{fake_isreg} };

   # Round up to nearest millisecond
   if( $timeout ) {
      my $mils = $timeout * 1000;
      my $fraction = $mils - int $mils;
      $timeout += ( 1 - $fraction ) / 1000 if $fraction;
   }

   if( my $poll = $self->{poll} ) {
      my $pollret;

      # There is a bug in IO::Poll at least version 0.07, where poll with no
      # registered masks returns immediately, rather than waiting for a timeout
      # This has been reported: 
      #   http://rt.cpan.org/Ticket/Display.html?id=25049
      if( $poll->handles ) {
         $pollret = $poll->poll( $timeout );

         if( ( $pollret == -1 and $! == EINTR ) or $pollret == 0 
                 and defined $self->{sigproxy} ) {
            # A signal occured and we have a sigproxy. Allow one more poll call
            # with zero timeout. If it finds something, keep that result. If it
            # finds nothing, keep -1

            # Preserve $! whatever happens
            local $!;

            my $secondattempt = $poll->poll( 0 );
            $pollret = $secondattempt if $secondattempt > 0;
         }
      }
      else {
         # Workaround - we'll use select to fake a millisecond-accurate sleep
         $pollret = select( undef, undef, undef, $timeout );
      }

      return undef unless defined $pollret;
      return $self->post_poll;
   }
   else {
      my @pollmasks = %{ $self->{pollmask} };

      # Perl 5.8.x's IO::Poll::_poll gets confused with no masks
      my $pollret;
      if( @pollmasks ) {
         my $msec = defined $timeout ? $timeout * 1000 : -1;
         $pollret = IO::Poll::_poll( $msec, @pollmasks );
         if( $pollret == -1 and $! == EINTR or
             $pollret == 0 and $self->{sigproxy} ) {
            local $!;

            @pollmasks = %{ $self->{pollmask} };
            my $secondattempt = IO::Poll::_poll( $msec, @pollmasks );
            $pollret = $secondattempt if $secondattempt > 0;
         }

      }
      else {
         # Workaround - we'll use select to fake a millisecond-accurate sleep
         $pollret = select( undef, undef, undef, $timeout );
      }

      return undef unless defined $pollret;

      $self->{pollevents} = { @pollmasks };
      return $self->post_poll;
   }
}

sub watch_io
{
   my $self = shift;
   my %params = @_;

   $self->__watch_io( %params );

   my $poll = $self->{poll};

   my $handle = $params{handle};
   my $fileno = $handle->fileno;

   my $curmask = $poll ? $poll->mask( $handle )
                       : $self->{pollmask}{$fileno};
   $curmask ||= 0;

   my $mask = $curmask;
   $params{on_read_ready}  and $mask |= POLLIN;
   $params{on_write_ready} and $mask |= POLLOUT | (POLL_CONNECT_POLLPRI ? POLLPRI : 0);
   $params{on_hangup}      and $mask |= POLLHUP;

   if( FAKE_ISREG_READY and S_ISREG +(stat $handle)[2] ) {
      $self->{fake_isreg}{$fileno} = $mask;
   }

   return if $mask == $curmask;

   if( $poll ) {
      $poll->mask( $handle, $mask );
   }
   else {
      $self->{pollmask}{$fileno} = $mask;
   }
}

sub unwatch_io
{
   my $self = shift;
   my %params = @_;

   $self->__unwatch_io( %params );

   my $poll = $self->{poll};

   my $handle = $params{handle};
   my $fileno = $handle->fileno;

   my $curmask = $poll ? $poll->mask( $handle )
                       : $self->{pollmask}{$fileno};
   $curmask ||= 0;