From Code to Community: Sponsoring The Perl and Raku Conference 2025 Learn more

#!/usr/bin/env perl
use strict;
use autodie;
use FindBin;
use lib "$FindBin::Bin/lib";
LP_EnsureArch::ensure_support('timerfd');
use Test::FailWarnings -allow_deps => 1;
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();