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