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