PERFORCE change 12574 for review

Change 12574 by pudge@pudge-mobile on 2001/10/22 18:53:28

	Sync Time::HiRes with bleadperl

Affected files ...

... //depot/maint-5.6/macperl/macos/bundled_ext/Time/HiRes/HiRes.pm#2 edit
... //depot/maint-5.6/macperl/macos/bundled_ext/Time/HiRes/HiRes.t#2 edit
... //depot/maint-5.6/macperl/macos/bundled_ext/Time/HiRes/HiRes.xs#3 edit

Differences ...

==== //depot/maint-5.6/macperl/macos/bundled_ext/Time/HiRes/HiRes.pm#2 (text) ====
Index: perl/macos/bundled_ext/Time/HiRes/HiRes.pm
--- perl/macos/bundled_ext/Time/HiRes/HiRes.pm.~1~	Mon Oct 22 13:00:07 2001
+++ perl/macos/bundled_ext/Time/HiRes/HiRes.pm	Mon Oct 22 13:00:07 2001
@@ -105,8 +105,9 @@
 
 =item usleep ( $useconds )
 
-Issues a usleep for the number of microseconds specified. See also 
-Time::HiRes::sleep() below.
+Issues a usleep for the number of microseconds specified.  Returns the
+number of microseconds actually slept.  See also Time::HiRes::sleep()
+below.
 
 =item ualarm ( $useconds [, $interval_useconds ] )
 
@@ -127,11 +128,27 @@
 resulting in a nice drop-in replacement for the C<time> provided with perl,
 see the EXAMPLES below.
 
+B<NOTE>: Since Sunday, September 9th, 2001 at 01:46:40 AM GMT
+(when the time() seconds since epoch rolled over to 1_000_000_000),
+the default floating point format of Perl and the seconds since epoch
+have conspired to produce an apparent bug: if you print the value of
+Time::HiRes::time() you seem to be getting only five decimals, not six
+as promised (microseconds).  Not to worry, the microseconds are there
+(assuming your platform supports such granularity).  What is going on
+is that the default floating point format of Perl only outputs 15
+digits.  In this case that means ten digits before the decimal
+separator and five after.  To see the microseconds you can use either
+printf/sprintf with C<%.6f>, or the gettimeofday() function in list
+context, which will give you the seconds and microseconds as two
+separate values.
+
 =item sleep ( $floating_seconds )
 
-Converts $floating_seconds to microseconds and issues a usleep for the 
-result.  This function can be imported, resulting in a nice drop-in 
-replacement for the C<sleep> provided with perl, see the EXAMPLES below.
+Converts $floating_seconds to microseconds and issues a usleep for the
+result.  Returns the number of seconds actually slept (a floating
+point value).  This function can be imported, resulting in a nice
+drop-in replacement for the C<sleep> provided with perl, see the
+EXAMPLES below.
 
 =item alarm ( $floating_seconds [, $interval_floating_seconds ] )
 

==== //depot/maint-5.6/macperl/macos/bundled_ext/Time/HiRes/HiRes.t#2 (text) ====
Index: perl/macos/bundled_ext/Time/HiRes/HiRes.t
--- perl/macos/bundled_ext/Time/HiRes/HiRes.t.~1~	Mon Oct 22 13:00:07 2001
+++ perl/macos/bundled_ext/Time/HiRes/HiRes.t	Mon Oct 22 13:00:07 2001
@@ -3,7 +3,7 @@
     @INC = '../lib';
 }
 
-BEGIN { $| = 1; print "1..19\n"; }
+BEGIN { $| = 1; print "1..21\n"; }
 
 END {print "not ok 1\n" unless $loaded;}
 
@@ -86,7 +86,7 @@
 # Two-arg tv_interval() is always available.
 {
     my $f = tv_interval [5, 100_000], [10, 500_000];
-    ok 9, $f == 5.4, $f;
+    ok 9, abs($f - 5.4) < 0.001, $f;
 }
 
 if (!$have_gettimeofday) {
@@ -133,10 +133,16 @@
 if (!$have_time) {
     skip 14
 } else {
- my $t = time();
- my $tf = Time::HiRes::time();
- ok 14, (abs($tf - $t) <= 1),
-  "time $t differs from Time::HiRes::time $tf";
+ my ($t1, $tf, $t2);
+ for my $i (1 .. 9) {
+     $t1 = time();
+     $tf = Time::HiRes::time();
+     $t2 = 1 + time();
+     last if (($t2 - $t1) <= 1);
+ }
+ ok 14, (($t1 <= $tf) && ($tf <= $t2)),
+      "Time::HiRes::time $tf not bracketed by $t1 - $t2";
+
 }
 
 unless (defined &Time::HiRes::gettimeofday
@@ -217,3 +223,9 @@
     $SIG{VTALRM} = 'DEFAULT';
 }
 
+$a = abs(sleep(1.5)                    - 1.5);
+print $a < 0.1 ? "ok 20 # $a\n" : "not ok 20 # $a\n";
+
+$a = abs(usleep(1_500_000) / 1_500_000 - 1.0);
+print $a < 0.1 ? "ok 21 # $a\n" : "not ok 21 # $a\n";
+

==== //depot/maint-5.6/macperl/macos/bundled_ext/Time/HiRes/HiRes.xs#3 (text) ====
Index: perl/macos/bundled_ext/Time/HiRes/HiRes.xs
--- perl/macos/bundled_ext/Time/HiRes/HiRes.xs.~1~	Mon Oct 22 13:00:07 2001
+++ perl/macos/bundled_ext/Time/HiRes/HiRes.xs	Mon Oct 22 13:00:07 2001
@@ -63,31 +63,38 @@
 }
 */
 
+typedef union {
+    unsigned __int64	ft_i64;
+    FILETIME		ft_val;
+} FT_t;
+
+/* Number of 100 nanosecond units from 1/1/1601 to 1/1/1970 */
+#define EPOCH_BIAS  116444736000000000i64
+
+/* NOTE: This does not compute the timezone info (doing so can be expensive,
+ * and appears to be unsupported even by glibc) */
 int
-gettimeofday (struct timeval *tp, int nothing)
+gettimeofday (struct timeval *tp, void *not_used)
 {
- SYSTEMTIME st;
- time_t tt;
- struct tm tmtm;
- /* mktime converts local to UTC */
- GetLocalTime (&st);
- tmtm.tm_sec = st.wSecond;
- tmtm.tm_min = st.wMinute;
- tmtm.tm_hour = st.wHour;
- tmtm.tm_mday = st.wDay;
- tmtm.tm_mon = st.wMonth - 1;
- tmtm.tm_year = st.wYear - 1900;
- tmtm.tm_isdst = -1;
- tt = mktime (&tmtm);
- tp->tv_sec = tt;
- tp->tv_usec = st.wMilliseconds * 1000;
- return 0;
+    FT_t ft;
+
+    /* this returns time in 100-nanosecond units  (i.e. tens of usecs) */
+    GetSystemTimeAsFileTime(&ft.ft_val);
+
+    /* seconds since epoch */
+    tp->tv_sec = (long)((ft.ft_i64 - EPOCH_BIAS) / 10000000i64);
+
+    /* microseconds remaining */
+    tp->tv_usec = (long)((ft.ft_i64 / 10i64) % 1000000i64);
+
+    return 0;
 }
 #endif
 
 #if !defined(HAS_GETTIMEOFDAY) && defined(VMS)
 #define HAS_GETTIMEOFDAY
 
+#include <lnmdef.h>
 #include <time.h> /* gettimeofday */
 #include <stdlib.h> /* qdiv */
 #include <starlet.h> /* sys$gettim */
@@ -116,6 +123,90 @@
 static __int64 base_adjust=0;
 #endif
 
+/* 
+
+   If we don't have gettimeofday, then likely we are on a VMS machine that
+   operates on local time rather than UTC...so we have to zone-adjust.
+   This code gleefully swiped from VMS.C 
+
+*/
+/* method used to handle UTC conversions:
+ *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
+ */
+static int gmtime_emulation_type;
+/* number of secs to add to UTC POSIX-style time to get local time */
+static long int utc_offset_secs;
+static struct dsc$descriptor_s fildevdsc = 
+  { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
+static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
+
+static time_t toutc_dst(time_t loc) {
+  struct tm *rsltmp;
+
+  if ((rsltmp = localtime(&loc)) == NULL) return -1;
+  loc -= utc_offset_secs;
+  if (rsltmp->tm_isdst) loc -= 3600;
+  return loc;
+}
+
+static time_t toloc_dst(time_t utc) {
+  struct tm *rsltmp;
+
+  utc += utc_offset_secs;
+  if ((rsltmp = localtime(&utc)) == NULL) return -1;
+  if (rsltmp->tm_isdst) utc += 3600;
+  return utc;
+}
+
+#define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
+       ((gmtime_emulation_type || timezone_setup()), \
+       (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
+       ((secs) - utc_offset_secs))))
+
+#define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
+       ((gmtime_emulation_type || timezone_setup()), \
+       (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
+       ((secs) + utc_offset_secs))))
+
+static int
+timezone_setup(void) 
+{
+  struct tm *tm_p;
+
+  if (gmtime_emulation_type == 0) {
+    int dstnow;
+    time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
+                              /* results of calls to gmtime() and localtime() */
+                              /* for same &base */
+
+    gmtime_emulation_type++;
+    if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
+      char off[LNM$C_NAMLENGTH+1];;
+
+      gmtime_emulation_type++;
+      if (!Perl_vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
+        gmtime_emulation_type++;
+        utc_offset_secs = 0;
+        Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
+      }
+      else { utc_offset_secs = atol(off); }
+    }
+    else { /* We've got a working gmtime() */
+      struct tm gmt, local;
+
+      gmt = *tm_p;
+      tm_p = localtime(&base);
+      local = *tm_p;
+      utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
+      utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
+      utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
+      utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
+    }
+  }
+  return 1;
+}
+
+
 int
 gettimeofday (struct timeval *tp, void *tpz)
 {
@@ -175,6 +266,13 @@
         tp->tv_sec = ret;
         return -1;
  }
+# ifdef VMSISH_TIME
+# ifdef RTL_USES_UTC
+  if (VMSISH_TIME) tp->tv_sec = _toloc(tp->tv_sec);
+# else
+  if (!VMSISH_TIME) tp->tv_sec = _toutc(tp->tv_sec);
+# endif
+# endif
  return 0;
 }
 #endif
@@ -269,18 +367,54 @@
 	char *		name
 	int		arg
 
-#ifdef HAS_USLEEP
+#if defined(HAS_USLEEP) && defined(HAS_GETTIMEOFDAY)
 
-void
+NV
 usleep(useconds)
-        int useconds 
+        NV useconds
+	PREINIT:
+	struct timeval Ta, Tb;
+	CODE:
+	gettimeofday(&Ta, NULL);
+	if (items > 0) {
+	    if (useconds > 1E6) {
+		IV seconds = (IV) (useconds / 1E6);
+		sleep(seconds);
+		useconds -= 1E6 * seconds;
+	    }
+	    usleep((UV)useconds);
+	} else
+	    PerlProc_pause();
+	gettimeofday(&Tb, NULL);
+#if 0
+	printf("[%ld %ld] [%ld %ld]\n", Tb.tv_sec, Tb.tv_usec, Ta.tv_sec, Ta.tv_usec);
+#endif
+	RETVAL = 1E6*(Tb.tv_sec-Ta.tv_sec)+(NV)((IV)Tb.tv_usec-(IV)Ta.tv_usec);
+
+	OUTPUT:
+	RETVAL
 
-void
-sleep(fseconds)
-        NV fseconds 
+NV
+sleep(...)
+	PREINIT:
+	struct timeval Ta, Tb;
 	CODE:
-	int useconds = fseconds * 1000000;
-	usleep (useconds);
+	gettimeofday(&Ta, NULL);
+	if (items > 0) {
+	    NV seconds  = SvNV(ST(0));
+	    IV useconds = 1E6 * (seconds - (IV)seconds);
+	    sleep(seconds);
+	    usleep(useconds);
+	} else
+	    PerlProc_pause();
+	gettimeofday(&Tb, NULL);
+#if 0
+	printf("[%ld %ld] [%ld %ld]\n", Tb.tv_sec, Tb.tv_usec, Ta.tv_sec, Ta.tv_usec);
+#endif
+	RETVAL = (NV)(Tb.tv_sec-Ta.tv_sec)+0.000001*(NV)(Tb.tv_usec-Ta.tv_usec);
+
+	OUTPUT:
+	RETVAL
 
 #endif
 
End of Patch.