#!/usr/bin/env perl
use
lib
"$FindBin::Bin/lib"
;
LP_EnsureArch::ensure_support(
'timerfd'
);
for
my
$generic_yn
( 0, 1 ) {
if
(
my
$pid
=
fork
) {
waitpid
$pid
, 0;
die
if
$?;
}
else
{
eval
{
my
$class
=
'Linux::Perl::timerfd'
;
if
(!
$generic_yn
) {
$class
= Linux::Perl::ArchLoader::get_arch_module(
$class
);
};
_do_tests(
$class
);
};
die
if
$@;
exit
;
}
}
sub
_do_tests {
my
(
$class
) =
@_
;
note
"Using class: $class (PID $$)"
;
my
$obj
=
$class
->new(
clockid
=>
'MONOTONIC'
);
ok(
$obj
->
fileno
(),
'fileno()'
);
is(
scalar
(
$obj
->settime(
value
=> 0.1,
interval
=> 0.2 ) ),
$obj
,
'scalar-context settime() return'
,
);
my
@old
=
$obj
->settime(
value
=> 0.3,
interval
=> 0.4 );
cmp_deeply(
\
@old
,
[ 0.2, ignore ],
'settime() list return - interval'
,
);
cmp_ok(
$old
[1],
'<='
, 0.1,
'settime() list return - value'
);
my
@cur
=
$obj
->gettime();
cmp_deeply(
\
@cur
,
[ 0.4, ignore ],
'gettime() list return - interval'
,
);
cmp_ok(
$cur
[1],
'<='
, 0.3,
'gettime() list return - value'
);
vec
(
my
$rin
=
q<>
,
$obj
->
fileno
(), 1 ) = 1;
cmp_ok(
$obj
->
read
(),
'>='
, 1,
'read() - blocking'
);
cmp_ok(
$obj
->
read
(),
'>='
, 1,
'read() - blocking (again)'
);
$obj
=
$class
->new(
clockid
=>
'REALTIME'
,
flags
=> [
'NONBLOCK'
],
);
my
$read_val
=
$obj
->
read
();
my
$err
= $!;
is(
$read_val
,
undef
,
'read() - non-blocking'
);
{
local
$! =
$err
;
ok( $!{
'EAGAIN'
},
'... and the error is as expected'
);
}
{
local
$^F = 1000;
my
(
$tfh
,
$tfile
) = File::Temp::tempfile(
CLEANUP
=> 1 );
my
$obj
=
$class
->new(
clockid
=>
'REALTIME'
);
my
$fileno
=
$obj
->
fileno
();
my
$no_cloexec
= `$^X -e
'print readlink "/proc/self/fd/$fileno"'
`;
ok(
$no_cloexec
,
'no CLOEXEC if $^F is set high'
);
$obj
=
$class
->new(
clockid
=>
'REALTIME'
,
flags
=> [
'NONBLOCK'
,
'CLOEXEC'
],
);
$no_cloexec
= `$^X -e
'print readlink "/proc/self/fd/$fileno"'
`;
ok( !
$no_cloexec
,
'CLOEXEC if $^F is high but CLOEXEC is passed'
);
}
SKIP: {
my
$obj
=
$class
->new(
clockid
=>
'REALTIME'
);
$obj
->set_ticks(23) or
do
{
skip
"set_ticks() does not work."
, 1;
};
is(
$obj
->
read
(), 23,
'set_ticks() worked as expected'
);
}
{
my
$obj
=
$class
->new(
clockid
=>
'REALTIME'
,
flags
=> [
'NONBLOCK'
],
)->settime(
value
=> (
time
- 1),
flags
=> [
'ABSTIME'
],
);
vec
(
my
$rin
=
q<>
,
$obj
->
fileno
(), 1 ) = 1;
if
( 0 >=
select
my
$rout
=
$rin
,
undef
,
undef
, 60 ) {
warn
"ABSTIME flag: epoch time of '1' did not make readable??"
;
}
is(
$obj
->
read
(), 1,
'settime() - ABSTIME flag'
);
}
}
done_testing();