The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
use strict;

BEGIN {
    require Time::HiRes;
    unless(&Time::HiRes::d_ualarm) {
	require Test::More;
	Test::More::plan(skip_all => "no ualarm()");
    }
}

use Test::More tests => 12;
BEGIN { push @INC, '.' }
use t::Watchdog;

use Config;

SKIP: {
    skip "no alarm", 2 unless $Config{d_alarm};
    my $tick = 0;
    local $SIG{ ALRM } = sub { $tick++ };

    my $one = CORE::time;
    $tick = 0; Time::HiRes::ualarm(10_000); while ($tick == 0) { }
    my $two = CORE::time;
    $tick = 0; Time::HiRes::ualarm(10_000); while ($tick == 0) { }
    my $three = CORE::time;
    ok $one == $two || $two == $three
	or print("# slept too long, $one $two $three\n");
    print("# tick = $tick, one = $one, two = $two, three = $three\n");

    $tick = 0; Time::HiRes::ualarm(10_000, 10_000); while ($tick < 3) { }
    ok 1;
    Time::HiRes::ualarm(0);
    print("# tick = $tick, one = $one, two = $two, three = $three\n");
}

eval { Time::HiRes::ualarm(-4) };
like $@, qr/::ualarm\(-4, 0\): negative time not invented yet/,
	"negative time error";

# Find the loop size N (a for() loop 0..N-1)
# that will take more than T seconds.

sub bellish {  # Cheap emulation of a bell curve.
    my ($min, $max) = @_;
    my $rand = ($max - $min) / 5;
    my $sum = 0; 
    for my $i (0..4) {
	$sum += rand($rand);
    }
    return $min + $sum;
}

# 1_100_000 slightly over 1_000_000,
# 2_200_000 slightly over 2**31/1000,
# 4_300_000 slightly over 2**32/1000.
for my $n (100_000, 1_100_000, 2_200_000, 4_300_000) {
    my $ok;
    for my $retry (1..10) {
	my $alarmed = 0;
	local $SIG{ ALRM } = sub { $alarmed++ };
	my $t0 = Time::HiRes::time();
	print("# t0 = $t0\n");
	print("# ualarm($n)\n");
	Time::HiRes::ualarm($n); 1 while $alarmed == 0;
	my $t1 = Time::HiRes::time();
	print("# t1 = $t1\n");
	my $dt = $t1 - $t0;
	print("# dt = $dt\n");
	my $r = $dt / ($n/1e6);
	print("# r = $r\n");
	$ok =
	    ($n < 1_000_000 || # Too much noise.
	     ($r >= 0.8 && $r <= 1.6));
	last if $ok;
	my $nap = bellish(3, 15);
	printf("# Retrying in %.1f seconds...\n", $nap);
	Time::HiRes::sleep($nap);
    }
    ok $ok or print("# ualarm($n) close enough\n");
}

{
    my $alrm0 = 0;

    $SIG{ALRM} = sub { $alrm0++ };
    my $t0 = Time::HiRes::time();
    my $got0 = Time::HiRes::ualarm(500_000);

    my($alrm, $t1);
    do {
	$alrm = $alrm0;
	$t1 = Time::HiRes::time();
    } while $t1 - $t0 <= 0.3;
    my $got1 = Time::HiRes::ualarm(0);

    print("# t0 = $t0\n");
    print("# got0 = $got0\n");
    print("# t1 = $t1\n");
    printf("# t1 - t0 = %s\n", ($t1 - $t0));
    print("# got1 = $got1\n");
    ok $got0 == 0 or print("# $got0\n");
    SKIP: {
	skip "alarm interval exceeded", 2 if $t1 - $t0 >= 0.5;
	ok $got1 > 0;
	ok $alrm == 0;
    }
    ok $got1 < 300_000;
    my $got2 = Time::HiRes::ualarm(0);
    ok $got2 == 0 or print("# $got2\n");
}

1;