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