"Fossies" - the Fresh Open Source Software Archive

Member "Time-HiRes-1.9764/t/alarm.t" (10 Aug 2020, 7015 Bytes) of package /linux/privat/Time-HiRes-1.9764.tar.gz:


As a special service "Fossies" has tried to format the requested text file into HTML format (style: standard) with prefixed line numbers. Alternatively you can here view or download the uninterpreted source code file.

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