our
@EXPORT
=
qw(
run_tests
)
;
use
Fcntl
qw( SEEK_SET )
;
use
POSIX
qw( SIGTERM WIFEXITED WEXITSTATUS WIFSIGNALED WTERMSIG )
;
use
Socket
qw( sockaddr_family AF_UNIX )
;
our
$VERSION
=
'0.59'
;
use
constant
AUT
=>
$ENV
{TEST_QUICK_TIMERS} ? 0.1 : 1;
my
$loop
;
sub
run_tests
{
my
(
$testclass
,
@tests
) =
@_
;
my
$count
= 0;
$count
+= __PACKAGE__->can(
"count_tests_$_"
)->() + 4
for
@tests
;
plan
tests
=>
$count
;
(
my
$file
=
"$testclass.pm"
) =~ s{::}{/}g;
eval
{
require
$file
};
if
( $@ ) {
BAIL_OUT(
"Unable to load $testclass - $@"
);
}
foreach
my
$test
(
@tests
) {
$loop
=
$testclass
->new;
isa_ok(
$loop
,
$testclass
,
'$loop'
);
is( IO::Async::Loop->new,
$loop
,
'magic constructor yields $loop'
);
undef
$IO::Async::Loop::ONE_TRUE_LOOP
;
is_oneref(
$loop
,
'$loop has refcount 1'
);
__PACKAGE__->can(
"run_tests_$test"
)->();
is_oneref(
$loop
,
'$loop has refcount 1 finally'
);
}
}
sub
wait_for(&)
{
IO::Async::Test::testing_loop(
$loop
);
&IO::Async::Test::wait_for
(
@_
);
IO::Async::Test::testing_loop(
undef
);
}
sub
time_between(&$$$)
{
my
(
$code
,
$lower
,
$upper
,
$name
) =
@_
;
my
$start
=
time
;
$code
->();
my
$took
= (
time
-
$start
) / AUT;
cmp_ok(
$took
,
'>='
,
$lower
,
"$name took at least $lower seconds"
)
if
defined
$lower
;
cmp_ok(
$took
,
'<='
,
$upper
* 3,
"$name took no more than $upper seconds"
)
if
defined
$upper
;
if
(
$took
>
$upper
and
$took
<=
$upper
* 3 ) {
diag(
"$name took longer than $upper seconds - this may just be an indication of a busy testing machine rather than a bug"
);
}
}
sub
run_tests_io
{
{
my
(
$S1
,
$S2
) = IO::Async::OS->
socketpair
or
die
"Cannot create socket pair - $!"
;
$_
->blocking( 0 )
for
$S1
,
$S2
;
my
$readready
= 0;
my
$writeready
= 0;
$loop
->watch_io(
handle
=>
$S1
,
on_read_ready
=>
sub
{
$readready
= 1 },
);
is_oneref(
$loop
,
'$loop has refcount 1 after watch_io on_read_ready'
);
is(
$readready
, 0,
'$readready still 0 before ->loop_once'
);
$loop
->loop_once( 0.1 );
is(
$readready
, 0,
'$readready when idle'
);
$S2
->
syswrite
(
"data\n"
);
$loop
->loop_once( 0.1 );
is(
$readready
, 1,
'$readready after loop_once'
);
$S1
->getline;
$loop
->unwatch_io(
handle
=>
$S1
,
on_read_ready
=> 1,
);
$loop
->watch_io(
handle
=>
$S1
,
on_read_ready
=>
sub
{
$readready
= 1 },
);
$readready
= 0;
$S2
->
syswrite
(
"more data\n"
);
$loop
->loop_once( 0.1 );
is(
$readready
, 1,
'$readready after ->unwatch_io/->watch_io'
);
$S1
->getline;
$loop
->watch_io(
handle
=>
$S1
,
on_write_ready
=>
sub
{
$writeready
= 1 },
);
is_oneref(
$loop
,
'$loop has refcount 1 after watch_io on_write_ready'
);
$loop
->loop_once( 0.1 );
is(
$writeready
, 1,
'$writeready after loop_once'
);
$loop
->unwatch_io(
handle
=>
$S1
,
on_write_ready
=> 1,
);
$readready
= 0;
$loop
->loop_once( 0.1 );
is(
$readready
, 0,
'$readready before HUP'
);
$S2
->
close
;
$readready
= 0;
$loop
->loop_once( 0.1 );
is(
$readready
, 1,
'$readready after HUP'
);
$loop
->unwatch_io(
handle
=>
$S1
,
on_read_ready
=> 1,
);
}
{
my
(
$Prd
,
$Pwr
) = IO::Async::OS->pipepair or
die
"Cannot pipepair - $!"
;
$_
->blocking( 0 )
for
$Prd
,
$Pwr
;
my
$readready
= 0;
$loop
->watch_io(
handle
=>
$Prd
,
on_read_ready
=>
sub
{
$readready
= 1 },
);
$loop
->loop_once( 0.1 );
is(
$readready
, 0,
'$readready before pipe HUP'
);
$Pwr
->
close
;
$readready
= 0;
$loop
->loop_once( 0.1 );
is(
$readready
, 1,
'$readready after pipe HUP'
);
$loop
->unwatch_io(
handle
=>
$Prd
,
on_read_ready
=> 1,
);
}
SKIP: {
$loop
->_CAN_ON_HANGUP or skip
"Loop cannot watch_io for on_hangup"
, 2;
SKIP: {
my
(
$S1
,
$S2
) = IO::Async::OS->
socketpair
or
die
"Cannot socketpair - $!"
;
$_
->blocking( 0 )
for
$S1
,
$S2
;
sockaddr_family(
$S1
->sockname ) == AF_UNIX or skip
"Cannot reliably detect hangup condition on non AF_UNIX sockets"
, 1;
my
$hangup
= 0;
$loop
->watch_io(
handle
=>
$S1
,
on_hangup
=>
sub
{
$hangup
= 1 },
);
$S2
->
close
;
$loop
->loop_once( 0.1 );
is(
$hangup
, 1,
'$hangup after socket close'
);
}
my
(
$Prd
,
$Pwr
) = IO::Async::OS->pipepair or
die
"Cannot pipepair - $!"
;
$_
->blocking( 0 )
for
$Prd
,
$Pwr
;
my
$hangup
= 0;
$loop
->watch_io(
handle
=>
$Pwr
,
on_hangup
=>
sub
{
$hangup
= 1 },
);
$Prd
->
close
;
$loop
->loop_once( 0.1 );
is(
$hangup
, 1,
'$hangup after pipe close for writing'
);
}
{
my
(
$S1
,
$S2
) = IO::Async::OS->
socketpair
or
die
"Cannot socketpair - $!"
;
$_
->blocking( 0 )
for
$S1
,
$S2
;
my
$callcount
= 0;
$loop
->watch_io(
handle
=>
$S1
,
on_read_ready
=>
sub
{
$callcount
++;
$loop
->unwatch_io(
handle
=>
$S1
,
on_read_ready
=> 1,
on_write_ready
=> 1 );
},
on_write_ready
=>
sub
{
$callcount
++;
$loop
->unwatch_io(
handle
=>
$S1
,
on_read_ready
=> 1,
on_write_ready
=> 1 );
},
);
$S2
->
close
;
$loop
->loop_once( 0.1 );
is(
$callcount
, 1,
'read/write_ready can cancel each other'
);
}
{
my
(
$S1
,
$S2
) = IO::Async::OS->
socketpair
(
'inet'
,
'dgram'
) or
die
"Cannot create AF_INET/SOCK_DGRAM connected pair - $!"
;
$_
->blocking( 0 )
for
$S1
,
$S2
;
$S2
->
close
;
my
$readready
= 0;
$loop
->watch_io(
handle
=>
$S1
,
on_read_ready
=>
sub
{
$readready
= 1 },
);
$S1
->
syswrite
(
"Boo!"
);
$loop
->loop_once( 0.1 );
is(
$readready
, 1,
'exceptional socket invokes on_read_ready'
);
$loop
->unwatch_io(
handle
=>
$S1
,
on_read_ready
=> 1,
);
}
{
my
$F
= IO::File->new_tmpfile or
die
"Cannot create temporary file - $!"
;
$F
->
print
(
"Here's some content\n"
);
$F
->
seek
( 0, SEEK_SET );
my
$readready
= 0;
my
$writeready
= 0;
$loop
->watch_io(
handle
=>
$F
,
on_read_ready
=>
sub
{
$readready
= 1 },
on_write_ready
=>
sub
{
$writeready
= 1 },
);
$loop
->loop_once( 0.1 );
is(
$readready
, 1,
'regular file is readready'
);
is(
$writeready
, 1,
'regular file is writeready'
);
$loop
->unwatch_io(
handle
=>
$F
,
on_read_ready
=> 1,
on_write_ready
=> 1,
);
}
}
sub
run_tests_timer
{
my
$done
= 0;
cmp_ok(
abs
(
$loop
->
time
-
time
),
"<"
, 0.1,
'$loop->time gives the current time'
);
$loop
->watch_time(
after
=> 2 * AUT,
code
=>
sub
{
$done
= 1; } );
is_oneref(
$loop
,
'$loop has refcount 1 after watch_time'
);
time_between {
my
$now
=
time
;
$loop
->loop_once( 5 * AUT );
while
( !
$done
) {
die
"It should have been ready by now"
if
(
time
-
$now
> 5 * AUT );
$loop
->loop_once( 0.1 * AUT );
}
} 1.5, 2.5,
'loop_once(5) while waiting for watch_time after'
;
$loop
->watch_time(
at
=>
time
+ 2 * AUT,
code
=>
sub
{
$done
= 2; } );
time_between {
my
$now
=
time
;
$loop
->loop_once( 5 * AUT );
while
( !
$done
) {
die
"It should have been ready by now"
if
(
time
-
$now
> 5 * AUT );
$loop
->loop_once( 0.1 * AUT );
}
} 1.5, 2.5,
'loop_once(5) while waiting for watch_time at'
;
my
$cancelled_fired
= 0;
my
$id
=
$loop
->watch_time(
after
=> 1 * AUT,
code
=>
sub
{
$cancelled_fired
= 1 } );
$loop
->unwatch_time(
$id
);
undef
$id
;
$loop
->loop_once( 2 * AUT );
ok( !
$cancelled_fired
,
'unwatched watch_time does not fire'
);
$loop
->watch_time(
after
=> -1,
code
=>
sub
{
$done
= 1 } );
$done
= 0;
time_between {
$loop
->loop_once
while
!
$done
;
} 0, 0.1,
'loop_once while waiting for negative interval timer'
;
{
my
$done
;
my
$id
;
$id
=
$loop
->watch_time(
after
=> 1 * AUT,
code
=>
sub
{
$loop
->unwatch_time(
$id
);
undef
$id
;
});
$loop
->watch_time(
after
=> 1.1 * AUT,
code
=>
sub
{
$done
++;
});
wait_for {
$done
};
is(
$done
, 1,
'Other timers still fire after self-cancelling one'
);
}
$done
= 0;
$loop
->enqueue_timer(
delay
=> 2 * AUT,
code
=>
sub
{
$done
= 1; } );
is_oneref(
$loop
,
'$loop has refcount 1 after enqueue_timer'
);
time_between {
my
$now
=
time
;
$loop
->loop_once( 5 * AUT );
while
( !
$done
) {
die
"It should have been ready by now"
if
(
time
-
$now
> 5 * AUT );
$loop
->loop_once( 0.1 * AUT );
}
} 1.5, 2.5,
'loop_once(5) while waiting for timer'
;
SKIP: {
skip
"Unable to handle sub-second timers accurately"
, 3
unless
$loop
->_CAN_SUBSECOND_ACCURATELY;
foreach
my
$delay
( 0.001, 0.01, 0.1 ) {
my
$done
;
my
$count
= 0;
my
$start
=
time
;
$loop
->enqueue_timer(
delay
=>
$delay
,
code
=>
sub
{
$done
++ } );
while
( !
$done
) {
$loop
->loop_once( 1 );
$count
++;
last
if
time
-
$start
> 5;
}
is(
$count
, 1,
"One ->loop_once(1) sufficient for a single $delay second timer"
);
}
}
$cancelled_fired
= 0;
$id
=
$loop
->enqueue_timer(
delay
=> 1 * AUT,
code
=>
sub
{
$cancelled_fired
= 1 } );
$loop
->cancel_timer(
$id
);
undef
$id
;
$loop
->loop_once( 2 * AUT );
ok( !
$cancelled_fired
,
'cancelled timer does not fire'
);
$id
=
$loop
->enqueue_timer(
delay
=> 1 * AUT,
code
=>
sub
{
$done
= 2; } );
$id
=
$loop
->requeue_timer(
$id
,
delay
=> 2 * AUT );
$done
= 0;
time_between {
$loop
->loop_once( 1 * AUT );
is(
$done
, 0,
'$done still 0 so far'
);
my
$now
=
time
;
$loop
->loop_once( 5 * AUT );
while
( !
$done
) {
die
"It should have been ready by now"
if
(
time
-
$now
> 5 * AUT );
$loop
->loop_once( 0.1 * AUT );
}
} 1.5, 2.5,
'requeued timer of delay 2'
;
is(
$done
, 2,
'$done is 2 after requeued timer'
);
}
sub
run_tests_signal
{
my
$caught
= 0;
$loop
->watch_signal(
TERM
=>
sub
{
$caught
++ } );
is_oneref(
$loop
,
'$loop has refcount 1 after watch_signal'
);
$loop
->loop_once( 0.1 );
is(
$caught
, 0,
'$caught idling'
);
kill
SIGTERM, $$;
is(
$caught
, 0,
'$caught before ->loop_once'
);
$loop
->loop_once( 0.1 );
is(
$caught
, 1,
'$caught after ->loop_once'
);
kill
SIGTERM, $$;
is(
$caught
, 1,
'second raise is still deferred'
);
$loop
->loop_once( 0.1 );
is(
$caught
, 2,
'$caught after second ->loop_once'
);
is_oneref(
$loop
,
'$loop has refcount 1 before unwatch_signal'
);
$loop
->unwatch_signal(
'TERM'
);
is_oneref(
$loop
,
'$loop has refcount 1 after unwatch_signal'
);
my
(
$cA
,
$cB
);
my
$idA
=
$loop
->attach_signal(
TERM
=>
sub
{
$cA
= 1 } );
my
$idB
=
$loop
->attach_signal(
TERM
=>
sub
{
$cB
= 1 } );
is_oneref(
$loop
,
'$loop has refcount 1 after 2 * attach_signal'
);
kill
SIGTERM, $$;
$loop
->loop_once( 0.1 );
is(
$cA
, 1,
'$cA after raise'
);
is(
$cB
, 1,
'$cB after raise'
);
$loop
->detach_signal(
'TERM'
,
$idA
);
undef
$cA
;
undef
$cB
;
kill
SIGTERM, $$;
$loop
->loop_once( 0.1 );
is(
$cA
,
undef
,
'$cA after raise'
);
is(
$cB
, 1,
'$cB after raise'
);
$loop
->detach_signal(
'TERM'
,
$idB
);
ok( exception {
$loop
->attach_signal(
'this signal name does not exist'
,
sub
{} ) },
'Bad signal name fails'
);
}
sub
run_tests_idle
{
my
$called
= 0;
my
$id
=
$loop
->watch_idle(
when
=>
'later'
,
code
=>
sub
{
$called
= 1 } );
ok(
defined
$id
,
'idle watcher id is defined'
);
is(
$called
, 0,
'deferred sub not yet invoked'
);
time_between {
$loop
->loop_once( 3 * AUT ) }
undef
, 1.0,
'loop_once(3) with deferred sub'
;
is(
$called
, 1,
'deferred sub called after loop_once'
);
$loop
->watch_idle(
when
=>
'later'
,
code
=>
sub
{
$loop
->watch_idle(
when
=>
'later'
,
code
=>
sub
{
$called
= 2 } )
} );
$loop
->loop_once( 1 );
is(
$called
, 1,
'inner deferral not yet invoked'
);
$loop
->loop_once( 1 );
is(
$called
, 2,
'inner deferral now invoked'
);
$called
= 2;
$id
=
$loop
->watch_idle(
when
=>
'later'
,
code
=>
sub
{
$called
= 20 } );
$loop
->unwatch_idle(
$id
);
time_between {
$loop
->loop_once( 1 * AUT ) } 0.5, 1.5,
'loop_once(1) with unwatched deferral'
;
is(
$called
, 2,
'unwatched deferral not called'
);
$id
=
$loop
->watch_idle(
when
=>
'later'
,
code
=>
sub
{
$called
= 3 } );
my
$timer_id
=
$loop
->watch_time(
after
=> 5,
code
=>
sub
{} );
$loop
->loop_once( 1 );
is(
$called
, 3,
'$loop->later still invoked with enqueued timer'
);
$loop
->unwatch_time(
$timer_id
);
$loop
->later(
sub
{
$called
= 4 } );
$loop
->loop_once( 1 );
is(
$called
, 4,
'$loop->later shortcut works'
);
}
sub
run_in_child(&)
{
my
$kid
=
fork
;
defined
$kid
or
die
"Cannot fork() - $!"
;
return
$kid
if
$kid
;
shift
->();
die
"Fell out of run_in_child!\n"
;
}
sub
run_tests_child
{
my
$kid
= run_in_child {
exit
( 3 );
};
my
$exitcode
;
$loop
->watch_child(
$kid
=>
sub
{ (
undef
,
$exitcode
) =
@_
; } );
is_oneref(
$loop
,
'$loop has refcount 1 after watch_child'
);
ok( !
defined
$exitcode
,
'$exitcode not defined before ->loop_once'
);
undef
$exitcode
;
wait_for {
defined
$exitcode
};
ok( WIFEXITED(
$exitcode
),
'WIFEXITED($exitcode) after child exit'
);
is( WEXITSTATUS(
$exitcode
), 3,
'WEXITSTATUS($exitcode) after child exit'
);
local
$SIG
{TERM} =
"DEFAULT"
;
$kid
= run_in_child {
sleep
( 10 );
exit
( 0 );
};
$loop
->watch_child(
$kid
=>
sub
{ (
undef
,
$exitcode
) =
@_
; } );
kill
SIGTERM,
$kid
;
undef
$exitcode
;
wait_for {
defined
$exitcode
};
ok( WIFSIGNALED(
$exitcode
),
'WIFSIGNALED($exitcode) after SIGTERM'
);
is( WTERMSIG(
$exitcode
), SIGTERM,
'WTERMSIG($exitcode) after SIGTERM'
);
my
%kids
;
$loop
->watch_child(
0
=>
sub
{
my
(
$kid
) =
@_
;
delete
$kids
{
$kid
} } );
%kids
=
map
{ run_in_child {
exit
0 } => 1 } 1 .. 3;
is(
scalar
keys
%kids
, 3,
'Waiting for 3 child processes'
);
wait_for { !
keys
%kids
};
ok( !
keys
%kids
,
'All child processes reclaimed'
);
}
sub
run_tests_control
{
time_between {
$loop
->loop_once( 0 ) } 0, 0.1,
'loop_once(0) when idle'
;
time_between {
$loop
->loop_once( 2 * AUT ) } 1.5, 2.5,
'loop_once(2) when idle'
;
$loop
->watch_time(
after
=> 0.1,
code
=>
sub
{
$loop
->stop(
result
=>
"here"
) } );
local
$SIG
{ALRM} =
sub
{
die
"Test timed out before ->stop"
};
alarm
( 1 );
my
@result
=
$loop
->run;
alarm
( 0 );
is_deeply( \
@result
, [
result
=>
"here"
],
'->stop arguments returned by ->run'
);
$loop
->watch_time(
after
=> 0.1,
code
=>
sub
{
$loop
->stop(
result
=>
"here"
) } );
my
$result
=
$loop
->run;
is(
$result
,
"result"
,
'First ->stop argument returned by ->run in scalar context'
);
$loop
->watch_time(
after
=> 0.1,
code
=>
sub
{
$loop
->watch_time(
after
=> 0.1,
code
=>
sub
{
$loop
->stop(
"inner"
) } );
my
@result
=
$loop
->run;
$loop
->stop(
@result
,
"outer"
);
} );
@result
=
$loop
->run;
is_deeply( \
@result
, [
"inner"
,
"outer"
],
'->run can be nested properly'
);
$loop
->watch_time(
after
=> 0.1,
code
=>
sub
{
$loop
->loop_stop } );
local
$SIG
{ALRM} =
sub
{
die
"Test timed out before ->loop_stop"
};
alarm
( 1 );
$loop
->loop_forever;
alarm
( 0 );
ok( 1,
'$loop->loop_forever interruptable by ->loop_stop'
);
}
0x55AA;