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