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