0fed57273a5c8aaf5c8d9732d0f16ac138207b70
[perl.git] / ext / Time / HiRes / t / HiRes.t
1 #!./perl -w
2
3 BEGIN {
4     if ($ENV{PERL_CORE}) {
5         chdir 't' if -d 't';
6         @INC = '../lib';
7         require Config; import Config;
8         if (" $Config{'extensions'} " !~ m[ Time/HiRes ]) {
9             print "1..0 # Skip -- Perl configured without Time::HiRes module\n";
10             exit 0;
11         }
12     }
13 }
14
15 BEGIN { $| = 1; print "1..33\n"; }
16
17 END { print "not ok 1\n" unless $loaded }
18
19 use Time::HiRes qw(tv_interval);
20
21 $loaded = 1;
22
23 print "ok 1\n";
24
25 use strict;
26
27 my $have_gettimeofday    = &Time::HiRes::d_gettimeofday;
28 my $have_usleep          = &Time::HiRes::d_usleep;
29 my $have_nanosleep       = &Time::HiRes::d_nanosleep;
30 my $have_ualarm          = &Time::HiRes::d_ualarm;
31 my $have_clock_gettime   = &Time::HiRes::d_clock_gettime;
32 my $have_clock_getres    = &Time::HiRes::d_clock_getres;
33 my $have_clock_nanosleep = &Time::HiRes::d_clock_nanosleep;
34 my $have_clock           = &Time::HiRes::d_clock;
35
36 sub has_symbol {
37     my $symbol = shift;
38     eval "use Time::HiRes qw($symbol)";
39     return 0 unless $@ eq '';
40     eval "my \$a = $symbol";
41     return $@ eq '';
42 }
43
44 printf "# have_gettimeofday    = %d\n", $have_gettimeofday;
45 printf "# have_usleep          = %d\n", $have_usleep;
46 printf "# have_nanosleep       = %d\n", $have_nanosleep;
47 printf "# have_ualarm          = %d\n", $have_ualarm;
48 printf "# have_clock_gettime   = %d\n", $have_clock_gettime;
49 printf "# have_clock_getres    = %d\n", $have_clock_getres;
50 printf "# have_clock_nanosleep = %d\n", $have_clock_nanosleep;
51 printf "# have_clock           = %d\n", $have_clock;
52
53 import Time::HiRes 'gettimeofday'       if $have_gettimeofday;
54 import Time::HiRes 'usleep'             if $have_usleep;
55 import Time::HiRes 'nanosleep'          if $have_nanosleep;
56 import Time::HiRes 'ualarm'             if $have_ualarm;
57 import Time::HiRes 'clock_gettime'      if $have_clock_gettime;
58 import Time::HiRes 'clock_getres'       if $have_clock_getres;
59 import Time::HiRes 'clock_nanosleep'    if $have_clock_nanosleep;
60 import Time::HiRes 'clock'              if $have_clock;
61
62 use Config;
63
64 use Time::HiRes qw(gettimeofday);
65
66 my $have_alarm = $Config{d_alarm};
67 my $have_fork  = $Config{d_fork};
68 my $waitfor = 60; # 10-20 seconds is normal (load affects this).
69 my $timer_pid;
70 my $TheEnd;
71
72 if ($have_fork) {
73     print "# I am the main process $$, starting the timer process...\n";
74     $timer_pid = fork();
75     if (defined $timer_pid) {
76         if ($timer_pid == 0) { # We are the kid, set up the timer.
77             print "# I am the timer process $$, sleeping for $waitfor seconds...\n";
78             sleep($waitfor);
79             warn "\n$0: overall time allowed for tests (${waitfor}s) exceeded!\n";
80             print "# Terminating the main process...\n";
81             kill('TERM', getppid());
82             print "# This is the timer process $$, over and out.\n";
83             exit(0);
84         } else {
85             print "# The timer process $timer_pid launched, continuing testing...\n";
86             $TheEnd = time() + $waitfor;
87         }
88     } else {
89         warn "$0: fork failed: $!\n";
90     }
91 } else {
92     print "# No timer process (need fork)\n";
93 }
94
95 my $xdefine = ''; 
96
97 if (open(XDEFINE, "xdefine")) {
98     chomp($xdefine = <XDEFINE>);
99     close(XDEFINE);
100 }
101
102 # Ideally, we'd like to test that the timers are rather precise.
103 # However, if the system is busy, there are no guarantees on how
104 # quickly we will return.  This limit used to be 10%, but that
105 # was occasionally triggered falsely.  
106 # Try 20%.  
107 # Another possibility might be to print "ok" if the test completes fine
108 # with (say) 10% slosh, "skip - system may have been busy?" if the test
109 # completes fine with (say) 30% slosh, and fail otherwise.  If you do that,
110 # consider changing over to test.pl at the same time.
111 # --A.D., Nov 27, 2001
112 my $limit = 0.20; # 20% is acceptable slosh for testing timers
113
114 sub skip {
115     map { print "ok $_ # skipped\n" } @_;
116 }
117
118 sub ok {
119     my ($n, $result, @info) = @_;
120     if ($result) {
121         print "ok $n\n";
122     }
123     else {
124         print "not ok $n\n";
125         print "# @info\n" if @info;
126     }
127 }
128
129 unless ($have_gettimeofday) {
130     skip 2..6;
131 }
132 else {
133     my @one = gettimeofday();
134     ok 2, @one == 2, 'gettimeofday returned ', 0+@one, ' args';
135     ok 3, $one[0] > 850_000_000, "@one too small";
136
137     sleep 1;
138
139     my @two = gettimeofday();
140     ok 4, ($two[0] > $one[0] || ($two[0] == $one[0] && $two[1] > $one[1])),
141             "@two is not greater than @one";
142
143     my $f = Time::HiRes::time();
144     ok 5, $f > 850_000_000, "$f too small";
145     ok 6, $f - $two[0] < 2, "$f - $two[0] >= 2";
146 }
147
148 unless ($have_usleep) {
149     skip 7..8;
150 }
151 else {
152     use Time::HiRes qw(usleep);
153     my $one = time;
154     usleep(10_000);
155     my $two = time;
156     usleep(10_000);
157     my $three = time;
158     ok 7, $one == $two || $two == $three, "slept too long, $one $two $three";
159
160     unless ($have_gettimeofday) {
161         skip 8;
162     }
163     else {
164         my $f = Time::HiRes::time();
165         usleep(500_000);
166         my $f2 = Time::HiRes::time();
167         my $d = $f2 - $f;
168         ok 8, $d > 0.4 && $d < 0.9, "slept $d secs $f to $f2";
169     }
170 }
171
172 # Two-arg tv_interval() is always available.
173 {
174     my $f = tv_interval [5, 100_000], [10, 500_000];
175     ok 9, abs($f - 5.4) < 0.001, $f;
176 }
177
178 unless ($have_gettimeofday) {
179     skip 10;
180 }
181 else {
182     my $r = [gettimeofday()];
183     my $f = tv_interval $r;
184     ok 10, $f < 2, $f;
185 }
186
187 unless ($have_usleep && $have_gettimeofday) {
188     skip 11;
189 }
190 else {
191     my $r = [ gettimeofday() ];
192     Time::HiRes::sleep( 0.5 );
193     my $f = tv_interval $r;
194     ok 11, $f > 0.4 && $f < 0.9, "slept $f instead of 0.5 secs.";
195 }
196
197 unless ($have_ualarm && $have_alarm) {
198     skip 12..13;
199 }
200 else {
201     my $tick = 0;
202     local $SIG{ ALRM } = sub { $tick++ };
203
204     my $one = time; $tick = 0; ualarm(10_000); while ($tick == 0) { }
205     my $two = time; $tick = 0; ualarm(10_000); while ($tick == 0) { }
206     my $three = time;
207     ok 12, $one == $two || $two == $three, "slept too long, $one $two $three";
208     print "# tick = $tick, one = $one, two = $two, three = $three\n";
209
210     $tick = 0; ualarm(10_000, 10_000); while ($tick < 3) { }
211     ok 13, 1;
212     ualarm(0);
213     print "# tick = $tick, one = $one, two = $two, three = $three\n";
214 }
215
216 # Did we even get close?
217
218 unless ($have_gettimeofday) {
219     skip 14;
220 } else {
221  my ($s, $n, $i) = (0);
222  for $i (1 .. 100) {
223      $s += Time::HiRes::time() - time();
224      $n++;
225  }
226  # $s should be, at worst, equal to $n
227  # (time() may be rounding down, up, or closest)
228  ok 14, abs($s) / $n <= 1.0, "Time::HiRes::time() not close to time()";
229  print "# s = $s, n = $n, s/n = ", $s/$n, "\n";
230 }
231
232 my $has_ualarm = $Config{d_ualarm};
233
234 $has_ualarm ||= $xdefine =~ /-DHAS_UALARM/;
235
236 unless (   defined &Time::HiRes::gettimeofday
237         && defined &Time::HiRes::ualarm
238         && defined &Time::HiRes::usleep
239         && $has_ualarm) {
240     for (15..17) {
241         print "ok $_ # Skip: no gettimeofday or no ualarm or no usleep\n";
242     }
243 } else {
244     use Time::HiRes qw(time alarm sleep);
245
246     my ($f, $r, $i, $not, $ok);
247
248     $f = time; 
249     print "# time...$f\n";
250     print "ok 15\n";
251
252     $r = [Time::HiRes::gettimeofday()];
253     sleep (0.5);
254     print "# sleep...", Time::HiRes::tv_interval($r), "\nok 16\n";
255
256     $r = [Time::HiRes::gettimeofday()];
257     $i = 5;
258     $SIG{ALRM} = "tick";
259     while ($i > 0)
260     {
261         alarm(0.3);
262         select (undef, undef, undef, 3);
263         my $ival = Time::HiRes::tv_interval ($r);
264         print "# Select returned! $i $ival\n";
265         print "# ", abs($ival/3 - 1), "\n";
266         # Whether select() gets restarted after signals is
267         # implementation dependent.  If it is restarted, we
268         # will get about 3.3 seconds: 3 from the select, 0.3
269         # from the alarm.  If this happens, let's just skip
270         # this particular test.  --jhi
271         if (abs($ival/3.3 - 1) < $limit) {
272             $ok = "Skip: your select() may get restarted by your SIGALRM (or just retry test)";
273             undef $not;
274             last;
275         }
276         my $exp = 0.3 * (5 - $i);
277         # This test is more sensitive, so impose a softer limit.
278         if (abs($ival/$exp - 1) > 3*$limit) {
279             my $ratio = abs($ival/$exp);
280             $not = "while: $exp sleep took $ival ratio $ratio";
281             last;
282         }
283         $ok = $i;
284     }
285
286     sub tick
287     {
288         $i--;
289         my $ival = Time::HiRes::tv_interval ($r);
290         print "# Tick! $i $ival\n";
291         my $exp = 0.3 * (5 - $i);
292         # This test is more sensitive, so impose a softer limit.
293         if (abs($ival/$exp - 1) > 3*$limit) {
294             my $ratio = abs($ival/$exp);
295             $not = "tick: $exp sleep took $ival ratio $ratio";
296             $i = 0;
297         }
298     }
299
300     alarm(0); # can't cancel usig %SIG
301
302     print $not ? "not ok 17 # $not\n" : "ok 17 # $ok\n";
303 }
304
305 unless (   defined &Time::HiRes::setitimer
306         && defined &Time::HiRes::getitimer
307         && has_symbol('ITIMER_VIRTUAL')
308         && $Config{sig_name} =~ m/\bVTALRM\b/) {
309     for (18..19) {
310         print "ok $_ # Skip: no virtual interval timers\n";
311     }
312 } else {
313     use Time::HiRes qw(setitimer getitimer ITIMER_VIRTUAL);
314
315     my $i = 3;
316     my $r = [Time::HiRes::gettimeofday()];
317
318     $SIG{VTALRM} = sub {
319         $i ? $i-- : setitimer(&ITIMER_VIRTUAL, 0);
320         print "# Tick! $i ", Time::HiRes::tv_interval($r), "\n";
321     };  
322
323     print "# setitimer: ", join(" ", setitimer(ITIMER_VIRTUAL, 0.5, 0.4)), "\n";
324
325     # Assume interval timer granularity of $limit * 0.5 seconds.  Too bold?
326     my $virt = getitimer(&ITIMER_VIRTUAL);
327     print "not " unless defined $virt && abs($virt / 0.5) - 1 < $limit;
328     print "ok 18\n";
329
330     print "# getitimer: ", join(" ", getitimer(ITIMER_VIRTUAL)), "\n";
331
332     while (getitimer(&ITIMER_VIRTUAL)) {
333         my $j;
334         for (1..1000) { $j++ } # Can't be unbreakable, must test getitimer().
335     }
336
337     print "# getitimer: ", join(" ", getitimer(ITIMER_VIRTUAL)), "\n";
338
339     $virt = getitimer(&ITIMER_VIRTUAL);
340     print "not " unless defined $virt && $virt == 0;
341     print "ok 19\n";
342
343     $SIG{VTALRM} = 'DEFAULT';
344 }
345
346 if ($have_gettimeofday &&
347     $have_usleep) {
348     use Time::HiRes qw(usleep);
349
350     my ($t0, $td);
351
352     my $sleep = 1.5; # seconds
353     my $msg;
354
355     $t0 = gettimeofday();
356     $a = abs(sleep($sleep)        / $sleep         - 1.0);
357     $td = gettimeofday() - $t0;
358     my $ratio = 1.0 + $a;
359
360     $msg = "$td went by while sleeping $sleep, ratio $ratio.\n";
361
362     if ($td < $sleep * (1 + $limit)) {
363         print $a < $limit ? "ok 20 # $msg" : "not ok 20 # $msg";
364     } else {
365         print "ok 20 # Skip: $msg";
366     }
367
368     $t0 = gettimeofday();
369     $a = abs(usleep($sleep * 1E6) / ($sleep * 1E6) - 1.0);
370     $td = gettimeofday() - $t0;
371     $ratio = 1.0 + $a;
372
373     $msg = "$td went by while sleeping $sleep, ratio $ratio.\n";
374
375     if ($td < $sleep * (1 + $limit)) {
376         print $a < $limit ? "ok 21 # $msg" : "not ok 21 # $msg";
377     } else {
378         print "ok 21 # Skip: $msg";
379     }
380
381 } else {
382     for (20..21) {
383         print "ok $_ # Skip: no gettimeofday\n";
384     }
385 }
386
387 unless ($have_nanosleep) {
388     skip 22..23;
389 }
390 else {
391     my $one = CORE::time;
392     nanosleep(10_000_000);
393     my $two = CORE::time;
394     nanosleep(10_000_000);
395     my $three = CORE::time;
396     ok 22, $one == $two || $two == $three, "slept too long, $one $two $three";
397
398     unless ($have_gettimeofday) {
399         skip 23;
400     }
401     else {
402         my $f = Time::HiRes::time();
403         nanosleep(500_000_000);
404         my $f2 = Time::HiRes::time();
405         my $d = $f2 - $f;
406         ok 23, $d > 0.4 && $d < 0.9, "slept $d secs $f to $f2";
407     }
408 }
409
410 eval { sleep(-1) };
411 print $@ =~ /::sleep\(-1\): negative time not invented yet/ ?
412     "ok 24\n" : "not ok 24\n";
413
414 eval { usleep(-2) };
415 print $@ =~ /::usleep\(-2\): negative time not invented yet/ ?
416     "ok 25\n" : "not ok 25\n";
417
418 if ($have_ualarm) {
419     eval { alarm(-3) };
420     print $@ =~ /::alarm\(-3, 0\): negative time not invented yet/ ?
421         "ok 26\n" : "not ok 26\n";
422
423     eval { ualarm(-4) };
424     print $@ =~ /::ualarm\(-4, 0\): negative time not invented yet/ ?
425     "ok 27\n" : "not ok 27\n";
426 } else {
427     skip 26;
428     skip 27;
429 }
430
431 if ($have_nanosleep) {
432     eval { nanosleep(-5) };
433     print $@ =~ /::nanosleep\(-5\): negative time not invented yet/ ?
434         "ok 28\n" : "not ok 28\n";
435 } else {
436     skip 28;
437 }
438
439 if ($have_ualarm && $] >= 5.008001) {
440     # http://groups.google.com/group/perl.perl5.porters/browse_thread/thread/adaffaaf939b042e/20dafc298df737f0%2320dafc298df737f0?sa=X&oi=groupsr&start=0&num=3
441     # Perl changes [18765] and [18770], perl bug [perl #20920]
442
443     # First we will find the loop size N (a for() loop 0..N-1)
444     # that will take more than T seconds.
445
446     my $T = 0.01;
447     use Time::HiRes qw(time);
448     my $N = 1024;
449     my $i;
450     N: {
451         do {
452             my $t0 = time();
453             for ($i = 0; $i < $N; $i++) { }
454             my $t1 = time();
455             my $dt = $t1 - $t0;
456             print "# N = $N, t1 = $t1, t0 = $t0, dt = $dt\n";
457             last N if $dt > $T;
458             $N *= 2;
459         } while (1);
460     }
461
462     # The time-burner which takes at least T seconds.
463     my $F = sub {
464         my $c = @_ ? shift : 1;
465         my $n = $c * $N;
466         my $i;
467         for ($i = 0; $i < $n; $i++) { }
468     };
469
470     # Then we will setup a periodic timer (the two-argument alarm() of
471     # Time::HiRes, behind the curtains the libc ualarm()) which has
472     # a signal handler that takes so much time (on the first initial
473     # invocation) that the first periodic invocation (second invocation)
474     # will happen before the first invocation has finished.  In Perl 5.8.0
475     # the "safe signals" concept was implemented, with unfortunately at least
476     # one bug that caused a core dump on reentering the handler. This bug
477     # was fixed by the time of Perl 5.8.1.
478
479     # Do not try mixing sleep() and alarm() for testing this.
480
481     my $a = 0; # Number of alarms we receive.
482     my $A = 2; # Number of alarms we will handle before disarming.
483                # (We may well get $A + 1 alarms.)
484
485     $SIG{ALRM} = sub {
486         $a++;
487         print "# Alarm $a - ", time(), "\n";
488         alarm(0) if $a >= $A; # Disarm the alarm.
489         $F->(2); # Try burning CPU at least for 2T seconds.
490     }; 
491
492     use Time::HiRes qw(alarm); 
493     alarm($T, $T);  # Arm the alarm.
494
495     $F->(10); # Try burning CPU at least for 10T seconds.
496
497     print "ok 29\n"; # Not core dumping by now is considered to be the success.
498 } else {
499     skip 29;
500 }
501
502 if ($have_clock_gettime &&
503     # All implementations of clock_gettime() 
504     # are SUPPOSED TO support CLOCK_REALTIME.
505     has_symbol('CLOCK_REALTIME')) {
506     my $ok = 0;
507  TRY: {
508         for my $try (1..3) {
509             print "# CLOCK_REALTIME: try = $try\n";
510             my $t0 = clock_gettime(&CLOCK_REALTIME);
511             use Time::HiRes qw(sleep);
512             my $T = 1.5;
513             sleep($T);
514             my $t1 = clock_gettime(&CLOCK_REALTIME);
515             if ($t0 > 0 && $t1 > $t0) {
516                 print "# t1 = $t1, t0 = $t0\n";
517                 my $dt = $t1 - $t0;
518                 my $rt = abs(1 - $dt / $T);
519                 print "# dt = $dt, rt = $rt\n";
520                 if ($rt <= 2 * $limit) {
521                     $ok = 1;
522                     last TRY;
523                 }
524             } else {
525                 print "# Error: t0 = $t0, t1 = $t1\n";
526             }
527             my $r = rand() + rand();
528             printf "# Sleeping for %.6f seconds...\n", $r;
529             sleep($r);
530         }
531     }
532     if ($ok) {
533         print "ok 30\n";
534     } else {
535         print "not ok 30\n";
536     }
537 } else {
538     print "# No clock_gettime\n";
539     skip 30;
540 }
541
542 if ($have_clock_getres) {
543     my $tr = clock_getres();
544     if ($tr > 0) {
545         print "ok 31 # tr = $tr\n";
546     } else {
547         print "not ok 31 # tr = $tr\n";
548     }
549 } else {
550     print "# No clock_getres\n";
551     skip 31;
552 }
553
554 if ($have_clock_nanosleep &&
555     has_symbol('CLOCK_REALTIME')) {
556     my $s = 1.5;
557     my $t = clock_nanosleep(&CLOCK_REALTIME, $s);
558     my $r = abs(1 - $t / $s);
559     if ($r < 2 * $limit) {
560         print "ok 32\n";
561     } else {
562         print "not ok 32 # $t = $t, r = $r\n";
563     }
564 } else {
565     print "# No clock_nanosleep\n";
566     skip 32;
567 }
568
569 if ($have_clock) {
570     my @clock = clock();
571     print "# clock = @clock\n";
572     for my $i (1..3) {
573         for (my $j = 0; $j < 1e6; $j++) { }
574         push @clock, clock();
575         print "# clock = @clock\n";
576     }
577     if ($clock[0] >= 0 &&
578         $clock[1] > $clock[0] &&
579         $clock[2] > $clock[1] &&
580         $clock[3] > $clock[2]) {
581         print "ok 33\n";
582     } else {
583         print "not ok 33\n";
584     }
585 } else {
586     print "# No clock\n";
587     skip 33;
588 }
589
590 END {
591     if (defined $timer_pid) {
592         my $left = $TheEnd - time();
593         printf "# I am the main process $$, terminating the timer process $timer_pid\n# before it terminates me in %d seconds (testing took %d seconds).\n", $left, $waitfor - $left;
594         kill('TERM', $timer_pid); # We are done, the timer can go.
595         unlink("ktrace.out"); # Used in BSD system call tracing.
596         print "# All done.\n";
597     }
598 }
599