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