From: Steve Peters Date: Thu, 3 Nov 2005 11:37:31 +0000 (+0000) Subject: Upgrade to Time-HiRes-1.77 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=ced84e60a279937a6d3baa19b9c0bda889e532f3;p=p5sagit%2Fp5-mst-13.2.git Upgrade to Time-HiRes-1.77 p4raw-id: //depot/perl@25970 --- diff --git a/ext/Time/HiRes/Changes b/ext/Time/HiRes/Changes index 3f7adc2..60f5c71 100644 --- a/ext/Time/HiRes/Changes +++ b/ext/Time/HiRes/Changes @@ -1,5 +1,14 @@ 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 diff --git a/ext/Time/HiRes/HiRes.pm b/ext/Time/HiRes/HiRes.pm index 70aab16..6064fb5 100644 --- a/ext/Time/HiRes/HiRes.pm +++ b/ext/Time/HiRes/HiRes.pm @@ -10,20 +10,24 @@ require DynaLoader; @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"; @@ -35,6 +39,21 @@ sub AUTOLOAD { 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. @@ -57,7 +76,8 @@ Time::HiRes - High resolution alarm, sleep, gettimeofday, interval timers =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); @@ -85,6 +105,8 @@ Time::HiRes - High resolution alarm, sleep, gettimeofday, interval timers setitimer ($which, $floating_seconds, $floating_interval ); getitimer ($which); + $realtime = clock_gettime(CLOCK_REALTIME); + =head1 DESCRIPTION The C module implements a Perl interface to the @@ -174,7 +196,8 @@ B: This higher resolution timer can return values either less or more than the core C, depending on whether your platform rounds the higher resolution timer values up, down, or to the nearest second to get the core C, but naturally the difference should be never -more than half a second. +more than half a second. See also L, if available +in your system. B: Since Sunday, September 9th, 2001 at 01:46:40 AM GMT, when the C seconds since epoch rolled over to 1_000_000_000, the @@ -267,6 +290,27 @@ In scalar context, the remaining time is returned. In list context, both the remaining time and the interval are returned. The interval is always what you put in using C. +=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, which is supposed to return results close to the +results of C, 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, 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, see L. + =back =head1 EXAMPLES @@ -315,6 +359,10 @@ The interval is always what you put in using C. $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 @@ -365,10 +413,15 @@ time as gracefully as UNIX ntp does). For example in Win32 (and derived 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, L. +Perl modules L, L. + +Your system documentation for C, C, +C, C, C, C. =head1 AUTHORS diff --git a/ext/Time/HiRes/HiRes.xs b/ext/Time/HiRes/HiRes.xs index dbd6590..4c56464 100644 --- a/ext/Time/HiRes/HiRes.xs +++ b/ext/Time/HiRes/HiRes.xs @@ -30,6 +30,9 @@ extern "C" { # include # endif #endif +#if defined(TIME_HIRES_CLOCK_GETTIME_SYSCALL) || defined(TIME_HIRES_CLOCK_GETRES_SYSCALL) +#include +#endif #ifdef __cplusplus } #endif @@ -739,6 +742,15 @@ nanosleep(nseconds) 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 @@ -778,6 +790,15 @@ sleep(...) 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 @@ -807,6 +828,24 @@ alarm(seconds,interval=0) 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 @@ -934,3 +973,63 @@ getitimer(which) #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) */ + diff --git a/ext/Time/HiRes/Makefile.PL b/ext/Time/HiRes/Makefile.PL index edc42de..bfa65e0 100644 --- a/ext/Time/HiRes/Makefile.PL +++ b/ext/Time/HiRes/Makefile.PL @@ -15,6 +15,7 @@ my $VERBOSE = $ENV{VERBOSE}; my $DEFINE; my $LIBS = []; my $XSOPT = ''; +my $SYSCALL_H; use vars qw($self); # Used in 'sourcing' the hints. @@ -141,7 +142,7 @@ sub try_compile_and_link { 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 = @@ -151,7 +152,14 @@ sub try_compile_and_link { $ok = 1; } else { $ok = 0; - print "[ system('$tmp_exe') failed: status $? ] "; + my $errno = $? >> 8; + local $! = $errno; + printf < 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(< 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) { @@ -278,6 +323,21 @@ sub init { $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}) { @@ -417,6 +477,50 @@ EOD 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 ... "; @@ -457,7 +561,8 @@ sub doMakefile { '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' => { @@ -478,12 +583,17 @@ sub doMakefile { 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/; @@ -532,7 +642,7 @@ EOM (exists $ENV{LC_CTYPE} && $ENV{LC_CTYPE} =~ /utf-?8/i) || (exists $ENV{LANG} && $ENV{LANG} =~ /utf-?8/i)) { print <"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"]}); @@ -128,8 +244,8 @@ __END__ /* 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; @@ -140,8 +256,8 @@ __END__ } 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; @@ -156,40 +272,36 @@ __END__ 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; diff --git a/ext/Time/HiRes/fallback/const-xs.inc b/ext/Time/HiRes/fallback/const-xs.inc index c84dd05..9412046 100644 --- a/ext/Time/HiRes/fallback/const-xs.inc +++ b/ext/Time/HiRes/fallback/const-xs.inc @@ -86,3 +86,4 @@ constant(sv) type, s)); PUSHs(sv); } + diff --git a/ext/Time/HiRes/t/HiRes.t b/ext/Time/HiRes/t/HiRes.t index e7d383c..93af2c6 100644 --- a/ext/Time/HiRes/t/HiRes.t +++ b/ext/Time/HiRes/t/HiRes.t @@ -12,7 +12,7 @@ BEGIN { } } -BEGIN { $| = 1; print "1..29\n"; } +BEGIN { $| = 1; print "1..31\n"; } END { print "not ok 1\n" unless $loaded } @@ -24,22 +24,26 @@ print "ok 1\n"; 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; @@ -192,7 +196,7 @@ else { # Did we even get close? -unless ($have_time) { +unless ($have_gettimeofday) { skip 14; } else { my ($s, $n, $i) = (0); @@ -218,7 +222,7 @@ unless ( defined &Time::HiRes::gettimeofday 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); @@ -281,7 +285,7 @@ unless ( defined &Time::HiRes::gettimeofday 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) { @@ -414,15 +418,107 @@ if ($have_nanosleep) { 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";