cpan/Time-HiRes/t/alarm.t

   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;