ext/Time/HiRes/HiRes.xs

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