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