This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Upgrade to Time-HiRes-1.92.
authorSteve Peters <steve@fisharerojo.org>
Fri, 13 Oct 2006 14:11:04 +0000 (14:11 +0000)
committerSteve Peters <steve@fisharerojo.org>
Fri, 13 Oct 2006 14:11:04 +0000 (14:11 +0000)
p4raw-id: //depot/perl@29010

MANIFEST
ext/Time/HiRes/Changes
ext/Time/HiRes/HiRes.pm
ext/Time/HiRes/HiRes.xs
ext/Time/HiRes/Makefile.PL
ext/Time/HiRes/hints/aix.pl [new file with mode: 0644]
ext/Time/HiRes/t/HiRes.t

index 1a4b163..3a2cbb5 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -1168,6 +1168,7 @@ ext/Thread/unsync.tx              Test thread implicit synchronisation
 ext/Time/HiRes/Changes         Time::HiRes extension
 ext/Time/HiRes/fallback/const-c.inc    Time::HiRes extension
 ext/Time/HiRes/fallback/const-xs.inc   Time::HiRes extension
+ext/Time/HiRes/hints/aix.pl    Hint for Time::HiRes for named architecture
 ext/Time/HiRes/hints/dec_osf.pl                Hint for Time::HiRes for named architecture
 ext/Time/HiRes/hints/dynixptx.pl       Hint for Time::HiRes for named architecture
 ext/Time/HiRes/hints/irix.pl   Hint for Time::HiRes for named architecture
index b878c28..07aed02 100644 (file)
@@ -1,11 +1,51 @@
-Revision history for Perl extension Time::HiRes.
+Revision history for the Perl extension Time::HiRes.
 
-1.91   [2006-09-28]
+1.92   [2006-10-13]
+       - scan for subsecond resolution timestamps in struct stat,
+         some known possibilities:
+
+         (1)  struct  timespec st_atimespec;
+                                st_atimespec.tv_nsec;
+         (2)  time_t  st_atime;
+              long    st_atimensec;
+          (3)  time_t  st_atime;
+               int     st_atime_n;
+         (4)  timestruc_t st_atim;
+                           st_atim.tv_nsec
+         (5)  time_t  st_atime;
+               int     st_uatime;
+
+          If something like this is found, one can do
+
+           use Time::HiRes;
+           my @stat = Time::HiRes::stat();
+
+         or even override the standard stat():
+      
+           use Time::HiRes qw(stat);
+
+          to get the stat() timestamps
+
+           my ($atime, $mtime, $ctime) = @stat[8, 9, 10];
+
+         with subsecond resolution (assuming both the operating
+         system and the filesystem support that kind of thing).
+
+         Contributions for more systems (especially non-UNIX,
+         e.g. but not limited to, Win32, VMS) gladly accepted.
+
+         Thanks to H.Merijn Brand, John Peacock, and Craig
+         Berry for brave beta testing.
+
+1.91   [2006-09-29]
        - ualarm() in SuSE 10.1 was overflowing after ~4.2 seconds,
-         probably due to a glibc bug/feature, workaround by using the
-         setitimer() variant if either useconds or interval >= IV_1E6
-         (this case seems to vary between systems: are useconds
-          more than 999_999 for ualarm() defined or not)
+         possibly due to a glibc bug/feature, workaround by using the
+         setitimer() implementation of ualarm() if either useconds or
+         interval > 999_999 (this case seems to vary between systems:
+         are useconds more than 999_999 for ualarm() defined or not)
+         Added more ualarm() tests to catch various overflow points,
+         hopefully no problems in various platforms.
+         (The problem report by Mark Seger and Jon Paul Sullivan of HP.)
 
 1.90   [2006-08-22]
        - tweak still needed for Const64(), from Jerry Hedden
@@ -16,7 +56,8 @@ Revision history for Perl extension Time::HiRes.
        - Const64() already appends an 'LL' (or i64), so provide LL and i64
          forms for the IV_1E[679] (effects Win32 and Cygwin), reported by
          Jerry Hedden.
-       - the Changes entry for 1.88 talked about [IN]V_1[679], missing the 'E'.
+       - the Changes entry for 1.88 talked about [IN]V_1[679],
+         missing the 'E'.
 
 1.88   [2006-08-21]
        - clean up the g++ warnings in HiRes.xs, all of them
index b975262..1824183 100644 (file)
@@ -19,9 +19,11 @@ require DynaLoader;
                 TIMER_ABSTIME
                 d_usleep d_ualarm d_gettimeofday d_getitimer d_setitimer
                 d_nanosleep d_clock_gettime d_clock_getres
-                d_clock d_clock_nanosleep);
+                d_clock d_clock_nanosleep
+                stat
+               );
        
-$VERSION = '1.91';
+$VERSION = '1.92';
 $XS_VERSION = $VERSION;
 $VERSION = eval $VERSION;
 
@@ -83,7 +85,8 @@ Time::HiRes - High resolution alarm, sleep, gettimeofday, interval timers
 =head1 SYNOPSIS
 
   use Time::HiRes qw( usleep ualarm gettimeofday tv_interval nanosleep
-                     clock_gettime clock_getres clock_nanosleep clock );
+                     clock_gettime clock_getres clock_nanosleep clock
+                      stat );
 
   usleep ($microseconds);
   nanosleep ($nanoseconds);
@@ -119,6 +122,8 @@ Time::HiRes - High resolution alarm, sleep, gettimeofday, interval timers
 
   my $ticktock = clock();
 
+  my @stat = stat(FH);
+
 =head1 DESCRIPTION
 
 The C<Time::HiRes> module implements a Perl interface to the
@@ -357,6 +362,31 @@ but not necessarily identical.  Note that due to backward
 compatibility limitations the returned value may wrap around at about
 2147 seconds or at about 36 minutes.
 
+=item stat
+
+=item stat FH
+
+=item stat EXPR
+
+As L<perlfunc/stat> but with the access/modify/change file timestamps
+in subsecond resolution, if the operating system and the filesystem
+both support such timestamps.  To override the standard stat():
+
+    use Time::HiRes qw(stat);
+
+Test for the value of &Time::HiRes::d_hires_stat to find out whether
+the operating system supports subsecond file timestamps: a value
+larger than zero means yes. There are unfortunately no easy
+ways to find out whether the filesystem supports such timestamps.
+
+A zero return value of &Time::HiRes::d_hires_stat means that
+Time::HiRes::stat is a no-op passthrough for CORE::stat(),
+and therefore the timestamps will stay integers.  The same
+will happen if the filesystem does not do subsecond timestamps.
+
+In any case do not expect nanosecond resolution, or even a microsecond
+resolution.
+
 =back
 
 =head1 EXAMPLES
index c27c563..f1029f0 100644 (file)
@@ -479,6 +479,13 @@ hrt_ualarm_itimer(int usec, int interval)
    itv.it_interval.tv_usec = interval % IV_1E6;
    return setitimer(ITIMER_REAL, &itv, 0);
 }
+#ifdef HAS_UALARM
+int
+hrt_ualarm(int usec, int interval) /* for binary compat before 1.91 */
+{
+   return hrt_ualarm_itimer(usec, interval);
+}
+#endif /* #ifdef HAS_UALARM */
 #endif /* #if !defined(HAS_UALARM) && defined(HAS_SETITIMER) */
 
 #if !defined(HAS_UALARM) && defined(HAS_SETITIMER)
@@ -710,6 +717,42 @@ myNVtime()
 
 #endif /* #ifdef HAS_GETTIMEOFDAY */
 
+static void
+hrstatns(UV atime, UV mtime, UV ctime, UV *atime_nsec, UV *mtime_nsec, UV *ctime_nsec)
+{
+  dTHX;
+  *atime_nsec = 0;
+  *mtime_nsec = 0;
+  *ctime_nsec = 0;
+#ifdef TIME_HIRES_STAT
+#if TIME_HIRES_STAT == 1
+  *atime_nsec = PL_statcache.st_atimespec.tv_nsec;
+  *mtime_nsec = PL_statcache.st_mtimespec.tv_nsec;
+  *ctime_nsec = PL_statcache.st_ctimespec.tv_nsec;
+#endif
+#if TIME_HIRES_STAT == 2
+  *atime_nsec = PL_statcache.st_atimensec;
+  *mtime_nsec = PL_statcache.st_mtimensec;
+  *ctime_nsec = PL_statcache.st_ctimensec;
+#endif
+#if TIME_HIRES_STAT == 3
+  *atime_nsec = PL_statcache.st_atime_n;
+  *mtime_nsec = PL_statcache.st_mtime_n;
+  *ctime_nsec = PL_statcache.st_ctime_n;
+#endif
+#if TIME_HIRES_STAT == 4
+  *atime_nsec = PL_statcache.st_atim.tv_nsec;
+  *mtime_nsec = PL_statcache.st_mtim.tv_nsec;
+  *ctime_nsec = PL_statcache.st_ctim.tv_nsec;
+#endif
+#if TIME_HIRES_STAT == 5
+  *atime_nsec = PL_statcache.st_uatime * 1000;
+  *mtime_nsec = PL_statcache.st_umtime * 1000;
+  *ctime_nsec = PL_statcache.st_uctime * 1000;
+#endif
+#endif
+}
+
 #include "const-c.inc"
 
 MODULE = Time::HiRes            PACKAGE = Time::HiRes
@@ -1166,3 +1209,34 @@ clock()
 
 #endif /*  #if defined(TIME_HIRES_CLOCK) && defined(CLOCKS_PER_SEC) */
 
+IV
+stat(...)
+PROTOTYPE: ;$
+    PPCODE:
+       PUSHMARK(SP);
+       XPUSHs(sv_2mortal(newSVsv(items == 1 ? ST(0) : DEFSV)));
+       PUTBACK;
+       ENTER;
+       PL_laststatval = -1;
+       (void)*(PL_ppaddr[OP_STAT])(aTHX);
+       SPAGAIN;
+       LEAVE;
+       if (PL_laststatval == 0) {
+         /* We assume that pp_stat() left us with 13 valid stack items. */
+         UV atime = SvUV(ST( 8));
+         UV mtime = SvUV(ST( 9));
+         UV ctime = SvUV(ST(10));
+         UV atime_nsec;
+         UV mtime_nsec;
+         UV ctime_nsec;
+         hrstatns(atime, mtime, ctime,
+                  &atime_nsec, &mtime_nsec, &ctime_nsec);
+         if (atime_nsec)
+           ST( 8) = sv_2mortal(newSVnv(atime + 1e-9 * (NV) atime_nsec));
+         if (mtime_nsec)
+           ST( 9) = sv_2mortal(newSVnv(mtime + 1e-9 * (NV) mtime_nsec));
+         if (ctime_nsec)
+           ST(10) = sv_2mortal(newSVnv(ctime + 1e-9 * (NV) ctime_nsec));
+         XSRETURN(13);
+       }
+       XSRETURN(0);
index 5e54b49..115cea3 100644 (file)
@@ -169,24 +169,26 @@ EOF
     return $ok;
 }
 
-sub has_gettimeofday {
-    # confusing but true (if condition true ==> -DHAS_GETTIMEOFDAY already)
-    return 0 if $Config{d_gettimeod};
-    return 1 if try_compile_and_link(<<EOM);
+my $TIME_HEADERS = <<EOH;
 #include "EXTERN.h"
 #include "perl.h"
 #include "XSUB.h"
 #ifdef I_SYS_TYPES
 #   include <sys/types.h>
 #endif
-
 #ifdef I_SYS_TIME
 #   include <sys/time.h>
 #endif
-
 #ifdef I_SYS_SELECT
 #   include <sys/select.h>     /* struct timeval might be hidden in here */
 #endif
+EOH
+
+sub has_gettimeofday {
+    # confusing but true (if condition true ==> -DHAS_GETTIMEOFDAY already)
+    return 0 if $Config{d_gettimeod};
+    return 1 if try_compile_and_link(<<EOM);
+$TIME_HEADERS
 static int foo()
 {
     struct timeval tv;
@@ -589,6 +591,113 @@ EOD
        print "NOT found.\n";
     }
 
+    print "Trying struct stat st_atimespec.tv_nsec...";
+    my $has_stat_st_xtimespec;
+    if (try_compile_and_link(<<EOM)) {
+$TIME_HEADERS
+#include <sys/stat.h>
+int main() {
+    struct stat st;
+    st.st_atimespec.tv_nsec = 0;
+}
+EOM
+      $has_stat_st_xtimespec++;
+      $DEFINE .= ' -DTIME_HIRES_STAT=1';
+    }
+
+    if ($has_stat_st_xtimespec) {
+        print "found.\n";
+    } else {
+       print "NOT found.\n";
+    }
+
+    print "Trying struct stat st_atimensec...";
+    my $has_stat_st_xtimensec;
+    if (try_compile_and_link(<<EOM)) {
+$TIME_HEADERS
+#include <sys/stat.h>
+int main() {
+    struct stat st;
+    st.st_atimensec = 0;
+}
+EOM
+      $has_stat_st_xtimensec++;
+      $DEFINE .= ' -DTIME_HIRES_STAT=2';
+    }
+
+    if ($has_stat_st_xtimensec) {
+        print "found.\n";
+    } else {
+       print "NOT found.\n";
+    }
+
+    print "Trying struct stat st_atime_n...";
+    my $has_stat_st_xtime_n;
+    if (try_compile_and_link(<<EOM)) {
+$TIME_HEADERS
+#include <sys/stat.h>
+int main() {
+    struct stat st;
+    st.st_atime_n = 0;
+}
+EOM
+      $has_stat_st_xtime_n++;
+      $DEFINE .= ' -DTIME_HIRES_STAT=3';
+    }
+
+    if ($has_stat_st_xtime_n) {
+        print "found.\n";
+    } else {
+       print "NOT found.\n";
+    }
+
+    print "Trying struct stat st_atim.tv_nsec...";
+    my $has_stat_st_xtim;
+    if (try_compile_and_link(<<EOM)) {
+$TIME_HEADERS
+#include <sys/stat.h>
+int main() {
+    struct stat st;
+    st.st_atim.tv_nsec = 0;
+}
+EOM
+      $has_stat_st_xtim++;
+      $DEFINE .= ' -DTIME_HIRES_STAT=4';
+    }
+
+    if ($has_stat_st_xtim) {
+        print "found.\n";
+    } else {
+       print "NOT found.\n";
+    }
+
+    print "Trying struct stat st_uatime...";
+    my $has_stat_st_uxtime;
+    if (try_compile_and_link(<<EOM)) {
+$TIME_HEADERS
+#include <sys/stat.h>
+int main() {
+    struct stat st;
+    st.st_uatime = 0;
+}
+EOM
+      $has_stat_st_uxtime++;
+      $DEFINE .= ' -DTIME_HIRES_STAT=5';
+    }
+
+    if ($has_stat_st_uxtime) {
+        print "found.\n";
+    } else {
+       print "NOT found.\n";
+    }
+
+   if ($DEFINE =~ /-DTIME_HIRES_STAT=\d+/) {
+    print "You seem to have stat subsecond timestamps.\n";
+    print "(Your struct stat has them, but the filesystems must help.)\n";
+   } else {
+    print "You do not seem to have stat subsecond timestamps.\n";
+   }
+
     my $has_w32api_windows_h;
 
     if ($^O eq 'cygwin') {
@@ -652,22 +761,28 @@ sub doMakefile {
 
 sub doConstants {
     if (eval {require ExtUtils::Constant; 1}) {
-       my @names = (qw(CLOCK_HIGHRES CLOCK_MONOTONIC
-                       CLOCK_PROCESS_CPUTIME_ID
-                       CLOCK_REALTIME
-                       CLOCK_SOFTTIME
-                       CLOCK_THREAD_CPUTIME_ID
-                       CLOCK_TIMEOFDAY
-                       CLOCKS_PER_SEC
-                       ITIMER_REAL ITIMER_VIRTUAL ITIMER_PROF
-                       ITIMER_REALPROF
-                       TIMER_ABSTIME));
+       my @names = qw(CLOCK_HIGHRES CLOCK_MONOTONIC
+                      CLOCK_PROCESS_CPUTIME_ID
+                      CLOCK_REALTIME
+                      CLOCK_SOFTTIME
+                      CLOCK_THREAD_CPUTIME_ID
+                      CLOCK_TIMEOFDAY
+                      CLOCKS_PER_SEC
+                      ITIMER_REAL ITIMER_VIRTUAL ITIMER_PROF
+                      ITIMER_REALPROF
+                      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_clock d_clock_nanosleep d_hires_stat)) {
            my $macro = $_;
            if ($macro =~ /^(d_nanosleep|d_clock_gettime|d_clock_getres|d_clock|d_clock_nanosleep)$/) {
                $macro =~ s/^d_(.+)/TIME_HIRES_\U$1/;
+           } elsif ($macro =~ /^(d_hires_stat)$/) {
+               my $d_hires_stat = 0;
+               $d_hires_stat = $1 if ($DEFINE =~ /-DTIME_HIRES_STAT=(\d+)/);
+               push @names, {name => $_, macro => "TIME_HIRES_STAT", value => $d_hires_stat,
+                             default => ["IV", "0"]};
+               next;
            } else {
                $macro =~ s/^d_(.+)/HAS_\U$1/;
            }
diff --git a/ext/Time/HiRes/hints/aix.pl b/ext/Time/HiRes/hints/aix.pl
new file mode 100644 (file)
index 0000000..bbb7fa8
--- /dev/null
@@ -0,0 +1,18 @@
+# Many AIX installations seem not to have the right PATH
+# for the C compiler.  Steal the logic from Perl's hints/aix.sh.
+use Config;
+unless ($Config{gccversion}) {
+    my $cc = $Config{cc};
+    if (! -x $cc && -x "/usr/vac/bin/$cc") {
+       unless (":$ENV{PATH}:" =~ m{:/usr/vac/bin:}) {
+           die <<__EOE__;
+***
+*** You either implicitly or explicitly specified an IBM C compiler,
+*** but you do not seem to have one in /usr/bin, but you seem to have
+*** the VAC installed in /usr/vac, but you do not have the /usr/vac/bin
+*** in your PATH.  I suggest adding that and retrying Makefile.PL.
+***
+__EOE__
+       }
+    }
+}
index cae9889..3ac0ca1 100644 (file)
@@ -12,7 +12,7 @@ BEGIN {
     }
 }
 
-BEGIN { $| = 1; print "1..33\n"; }
+BEGIN { $| = 1; print "1..38\n"; }
 
 END { print "not ok 1\n" unless $loaded }
 
@@ -32,6 +32,7 @@ my $have_clock_gettime         = &Time::HiRes::d_clock_gettime;
 my $have_clock_getres   = &Time::HiRes::d_clock_getres;
 my $have_clock_nanosleep = &Time::HiRes::d_clock_nanosleep;
 my $have_clock           = &Time::HiRes::d_clock;
+my $have_hires_stat      = &Time::HiRes::d_hires_stat;
 
 sub has_symbol {
     my $symbol = shift;
@@ -49,6 +50,7 @@ printf "# have_clock_gettime   = %d\n", $have_clock_gettime;
 printf "# have_clock_getres    = %d\n", $have_clock_getres;
 printf "# have_clock_nanosleep = %d\n", $have_clock_nanosleep;
 printf "# have_clock           = %d\n", $have_clock;
+printf "# have_hires_stat      = %d\n", $have_hires_stat;
 
 import Time::HiRes 'gettimeofday'      if $have_gettimeofday;
 import Time::HiRes 'usleep'            if $have_usleep;
@@ -65,7 +67,7 @@ use Time::HiRes qw(gettimeofday);
 
 my $have_alarm = $Config{d_alarm};
 my $have_fork  = $Config{d_fork};
-my $waitfor = 60; # 10-20 seconds is normal (load affects this).
+my $waitfor = 90; # 30-45 seconds is normal (load affects this).
 my $timer_pid;
 my $TheEnd;
 
@@ -584,10 +586,80 @@ if ($have_clock) {
        print "not ok 33\n";
     }
 } else {
-    print "# No clock\n";
     skip 33;
 }
 
+if ($have_ualarm) {
+    # 1_100_000 sligthly over 1_000_000,
+    # 2_200_000 slightly over 2**31/1000,
+    # 4_300_000 slightly over 2**32/1000.
+    for my $t ([34, 100_000],
+              [35, 1_100_000],
+              [36, 2_200_000],
+              [37, 4_300_000]) {
+       my ($i, $n) = @$t;
+       my $alarmed = 0;
+       local $SIG{ ALRM } = sub { $alarmed++ };
+       my $t0 = Time::HiRes::time();
+       print "# t0 = $t0\n";
+       print "# ualarm($n)\n";
+       ualarm($n); 1 while $alarmed == 0;
+       my $t1 = Time::HiRes::time();
+       print "# t1 = $t1\n";
+       my $dt = $t1 - $t0;
+       print "# dt = $dt\n";
+       ok $i, $dt >= $n/1e6 &&
+           ($n < 1_000_000 # Too much noise.
+            || $dt <= 1.5*$n/1e6), "ualarm($n) close enough";
+    }
+} else {
+    print "# No ualarm\n";
+    skip 34..37;
+}
+
+if (&Time::HiRes::d_hires_stat) {
+    my @stat;
+    my @time;
+    for (1..5) {
+       Time::HiRes::sleep(rand(0.1) + 0.1);
+       open(X, ">$$");
+       print X $$;
+       close(X);
+       @stat = Time::HiRes::stat($$);
+       push @time, $stat[9];
+       Time::HiRes::sleep(rand(0.1) + 0.1);
+       open(X, "<$$");
+       <X>;
+       close(X);
+       @stat = Time::HiRes::stat($$);
+       push @time, $stat[8];
+    }
+    1 while unlink $$;
+    print "# @time\n";
+    my $mi = 1;
+    my $ss = 0;
+    for (my $i = 1; $i < @time; $i++) {
+       if ($time[$i] > $time[$i-1]) {
+           $mi++;
+       }
+       if ($time[$i] > int($time[$i])) {
+           $ss++;
+       }
+    }
+    # Need at least 80% of monotonical increase and subsecond results.
+    if ($ss == 0) {
+       print "# No subsecond timestamps detected\n";
+       skip 38;
+    } elsif ($mi/@time > 0.8 && $ss/@time > 0.8) {
+       print "ok 38\n";
+    } else {
+       print "not ok 38\n";
+    }
+} else {
+    print "# No effectual d_hires_stat\n";
+    skip 38;
+}
+
 END {
     if ($timer_pid) { # Only in the main process.
        my $left = $TheEnd - time();