This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perlapi: Document __ASSERT_
[perl5.git] / dist / Time-HiRes / HiRes.xs
CommitLineData
f8daf111 1/*
708180a3 2 *
f8daf111 3 * Copyright (c) 1996-2002 Douglas E. Wegscheid. All rights reserved.
708180a3 4 *
68c5b4db 5 * Copyright (c) 2002-2010 Jarkko Hietaniemi.
bf8300de 6 * All rights reserved.
91a2e9f6 7 *
0f0eae2c 8 * Copyright (C) 2011, 2012, 2013 Andrew Main (Zefram) <zefram@fysh.org>
708180a3 9 *
f8daf111
RGS
10 * This program is free software; you can redistribute it and/or modify
11 * it under the same terms as Perl itself.
12 */
13
dcf686c9
JH
14#ifdef __cplusplus
15extern "C" {
16#endif
0225372c 17#define PERL_NO_GET_CONTEXT
dcf686c9
JH
18#include "EXTERN.h"
19#include "perl.h"
20#include "XSUB.h"
cbc1b415
DD
21#ifdef USE_PPPORT_H
22# include "ppport.h"
23#endif
4ed0e2d4 24#if defined(__CYGWIN__) && defined(HAS_W32API_WINDOWS_H)
708180a3
TK
25# include <w32api/windows.h>
26# define CYGWIN_WITH_W32API
4ed0e2d4 27#endif
dcf686c9 28#ifdef WIN32
708180a3 29# include <time.h>
dcf686c9 30#else
708180a3 31# include <sys/time.h>
dcf686c9 32#endif
36df99d6 33#ifdef HAS_SELECT
708180a3
TK
34# ifdef I_SYS_SELECT
35# include <sys/select.h>
36# endif
36df99d6 37#endif
ced84e60 38#if defined(TIME_HIRES_CLOCK_GETTIME_SYSCALL) || defined(TIME_HIRES_CLOCK_GETRES_SYSCALL)
708180a3 39# include <syscall.h>
ced84e60 40#endif
dcf686c9
JH
41#ifdef __cplusplus
42}
43#endif
44
0f0eae2c
Z
45#define PERL_VERSION_DECIMAL(r,v,s) (r*1000000 + v*1000 + s)
46#define PERL_DECIMAL_VERSION \
708180a3 47 PERL_VERSION_DECIMAL(PERL_REVISION,PERL_VERSION,PERL_SUBVERSION)
0f0eae2c 48#define PERL_VERSION_GE(r,v,s) \
708180a3 49 (PERL_DECIMAL_VERSION >= PERL_VERSION_DECIMAL(r,v,s))
0f0eae2c 50
7347ee54 51#ifndef GCC_DIAG_IGNORE
708180a3
TK
52# define GCC_DIAG_IGNORE(x)
53# define GCC_DIAG_RESTORE
7347ee54
Z
54#endif
55#ifndef GCC_DIAG_IGNORE_STMT
708180a3
TK
56# define GCC_DIAG_IGNORE_STMT(x) GCC_DIAG_IGNORE(x) NOOP
57# define GCC_DIAG_RESTORE_STMT GCC_DIAG_RESTORE NOOP
7347ee54
Z
58#endif
59
0f0eae2c 60#if PERL_VERSION_GE(5,7,3) && !PERL_VERSION_GE(5,10,1)
708180a3
TK
61# undef SAVEOP
62# define SAVEOP() SAVEVPTR(PL_op)
0f0eae2c
Z
63#endif
64
b69b1b83
SP
65#define IV_1E6 1000000
66#define IV_1E7 10000000
67#define IV_1E9 1000000000
68
727404d0
TR
69#define NV_1E6 1000000.0
70#define NV_1E7 10000000.0
71#define NV_1E9 1000000000.0
47e797f6 72
1fbb4de4 73#ifndef PerlProc_pause
708180a3 74# define PerlProc_pause() Pause()
3f2ee006
HS
75#endif
76
1fbb4de4 77#ifdef HAS_PAUSE
708180a3 78# define Pause pause
3f2ee006 79#else
708180a3
TK
80# undef Pause /* In case perl.h did it already. */
81# define Pause() sleep(~0) /* Zzz for a long time. */
3f2ee006
HS
82#endif
83
84/* Though the cpp define ITIMER_VIRTUAL is available the functionality
4ed0e2d4 85 * is not supported in Cygwin as of August 2004, ditto for Win32.
3f2ee006
HS
86 * Neither are ITIMER_PROF or ITIMER_REALPROF implemented. --jhi
87 */
88#if defined(__CYGWIN__) || defined(WIN32)
708180a3
TK
89# undef ITIMER_VIRTUAL
90# undef ITIMER_PROF
91# undef ITIMER_REALPROF
3f2ee006
HS
92#endif
93
69d1f2c2
JH
94#ifndef TIME_HIRES_CLOCKID_T
95typedef int clockid_t;
96#endif
97
82cbdcc3
SP
98#if defined(TIME_HIRES_CLOCK_GETTIME) && defined(_STRUCT_ITIMERSPEC)
99
100/* HP-UX has CLOCK_XXX values but as enums, not as defines.
101 * The only way to detect these would be to test compile for each. */
708180a3 102# ifdef __hpux
bf8300de
RGS
103/* However, it seems that at least in HP-UX 11.31 ia64 there *are*
104 * defines for these, so let's try detecting them. */
708180a3
TK
105# ifndef CLOCK_REALTIME
106# define CLOCK_REALTIME CLOCK_REALTIME
107# define CLOCK_VIRTUAL CLOCK_VIRTUAL
108# define CLOCK_PROFILE CLOCK_PROFILE
109# endif
110# endif /* # ifdef __hpux */
82cbdcc3
SP
111
112#endif /* #if defined(TIME_HIRES_CLOCK_GETTIME) && defined(_STRUCT_ITIMERSPEC) */
3c72ec00 113
4ed0e2d4 114#if defined(WIN32) || defined(CYGWIN_WITH_W32API)
0225372c 115
708180a3
TK
116# ifndef HAS_GETTIMEOFDAY
117# define HAS_GETTIMEOFDAY
118# endif
fd44fdfd 119
6e3b076d
JH
120/* shows up in winsock.h?
121struct timeval {
708180a3
TK
122 long tv_sec;
123 long tv_usec;
6e3b076d
JH
124}
125*/
126
fd44fdfd 127typedef union {
708180a3
TK
128 unsigned __int64 ft_i64;
129 FILETIME ft_val;
fd44fdfd
JH
130} FT_t;
131
708180a3 132# define MY_CXT_KEY "Time::HiRes_" XS_VERSION
0225372c
RGS
133
134typedef struct {
135 unsigned long run_count;
136 unsigned __int64 base_ticks;
137 unsigned __int64 tick_frequency;
138 FT_t base_systime_as_filetime;
4ed0e2d4 139 unsigned __int64 reset_time;
0225372c
RGS
140} my_cxt_t;
141
142START_MY_CXT
143
6e3b076d 144/* Number of 100 nanosecond units from 1/1/1601 to 1/1/1970 */
708180a3
TK
145# ifdef __GNUC__
146# define Const64(x) x##LL
147# else
148# define Const64(x) x##i64
149# endif
150# define EPOCH_BIAS Const64(116444736000000000)
151
152# ifdef Const64
153# ifdef __GNUC__
154# define IV_1E6LL 1000000LL /* Needed because of Const64() ##-appends LL (or i64). */
155# define IV_1E7LL 10000000LL
156# define IV_1E9LL 1000000000LL
157# else
158# define IV_1E6i64 1000000i64
159# define IV_1E7i64 10000000i64
160# define IV_1E9i64 1000000000i64
161# endif
162# endif
f445b110 163
fd44fdfd
JH
164/* NOTE: This does not compute the timezone info (doing so can be expensive,
165 * and appears to be unsupported even by glibc) */
0225372c
RGS
166
167/* dMY_CXT needs a Perl context and we don't want to call PERL_GET_CONTEXT
168 for performance reasons */
169
708180a3
TK
170# undef gettimeofday
171# define gettimeofday(tp, not_used) _gettimeofday(aTHX_ tp, not_used)
0225372c 172
d8cb5b61
RGS
173/* If the performance counter delta drifts more than 0.5 seconds from the
174 * system time then we recalibrate to the system time. This means we may
c1dc6e7c 175 * move *backwards* in time! */
708180a3 176# define MAX_PERF_COUNTER_SKEW Const64(5000000) /* 0.5 seconds */
c1dc6e7c 177
4ed0e2d4
RGS
178/* Reset reading from the performance counter every five minutes.
179 * Many PC clocks just seem to be so bad. */
708180a3 180# define MAX_PERF_COUNTER_TICKS Const64(300000000) /* 300 seconds */
c1dc6e7c 181
0225372c
RGS
182static int
183_gettimeofday(pTHX_ struct timeval *tp, void *not_used)
fd44fdfd 184{
0225372c
RGS
185 dMY_CXT;
186
187 unsigned __int64 ticks;
fd44fdfd
JH
188 FT_t ft;
189
a914236c 190 PERL_UNUSED_ARG(not_used);
4ed0e2d4 191 if (MY_CXT.run_count++ == 0 ||
708180a3
TK
192 MY_CXT.base_systime_as_filetime.ft_i64 > MY_CXT.reset_time) {
193
4ed0e2d4
RGS
194 QueryPerformanceFrequency((LARGE_INTEGER*)&MY_CXT.tick_frequency);
195 QueryPerformanceCounter((LARGE_INTEGER*)&MY_CXT.base_ticks);
196 GetSystemTimeAsFileTime(&MY_CXT.base_systime_as_filetime.ft_val);
197 ft.ft_i64 = MY_CXT.base_systime_as_filetime.ft_i64;
708180a3 198 MY_CXT.reset_time = ft.ft_i64 + MAX_PERF_COUNTER_TICKS;
4ed0e2d4
RGS
199 }
200 else {
708180a3 201 __int64 diff;
0225372c
RGS
202 QueryPerformanceCounter((LARGE_INTEGER*)&ticks);
203 ticks -= MY_CXT.base_ticks;
204 ft.ft_i64 = MY_CXT.base_systime_as_filetime.ft_i64
47e797f6
SP
205 + Const64(IV_1E7) * (ticks / MY_CXT.tick_frequency)
206 +(Const64(IV_1E7) * (ticks % MY_CXT.tick_frequency)) / MY_CXT.tick_frequency;
708180a3
TK
207 diff = ft.ft_i64 - MY_CXT.base_systime_as_filetime.ft_i64;
208 if (diff < -MAX_PERF_COUNTER_SKEW || diff > MAX_PERF_COUNTER_SKEW) {
209 MY_CXT.base_ticks += ticks;
4ed0e2d4
RGS
210 GetSystemTimeAsFileTime(&MY_CXT.base_systime_as_filetime.ft_val);
211 ft.ft_i64 = MY_CXT.base_systime_as_filetime.ft_i64;
708180a3 212 }
0225372c 213 }
fd44fdfd
JH
214
215 /* seconds since epoch */
47e797f6 216 tp->tv_sec = (long)((ft.ft_i64 - EPOCH_BIAS) / Const64(IV_1E7));
fd44fdfd
JH
217
218 /* microseconds remaining */
47e797f6 219 tp->tv_usec = (long)((ft.ft_i64 / Const64(10)) % Const64(IV_1E6));
fd44fdfd
JH
220
221 return 0;
222}
708180a3 223#endif /* #if defined(WIN32) || defined(CYGWIN_WITH_W32API) */
fd44fdfd 224
dcf686c9 225#if !defined(HAS_GETTIMEOFDAY) && defined(VMS)
708180a3
TK
226# define HAS_GETTIMEOFDAY
227
228# include <lnmdef.h>
229# include <time.h> /* gettimeofday */
230# include <stdlib.h> /* qdiv */
231# include <starlet.h> /* sys$gettim */
232# include <descrip.h>
233# ifdef __VAX
234# include <lib$routines.h> /* lib$ediv() */
235# endif
dcf686c9
JH
236
237/*
238 VMS binary time is expressed in 100 nano-seconds since
239 system base time which is 17-NOV-1858 00:00:00.00
240*/
241
708180a3
TK
242# define DIV_100NS_TO_SECS 10000000L
243# define DIV_100NS_TO_USECS 10L
dcf686c9 244
708180a3 245/*
dcf686c9
JH
246 gettimeofday is supposed to return times since the epoch
247 so need to determine this in terms of VMS base time
248*/
249static $DESCRIPTOR(dscepoch,"01-JAN-1970 00:00:00.00");
250
708180a3 251# ifdef __VAX
3785778e 252static long base_adjust[2]={0L,0L};
708180a3 253# else
dcf686c9 254static __int64 base_adjust=0;
708180a3 255# endif
dcf686c9 256
708180a3 257/*
9b6f56ad
CL
258
259 If we don't have gettimeofday, then likely we are on a VMS machine that
260 operates on local time rather than UTC...so we have to zone-adjust.
708180a3 261 This code gleefully swiped from VMS.C
9b6f56ad
CL
262
263*/
264/* method used to handle UTC conversions:
265 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
266 */
267static int gmtime_emulation_type;
268/* number of secs to add to UTC POSIX-style time to get local time */
269static long int utc_offset_secs;
708180a3
TK
270static struct dsc$descriptor_s fildevdsc =
271 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
9b6f56ad
CL
272static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
273
274static time_t toutc_dst(time_t loc) {
708180a3 275 struct tm *rsltmp;
9b6f56ad 276
708180a3
TK
277 if ((rsltmp = localtime(&loc)) == NULL) return -1;
278 loc -= utc_offset_secs;
279 if (rsltmp->tm_isdst) loc -= 3600;
280 return loc;
9b6f56ad
CL
281}
282
283static time_t toloc_dst(time_t utc) {
708180a3 284 struct tm *rsltmp;
9b6f56ad 285
708180a3
TK
286 utc += utc_offset_secs;
287 if ((rsltmp = localtime(&utc)) == NULL) return -1;
288 if (rsltmp->tm_isdst) utc += 3600;
289 return utc;
9b6f56ad
CL
290}
291
708180a3
TK
292# define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
293 ((gmtime_emulation_type || timezone_setup()), \
294 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
295 ((secs) - utc_offset_secs))))
9b6f56ad 296
708180a3
TK
297# define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
298 ((gmtime_emulation_type || timezone_setup()), \
299 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
300 ((secs) + utc_offset_secs))))
9b6f56ad
CL
301
302static int
708180a3 303timezone_setup(void)
9b6f56ad 304{
708180a3 305 struct tm *tm_p;
9b6f56ad 306
708180a3
TK
307 if (gmtime_emulation_type == 0) {
308 int dstnow;
309 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
310 /* results of calls to gmtime() and localtime() */
311 /* for same &base */
9b6f56ad 312
9b6f56ad 313 gmtime_emulation_type++;
708180a3
TK
314 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
315 char off[LNM$C_NAMLENGTH+1];;
316
317 gmtime_emulation_type++;
318 if (!Perl_vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
319 gmtime_emulation_type++;
320 utc_offset_secs = 0;
321 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
322 }
323 else { utc_offset_secs = atol(off); }
324 }
325 else { /* We've got a working gmtime() */
326 struct tm gmt, local;
327
328 gmt = *tm_p;
329 tm_p = localtime(&base);
330 local = *tm_p;
331 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
332 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
333 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
334 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
335 }
9b6f56ad 336 }
708180a3 337 return 1;
9b6f56ad
CL
338}
339
340
dcf686c9
JH
341int
342gettimeofday (struct timeval *tp, void *tpz)
343{
708180a3
TK
344 long ret;
345# ifdef __VAX
346 long quad[2];
347 long quad1[2];
348 long div_100ns_to_secs;
349 long div_100ns_to_usecs;
350 long quo,rem;
351 long quo1,rem1;
352# else
353 __int64 quad;
354 __qdiv_t ans1,ans2;
355# endif
356 /*
dcf686c9
JH
357 In case of error, tv_usec = 0 and tv_sec = VMS condition code.
358 The return from function is also set to -1.
359 This is not exactly as per the manual page.
708180a3 360 */
dcf686c9 361
708180a3 362 tp->tv_usec = 0;
dcf686c9 363
708180a3
TK
364# ifdef __VAX
365 if (base_adjust[0]==0 && base_adjust[1]==0) {
366# else
367 if (base_adjust==0) { /* Need to determine epoch adjustment */
368# endif
dcf686c9
JH
369 ret=sys$bintim(&dscepoch,&base_adjust);
370 if (1 != (ret &&1)) {
708180a3
TK
371 tp->tv_sec = ret;
372 return -1;
dcf686c9 373 }
708180a3 374 }
dcf686c9 375
708180a3
TK
376 ret=sys$gettim(&quad); /* Get VMS system time */
377 if ((1 && ret) == 1) {
378# ifdef __VAX
3785778e
PP
379 quad[0] -= base_adjust[0]; /* convert to epoch offset */
380 quad[1] -= base_adjust[1]; /* convert 2nd half of quadword */
381 div_100ns_to_secs = DIV_100NS_TO_SECS;
382 div_100ns_to_usecs = DIV_100NS_TO_USECS;
383 lib$ediv(&div_100ns_to_secs,&quad,&quo,&rem);
384 quad1[0] = rem;
385 quad1[1] = 0L;
386 lib$ediv(&div_100ns_to_usecs,&quad1,&quo1,&rem1);
387 tp->tv_sec = quo; /* Whole seconds */
388 tp->tv_usec = quo1; /* Micro-seconds */
708180a3 389# else
3785778e 390 quad -= base_adjust; /* convert to epoch offset */
dcf686c9
JH
391 ans1=qdiv(quad,DIV_100NS_TO_SECS);
392 ans2=qdiv(ans1.rem,DIV_100NS_TO_USECS);
393 tp->tv_sec = ans1.quot; /* Whole seconds */
394 tp->tv_usec = ans2.quot; /* Micro-seconds */
708180a3
TK
395# endif
396 } else {
dcf686c9
JH
397 tp->tv_sec = ret;
398 return -1;
708180a3
TK
399 }
400# ifdef VMSISH_TIME
401# ifdef RTL_USES_UTC
402 if (VMSISH_TIME) tp->tv_sec = _toloc(tp->tv_sec);
403# else
404 if (!VMSISH_TIME) tp->tv_sec = _toutc(tp->tv_sec);
405# endif
406# endif
407 return 0;
dcf686c9 408}
708180a3 409#endif /* #if !defined(HAS_GETTIMEOFDAY) && defined(VMS) */
dcf686c9 410
3f2ee006 411
046e3f33 412 /* Do not use H A S _ N A N O S L E E P
70cf0185
SP
413 * so that Perl Configure doesn't scan for it (and pull in -lrt and
414 * the like which are not usually good ideas for the default Perl).
e5433ad8 415 * (We are part of the core perl now.)
046e3f33
JH
416 * The TIME_HIRES_NANOSLEEP is set by Makefile.PL. */
417#if !defined(HAS_USLEEP) && defined(TIME_HIRES_NANOSLEEP)
708180a3
TK
418# define HAS_USLEEP
419# define usleep hrt_usleep /* could conflict with ncurses for static build */
3f2ee006 420
4e922c26 421static void
e5620114 422hrt_usleep(unsigned long usec) /* This is used to emulate usleep. */
3f2ee006
HS
423{
424 struct timespec res;
47e797f6
SP
425 res.tv_sec = usec / IV_1E6;
426 res.tv_nsec = ( usec - res.tv_sec * IV_1E6 ) * 1000;
3f2ee006
HS
427 nanosleep(&res, NULL);
428}
3f2ee006 429
44d3ce20 430#endif /* #if !defined(HAS_USLEEP) && defined(TIME_HIRES_NANOSLEEP) */
3f2ee006 431
dcf686c9 432#if !defined(HAS_USLEEP) && defined(HAS_SELECT)
708180a3
TK
433# ifndef SELECT_IS_BROKEN
434# define HAS_USLEEP
435# define usleep hrt_usleep /* could conflict with ncurses for static build */
dcf686c9 436
4e922c26 437static void
dcf686c9
JH
438hrt_usleep(unsigned long usec)
439{
440 struct timeval tv;
441 tv.tv_sec = 0;
442 tv.tv_usec = usec;
443 select(0, (Select_fd_set_t)NULL, (Select_fd_set_t)NULL,
708180a3 444 (Select_fd_set_t)NULL, &tv);
dcf686c9 445}
708180a3 446# endif
44d3ce20 447#endif /* #if !defined(HAS_USLEEP) && defined(HAS_SELECT) */
dcf686c9
JH
448
449#if !defined(HAS_USLEEP) && defined(WIN32)
708180a3
TK
450# define HAS_USLEEP
451# define usleep hrt_usleep /* could conflict with ncurses for static build */
dcf686c9 452
4e922c26 453static void
dcf686c9
JH
454hrt_usleep(unsigned long usec)
455{
456 long msec;
457 msec = usec / 1000;
458 Sleep (msec);
459}
44d3ce20 460#endif /* #if !defined(HAS_USLEEP) && defined(WIN32) */
dcf686c9 461
e5433ad8 462#if !defined(HAS_USLEEP) && defined(HAS_POLL)
708180a3
TK
463# define HAS_USLEEP
464# define usleep hrt_usleep /* could conflict with ncurses for static build */
e5433ad8 465
4e922c26 466static void
e5433ad8
SP
467hrt_usleep(unsigned long usec)
468{
469 int msec = usec / 1000;
470 poll(0, 0, msec);
471}
472
473#endif /* #if !defined(HAS_USLEEP) && defined(HAS_POLL) */
dcf686c9 474
34f69483 475#if defined(HAS_SETITIMER) && defined(ITIMER_REAL)
bf8300de
RGS
476
477static int
68c5b4db 478hrt_ualarm_itimero(struct itimerval *oitv, int usec, int uinterval)
bf8300de 479{
708180a3
TK
480 struct itimerval itv;
481 itv.it_value.tv_sec = usec / IV_1E6;
482 itv.it_value.tv_usec = usec % IV_1E6;
483 itv.it_interval.tv_sec = uinterval / IV_1E6;
484 itv.it_interval.tv_usec = uinterval % IV_1E6;
485 return setitimer(ITIMER_REAL, &itv, oitv);
bf8300de
RGS
486}
487
44d3ce20 488#endif /* #if !defined(HAS_UALARM) && defined(HAS_SETITIMER) */
dcf686c9 489
34f69483 490#if !defined(HAS_UALARM) && defined(HAS_SETITIMER)
708180a3
TK
491# define HAS_UALARM
492# define ualarm hrt_ualarm_itimer /* could conflict with ncurses for static build */
34f69483
SP
493#endif
494
ca40fe49 495#if !defined(HAS_UALARM) && defined(VMS)
708180a3
TK
496# define HAS_UALARM
497# define ualarm vms_ualarm
ca40fe49 498
708180a3
TK
499# include <lib$routines.h>
500# include <ssdef.h>
501# include <starlet.h>
502# include <descrip.h>
503# include <signal.h>
504# include <jpidef.h>
505# include <psldef.h>
ca40fe49 506
708180a3 507# define VMSERR(s) (!((s)&1))
ca40fe49
CL
508
509static void
510us_to_VMS(useconds_t mseconds, unsigned long v[])
511{
512 int iss;
513 unsigned long qq[2];
514
515 qq[0] = mseconds;
516 qq[1] = 0;
517 v[0] = v[1] = 0;
518
519 iss = lib$addx(qq,qq,qq);
520 if (VMSERR(iss)) lib$signal(iss);
521 iss = lib$subx(v,qq,v);
522 if (VMSERR(iss)) lib$signal(iss);
523 iss = lib$addx(qq,qq,qq);
524 if (VMSERR(iss)) lib$signal(iss);
525 iss = lib$subx(v,qq,v);
526 if (VMSERR(iss)) lib$signal(iss);
527 iss = lib$subx(v,qq,v);
528 if (VMSERR(iss)) lib$signal(iss);
529}
530
531static int
532VMS_to_us(unsigned long v[])
533{
534 int iss;
535 unsigned long div=10,quot, rem;
536
537 iss = lib$ediv(&div,v,&quot,&rem);
538 if (VMSERR(iss)) lib$signal(iss);
539
540 return quot;
541}
542
543typedef unsigned short word;
544typedef struct _ualarm {
545 int function;
546 int repeat;
547 unsigned long delay[2];
548 unsigned long interval[2];
549 unsigned long remain[2];
550} Alarm;
551
552
553static int alarm_ef;
554static Alarm *a0, alarm_base;
708180a3
TK
555# define UAL_NULL 0
556# define UAL_SET 1
557# define UAL_CLEAR 2
558# define UAL_ACTIVE 4
ca40fe49
CL
559static void ualarm_AST(Alarm *a);
560
708180a3 561static int
ca40fe49
CL
562vms_ualarm(int mseconds, int interval)
563{
564 Alarm *a, abase;
565 struct item_list3 {
566 word length;
567 word code;
568 void *bufaddr;
569 void *retlenaddr;
570 } ;
571 static struct item_list3 itmlst[2];
572 static int first = 1;
573 unsigned long asten;
574 int iss, enabled;
575
576 if (first) {
577 first = 0;
578 itmlst[0].code = JPI$_ASTEN;
579 itmlst[0].length = sizeof(asten);
580 itmlst[0].retlenaddr = NULL;
581 itmlst[1].code = 0;
582 itmlst[1].length = 0;
583 itmlst[1].bufaddr = NULL;
584 itmlst[1].retlenaddr = NULL;
585
586 iss = lib$get_ef(&alarm_ef);
587 if (VMSERR(iss)) lib$signal(iss);
588
589 a0 = &alarm_base;
590 a0->function = UAL_NULL;
591 }
592 itmlst[0].bufaddr = &asten;
708180a3 593
ca40fe49
CL
594 iss = sys$getjpiw(0,0,0,itmlst,0,0,0);
595 if (VMSERR(iss)) lib$signal(iss);
596 if (!(asten&0x08)) return -1;
597
598 a = &abase;
599 if (mseconds) {
600 a->function = UAL_SET;
601 } else {
602 a->function = UAL_CLEAR;
603 }
604
605 us_to_VMS(mseconds, a->delay);
606 if (interval) {
607 us_to_VMS(interval, a->interval);
608 a->repeat = 1;
708180a3 609 } else
ca40fe49
CL
610 a->repeat = 0;
611
612 iss = sys$clref(alarm_ef);
613 if (VMSERR(iss)) lib$signal(iss);
614
615 iss = sys$dclast(ualarm_AST,a,0);
616 if (VMSERR(iss)) lib$signal(iss);
617
618 iss = sys$waitfr(alarm_ef);
619 if (VMSERR(iss)) lib$signal(iss);
620
708180a3 621 if (a->function == UAL_ACTIVE)
ca40fe49
CL
622 return VMS_to_us(a->remain);
623 else
624 return 0;
625}
626
627
628
629static void
630ualarm_AST(Alarm *a)
631{
632 int iss;
633 unsigned long now[2];
634
635 iss = sys$gettim(now);
636 if (VMSERR(iss)) lib$signal(iss);
637
638 if (a->function == UAL_SET || a->function == UAL_CLEAR) {
639 if (a0->function == UAL_ACTIVE) {
640 iss = sys$cantim(a0,PSL$C_USER);
641 if (VMSERR(iss)) lib$signal(iss);
642
643 iss = lib$subx(a0->remain, now, a->remain);
644 if (VMSERR(iss)) lib$signal(iss);
645
708180a3 646 if (a->remain[1] & 0x80000000)
ca40fe49
CL
647 a->remain[0] = a->remain[1] = 0;
648 }
649
650 if (a->function == UAL_SET) {
651 a->function = a0->function;
652 a0->function = UAL_ACTIVE;
653 a0->repeat = a->repeat;
654 if (a0->repeat) {
655 a0->interval[0] = a->interval[0];
656 a0->interval[1] = a->interval[1];
657 }
658 a0->delay[0] = a->delay[0];
659 a0->delay[1] = a->delay[1];
660
661 iss = lib$subx(now, a0->delay, a0->remain);
662 if (VMSERR(iss)) lib$signal(iss);
663
664 iss = sys$setimr(0,a0->delay,ualarm_AST,a0);
665 if (VMSERR(iss)) lib$signal(iss);
666 } else {
667 a->function = a0->function;
668 a0->function = UAL_NULL;
669 }
670 iss = sys$setef(alarm_ef);
671 if (VMSERR(iss)) lib$signal(iss);
672 } else if (a->function == UAL_ACTIVE) {
673 if (a->repeat) {
674 iss = lib$subx(now, a->interval, a->remain);
675 if (VMSERR(iss)) lib$signal(iss);
676
677 iss = sys$setimr(0,a->interval,ualarm_AST,a);
678 if (VMSERR(iss)) lib$signal(iss);
679 } else {
680 a->function = UAL_NULL;
681 }
682 iss = sys$wake(0,0);
683 if (VMSERR(iss)) lib$signal(iss);
684 lib$signal(SS$_ASTFLT);
685 } else {
686 lib$signal(SS$_BADPARAM);
687 }
688}
689
44d3ce20 690#endif /* #if !defined(HAS_UALARM) && defined(VMS) */
ca40fe49 691
dcf686c9
JH
692#ifdef HAS_GETTIMEOFDAY
693
a2e20b18 694static int
0225372c 695myU2time(pTHX_ UV *ret)
dcf686c9 696{
708180a3
TK
697 struct timeval Tp;
698 int status;
699 status = gettimeofday (&Tp, NULL);
700 ret[0] = Tp.tv_sec;
701 ret[1] = Tp.tv_usec;
702 return status;
dcf686c9
JH
703}
704
3c72ec00 705static NV
dcf686c9
JH
706myNVtime()
707{
708180a3
TK
708# ifdef WIN32
709 dTHX;
710# endif
711 struct timeval Tp;
712 int status;
713 status = gettimeofday (&Tp, NULL);
714 return status == 0 ? Tp.tv_sec + (Tp.tv_usec / NV_1E6) : -1.0;
dcf686c9
JH
715}
716
44d3ce20 717#endif /* #ifdef HAS_GETTIMEOFDAY */
dcf686c9 718
75d5269b 719static void
91a2e9f6 720hrstatns(UV *atime_nsec, UV *mtime_nsec, UV *ctime_nsec)
75d5269b 721{
708180a3 722 dTHX;
75d5269b 723#if TIME_HIRES_STAT == 1
708180a3
TK
724 *atime_nsec = PL_statcache.st_atimespec.tv_nsec;
725 *mtime_nsec = PL_statcache.st_mtimespec.tv_nsec;
726 *ctime_nsec = PL_statcache.st_ctimespec.tv_nsec;
91a2e9f6 727#elif TIME_HIRES_STAT == 2
708180a3
TK
728 *atime_nsec = PL_statcache.st_atimensec;
729 *mtime_nsec = PL_statcache.st_mtimensec;
730 *ctime_nsec = PL_statcache.st_ctimensec;
91a2e9f6 731#elif TIME_HIRES_STAT == 3
708180a3
TK
732 *atime_nsec = PL_statcache.st_atime_n;
733 *mtime_nsec = PL_statcache.st_mtime_n;
734 *ctime_nsec = PL_statcache.st_ctime_n;
91a2e9f6 735#elif TIME_HIRES_STAT == 4
708180a3
TK
736 *atime_nsec = PL_statcache.st_atim.tv_nsec;
737 *mtime_nsec = PL_statcache.st_mtim.tv_nsec;
738 *ctime_nsec = PL_statcache.st_ctim.tv_nsec;
91a2e9f6 739#elif TIME_HIRES_STAT == 5
708180a3
TK
740 *atime_nsec = PL_statcache.st_uatime * 1000;
741 *mtime_nsec = PL_statcache.st_umtime * 1000;
742 *ctime_nsec = PL_statcache.st_uctime * 1000;
91a2e9f6 743#else /* !TIME_HIRES_STAT */
708180a3
TK
744 *atime_nsec = 0;
745 *mtime_nsec = 0;
746 *ctime_nsec = 0;
91a2e9f6 747#endif /* !TIME_HIRES_STAT */
75d5269b
SP
748}
749
c4a535af
SH
750/* Until Apple implements clock_gettime()
751 * (ditto clock_getres() and clock_nanosleep())
752 * we will emulate them using the Mach kernel interfaces. */
753#if defined(PERL_DARWIN) && \
754 (defined(TIME_HIRES_CLOCK_GETTIME_EMULATION) || \
755 defined(TIME_HIRES_CLOCK_GETRES_EMULATION) || \
756 defined(TIME_HIRES_CLOCK_NANOSLEEP_EMULATION))
757
708180a3
TK
758# ifndef CLOCK_REALTIME
759# define CLOCK_REALTIME 0x01
760# define CLOCK_MONOTONIC 0x02
761# endif
1e845d0c 762
708180a3
TK
763# ifndef TIMER_ABSTIME
764# define TIMER_ABSTIME 0x01
765# endif
1e845d0c 766
708180a3
TK
767# ifdef USE_ITHREADS
768# define PERL_DARWIN_MUTEX
769# endif
c4a535af 770
708180a3 771# ifdef PERL_DARWIN_MUTEX
1e845d0c 772STATIC perl_mutex darwin_time_mutex;
708180a3 773# endif
1e845d0c 774
708180a3 775# include <mach/mach_time.h>
c4a535af 776
1e845d0c
JH
777static uint64_t absolute_time_init;
778static mach_timebase_info_data_t timebase_info;
779static struct timespec timespec_init;
780
781static int darwin_time_init() {
708180a3
TK
782 struct timeval tv;
783 int success = 1;
784# ifdef PERL_DARWIN_MUTEX
785 MUTEX_LOCK(&darwin_time_mutex);
786# endif
787 if (absolute_time_init == 0) {
788 /* mach_absolute_time() cannot fail */
789 absolute_time_init = mach_absolute_time();
790 success = mach_timebase_info(&timebase_info) == KERN_SUCCESS;
791 if (success) {
792 success = gettimeofday(&tv, NULL) == 0;
793 if (success) {
794 timespec_init.tv_sec = tv.tv_sec;
795 timespec_init.tv_nsec = tv.tv_usec * 1000;
796 }
797 }
1e845d0c 798 }
708180a3
TK
799# ifdef PERL_DARWIN_MUTEX
800 MUTEX_UNLOCK(&darwin_time_mutex);
801# endif
802 return success;
1e845d0c
JH
803}
804
708180a3 805# ifdef TIME_HIRES_CLOCK_GETTIME_EMULATION
45bbc013 806static int th_clock_gettime(clockid_t clock_id, struct timespec *ts) {
708180a3
TK
807 if (darwin_time_init() && timebase_info.denom) {
808 switch (clock_id) {
809 case CLOCK_REALTIME:
810 {
811 uint64_t nanos =
812 ((mach_absolute_time() - absolute_time_init) *
813 (uint64_t)timebase_info.numer) / (uint64_t)timebase_info.denom;
814 ts->tv_sec = timespec_init.tv_sec + nanos / IV_1E9;
815 ts->tv_nsec = timespec_init.tv_nsec + nanos % IV_1E9;
816 return 0;
817 }
818
819 case CLOCK_MONOTONIC:
820 {
821 uint64_t nanos =
822 (mach_absolute_time() *
823 (uint64_t)timebase_info.numer) / (uint64_t)timebase_info.denom;
824 ts->tv_sec = nanos / IV_1E9;
825 ts->tv_nsec = nanos - ts->tv_sec * IV_1E9;
826 return 0;
827 }
828
829 default:
830 break;
831 }
1e845d0c 832 }
1e845d0c 833
708180a3
TK
834 SETERRNO(EINVAL, LIB_INVARG);
835 return -1;
1e845d0c 836}
45bbc013 837
708180a3 838# define clock_gettime(clock_id, ts) th_clock_gettime((clock_id), (ts))
45bbc013 839
708180a3 840# endif /* TIME_HIRES_CLOCK_GETTIME_EMULATION */
1e845d0c 841
708180a3 842# ifdef TIME_HIRES_CLOCK_GETRES_EMULATION
45bbc013 843static int th_clock_getres(clockid_t clock_id, struct timespec *ts) {
708180a3
TK
844 if (darwin_time_init() && timebase_info.denom) {
845 switch (clock_id) {
846 case CLOCK_REALTIME:
847 case CLOCK_MONOTONIC:
848 ts->tv_sec = 0;
849 /* In newer kernels both the numer and denom are one,
850 * resulting in conversion factor of one, which is of
851 * course unrealistic. */
852 ts->tv_nsec = timebase_info.numer / timebase_info.denom;
853 return 0;
854 default:
855 break;
856 }
1e845d0c 857 }
1e845d0c 858
708180a3
TK
859 SETERRNO(EINVAL, LIB_INVARG);
860 return -1;
1e845d0c 861}
45bbc013 862
708180a3
TK
863# define clock_getres(clock_id, ts) th_clock_getres((clock_id), (ts))
864# endif /* TIME_HIRES_CLOCK_GETRES_EMULATION */
1e845d0c 865
708180a3 866# ifdef TIME_HIRES_CLOCK_NANOSLEEP_EMULATION
45bbc013 867static int th_clock_nanosleep(clockid_t clock_id, int flags,
708180a3
TK
868 const struct timespec *rqtp,
869 struct timespec *rmtp) {
870 if (darwin_time_init()) {
871 switch (clock_id) {
872 case CLOCK_REALTIME:
873 case CLOCK_MONOTONIC:
874 {
875 uint64_t nanos = rqtp->tv_sec * IV_1E9 + rqtp->tv_nsec;
876 int success;
877 if ((flags & TIMER_ABSTIME)) {
878 uint64_t back =
879 timespec_init.tv_sec * IV_1E9 + timespec_init.tv_nsec;
880 nanos = nanos > back ? nanos - back : 0;
881 }
882 success =
883 mach_wait_until(mach_absolute_time() + nanos) == KERN_SUCCESS;
884
885 /* In the relative sleep, the rmtp should be filled in with
886 * the 'unused' part of the rqtp in case the sleep gets
887 * interrupted by a signal. But it is unknown how signals
888 * interact with mach_wait_until(). In the absolute sleep,
889 * the rmtp should stay untouched. */
890 rmtp->tv_sec = 0;
891 rmtp->tv_nsec = 0;
892
893 return success;
894 }
895
896 default:
897 break;
898 }
3b614a59 899 }
3b614a59 900
708180a3
TK
901 SETERRNO(EINVAL, LIB_INVARG);
902 return -1;
3b614a59 903}
45bbc013 904
708180a3 905# define clock_nanosleep(clock_id, flags, rqtp, rmtp) \
45bbc013
TC
906 th_clock_nanosleep((clock_id), (flags), (rqtp), (rmtp))
907
708180a3 908# endif /* TIME_HIRES_CLOCK_NANOSLEEP_EMULATION */
3b614a59 909
1e845d0c
JH
910#endif /* PERL_DARWIN */
911
8eedd56d
CBW
912/* The macOS headers warn about using certain interfaces in
913 * OS-release-ignorant manner, for example:
914 *
915 * warning: 'futimens' is only available on macOS 10.13 or newer
916 * [-Wunguarded-availability-new]
917 *
918 * (ditto for utimensat)
919 *
920 * There is clang __builtin_available() *runtime* check for this.
921 * The gotchas are that neither __builtin_available() nor __has_builtin()
922 * are always available.
923 */
924#ifndef __has_builtin
708180a3 925# define __has_builtin(x) 0 /* non-clang */
8eedd56d
CBW
926#endif
927#ifdef HAS_FUTIMENS
708180a3
TK
928# if defined(PERL_DARWIN) && __has_builtin(__builtin_available)
929# define FUTIMENS_AVAILABLE __builtin_available(macOS 10.13, *)
930# else
931# define FUTIMENS_AVAILABLE 1
932# endif
8eedd56d 933#else
708180a3 934# define FUTIMENS_AVAILABLE 0
8eedd56d
CBW
935#endif
936#ifdef HAS_UTIMENSAT
708180a3
TK
937# if defined(PERL_DARWIN) && __has_builtin(__builtin_available)
938# define UTIMENSAT_AVAILABLE __builtin_available(macOS 10.13, *)
939# else
940# define UTIMENSAT_AVAILABLE 1
941# endif
8eedd56d 942#else
708180a3 943# define UTIMENSAT_AVAILABLE 0
8eedd56d
CBW
944#endif
945
82cbdcc3
SP
946#include "const-c.inc"
947
24e1662b
JH
948#if (defined(TIME_HIRES_NANOSLEEP)) || \
949 (defined(TIME_HIRES_CLOCK_NANOSLEEP) && defined(TIMER_ABSTIME))
950
e3ff671b
JH
951static void
952nanosleep_init(NV nsec,
953 struct timespec *sleepfor,
954 struct timespec *unslept) {
955 sleepfor->tv_sec = (Time_t)(nsec / NV_1E9);
956 sleepfor->tv_nsec = (long)(nsec - ((NV)sleepfor->tv_sec) * NV_1E9);
957 unslept->tv_sec = 0;
958 unslept->tv_nsec = 0;
959}
960
24e1662b
JH
961static NV
962nsec_without_unslept(struct timespec *sleepfor,
963 const struct timespec *unslept) {
708180a3
TK
964 if (sleepfor->tv_sec >= unslept->tv_sec) {
965 sleepfor->tv_sec -= unslept->tv_sec;
966 if (sleepfor->tv_nsec >= unslept->tv_nsec) {
967 sleepfor->tv_nsec -= unslept->tv_nsec;
968 } else if (sleepfor->tv_sec > 0) {
969 sleepfor->tv_sec--;
970 sleepfor->tv_nsec += IV_1E9;
971 sleepfor->tv_nsec -= unslept->tv_nsec;
972 } else {
973 sleepfor->tv_sec = 0;
974 sleepfor->tv_nsec = 0;
975 }
ea21af8c 976 } else {
708180a3
TK
977 sleepfor->tv_sec = 0;
978 sleepfor->tv_nsec = 0;
ea21af8c 979 }
708180a3 980 return ((NV)sleepfor->tv_sec) * NV_1E9 + ((NV)sleepfor->tv_nsec);
24e1662b
JH
981}
982
983#endif
984
c4a535af
SH
985/* In case Perl and/or Devel::PPPort are too old, minimally emulate
986 * IS_SAFE_PATHNAME() (which looks for zero bytes in the pathname). */
987#ifndef IS_SAFE_PATHNAME
708180a3
TK
988# if PERL_VERSION >= 12 /* Perl_ck_warner is 5.10.0 -> */
989# ifdef WARN_SYSCALLS
990# define WARNEMUCAT WARN_SYSCALLS /* 5.22.0 -> */
991# else
992# define WARNEMUCAT WARN_MISC
993# endif
994# define WARNEMU(opname) Perl_ck_warner(aTHX_ packWARN(WARNEMUCAT), "Invalid \\0 character in pathname for %s",opname)
995# else
996# define WARNEMU(opname) Perl_warn(aTHX_ "Invalid \\0 character in pathname for %s",opname)
997# endif
998# define IS_SAFE_PATHNAME(pv, len, opname) (((len)>1)&&memchr((pv), 0, (len)-1)?(SETERRNO(ENOENT, LIB_INVARG),WARNEMU(opname),FALSE):(TRUE))
c4a535af
SH
999#endif
1000
dcf686c9
JH
1001MODULE = Time::HiRes PACKAGE = Time::HiRes
1002
1003PROTOTYPES: ENABLE
1004
1005BOOT:
708180a3 1006 {
0225372c 1007#ifdef MY_CXT_KEY
708180a3 1008 MY_CXT_INIT;
0225372c 1009#endif
6abf31df 1010#ifdef HAS_GETTIMEOFDAY
708180a3
TK
1011 {
1012 (void) hv_store(PL_modglobal, "Time::NVtime", 12,
1013 newSViv(PTR2IV(myNVtime)), 0);
1014 (void) hv_store(PL_modglobal, "Time::U2time", 12,
1015 newSViv(PTR2IV(myU2time)), 0);
1016 }
dcf686c9 1017#endif
c4a535af
SH
1018#if defined(PERL_DARWIN)
1019# if defined(USE_ITHREADS) && defined(PERL_DARWIN_MUTEX)
708180a3 1020 MUTEX_INIT(&darwin_time_mutex);
2d639e20
JH
1021# endif
1022#endif
708180a3 1023 }
0225372c
RGS
1024
1025#if defined(USE_ITHREADS) && defined(MY_CXT_KEY)
1026
1027void
1028CLONE(...)
1029 CODE:
708180a3 1030 MY_CXT_CLONE;
0225372c 1031
3f2ee006 1032#endif
dcf686c9 1033
98b50af3 1034INCLUDE: const-xs.inc
3c72ec00 1035
52d72fba 1036#if defined(HAS_USLEEP) && defined(HAS_GETTIMEOFDAY)
dcf686c9 1037
92bc48ca 1038NV
dcf686c9 1039usleep(useconds)
708180a3
TK
1040 NV useconds
1041 PREINIT:
1042 struct timeval Ta, Tb;
1043 CODE:
1044 gettimeofday(&Ta, NULL);
1045 if (items > 0) {
1046 if (useconds >= NV_1E6) {
1047 IV seconds = (IV) (useconds / NV_1E6);
1048 /* If usleep() has been implemented using setitimer()
1049 * then this contortion is unnecessary-- but usleep()
1050 * may be implemented in some other way, so let's contort. */
1051 if (seconds) {
1052 sleep(seconds);
1053 useconds -= NV_1E6 * seconds;
1054 }
1055 } else if (useconds < 0.0)
1056 croak("Time::HiRes::usleep(%" NVgf
a135cb6c 1057 "): negative time not invented yet", useconds);
dcf686c9 1058
708180a3
TK
1059 usleep((U32)useconds);
1060 } else
1061 PerlProc_pause();
52d72fba 1062
708180a3
TK
1063 gettimeofday(&Tb, NULL);
1064# if 0
1065 printf("[%ld %ld] [%ld %ld]\n", Tb.tv_sec, Tb.tv_usec, Ta.tv_sec, Ta.tv_usec);
1066# endif
1067 RETVAL = NV_1E6*(Tb.tv_sec-Ta.tv_sec)+(NV)((IV)Tb.tv_usec-(IV)Ta.tv_usec);
1068
1069 OUTPUT:
1070 RETVAL
1071
1072# if defined(TIME_HIRES_NANOSLEEP)
44d3ce20
RGS
1073
1074NV
170c5524 1075nanosleep(nsec)
708180a3
TK
1076 NV nsec
1077 PREINIT:
1078 struct timespec sleepfor, unslept;
1079 CODE:
1080 if (nsec < 0.0)
1081 croak("Time::HiRes::nanosleep(%" NVgf
a135cb6c 1082 "): negative time not invented yet", nsec);
e3ff671b 1083 nanosleep_init(nsec, &sleepfor, &unslept);
708180a3
TK
1084 if (nanosleep(&sleepfor, &unslept) == 0) {
1085 RETVAL = nsec;
1086 } else {
24e1662b 1087 RETVAL = nsec_without_unslept(&sleepfor, &unslept);
708180a3 1088 }
a8fb48f7 1089 OUTPUT:
708180a3 1090 RETVAL
44d3ce20 1091
708180a3 1092# else /* #if defined(TIME_HIRES_NANOSLEEP) */
ced84e60
SP
1093
1094NV
170c5524 1095nanosleep(nsec)
708180a3 1096 NV nsec
ced84e60 1097 CODE:
708180a3 1098 PERL_UNUSED_ARG(nsec);
ced84e60
SP
1099 croak("Time::HiRes::nanosleep(): unimplemented in this platform");
1100 RETVAL = 0.0;
858dcda5 1101 OUTPUT:
708180a3 1102 RETVAL
ced84e60 1103
708180a3 1104# endif /* #if defined(TIME_HIRES_NANOSLEEP) */
44d3ce20 1105
52d72fba 1106NV
f9d00e57 1107sleep(...)
708180a3
TK
1108 PREINIT:
1109 struct timeval Ta, Tb;
1110 CODE:
1111 gettimeofday(&Ta, NULL);
1112 if (items > 0) {
1113 NV seconds = SvNV(ST(0));
1114 if (seconds >= 0.0) {
1115 UV useconds = (UV)(1E6 * (seconds - (UV)seconds));
1116 if (seconds >= 1.0)
1117 sleep((U32)seconds);
1118 if ((IV)useconds < 0) {
1119# if defined(__sparc64__) && defined(__GNUC__)
1120 /* Sparc64 gcc 2.95.3 (e.g. on NetBSD) has a bug
1121 * where (0.5 - (UV)(0.5)) will under certain
1122 * circumstances (if the double is cast to UV more
1123 * than once?) evaluate to -0.5, instead of 0.5. */
1124 useconds = -(IV)useconds;
1125# endif /* #if defined(__sparc64__) && defined(__GNUC__) */
1126 if ((IV)useconds < 0)
1127 croak("Time::HiRes::sleep(%" NVgf
1128 "): internal error: useconds < 0 (unsigned %" UVuf
1129 " signed %" IVdf ")",
1130 seconds, useconds, (IV)useconds);
1131 }
1132 usleep(useconds);
1133 } else
1134 croak("Time::HiRes::sleep(%" NVgf
a135cb6c 1135 "): negative time not invented yet", seconds);
708180a3
TK
1136 } else
1137 PerlProc_pause();
1138
1139 gettimeofday(&Tb, NULL);
1140# if 0
1141 printf("[%ld %ld] [%ld %ld]\n", Tb.tv_sec, Tb.tv_usec, Ta.tv_sec, Ta.tv_usec);
1142# endif
1143 RETVAL = (NV)(Tb.tv_sec-Ta.tv_sec)+0.000001*(NV)(Tb.tv_usec-Ta.tv_usec);
52d72fba 1144
708180a3
TK
1145 OUTPUT:
1146 RETVAL
dcf686c9 1147
ced84e60
SP
1148#else /* #if defined(HAS_USLEEP) && defined(HAS_GETTIMEOFDAY) */
1149
1150NV
1151usleep(useconds)
708180a3 1152 NV useconds
ced84e60 1153 CODE:
708180a3 1154 PERL_UNUSED_ARG(useconds);
ced84e60
SP
1155 croak("Time::HiRes::usleep(): unimplemented in this platform");
1156 RETVAL = 0.0;
858dcda5 1157 OUTPUT:
708180a3 1158 RETVAL
ced84e60 1159
44d3ce20 1160#endif /* #if defined(HAS_USLEEP) && defined(HAS_GETTIMEOFDAY) */
dcf686c9
JH
1161
1162#ifdef HAS_UALARM
1163
bf8300de
RGS
1164IV
1165ualarm(useconds,uinterval=0)
708180a3
TK
1166 int useconds
1167 int uinterval
1168 CODE:
1169 if (useconds < 0 || uinterval < 0)
1170 croak("Time::HiRes::ualarm(%d, %d): negative time not invented yet", useconds, uinterval);
1171# if defined(HAS_SETITIMER) && defined(ITIMER_REAL)
1172 {
1173 struct itimerval itv;
1174 if (hrt_ualarm_itimero(&itv, useconds, uinterval)) {
1175 /* To conform to ualarm's interface, we're actually ignoring
1176 an error here. */
1177 RETVAL = 0;
1178 } else {
1179 RETVAL = itv.it_value.tv_sec * IV_1E6 + itv.it_value.tv_usec;
1180 }
1181 }
1182# else
1183 if (useconds >= IV_1E6 || uinterval >= IV_1E6)
1184 croak("Time::HiRes::ualarm(%d, %d): useconds or uinterval"
1185 " equal to or more than %" IVdf,
1186 useconds, uinterval, IV_1E6);
dcf686c9 1187
708180a3
TK
1188 RETVAL = ualarm(useconds, uinterval);
1189# endif
1190
1191 OUTPUT:
1192 RETVAL
f7916ddb
JH
1193
1194NV
1195alarm(seconds,interval=0)
708180a3
TK
1196 NV seconds
1197 NV interval
1198 CODE:
1199 if (seconds < 0.0 || interval < 0.0)
1200 croak("Time::HiRes::alarm(%" NVgf ", %" NVgf
a135cb6c 1201 "): negative time not invented yet", seconds, interval);
708180a3
TK
1202
1203 {
1204 IV iseconds = (IV)seconds;
1205 IV iinterval = (IV)interval;
1206 NV fseconds = seconds - iseconds;
1207 NV finterval = interval - iinterval;
1208 IV useconds, uinterval;
1209 if (fseconds >= 1.0 || finterval >= 1.0)
1210 croak("Time::HiRes::alarm(%" NVgf ", %" NVgf
a135cb6c
KW
1211 "): seconds or interval too large to split correctly",
1212 seconds, interval);
708180a3
TK
1213
1214 useconds = IV_1E6 * fseconds;
1215 uinterval = IV_1E6 * finterval;
1216# if defined(HAS_SETITIMER) && defined(ITIMER_REAL)
1217 {
1218 struct itimerval nitv, oitv;
1219 nitv.it_value.tv_sec = iseconds;
1220 nitv.it_value.tv_usec = useconds;
1221 nitv.it_interval.tv_sec = iinterval;
1222 nitv.it_interval.tv_usec = uinterval;
1223 if (setitimer(ITIMER_REAL, &nitv, &oitv)) {
1224 /* To conform to alarm's interface, we're actually ignoring
1225 an error here. */
1226 RETVAL = 0;
1227 } else {
1228 RETVAL = oitv.it_value.tv_sec + ((NV)oitv.it_value.tv_usec) / NV_1E6;
1229 }
1230 }
1231# else
1232 if (iseconds || iinterval)
1233 croak("Time::HiRes::alarm(%" NVgf ", %" NVgf
a135cb6c
KW
1234 "): seconds or interval equal to or more than 1.0 ",
1235 seconds, interval);
dcf686c9 1236
708180a3
TK
1237 RETVAL = (NV)ualarm( useconds, uinterval ) / NV_1E6;
1238# endif
1239 }
c6c619a9 1240
708180a3
TK
1241 OUTPUT:
1242 RETVAL
1243
1244#else /* #ifdef HAS_UALARM */
ced84e60
SP
1245
1246int
1247ualarm(useconds,interval=0)
708180a3
TK
1248 int useconds
1249 int interval
ced84e60 1250 CODE:
708180a3
TK
1251 PERL_UNUSED_ARG(useconds);
1252 PERL_UNUSED_ARG(interval);
ced84e60 1253 croak("Time::HiRes::ualarm(): unimplemented in this platform");
708180a3 1254 RETVAL = -1;
858dcda5 1255 OUTPUT:
708180a3 1256 RETVAL
ced84e60
SP
1257
1258NV
1259alarm(seconds,interval=0)
708180a3
TK
1260 NV seconds
1261 NV interval
ced84e60 1262 CODE:
708180a3
TK
1263 PERL_UNUSED_ARG(seconds);
1264 PERL_UNUSED_ARG(interval);
ced84e60 1265 croak("Time::HiRes::alarm(): unimplemented in this platform");
708180a3 1266 RETVAL = 0.0;
858dcda5 1267 OUTPUT:
708180a3 1268 RETVAL
ced84e60 1269
44d3ce20 1270#endif /* #ifdef HAS_UALARM */
dcf686c9
JH
1271
1272#ifdef HAS_GETTIMEOFDAY
1273
727404d0
TR
1274void
1275gettimeofday()
708180a3 1276 PREINIT:
727404d0 1277 struct timeval Tp;
708180a3
TK
1278 PPCODE:
1279 int status;
727404d0 1280 status = gettimeofday (&Tp, NULL);
708180a3
TK
1281 if (status == 0) {
1282 if (GIMME == G_ARRAY) {
1283 EXTEND(sp, 2);
1284 PUSHs(sv_2mortal(newSViv(Tp.tv_sec)));
1285 PUSHs(sv_2mortal(newSViv(Tp.tv_usec)));
1286 } else {
1287 EXTEND(sp, 1);
1288 PUSHs(sv_2mortal(newSVnv(Tp.tv_sec + (Tp.tv_usec / NV_1E6))));
1289 }
13813507 1290 }
13813507 1291
727404d0
TR
1292NV
1293time()
708180a3 1294 PREINIT:
727404d0 1295 struct timeval Tp;
708180a3
TK
1296 CODE:
1297 int status;
727404d0 1298 status = gettimeofday (&Tp, NULL);
708180a3 1299 if (status == 0) {
727404d0 1300 RETVAL = Tp.tv_sec + (Tp.tv_usec / NV_1E6);
708180a3
TK
1301 } else {
1302 RETVAL = -1.0;
1303 }
1304 OUTPUT:
1305 RETVAL
dcf686c9 1306
44d3ce20 1307#endif /* #ifdef HAS_GETTIMEOFDAY */
dcf686c9 1308
3c72ec00
JH
1309#if defined(HAS_GETITIMER) && defined(HAS_SETITIMER)
1310
708180a3 1311# define TV2NV(tv) ((NV)((tv).tv_sec) + 0.000001 * (NV)((tv).tv_usec))
3c72ec00
JH
1312
1313void
1314setitimer(which, seconds, interval = 0)
708180a3
TK
1315 int which
1316 NV seconds
1317 NV interval
3c72ec00 1318 PREINIT:
708180a3
TK
1319 struct itimerval newit;
1320 struct itimerval oldit;
3c72ec00 1321 PPCODE:
708180a3
TK
1322 if (seconds < 0.0 || interval < 0.0)
1323 croak("Time::HiRes::setitimer(%" IVdf ", %" NVgf ", %" NVgf
a135cb6c
KW
1324 "): negative time not invented yet",
1325 (IV)which, seconds, interval);
708180a3
TK
1326 newit.it_value.tv_sec = (IV)seconds;
1327 newit.it_value.tv_usec =
1328 (IV)((seconds - (NV)newit.it_value.tv_sec) * NV_1E6);
1329 newit.it_interval.tv_sec = (IV)interval;
1330 newit.it_interval.tv_usec =
1331 (IV)((interval - (NV)newit.it_interval.tv_sec) * NV_1E6);
120b53f9
RS
1332 /* on some platforms the 1st arg to setitimer is an enum, which
1333 * causes -Wc++-compat to complain about passing an int instead
1334 */
7347ee54 1335 GCC_DIAG_IGNORE_STMT(-Wc++-compat);
708180a3
TK
1336 if (setitimer(which, &newit, &oldit) == 0) {
1337 EXTEND(sp, 1);
1338 PUSHs(sv_2mortal(newSVnv(TV2NV(oldit.it_value))));
1339 if (GIMME == G_ARRAY) {
1340 EXTEND(sp, 1);
1341 PUSHs(sv_2mortal(newSVnv(TV2NV(oldit.it_interval))));
1342 }
1343 }
7347ee54 1344 GCC_DIAG_RESTORE_STMT;
3c72ec00
JH
1345
1346void
1347getitimer(which)
708180a3 1348 int which
3c72ec00 1349 PREINIT:
708180a3 1350 struct itimerval nowit;
3c72ec00 1351 PPCODE:
120b53f9
RS
1352 /* on some platforms the 1st arg to getitimer is an enum, which
1353 * causes -Wc++-compat to complain about passing an int instead
1354 */
7347ee54 1355 GCC_DIAG_IGNORE_STMT(-Wc++-compat);
708180a3
TK
1356 if (getitimer(which, &nowit) == 0) {
1357 EXTEND(sp, 1);
1358 PUSHs(sv_2mortal(newSVnv(TV2NV(nowit.it_value))));
1359 if (GIMME == G_ARRAY) {
1360 EXTEND(sp, 1);
1361 PUSHs(sv_2mortal(newSVnv(TV2NV(nowit.it_interval))));
1362 }
1363 }
7347ee54 1364 GCC_DIAG_RESTORE_STMT;
3c72ec00 1365
44d3ce20
RGS
1366#endif /* #if defined(HAS_GETITIMER) && defined(HAS_SETITIMER) */
1367
c4a535af
SH
1368#if defined(TIME_HIRES_UTIME)
1369
1370I32
1371utime(accessed, modified, ...)
1372PROTOTYPE: $$@
1373 PREINIT:
708180a3
TK
1374 SV* accessed;
1375 SV* modified;
1376 SV* file;
c4a535af 1377
708180a3
TK
1378 struct timespec utbuf[2];
1379 struct timespec *utbufp = utbuf;
1380 int tot;
c4a535af
SH
1381
1382 CODE:
708180a3
TK
1383 accessed = ST(0);
1384 modified = ST(1);
1385 items -= 2;
1386 tot = 0;
1387
1388 if ( accessed == &PL_sv_undef && modified == &PL_sv_undef )
1389 utbufp = NULL;
1390 else {
1391 if (SvNV(accessed) < 0.0 || SvNV(modified) < 0.0)
1392 croak("Time::HiRes::utime(%" NVgf ", %" NVgf
1393 "): negative time not invented yet",
1394 SvNV(accessed), SvNV(modified));
1395 Zero(&utbuf, sizeof utbuf, char);
1396
1397 utbuf[0].tv_sec = (Time_t)SvNV(accessed); /* time accessed */
1398 utbuf[0].tv_nsec = (long)(
1399 (SvNV(accessed) - (NV)utbuf[0].tv_sec)
1400 * NV_1E9 + (NV)0.5);
1401
1402 utbuf[1].tv_sec = (Time_t)SvNV(modified); /* time modified */
1403 utbuf[1].tv_nsec = (long)(
1404 (SvNV(modified) - (NV)utbuf[1].tv_sec)
1405 * NV_1E9 + (NV)0.5);
1406 }
1407
1408 while (items > 0) {
1409 file = POPs; items--;
1410
1411 if (SvROK(file) && GvIO(SvRV(file)) && IoIFP(sv_2io(SvRV(file)))) {
1412 int fd = PerlIO_fileno(IoIFP(sv_2io(file)));
1413 if (fd < 0) {
1414 SETERRNO(EBADF,RMS_IFI);
1415 } else {
1416# ifdef HAS_FUTIMENS
1417 if (FUTIMENS_AVAILABLE) {
1418 if (futimens(fd, utbufp) == 0) {
1419 tot++;
8eedd56d 1420 }
708180a3
TK
1421 } else {
1422 croak("futimens unimplemented in this platform");
1423 }
1424# else /* HAS_FUTIMENS */
1425 croak("futimens unimplemented in this platform");
1426# endif /* HAS_FUTIMENS */
1427 }
1428 }
1429 else {
1430# ifdef HAS_UTIMENSAT
1431 if (UTIMENSAT_AVAILABLE) {
8eedd56d
CBW
1432 STRLEN len;
1433 char * name = SvPV(file, len);
1434 if (IS_SAFE_PATHNAME(name, len, "utime") &&
1435 utimensat(AT_FDCWD, name, utbufp, 0) == 0) {
708180a3
TK
1436
1437 tot++;
8eedd56d 1438 }
708180a3 1439 } else {
de3293c0 1440 croak("utimensat unimplemented in this platform");
708180a3
TK
1441 }
1442# else /* HAS_UTIMENSAT */
1443 croak("utimensat unimplemented in this platform");
1444# endif /* HAS_UTIMENSAT */
1445 }
1446 } /* while items */
1447 RETVAL = tot;
c4a535af
SH
1448
1449 OUTPUT:
708180a3 1450 RETVAL
c4a535af
SH
1451
1452#else /* #if defined(TIME_HIRES_UTIME) */
1453
1454I32
1455utime(accessed, modified, ...)
1456 CODE:
1457 croak("Time::HiRes::utime(): unimplemented in this platform");
1458 RETVAL = 0;
1459 OUTPUT:
708180a3 1460 RETVAL
c4a535af
SH
1461
1462#endif /* #if defined(TIME_HIRES_UTIME) */
1463
ced84e60
SP
1464#if defined(TIME_HIRES_CLOCK_GETTIME)
1465
1466NV
1467clock_gettime(clock_id = CLOCK_REALTIME)
708180a3 1468 clockid_t clock_id
ced84e60 1469 PREINIT:
708180a3
TK
1470 struct timespec ts;
1471 int status = -1;
ced84e60 1472 CODE:
708180a3
TK
1473# ifdef TIME_HIRES_CLOCK_GETTIME_SYSCALL
1474 status = syscall(SYS_clock_gettime, clock_id, &ts);
1475# else
1476 status = clock_gettime(clock_id, &ts);
1477# endif
1478 RETVAL = status == 0 ? ts.tv_sec + (NV) ts.tv_nsec / NV_1E9 : -1;
ced84e60
SP
1479
1480 OUTPUT:
708180a3 1481 RETVAL
ced84e60
SP
1482
1483#else /* if defined(TIME_HIRES_CLOCK_GETTIME) */
1484
1485NV
1486clock_gettime(clock_id = 0)
708180a3 1487 clockid_t clock_id
ced84e60 1488 CODE:
708180a3 1489 PERL_UNUSED_ARG(clock_id);
ced84e60
SP
1490 croak("Time::HiRes::clock_gettime(): unimplemented in this platform");
1491 RETVAL = 0.0;
858dcda5 1492 OUTPUT:
708180a3 1493 RETVAL
ced84e60
SP
1494
1495#endif /* #if defined(TIME_HIRES_CLOCK_GETTIME) */
1496
1497#if defined(TIME_HIRES_CLOCK_GETRES)
1498
1499NV
1500clock_getres(clock_id = CLOCK_REALTIME)
708180a3 1501 clockid_t clock_id
ced84e60 1502 PREINIT:
708180a3
TK
1503 int status = -1;
1504 struct timespec ts;
ced84e60 1505 CODE:
708180a3
TK
1506# ifdef TIME_HIRES_CLOCK_GETRES_SYSCALL
1507 status = syscall(SYS_clock_getres, clock_id, &ts);
1508# else
1509 status = clock_getres(clock_id, &ts);
1510# endif
1511 RETVAL = status == 0 ? ts.tv_sec + (NV) ts.tv_nsec / NV_1E9 : -1;
ced84e60
SP
1512
1513 OUTPUT:
708180a3 1514 RETVAL
ced84e60
SP
1515
1516#else /* if defined(TIME_HIRES_CLOCK_GETRES) */
1517
1518NV
1519clock_getres(clock_id = 0)
708180a3 1520 clockid_t clock_id
ced84e60 1521 CODE:
708180a3 1522 PERL_UNUSED_ARG(clock_id);
ced84e60
SP
1523 croak("Time::HiRes::clock_getres(): unimplemented in this platform");
1524 RETVAL = 0.0;
858dcda5 1525 OUTPUT:
708180a3 1526 RETVAL
ced84e60
SP
1527
1528#endif /* #if defined(TIME_HIRES_CLOCK_GETRES) */
1529
170c5524
SP
1530#if defined(TIME_HIRES_CLOCK_NANOSLEEP) && defined(TIMER_ABSTIME)
1531
1532NV
a8fb48f7 1533clock_nanosleep(clock_id, nsec, flags = 0)
708180a3
TK
1534 clockid_t clock_id
1535 NV nsec
1536 int flags
170c5524 1537 PREINIT:
708180a3 1538 struct timespec sleepfor, unslept;
170c5524 1539 CODE:
708180a3
TK
1540 if (nsec < 0.0)
1541 croak("Time::HiRes::clock_nanosleep(..., %" NVgf
a135cb6c 1542 "): negative time not invented yet", nsec);
e3ff671b 1543 nanosleep_init(nsec, &sleepfor, &unslept);
708180a3
TK
1544 if (clock_nanosleep(clock_id, flags, &sleepfor, &unslept) == 0) {
1545 RETVAL = nsec;
1546 } else {
24e1662b 1547 RETVAL = nsec_without_unslept(&sleepfor, &unslept);
708180a3 1548 }
170c5524 1549 OUTPUT:
708180a3 1550 RETVAL
170c5524
SP
1551
1552#else /* if defined(TIME_HIRES_CLOCK_NANOSLEEP) && defined(TIMER_ABSTIME) */
1553
1554NV
90e44bf6 1555clock_nanosleep(clock_id, nsec, flags = 0)
708180a3
TK
1556 clockid_t clock_id
1557 NV nsec
1558 int flags
170c5524 1559 CODE:
708180a3
TK
1560 PERL_UNUSED_ARG(clock_id);
1561 PERL_UNUSED_ARG(nsec);
1562 PERL_UNUSED_ARG(flags);
170c5524
SP
1563 croak("Time::HiRes::clock_nanosleep(): unimplemented in this platform");
1564 RETVAL = 0.0;
858dcda5 1565 OUTPUT:
708180a3 1566 RETVAL
170c5524
SP
1567
1568#endif /* #if defined(TIME_HIRES_CLOCK_NANOSLEEP) && defined(TIMER_ABSTIME) */
1569
1570#if defined(TIME_HIRES_CLOCK) && defined(CLOCKS_PER_SEC)
1571
1572NV
1573clock()
1574 PREINIT:
708180a3 1575 clock_t clocks;
170c5524 1576 CODE:
708180a3
TK
1577 clocks = clock();
1578 RETVAL = clocks == (clock_t) -1 ? (clock_t) -1 : (NV)clocks / (NV)CLOCKS_PER_SEC;
170c5524
SP
1579
1580 OUTPUT:
708180a3 1581 RETVAL
170c5524
SP
1582
1583#else /* if defined(TIME_HIRES_CLOCK) && defined(CLOCKS_PER_SEC) */
1584
1585NV
1586clock()
1587 CODE:
1588 croak("Time::HiRes::clock(): unimplemented in this platform");
1589 RETVAL = 0.0;
858dcda5 1590 OUTPUT:
708180a3 1591 RETVAL
170c5524
SP
1592
1593#endif /* #if defined(TIME_HIRES_CLOCK) && defined(CLOCKS_PER_SEC) */
1594
86413ec0 1595void
75d5269b
SP
1596stat(...)
1597PROTOTYPE: ;$
0f0eae2c 1598 PREINIT:
708180a3
TK
1599 OP fakeop;
1600 int nret;
0f0eae2c 1601 ALIAS:
708180a3 1602 Time::HiRes::lstat = 1
75d5269b 1603 PPCODE:
708180a3
TK
1604 XPUSHs(sv_2mortal(newSVsv(items == 1 ? ST(0) : DEFSV)));
1605 PUTBACK;
1606 ENTER;
1607 PL_laststatval = -1;
1608 SAVEOP();
1609 Zero(&fakeop, 1, OP);
1610 fakeop.op_type = ix ? OP_LSTAT : OP_STAT;
1611 fakeop.op_ppaddr = PL_ppaddr[fakeop.op_type];
1612 fakeop.op_flags = GIMME_V == G_ARRAY ? OPf_WANT_LIST :
1613 GIMME_V == G_SCALAR ? OPf_WANT_SCALAR : OPf_WANT_VOID;
1614 PL_op = &fakeop;
1615 (void)fakeop.op_ppaddr(aTHX);
1616 SPAGAIN;
1617 LEAVE;
1618 nret = SP+1 - &ST(0);
1619 if (nret == 13) {
1620 UV atime = SvUV(ST( 8));
1621 UV mtime = SvUV(ST( 9));
1622 UV ctime = SvUV(ST(10));
1623 UV atime_nsec;
1624 UV mtime_nsec;
1625 UV ctime_nsec;
1626 hrstatns(&atime_nsec, &mtime_nsec, &ctime_nsec);
1627 if (atime_nsec)
1628 ST( 8) = sv_2mortal(newSVnv(atime + (NV) atime_nsec / NV_1E9));
1629 if (mtime_nsec)
1630 ST( 9) = sv_2mortal(newSVnv(mtime + (NV) mtime_nsec / NV_1E9));
1631 if (ctime_nsec)
1632 ST(10) = sv_2mortal(newSVnv(ctime + (NV) ctime_nsec / NV_1E9));
1633 }
1634 XSRETURN(nret);