ext/Time/HiRes/HiRes.xs

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