ext/Time/HiRes/HiRes.xs

   1 #ifdef __cplusplus
   2 extern "C" {
   3 #endif
   4 #define PERL_NO_GET_CONTEXT
   5 #include "EXTERN.h"
   6 #include "perl.h"
   7 #include "XSUB.h"
   8 #include "ppport.h"
   9 #if defined(__CYGWIN__) && defined(HAS_W32API_WINDOWS_H)
  10 # include <w32api/windows.h>
  11 # define CYGWIN_WITH_W32API
  12 #endif
  13 #ifdef WIN32
  14 # include <time.h>
  15 #else
  16 # include <sys/time.h>
  17 #endif
  18 #ifdef HAS_SELECT
  19 # ifdef I_SYS_SELECT
  20 #  include <sys/select.h>
  21 # endif
  22 #endif
  23 #ifdef __cplusplus
  24 }
  25 #endif
  26
  27 #ifndef PerlProc_pause
  28 #   define PerlProc_pause() Pause()
  29 #endif
  30
  31 #ifdef HAS_PAUSE
  32 #   define Pause   pause
  33 #else
  34 #   undef Pause /* In case perl.h did it already. */
  35 #   define Pause() sleep(~0) /* Zzz for a long time. */
  36 #endif
  37
  38 /* Though the cpp define ITIMER_VIRTUAL is available the functionality
  39  * is not supported in Cygwin as of August 2004, ditto for Win32.
  40  * Neither are ITIMER_PROF or ITIMER_REALPROF implemented.  --jhi
  41  */
  42 #if defined(__CYGWIN__) || defined(WIN32)
  43 #   undef ITIMER_VIRTUAL
  44 #   undef ITIMER_PROF
  45 #   undef ITIMER_REALPROF
  46 #endif
  47
  48 /* 5.004 doesn't define PL_sv_undef */
  49 #ifndef ATLEASTFIVEOHOHFIVE
  50 # ifndef PL_sv_undef
  51 #  define PL_sv_undef sv_undef
  52 # endif
  53 #endif
  54
  55 #include "const-c.inc"
  56
  57 #if defined(WIN32) || defined(CYGWIN_WITH_W32API)
  58
  59 #ifndef HAS_GETTIMEOFDAY
  60 #   define HAS_GETTIMEOFDAY
  61 #endif
  62
  63 /* shows up in winsock.h?
  64 struct timeval {
  65  long tv_sec;
  66  long tv_usec;
  67 }
  68 */
  69
  70 typedef union {
  71     unsigned __int64    ft_i64;
  72     FILETIME            ft_val;
  73 } FT_t;
  74
  75 #define MY_CXT_KEY "Time::HiRes_" XS_VERSION
  76
  77 typedef struct {
  78     unsigned long run_count;
  79     unsigned __int64 base_ticks;
  80     unsigned __int64 tick_frequency;
  81     FT_t base_systime_as_filetime;
  82     unsigned __int64 reset_time;
  83 } my_cxt_t;
  84
  85 START_MY_CXT
  86
  87 /* Number of 100 nanosecond units from 1/1/1601 to 1/1/1970 */
  88 #ifdef __GNUC__
  89 # define Const64(x) x##LL
  90 #else
  91 # define Const64(x) x##i64
  92 #endif
  93 #define EPOCH_BIAS  Const64(116444736000000000)
  94
  95 /* NOTE: This does not compute the timezone info (doing so can be expensive,
  96  * and appears to be unsupported even by glibc) */
  97
  98 /* dMY_CXT needs a Perl context and we don't want to call PERL_GET_CONTEXT
  99    for performance reasons */
 100
 101 #undef gettimeofday
 102 #define gettimeofday(tp, not_used) _gettimeofday(aTHX_ tp, not_used)
 103
 104 /* If the performance counter delta drifts more than 0.5 seconds from the
 105  * system time then we recalibrate to the system time.  This means we may
 106  * move *backwards* in time! */
 107 #define MAX_PERF_COUNTER_SKEW Const64(5000000) /* 0.5 seconds */
 108
 109 /* Reset reading from the performance counter every five minutes.
 110  * Many PC clocks just seem to be so bad. */
 111 #define MAX_PERF_COUNTER_TICKS Const64(300000000) /* 300 seconds */
 112
 113 static int
 114 _gettimeofday(pTHX_ struct timeval *tp, void *not_used)
 115 {
 116     dMY_CXT;
 117
 118     unsigned __int64 ticks;
 119     FT_t ft;
 120
 121     if (MY_CXT.run_count++ == 0 ||
 122         MY_CXT.base_systime_as_filetime.ft_i64 > MY_CXT.reset_time) {
 123         QueryPerformanceFrequency((LARGE_INTEGER*)&MY_CXT.tick_frequency);
 124         QueryPerformanceCounter((LARGE_INTEGER*)&MY_CXT.base_ticks);
 125         GetSystemTimeAsFileTime(&MY_CXT.base_systime_as_filetime.ft_val);
 126         ft.ft_i64 = MY_CXT.base_systime_as_filetime.ft_i64;
 127         MY_CXT.reset_time = ft.ft_i64 + MAX_PERF_COUNTER_TICKS;
 128     }
 129     else {
 130         __int64 diff;
 131         QueryPerformanceCounter((LARGE_INTEGER*)&ticks);
 132         ticks -= MY_CXT.base_ticks;
 133         ft.ft_i64 = MY_CXT.base_systime_as_filetime.ft_i64
 134                     + Const64(10000000) * (ticks / MY_CXT.tick_frequency)
 135                     +(Const64(10000000) * (ticks % MY_CXT.tick_frequency)) / MY_CXT.tick_frequency;
 136         diff = ft.ft_i64 - MY_CXT.base_systime_as_filetime.ft_i64;
 137         if (diff < -MAX_PERF_COUNTER_SKEW || diff > MAX_PERF_COUNTER_SKEW) {
 138             MY_CXT.base_ticks += ticks;
 139             GetSystemTimeAsFileTime(&MY_CXT.base_systime_as_filetime.ft_val);
 140             ft.ft_i64 = MY_CXT.base_systime_as_filetime.ft_i64;
 141         }
 142     }
 143
 144     /* seconds since epoch */
 145     tp->tv_sec = (long)((ft.ft_i64 - EPOCH_BIAS) / Const64(10000000));
 146
 147     /* microseconds remaining */
 148     tp->tv_usec = (long)((ft.ft_i64 / Const64(10)) % Const64(1000000));
 149
 150     return 0;
 151 }
 152 #endif
 153
 154 #if defined(WIN32) && !defined(ATLEASTFIVEOHOHFIVE)
 155 static unsigned int
 156 sleep(unsigned int t)
 157 {
 158     Sleep(t*1000);
 159     return 0;
 160 }
 161 #endif
 162
 163 #if !defined(HAS_GETTIMEOFDAY) && defined(VMS)
 164 #define HAS_GETTIMEOFDAY
 165
 166 #include <lnmdef.h>
 167 #include <time.h> /* gettimeofday */
 168 #include <stdlib.h> /* qdiv */
 169 #include <starlet.h> /* sys$gettim */
 170 #include <descrip.h>
 171 #ifdef __VAX
 172 #include <lib$routines.h> /* lib$ediv() */
 173 #endif
 174
 175 /*
 176         VMS binary time is expressed in 100 nano-seconds since
 177         system base time which is 17-NOV-1858 00:00:00.00
 178 */
 179
 180 #define DIV_100NS_TO_SECS  10000000L
 181 #define DIV_100NS_TO_USECS 10L
 182
 183 /*
 184         gettimeofday is supposed to return times since the epoch
 185         so need to determine this in terms of VMS base time
 186 */
 187 static $DESCRIPTOR(dscepoch,"01-JAN-1970 00:00:00.00");
 188
 189 #ifdef __VAX
 190 static long base_adjust[2]={0L,0L};
 191 #else
 192 static __int64 base_adjust=0;
 193 #endif
 194
 195 /*
 196
 197    If we don't have gettimeofday, then likely we are on a VMS machine that
 198    operates on local time rather than UTC...so we have to zone-adjust.
 199    This code gleefully swiped from VMS.C
 200
 201 */
 202 /* method used to handle UTC conversions:
 203  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
 204  */
 205 static int gmtime_emulation_type;
 206 /* number of secs to add to UTC POSIX-style time to get local time */
 207 static long int utc_offset_secs;
 208 static struct dsc$descriptor_s fildevdsc =
 209   { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
 210 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
 211
 212 static time_t toutc_dst(time_t loc) {
 213   struct tm *rsltmp;
 214
 215   if ((rsltmp = localtime(&loc)) == NULL) return -1;
 216   loc -= utc_offset_secs;
 217   if (rsltmp->tm_isdst) loc -= 3600;
 218   return loc;
 219 }
 220
 221 static time_t toloc_dst(time_t utc) {
 222   struct tm *rsltmp;
 223
 224   utc += utc_offset_secs;
 225   if ((rsltmp = localtime(&utc)) == NULL) return -1;
 226   if (rsltmp->tm_isdst) utc += 3600;
 227   return utc;
 228 }
 229
 230 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
 231        ((gmtime_emulation_type || timezone_setup()), \
 232        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
 233        ((secs) - utc_offset_secs))))
 234
 235 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
 236        ((gmtime_emulation_type || timezone_setup()), \
 237        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
 238        ((secs) + utc_offset_secs))))
 239
 240 static int
 241 timezone_setup(void)
 242 {
 243   struct tm *tm_p;
 244
 245   if (gmtime_emulation_type == 0) {
 246     int dstnow;
 247     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
 248                               /* results of calls to gmtime() and localtime() */
 249                               /* for same &base */
 250
 251     gmtime_emulation_type++;
 252     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
 253       char off[LNM$C_NAMLENGTH+1];;
 254
 255       gmtime_emulation_type++;
 256       if (!Perl_vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
 257         gmtime_emulation_type++;
 258         utc_offset_secs = 0;
 259         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
 260       }
 261       else { utc_offset_secs = atol(off); }
 262     }
 263     else { /* We've got a working gmtime() */
 264       struct tm gmt, local;
 265
 266       gmt = *tm_p;
 267       tm_p = localtime(&base);
 268       local = *tm_p;
 269       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
 270       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
 271       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
 272       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
 273     }
 274   }
 275   return 1;
 276 }
 277
 278
 279 int
 280 gettimeofday (struct timeval *tp, void *tpz)
 281 {
 282  long ret;
 283 #ifdef __VAX
 284  long quad[2];
 285  long quad1[2];
 286  long div_100ns_to_secs;
 287  long div_100ns_to_usecs;
 288  long quo,rem;
 289  long quo1,rem1;
 290 #else
 291  __int64 quad;
 292  __qdiv_t ans1,ans2;
 293 #endif
 294 /*
 295         In case of error, tv_usec = 0 and tv_sec = VMS condition code.
 296         The return from function is also set to -1.
 297         This is not exactly as per the manual page.
 298 */
 299
 300  tp->tv_usec = 0;
 301
 302 #ifdef __VAX
 303  if (base_adjust[0]==0 && base_adjust[1]==0) {
 304 #else
 305  if (base_adjust==0) { /* Need to determine epoch adjustment */
 306 #endif
 307         ret=sys$bintim(&dscepoch,&base_adjust);
 308         if (1 != (ret &&1)) {
 309                 tp->tv_sec = ret;
 310                 return -1;
 311         }
 312  }
 313
 314  ret=sys$gettim(&quad); /* Get VMS system time */
 315  if ((1 && ret) == 1) {
 316 #ifdef __VAX
 317         quad[0] -= base_adjust[0]; /* convert to epoch offset */
 318         quad[1] -= base_adjust[1]; /* convert 2nd half of quadword */
 319         div_100ns_to_secs = DIV_100NS_TO_SECS;
 320         div_100ns_to_usecs = DIV_100NS_TO_USECS;
 321         lib$ediv(&div_100ns_to_secs,&quad,&quo,&rem);
 322         quad1[0] = rem;
 323         quad1[1] = 0L;
 324         lib$ediv(&div_100ns_to_usecs,&quad1,&quo1,&rem1);
 325         tp->tv_sec = quo; /* Whole seconds */
 326         tp->tv_usec = quo1; /* Micro-seconds */
 327 #else
 328         quad -= base_adjust; /* convert to epoch offset */
 329         ans1=qdiv(quad,DIV_100NS_TO_SECS);
 330         ans2=qdiv(ans1.rem,DIV_100NS_TO_USECS);
 331         tp->tv_sec = ans1.quot; /* Whole seconds */
 332         tp->tv_usec = ans2.quot; /* Micro-seconds */
 333 #endif
 334  } else {
 335         tp->tv_sec = ret;
 336         return -1;
 337  }
 338 # ifdef VMSISH_TIME
 339 # ifdef RTL_USES_UTC
 340   if (VMSISH_TIME) tp->tv_sec = _toloc(tp->tv_sec);
 341 # else
 342   if (!VMSISH_TIME) tp->tv_sec = _toutc(tp->tv_sec);
 343 # endif
 344 # endif
 345  return 0;
 346 }
 347 #endif
 348
 349
 350  /* Do not use H A S _ N A N O S L E E P
 351   * so that Perl Configure doesn't scan for it.
 352   * The TIME_HIRES_NANOSLEEP is set by Makefile.PL. */
 353 #if !defined(HAS_USLEEP) && defined(TIME_HIRES_NANOSLEEP)
 354 #define HAS_USLEEP
 355 #define usleep hrt_unanosleep  /* could conflict with ncurses for static build */
 356
 357 void
 358 hrt_unanosleep(unsigned long usec) /* This is used to emulate usleep. */
 359 {
 360     struct timespec res;
 361     res.tv_sec = usec/1000/1000;
 362     res.tv_nsec = ( usec - res.tv_sec*1000*1000 ) * 1000;
 363     nanosleep(&res, NULL);
 364 }
 365
 366 #endif /* #if !defined(HAS_USLEEP) && defined(TIME_HIRES_NANOSLEEP) */
 367
 368 #if !defined(HAS_USLEEP) && defined(HAS_SELECT)
 369 #ifndef SELECT_IS_BROKEN
 370 #define HAS_USLEEP
 371 #define usleep hrt_usleep  /* could conflict with ncurses for static build */
 372
 373 void
 374 hrt_usleep(unsigned long usec)
 375 {
 376     struct timeval tv;
 377     tv.tv_sec = 0;
 378     tv.tv_usec = usec;
 379     select(0, (Select_fd_set_t)NULL, (Select_fd_set_t)NULL,
 380                 (Select_fd_set_t)NULL, &tv);
 381 }
 382 #endif
 383 #endif /* #if !defined(HAS_USLEEP) && defined(HAS_SELECT) */
 384
 385 #if !defined(HAS_USLEEP) && defined(WIN32)
 386 #define HAS_USLEEP
 387 #define usleep hrt_usleep  /* could conflict with ncurses for static build */
 388
 389 void
 390 hrt_usleep(unsigned long usec)
 391 {
 392     long msec;
 393     msec = usec / 1000;
 394     Sleep (msec);
 395 }
 396 #endif /* #if !defined(HAS_USLEEP) && defined(WIN32) */
 397
 398
 399 #if !defined(HAS_UALARM) && defined(HAS_SETITIMER)
 400 #define HAS_UALARM
 401 #define ualarm hrt_ualarm  /* could conflict with ncurses for static build */
 402
 403 int
 404 hrt_ualarm(int usec, int interval)
 405 {
 406    struct itimerval itv;
 407    itv.it_value.tv_sec = usec / 1000000;
 408    itv.it_value.tv_usec = usec % 1000000;
 409    itv.it_interval.tv_sec = interval / 1000000;
 410    itv.it_interval.tv_usec = interval % 1000000;
 411    return setitimer(ITIMER_REAL, &itv, 0);
 412 }
 413 #endif /* #if !defined(HAS_UALARM) && defined(HAS_SETITIMER) */
 414
 415 #if !defined(HAS_UALARM) && defined(VMS)
 416 #define HAS_UALARM
 417 #define ualarm vms_ualarm
 418
 419 #include <lib$routines.h>
 420 #include <ssdef.h>
 421 #include <starlet.h>
 422 #include <descrip.h>
 423 #include <signal.h>
 424 #include <jpidef.h>
 425 #include <psldef.h>
 426
 427 #define VMSERR(s)   (!((s)&1))
 428
 429 static void
 430 us_to_VMS(useconds_t mseconds, unsigned long v[])
 431 {
 432     int iss;
 433     unsigned long qq[2];
 434
 435     qq[0] = mseconds;
 436     qq[1] = 0;
 437     v[0] = v[1] = 0;
 438
 439     iss = lib$addx(qq,qq,qq);
 440     if (VMSERR(iss)) lib$signal(iss);
 441     iss = lib$subx(v,qq,v);
 442     if (VMSERR(iss)) lib$signal(iss);
 443     iss = lib$addx(qq,qq,qq);
 444     if (VMSERR(iss)) lib$signal(iss);
 445     iss = lib$subx(v,qq,v);
 446     if (VMSERR(iss)) lib$signal(iss);
 447     iss = lib$subx(v,qq,v);
 448     if (VMSERR(iss)) lib$signal(iss);
 449 }
 450
 451 static int
 452 VMS_to_us(unsigned long v[])
 453 {
 454     int iss;
 455     unsigned long div=10,quot, rem;
 456
 457     iss = lib$ediv(&div,v,&quot,&rem);
 458     if (VMSERR(iss)) lib$signal(iss);
 459
 460     return quot;
 461 }
 462
 463 typedef unsigned short word;
 464 typedef struct _ualarm {
 465     int function;
 466     int repeat;
 467     unsigned long delay[2];
 468     unsigned long interval[2];
 469     unsigned long remain[2];
 470 } Alarm;
 471
 472
 473 static int alarm_ef;
 474 static Alarm *a0, alarm_base;
 475 #define UAL_NULL   0
 476 #define UAL_SET    1
 477 #define UAL_CLEAR  2
 478 #define UAL_ACTIVE 4
 479 static void ualarm_AST(Alarm *a);
 480
 481 static int
 482 vms_ualarm(int mseconds, int interval)
 483 {
 484     Alarm *a, abase;
 485     struct item_list3 {
 486         word length;
 487         word code;
 488         void *bufaddr;
 489         void *retlenaddr;
 490     } ;
 491     static struct item_list3 itmlst[2];
 492     static int first = 1;
 493     unsigned long asten;
 494     int iss, enabled;
 495
 496     if (first) {
 497         first = 0;
 498         itmlst[0].code       = JPI$_ASTEN;
 499         itmlst[0].length     = sizeof(asten);
 500         itmlst[0].retlenaddr = NULL;
 501         itmlst[1].code       = 0;
 502         itmlst[1].length     = 0;
 503         itmlst[1].bufaddr    = NULL;
 504         itmlst[1].retlenaddr = NULL;
 505
 506         iss = lib$get_ef(&alarm_ef);
 507         if (VMSERR(iss)) lib$signal(iss);
 508
 509         a0 = &alarm_base;
 510         a0->function = UAL_NULL;
 511     }
 512     itmlst[0].bufaddr    = &asten;
 513
 514     iss = sys$getjpiw(0,0,0,itmlst,0,0,0);
 515     if (VMSERR(iss)) lib$signal(iss);
 516     if (!(asten&0x08)) return -1;
 517
 518     a = &abase;
 519     if (mseconds) {
 520         a->function = UAL_SET;
 521     } else {
 522         a->function = UAL_CLEAR;
 523     }
 524
 525     us_to_VMS(mseconds, a->delay);
 526     if (interval) {
 527         us_to_VMS(interval, a->interval);
 528         a->repeat = 1;
 529     } else
 530         a->repeat = 0;
 531
 532     iss = sys$clref(alarm_ef);
 533     if (VMSERR(iss)) lib$signal(iss);
 534
 535     iss = sys$dclast(ualarm_AST,a,0);
 536     if (VMSERR(iss)) lib$signal(iss);
 537
 538     iss = sys$waitfr(alarm_ef);
 539     if (VMSERR(iss)) lib$signal(iss);
 540
 541     if (a->function == UAL_ACTIVE)
 542         return VMS_to_us(a->remain);
 543     else
 544         return 0;
 545 }
 546
 547
 548
 549 static void
 550 ualarm_AST(Alarm *a)
 551 {
 552     int iss;
 553     unsigned long now[2];
 554
 555     iss = sys$gettim(now);
 556     if (VMSERR(iss)) lib$signal(iss);
 557
 558     if (a->function == UAL_SET || a->function == UAL_CLEAR) {
 559         if (a0->function == UAL_ACTIVE) {
 560             iss = sys$cantim(a0,PSL$C_USER);
 561             if (VMSERR(iss)) lib$signal(iss);
 562
 563             iss = lib$subx(a0->remain, now, a->remain);
 564             if (VMSERR(iss)) lib$signal(iss);
 565
 566             if (a->remain[1] & 0x80000000)
 567                 a->remain[0] = a->remain[1] = 0;
 568         }
 569
 570         if (a->function == UAL_SET) {
 571             a->function = a0->function;
 572             a0->function = UAL_ACTIVE;
 573             a0->repeat = a->repeat;
 574             if (a0->repeat) {
 575                 a0->interval[0] = a->interval[0];
 576                 a0->interval[1] = a->interval[1];
 577             }
 578             a0->delay[0] = a->delay[0];
 579             a0->delay[1] = a->delay[1];
 580
 581             iss = lib$subx(now, a0->delay, a0->remain);
 582             if (VMSERR(iss)) lib$signal(iss);
 583
 584             iss = sys$setimr(0,a0->delay,ualarm_AST,a0);
 585             if (VMSERR(iss)) lib$signal(iss);
 586         } else {
 587             a->function = a0->function;
 588             a0->function = UAL_NULL;
 589         }
 590         iss = sys$setef(alarm_ef);
 591         if (VMSERR(iss)) lib$signal(iss);
 592     } else if (a->function == UAL_ACTIVE) {
 593         if (a->repeat) {
 594             iss = lib$subx(now, a->interval, a->remain);
 595             if (VMSERR(iss)) lib$signal(iss);
 596
 597             iss = sys$setimr(0,a->interval,ualarm_AST,a);
 598             if (VMSERR(iss)) lib$signal(iss);
 599         } else {
 600             a->function = UAL_NULL;
 601         }
 602         iss = sys$wake(0,0);
 603         if (VMSERR(iss)) lib$signal(iss);
 604         lib$signal(SS$_ASTFLT);
 605     } else {
 606         lib$signal(SS$_BADPARAM);
 607     }
 608 }
 609
 610 #endif /* #if !defined(HAS_UALARM) && defined(VMS) */
 611
 612 #ifdef HAS_GETTIMEOFDAY
 613
 614 static int
 615 myU2time(pTHX_ UV *ret)
 616 {
 617   struct timeval Tp;
 618   int status;
 619   status = gettimeofday (&Tp, NULL);
 620   ret[0] = Tp.tv_sec;
 621   ret[1] = Tp.tv_usec;
 622   return status;
 623 }
 624
 625 static NV
 626 myNVtime()
 627 {
 628 #ifdef WIN32
 629   dTHX;
 630 #endif
 631   struct timeval Tp;
 632   int status;
 633   status = gettimeofday (&Tp, NULL);
 634   return status == 0 ? Tp.tv_sec + (Tp.tv_usec / 1000000.) : -1.0;
 635 }
 636
 637 #endif /* #ifdef HAS_GETTIMEOFDAY */
 638
 639 MODULE = Time::HiRes            PACKAGE = Time::HiRes
 640
 641 PROTOTYPES: ENABLE
 642
 643 BOOT:
 644 {
 645 #ifdef MY_CXT_KEY
 646   MY_CXT_INIT;
 647 #endif
 648 #ifdef ATLEASTFIVEOHOHFIVE
 649 #ifdef HAS_GETTIMEOFDAY
 650   {
 651     UV auv[2];
 652     hv_store(PL_modglobal, "Time::NVtime", 12, newSViv(PTR2IV(myNVtime)), 0);
 653     if (myU2time(aTHX_ auv) == 0)
 654       hv_store(PL_modglobal, "Time::U2time", 12, newSViv((IV) auv[0]), 0);
 655   }
 656 #endif
 657 #endif
 658 }
 659
 660 #if defined(USE_ITHREADS) && defined(MY_CXT_KEY)
 661
 662 void
 663 CLONE(...)
 664     CODE:
 665     MY_CXT_CLONE;
 666
 667 #endif
 668
 669 INCLUDE: const-xs.inc
 670
 671 #if defined(HAS_USLEEP) && defined(HAS_GETTIMEOFDAY)
 672
 673 NV
 674 usleep(useconds)
 675         NV useconds
 676         PREINIT:
 677         struct timeval Ta, Tb;
 678         CODE:
 679         gettimeofday(&Ta, NULL);
 680         if (items > 0) {
 681             if (useconds > 1E6) {
 682                 IV seconds = (IV) (useconds / 1E6);
 683                 /* If usleep() has been implemented using setitimer()
 684                  * then this contortion is unnecessary-- but usleep()
 685                  * may be implemented in some other way, so let's contort. */
 686                 if (seconds) {
 687                     sleep(seconds);
 688                     useconds -= 1E6 * seconds;
 689                 }
 690             } else if (useconds < 0.0)
 691                 croak("Time::HiRes::usleep(%"NVgf"): negative time not invented yet", useconds);
 692             usleep((U32)useconds);
 693         } else
 694             PerlProc_pause();
 695         gettimeofday(&Tb, NULL);
 696 #if 0
 697         printf("[%ld %ld] [%ld %ld]\n", Tb.tv_sec, Tb.tv_usec, Ta.tv_sec, Ta.tv_usec);
 698 #endif
 699         RETVAL = 1E6*(Tb.tv_sec-Ta.tv_sec)+(NV)((IV)Tb.tv_usec-(IV)Ta.tv_usec);
 700
 701         OUTPUT:
 702         RETVAL
 703
 704 #if defined(TIME_HIRES_NANOSLEEP)
 705
 706 NV
 707 nanosleep(nseconds)
 708         NV nseconds
 709         PREINIT:
 710         struct timeval Ta, Tb;
 711         CODE:
 712         gettimeofday(&Ta, NULL);
 713         if (items > 0) {
 714             struct timespec tsa;
 715             if (nseconds > 1E9) {
 716                 IV seconds = (IV) (nseconds / 1E9);
 717                 if (seconds) {
 718                     sleep(seconds);
 719                     nseconds -= 1E9 * seconds;
 720                 }
 721             } else if (nseconds < 0.0)
 722                 croak("Time::HiRes::nanosleep(%"NVgf"): negative time not invented yet", nseconds);
 723             tsa.tv_sec  = (IV) (nseconds / 1E9);
 724             tsa.tv_nsec = (IV) nseconds - tsa.tv_sec * 1E9;
 725             nanosleep(&tsa, NULL);
 726         } else
 727             PerlProc_pause();
 728         gettimeofday(&Tb, NULL);
 729         RETVAL = 1E3*(1E6*(Tb.tv_sec-Ta.tv_sec)+(NV)((IV)Tb.tv_usec-(IV)Ta.tv_usec));
 730
 731         OUTPUT:
 732         RETVAL
 733
 734 #endif /* #if defined(TIME_HIRES_NANOSLEEP) */
 735
 736 NV
 737 sleep(...)
 738         PREINIT:
 739         struct timeval Ta, Tb;
 740         CODE:
 741         gettimeofday(&Ta, NULL);
 742         if (items > 0) {
 743             NV seconds  = SvNV(ST(0));
 744             if (seconds >= 0.0) {
 745                  UV useconds = (UV)(1E6 * (seconds - (UV)seconds));
 746                  if (seconds >= 1.0)
 747                      sleep((U32)seconds);
 748                  if ((IV)useconds < 0) {
 749 #if defined(__sparc64__) && defined(__GNUC__)
 750                    /* Sparc64 gcc 2.95.3 (e.g. on NetBSD) has a bug
 751                     * where (0.5 - (UV)(0.5)) will under certain
 752                     * circumstances (if the double is cast to UV more
 753                     * than once?) evaluate to -0.5, instead of 0.5. */
 754                    useconds = -(IV)useconds;
 755 #endif /* #if defined(__sparc64__) && defined(__GNUC__) */
 756                    if ((IV)useconds < 0)
 757                      croak("Time::HiRes::sleep(%"NVgf"): internal error: useconds < 0 (unsigned %"UVuf" signed %"IVdf")", seconds, useconds, (IV)useconds);
 758                  }
 759                  usleep(useconds);
 760             } else
 761                 croak("Time::HiRes::sleep(%"NVgf"): negative time not invented yet", seconds);
 762         } else
 763             PerlProc_pause();
 764         gettimeofday(&Tb, NULL);
 765 #if 0
 766         printf("[%ld %ld] [%ld %ld]\n", Tb.tv_sec, Tb.tv_usec, Ta.tv_sec, Ta.tv_usec);
 767 #endif
 768         RETVAL = (NV)(Tb.tv_sec-Ta.tv_sec)+0.000001*(NV)(Tb.tv_usec-Ta.tv_usec);
 769
 770         OUTPUT:
 771         RETVAL
 772
 773 #endif /* #if defined(HAS_USLEEP) && defined(HAS_GETTIMEOFDAY) */
 774
 775 #ifdef HAS_UALARM
 776
 777 int
 778 ualarm(useconds,interval=0)
 779         int useconds
 780         int interval
 781         CODE:
 782         if (useconds < 0 || interval < 0)
 783             croak("Time::HiRes::ualarm(%d, %d): negative time not invented yet", useconds, interval);
 784         RETVAL = ualarm(useconds, interval);
 785
 786         OUTPUT:
 787         RETVAL
 788
 789 NV
 790 alarm(seconds,interval=0)
 791         NV seconds
 792         NV interval
 793         CODE:
 794         if (seconds < 0.0 || interval < 0.0)
 795             croak("Time::HiRes::alarm(%"NVgf", %"NVgf"): negative time not invented yet", seconds, interval);
 796         RETVAL = (NV)ualarm(seconds  * 1000000,
 797                             interval * 1000000) / 1E6;
 798
 799         OUTPUT:
 800         RETVAL
 801
 802 #endif /* #ifdef HAS_UALARM */
 803
 804 #ifdef HAS_GETTIMEOFDAY
 805 #    ifdef MACOS_TRADITIONAL    /* fix epoch TZ and use unsigned time_t */
 806 void
 807 gettimeofday()
 808         PREINIT:
 809         struct timeval Tp;
 810         struct timezone Tz;
 811         PPCODE:
 812         int status;
 813         status = gettimeofday (&Tp, &Tz);
 814
 815         if (status == 0) {
 816              Tp.tv_sec += Tz.tz_minuteswest * 60;       /* adjust for TZ */
 817              if (GIMME == G_ARRAY) {
 818                  EXTEND(sp, 2);
 819                  /* Mac OS (Classic) has unsigned time_t */
 820                  PUSHs(sv_2mortal(newSVuv(Tp.tv_sec)));
 821                  PUSHs(sv_2mortal(newSViv(Tp.tv_usec)));
 822              } else {
 823                  EXTEND(sp, 1);
 824                  PUSHs(sv_2mortal(newSVnv(Tp.tv_sec + (Tp.tv_usec / 1000000.0))));
 825              }
 826         }
 827
 828 NV
 829 time()
 830         PREINIT:
 831         struct timeval Tp;
 832         struct timezone Tz;
 833         CODE:
 834         int status;
 835         status = gettimeofday (&Tp, &Tz);
 836         if (status == 0) {
 837             Tp.tv_sec += Tz.tz_minuteswest * 60;        /* adjust for TZ */
 838             RETVAL = Tp.tv_sec + (Tp.tv_usec / 1000000.0);
 839         } else {
 840             RETVAL = -1.0;
 841         }
 842         OUTPUT:
 843         RETVAL
 844
 845 #    else       /* MACOS_TRADITIONAL */
 846 void
 847 gettimeofday()
 848         PREINIT:
 849         struct timeval Tp;
 850         PPCODE:
 851         int status;
 852         status = gettimeofday (&Tp, NULL);
 853         if (status == 0) {
 854              if (GIMME == G_ARRAY) {
 855                  EXTEND(sp, 2);
 856                  PUSHs(sv_2mortal(newSViv(Tp.tv_sec)));
 857                  PUSHs(sv_2mortal(newSViv(Tp.tv_usec)));
 858              } else {
 859                  EXTEND(sp, 1);
 860                  PUSHs(sv_2mortal(newSVnv(Tp.tv_sec + (Tp.tv_usec / 1000000.0))));
 861              }
 862         }
 863
 864 NV
 865 time()
 866         PREINIT:
 867         struct timeval Tp;
 868         CODE:
 869         int status;
 870         status = gettimeofday (&Tp, NULL);
 871         if (status == 0) {
 872             RETVAL = Tp.tv_sec + (Tp.tv_usec / 1000000.);
 873         } else {
 874             RETVAL = -1.0;
 875         }
 876         OUTPUT:
 877         RETVAL
 878
 879 #    endif      /* MACOS_TRADITIONAL */
 880 #endif /* #ifdef HAS_GETTIMEOFDAY */
 881
 882 #if defined(HAS_GETITIMER) && defined(HAS_SETITIMER)
 883
 884 #define TV2NV(tv) ((NV)((tv).tv_sec) + 0.000001 * (NV)((tv).tv_usec))
 885
 886 void
 887 setitimer(which, seconds, interval = 0)
 888         int which
 889         NV seconds
 890         NV interval
 891     PREINIT:
 892         struct itimerval newit;
 893         struct itimerval oldit;
 894     PPCODE:
 895         if (seconds < 0.0 || interval < 0.0)
 896             croak("Time::HiRes::setitimer(%"IVdf", %"NVgf", %"NVgf"): negative time not invented yet", (IV)which, seconds, interval);
 897         newit.it_value.tv_sec  = seconds;
 898         newit.it_value.tv_usec =
 899           (seconds  - (NV)newit.it_value.tv_sec)    * 1000000.0;
 900         newit.it_interval.tv_sec  = interval;
 901         newit.it_interval.tv_usec =
 902           (interval - (NV)newit.it_interval.tv_sec) * 1000000.0;
 903         if (setitimer(which, &newit, &oldit) == 0) {
 904           EXTEND(sp, 1);
 905           PUSHs(sv_2mortal(newSVnv(TV2NV(oldit.it_value))));
 906           if (GIMME == G_ARRAY) {
 907             EXTEND(sp, 1);
 908             PUSHs(sv_2mortal(newSVnv(TV2NV(oldit.it_interval))));
 909           }
 910         }
 911
 912 void
 913 getitimer(which)
 914         int which
 915     PREINIT:
 916         struct itimerval nowit;
 917     PPCODE:
 918         if (getitimer(which, &nowit) == 0) {
 919           EXTEND(sp, 1);
 920           PUSHs(sv_2mortal(newSVnv(TV2NV(nowit.it_value))));
 921           if (GIMME == G_ARRAY) {
 922             EXTEND(sp, 1);
 923             PUSHs(sv_2mortal(newSVnv(TV2NV(nowit.it_interval))));
 924           }
 925         }
 926
 927 #endif /* #if defined(HAS_GETITIMER) && defined(HAS_SETITIMER) */
 928
 929