1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222
|
use strict;
use Test::More 0.82 tests => 10;
use t::Watchdog;
BEGIN { require_ok "Time::HiRes"; }
use Config;
my $limit = 0.25; # 25% is acceptable slosh for testing timers
my $xdefine = '';
if (open(XDEFINE, "xdefine")) {
chomp($xdefine = <XDEFINE> || "");
close(XDEFINE);
}
my $can_subsecond_alarm =
defined &Time::HiRes::gettimeofday &&
defined &Time::HiRes::ualarm &&
defined &Time::HiRes::usleep &&
($Config{d_ualarm} || $xdefine =~ /-DHAS_UALARM/);
SKIP: {
skip "no subsecond alarm", 1 unless $can_subsecond_alarm;
eval { require POSIX };
my $use_sigaction =
!$@ && defined &POSIX::sigaction && &POSIX::SIGALRM > 0;
my ($r, $i, $not, $ok);
$r = [Time::HiRes::gettimeofday()];
$i = 5;
my $oldaction;
if ($use_sigaction) {
$oldaction = new POSIX::SigAction;
note sprintf "sigaction tick, ALRM = %d", &POSIX::SIGALRM;
# Perl's deferred signals may be too wimpy to break through
# a restartable select(), so use POSIX::sigaction if available.
POSIX::sigaction(&POSIX::SIGALRM,
POSIX::SigAction->new("tick"),
$oldaction)
or die "Error setting SIGALRM handler with sigaction: $!\n";
} else {
note "SIG tick";
$SIG{ALRM} = "tick";
}
# On VMS timers can not interrupt select.
if ($^O eq 'VMS') {
$ok = "Skip: VMS select() does not get interrupted.";
} else {
while ($i > 0) {
Time::HiRes::alarm(0.3);
select (undef, undef, undef, 3);
my $ival = Time::HiRes::tv_interval ($r);
note "Select returned! $i $ival";
note abs($ival/3 - 1);
# Whether select() gets restarted after signals is
# implementation dependent. If it is restarted, we
# will get about 3.3 seconds: 3 from the select, 0.3
# from the alarm. If this happens, let's just skip
# this particular test. --jhi
if (abs($ival/3.3 - 1) < $limit) {
$ok = "Skip: your select() may get restarted by your SIGALRM (or just retry test)";
undef $not;
last;
}
my $exp = 0.3 * (5 - $i);
if ($exp == 0) {
$not = "while: divisor became zero";
last;
}
# This test is more sensitive, so impose a softer limit.
if (abs($ival/$exp - 1) > 4*$limit) {
my $ratio = abs($ival/$exp);
$not = "while: $exp sleep took $ival ratio $ratio";
last;
}
$ok = $i;
}
}
sub tick {
$i--;
my $ival = Time::HiRes::tv_interval ($r);
note "Tick! $i $ival";
my $exp = 0.3 * (5 - $i);
if ($exp == 0) {
$not = "tick: divisor became zero";
last;
}
# This test is more sensitive, so impose a softer limit.
if (abs($ival/$exp - 1) > 4*$limit) {
my $ratio = abs($ival/$exp);
$not = "tick: $exp sleep took $ival ratio $ratio";
$i = 0;
}
}
if ($use_sigaction) {
POSIX::sigaction(&POSIX::SIGALRM, $oldaction);
} else {
Time::HiRes::alarm(0); # can't cancel usig %SIG
}
ok !$not;
note $not || $ok;
}
SKIP: {
skip "no ualarm", 1 unless &Time::HiRes::d_ualarm;
eval { Time::HiRes::alarm(-3) };
like $@, qr/::alarm\(-3, 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.
SKIP: {
skip "no ualarm", 1 unless &Time::HiRes::d_ualarm;
skip "perl bug", 1 unless $] >= 5.008001;
# http://groups.google.com/group/perl.perl5.porters/browse_thread/thread/adaffaaf939b042e/20dafc298df737f0%2320dafc298df737f0?sa=X&oi=groupsr&start=0&num=3
# Perl changes [18765] and [18770], perl bug [perl #20920]
note "Finding delay loop...";
my $T = 0.01;
my $DelayN = 1024;
my $i;
N: {
do {
my $t0 = Time::HiRes::time();
for ($i = 0; $i < $DelayN; $i++) { }
my $t1 = Time::HiRes::time();
my $dt = $t1 - $t0;
note "N = $DelayN, t1 = $t1, t0 = $t0, dt = $dt";
last N if $dt > $T;
$DelayN *= 2;
} while (1);
}
# The time-burner which takes at least T (default 1) seconds.
my $Delay = sub {
my $c = @_ ? shift : 1;
my $n = $c * $DelayN;
my $i;
for ($i = 0; $i < $n; $i++) { }
};
# Next setup a periodic timer (the two-argument alarm() of
# Time::HiRes, behind the curtains the libc getitimer() or
# ualarm()) which has a signal handler that takes so much time (on
# the first initial invocation) that the first periodic invocation
# (second invocation) will happen before the first invocation has
# finished. In Perl 5.8.0 the "safe signals" concept was
# implemented, with unfortunately at least one bug that caused a
# core dump on reentering the handler. This bug was fixed by the
# time of Perl 5.8.1.
# Do not try mixing sleep() and alarm() for testing this.
my $a = 0; # Number of alarms we receive.
my $A = 2; # Number of alarms we will handle before disarming.
# (We may well get $A + 1 alarms.)
$SIG{ALRM} = sub {
$a++;
note "Alarm $a - ", Time::HiRes::time();
Time::HiRes::alarm(0) if $a >= $A; # Disarm the alarm.
$Delay->(2); # Try burning CPU at least for 2T seconds.
};
Time::HiRes::alarm($T, $T); # Arm the alarm.
$Delay->(10); # Try burning CPU at least for 10T seconds.
ok 1; # Not core dumping by now is considered to be the success.
}
SKIP: {
skip "no subsecond alarm", 6 unless $can_subsecond_alarm;
{
my $alrm;
$SIG{ALRM} = sub { $alrm++ };
Time::HiRes::alarm(0.1);
my $t0 = Time::HiRes::time();
1 while Time::HiRes::time() - $t0 <= 1;
ok $alrm;
}
{
my $alrm;
$SIG{ALRM} = sub { $alrm++ };
Time::HiRes::alarm(1.1);
my $t0 = Time::HiRes::time();
1 while Time::HiRes::time() - $t0 <= 2;
ok $alrm;
}
{
my $alrm = 0;
$SIG{ALRM} = sub { $alrm++ };
my $got = Time::HiRes::alarm(2.7);
ok $got == 0 or note $got;
my $t0 = Time::HiRes::time();
1 while Time::HiRes::time() - $t0 <= 1;
$got = Time::HiRes::alarm(0);
ok $got > 0 && $got < 1.8 or note $got;
ok $alrm == 0 or note $alrm;
$got = Time::HiRes::alarm(0);
ok $got == 0 or note $got;
}
}
1;
|