r40225 - in /branches/upstream/libio-async-loop-epoll-perl: ./ current/ current/lib/ current/lib/IO/ current/lib/IO/Async/ current/lib/IO/Async/Loop/ current/t/

jawnsy-guest at users.alioth.debian.org jawnsy-guest at users.alioth.debian.org
Mon Jul 20 02:39:09 UTC 2009


Author: jawnsy-guest
Date: Mon Jul 20 02:39:02 2009
New Revision: 40225

URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=40225
Log:
[svn-inject] Installing original source of libio-async-loop-epoll-perl

Added:
    branches/upstream/libio-async-loop-epoll-perl/
    branches/upstream/libio-async-loop-epoll-perl/current/
    branches/upstream/libio-async-loop-epoll-perl/current/Build.PL
    branches/upstream/libio-async-loop-epoll-perl/current/Changes
    branches/upstream/libio-async-loop-epoll-perl/current/MANIFEST
    branches/upstream/libio-async-loop-epoll-perl/current/META.yml
    branches/upstream/libio-async-loop-epoll-perl/current/Makefile.PL
    branches/upstream/libio-async-loop-epoll-perl/current/lib/
    branches/upstream/libio-async-loop-epoll-perl/current/lib/IO/
    branches/upstream/libio-async-loop-epoll-perl/current/lib/IO/Async/
    branches/upstream/libio-async-loop-epoll-perl/current/lib/IO/Async/Loop/
    branches/upstream/libio-async-loop-epoll-perl/current/lib/IO/Async/Loop/Epoll.pm
    branches/upstream/libio-async-loop-epoll-perl/current/t/
    branches/upstream/libio-async-loop-epoll-perl/current/t/00use.t
    branches/upstream/libio-async-loop-epoll-perl/current/t/01epoll-io.t
    branches/upstream/libio-async-loop-epoll-perl/current/t/02epoll-sig.t
    branches/upstream/libio-async-loop-epoll-perl/current/t/03epoll-timing.t

Added: branches/upstream/libio-async-loop-epoll-perl/current/Build.PL
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libio-async-loop-epoll-perl/current/Build.PL?rev=40225&op=file
==============================================================================
--- branches/upstream/libio-async-loop-epoll-perl/current/Build.PL (added)
+++ branches/upstream/libio-async-loop-epoll-perl/current/Build.PL Mon Jul 20 02:39:02 2009
@@ -1,0 +1,23 @@
+use strict;
+use warnings;
+
+use Module::Build;
+
+my $build = Module::Build->new
+  (
+   module_name => 'IO::Async::Loop::Epoll',
+   requires => {
+                 'IO::Async'    => '0.20',
+                 'IO::Epoll'    => 0.02,
+               },
+   build_requires => {
+                 'Test::More' => 0,
+                 'Test::Exception' => 0,
+                 'Test::Refcount' => 0,
+                 'Time::HiRes' => 0,
+               },
+   license => 'perl',
+   create_makefile_pl => 'traditional',
+  );
+
+$build->create_build_script;

Added: branches/upstream/libio-async-loop-epoll-perl/current/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libio-async-loop-epoll-perl/current/Changes?rev=40225&op=file
==============================================================================
--- branches/upstream/libio-async-loop-epoll-perl/current/Changes (added)
+++ branches/upstream/libio-async-loop-epoll-perl/current/Changes Mon Jul 20 02:39:02 2009
@@ -1,0 +1,22 @@
+Revision history for IO-Async-Loop-Epoll
+
+0.05    CHANGES:
+         * Added 'use warnings'
+
+        BUGFIXES:
+         * Don't rely on writability of STDOUT during test scripts
+
+0.04    CHANGES:
+         * Updated for IO-Async 0.20
+
+0.03    BUGFIXES:
+         * Better handling of write-only Notifiers
+
+0.02    CHANGES:
+         * Use low-level IO::Epoll interface (epoll_ctl() etc..) instead of
+           high-level IO::Poll-alike object wrapper. Should be better
+           performance, and less buggy - doesn't depend on poor IO::Poll-like
+           emulation details.
+
+0.01    First version, released on an unsuspecting world.
+

Added: branches/upstream/libio-async-loop-epoll-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libio-async-loop-epoll-perl/current/MANIFEST?rev=40225&op=file
==============================================================================
--- branches/upstream/libio-async-loop-epoll-perl/current/MANIFEST (added)
+++ branches/upstream/libio-async-loop-epoll-perl/current/MANIFEST Mon Jul 20 02:39:02 2009
@@ -1,0 +1,10 @@
+Build.PL
+Changes
+lib/IO/Async/Loop/Epoll.pm
+Makefile.PL
+MANIFEST			This list of files
+META.yml
+t/00use.t
+t/01epoll-io.t
+t/02epoll-sig.t
+t/03epoll-timing.t

Added: branches/upstream/libio-async-loop-epoll-perl/current/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libio-async-loop-epoll-perl/current/META.yml?rev=40225&op=file
==============================================================================
--- branches/upstream/libio-async-loop-epoll-perl/current/META.yml (added)
+++ branches/upstream/libio-async-loop-epoll-perl/current/META.yml Mon Jul 20 02:39:02 2009
@@ -1,0 +1,25 @@
+---
+name: IO-Async-Loop-Epoll
+version: 0.05
+author:
+  - 'Paul Evans E<lt>leonerd at leonerd.org.ukE<gt>'
+abstract: a Loop using an C<IO::Epoll> object
+license: perl
+resources:
+  license: http://dev.perl.org/licenses/
+requires:
+  IO::Async: 0.20
+  IO::Epoll: 0.02
+build_requires:
+  Test::Exception: 0
+  Test::More: 0
+  Test::Refcount: 0
+  Time::HiRes: 0
+provides:
+  IO::Async::Loop::Epoll:
+    file: lib/IO/Async/Loop/Epoll.pm
+    version: 0.05
+generated_by: Module::Build version 0.33
+meta-spec:
+  url: http://module-build.sourceforge.net/META-spec-v1.4.html
+  version: 1.4

Added: branches/upstream/libio-async-loop-epoll-perl/current/Makefile.PL
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libio-async-loop-epoll-perl/current/Makefile.PL?rev=40225&op=file
==============================================================================
--- branches/upstream/libio-async-loop-epoll-perl/current/Makefile.PL (added)
+++ branches/upstream/libio-async-loop-epoll-perl/current/Makefile.PL Mon Jul 20 02:39:02 2009
@@ -1,0 +1,19 @@
+# Note: this file was auto-generated by Module::Build::Compat version 0.33
+use ExtUtils::MakeMaker;
+WriteMakefile
+(
+          'NAME' => 'IO::Async::Loop::Epoll',
+          'VERSION_FROM' => 'lib/IO/Async/Loop/Epoll.pm',
+          'PREREQ_PM' => {
+                           'IO::Async' => '0.20',
+                           'IO::Epoll' => '0.02',
+                           'Test::Exception' => 0,
+                           'Test::More' => 0,
+                           'Test::Refcount' => 0,
+                           'Time::HiRes' => 0
+                         },
+          'INSTALLDIRS' => 'site',
+          'EXE_FILES' => [],
+          'PL_FILES' => {}
+        )
+;

Added: branches/upstream/libio-async-loop-epoll-perl/current/lib/IO/Async/Loop/Epoll.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libio-async-loop-epoll-perl/current/lib/IO/Async/Loop/Epoll.pm?rev=40225&op=file
==============================================================================
--- branches/upstream/libio-async-loop-epoll-perl/current/lib/IO/Async/Loop/Epoll.pm (added)
+++ branches/upstream/libio-async-loop-epoll-perl/current/lib/IO/Async/Loop/Epoll.pm Mon Jul 20 02:39:02 2009
@@ -1,0 +1,278 @@
+#  You may distribute under the terms of either the GNU General Public License
+#  or the Artistic License (the same terms as Perl itself)
+#
+#  (C) Paul Evans, 2008,2009 -- leonerd at leonerd.org.uk
+
+package IO::Async::Loop::Epoll;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.05';
+
+use base qw( IO::Async::Loop );
+
+use Carp;
+
+use IO::Epoll qw(
+   epoll_create epoll_ctl epoll_pwait 
+   EPOLL_CTL_ADD EPOLL_CTL_MOD EPOLL_CTL_DEL
+   EPOLLIN EPOLLOUT EPOLLHUP
+);
+
+use POSIX qw( EINTR SIG_BLOCK SIG_UNBLOCK sigprocmask );
+
+=head1 NAME
+
+L<IO::Async::Loop::Epoll> - a Loop using an C<IO::Epoll> object
+
+=head1 SYNOPSIS
+
+ use IO::Async::Loop::Epoll;
+
+ my $loop = IO::Async::Loop::Epoll->new();
+
+ $loop->add( ... );
+
+ $loop->add( IO::Async::Signal->new(
+       name =< 'HUP',
+       on_receipt => sub { ... },
+ ) );
+
+ $loop->loop_forever();
+
+=head1 DESCRIPTION
+
+This subclass of C<IO::Async::Loop> uses C<IO::Epoll> to perform read-ready
+and write-ready tests so that the OZ<>(1) high-performance multiplexing of
+Linux's C<epoll_pwait(2)> syscall can be used.
+
+The C<epoll> Linux subsystem uses a registration system similar to the higher
+level C<IO::Poll> object wrapper, meaning that better performance can be
+achieved in programs using a large number of filehandles. Each
+C<epoll_pwait(2)> syscall only has an overhead proportional to the number of
+ready filehandles, rather than the total number being watched. For more
+detail, see the C<epoll(7)> manpage.
+
+This class uses the C<epoll_pwait(2)> system call, which atomically switches
+the process's signal mask, performs a wait exactly as C<epoll_wait(2)> would,
+then switches it back. This allows a process to block the signals it cares
+about, but switch in an empty signal mask during the poll, allowing it to 
+handle file IO and signals concurrently.
+
+=cut
+
+=head1 CONSTRUCTOR
+
+=cut
+
+=head2 $loop = IO::Async::Loop::Epoll->new()
+
+This function returns a new instance of a C<IO::Async::Loop::Epoll> object.
+
+=cut
+
+sub new
+{
+   my $class = shift;
+   my ( %args ) = @_;
+
+   my $epoll = epoll_create(10); # Just made up 10. Kernel will readjust
+   defined $epoll or croak "Cannot create epoll handle - $!";
+
+   my $self = $class->SUPER::__new( %args );
+
+   $self->{epoll} = $epoll;
+   $self->{sigmask} = POSIX::SigSet->new();
+
+   $self->{restore_SIG} = {};
+
+   return $self;
+}
+
+=head1 METHODS
+
+As this is a subclass of L<IO::Async::Loop>, all of its methods are inherited.
+Expect where noted below, all of the class's methods behave identically to
+C<IO::Async::Loop>.
+
+=cut
+
+sub DESTROY
+{
+   my $self = shift;
+
+   foreach my $signal ( keys %{ $self->{restore_SIG} } ) {
+      $self->unwatch_signal( $signal );
+   }
+}
+
+=head2 $count = $loop->loop_once( $timeout )
+
+This method calls the C<poll()> method on the stored C<IO::Epoll> object,
+passing in the value of C<$timeout>, and processes the results of that call.
+It returns the total number of C<IO::Async::Notifier> callbacks invoked, or
+C<undef> if the underlying C<epoll_pwait()> method returned an error. If the
+C<epoll_pwait()> was interrupted by a signal, then 0 is returned instead.
+
+=cut
+
+sub loop_once
+{
+   my $self = shift;
+   my ( $timeout ) = @_;
+
+   $self->_adjust_timeout( \$timeout );
+
+   my $msec = defined $timeout ? $timeout * 1000 : -1;
+
+   my $ret = epoll_pwait( $self->{epoll}, 20, $msec, $self->{sigmask} );
+
+   return 0 if !$ret and $! == EINTR; # Caught signal
+   return undef if !$ret;             # Some other error
+
+   my $count = 0;
+
+   my $iowatches = $self->{iowatches};
+
+   foreach my $ev ( @$ret ) {
+      my ( $fd, $bits ) = @$ev;
+
+      my $watch = $iowatches->{$fd};
+
+      if( $bits & (EPOLLIN|EPOLLHUP) ) {
+         $watch->[1]->() if $watch->[1];
+         $count++;
+      }
+
+      if( $bits & (EPOLLOUT|EPOLLHUP) ) {
+         $watch->[2]->() if $watch->[2];
+         $count++;
+      }
+   }
+
+   my $timequeue = $self->{timequeue};
+   $count += $timequeue->fire if $timequeue;
+
+   return $count;
+}
+
+# override
+sub watch_io
+{
+   my $self = shift;
+   my %params = @_;
+
+   my $epoll = $self->{epoll};
+
+   $self->__watch_io( %params );
+
+   my $handle = $params{handle};
+   my $fd = $handle->fileno;
+
+   my $curmask = $self->{masks}->{$fd} || 0;
+
+   my $mask = $curmask;
+   $params{on_read_ready}  and $mask |= EPOLLIN;
+   $params{on_write_ready} and $mask |= EPOLLOUT;
+
+   if( !$curmask ) {
+      epoll_ctl( $epoll, EPOLL_CTL_ADD, $fd, $mask ) == 0
+         or carp "Cannot EPOLL_CTL_ADD($fd,$mask) - $!";
+   }
+   elsif( $mask != $curmask ) {
+      epoll_ctl( $epoll, EPOLL_CTL_MOD, $fd, $mask ) == 0
+         or carp "Cannot EPOLL_CTL_MOD($fd,$mask) - $!";
+   }
+
+   $self->{masks}->{$fd} = $mask;
+}
+
+sub unwatch_io
+{
+   my $self = shift;
+   my %params = @_;
+
+   $self->__unwatch_io( %params );
+
+   my $epoll = $self->{epoll};
+
+   my $handle = $params{handle};
+   my $fd = $handle->fileno;
+
+   my $curmask = $self->{masks}->{$fd} or return;
+
+   my $mask = $curmask;
+   $params{on_read_ready}  and $mask &= ~EPOLLIN;
+   $params{on_write_ready} and $mask &= ~EPOLLOUT;
+
+   if( $mask ) {
+      epoll_ctl( $epoll, EPOLL_CTL_MOD, $fd, $mask ) == 0
+         or carp "Cannot EPOLL_CTL_MOD($fd,$mask) - $!";
+      $self->{masks}->{$fd} = $mask;
+   }
+   else {
+      epoll_ctl( $epoll, EPOLL_CTL_DEL, $fd, 0 ) == 0
+         or carp "Cannot EPOLL_CTL_DEL($fd) - $!";
+      delete $self->{masks}->{$fd};
+   }
+}
+
+# override
+sub watch_signal
+{
+   my $self = shift;
+   my ( $signal, $code ) = @_;
+
+   exists $SIG{$signal} or croak "Unrecognised signal name $signal";
+
+   $self->{restore_SIG}->{$signal} = $SIG{$signal};
+
+   my $signum = $self->signame2num( $signal );
+
+   sigprocmask( SIG_BLOCK, POSIX::SigSet->new( $signum ) );
+
+   $SIG{$signal} = $code;
+}
+
+# override
+sub unwatch_signal
+{
+   my $self = shift;
+   my ( $signal ) = @_;
+
+   exists $SIG{$signal} or croak "Unrecognised signal name $signal";
+
+   # When we saved the original value, we might have got an undef. But %SIG
+   # doesn't like having undef assigned back in, so we need to translate
+   $SIG{$signal} = $self->{restore_SIG}->{$signal} || 'DEFAULT';
+
+   delete $self->{restore_SIG}->{$signal};
+   
+   my $signum = $self->signame2num( $signal );
+
+   sigprocmask( SIG_UNBLOCK, POSIX::SigSet->new( $signum ) );
+}
+
+# Keep perl happy; keep Britain tidy
+1;
+
+__END__
+
+=head1 SEE ALSO
+
+=over 4
+
+=item *
+
+L<IO::Epoll> - Scalable IO Multiplexing for Linux 2.5.44 and higher
+
+=item *
+
+L<IO::Async::Loop::IO_Poll> - a Loop using an IO::Poll object 
+
+=back
+
+=head1 AUTHOR
+
+Paul Evans E<lt>leonerd at leonerd.org.ukE<gt>

Added: branches/upstream/libio-async-loop-epoll-perl/current/t/00use.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libio-async-loop-epoll-perl/current/t/00use.t?rev=40225&op=file
==============================================================================
--- branches/upstream/libio-async-loop-epoll-perl/current/t/00use.t (added)
+++ branches/upstream/libio-async-loop-epoll-perl/current/t/00use.t Mon Jul 20 02:39:02 2009
@@ -1,0 +1,6 @@
+#!/usr/bin/perl -w
+
+use strict;
+use Test::More tests => 1;
+
+use_ok( "IO::Async::Loop::Epoll" );

Added: branches/upstream/libio-async-loop-epoll-perl/current/t/01epoll-io.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libio-async-loop-epoll-perl/current/t/01epoll-io.t?rev=40225&op=file
==============================================================================
--- branches/upstream/libio-async-loop-epoll-perl/current/t/01epoll-io.t (added)
+++ branches/upstream/libio-async-loop-epoll-perl/current/t/01epoll-io.t Mon Jul 20 02:39:02 2009
@@ -1,0 +1,118 @@
+#!/usr/bin/perl -w
+
+use strict;
+
+use Test::More tests => 9;
+use Test::Exception;
+
+use IO::Async::Loop::Epoll;
+
+my $loop = IO::Async::Loop::Epoll->new();
+
+ok( defined $loop, '$loop defined' );
+isa_ok( $loop, "IO::Async::Loop::Epoll", '$loop isa IO::Async::Loop::Epoll' );
+
+my ( $S1, $S2 ) = $loop->socketpair() or die "Cannot create socket pair - $!";
+
+# Need sockets in nonblocking mode
+$S1->blocking( 0 );
+$S2->blocking( 0 );
+
+my $readready = 0;
+
+$loop->watch_io(
+   handle => $S1,
+   on_read_ready  => sub { $readready = 1 },
+);
+
+$S2->syswrite( "data\n" );
+
+# We should still wait a little while even thought we expect to be ready
+# immediately, because talking to ourself with 0 poll timeout is a race
+# condition - we can still race with the kernel.
+
+$loop->loop_once( 0.1 );
+
+is( $readready, 1, '$readready after loop_once' );
+
+# Ready $S1 to clear the data
+$S1->getline(); # ignore return
+
+# Write-ready
+
+my $writeready = 0;
+
+$loop->watch_io(
+   handle => $S1,
+   on_write_ready => sub { $writeready = 1 },
+);
+
+$loop->loop_once( 0.1 );
+
+is( $writeready, 1, '$writeready after loop_once' );
+
+# loop_forever
+
+$loop->watch_io(
+   handle => $S2,
+   on_write_ready => sub { $loop->loop_stop() },
+);
+
+$writeready = 0;
+
+$SIG{ALRM} = sub { die "Test timed out"; };
+alarm( 1 );
+
+$loop->loop_forever();
+
+alarm( 0 );
+
+is( $writeready, 1, '$writeready after loop_forever' );
+
+$loop->unwatch_io(
+   handle => $S2,
+   on_write_ready => 1,
+);
+
+$readready = 0;
+$loop->loop_once( 0.1 );
+
+is( $readready, 0, '$readready before HUP' );
+
+close( $S2 );
+
+$readready = 0;
+$loop->loop_once( 0.1 );
+
+is( $readready, 1, '$readready after HUP' );
+
+$loop->unwatch_io(
+   handle => $S1,
+   on_read_ready => 1,
+);
+
+# HUP of pipe
+
+my ( $P1, $P2 ) = $loop->pipepair() or die "Cannot pipepair - $!";
+
+$loop->watch_io(
+   handle => $P1,
+   on_read_ready => sub { $readready = 1 },
+);
+
+$readready = 0;
+$loop->loop_once( 0.1 );
+
+is( $readready, 0, '$readready before pipe HUP' );
+
+close( $P2 );
+
+$readready = 0;
+$loop->loop_once( 0.1 );
+
+is( $readready, 1, '$readready after pipe HUP' );
+
+$loop->unwatch_io(
+   handle => $P1,
+   on_read_ready => 1,
+);

Added: branches/upstream/libio-async-loop-epoll-perl/current/t/02epoll-sig.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libio-async-loop-epoll-perl/current/t/02epoll-sig.t?rev=40225&op=file
==============================================================================
--- branches/upstream/libio-async-loop-epoll-perl/current/t/02epoll-sig.t (added)
+++ branches/upstream/libio-async-loop-epoll-perl/current/t/02epoll-sig.t Mon Jul 20 02:39:02 2009
@@ -1,0 +1,32 @@
+#!/usr/bin/perl -w
+
+use strict;
+
+use Test::More tests => 6;
+
+use POSIX qw( SIGHUP );
+
+use IO::Async::Loop::Epoll;
+
+my $loop = IO::Async::Loop::Epoll->new();
+
+is( $SIG{HUP}, undef, '$SIG{HUP} default before watch' );
+
+my $SIGHUP_count = 0;
+$loop->watch_signal( HUP => sub { $SIGHUP_count++ } );
+
+ok( defined $SIG{HUP}, '$SIG{HUP} defined after watch' );
+
+kill SIGHUP, $$;
+
+is( $SIGHUP_count, 0, 'Not caught SIGHUP before loop_once' );
+
+my $count = $loop->loop_once( 0.1 );
+
+is( $count, 0, '$count is 0 after loop_once' );
+
+is( $SIGHUP_count, 1, 'Caught SIGHUP after loop_once' );
+
+undef $loop;
+
+is( $SIG{HUP}, 'DEFAULT', '$SIG{HUP} restored after $loop unref' );

Added: branches/upstream/libio-async-loop-epoll-perl/current/t/03epoll-timing.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libio-async-loop-epoll-perl/current/t/03epoll-timing.t?rev=40225&op=file
==============================================================================
--- branches/upstream/libio-async-loop-epoll-perl/current/t/03epoll-timing.t (added)
+++ branches/upstream/libio-async-loop-epoll-perl/current/t/03epoll-timing.t Mon Jul 20 02:39:02 2009
@@ -1,0 +1,98 @@
+#!/usr/bin/perl -w
+
+use strict;
+
+use Test::More tests => 8;
+
+use Time::HiRes qw( time );
+
+use IO::Async::Loop::Epoll;
+
+my $loop = IO::Async::Loop::Epoll->new();
+
+my ( $S1, $S2 ) = $loop->socketpair() or die "Cannot create socket pair - $!";
+
+# loop_once
+
+my ( $now, $took );
+
+$now = time;
+$loop->loop_once( 2 );
+$took = time - $now;
+
+cmp_ok( $took, '>', 1.9, 'loop_once(2) while idle takes at least 1.9 seconds' );
+cmp_ok( $took, '<', 10, 'loop_once(2) while idle takes no more than 10 seconds' );
+if( $took > 2.5 ) {
+   diag( "loop_once(2) while idle took more than 2.5 seconds.\n" .
+         "This is not itself a bug, and may just be an indication of a busy testing machine" );
+}
+
+$loop->watch_io( handle => $S1,
+   on_read_ready => sub { "DUMMY" },
+);
+
+$now = time;
+$loop->loop_once( 2 );
+$took = time - $now;
+
+cmp_ok( $took, '>', 1.9, 'loop_once(2) while waiting takes at least 1.9 seconds' );
+cmp_ok( $took, '<', 10, 'loop_once(2) while waiting takes no more than 10 seconds' );
+if( $took > 2.5 ) {
+   diag( "loop_once(2) while waiting took more than 2.5 seconds.\n" .
+         "This is not itself a bug, and may just be an indication of a busy testing machine" );
+}
+
+$loop->unwatch_io( handle => $S1,
+   on_read_ready => 1,
+);
+
+# timers
+
+my $done = 0;
+
+$loop->enqueue_timer( delay => 2, code => sub { $done = 1; } );
+
+my $id = $loop->enqueue_timer( delay => 3, code => sub { die "This timer should have been cancelled" } );
+$loop->cancel_timer( $id );
+
+undef $id;
+
+$now = time;
+
+$loop->loop_once( 5 );
+
+# poll() might have returned just a little early, such that the TimerQueue
+# doesn't think anything is ready yet. We need to handle that case.
+while( !$done ) {
+   die "It should have been ready by now" if( time - $now > 5 );
+   $loop->loop_once( 0.1 );
+}
+
+$took = time - $now;
+
+cmp_ok( $took, '>', 1.9, 'loop_once(5) while waiting for timer takes at least 1.9 seconds' );
+cmp_ok( $took, '<', 10, 'loop_once(5) while waiting for timer no more than 10 seconds' );
+if( $took > 2.5 ) {
+   diag( "loop_once(2) while waiting for timer took more than 2.5 seconds.\n" .
+         "This is not itself a bug, and may just be an indication of a busy testing machine" );
+}
+
+$id = $loop->enqueue_timer( delay => 1, code => sub { $done = 2; } );
+$id = $loop->requeue_timer( $id, delay => 2 );
+
+$done = 0;
+
+$loop->loop_once( 1 );
+
+is( $done, 0, '$done still 0 so far' );
+
+$loop->loop_once( 5 );
+
+# poll() might have returned just a little early, such that the TimerQueue
+# doesn't think anything is ready yet. We need to handle that case.
+while( !$done ) {
+   die "It should have been ready by now" if( time - $now > 5 );
+   $loop->loop_once( 0.1 );
+}
+
+is( $done, 2, '$done is 2 after requeued timer' );




More information about the Pkg-perl-cvs-commits mailing list