Revision history for Perl extension Time::HiRes.
+1.77 [2005-10-03]
+ - add support for the POSIX clock_gettime() and clock_getres(),
+ if available, either as library calls or as syscalls
+ - be more defensive about missing functionality: break out
+ early (during 'use') if no e.g. clock_getres() is available,
+ and protect our back by trapping those cases also in HiRes.xs
+ - the test added in 1.76 could cause an endless loop e.g. in Solaris,
+ due to mixing of sleep() and alarm() (bad programmer, no cookie!)
+
1.76 [2005-10-22]
- testing for nanosleep had wrong logic which caused nanosleep
to become undefined for e.g. Mac OS X
@EXPORT = qw( );
@EXPORT_OK = qw (usleep sleep ualarm alarm gettimeofday time tv_interval
- getitimer setitimer nanosleep
+ getitimer setitimer nanosleep clock_gettime clock_getres
+ CLOCK_HIGHRES CLOCK_MONOTONIC CLOCK_PROCESS_CPUTIME_ID
+ CLOCK_REALTIME CLOCK_THREAD_CPUTIME_ID CLOCK_TIMEOFDAY
ITIMER_REAL ITIMER_VIRTUAL ITIMER_PROF ITIMER_REALPROF
d_usleep d_ualarm d_gettimeofday d_getitimer d_setitimer
- d_nanosleep);
+ d_nanosleep d_clock_gettime d_clock_getres);
-$VERSION = '1.76';
+$VERSION = '1.77';
$XS_VERSION = $VERSION;
$VERSION = eval $VERSION;
sub AUTOLOAD {
my $constname;
($constname = $AUTOLOAD) =~ s/.*:://;
+ # print "AUTOLOAD: constname = $constname ($AUTOLOAD)\n";
die "&Time::HiRes::constant not defined" if $constname eq 'constant';
my ($error, $val) = constant($constname);
+ # print "AUTOLOAD: error = $error, val = $val\n";
if ($error) {
my (undef,$file,$line) = caller;
die "$error at $file line $line.\n";
goto &$AUTOLOAD;
}
+sub import {
+ my $this = shift;
+ for my $i (@_) {
+ if (($i eq 'clock_getres' && !&d_clock_getres) ||
+ ($i eq 'clock_gettime' && !&d_clock_gettime) ||
+ ($i eq 'nanosleep' && !&d_nanosleep) ||
+ ($i eq 'usleep' && !&d_usleep) ||
+ ($i eq 'ualarm' && !&d_ualarm)) {
+ require Carp;
+ Carp::croak("Time::HiRes::$i(): unimplemented in this platform");
+ }
+ }
+ Time::HiRes->export_to_level(1, $this, @_);
+}
+
bootstrap Time::HiRes;
# Preloaded methods go here.
=head1 SYNOPSIS
- use Time::HiRes qw( usleep ualarm gettimeofday tv_interval nanosleep );
+ use Time::HiRes qw( usleep ualarm gettimeofday tv_interval nanosleep
+ clock_gettime clock_getres );
usleep ($microseconds);
nanosleep ($nanoseconds);
setitimer ($which, $floating_seconds, $floating_interval );
getitimer ($which);
+ $realtime = clock_gettime(CLOCK_REALTIME);
+
=head1 DESCRIPTION
The C<Time::HiRes> module implements a Perl interface to the
or more than the core C<time()>, depending on whether your platform
rounds the higher resolution timer values up, down, or to the nearest second
to get the core C<time()>, but naturally the difference should be never
-more than half a second.
+more than half a second. See also L</clock_getres>, if available
+in your system.
B<NOTE 2>: Since Sunday, September 9th, 2001 at 01:46:40 AM GMT, when
the C<time()> seconds since epoch rolled over to 1_000_000_000, the
In list context, both the remaining time and the interval are returned.
The interval is always what you put in using C<setitimer()>.
+=item clock_gettime ( $which )
+
+Return as seconds the current value of the POSIX high resolution timer
+specified by C<$which>. All implementations that support POSIX high
+resolution timers are supposed to support at least the C<$which> value
+of C<CLOCK_REALTIME>, which is supposed to return results close to the
+results of C<gettimeofday>, or the number of seconds since 00:00:00:00
+January 1, 1970 Greenwich Mean Time (GMT). Do not assume that
+CLOCK_REALTIME is zero, it might be one, or something else.
+Another potentially useful (but not available everywhere) value is
+C<CLOCK_MONOTONIC>, which guarantees a monotonically increasing time
+value (unlike time(), which can be adjusted). See your system
+documentation for other possibly supported values.
+
+=item clock_getres ( $which )
+
+Return as seconds the resolution of the POSIX high resolution timer
+specified by C<$which>. All implementations that support POSIX high
+resolution timers are supposed to support at least the C<$which> value
+of C<CLOCK_REALTIME>, see L</clock_gettime>.
+
=back
=head1 EXAMPLES
$SIG{VTALRM} = sub { print time, "\n" };
setitimer(ITIMER_VIRTUAL, 10, 2.5);
+ # How accurate we can be, really?
+
+ my $reso = clock_gettime(CLOCK_REALTIME);
+
=head1 C API
In addition to the perl API described above, a C API is available for
platforms like Cygwin and MinGW) the Time::HiRes::time() may temporarily
drift off from the system clock (and the original time()) by up to 0.5
seconds. Time::HiRes will notice this eventually and recalibrate.
+Note that since Time::HiRes 1.77 the clock_gettime(CLOCK_MONOTONIC)
+might help in this (in case your system supports it).
=head1 SEE ALSO
-L<BSD::Resource>, L<Time::TAI64>.
+Perl modules L<BSD::Resource>, L<Time::TAI64>.
+
+Your system documentation for C<clock_gettime>, C<clock_settime>,
+C<gettimeofday>, C<getitimer>, C<setitimer>, C<ualarm>.
=head1 AUTHORS
# include <sys/select.h>
# endif
#endif
+#if defined(TIME_HIRES_CLOCK_GETTIME_SYSCALL) || defined(TIME_HIRES_CLOCK_GETRES_SYSCALL)
+#include <syscall.h>
+#endif
#ifdef __cplusplus
}
#endif
OUTPUT:
RETVAL
+#else /* #if defined(TIME_HIRES_NANOSLEEP) */
+
+NV
+nanosleep(nseconds)
+ NV nseconds
+ CODE:
+ croak("Time::HiRes::nanosleep(): unimplemented in this platform");
+ RETVAL = 0.0;
+
#endif /* #if defined(TIME_HIRES_NANOSLEEP) */
NV
OUTPUT:
RETVAL
+#else /* #if defined(HAS_USLEEP) && defined(HAS_GETTIMEOFDAY) */
+
+NV
+usleep(useconds)
+ NV useconds
+ CODE:
+ croak("Time::HiRes::usleep(): unimplemented in this platform");
+ RETVAL = 0.0;
+
#endif /* #if defined(HAS_USLEEP) && defined(HAS_GETTIMEOFDAY) */
#ifdef HAS_UALARM
OUTPUT:
RETVAL
+#else
+
+int
+ualarm(useconds,interval=0)
+ int useconds
+ int interval
+ CODE:
+ croak("Time::HiRes::ualarm(): unimplemented in this platform");
+ RETVAL = -1;
+
+NV
+alarm(seconds,interval=0)
+ NV seconds
+ NV interval
+ CODE:
+ croak("Time::HiRes::alarm(): unimplemented in this platform");
+ RETVAL = 0.0;
+
#endif /* #ifdef HAS_UALARM */
#ifdef HAS_GETTIMEOFDAY
#endif /* #if defined(HAS_GETITIMER) && defined(HAS_SETITIMER) */
+#if defined(TIME_HIRES_CLOCK_GETTIME)
+
+NV
+clock_gettime(clock_id = CLOCK_REALTIME)
+ int clock_id
+ PREINIT:
+ struct timespec ts;
+ int status = -1;
+ CODE:
+#ifdef TIME_HIRES_CLOCK_GETTIME_SYSCALL
+ status = syscall(SYS_clock_gettime, clock_id, &ts);
+#else
+ status = clock_gettime(clock_id, &ts);
+#endif
+ RETVAL = status == 0 ? ts.tv_sec + (NV) ts.tv_nsec / (NV) 1e9 : -1;
+
+ OUTPUT:
+ RETVAL
+
+#else /* if defined(TIME_HIRES_CLOCK_GETTIME) */
+
+NV
+clock_gettime(clock_id = 0)
+ int clock_id
+ CODE:
+ croak("Time::HiRes::clock_gettime(): unimplemented in this platform");
+ RETVAL = 0.0;
+
+#endif /* #if defined(TIME_HIRES_CLOCK_GETTIME) */
+
+#if defined(TIME_HIRES_CLOCK_GETRES)
+
+NV
+clock_getres(clock_id = CLOCK_REALTIME)
+ int clock_id
+ PREINIT:
+ int status = -1;
+ struct timespec ts;
+ CODE:
+#ifdef TIME_HIRES_CLOCK_GETRES_SYSCALL
+ status = syscall(SYS_clock_getres, clock_id, &ts);
+#else
+ status = clock_getres(clock_id, &ts);
+#endif
+ RETVAL = status == 0 ? ts.tv_sec + (NV) ts.tv_nsec / (NV) 1e9 : -1;
+
+ OUTPUT:
+ RETVAL
+
+#else /* if defined(TIME_HIRES_CLOCK_GETRES) */
+
+NV
+clock_getres(clock_id = 0)
+ int clock_id
+ CODE:
+ croak("Time::HiRes::clock_getres(): unimplemented in this platform");
+ RETVAL = 0.0;
+
+#endif /* #if defined(TIME_HIRES_CLOCK_GETRES) */
+
my $DEFINE;
my $LIBS = [];
my $XSOPT = '';
+my $SYSCALL_H;
use vars qw($self); # Used in 'sourcing' the hints.
my $tmp_exe = "$tmp$ld_exeext";
printf "cccmd = $cccmd\n" if $VERBOSE;
my $res = system($cccmd);
- $ok = defined($res) && $res==0 && -s $tmp_exe && -x _;
+ $ok = defined($res) && $res == 0 && -s $tmp_exe && -x _;
if ( $ok && exists $args{run} && $args{run}) {
my $tmp_exe =
$ok = 1;
} else {
$ok = 0;
- print "[ system('$tmp_exe') failed: status $? ] ";
+ my $errno = $? >> 8;
+ local $! = $errno;
+ printf <<EOF;
+
+*** The test run of '$tmp_exe' failed: status $?
+*** (the status means: errno = $errno or '$!')
+*** DO NOT PANIC: this just means that *some* functionality will be missing.
+EOF
}
}
unlink("$tmp.c", $tmp_exe);
ts2.tv_sec = 0;
ts2.tv_nsec = 0;
errno = 0;
- ret = nanosleep(&ts1, &ts2); /* E.g. in AIX nanosleep() fail and set errno to ENOSYS. */
+ ret = nanosleep(&ts1, &ts2); /* E.g. in AIX nanosleep() fails and sets errno to ENOSYS. */
ret == 0 ? exit(0) : exit(errno ? errno : -1);
}
EOM
return 0;
}
+sub has_clock_x_syscall {
+ my $x = shift;
+ return 0 unless defined $SYSCALL_H;
+ return 1 if
+ try_compile_and_link(<<EOM, run => 1);
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+#include <$SYSCALL_H>
+int main _((int argc, char** argv, char** env))
+{
+ struct timespec ts;
+ /* Many Linuxes get ENOSYS even though the syscall exists. */
+ /* All implementations are supposed to support CLOCK_REALTIME. */
+ int ret = syscall(SYS_clock_$x, CLOCK_REALTIME, &ts);
+ ret == 0 ? exit(0) : exit(errno ? errno : -1);
+}
+EOM
+}
+
+sub has_clock_x {
+ my $x = shift;
+ return 1 if
+ try_compile_and_link(<<EOM, run => 1);
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+int main _((int argc, char** argv, char** env))
+{
+ struct timespec ts;
+ int ret = clock_$x(CLOCK_REALTIME, &ts); /* Many Linuxes get ENOSYS. */
+ /* All implementations are supposed to support CLOCK_REALTIME. */
+ ret == 0 ? exit(0) : exit(errno ? errno : -1);
+}
+EOM
+}
+
sub init {
my $hints = File::Spec->catfile("hints", "$^O.pl");
if (-f $hints) {
$DEFINE = '';
+ if ($Config{d_syscall}) {
+ print "Have syscall(), looking for syscall.h... ";
+ if (has_include('syscall.h')) {
+ $SYSCALL_H = 'syscall.h';
+ } elsif (has_include('sys/syscall.h')) {
+ $SYSCALL_H = 'sys/syscall.h';
+ }
+ }
+
+ if (defined $SYSCALL_H) {
+ print "found <$SYSCALL_H>.\n";
+ } else {
+ print "NOT found.\n";
+ }
+
print "Looking for gettimeofday()... ";
my $has_gettimeofday;
if (exists $Config{d_gettimeod}) {
print "(It would not be portable anyway.)\n";
}
+ print "Looking for clock_gettime()... ";
+ my $has_clock_gettime;
+ if (exists $Config{d_clock_gettime}) {
+ $has_clock_gettime++ if $Config{d_clock_gettime}; # Unlikely...
+ } elsif (has_clock_x('gettime')) {
+ $has_clock_gettime++;
+ $DEFINE .= ' -DTIME_HIRES_CLOCK_GETTIME';
+ } elsif (defined $SYSCALL_H && has_clock_x_syscall('gettime')) {
+ $has_clock_gettime++;
+ $DEFINE .= ' -DTIME_HIRES_CLOCK_GETTIME -DTIME_HIRES_CLOCK_GETTIME_SYSCALL';
+ }
+
+ if ($has_clock_gettime) {
+ if ($DEFINE =~ /-DTIME_HIRES_CLOCK_GETTIME_SYSCALL/) {
+ print "found (via syscall).\n";
+ } else {
+ print "found.\n";
+ }
+ } else {
+ print "NOT found.\n";
+ }
+
+ print "Looking for clock_getres()... ";
+ my $has_clock_getres;
+ if (exists $Config{d_clock_getres}) {
+ $has_clock_getres++ if $Config{d_clock_getres}; # Unlikely...
+ } elsif (has_clock_x('getres')) {
+ $has_clock_getres++;
+ $DEFINE .= ' -DTIME_HIRES_CLOCK_GETRES';
+ } elsif (defined $SYSCALL_H && has_clock_x_syscall('getres')) {
+ $has_clock_getres++;
+ $DEFINE .= ' -DTIME_HIRES_CLOCK_GETRES -DTIME_HIRES_CLOCK_GETRES_SYSCALL';
+ }
+
+ if ($has_clock_getres) {
+ if ($DEFINE =~ /-DTIME_HIRES_CLOCK_GETRES_SYSCALL/) {
+ print "found (via syscall).\n";
+ } else {
+ print "found.\n";
+ }
+ } else {
+ print "NOT found.\n";
+ }
+
my $has_w32api_windows_h;
if ($^O eq 'cygwin') {
print "Looking for <w32api/windows.h>... ";
'LIBS' => $LIBS, # e.g., '-lm'
'DEFINE' => $DEFINE, # e.g., '-DHAS_SOMETHING'
'XSOPT' => $XSOPT,
- # do not even think about 'INC' => '-I/usr/ucbinclude', Solaris will avenge.
+ # Do not even think about 'INC' => '-I/usr/ucbinclude',
+ # Solaris will avenge.
'INC' => '', # e.g., '-I/usr/include/other'
'INSTALLDIRS' => ($] >= 5.008 ? 'perl' : 'site'),
'dist' => {
sub doConstants {
if (eval {require ExtUtils::Constant; 1}) {
- my @names = (qw(ITIMER_REAL ITIMER_VIRTUAL ITIMER_PROF
+ my @names = (qw(CLOCK_HIGHRES CLOCK_MONOTONIC
+ CLOCK_PROCESS_CPUTIME_ID
+ CLOCK_REALTIME
+ CLOCK_THREAD_CPUTIME_ID
+ CLOCK_TIMEOFDAY
+ ITIMER_REAL ITIMER_VIRTUAL ITIMER_PROF
ITIMER_REALPROF));
foreach (qw (d_usleep d_ualarm d_gettimeofday d_getitimer d_setitimer
- d_nanosleep)) {
+ d_nanosleep d_clock_gettime d_clock_getres)) {
my $macro = $_;
- if ($macro eq 'd_nanosleep') {
+ if ($macro =~ /^(d_nanosleep|d_clock_gettime|d_clock_getres)$/) {
$macro =~ s/d_(.*)/TIME_HIRES_\U$1/;
} else {
$macro =~ s/d_(.*)/HAS_\U$1/;
(exists $ENV{LC_CTYPE} && $ENV{LC_CTYPE} =~ /utf-?8/i) ||
(exists $ENV{LANG} && $ENV{LANG} =~ /utf-?8/i)) {
print <<EOM;
-NOTE: if you get an error like this (the line number may vary):
+NOTE: if you get an error like this (the Makefile line number may vary):
Makefile:91: *** missing separator
then set the environment variable LC_ALL to "C" and retry
from scratch (re-run perl "Makefile.PL").
#ifndef pTHX_
#define pTHX_ /* 5.6 or later define this for threading support. */
#endif
-
static int
constant_11 (pTHX_ const char *name, IV *iv_return) {
/* When generated this function returned values for the list of names given
case 'l':
if (memEQ(name, "d_nanosleep", 11)) {
/* ^ */
-#ifdef HAS_NANOSLEEP
+#ifdef TIME_HIRES_NANOSLEEP
+ *iv_return = 1;
+ return PERL_constant_ISIV;
+#else
+ *iv_return = 0;
+ return PERL_constant_ISIV;
+#endif
+ }
+ break;
+ }
+ return PERL_constant_NOTFOUND;
+}
+
+static int
+constant_14 (pTHX_ const char *name, IV *iv_return) {
+ /* When generated this function returned values for the list of names given
+ here. However, subsequent manual editing may have added or removed some.
+ CLOCK_REALTIME ITIMER_VIRTUAL d_clock_getres d_gettimeofday */
+ /* Offset 6 gives the best switch position. */
+ switch (name[6]) {
+ case 'R':
+ if (memEQ(name, "CLOCK_REALTIME", 14)) {
+ /* ^ */
+#ifdef CLOCK_REALTIME
+ *iv_return = CLOCK_REALTIME;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case '_':
+ if (memEQ(name, "ITIMER_VIRTUAL", 14)) {
+ /* ^ */
+#ifdef ITIMER_VIRTUAL
+ *iv_return = ITIMER_VIRTUAL;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'i':
+ if (memEQ(name, "d_gettimeofday", 14)) {
+ /* ^ */
+#ifdef HAS_GETTIMEOFDAY
+ *iv_return = 1;
+ return PERL_constant_ISIV;
+#else
+ *iv_return = 0;
+ return PERL_constant_ISIV;
+#endif
+ }
+ break;
+ case 'k':
+ if (memEQ(name, "d_clock_getres", 14)) {
+ /* ^ */
+#ifdef TIME_HIRES_CLOCK_GETRES
+ *iv_return = 1;
+ return PERL_constant_ISIV;
+#else
+ *iv_return = 0;
+ return PERL_constant_ISIV;
+#endif
+ }
+ break;
+ }
+ return PERL_constant_NOTFOUND;
+}
+
+static int
+constant_15 (pTHX_ const char *name, IV *iv_return) {
+ /* When generated this function returned values for the list of names given
+ here. However, subsequent manual editing may have added or removed some.
+ CLOCK_MONOTONIC CLOCK_TIMEOFDAY ITIMER_REALPROF d_clock_gettime */
+ /* Offset 7 gives the best switch position. */
+ switch (name[7]) {
+ case 'I':
+ if (memEQ(name, "CLOCK_TIMEOFDAY", 15)) {
+ /* ^ */
+#ifdef CLOCK_TIMEOFDAY
+ *iv_return = CLOCK_TIMEOFDAY;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'O':
+ if (memEQ(name, "CLOCK_MONOTONIC", 15)) {
+ /* ^ */
+#ifdef CLOCK_MONOTONIC
+ *iv_return = CLOCK_MONOTONIC;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'R':
+ if (memEQ(name, "ITIMER_REALPROF", 15)) {
+ /* ^ */
+#ifdef ITIMER_REALPROF
+ *iv_return = ITIMER_REALPROF;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case '_':
+ if (memEQ(name, "d_clock_gettime", 15)) {
+ /* ^ */
+#ifdef TIME_HIRES_CLOCK_GETTIME
*iv_return = 1;
return PERL_constant_ISIV;
#else
Regenerate these constant functions by feeding this entire source file to
perl -x
-#!/usr/local/bin/perl5.8.0 -w
+#!perl -w
use ExtUtils::Constant qw (constant_types C_constant XS_constant);
my $types = {map {($_, 1)} qw(IV)};
-my @names = (qw(ITIMER_PROF ITIMER_REAL ITIMER_REALPROF ITIMER_VIRTUAL),
+my @names = (qw(CLOCK_HIGHRES CLOCK_MONOTONIC CLOCK_PROCESS_CPUTIME_ID
+ CLOCK_REALTIME CLOCK_THREAD_CPUTIME_ID CLOCK_TIMEOFDAY
+ ITIMER_PROF ITIMER_REAL ITIMER_REALPROF ITIMER_VIRTUAL),
+ {name=>"d_clock_getres", type=>"IV", macro=>"TIME_HIRES_CLOCK_GETRES", value=>"1", default=>["IV", "0"]},
+ {name=>"d_clock_gettime", type=>"IV", macro=>"TIME_HIRES_CLOCK_GETTIME", value=>"1", default=>["IV", "0"]},
{name=>"d_getitimer", type=>"IV", macro=>"HAS_GETITIMER", value=>"1", default=>["IV", "0"]},
{name=>"d_gettimeofday", type=>"IV", macro=>"HAS_GETTIMEOFDAY", value=>"1", default=>["IV", "0"]},
- {name=>"d_nanosleep", type=>"IV", macro=>"HAS_NANOSLEEP", value=>"1", default=>["IV", "0"]},
+ {name=>"d_nanosleep", type=>"IV", macro=>"TIME_HIRES_NANOSLEEP", value=>"1", default=>["IV", "0"]},
{name=>"d_setitimer", type=>"IV", macro=>"HAS_SETITIMER", value=>"1", default=>["IV", "0"]},
{name=>"d_ualarm", type=>"IV", macro=>"HAS_UALARM", value=>"1", default=>["IV", "0"]},
{name=>"d_usleep", type=>"IV", macro=>"HAS_USLEEP", value=>"1", default=>["IV", "0"]});
/* Offset 7 gives the best switch position. */
switch (name[7]) {
case 'm':
- if (memEQ(name, "d_ualarm", 8)) {
- /* ^ */
+ if (memEQ(name, "d_ualar", 7)) {
+ /* m */
#ifdef HAS_UALARM
*iv_return = 1;
return PERL_constant_ISIV;
}
break;
case 'p':
- if (memEQ(name, "d_usleep", 8)) {
- /* ^ */
+ if (memEQ(name, "d_uslee", 7)) {
+ /* p */
#ifdef HAS_USLEEP
*iv_return = 1;
return PERL_constant_ISIV;
case 11:
return constant_11 (aTHX_ name, iv_return);
break;
- case 14:
- /* Names all of length 14. */
- /* ITIMER_VIRTUAL d_gettimeofday */
- /* Offset 6 gives the best switch position. */
- switch (name[6]) {
- case '_':
- if (memEQ(name, "ITIMER_VIRTUAL", 14)) {
- /* ^ */
-#ifdef ITIMER_VIRTUAL
- *iv_return = ITIMER_VIRTUAL;
- return PERL_constant_ISIV;
+ case 13:
+ if (memEQ(name, "CLOCK_HIGHRES", 13)) {
+#ifdef CLOCK_HIGHRES
+ *iv_return = CLOCK_HIGHRES;
+ return PERL_constant_ISIV;
#else
- return PERL_constant_NOTDEF;
+ return PERL_constant_NOTDEF;
#endif
- }
- break;
- case 'i':
- if (memEQ(name, "d_gettimeofday", 14)) {
- /* ^ */
-#ifdef HAS_GETTIMEOFDAY
- *iv_return = 1;
- return PERL_constant_ISIV;
+ }
+ break;
+ case 14:
+ return constant_14 (aTHX_ name, iv_return);
+ break;
+ case 15:
+ return constant_15 (aTHX_ name, iv_return);
+ break;
+ case 23:
+ if (memEQ(name, "CLOCK_THREAD_CPUTIME_ID", 23)) {
+#ifdef CLOCK_THREAD_CPUTIME_ID
+ *iv_return = CLOCK_THREAD_CPUTIME_ID;
+ return PERL_constant_ISIV;
#else
- *iv_return = 0;
- return PERL_constant_ISIV;
+ return PERL_constant_NOTDEF;
#endif
- }
- break;
}
break;
- case 15:
- if (memEQ(name, "ITIMER_REALPROF", 15)) {
-#ifdef ITIMER_REALPROF
- *iv_return = ITIMER_REALPROF;
+ case 24:
+ if (memEQ(name, "CLOCK_PROCESS_CPUTIME_ID", 24)) {
+#ifdef CLOCK_PROCESS_CPUTIME_ID
+ *iv_return = CLOCK_PROCESS_CPUTIME_ID;
return PERL_constant_ISIV;
#else
return PERL_constant_NOTDEF;
type, s));
PUSHs(sv);
}
+
}
}
-BEGIN { $| = 1; print "1..29\n"; }
+BEGIN { $| = 1; print "1..31\n"; }
END { print "not ok 1\n" unless $loaded }
use strict;
-my $have_gettimeofday = defined &Time::HiRes::gettimeofday;
-my $have_usleep = defined &Time::HiRes::usleep;
-my $have_nanosleep = defined &Time::HiRes::nanosleep;
-my $have_ualarm = defined &Time::HiRes::ualarm;
-my $have_time = defined &Time::HiRes::time;
+my $have_gettimeofday = &Time::HiRes::d_gettimeofday;
+my $have_usleep = &Time::HiRes::d_usleep;
+my $have_nanosleep = &Time::HiRes::d_nanosleep;
+my $have_ualarm = &Time::HiRes::d_ualarm;
+my $have_clock_gettime = &Time::HiRes::d_clock_gettime;
+my $have_clock_getres = &Time::HiRes::d_clock_getres;
-printf "# have_gettimeofday = %d\n", $have_gettimeofday;
-printf "# have_usleep = %d\n", $have_usleep;
-printf "# have_nanosleep = %d\n", $have_nanosleep;
-printf "# have_ualarm = %d\n", $have_ualarm;
-printf "# have_time = %d\n", $have_time;
+printf "# have_gettimeofday = %d\n", $have_gettimeofday;
+printf "# have_usleep = %d\n", $have_usleep;
+printf "# have_nanosleep = %d\n", $have_nanosleep;
+printf "# have_ualarm = %d\n", $have_ualarm;
+printf "# have_clock_gettime = %d\n", $have_clock_gettime;
+printf "# have_clock_getres = %d\n", $have_clock_getres;
import Time::HiRes 'gettimeofday' if $have_gettimeofday;
import Time::HiRes 'usleep' if $have_usleep;
import Time::HiRes 'nanosleep' if $have_nanosleep;
import Time::HiRes 'ualarm' if $have_ualarm;
+import Time::HiRes 'clock_gettime' if $have_clock_gettime;
+import Time::HiRes 'clock_getres' if $have_clock_getres;
use Config;
# Did we even get close?
-unless ($have_time) {
+unless ($have_gettimeofday) {
skip 14;
} else {
my ($s, $n, $i) = (0);
print "ok $_ # Skip: no gettimeofday or no ualarm or no usleep\n";
}
} else {
- use Time::HiRes qw (time alarm sleep);
+ use Time::HiRes qw(time alarm sleep);
my ($f, $r, $i, $not, $ok);
unless ( defined &Time::HiRes::setitimer
&& defined &Time::HiRes::getitimer
- && eval 'Time::HiRes::ITIMER_VIRTUAL'
+ && exists &Time::HiRes::ITIMER_VIRTUAL
&& $Config{d_select}
&& $Config{sig_name} =~ m/\bVTALRM\b/) {
for (18..19) {
if ($have_ualarm && $] >= 5.008001) {
# http://groups.google.com/group/perl.perl5.porters/browse_thread/thread/adaffaaf939b042e/20dafc298df737f0%2320dafc298df737f0?sa=X&oi=groupsr&start=0&num=3
# Perl changes [18765] and [18770], perl bug [perl #20920]
+
+ # First we will find the loop size N (a for() loop 0..N-1)
+ # that will take more than T seconds.
+
+ my $T = 0.01;
+ use Time::HiRes qw(time);
+ my $N = 1024;
+ my $i;
+ N: {
+ do {
+ my $t0 = time();
+ for ($i = 0; $i < $N; $i++) { }
+ my $t1 = time();
+ my $dt = $t1 - $t0;
+ print "# N = $N, t1 = $t1, t0 = $t0, dt = $dt\n";
+ last N if $dt > $T;
+ $N *= 2;
+ } while (1);
+ }
+
+ # The time-burner which takes at least T seconds.
+ my $F = sub {
+ my $c = @_ ? shift : 1;
+ my $n = $c * $N;
+ my $i;
+ for ($i = 0; $i < $n; $i++) { }
+ };
+
+ # Then we will setup a periodic timer (the two-argument alarm() of
+ # Time::HiRes, behind the curtains the libc ualarm()) which has
+ # a signal handler that takes so much time (on the first initial
+ # invocation) that the first periodic invocation (second invocation)
+ # will happen before the first invocation has finished. In Perl 5.8.0
+ # the "safe signals" concept was implemented, with unfortunately at least
+ # one bug that caused a core dump on reentering the handler. This bug
+ # was fixed by the time of Perl 5.8.1.
+
+ my $a = 0; # Number of alarms we receive.
+ my $A = 2; # Number of alarms we will handle before disarming.
+ # (We may well get $A + 1 alarms.)
+
+ $SIG{ALRM} = sub {
+ $a++;
+ print "# Alarm $a - ", time(), "\n";
+ alarm(0) if $a >= $A; # Disarm the alarm.
+ $F->(2); # Try burning CPU at least for 2T seconds.
+ };
+
use Time::HiRes qw(alarm);
- $SIG{ALRM} = sub { 1 for 1..100000 };
- alarm(0.01, 0.01);
- sleep(1);
+ alarm($T, $T); # Arm the alarm.
+
+ $F->(10); # Try burning CPU at least for 10T seconds.
+
print "ok 29\n"; # Not core dumping by now is considered to be the success.
} else {
skip 29;
}
+if ($have_clock_gettime) {
+ # All implementations are SUPPOSED TO support CLOCK_REALTIME...
+ eval 'use Time::HiRes qw(CLOCK_REALTIME)';
+ unless ($@) {
+ my $t0 = clock_gettime(&CLOCK_REALTIME);
+ use Time::HiRes qw(sleep);
+ my $T = 0.1;
+ sleep($T);
+ my $t1 = clock_gettime(&CLOCK_REALTIME);
+ if ($t0 > 0 && $t1) {
+ print "# t1 = $t1, t0 = $t0\n";
+ my $dt = $t1 - $t0;
+ my $rt = abs(1 - $dt / $T);
+ if ($rt <= 0.25) { # Allow 25% jitter.
+ print "ok 30 # dt = $dt, r = $rt\n";
+ } else {
+ print "not ok 30 # dt = $dt, rt = $rt\n";
+ }
+ } else {
+ print "# Error '$!'\n";
+ skip 30;
+ }
+ } else {
+ print "# No CLOCK_REALTIME ($@)\n";
+ skip 30;
+ }
+} else {
+ print "# No clock_gettime\n";
+ skip 30;
+}
+
+if ($have_clock_getres) {
+ my $tr = clock_getres();
+ if ($tr > 0) {
+ print "ok 31 # tr = $tr\n";
+ } else {
+ print "not ok 31 # tr = $tr\n";
+ }
+} else {
+ print "# No clock_getres\n";
+ skip 31;
+}
+
END {
if (defined $timer_pid) {
print "# I am the main process $$, terminating the timer process $timer_pid.\n";
projects / p5sagit/p5-mst-13.2.git / commitdiff