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