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