Commit | Line | Data |
---|---|---|
90e44bf6 Z |
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; |