xref: /openbsd/gnu/usr.bin/perl/dist/Time-HiRes/t/alarm.t (revision 56d68f1e) 
1use strict;
2
3use Test::More tests => 10;
4BEGIN { push @INC, '.' }
5use t::Watchdog;
6
7BEGIN { require_ok "Time::HiRes"; }
8
9use Config;
10
11my $limit = 0.25; # 25% is acceptable slosh for testing timers
12
13my $xdefine = '';
14if (open(XDEFINE, "<", "xdefine")) {
15    chomp($xdefine = <XDEFINE> || "");
16    close(XDEFINE);
17}
18
19my $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
25SKIP: {
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
119SKIP: {
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
129SKIP: {
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
190SKIP: {
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
2281;
229