1 files changed, 112 insertions, 0 deletions
diff --git a/cpan/Time-HiRes/t/ualarm.t b/cpan/Time-HiRes/t/ualarm.t
new file mode 100644
index 0000000000..12ef4b52cc
--- /dev/null
+++ b/cpan/Time-HiRes/t/ualarm.t
@@ -0,0 +1,112 @@
+use strict;
+
+BEGIN {
+    require Time::HiRes;
+    unless(&Time::HiRes::d_ualarm) {
+	require Test::More;
+	Test::More::plan(skip_all => "no ualarm()");
+    }
+}
+
+use Test::More 0.82 tests => 12;
+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 note "slept too long, $one $two $three";
+    note "tick = $tick, one = $one, two = $two, three = $three";
+
+    $tick = 0; Time::HiRes::ualarm(10_000, 10_000); while ($tick < 3) { }
+    ok 1;
+    Time::HiRes::ualarm(0);
+    note "tick = $tick, one = $one, two = $two, three = $three";
+}
+
+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();
+	note "t0 = $t0";
+	note "ualarm($n)";
+	Time::HiRes::ualarm($n); 1 while $alarmed == 0;
+	my $t1 = Time::HiRes::time();
+	note "t1 = $t1";
+	my $dt = $t1 - $t0;
+	note "dt = $dt";
+	my $r = $dt / ($n/1e6);
+	note "r = $r";
+	$ok =
+	    ($n < 1_000_000 || # Too much noise.
+	     ($r >= 0.8 && $r <= 1.6));
+	last if $ok;
+	my $nap = bellish(3, 15);
+	note sprintf "Retrying in %.1f seconds...\n", $nap;
+	Time::HiRes::sleep($nap);
+    }
+    ok $ok or note "ualarm($n) close enough";
+}
+
+{
+    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);
+
+    note "t0 = $t0";
+    note "got0 = $got0";
+    note "t1 = $t1";
+    note "t1 - t0 = ", ($t1 - $t0);
+    note "got1 = $got1";
+    ok $got0 == 0 or note $got0;
+    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 note $got2;
+}
+
+1;