view release on metacpan or  search on metacpan

lib/AnyEvent/Loop.pm  view on Meta::CPAN

   my $round; # actual granularity

   if ($time_hires && eval "&Time::HiRes::clock_gettime (Time::HiRes::CLOCK_MONOTONIC ())") {
      AE::log 8 => "Using CLOCK_MONOTONIC as timebase.";
      *_update_clock = sub {
         $NOW  = &Time::HiRes::time;
         $MNOW = Time::HiRes::clock_gettime (&Time::HiRes::CLOCK_MONOTONIC);
      };

   } elsif (100 <= $clk_tck && $clk_tck <= 1000000 && eval { (POSIX::times ())[0] != -1 }) { # -1 is also a valid return value :/
      AE::log 8 => "Using POSIX::times (monotonic) as timebase.";
      my $HZ1 = 1 / $clk_tck;

      my $last = (POSIX::times ())[0];
      my $next;
      *_update_clock = sub {
         $NOW  = time; # d'oh

         $next = (POSIX::times ())[0];
         # we assume 32 bit signed on wrap but 64 bit will never wrap
         $last -= 4294967296 if $last > $next; # 0x100000000, but perl has problems with big hex constants
         $MNOW += ($next - $last) * $HZ1;
         $last = $next;
      };

      $round = $HZ1;

   } elsif (eval "use Time::HiRes (); 1") {
      AE::log 8 => "Using Time::HiRes::time (non-monotonic) clock as timebase.";
      *_update_clock = sub {
         $NOW = $MNOW = &Time::HiRes::time;
      };

   } else {
      AE::log fatal => "Unable to find sub-second time source (is this really perl 5.8.0 or later?)";
   }

   $round = 0.001 if $round < 0.001; # 1ms is enough for us
   $round -= $round * 1e-2; # 0.1 => 0.099
   eval "sub ROUNDUP() { $round }";
}

_update_clock;

# rely on AnyEvent:Base::time to provide time
sub now       () { $NOW          }
sub now_update() { _update_clock }

# fds[0] is for read, fds[1] is for write watchers
# fds[poll][V] is the bitmask for select
# fds[poll][W][fd] contains a list of i/o watchers
# an I/O watcher is a blessed arrayref containing [fh, poll(0/1), callback, queue-index]
# the queue-index is simply the index in the [W] array, which is only used to improve
# benchmark results in the synthetic "many watchers on one fd" benchmark.
my @fds = ([], []);
sub V() { 0 }
sub W() { 1 }

my $need_sort = 1e300; # when to re-sort timer list
my @timer; # list of [ abs-timeout, Timer::[callback] ]
my @idle;  # list of idle callbacks

# the pure perl mainloop
sub one_event {
   _update_clock;

   # first sort timers if required (slow)
   if ($MNOW >= $need_sort) {
      $need_sort = 1e300;
      @timer = sort { $a->[0] <=> $b->[0] } @timer;
   }

   # handle all pending timers
   if (@timer && $timer[0][0] <= $MNOW) {
      do {
         my $timer = shift @timer;
         $timer->[1] && $timer->[1]($timer);
      } while @timer && $timer[0][0] <= $MNOW;

   } else {
      # poll for I/O events, we do not do this when there
      # were any pending timers to ensure that one_event returns
      # quickly when some timers have been handled
      my ($wait, @vec, $fds)
         = (@timer && $timer[0][0] < $need_sort ? $timer[0][0] : $need_sort) - $MNOW;

      $wait = $wait < MAXWAIT ? $wait + ROUNDUP : MAXWAIT;
      $wait = 0 if @idle;

      $fds = CORE::select
        $vec[0] = $fds[0][V],
        $vec[1] = $fds[1][V],
        AnyEvent::WIN32 ? $vec[2] = $fds[1][V] : undef,
        $wait;

      _update_clock;

      if ($fds > 0) {
         # buggy microshit windows errornously sets exceptfds instead of writefds
         $vec[1] |= $vec[2] if AnyEvent::WIN32;

         # prefer write watchers, because they might reduce memory pressure.
         for (1, 0) {
            my $fds = $fds[$_];

            # we parse the bitmask by first expanding it into
            # a string of bits
            for (unpack "b*", $vec[$_]) {
               # and then repeatedly matching a regex against it
               while (/1/g) {
                  # and use the resulting string position as fd
                  $_ && $_->[2]()
                     for @{ $fds->[W][(pos) - 1] || [] };
               }
            }
         }
      } elsif (AnyEvent::WIN32 && $fds && $! == AnyEvent::Util::WSAEINVAL) {
         # buggy microshit windoze asks us to route around it
         CORE::select undef, undef, undef, $wait if $wait;
      } elsif (!@timer || $timer[0][0] > $MNOW && !$fds) {
         $$$_ && $$$_->() for @idle = grep $$$_, @idle;