dist/Time-HiRes/t/alarm.t

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