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