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         struct timespec sleepfor, unslept;
 821         CODE:
 822         if (nsec < 0.0)
 823             croak("Time::HiRes::nanosleep(%"NVgf"): negative time not invented yet", nsec);
 824         sleepfor.tv_sec = (Time_t)(nsec / 1e9);
 825         sleepfor.tv_nsec = (long)(nsec - ((NV)sleepfor.tv_sec) * 1e9);
 826         if (!nanosleep(&sleepfor, &unslept)) {
 827             RETVAL = nsec;
 828         } else {
 829             sleepfor.tv_sec -= unslept.tv_sec;
 830             sleepfor.tv_nsec -= unslept.tv_nsec;
 831             if (sleepfor.tv_nsec < 0) {
 832                 sleepfor.tv_sec--;
 833                 sleepfor.tv_nsec += 1000000000;
 834             }
 835             RETVAL = ((NV)sleepfor.tv_sec) * 1e9 + ((NV)sleepfor.tv_nsec);
 836         }
 837     OUTPUT:
 838         RETVAL
 839
 840 #else  /* #if defined(TIME_HIRES_NANOSLEEP) */
 841
 842 NV
 843 nanosleep(nsec)
 844         NV nsec
 845     CODE:
 846         croak("Time::HiRes::nanosleep(): unimplemented in this platform");
 847         RETVAL = 0.0;
 848
 849 #endif /* #if defined(TIME_HIRES_NANOSLEEP) */
 850
 851 NV
 852 sleep(...)
 853         PREINIT:
 854         struct timeval Ta, Tb;
 855         CODE:
 856         gettimeofday(&Ta, NULL);
 857         if (items > 0) {
 858             NV seconds  = SvNV(ST(0));
 859             if (seconds >= 0.0) {
 860                  UV useconds = (UV)(1E6 * (seconds - (UV)seconds));
 861                  if (seconds >= 1.0)
 862                      sleep((U32)seconds);
 863                  if ((IV)useconds < 0) {
 864 #if defined(__sparc64__) && defined(__GNUC__)
 865                    /* Sparc64 gcc 2.95.3 (e.g. on NetBSD) has a bug
 866                     * where (0.5 - (UV)(0.5)) will under certain
 867                     * circumstances (if the double is cast to UV more
 868                     * than once?) evaluate to -0.5, instead of 0.5. */
 869                    useconds = -(IV)useconds;
 870 #endif /* #if defined(__sparc64__) && defined(__GNUC__) */
 871                    if ((IV)useconds < 0)
 872                      croak("Time::HiRes::sleep(%"NVgf"): internal error: useconds < 0 (unsigned %"UVuf" signed %"IVdf")", seconds, useconds, (IV)useconds);
 873                  }
 874                  usleep(useconds);
 875             } else
 876                 croak("Time::HiRes::sleep(%"NVgf"): negative time not invented yet", seconds);
 877         } else
 878             PerlProc_pause();
 879         gettimeofday(&Tb, NULL);
 880 #if 0
 881         printf("[%ld %ld] [%ld %ld]\n", Tb.tv_sec, Tb.tv_usec, Ta.tv_sec, Ta.tv_usec);
 882 #endif
 883         RETVAL = (NV)(Tb.tv_sec-Ta.tv_sec)+0.000001*(NV)(Tb.tv_usec-Ta.tv_usec);
 884
 885         OUTPUT:
 886         RETVAL
 887
 888 #else  /* #if defined(HAS_USLEEP) && defined(HAS_GETTIMEOFDAY) */
 889
 890 NV
 891 usleep(useconds)
 892         NV useconds
 893     CODE:
 894         croak("Time::HiRes::usleep(): unimplemented in this platform");
 895         RETVAL = 0.0;
 896
 897 #endif /* #if defined(HAS_USLEEP) && defined(HAS_GETTIMEOFDAY) */
 898
 899 #ifdef HAS_UALARM
 900
 901 int
 902 ualarm(useconds,interval=0)
 903         int useconds
 904         int interval
 905         CODE:
 906         if (useconds < 0 || interval < 0)
 907             croak("Time::HiRes::ualarm(%d, %d): negative time not invented yet", useconds, interval);
 908         if (useconds >= IV_1E6 || interval >= IV_1E6)
 909 #if defined(HAS_SETITIMER) && defined(ITIMER_REAL)
 910                 RETVAL = hrt_ualarm_itimer(useconds, interval);
 911 #else
 912                 croak("Time::HiRes::ualarm(%d, %d): useconds or interval equal or more than %"IVdf, useconds, interval, IV_1E6);
 913 #endif
 914         else
 915                 RETVAL = ualarm(useconds, interval);
 916
 917         OUTPUT:
 918         RETVAL
 919
 920 NV
 921 alarm(seconds,interval=0)
 922         NV seconds
 923         NV interval
 924         CODE:
 925         if (seconds < 0.0 || interval < 0.0)
 926             croak("Time::HiRes::alarm(%"NVgf", %"NVgf"): negative time not invented yet", seconds, interval);
 927         RETVAL = (NV)ualarm((IV)(seconds  * IV_1E6),
 928                             (IV)(interval * IV_1E6)) / NV_1E6;
 929
 930         OUTPUT:
 931         RETVAL
 932
 933 #else
 934
 935 int
 936 ualarm(useconds,interval=0)
 937         int useconds
 938         int interval
 939     CODE:
 940         croak("Time::HiRes::ualarm(): unimplemented in this platform");
 941         RETVAL = -1;
 942
 943 NV
 944 alarm(seconds,interval=0)
 945         NV seconds
 946         NV interval
 947     CODE:
 948         croak("Time::HiRes::alarm(): unimplemented in this platform");
 949         RETVAL = 0.0;
 950
 951 #endif /* #ifdef HAS_UALARM */
 952
 953 #ifdef HAS_GETTIMEOFDAY
 954 #    ifdef MACOS_TRADITIONAL    /* fix epoch TZ and use unsigned time_t */
 955 void
 956 gettimeofday()
 957         PREINIT:
 958         struct timeval Tp;
 959         struct timezone Tz;
 960         PPCODE:
 961         int status;
 962         status = gettimeofday (&Tp, &Tz);
 963
 964         if (status == 0) {
 965              Tp.tv_sec += Tz.tz_minuteswest * 60;       /* adjust for TZ */
 966              if (GIMME == G_ARRAY) {
 967                  EXTEND(sp, 2);
 968                  /* Mac OS (Classic) has unsigned time_t */
 969                  PUSHs(sv_2mortal(newSVuv(Tp.tv_sec)));
 970                  PUSHs(sv_2mortal(newSViv(Tp.tv_usec)));
 971              } else {
 972                  EXTEND(sp, 1);
 973                  PUSHs(sv_2mortal(newSVnv(Tp.tv_sec + (Tp.tv_usec / NV_1E6))));
 974              }
 975         }
 976
 977 NV
 978 time()
 979         PREINIT:
 980         struct timeval Tp;
 981         struct timezone Tz;
 982         CODE:
 983         int status;
 984         status = gettimeofday (&Tp, &Tz);
 985         if (status == 0) {
 986             Tp.tv_sec += Tz.tz_minuteswest * 60;        /* adjust for TZ */
 987             RETVAL = Tp.tv_sec + (Tp.tv_usec / NV_1E6);
 988         } else {
 989             RETVAL = -1.0;
 990         }
 991         OUTPUT:
 992         RETVAL
 993
 994 #    else       /* MACOS_TRADITIONAL */
 995 void
 996 gettimeofday()
 997         PREINIT:
 998         struct timeval Tp;
 999         PPCODE:
1000         int status;
1001         status = gettimeofday (&Tp, NULL);
1002         if (status == 0) {
1003              if (GIMME == G_ARRAY) {
1004                  EXTEND(sp, 2);
1005                  PUSHs(sv_2mortal(newSViv(Tp.tv_sec)));
1006                  PUSHs(sv_2mortal(newSViv(Tp.tv_usec)));
1007              } else {
1008                  EXTEND(sp, 1);
1009                  PUSHs(sv_2mortal(newSVnv(Tp.tv_sec + (Tp.tv_usec / NV_1E6))));
1010              }
1011         }
1012
1013 NV
1014 time()
1015         PREINIT:
1016         struct timeval Tp;
1017         CODE:
1018         int status;
1019         status = gettimeofday (&Tp, NULL);
1020         if (status == 0) {
1021             RETVAL = Tp.tv_sec + (Tp.tv_usec / NV_1E6);
1022         } else {
1023             RETVAL = -1.0;
1024         }
1025         OUTPUT:
1026         RETVAL
1027
1028 #    endif      /* MACOS_TRADITIONAL */
1029 #endif /* #ifdef HAS_GETTIMEOFDAY */
1030
1031 #if defined(HAS_GETITIMER) && defined(HAS_SETITIMER)
1032
1033 #define TV2NV(tv) ((NV)((tv).tv_sec) + 0.000001 * (NV)((tv).tv_usec))
1034
1035 void
1036 setitimer(which, seconds, interval = 0)
1037         int which
1038         NV seconds
1039         NV interval
1040     PREINIT:
1041         struct itimerval newit;
1042         struct itimerval oldit;
1043     PPCODE:
1044         if (seconds < 0.0 || interval < 0.0)
1045             croak("Time::HiRes::setitimer(%"IVdf", %"NVgf", %"NVgf"): negative time not invented yet", (IV)which, seconds, interval);
1046         newit.it_value.tv_sec  = (IV)seconds;
1047         newit.it_value.tv_usec =
1048           (IV)((seconds  - (NV)newit.it_value.tv_sec)    * NV_1E6);
1049         newit.it_interval.tv_sec  = (IV)interval;
1050         newit.it_interval.tv_usec =
1051           (IV)((interval - (NV)newit.it_interval.tv_sec) * NV_1E6);
1052         if (setitimer(which, &newit, &oldit) == 0) {
1053           EXTEND(sp, 1);
1054           PUSHs(sv_2mortal(newSVnv(TV2NV(oldit.it_value))));
1055           if (GIMME == G_ARRAY) {
1056             EXTEND(sp, 1);
1057             PUSHs(sv_2mortal(newSVnv(TV2NV(oldit.it_interval))));
1058           }
1059         }
1060
1061 void
1062 getitimer(which)
1063         int which
1064     PREINIT:
1065         struct itimerval nowit;
1066     PPCODE:
1067         if (getitimer(which, &nowit) == 0) {
1068           EXTEND(sp, 1);
1069           PUSHs(sv_2mortal(newSVnv(TV2NV(nowit.it_value))));
1070           if (GIMME == G_ARRAY) {
1071             EXTEND(sp, 1);
1072             PUSHs(sv_2mortal(newSVnv(TV2NV(nowit.it_interval))));
1073           }
1074         }
1075
1076 #endif /* #if defined(HAS_GETITIMER) && defined(HAS_SETITIMER) */
1077
1078 #if defined(TIME_HIRES_CLOCK_GETTIME)
1079
1080 NV
1081 clock_gettime(clock_id = CLOCK_REALTIME)
1082         int clock_id
1083     PREINIT:
1084         struct timespec ts;
1085         int status = -1;
1086     CODE:
1087 #ifdef TIME_HIRES_CLOCK_GETTIME_SYSCALL
1088         status = syscall(SYS_clock_gettime, clock_id, &ts);
1089 #else
1090         status = clock_gettime(clock_id, &ts);
1091 #endif
1092         RETVAL = status == 0 ? ts.tv_sec + (NV) ts.tv_nsec / (NV) 1e9 : -1;
1093
1094     OUTPUT:
1095         RETVAL
1096
1097 #else  /* if defined(TIME_HIRES_CLOCK_GETTIME) */
1098
1099 NV
1100 clock_gettime(clock_id = 0)
1101         int clock_id
1102     CODE:
1103         croak("Time::HiRes::clock_gettime(): unimplemented in this platform");
1104         RETVAL = 0.0;
1105
1106 #endif /*  #if defined(TIME_HIRES_CLOCK_GETTIME) */
1107
1108 #if defined(TIME_HIRES_CLOCK_GETRES)
1109
1110 NV
1111 clock_getres(clock_id = CLOCK_REALTIME)
1112         int clock_id
1113     PREINIT:
1114         int status = -1;
1115         struct timespec ts;
1116     CODE:
1117 #ifdef TIME_HIRES_CLOCK_GETRES_SYSCALL
1118         status = syscall(SYS_clock_getres, clock_id, &ts);
1119 #else
1120         status = clock_getres(clock_id, &ts);
1121 #endif
1122         RETVAL = status == 0 ? ts.tv_sec + (NV) ts.tv_nsec / (NV) 1e9 : -1;
1123
1124     OUTPUT:
1125         RETVAL
1126
1127 #else  /* if defined(TIME_HIRES_CLOCK_GETRES) */
1128
1129 NV
1130 clock_getres(clock_id = 0)
1131         int clock_id
1132     CODE:
1133         croak("Time::HiRes::clock_getres(): unimplemented in this platform");
1134         RETVAL = 0.0;
1135
1136 #endif /*  #if defined(TIME_HIRES_CLOCK_GETRES) */
1137
1138 #if defined(TIME_HIRES_CLOCK_NANOSLEEP) && defined(TIMER_ABSTIME)
1139
1140 NV
1141 clock_nanosleep(clock_id, nsec, flags = 0)
1142         int clock_id
1143         NV  nsec
1144         int flags
1145     PREINIT:
1146         struct timespec sleepfor, unslept;
1147     CODE:
1148         if (nsec < 0.0)
1149             croak("Time::HiRes::clock_nanosleep(..., %"NVgf"): negative time not invented yet", nsec);
1150         sleepfor.tv_sec = (Time_t)(nsec / 1e9);
1151         sleepfor.tv_nsec = (long)(nsec - ((NV)sleepfor.tv_sec) * 1e9);
1152         if (!clock_nanosleep(clock_id, flags, &sleepfor, &unslept)) {
1153             RETVAL = nsec;
1154         } else {
1155             sleepfor.tv_sec -= unslept.tv_sec;
1156             sleepfor.tv_nsec -= unslept.tv_nsec;
1157             if (sleepfor.tv_nsec < 0) {
1158                 sleepfor.tv_sec--;
1159                 sleepfor.tv_nsec += 1000000000;
1160             }
1161             RETVAL = ((NV)sleepfor.tv_sec) * 1e9 + ((NV)sleepfor.tv_nsec);
1162         }
1163     OUTPUT:
1164         RETVAL
1165
1166 #else  /* if defined(TIME_HIRES_CLOCK_NANOSLEEP) && defined(TIMER_ABSTIME) */
1167
1168 NV
1169 clock_nanosleep()
1170     CODE:
1171         croak("Time::HiRes::clock_nanosleep(): unimplemented in this platform");
1172         RETVAL = 0.0;
1173
1174 #endif /*  #if defined(TIME_HIRES_CLOCK_NANOSLEEP) && defined(TIMER_ABSTIME) */
1175
1176 #if defined(TIME_HIRES_CLOCK) && defined(CLOCKS_PER_SEC)
1177
1178 NV
1179 clock()
1180     PREINIT:
1181         clock_t clocks;
1182     CODE:
1183         clocks = clock();
1184         RETVAL = clocks == -1 ? -1 : (NV)clocks / (NV)CLOCKS_PER_SEC;
1185
1186     OUTPUT:
1187         RETVAL
1188
1189 #else  /* if defined(TIME_HIRES_CLOCK) && defined(CLOCKS_PER_SEC) */
1190
1191 NV
1192 clock()
1193     CODE:
1194         croak("Time::HiRes::clock(): unimplemented in this platform");
1195         RETVAL = 0.0;
1196
1197 #endif /*  #if defined(TIME_HIRES_CLOCK) && defined(CLOCKS_PER_SEC) */
1198
1199 void
1200 stat(...)
1201 PROTOTYPE: ;$
1202     PPCODE:
1203         PUSHMARK(SP);
1204         XPUSHs(sv_2mortal(newSVsv(items == 1 ? ST(0) : DEFSV)));
1205         PUTBACK;
1206         ENTER;
1207         PL_laststatval = -1;
1208         (void)*(PL_ppaddr[OP_STAT])(aTHXR);
1209         SPAGAIN;
1210         LEAVE;
1211         if (PL_laststatval == 0) {
1212           /* We assume that pp_stat() left us with 13 valid stack items,
1213            * and that the timestamps are at offsets 8, 9, and 10. */
1214           UV atime = SvUV(ST( 8));
1215           UV mtime = SvUV(ST( 9));
1216           UV ctime = SvUV(ST(10));
1217           UV atime_nsec;
1218           UV mtime_nsec;
1219           UV ctime_nsec;
1220           hrstatns(atime, mtime, ctime,
1221                    &atime_nsec, &mtime_nsec, &ctime_nsec);
1222           if (atime_nsec)
1223             ST( 8) = sv_2mortal(newSVnv(atime + 1e-9 * (NV) atime_nsec));
1224           if (mtime_nsec)
1225             ST( 9) = sv_2mortal(newSVnv(mtime + 1e-9 * (NV) mtime_nsec));
1226           if (ctime_nsec)
1227             ST(10) = sv_2mortal(newSVnv(ctime + 1e-9 * (NV) ctime_nsec));
1228           XSRETURN(13);
1229         }
1230         XSRETURN(0);