},
'Time::HiRes' => {
- 'DISTRIBUTION' => 'JHI/Time-HiRes-1.9753.tar.gz',
+ 'DISTRIBUTION' => 'JHI/Time-HiRes-1.9757.tar.gz',
'FILES' => q[dist/Time-HiRes],
},
Revision history for the Perl extension Time::HiRes.
+1.9577 [2018-03-15]
+ - fix win32 (and cygwin?) builds which have been broken since 1.9755:
+ problem was that gettimeofday() is a macro and needs to stay such
+ - regenerate ppport.h with Perl 5.26.1 (was previously generated with
+ 5.25.6) and Devel::PPPort 3.35 (previously 3.36) -- this doesn't
+ change the ppport.h, though
+
+1.9756 [2018-03-14]
+ - division by zero in new test tv_interval.t [rt.cpan.org #124775]:
+ made the test pass even if the difference is zero, but also
+ made it practically impossible to ever be zero by adding
+ a sub-second sleep.
+ - remove comments from inside qw [rt.cpan.org #124777],
+ only seemed to be caught by Perl 5.18.4
+
+1.9755 [2018-03-14]
+ - adjust the error messages of tv_interval()
+ - the NV_1EX constants now cast to be NV so that
+ tv_interval() with long double builds does not
+ produce ugly results [rt.cpan.org #106456]
+ - add tests for tv_interval()
+ - centralize the mygettimeofday() logic
+ - make the mygettimeofday() a function instead of macro
+ - add the OS X 10.12+ clock_gettime() constants
+ CLOCK_MONOTONIC_RAW_APPROX CLOCK_UPTIME_RAW_APPROX
+ - regenerate the fallback files
+
+1.9754 [2018-02-16]
+ - unify the gettimeofday() and time() forked code
+ that had near identical code paths for MacOS Classic
+ (which has two unusual features: unsigned time_t,
+ and a special tz struct member), and for non-MacOS Classic
+ - tv_interval should be implemented in XS
+ [rt.cpan.org #106456]
+ thanks to Sergey Aleynikov (suggested implementation simplified
+ by the above-mentioned MacOS Classic simplification)
+
1.9753 [2018-01-11]
- in t/clock.t in a fast system we need to burn more CPU,
reported and fix suggested by Joel C. Maslak <jmaslak@antelope.net>
our @ISA = qw(Exporter);
our @EXPORT = qw( );
-# More or less this same list is in Makefile.PL. Should unify.
+# TODO: this list is a superset of the @names in
+# Makefile.PL:doConstants(), automate this somehow.
our @EXPORT_OK = qw (usleep sleep ualarm alarm gettimeofday time tv_interval
getitimer setitimer nanosleep clock_gettime clock_getres
clock clock_nanosleep
CLOCK_MONOTONIC_FAST
CLOCK_MONOTONIC_PRECISE
CLOCK_MONOTONIC_RAW
+ CLOCK_MONOTONIC_RAW_APPROX
CLOCK_PROCESS_CPUTIME_ID
CLOCK_PROF
CLOCK_REALTIME
CLOCK_UPTIME_FAST
CLOCK_UPTIME_PRECISE
CLOCK_UPTIME_RAW
+ CLOCK_UPTIME_RAW_APPROX
CLOCK_VIRTUAL
ITIMER_PROF
ITIMER_REAL
stat lstat utime
);
-our $VERSION = '1.9753';
+our $VERSION = '1.9757';
our $XS_VERSION = $VERSION;
$VERSION = eval $VERSION;
# Preloaded methods go here.
-sub tv_interval {
- # probably could have been done in C
- my ($a, $b) = @_;
- $b = [gettimeofday()] unless defined($b);
- (${$b}[0] - ${$a}[0]) + ((${$b}[1] - ${$a}[1]) / 1_000_000);
-}
-
# Autoload methods go after =cut, and are processed by the autosplit program.
1;
#define IV_1E7 10000000
#define IV_1E9 1000000000
-#define NV_1E6 1000000.0
-#define NV_1E7 10000000.0
-#define NV_1E9 1000000000.0
+#define NV_1E6 (NV)1000000.0
+#define NV_1E7 (NV)10000000.0
+#define NV_1E9 (NV)1000000000.0
#ifndef PerlProc_pause
# define PerlProc_pause() Pause()
#define IS_SAFE_PATHNAME(pv, len, opname) (((len)>1)&&memchr((pv), 0, (len)-1)?(SETERRNO(ENOENT, LIB_INVARG),WARNEMU(opname),FALSE):(TRUE))
#endif
+/* Mac OS (Classic) (MacOS 9) */
+#ifdef MACOS_TRADITIONAL
+/* has tz values that matter */
+#define GETTIMEOFDAY_TZ
+/* has tz.tz_minuteswest which needs to be added to tv_sec */
+#define ADJUST_BY_TZ_MINUTES
+/* has unsigned time_t */
+#define UNSIGNED_TIME_T
+#endif
+
+#if defined(WIN32) || defined(CYGWIN_WITH_W32API)
+# define mygettimeofday(tp, not_used) gettimeofday(tp, not_used)
+#else
+static int mygettimeofday(struct timeval *tv, struct timezone *tz)
+{
+ int status;
+# ifdef GETTIMEOFDAY_TZ
+ status = gettimeofday(tv, tz);
+# else
+ (void) tz;
+ status = gettimeofday(tv, NULL);
+# endif /* ifdef GETTIMEOFDAY_TZ */
+# ifdef ADJUST_BY_TZ_MINUTES
+# ifndef GETTIMEOFDAY_TZ
+# error "ADJUST_BY_TZ_MINUTES requires GETTIMEOFDAY_TZ"
+# endif /* ifndef GETTIMEOFDAY_TZ */
+ tv->tv_sec += tz->tz_minuteswest * 60; /* adjust for TZ */
+# endif /* ADJUST_BY_TZ_MINUTES */
+ return status;
+}
+#endif /* if defined(WIN32) || defined(CYGWIN_WITH_W32API) else */
+
+#ifdef UNSIGNED_TIME_T
+#define SvTIME(sv) SvUV(sv)
+#define newSVtimet) newSVuv(t)
+#else
+#define SvTIME(sv) SvIV(sv)
+#define newSVtime(t) newSViv(t)
+#endif
+
MODULE = Time::HiRes PACKAGE = Time::HiRes
PROTOTYPES: ENABLE
#endif /* #ifdef HAS_UALARM */
#ifdef HAS_GETTIMEOFDAY
-# ifdef MACOS_TRADITIONAL /* fix epoch TZ and use unsigned time_t */
void
gettimeofday()
PREINIT:
struct timezone Tz;
PPCODE:
int status;
- status = gettimeofday (&Tp, &Tz);
-
+ status = mygettimeofday (&Tp, &Tz);
if (status == 0) {
- Tp.tv_sec += Tz.tz_minuteswest * 60; /* adjust for TZ */
if (GIMME == G_ARRAY) {
EXTEND(sp, 2);
- /* Mac OS (Classic) has unsigned time_t */
- PUSHs(sv_2mortal(newSVuv(Tp.tv_sec)));
+ PUSHs(sv_2mortal(newSVtime(Tp.tv_sec)));
PUSHs(sv_2mortal(newSViv(Tp.tv_usec)));
} else {
EXTEND(sp, 1);
struct timezone Tz;
CODE:
int status;
- status = gettimeofday (&Tp, &Tz);
+ status = mygettimeofday (&Tp, &Tz);
if (status == 0) {
- Tp.tv_sec += Tz.tz_minuteswest * 60; /* adjust for TZ */
RETVAL = Tp.tv_sec + (Tp.tv_usec / NV_1E6);
} else {
RETVAL = -1.0;
OUTPUT:
RETVAL
-# else /* MACOS_TRADITIONAL */
-void
-gettimeofday()
- PREINIT:
- struct timeval Tp;
- PPCODE:
- int status;
- status = gettimeofday (&Tp, NULL);
- if (status == 0) {
- if (GIMME == G_ARRAY) {
- EXTEND(sp, 2);
- PUSHs(sv_2mortal(newSViv(Tp.tv_sec)));
- PUSHs(sv_2mortal(newSViv(Tp.tv_usec)));
- } else {
- EXTEND(sp, 1);
- PUSHs(sv_2mortal(newSVnv(Tp.tv_sec + (Tp.tv_usec / NV_1E6))));
- }
+NV
+tv_interval(SV* start, ...)
+ PREINIT:
+ struct timeval Tp;
+ struct timezone Tz;
+ SV* end;
+ time_t end_sec;
+ IV end_usec;
+ SV** avalue;
+
+ CODE:
+
+ end = NULL;
+ if (items >= 2) {
+ end = ST(1);
+ }
+ /* It would be tempting croak on items > 2
+ * but that would probably break some code. */
+
+ if (SvROK(start) && SvTYPE(SvRV(start)) == SVt_PVAV) {
+ start = SvRV(start);
+ } else {
+ croak("tv_interval() 1st argument should be an array reference");
+ }
+
+ if (end != NULL) {
+ if (SvROK(end) && SvTYPE(SvRV(end)) == SVt_PVAV) {
+ end = SvRV(end);
+ /* Resist the temptation to expect exactly
+ * an array of length two: that would
+ * no doubt break some code. */
+ avalue = av_fetch((AV*)end, 0, FALSE);
+ end_sec = avalue ? SvTIME(*avalue) : 0;
+ avalue = av_fetch((AV*)end, 1, FALSE);
+ end_usec = avalue ? SvIV(*avalue) : 0;
+ } else {
+ croak("tv_interval() 2nd argument should be an array reference");
}
+ } else {
+ int status;
+ status = mygettimeofday (&Tp, &Tz);
+ if (status == 0) {
+ end_sec = Tp.tv_sec;
+ end_usec = Tp.tv_usec;
+ } else {
+ end_sec = 0;
+ end_usec = 0;
+ }
+ }
-NV
-time()
- PREINIT:
- struct timeval Tp;
- CODE:
- int status;
- status = gettimeofday (&Tp, NULL);
- if (status == 0) {
- RETVAL = Tp.tv_sec + (Tp.tv_usec / NV_1E6);
- } else {
- RETVAL = -1.0;
- }
- OUTPUT:
- RETVAL
+ /* Resist temptation to expect exactly an array
+ * of length two: that would no doubt break some code. */
+ avalue = av_fetch((AV*)start, 0, FALSE);
+ RETVAL = end_sec - (avalue ? SvTIME(*avalue) : 0);
+ avalue = av_fetch((AV*)start, 1, FALSE);
+ RETVAL += ((end_usec - (avalue ? SvIV(*avalue) : 0)) / NV_1E6);
+
+ OUTPUT:
+ RETVAL
-# endif /* MACOS_TRADITIONAL */
#endif /* #ifdef HAS_GETTIMEOFDAY */
#if defined(HAS_GETITIMER) && defined(HAS_SETITIMER)
sub doConstants {
if (eval {require ExtUtils::Constant; 1}) {
- # More or less this same list is in HiRes.pm. Should unify.
- my @names = qw(
- CLOCKS_PER_SEC
- CLOCK_BOOTTIME
- CLOCK_HIGHRES
- CLOCK_MONOTONIC
- CLOCK_MONOTONIC_COARSE
- CLOCK_MONOTONIC_FAST
- CLOCK_MONOTONIC_PRECISE
- CLOCK_MONOTONIC_RAW
- CLOCK_PROF
- CLOCK_PROCESS_CPUTIME_ID
- CLOCK_REALTIME
- CLOCK_REALTIME_COARSE
- CLOCK_REALTIME_FAST
- CLOCK_REALTIME_PRECISE
- CLOCK_REALTIME_RAW
- CLOCK_SECOND
- CLOCK_SOFTTIME
- CLOCK_THREAD_CPUTIME_ID
- CLOCK_TIMEOFDAY
- CLOCK_UPTIME
- CLOCK_UPTIME_COARSE
- CLOCK_UPTIME_FAST
- CLOCK_UPTIME_PRECISE
- CLOCK_UPTIME_RAW
- CLOCK_VIRTUAL
- ITIMER_PROF
- ITIMER_REAL
- ITIMER_REALPROF
- ITIMER_VIRTUAL
- TIMER_ABSTIME
- );
+ # TODO: this list is a subset of the @EXPORT_OK in HiRes.pm,
+ # automate this somehow.
+ my @names = qw[
+ CLOCKS_PER_SEC
+ CLOCK_BOOTTIME
+ CLOCK_HIGHRES
+ CLOCK_MONOTONIC
+ CLOCK_MONOTONIC_COARSE
+ CLOCK_MONOTONIC_FAST
+ CLOCK_MONOTONIC_PRECISE
+ CLOCK_MONOTONIC_RAW
+ CLOCK_MONOTONIC_RAW_APPROX
+ CLOCK_PROCESS_CPUTIME_ID
+ CLOCK_PROF
+ CLOCK_REALTIME
+ CLOCK_REALTIME_COARSE
+ CLOCK_REALTIME_FAST
+ CLOCK_REALTIME_PRECISE
+ CLOCK_REALTIME_RAW
+ CLOCK_SECOND
+ CLOCK_SOFTTIME
+ CLOCK_THREAD_CPUTIME_ID
+ CLOCK_TIMEOFDAY
+ CLOCK_UPTIME
+ CLOCK_UPTIME_COARSE
+ CLOCK_UPTIME_FAST
+ CLOCK_UPTIME_PRECISE
+ CLOCK_UPTIME_RAW
+ CLOCK_UPTIME_RAW_APPROX
+ CLOCK_VIRTUAL
+ ITIMER_PROF
+ ITIMER_REAL
+ ITIMER_REALPROF
+ ITIMER_VIRTUAL
+ TIMER_ABSTIME
+ ];
foreach (qw (d_usleep d_ualarm d_gettimeofday d_getitimer d_setitimer
d_nanosleep d_clock_gettime d_clock_getres
d_clock d_clock_nanosleep d_hires_stat
NAMES => \@names,
);
} else {
+ # E.g. perl 5.6 did not have ExtUtils::Constant,
+ # use the pregenerated files instead.
my $file;
foreach $file ('const-c.inc', 'const-xs.inc') {
my $fallback = File::Spec->catfile('fallback', $file);
}
static int
+constant_23 (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_PRECISE CLOCK_THREAD_CPUTIME_ID CLOCK_UPTIME_RAW_APPROX */
+ /* Offset 8 gives the best switch position. */
+ switch (name[8]) {
+ case 'N':
+ if (memEQ(name, "CLOCK_MONOTONIC_PRECISE", 23)) {
+ /* ^ */
+#ifdef CLOCK_MONOTONIC_PRECISE
+ *iv_return = CLOCK_MONOTONIC_PRECISE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'R':
+ if (memEQ(name, "CLOCK_THREAD_CPUTIME_ID", 23)) {
+ /* ^ */
+#ifdef CLOCK_THREAD_CPUTIME_ID
+ *iv_return = CLOCK_THREAD_CPUTIME_ID;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'T':
+ if (memEQ(name, "CLOCK_UPTIME_RAW_APPROX", 23)) {
+ /* ^ */
+#ifdef CLOCK_UPTIME_RAW_APPROX
+ *iv_return = CLOCK_UPTIME_RAW_APPROX;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ }
+ return PERL_constant_NOTFOUND;
+}
+
+static int
constant (pTHX_ const char *name, STRLEN len, IV *iv_return) {
/* Initially switch on the length of the name. */
/* When generated this function returned values for the list of names given
Regenerate these constant functions by feeding this entire source file to
perl -x
-#!/opt/local/perl-5.25.6/bin/perl -w
+#!/opt/local/perl-5.26.1/bin/perl -w
use ExtUtils::Constant qw (constant_types C_constant XS_constant);
my $types = {map {($_, 1)} qw(IV)};
my @names = (qw(CLOCKS_PER_SEC CLOCK_BOOTTIME CLOCK_HIGHRES CLOCK_MONOTONIC
CLOCK_MONOTONIC_COARSE CLOCK_MONOTONIC_FAST
CLOCK_MONOTONIC_PRECISE CLOCK_MONOTONIC_RAW
- CLOCK_PROCESS_CPUTIME_ID CLOCK_PROF CLOCK_REALTIME
- CLOCK_REALTIME_COARSE CLOCK_REALTIME_FAST CLOCK_REALTIME_PRECISE
- CLOCK_REALTIME_RAW CLOCK_SECOND CLOCK_SOFTTIME
- CLOCK_THREAD_CPUTIME_ID CLOCK_TIMEOFDAY CLOCK_UPTIME
- CLOCK_UPTIME_COARSE CLOCK_UPTIME_FAST CLOCK_UPTIME_PRECISE
- CLOCK_UPTIME_RAW CLOCK_VIRTUAL ITIMER_PROF ITIMER_REAL
- ITIMER_REALPROF ITIMER_VIRTUAL TIMER_ABSTIME),
+ CLOCK_MONOTONIC_RAW_APPROX CLOCK_PROCESS_CPUTIME_ID CLOCK_PROF
+ CLOCK_REALTIME CLOCK_REALTIME_COARSE CLOCK_REALTIME_FAST
+ CLOCK_REALTIME_PRECISE CLOCK_REALTIME_RAW CLOCK_SECOND
+ CLOCK_SOFTTIME CLOCK_THREAD_CPUTIME_ID CLOCK_TIMEOFDAY
+ CLOCK_UPTIME CLOCK_UPTIME_COARSE CLOCK_UPTIME_FAST
+ CLOCK_UPTIME_PRECISE CLOCK_UPTIME_RAW CLOCK_UPTIME_RAW_APPROX
+ CLOCK_VIRTUAL ITIMER_PROF ITIMER_REAL ITIMER_REALPROF
+ ITIMER_VIRTUAL TIMER_ABSTIME),
{name=>"d_clock", type=>"IV", macro=>"TIME_HIRES_CLOCK", value=>"1", default=>["IV", "0"]},
{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"]},
}
break;
case 23:
- /* Names all of length 23. */
- /* CLOCK_MONOTONIC_PRECISE CLOCK_THREAD_CPUTIME_ID */
- /* Offset 22 gives the best switch position. */
- switch (name[22]) {
- case 'D':
- if (memEQ(name, "CLOCK_THREAD_CPUTIME_I", 22)) {
- /* D */
-#ifdef CLOCK_THREAD_CPUTIME_ID
- *iv_return = CLOCK_THREAD_CPUTIME_ID;
- return PERL_constant_ISIV;
-#else
- return PERL_constant_NOTDEF;
-#endif
- }
- break;
- case 'E':
- if (memEQ(name, "CLOCK_MONOTONIC_PRECIS", 22)) {
- /* E */
-#ifdef CLOCK_MONOTONIC_PRECISE
- *iv_return = CLOCK_MONOTONIC_PRECISE;
- return PERL_constant_ISIV;
-#else
- return PERL_constant_NOTDEF;
-#endif
- }
- break;
- }
+ return constant_23 (aTHX_ name, iv_return);
break;
case 24:
if (memEQ(name, "CLOCK_PROCESS_CPUTIME_ID", 24)) {
#endif
}
break;
+ case 26:
+ if (memEQ(name, "CLOCK_MONOTONIC_RAW_APPROX", 26)) {
+#ifdef CLOCK_MONOTONIC_RAW_APPROX
+ *iv_return = CLOCK_MONOTONIC_RAW_APPROX;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
}
return PERL_constant_NOTFOUND;
}
use strict;
-use Test::More tests => 2;
+use Test::More tests => 13;
BEGIN { require_ok "Time::HiRes"; }
-my $f = Time::HiRes::tv_interval [5, 100_000], [10, 500_000];
-ok abs($f - 5.4) < 0.001 or print("# $f\n");
+my $d0 = Time::HiRes::tv_interval [5, 100_000], [10, 500_000];
+ok(abs($d0 - 5.4) < 0.001, "10.5 - 5.1 = $d0");
+
+my $d1 = Time::HiRes::tv_interval([], []);
+is($d1, 0, "[] - [] = $d1");
+
+my $t0 = [Time::HiRes::gettimeofday()];
+Time::HiRes::sleep 0.1;
+my $t1 = [Time::HiRes::gettimeofday()];
+my $d2 = Time::HiRes::tv_interval($t1); # NOTE: only one arg.
+
+# This test will fail if between the $t1 and $d2 the time goes backwards:
+# this will happen if the clock is adjusted for example by NTP.
+ok($d2 >= 0, "now - [@$t0] = $d2 >= 0");
+
+my $d3 = Time::HiRes::tv_interval($t0, $t0);
+is($d3, 0, "[@$t0] - [@$t0] = $d3");
+
+my $d4 = Time::HiRes::tv_interval($t0, $t1);
+
+# Compute in Perl what tv_interval() used to do pre-1.9754.
+# This test will fail if too much wallclock time passes between
+# the $t0 and $t1: this can happen in a heavily loaded system.
+my $d5 = ($t1->[0] - $t0->[0]) + ($t1->[1] - $t0->[1]) / 1e6;
+if ($d4 > 0) {
+ my $rd4d5 = $d5 / $d4;
+ ok(abs($rd4d5 - 1) < 0.001, "[@$t1] - [@$t0] = $d4 ($d5, $rd4d5)");
+} else {
+ is($d4, $d5, "$d4 == $d5");
+}
+
+# Then test errorneous inputs.
+
+eval 'Time::HiRes::tv_interval()';
+like($@, qr/Not enough arguments/, "at least one arg");
+
+eval 'Time::HiRes::tv_interval(1)';
+like($@, qr/1st argument should be an array reference/, "1st arg aref");
+
+eval 'Time::HiRes::tv_interval(undef)';
+like($@, qr/1st argument should be an array reference/, "1st arg aref");
+
+eval 'Time::HiRes::tv_interval({})';
+like($@, qr/1st argument should be an array reference/, "1st arg aref");
+
+eval 'Time::HiRes::tv_interval([], 1)';
+like($@, qr/2nd argument should be an array reference/, "2nd arg aref");
+
+eval 'Time::HiRes::tv_interval([], {})';
+like($@, qr/2nd argument should be an array reference/, "2nd arg aref");
+
+# Would be tempting but would probably break some code.
+# eval 'Time::HiRes::tv_interval([], [], [])';
+# like($@, qr/expects two arguments/, "two args");
+
+my $t2 = [Time::HiRes::gettimeofday];
+Time::HiRes::sleep 0.1;
+my $d6 = Time::HiRes::tv_interval($t2);
+# This test originally for long double builds,
+# has considerable flakness potential:
+# (1) if the sleep takes exactly one second (or two, ...)
+# (2) if the floating point operations in tv_interval()
+# come up with a floating point result that does not
+# format as a nicely "terminating" decimal number
+like($d6, qr/\.\d{1,6}$/, "no extra decimals");
1;
https://perl5.git.perl.org / perl5.git / commitdiff