diff options
Diffstat (limited to 'ext/Time-HiRes')
| -rw-r--r-- | ext/Time-HiRes/.gitignore | 2 | ||||
| -rw-r--r-- | ext/Time-HiRes/Changes | 886 | ||||
| -rw-r--r-- | ext/Time-HiRes/HiRes.pm | 591 | ||||
| -rw-r--r-- | ext/Time-HiRes/HiRes.xs | 1257 | ||||
| -rw-r--r-- | ext/Time-HiRes/Makefile.PL | 879 | ||||
| -rw-r--r-- | ext/Time-HiRes/fallback/const-c.inc | 393 | ||||
| -rw-r--r-- | ext/Time-HiRes/fallback/const-xs.inc | 88 | ||||
| -rw-r--r-- | ext/Time-HiRes/hints/aix.pl | 18 | ||||
| -rw-r--r-- | ext/Time-HiRes/hints/dec_osf.pl | 3 | ||||
| -rw-r--r-- | ext/Time-HiRes/hints/dynixptx.pl | 5 | ||||
| -rw-r--r-- | ext/Time-HiRes/hints/irix.pl | 6 | ||||
| -rw-r--r-- | ext/Time-HiRes/hints/linux.pl | 2 | ||||
| -rw-r--r-- | ext/Time-HiRes/hints/sco.pl | 4 | ||||
| -rw-r--r-- | ext/Time-HiRes/hints/solaris.pl | 10 | ||||
| -rw-r--r-- | ext/Time-HiRes/hints/svr4.pl | 4 | ||||
| -rw-r--r-- | ext/Time-HiRes/t/HiRes.t | 783 | ||||
| -rw-r--r-- | ext/Time-HiRes/typemap | 313 |
17 files changed, 5244 insertions, 0 deletions
diff --git a/ext/Time-HiRes/.gitignore b/ext/Time-HiRes/.gitignore new file mode 100644 index 0000000000..a89cf3eadf --- /dev/null +++ b/ext/Time-HiRes/.gitignore @@ -0,0 +1,2 @@ +*.inc +/xdefine diff --git a/ext/Time-HiRes/Changes b/ext/Time-HiRes/Changes new file mode 100644 index 0000000000..ffec191c1e --- /dev/null +++ b/ext/Time-HiRes/Changes @@ -0,0 +1,886 @@ +Revision history for the Perl extension Time::HiRes. + +1.9719 [2009-01-04] + - As with QNX, Haiku has the API of interval timers but not + the implementation (bleadperl change #34630), hence skip + the tests, via David Mitchell. + +1.9718 [2008-12-31] + - .xs code cleanup from Albert Dvornik + - in the #39 and #40 do not do us I did, mixing alarm() and + sleep(). Now instead spin until enough time has passed. + +1.9717 [2008-12-30] + - Skip the tests added in 1.9716 (#39, #40) if there's no subsecond + alarm capability, like with the older subsecond alarm tests + +1.9716 [2008-12-26] + - Change documentation to agree with reality: there are + no interval timers in Win32. + - Address [rt.cpan.org #35899] (problem in subsecond sleeps), + add two tests to guard against this problem + - Address [rt.cpan.org #36600] 'Division by zero' failure in test suite + - Address [rt.cpan.org #37340] [PATCH] Address timer process in test + - Address [rt.cpan.org#40311 ] bad implementation of hrt_usleep + with TIME_HIRES_NANOSLEEP + +1.9715 [2008-04-08] + - Silly me: Makefile.PL does need to accept arguments other than mine. + Some testing frameworks obviously do this. + - Add retrying for tests 34..37, which are the most commonly + failing tests. If this helps, consider extending the retry + framework to all the tests. [Inspired by Slaven Rezic, + [rt.cpan.org #34711] Occasional failures of test 35 or 36 (FreeBSD)] + +1.9714 [2008-04-07] + - Under Perl 5.6.* NVgf needs to be "g", reported by Zefram, + it seems that ppport.h 3.13 gets this wrong. + - remove the check in Makefile.PL for 5.7.2, shouldn't be + (a) necessary (b) relevant + - add logic to Makefile.PL to skip configure/write Makefile + step if the "xdefine" file already exists, indicating that + the configure step has already been done, one can still + force (re)configure by "perl Makefile.PL configure", + or of course by "make clean && perl Makefile.PL". + +1.9713 [2008-04-04] + - for alarm() and ualarm() [Perl] prefer setitimer() [C] + instead of ualarm() [C] since ualarm() [C] cannot portably + (and standards-compliantly) be used for more than 999_999 + microseconds (rt.cpan.org #34655) + - it seems that HP-UX has started (at least in 11.31 ia64) + #defining the CLOCK_REALTIME et alia (instead of having + them just as enums) + - document all the diagnostics + +1.9712 [2008-02-09] + - move the sub tick in the test file back to where it used to be + - in the "consider upgrading" message recommend at least Perl 5.8.8 + and make the message to appear only for 5.8.0 since 5.8.1 and + later have the problem fixed + - VOS tweak for Makefile (core perl change #33259) + - since the test #17 seems to fail often, relax its limits a bit + +1.9711 [2007-11-29] + - lost VMS test skippage from Craig Berry + - reformat the test code a little + +1.9710 [2007-11-29] + - I got the sense of the QNX test the wrong way in an attempt + to generalize it for future + +1.9709 [2007-11-28] + - casting fixes from Robin Barker for g++ and 64bitint + - in QNX skip the itimer tests because though the API + is there, the implementation isn't, from Matt Kraai + - raise the dead man timer to 180 seconds for really + slow/busy systems + - elaborate the UTF-8 locale warning from Makefile.PL + +1.9708 [2007-10-05] + - [rt.cpan.org #29747]: Build failure with perl 5.005_05 + Fixed by regenerating the ppport.h using Devel::PPPort 3.13. + +1.9707 [2007-02-27] + - t/HiRes.t failed in Perl 5.6.2, + "action is not of type POSIX::SigAction at t/HiRes.t line 318", + reported and fixed by Anton Berezin, the reason was faulty + use of sigaction() when restoring the old action. + +1.9706 [2007-02-25] + - with bleadperl in VMS the HiRes.t overrun the maximum number + of deferred signals because the libc SIGALRM was not strong + enough to interrupt select(), and select() got restarted every + time, solution is to use POSIX::SigAction if available. + A fix from Craig Berry (not 100% there, but helps). + - allow for more measuring noise for ualarm() tests 35..37 + +1.9705 [2007-02-06] + - nanosleep() and clock_nanosleep() detection and use were + quite broken; in Linux -lrt needed; fixes from Zefram + - [internal] slightly cleaner building of $DEFINE in Makefile.PL, + should avoid double/conflicting -D flags + +1.9704 [2007-01-01] + - allow 10% of slop in test #14 (testing difference between + CORE::time() and Time::HiRes::time()), there seem to be often + transient failures from Perl smoke builds on this test + - small pod tweaks + +1.9703 [2006-12-08] + - use int main(int argc, char **argv) consistently in Makefile.PL, + should help with + [rt.cpan.org #23868] nanosleep not detected under Mac OS 10.3.9 starting with Time::HiRes 1.96 + - if someone still has the locale-broken Perl 5.8.0, + suggest that they upgrade their Perl + +1.9702 [2006-12-06] + - restore the -DATLEASTFIVEOHOHFIVE, Win32 needed it still + +1.9701 [2006-12-04] + - upgrade to ppport.h 3.10_02 + - remove the -DATLEASTFIVEOHOHFIVE + - use the ppport.h PL_ppaddr, PL_statcache, PL_laststatval + - use the ppport.h aTHXR for calling Perl stat() + - switch into four-digit version since 2.0 is coming up + awfully fast but not feeling like a major rewrite + +1.97 [2006-11-30] + - 1.95 broke building in Win32 (since pp_stat is not exported), + figured out how to call an op directly in 5.005 (use Perl_ppaddr + instead of PL_ppaddr) + - backport to Perl 5.004_05 (requires using statcache + and laststatval instead of PL_statcache and PL_laststatval) + (also checked to work in 5.005_04, 5.6.1, and 5.8.8 with threads) + +1.96 [2006-11-30] + - 1.95 broke builds for threaded Perls, rt.cpan.org tickets: + [rt.cpan.org #23694] Time::HiRes fails tests on Solaris and Perl 5.6.1 + [rt.cpan.org #23712] Time-HiRes 1.95 Fails make on AIX 5.2 with Perl 5.8.8 + [rt.cpan.org #23730] Time::HiRes 1.95 fails make on MacOS X 10.3.9/perl 5.8.8 + - use main() prototype consistently in Makefile.PL + +1.95 [2006-11-29] + - integrate core change #29180: Silence VC++ compiler warnings + from Steve Hay + - do not use PL_ppaddr in stat() because that is not available + in Perl 5.005_04 + - regenerate fallback/*.inc for older Perls without + ExtUtils::Constant because of d_hires_stat, resolves + [rt.cpan.org #23694] Time::HiRes fails tests on Solaris and Perl 5.6.1 + - Make Makefile.PL more defensive against false PERL_CORE + +1.94 [2006-10-16] + - file timestamps oddities seen: the atime and mtime + can be out of sync (modify first and read second can leave + atime < mtime) and mtime can be subsecond while atime is not. + So make the test more forgiving. + +1.93 [2006-10-15] + - the ualarm() tests (34-37) assumed that ualarm(N) + could never alarm in less than N seconds, widened + the acceptable relative range to 0.9..1.5. Addresses + [rt.cpan.org #22090] and [rt.cpan.org #22091]. + + - skip the stat() tests in cygwin and win32, because + if run on FAT the timestamp granularity is only 2 seconds. + Any good way to detect (cygwin or win32) whether we are + being run on NTFS or anywhere with better timestamps? + Addresses [rt.cpan.org #22089] and [rt.cpan.org #22098]. + +1.92 [2006-10-13] + - scan for subsecond resolution timestamps in struct stat, + some known possibilities: + + (1) struct timespec st_atimespec; + st_atimespec.tv_nsec; + (2) time_t st_atime; + long st_atimensec; + (3) time_t st_atime; + int st_atime_n; + (4) timestruc_t st_atim; + st_atim.tv_nsec + (5) time_t st_atime; + int st_uatime; + + If something like this is found, one can do + + use Time::HiRes; + my @stat = Time::HiRes::stat(); + + or even override the standard stat(): + + use Time::HiRes qw(stat); + + to get the stat() timestamps + + my ($atime, $mtime, $ctime) = @stat[8, 9, 10]; + + with subsecond resolution (assuming both the operating + system and the filesystem support that kind of thing). + + Contributions for more systems (especially non-UNIX, + e.g. but not limited to: Win32, VMS, OS/2) gladly accepted. + (also more UNIX variants welcome: HP-UX? IRIX?) + + Thanks to H.Merijn Brand, John Peacock, and Craig + Berry for brave beta testing. + +1.91 [2006-09-29] + - ualarm() in SuSE 10.1 was overflowing after ~4.2 seconds, + possibly due to a glibc bug/feature (suspected overflow at + 2**32 microseconds?), workaround by using the setitimer() + implementation of ualarm() if either useconds or + interval > 999_999 (this case seems to vary between systems: + are useconds more than 999_999 for ualarm() defined or not) + Added more ualarm() tests to catch various overflow points, + hopefully no problems in various platforms. + (The problem report by Mark Seger and Jon Paul Sullivan of HP.) + +1.90 [2006-08-22] + - tweak still needed for Const64(), from Jerry Hedden + - get a freshly generated ppport.h + - update Copyright years + +1.89 [2006-08-22] + - Const64() already appends an 'LL' (or i64), so provide LL and i64 + forms for the IV_1E[679] (effects Win32 and Cygwin), reported by + Jerry Hedden. + - the Changes entry for 1.88 talked about [IN]V_1[679], + missing the 'E'. + +1.88 [2006-08-21] + - clean up the g++ warnings in HiRes.xs, all of them + about mixing integer and floating point, introduce + constants IV_1E[679] and NV_1E[679] + +1.87 [2006-02-13] + - [rt.cpan.org #17442] 'make test' frequently fails under + Cygwin Perl v5.8.8, reported and patched by J. R. Hedden + (two race condition bugs in the END block in the case the + main process dies before the timer process, unearthed + by a bug in Cygwin ualarm) + +1.86 [2005-12-17] + - HiRes.t:s/ok 32/ok 33/, from Dominic Dunlop + - tighten up the clock() test marginally by requiring non-negative + - clock_nanosleep() and clock() doc tweaks + +1.85 [2005-12-16] + - the interface to clock_nanosleep() is more natural + when it is like (hires) time() (instead of like nanosleep), + and the .xs implementation of clock_nanosleep() in 1.84 + was broken anyway + - the semantics of clock() are not quite so silly as I thought, + but still somewhat odd, documented as such + - additional enhancements to the clock() documentation + - add test for clock_nanosleep() (I cannot test this + since none of my systems have the function) + - add test for clock() + +1.84 [2005-12-16] + - add clock() which returns the processor time in + (floating point) seconds since an arbitrary era + - add clock_nanosleep() which suspends the current + thread until either absolute time or for relative time + - [rt.cpan.org #16486] printf missing value in HiRes.t + - add constants CLOCKS_PER_SEC, CLOCK_SOFTTIME, TIMER_ABSTIME + - tiny typo fixes + +1.83 [2005-11-19] + - has_symbol() was wrong since e.g. ITIMER_VIRTUAL is exported + via @EXPORT_OK even when it is not available. This is heinous. + @EXPORT_OK should be determined at Makefile.PL time. + - be more lenient is testing clock_gettime(): allow more slop, + and retry up to three times, sleeping a random nap between + the retries + - human months are one-based (noticed by Anton Berezin) + +1.82 [2005-10-06] + - CLOCK_REALTIME is an enum value (of the clockid_t enum) + in HP-UX (and might be so elsewhere, too), debugged by + H. Merijn Brand + - include const-c.inc as late as possible (from Randy Kobes, + [rt.cpan.org #15552] to avoid undefined usleep() on Win32 + +1.81 [2005-11-05] + - try to be more robust and consistent in the detection of + CLOCK_REALTIME and ITIMER_VIRTUAL in HiRes.t: the proper + way is + + sub has_symbol { + my $symbol = shift; + eval 'import Time::HiRes qw($symbol)'; + return 0 unless $@ eq ''; + return exists ${"Time::HiRes::$symbol"}; + } + + and then use + + &FOO_BAR + + in the test. All these moves are needed because + + 1) one cannot directly do eval 'Time::HiRes::FOO_BAR' + because FOO_BAR might have a true value of zero + (or in the general case an empty string or even undef) + + 2) In case FOO_BAR is not available in this platform, + &FOO_BAR avoids the bareword warning + + - wait more (1.5 seconds instead of 0.1) for the CLOCK_REALTIME test + but expect the 'customary' slop of 0.20 instead of 0.25 + - fixed inside a comment HAS_POLL -> TIME_HIRES_NANOSLEEP + - at the end of HiRest.t tell how close we were to termination + +1.80 [2005-11-04] + - Gisle noticed a mistake (using HAS_NANOSLEEP) in 1.79 + +1.79 [2005-11-03] + - try nanosleep for emulating usleep -- may help in some weird + embedded realtime places which have nanosleep but neither usleep + nor select nor poll (doesn't have to be weird embedded realtime + place, though -- in many places usleep is nanosleep anyway) + - try poll for emulating usleep -- this may help some obscure/old + SVR4 places that have neither usleep nor select + - a redundant test guard in HiRes.t + +1.78 [2005-11-03] + - ITIMER_VIRTUAL detection in HiRes.t had problems (that we cannot + in the general case fail already at 'use' phase is suboptimal) + - fixes to the documentation of clock_gettime() and clock_getres() + +1.77 [2005-11-03] + - add support for the POSIX clock_gettime() and clock_getres(), + if available, either as library calls or as syscalls + - be more defensive about missing functionality: break out + early (during 'use') if no e.g. clock_getres() is available, + and protect our back by trapping those cases also in HiRes.xs + - the test added in 1.76 could cause an endless loop e.g. in Solaris, + due to mixing of sleep() and alarm() (bad programmer, no cookie!) + +1.76 [2005-10-22] + - testing for nanosleep had wrong logic which caused nanosleep + to become undefined for e.g. Mac OS X + - added a test for a core dump that was introduced by Perl 5.8.0 + safe signals and was fixed for the time of 5.8.1 (one report of + the core dump was [perl #20920]), the test skipped pre-5.8.1. + - *cough* s/unanosleep/nanosleep/g; *cough* + +1.75 [2005-10-18] + - installation patch from Gisle Aas: in Perls 5.8.x and later + use MakeMaker INSTALLDIRS value of 'perl' instead of 'site'. + +1.74 [2005-09-19] + - [cpan #14608] Solaris 8 perl 5.005_03 File::Spec module does not have method rel2abs + (the workaround is not to use rel2abs, should not be necessary) + - [cpan #14642] U2time wrongly exported on the C API + (patch supplied by the reporter, SALVA@cpan.org) + - add release dates to Changes + +1.73 [2005-08-16] + - Time::HiRes::nanosleep support for Solaris [PATCH] + (POSIX::uname() not available if building with core perl, + from Gisle Aas, via perl5-porters, perl change #25295) + +1.72 [2005-07-01] + - going back to the 1.68 loader setup (using DynaLoader) + since too many weird things starting breaking + - fix a typo in José Auguste-Etienne's name + +1.71 [2005-06-28] + - a thinko in the nanosleep() detection + - move more changes stuff from the README to Changes + - add -w to the Makefile.PL + +1.70 [2005-06-26] + - oops in 1.69 about @ISA (not affecting anything but silly) + - add copyright 2005 to HiRes.pm + - add copyright and license to HiRes.xs + - add copyrights 2003, 2004, 2005 to README + +1.69 [2005-06-25] + - actually run a test for nanosleep + (if there is no $Config{d_nanosleep}) since e.g. in AIX 4.2 + it seems that one can link in nanosleep() but then calling + it fails instantly and sets errno to ENOSYS (Not implemented). + This may be fixable in the AIX case by figuring out the right + (realtime POSIX?) libs and whatnot, but in the general case + running a real test case is better. (Of course, this change + will no doubt run into portability problems because of the + execution step...) Note that because of hysterical raisins + most Perls do NOT have $Config{d_nanosleep} (scanning for + it by Configure would in many platforms require linking in + things like -lrt, which would in many platforms be a bad idea + for Perl itself). + (from José Auguste-Etienne) + - support XSLoader also since it's much faster + (from Alexey Tourbin) + - add SEE ALSO (BSD::Resource and Time::TAI64) + +1.68 [2005-05-14] + - somehow 1.67 had a lot of doubled lines (a major cut-and-paste + error suspected), but miraculously it still worked since the + doubling took place below the __END__ token + - undef Pause() before defining it to avoid redefinition warnings + during compilation in case perl.h had already defined Pause() + (part of perl change #24271) + - minor doc tweaks + +1.67 [2005-05-04] + - (internal) don't ignore the return value of gettimeofday() + - (external) return undef or an empty if the C gettimeofday() fails + (affects Time::HiRes gettimeofday() and the hires time()) + +1.66 [2004-12-19] + - add nanosleep() + - fix the 'hierachy' typo in Makefile.PL [rt.cpan.org #8492] + - should now build in Solaris [rt.cpan.org #7165] (since 1.64) + - should now build in Cygwin [rt.cpan.org #7535] (since 1.64) + - close also [rt.cpan.org #5933] "Time::HiRes::time does not + pick up time adjustments like ntp" since ever reproducing it + (and therefore verifying a possible fix) in the same environment + has become rather unlikely + +1.65 [2004-09-18] + - one should not mix u?alarm and sleep (the tests modified + by 1.65, #12 and #13, hung in Solaris), now we just busy + loop executing an empty block + - in the documentation underline the unspecificity of mixing + sleeps and alarms + - small spelling fixes + +1.64 [2004-09-16] + - regenerate ppport.h with Devel::PPPort 3.03, + now the MY_CXT_CLONE is defined in ppport.h, + we no more need to do that. + + - the test #12 would often hang in sigsuspend() (at least that's + where Mac OS X' ktrace shows it hanging). With the sleep()s + changed to sleep(1)s, the tests still pass but no hang after + a few hundred repeats. + +1.63 [2004-09-01] + - Win32 and any ithread build: ppport.h didn't define + MY_CXT_CLONE, which seems to be a Time-HiRes-ism. + +1.62 [2004-08-31] + - Skip testing if under PERL_CORE and Time::HiRes has not + been Configured (from Marcus Holland-Moritz, core change + #23246) + - Use ppport.h generated by Devel::PPPort 3.01, + allowing cutting away our own portability code. + - Don't use $ENV{PERL_CORE} for < 5.6.0. + - Don't use "for my $i" for <= 5.003. + - Don't use Pause() for <= 5.003. + - Can't use newSVpvf for <= 5.003. + (most of the changes from Marcus) + +1.61 [2004-08-21] + - Win32: reset reading from the performance counters every + five minutes to better track wall clock time (thanks to + PC timers being often quite bad), should help long-running + programs. + +1.60 [2004-08-15] + - Win32: Patch from Steve Hay + [PATCH] Re: [perl #30755] [Win32] Different results from Time::HiRes::gettimeofdayunder the debugger + to [perl #30755] reported by Nigel Sandever + + - Cygwin: Use the Win32 recalibration code also in Cygwin if the + <w32api/windows.h> APIs are available. Cygwin testing by + Yitzchak Scott-Thoennes. + + - Solaris: use -lposix4 to get nanosleep for Solaris 2.6, + after that keep using -lrt, patch from Alan Burlison, + bug reported in [cpan #7165] + +1.59 [2004-04-08] + - Change the Win32 recalibration limit to 0.5 seconds and tweak + the documentation to blather less about the gory details of the + Win32 implementation and more about the complications in general + of meddling with the system clock. + +1.58 [2004-04-08] + - Document the 1.57 change better. + +1.57 [2004-07-04] + - Win32/Cygwin/MinGW: if the performance counter drifts by more + than two seconds from the system clock (due to ntp adjustments, + for example), recalibrate our internal counter: from Jan Dubois, + based on [cpan #5933] by Jerry D. Hedden. + +1.56 [2004-29-02] + - Give a clearer message if the tests timeout (perl change #22253) + - Don't use /tmp or its moral equivalents (perl bug #15036, + perl change #22258) + +1.55 [2004-01-14] + - Windows: mingw32 patch from Mike Pomraning (use Perl's Const64() + instead of VC-specific i64 suffix) + +1.54 [2003-12-31] + - Solaris: like Tru64 (dec_osf) also Solaris need -lrt for nanosleep + +1.53 [2003-12-30] + - Windows: higher resolution time() by using the Windows + performance counter API, from Jan Dubois and Anton Shcherbinin. + The exact new higher resolution depends on the hardware, + but it should be quite a bit better than using the basic + Windows timers. + +1.52 [2003-10-28] + - In AIX (v?) with perl 5.6.1 the HiRes.t can hang after + the subtest 18. No known analysis nor fix, but added + an alarm (that requires fork() and alarm()) to the test. + +1.51 [2003-09-22] + - doc tweaks from mjd (perl change #20456) + - NCR MP-RAS hints file added (svr4.pl) (perl change #21249) + +1.50 [2003-08-02] + - add a message (for non-core builds) to Makefile.PL about + the LC_ALL=C workaround + - &Time::HiRes::d_nanosleep was broken (perl change #20131) + - the nanosleep() probe was broken (perl change #20061) + - use existence instead of definedness for feature probes + (perl change #20043) + - MPE/iX tweak (perl change #20042) + - do not use HAS_NANOSLEEP (perl change #19898) + +1.49 [2003-06-23] + - UVuf for non-IVSIZE platforms (from Keiichiro Nagano) + - OS/2 can always mix subsecond sleeps with signals + (part of perl change #19789) + +1.48 [2003-06-04] + - workaround for buggy gcc 2.95.3 in openbsd/sparc64 + (perl change #19592) + +1.47 [2003-05-03] + - do not use -lrt in Linux (from March Lehmann, perl change #19449) + - unnecessary (nanosleep is in libc anyway) + - harmful (-lrt slows down execution) + - incompatible (with many distributions' pthreads) + +1.46 [2003-04-25] + - do not create files in blib directories under core + (perl change #19160, from rgs) + - detypo s/VTLARM/VTARLM/ (perl change #19328, from mjd) + +1.45 [2003-04-01] + - guarantee that $xdefine in HiRes.t is always defined + (perl change #19109, from IlyaZ) + - a cleaner way to detect PERL_CORE (perl change #19111, + from IlyaZ) + +1.44 [2003-03-30] + - add hints/irix.pl to turn off overly POSIX flags that + cause hide struct timespec to be hidden (and compilation + to fail) (bleadperl change #19085) + - documentation tweaks + +1.43 [2003-03-11] + - add c:/temp to the list of temp directories to probe + so that cygwin (and win*?) builds are happy. This was + needed at least in my cygwin 1.3.20/w2k setup. + +1.42 [2003-01-07] + - modernize the constants code (from Nicholas Clark) + +1.41 [2003-01-03] + - At some point the ability to figure our the correct incdir + for EXTERN.h (either a core perl build, or an installed perl) + had broken (which lead into all test compiles failing with + a core perl build, but thanks to the robustness of Makefile.PL + nothing of this was visible). The brokenness seemed to be + caused by $ENV{PERL_CORE} not being on for core builds? + Now stole a trick from the Encode that sets $ENV{PERL_CORE} + right, and both styles of build should work again. + +1.40 [2003-01-03] + - Nicholas Clark noticed that the my_catdir() emulation function + was broken (which means that we didn't really work for Perls + 5.002 and 5.003) + - inspired by fixing the above made the whole Makefile.PL -w + and strict clean + - tightened up the Makefile.PL output, less whitespace + +1.39 [2003-10-20] + - fix from Craig Berry for better building in VMS with PERL_CORE + +1.38 [2003-10-13] + - no functional changes + - move lib/Time/HiRes.pm as Hires.pm + - libraries scanning was slightly broken (always scanned + for a library even when $Config{libs} already had it) + +1.37 [2003-09-23] + - Ray Zimmerman ran into a race condition in Mac OS X. + A 0.01-second alarm fired before the test expected. + The test first slept indefinitely (blocking for signals) + and only after that tested for the signal having been sent. + Since the signal had already been sent, the test #12 never + completed. The solution: test first, then block. + - default to being silent on all probing attempts, set the + environment variable VERBOSE to a true value to see the + details (the probing command and the possible errors) + +1.36 [2003-09-12] + - do not clear MAN3PODS in Makefile.PL (Radoslaw Zielinski) + - INSTALLDIRS => 'perl' missing which means that Time::HiRes + cannot be upgraded from CPAN to override the 5.8.0 version + (Guido A. Ostkamp) + - Time::HiRes 1.35 could not be dropped as-is to bleadperl + because the include directories did not adjust themselves + if $ENV{PERL_CORE} (Hugo van der Sanden) + - add documentation about the restart of select() under alarm() + +1.35 [2003-08-24] + - small documentation tweaks + + +1.34 [2003-08-22] + - better VMS operation (Craig Berry) + +1.33 [2003-08-20] + - our time machine is accelerating: now works with Perl 5.004_01 + (tried with 5.003_07 and 5.002 but I get segmentation faults + from running the Makefile.PL with those in Tru64 4.0D) + +1.32 [2003-08-20] + - backward compatibility (pre-5.6.0) tweaks: + - no XSLoader in 5.00503, use DynaLoader instead + - no SvPV_nolen, either + - no PerlProc_pause(), either + - now tested with 5.00404 and 5.00503 + - Makefile.PL requires 5.00404 (no more 5.002) + - use nanosleep instead of usleep, if it is available (Wilson Snyder) + (this means that one can mix subsecond sleeps with alarms) + - because of nanosleep we probe for -lrt and -lposix4 + - the existence of getitimer/nanosleep/setitimer/ualarm/usleep + is available by exportable constants Time::HiRes::d_func + (since older Perl do not have them in %Config, and even + 5.8.0 does not probe for nanosleep) + +1.31 [2003-08-19] + - backward compatibility (pre-5.6.1) tweaks: + - define NV if no NVTYPE + - define IVdf if needed (note: the Devel::PPPort + in 5.8.0 does not try hard hard enough since + the IVSIZE might not be defined) + - define NVgf if needed + - grab the typemap from 5.8.0 for the NV stuff + + 1.31 and 1.32 add more backward compatibility (now all the way + back to Perl 5.00404), and using nanosleep() (if available) for + subsecond sleeps. + +1.30 [2003-08-16] + + - release 1.29_02 as 1.30 + + 1.30 adds all the changes made during the Perl 5.6->5.7->5.8 + development cycle. Most notably portability across platforms has been + enhanced, and the interval timers (setitimer, getitimer) have been + added. Note that the version of Time::HiRes that is included in Perl + 5.8.0 calls itself 1.20_00, but it is equivalent to this Time::HiRes + version. Note also that in 1.30 Wegscheid turns over the maintenance + to Jarkko Hietaniemi. + +1.29_02 [2003-08-16] + + - fix a silly unclosed comment typo in HiRes.xs + - document and export REALTIME_REALPROF (Solaris) + +1.29_01 [2003-08-16] + + - only getitimer(ITIMER_REAL) available in Cygwin and Win32 + (need to patch this also in Perl 5.[89]) + - remove CVS revision log from HiRes.xs + +1.29_00 [2003-08-14] + + The following numbered patches refer to the Perl 5.7 changes, + you can browse them at http://public.activestate.com/cgi-bin/perlbrowse + + - 17558: Add #!./perl to the .t + - 17201: linux + usemorebits fix, from Rafael Garcia-Suarez + - 16198: political correctness, from Simon Cozens + - 15857: doc tweaks, from Jarkko Hietaniemi + - 15593: optimization in .xs, from Paul Green + - 14892: pod fixes, from Robin Barker + - 14100: VOS fixes, from Paul Green + - 13422: XS segfault, from Marc Lehmann + - 13378: whether select() gets restarted on signals, depends + - 13354: timing constraints, again, from Andy Dougherty + - 13278: can't do subsecond alarms with ualarm; + break out early if alarms do not seem to be working + - 13266: test relaxation (cygwin gets lower hires + times than lores ones) + - 12846: protect against high load, from Jarkko Hietaniemi + - 12837: HiRes.t VMS tweak, from Craig A. Berry + - 12797: HiRes.t VMS tweak, from Charles Lane + - 12769: HiRes.t VMS tweak, from Craig A. Berry + - 12744: gcc vs MS 64-bit constant syntax, from Nick Ing-Simmons + - 12722: VMS ualarm for VMS without ualarm, from Charles Lane + - 12692: alarm() ain't gonna work if ualarm() ain't, + from Gurusamy Sarathy + - 12680: minor VMS tweak, from Charles Lane + - 12617: don't try to print ints as IVs, from Jarkko Hietaniemi + - 12609: croak on negative time, from Jarkko Hietaniemi + - 12595: Cygwin rounds up for time(), from Jarkko Hietaniemi + - 12594: MacOS Classic timeofday, from Chris Nandor + - 12473: allow for more than one second for sleep() and usleep() + - 12458: test tuning, relax timing constraints, + from Jarkko Hietaniemi + - 12449: make sleep() and usleep() to return the number + of seconds and microseconds actually slept (analogously + with the builtin sleep()), also make usleep() croak if + asked for more than 1_000_000 useconds, from Jarkko Hietaniemi + - 12366: Time::HiRes for VMS pre-7.0, from Charles Lane + - 12199: do not use ftime on Win32, from Gurusamy Sarathy + - 12196: use ftime() on Win32, from Artur Bergman + - 12184: fix Time::HiRes gettimeofday() on Win32, from Gurusamy Sarathy + - 12105: use GetSystemTime() on Win32, from Artur Bergman + - 12060: explain the 1e9 seconds problem, from Jarkko Hietaniemi + - 11901: UNICOS sloppy division, from Jarkko Hietaniemi + - 11797: problem in HiRes.t, from John P. Linderman + - 11414: prototype from Time::HiRes::sleep(), from Abhijit Menon-Sen + - 11409: Time::HiRes qw(sleep) failed, from Abhijit Menon-Sen + - 11270: dynix/ptx 4.5.2 hints fix, from Peter Prymmer + - 11032: VAX VMS s/div/lib\$ediv/ fix, from Peter Prymmer + - 11011: VAX VMS s/qdiv/div/ fix, from Peter Prymmer + - 10953: SCO OpenServer 5.0.5 requires an explicit -lc for usleep(), + from Jonathan Stowe + - 10942: MPE/IX test tweaks, from Mark Bixby + - 10784: unnecessary pod2man calls, from Andy Dougherty + - 10354: ext/ + -Wall, from Doug MacEachern + - 10320: fix the BOOT section to call myU2time correctly + - 10317: correct casting for AIX< from H. Merijn Brand + - 10119: document that the core time() may be rounding, not truncating + - 10118: test fix, from John Peacock + - 9988: long =item, from Robin Barker + - 9714: correct test output + - 9708: test also the scalar aspect of getitimer() + - 9705: Add interval timers (setitimer, getitimer) + - 9692: do not require at least 5.005 using XS + + The following changes were made on top of the changes + made for Time::HiRes during the Perl 5.7 development + cycle that culminated in the release of Perl 5.8.0. + + - add "require 5.005" to the Makefile.PL + - remove the REVISION section (CVS log) from HiRes.pm + - add jhi's copyright alongside Douglas' + - move HiRes.pm to lib/Time/ + - move HiRes.t to t/ + - modify HiRes.t to use $ENV{PERL_CORE} + - modify the original Time::HiRes version 1.20 Makefile.PL + to work both with Perl 5.8.0 and the new code with pre-5.8.0 + Perls (tried with 5.6.1) + - tiny tweaks and updates in README and TODO + - bump the VERSION to 1.29 + +1.20 Wed Feb 24 21:30 1999 + - make our usleep and ualarm substitutes into hrt_usleep + and hrt_ualarm. This helps static links of Perl with other + packages that also have usleep, etc. From + Ilya Zakharevich <ilya@math.ohio-state.edu> + - add C API stuff. From Joshua Pritikin + <joshua.pritikin@db.com> + - VMS Makefile.PL fun. From pvhp@forte.com (Peter Prymmer) + - hopefully correct "-lc" fix for SCO. + - add PPD stuff + + 1.20 adds a platform neutral set of C accessible routines if you are + running 5.005+. All other changes are packaging changes and build + fixes(?) for statically linked Perl, SCO, and VMS. + +1.19 Tue Sep 29 22:30 1998 + - put VMS gettimeofday() in. Patch is from Sebastian Bazley + <seb@stian.demon.co.uk> + - change GIMME_V to GIMME to help people with older versions of + Perl. + - fix Win32 version of gettimeofday(). It didn't affect anything, + but it confuses people reading the code when the return value + is backwards (0 is success). + - fix Makefile.PL (more) so that detection of gettimeofday is + more correct. + + 1.19 has better VMS support. + +1.18 Mon Jul 6 22:40 1998 + - add usleep() for Win32. + - fix Makefile.PL to fix reported HP/UX feature where unresolved + externals still cause an executable to be generated (though no + x bit set). Thanks to David Kozinn for report and explanation. + Problems with the fix are mine :) + + 1.18 has limited Win32 support (no ualarm). Added usleep for Win32. + Probably buggy. I'm sure I'll hear. + +1.17 Wed Jul 1 20:10 1998 + - fix setitimer calls so microseconds is not more than 1000000. + Hp/UX 9 doesn't like that. Provided by Roland B Robert, PhD. + - make Win32. We only get gettimeofday (the select hack doesn't + seem to work on my Win95 system). + - fix test 4 on 01test.t. add test to see if time() and + Time::HiRes::time() are close. + +1.16 Wed Nov 12 21:05 1997 + - add missing EXTEND in new gettimeofday scalar code. + + 1.16+ should be closer to building out of the box on Linux. Thanks + to Gisle Aas for patches, and the ualarm equivalent using setitimer. + + If your underlying operating system doesn't implement ualarm(), then + a fake using setitimer() will be made. If the OS is missing usleep(), + a fake one using select() will be made. If a fake can't be made for + either ualarm() or usleep(), then the corresponding Perl function will + not be available. If the OS is missing gettimeofday(), you will get + unresolved externals, either at link- or run-time. + + This is an improvement; the package used to not even build if + you were missing any of these bits. Roderick Schertler + + <roderick@argon.org> did all the conditional compilation stuff, + look at HiRes.pm and the test suites; it's good educational reading. + +1.15 Mon Nov 10 21:30 1997 + - HiRes.pm: update pod. Provided by Gisle Aas. + - HiRes.xs: if gettimeofday() called in scalar context, do + something more useful than before. Provided by Gisle Aas. + - README: tell of xsubpp '-nolinenumber' woes. thanks to + Edward Henigin <ed@texas.net> for pointing out the problem. + +1.14 Wed Nov 5 9:40 1997 + - Makefile.PL: look for setitimer + - HiRes.xs: if missing ualarm, but we have setitimer, make up + our own setitimer. These were provided by Gisle Aas. + +1.13 Tue Nov 4 23:30 1997 + - Makefile.PL: fix autodetect mechanism to do try linking in addition + to just compiling; should fix Linux build problem. Fix was provided + by Gisle Aas. + +1.12 Sun Oct 12 12:00:00 1997 + - Makefile.PL: set XSOPT to '-nolinenumbers' to work around xsubpp bug; + you may need to comment this back out if you have an older xsubpp. + - HiRes.xs: set PROTOTYPES: DISABLE + +1.11 Fri Sep 05 16:00:00 1997 + - Makefile.PL: + Had some line commented out that shouldn't have been (testing + remnants) + - README: + Previous version was corrupted. + +1.10 Thu May 22 20:20:00 1997 + - HiRes.xs, HiRes.pm, t/*: + - only compile what we have OS support for (or can + fake with select()) + - only test what we compiled + - gross improvement to the test suite + - fix EXPORT_FAIL. + This work was all done by Roderick Schertler + <roderick@argon.org>. If you run Linux or + one of the other ualarm-less platforms, and you like this + module, let Roderick know; without him, it still wouldn't + be working on those boxes... + - Makefile.PL: figure out what routines the OS has and + only build what we need. These bits were written by Jarkko + Hietaniemi <jhi@iki.fi>. Again, gratitude is due... + +1.02 Mon Dec 30 08:00:00 1996 + - HiRes.pm: update documentation to say what to do when missing + ualarm() and friends. + - README: update to warn that ualarm() and friends need to exist + +1.01 Fri Oct 17 08:00:00 1996 + - Makefile.PL: make XSPROTOARGS => '-noprototyopes' + - HiRes.pm: put blank line between __END__ and =head1 so that + pod2man works. + +1.00 Tue Sep 03 13:00:00 1996 + - original version; created by h2xs 1.16 diff --git a/ext/Time-HiRes/HiRes.pm b/ext/Time-HiRes/HiRes.pm new file mode 100644 index 0000000000..da4d45a96e --- /dev/null +++ b/ext/Time-HiRes/HiRes.pm @@ -0,0 +1,591 @@ +package Time::HiRes; + +use strict; +use vars qw($VERSION $XS_VERSION @ISA @EXPORT @EXPORT_OK $AUTOLOAD); + +require Exporter; +require DynaLoader; + +@ISA = qw(Exporter DynaLoader); + +@EXPORT = qw( ); +@EXPORT_OK = qw (usleep sleep ualarm alarm gettimeofday time tv_interval + getitimer setitimer nanosleep clock_gettime clock_getres + clock clock_nanosleep + CLOCK_HIGHRES CLOCK_MONOTONIC CLOCK_PROCESS_CPUTIME_ID + CLOCK_REALTIME CLOCK_SOFTTIME CLOCK_THREAD_CPUTIME_ID + CLOCK_TIMEOFDAY CLOCKS_PER_SEC + ITIMER_REAL ITIMER_VIRTUAL ITIMER_PROF ITIMER_REALPROF + TIMER_ABSTIME + d_usleep d_ualarm d_gettimeofday d_getitimer d_setitimer + d_nanosleep d_clock_gettime d_clock_getres + d_clock d_clock_nanosleep + stat + ); + +$VERSION = '1.9719'; +$XS_VERSION = $VERSION; +$VERSION = eval $VERSION; + +sub AUTOLOAD { + my $constname; + ($constname = $AUTOLOAD) =~ s/.*:://; + # print "AUTOLOAD: constname = $constname ($AUTOLOAD)\n"; + die "&Time::HiRes::constant not defined" if $constname eq 'constant'; + my ($error, $val) = constant($constname); + # print "AUTOLOAD: error = $error, val = $val\n"; + if ($error) { + my (undef,$file,$line) = caller; + die "$error at $file line $line.\n"; + } + { + no strict 'refs'; + *$AUTOLOAD = sub { $val }; + } + goto &$AUTOLOAD; +} + +sub import { + my $this = shift; + for my $i (@_) { + if (($i eq 'clock_getres' && !&d_clock_getres) || + ($i eq 'clock_gettime' && !&d_clock_gettime) || + ($i eq 'clock_nanosleep' && !&d_clock_nanosleep) || + ($i eq 'clock' && !&d_clock) || + ($i eq 'nanosleep' && !&d_nanosleep) || + ($i eq 'usleep' && !&d_usleep) || + ($i eq 'ualarm' && !&d_ualarm)) { + require Carp; + Carp::croak("Time::HiRes::$i(): unimplemented in this platform"); + } + } + Time::HiRes->export_to_level(1, $this, @_); +} + +bootstrap Time::HiRes; + +# Preloaded methods go here. + +sub tv_interval { + # probably could have been done in C + my ($a, $b) = @_; + $b = [gettimeofday()] unless defined($b); + (${$b}[0] - ${$a}[0]) + ((${$b}[1] - ${$a}[1]) / 1_000_000); +} + +# Autoload methods go after =cut, and are processed by the autosplit program. + +1; +__END__ + +=head1 NAME + +Time::HiRes - High resolution alarm, sleep, gettimeofday, interval timers + +=head1 SYNOPSIS + + use Time::HiRes qw( usleep ualarm gettimeofday tv_interval nanosleep + clock_gettime clock_getres clock_nanosleep clock + stat ); + + usleep ($microseconds); + nanosleep ($nanoseconds); + + ualarm ($microseconds); + ualarm ($microseconds, $interval_microseconds); + + $t0 = [gettimeofday]; + ($seconds, $microseconds) = gettimeofday; + + $elapsed = tv_interval ( $t0, [$seconds, $microseconds]); + $elapsed = tv_interval ( $t0, [gettimeofday]); + $elapsed = tv_interval ( $t0 ); + + use Time::HiRes qw ( time alarm sleep ); + + $now_fractions = time; + sleep ($floating_seconds); + alarm ($floating_seconds); + alarm ($floating_seconds, $floating_interval); + + use Time::HiRes qw( setitimer getitimer ); + + setitimer ($which, $floating_seconds, $floating_interval ); + getitimer ($which); + + use Time::HiRes qw( clock_gettime clock_getres clock_nanosleep + ITIMER_REAL ITIMER_VIRTUAL ITIMER_PROF ITIMER_REALPROF ); + + $realtime = clock_gettime(CLOCK_REALTIME); + $resolution = clock_getres(CLOCK_REALTIME); + + clock_nanosleep(CLOCK_REALTIME, 1.5e9); + clock_nanosleep(CLOCK_REALTIME, time()*1e9 + 10e9, TIMER_ABSTIME); + + my $ticktock = clock(); + + use Time::HiRes qw( stat ); + + my @stat = stat("file"); + my @stat = stat(FH); + +=head1 DESCRIPTION + +The C<Time::HiRes> module implements a Perl interface to the +C<usleep>, C<nanosleep>, C<ualarm>, C<gettimeofday>, and +C<setitimer>/C<getitimer> system calls, in other words, high +resolution time and timers. See the L</EXAMPLES> section below and the +test scripts for usage; see your system documentation for the +description of the underlying C<nanosleep> or C<usleep>, C<ualarm>, +C<gettimeofday>, and C<setitimer>/C<getitimer> calls. + +If your system lacks C<gettimeofday()> or an emulation of it you don't +get C<gettimeofday()> or the one-argument form of C<tv_interval()>. +If your system lacks all of C<nanosleep()>, C<usleep()>, +C<select()>, and C<poll>, you don't get C<Time::HiRes::usleep()>, +C<Time::HiRes::nanosleep()>, or C<Time::HiRes::sleep()>. +If your system lacks both C<ualarm()> and C<setitimer()> you don't get +C<Time::HiRes::ualarm()> or C<Time::HiRes::alarm()>. + +If you try to import an unimplemented function in the C<use> statement +it will fail at compile time. + +If your subsecond sleeping is implemented with C<nanosleep()> instead +of C<usleep()>, you can mix subsecond sleeping with signals since +C<nanosleep()> does not use signals. This, however, is not portable, +and you should first check for the truth value of +C<&Time::HiRes::d_nanosleep> to see whether you have nanosleep, and +then carefully read your C<nanosleep()> C API documentation for any +peculiarities. + +If you are using C<nanosleep> for something else than mixing sleeping +with signals, give some thought to whether Perl is the tool you should +be using for work requiring nanosecond accuracies. + +Remember that unless you are working on a I<hard realtime> system, +any clocks and timers will be imprecise, especially so if you are working +in a pre-emptive multiuser system. Understand the difference between +I<wallclock time> and process time (in UNIX-like systems the sum of +I<user> and I<system> times). Any attempt to sleep for X seconds will +most probably end up sleeping B<more> than that, but don't be surpised +if you end up sleeping slightly B<less>. + +The following functions can be imported from this module. +No functions are exported by default. + +=over 4 + +=item gettimeofday () + +In array context returns a two-element array with the seconds and +microseconds since the epoch. In scalar context returns floating +seconds like C<Time::HiRes::time()> (see below). + +=item usleep ( $useconds ) + +Sleeps for the number of microseconds (millionths of a second) +specified. Returns the number of microseconds actually slept. +Can sleep for more than one second, unlike the C<usleep> system call. +Can also sleep for zero seconds, which often works like a I<thread yield>. +See also C<Time::HiRes::usleep()>, C<Time::HiRes::sleep()>, and +C<Time::HiRes::clock_nanosleep()>. + +Do not expect usleep() to be exact down to one microsecond. + +=item nanosleep ( $nanoseconds ) + +Sleeps for the number of nanoseconds (1e9ths of a second) specified. +Returns the number of nanoseconds actually slept (accurate only to +microseconds, the nearest thousand of them). Can sleep for more than +one second. Can also sleep for zero seconds, which often works like +a I<thread yield>. See also C<Time::HiRes::sleep()>, +C<Time::HiRes::usleep()>, and C<Time::HiRes::clock_nanosleep()>. + +Do not expect nanosleep() to be exact down to one nanosecond. +Getting even accuracy of one thousand nanoseconds is good. + +=item ualarm ( $useconds [, $interval_useconds ] ) + +Issues a C<ualarm> call; the C<$interval_useconds> is optional and +will be zero if unspecified, resulting in C<alarm>-like behaviour. + +Returns the remaining time in the alarm in microseconds, or C<undef> +if an error occurred. + +ualarm(0) will cancel an outstanding ualarm(). + +Note that the interaction between alarms and sleeps is unspecified. + +=item tv_interval + +tv_interval ( $ref_to_gettimeofday [, $ref_to_later_gettimeofday] ) + +Returns the floating seconds between the two times, which should have +been returned by C<gettimeofday()>. If the second argument is omitted, +then the current time is used. + +=item time () + +Returns a floating seconds since the epoch. This function can be +imported, resulting in a nice drop-in replacement for the C<time> +provided with core Perl; see the L</EXAMPLES> below. + +B<NOTE 1>: This higher resolution timer can return values either less +or more than the core C<time()>, depending on whether your platform +rounds the higher resolution timer values up, down, or to the nearest second +to get the core C<time()>, but naturally the difference should be never +more than half a second. See also L</clock_getres>, if available +in your system. + +B<NOTE 2>: Since Sunday, September 9th, 2001 at 01:46:40 AM GMT, when +the C<time()> seconds since epoch rolled over to 1_000_000_000, the +default floating point format of Perl and the seconds since epoch have +conspired to produce an apparent bug: if you print the value of +C<Time::HiRes::time()> you seem to be getting only five decimals, not +six as promised (microseconds). Not to worry, the microseconds are +there (assuming your platform supports such granularity in the first +place). What is going on is that the default floating point format of +Perl only outputs 15 digits. In this case that means ten digits +before the decimal separator and five after. To see the microseconds +you can use either C<printf>/C<sprintf> with C<"%.6f">, or the +C<gettimeofday()> function in list context, which will give you the +seconds and microseconds as two separate values. + +=item sleep ( $floating_seconds ) + +Sleeps for the specified amount of seconds. Returns the number of +seconds actually slept (a floating point value). This function can +be imported, resulting in a nice drop-in replacement for the C<sleep> +provided with perl, see the L</EXAMPLES> below. + +Note that the interaction between alarms and sleeps is unspecified. + +=item alarm ( $floating_seconds [, $interval_floating_seconds ] ) + +The C<SIGALRM> signal is sent after the specified number of seconds. +Implemented using C<setitimer()> if available, C<ualarm()> if not. +The C<$interval_floating_seconds> argument is optional and will be +zero if unspecified, resulting in C<alarm()>-like behaviour. This +function can be imported, resulting in a nice drop-in replacement for +the C<alarm> provided with perl, see the L</EXAMPLES> below. + +Returns the remaining time in the alarm in seconds, or C<undef> +if an error occurred. + +B<NOTE 1>: With some combinations of operating systems and Perl +releases C<SIGALRM> restarts C<select()>, instead of interrupting it. +This means that an C<alarm()> followed by a C<select()> may together +take the sum of the times specified for the the C<alarm()> and the +C<select()>, not just the time of the C<alarm()>. + +Note that the interaction between alarms and sleeps is unspecified. + +=item setitimer ( $which, $floating_seconds [, $interval_floating_seconds ] ) + +Start up an interval timer: after a certain time, a signal ($which) arrives, +and more signals may keep arriving at certain intervals. To disable +an "itimer", use C<$floating_seconds> of zero. If the +C<$interval_floating_seconds> is set to zero (or unspecified), the +timer is disabled B<after> the next delivered signal. + +Use of interval timers may interfere with C<alarm()>, C<sleep()>, +and C<usleep()>. In standard-speak the "interaction is unspecified", +which means that I<anything> may happen: it may work, it may not. + +In scalar context, the remaining time in the timer is returned. + +In list context, both the remaining time and the interval are returned. + +There are usually three or four interval timers (signals) available: the +C<$which> can be C<ITIMER_REAL>, C<ITIMER_VIRTUAL>, C<ITIMER_PROF>, or +C<ITIMER_REALPROF>. Note that which ones are available depends: true +UNIX platforms usually have the first three, but only Solaris seems to +have C<ITIMER_REALPROF> (which is used to profile multithreaded programs). +Win32 unfortunately does not haveinterval timers. + +C<ITIMER_REAL> results in C<alarm()>-like behaviour. Time is counted in +I<real time>; that is, wallclock time. C<SIGALRM> is delivered when +the timer expires. + +C<ITIMER_VIRTUAL> counts time in (process) I<virtual time>; that is, +only when the process is running. In multiprocessor/user/CPU systems +this may be more or less than real or wallclock time. (This time is +also known as the I<user time>.) C<SIGVTALRM> is delivered when the +timer expires. + +C<ITIMER_PROF> counts time when either the process virtual time or when +the operating system is running on behalf of the process (such as I/O). +(This time is also known as the I<system time>.) (The sum of user +time and system time is known as the I<CPU time>.) C<SIGPROF> is +delivered when the timer expires. C<SIGPROF> can interrupt system calls. + +The semantics of interval timers for multithreaded programs are +system-specific, and some systems may support additional interval +timers. For example, it is unspecified which thread gets the signals. +See your C<setitimer()> documentation. + +=item getitimer ( $which ) + +Return the remaining time in the interval timer specified by C<$which>. + +In scalar context, the remaining time is returned. + +In list context, both the remaining time and the interval are returned. +The interval is always what you put in using C<setitimer()>. + +=item clock_gettime ( $which ) + +Return as seconds the current value of the POSIX high resolution timer +specified by C<$which>. All implementations that support POSIX high +resolution timers are supposed to support at least the C<$which> value +of C<CLOCK_REALTIME>, which is supposed to return results close to the +results of C<gettimeofday>, or the number of seconds since 00:00:00:00 +January 1, 1970 Greenwich Mean Time (GMT). Do not assume that +CLOCK_REALTIME is zero, it might be one, or something else. +Another potentially useful (but not available everywhere) value is +C<CLOCK_MONOTONIC>, which guarantees a monotonically increasing time +value (unlike time() or gettimeofday(), which can be adjusted). +See your system documentation for other possibly supported values. + +=item clock_getres ( $which ) + +Return as seconds the resolution of the POSIX high resolution timer +specified by C<$which>. All implementations that support POSIX high +resolution timers are supposed to support at least the C<$which> value +of C<CLOCK_REALTIME>, see L</clock_gettime>. + +=item clock_nanosleep ( $which, $nanoseconds, $flags = 0) + +Sleeps for the number of nanoseconds (1e9ths of a second) specified. +Returns the number of nanoseconds actually slept. The $which is the +"clock id", as with clock_gettime() and clock_getres(). The flags +default to zero but C<TIMER_ABSTIME> can specified (must be exported +explicitly) which means that C<$nanoseconds> is not a time interval +(as is the default) but instead an absolute time. Can sleep for more +than one second. Can also sleep for zero seconds, which often works +like a I<thread yield>. See also C<Time::HiRes::sleep()>, +C<Time::HiRes::usleep()>, and C<Time::HiRes::nanosleep()>. + +Do not expect clock_nanosleep() to be exact down to one nanosecond. +Getting even accuracy of one thousand nanoseconds is good. + +=item clock() + +Return as seconds the I<process time> (user + system time) spent by +the process since the first call to clock() (the definition is B<not> +"since the start of the process", though if you are lucky these times +may be quite close to each other, depending on the system). What this +means is that you probably need to store the result of your first call +to clock(), and subtract that value from the following results of clock(). + +The time returned also includes the process times of the terminated +child processes for which wait() has been executed. This value is +somewhat like the second value returned by the times() of core Perl, +but not necessarily identical. Note that due to backward +compatibility limitations the returned value may wrap around at about +2147 seconds or at about 36 minutes. + +=item stat + +=item stat FH + +=item stat EXPR + +As L<perlfunc/stat> but with the access/modify/change file timestamps +in subsecond resolution, if the operating system and the filesystem +both support such timestamps. To override the standard stat(): + + use Time::HiRes qw(stat); + +Test for the value of &Time::HiRes::d_hires_stat to find out whether +the operating system supports subsecond file timestamps: a value +larger than zero means yes. There are unfortunately no easy +ways to find out whether the filesystem supports such timestamps. +UNIX filesystems often do; NTFS does; FAT doesn't (FAT timestamp +granularity is B<two> seconds). + +A zero return value of &Time::HiRes::d_hires_stat means that +Time::HiRes::stat is a no-op passthrough for CORE::stat(), +and therefore the timestamps will stay integers. The same +thing will happen if the filesystem does not do subsecond timestamps, +even if the &Time::HiRes::d_hires_stat is non-zero. + +In any case do not expect nanosecond resolution, or even a microsecond +resolution. Also note that the modify/access timestamps might have +different resolutions, and that they need not be synchronized, e.g. +if the operations are + + write + stat # t1 + read + stat # t2 + +the access time stamp from t2 need not be greater-than the modify +time stamp from t1: it may be equal or I<less>. + +=back + +=head1 EXAMPLES + + use Time::HiRes qw(usleep ualarm gettimeofday tv_interval); + + $microseconds = 750_000; + usleep($microseconds); + + # signal alarm in 2.5s & every .1s thereafter + ualarm(2_500_000, 100_000); + # cancel that ualarm + ualarm(0); + + # get seconds and microseconds since the epoch + ($s, $usec) = gettimeofday(); + + # measure elapsed time + # (could also do by subtracting 2 gettimeofday return values) + $t0 = [gettimeofday]; + # do bunch of stuff here + $t1 = [gettimeofday]; + # do more stuff here + $t0_t1 = tv_interval $t0, $t1; + + $elapsed = tv_interval ($t0, [gettimeofday]); + $elapsed = tv_interval ($t0); # equivalent code + + # + # replacements for time, alarm and sleep that know about + # floating seconds + # + use Time::HiRes; + $now_fractions = Time::HiRes::time; + Time::HiRes::sleep (2.5); + Time::HiRes::alarm (10.6666666); + + use Time::HiRes qw ( time alarm sleep ); + $now_fractions = time; + sleep (2.5); + alarm (10.6666666); + + # Arm an interval timer to go off first at 10 seconds and + # after that every 2.5 seconds, in process virtual time + + use Time::HiRes qw ( setitimer ITIMER_VIRTUAL time ); + + $SIG{VTALRM} = sub { print time, "\n" }; + setitimer(ITIMER_VIRTUAL, 10, 2.5); + + use Time::HiRes qw( clock_gettime clock_getres CLOCK_REALTIME ); + # Read the POSIX high resolution timer. + my $high = clock_getres(CLOCK_REALTIME); + # But how accurate we can be, really? + my $reso = clock_getres(CLOCK_REALTIME); + + use Time::HiRes qw( clock_nanosleep TIMER_ABSTIME ); + clock_nanosleep(CLOCK_REALTIME, 1e6); + clock_nanosleep(CLOCK_REALTIME, 2e9, TIMER_ABSTIME); + + use Time::HiRes qw( clock ); + my $clock0 = clock(); + ... # Do something. + my $clock1 = clock(); + my $clockd = $clock1 - $clock0; + + use Time::HiRes qw( stat ); + my ($atime, $mtime, $ctime) = (stat("istics"))[8, 9, 10]; + +=head1 C API + +In addition to the perl API described above, a C API is available for +extension writers. The following C functions are available in the +modglobal hash: + + name C prototype + --------------- ---------------------- + Time::NVtime double (*)() + Time::U2time void (*)(pTHX_ UV ret[2]) + +Both functions return equivalent information (like C<gettimeofday>) +but with different representations. The names C<NVtime> and C<U2time> +were selected mainly because they are operating system independent. +(C<gettimeofday> is Unix-centric, though some platforms like Win32 and +VMS have emulations for it.) + +Here is an example of using C<NVtime> from C: + + double (*myNVtime)(); /* Returns -1 on failure. */ + SV **svp = hv_fetch(PL_modglobal, "Time::NVtime", 12, 0); + if (!svp) croak("Time::HiRes is required"); + if (!SvIOK(*svp)) croak("Time::NVtime isn't a function pointer"); + myNVtime = INT2PTR(double(*)(), SvIV(*svp)); + printf("The current time is: %f\n", (*myNVtime)()); + +=head1 DIAGNOSTICS + +=head2 useconds or interval more than ... + +In ualarm() you tried to use number of microseconds or interval (also +in microseconds) more than 1_000_000 and setitimer() is not available +in your system to emulate that case. + +=head2 negative time not invented yet + +You tried to use a negative time argument. + +=head2 internal error: useconds < 0 (unsigned ... signed ...) + +Something went horribly wrong-- the number of microseconds that cannot +become negative just became negative. Maybe your compiler is broken? + +=head2 useconds or uinterval equal to or more than 1000000 + +In some platforms it is not possible to get an alarm with subsecond +resolution and later than one second. + +=head2 unimplemented in this platform + +Some calls simply aren't available, real or emulated, on every platform. + +=head1 CAVEATS + +Notice that the core C<time()> maybe rounding rather than truncating. +What this means is that the core C<time()> may be reporting the time +as one second later than C<gettimeofday()> and C<Time::HiRes::time()>. + +Adjusting the system clock (either manually or by services like ntp) +may cause problems, especially for long running programs that assume +a monotonously increasing time (note that all platforms do not adjust +time as gracefully as UNIX ntp does). For example in Win32 (and derived +platforms like Cygwin and MinGW) the Time::HiRes::time() may temporarily +drift off from the system clock (and the original time()) by up to 0.5 +seconds. Time::HiRes will notice this eventually and recalibrate. +Note that since Time::HiRes 1.77 the clock_gettime(CLOCK_MONOTONIC) +might help in this (in case your system supports CLOCK_MONOTONIC). + +Some systems have APIs but not implementations: for example QNX and Haiku +have the interval timer APIs but not the functionality. + +=head1 SEE ALSO + +Perl modules L<BSD::Resource>, L<Time::TAI64>. + +Your system documentation for C<clock>, C<clock_gettime>, +C<clock_getres>, C<clock_nanosleep>, C<clock_settime>, C<getitimer>, +C<gettimeofday>, C<setitimer>, C<sleep>, C<stat>, C<ualarm>. + +=head1 AUTHORS + +D. Wegscheid <wegscd@whirlpool.com> +R. Schertler <roderick@argon.org> +J. Hietaniemi <jhi@iki.fi> +G. Aas <gisle@aas.no> + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 1996-2002 Douglas E. Wegscheid. All rights reserved. + +Copyright (c) 2002, 2003, 2004, 2005, 2006, 2007, 2008 Jarkko Hietaniemi. +All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/ext/Time-HiRes/HiRes.xs b/ext/Time-HiRes/HiRes.xs new file mode 100644 index 0000000000..69eee69333 --- /dev/null +++ b/ext/Time-HiRes/HiRes.xs @@ -0,0 +1,1257 @@ +/* + * + * Copyright (c) 1996-2002 Douglas E. Wegscheid. All rights reserved. + * + * Copyright (c) 2002,2003,2004,2005,2006,2007,2008 Jarkko Hietaniemi. + * All rights reserved. + * + * This program is free software; you can redistribute it and/or modify + * it under the same terms as Perl itself. + */ + +#ifdef __cplusplus +extern "C" { +#endif +#define PERL_NO_GET_CONTEXT +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" +#include "ppport.h" +#if defined(__CYGWIN__) && defined(HAS_W32API_WINDOWS_H) +# include <w32api/windows.h> +# define CYGWIN_WITH_W32API +#endif +#ifdef WIN32 +# include <time.h> +#else +# include <sys/time.h> +#endif +#ifdef HAS_SELECT +# ifdef I_SYS_SELECT +# include <sys/select.h> +# endif +#endif +#if defined(TIME_HIRES_CLOCK_GETTIME_SYSCALL) || defined(TIME_HIRES_CLOCK_GETRES_SYSCALL) +#include <syscall.h> +#endif +#ifdef __cplusplus +} +#endif + +/* At least ppport.h 3.13 gets this wrong: one really cannot + * have NVgf as anything else than "g" under Perl 5.6.x. */ +#if PERL_REVISION == 5 && PERL_VERSION == 6 +# undef NVgf +# define NVgf "g" +#endif + +#define IV_1E6 1000000 +#define IV_1E7 10000000 +#define IV_1E9 1000000000 + +#define NV_1E6 1000000.0 +#define NV_1E7 10000000.0 +#define NV_1E9 1000000000.0 + +#ifndef PerlProc_pause +# define PerlProc_pause() Pause() +#endif + +#ifdef HAS_PAUSE +# define Pause pause +#else +# undef Pause /* In case perl.h did it already. */ +# define Pause() sleep(~0) /* Zzz for a long time. */ +#endif + +/* Though the cpp define ITIMER_VIRTUAL is available the functionality + * is not supported in Cygwin as of August 2004, ditto for Win32. + * Neither are ITIMER_PROF or ITIMER_REALPROF implemented. --jhi + */ +#if defined(__CYGWIN__) || defined(WIN32) +# undef ITIMER_VIRTUAL +# undef ITIMER_PROF +# undef ITIMER_REALPROF +#endif + +#if defined(TIME_HIRES_CLOCK_GETTIME) && defined(_STRUCT_ITIMERSPEC) + +/* HP-UX has CLOCK_XXX values but as enums, not as defines. + * The only way to detect these would be to test compile for each. */ +# ifdef __hpux +/* However, it seems that at least in HP-UX 11.31 ia64 there *are* + * defines for these, so let's try detecting them. */ +# ifndef CLOCK_REALTIME +# define CLOCK_REALTIME CLOCK_REALTIME +# define CLOCK_VIRTUAL CLOCK_VIRTUAL +# define CLOCK_PROFILE CLOCK_PROFILE +# endif +# endif /* # ifdef __hpux */ + +#endif /* #if defined(TIME_HIRES_CLOCK_GETTIME) && defined(_STRUCT_ITIMERSPEC) */ + +#if defined(WIN32) || defined(CYGWIN_WITH_W32API) + +#ifndef HAS_GETTIMEOFDAY +# define HAS_GETTIMEOFDAY +#endif + +/* shows up in winsock.h? +struct timeval { + long tv_sec; + long tv_usec; +} +*/ + +typedef union { + unsigned __int64 ft_i64; + FILETIME ft_val; +} FT_t; + +#define MY_CXT_KEY "Time::HiRes_" XS_VERSION + +typedef struct { + unsigned long run_count; + unsigned __int64 base_ticks; + unsigned __int64 tick_frequency; + FT_t base_systime_as_filetime; + unsigned __int64 reset_time; +} my_cxt_t; + +START_MY_CXT + +/* Number of 100 nanosecond units from 1/1/1601 to 1/1/1970 */ +#ifdef __GNUC__ +# define Const64(x) x##LL +#else +# define Const64(x) x##i64 +#endif +#define EPOCH_BIAS Const64(116444736000000000) + +#ifdef Const64 +# ifdef __GNUC__ +# define IV_1E6LL 1000000LL /* Needed because of Const64() ##-appends LL (or i64). */ +# define IV_1E7LL 10000000LL +# define IV_1E9LL 1000000000LL +# else +# define IV_1E6i64 1000000i64 +# define IV_1E7i64 10000000i64 +# define IV_1E9i64 1000000000i64 +# endif +#endif + +/* NOTE: This does not compute the timezone info (doing so can be expensive, + * and appears to be unsupported even by glibc) */ + +/* dMY_CXT needs a Perl context and we don't want to call PERL_GET_CONTEXT + for performance reasons */ + +#undef gettimeofday +#define gettimeofday(tp, not_used) _gettimeofday(aTHX_ tp, not_used) + +/* If the performance counter delta drifts more than 0.5 seconds from the + * system time then we recalibrate to the system time. This means we may + * move *backwards* in time! */ +#define MAX_PERF_COUNTER_SKEW Const64(5000000) /* 0.5 seconds */ + +/* Reset reading from the performance counter every five minutes. + * Many PC clocks just seem to be so bad. */ +#define MAX_PERF_COUNTER_TICKS Const64(300000000) /* 300 seconds */ + +static int +_gettimeofday(pTHX_ struct timeval *tp, void *not_used) +{ + dMY_CXT; + + unsigned __int64 ticks; + FT_t ft; + + if (MY_CXT.run_count++ == 0 || + MY_CXT.base_systime_as_filetime.ft_i64 > MY_CXT.reset_time) { + QueryPerformanceFrequency((LARGE_INTEGER*)&MY_CXT.tick_frequency); + QueryPerformanceCounter((LARGE_INTEGER*)&MY_CXT.base_ticks); + GetSystemTimeAsFileTime(&MY_CXT.base_systime_as_filetime.ft_val); + ft.ft_i64 = MY_CXT.base_systime_as_filetime.ft_i64; + MY_CXT.reset_time = ft.ft_i64 + MAX_PERF_COUNTER_TICKS; + } + else { + __int64 diff; + QueryPerformanceCounter((LARGE_INTEGER*)&ticks); + ticks -= MY_CXT.base_ticks; + ft.ft_i64 = MY_CXT.base_systime_as_filetime.ft_i64 + + Const64(IV_1E7) * (ticks / MY_CXT.tick_frequency) + +(Const64(IV_1E7) * (ticks % MY_CXT.tick_frequency)) / MY_CXT.tick_frequency; + diff = ft.ft_i64 - MY_CXT.base_systime_as_filetime.ft_i64; + if (diff < -MAX_PERF_COUNTER_SKEW || diff > MAX_PERF_COUNTER_SKEW) { + MY_CXT.base_ticks += ticks; + GetSystemTimeAsFileTime(&MY_CXT.base_systime_as_filetime.ft_val); + ft.ft_i64 = MY_CXT.base_systime_as_filetime.ft_i64; + } + } + + /* seconds since epoch */ + tp->tv_sec = (long)((ft.ft_i64 - EPOCH_BIAS) / Const64(IV_1E7)); + + /* microseconds remaining */ + tp->tv_usec = (long)((ft.ft_i64 / Const64(10)) % Const64(IV_1E6)); + + return 0; +} +#endif + +#if defined(WIN32) && !defined(ATLEASTFIVEOHOHFIVE) +static unsigned int +sleep(unsigned int t) +{ + Sleep(t*1000); + return 0; +} +#endif + +#if !defined(HAS_GETTIMEOFDAY) && defined(VMS) +#define HAS_GETTIMEOFDAY + +#include <lnmdef.h> +#include <time.h> /* gettimeofday */ +#include <stdlib.h> /* qdiv */ +#include <starlet.h> /* sys$gettim */ +#include <descrip.h> +#ifdef __VAX +#include <lib$routines.h> /* lib$ediv() */ +#endif + +/* + VMS binary time is expressed in 100 nano-seconds since + system base time which is 17-NOV-1858 00:00:00.00 +*/ + +#define DIV_100NS_TO_SECS 10000000L +#define DIV_100NS_TO_USECS 10L + +/* + gettimeofday is supposed to return times since the epoch + so need to determine this in terms of VMS base time +*/ +static $DESCRIPTOR(dscepoch,"01-JAN-1970 00:00:00.00"); + +#ifdef __VAX +static long base_adjust[2]={0L,0L}; +#else +static __int64 base_adjust=0; +#endif + +/* + + If we don't have gettimeofday, then likely we are on a VMS machine that + operates on local time rather than UTC...so we have to zone-adjust. + This code gleefully swiped from VMS.C + +*/ +/* method used to handle UTC conversions: + * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction + */ +static int gmtime_emulation_type; +/* number of secs to add to UTC POSIX-style time to get local time */ +static long int utc_offset_secs; +static struct dsc$descriptor_s fildevdsc = + { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" }; +static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL }; + +static time_t toutc_dst(time_t loc) { + struct tm *rsltmp; + + if ((rsltmp = localtime(&loc)) == NULL) return -1; + loc -= utc_offset_secs; + if (rsltmp->tm_isdst) loc -= 3600; + return loc; +} + +static time_t toloc_dst(time_t utc) { + struct tm *rsltmp; + + utc += utc_offset_secs; + if ((rsltmp = localtime(&utc)) == NULL) return -1; + if (rsltmp->tm_isdst) utc += 3600; + return utc; +} + +#define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \ + ((gmtime_emulation_type || timezone_setup()), \ + (gmtime_emulation_type == 1 ? toutc_dst(secs) : \ + ((secs) - utc_offset_secs)))) + +#define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \ + ((gmtime_emulation_type || timezone_setup()), \ + (gmtime_emulation_type == 1 ? toloc_dst(secs) : \ + ((secs) + utc_offset_secs)))) + +static int +timezone_setup(void) +{ + struct tm *tm_p; + + if (gmtime_emulation_type == 0) { + int dstnow; + time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */ + /* results of calls to gmtime() and localtime() */ + /* for same &base */ + + gmtime_emulation_type++; + if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */ + char off[LNM$C_NAMLENGTH+1];; + + gmtime_emulation_type++; + if (!Perl_vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) { + gmtime_emulation_type++; + utc_offset_secs = 0; + Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC"); + } + else { utc_offset_secs = atol(off); } + } + else { /* We've got a working gmtime() */ + struct tm gmt, local; + + gmt = *tm_p; + tm_p = localtime(&base); + local = *tm_p; + utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400; + utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600; + utc_offset_secs += (local.tm_min - gmt.tm_min) * 60; + utc_offset_secs += (local.tm_sec - gmt.tm_sec); + } + } + return 1; +} + + +int +gettimeofday (struct timeval *tp, void *tpz) +{ + long ret; +#ifdef __VAX + long quad[2]; + long quad1[2]; + long div_100ns_to_secs; + long div_100ns_to_usecs; + long quo,rem; + long quo1,rem1; +#else + __int64 quad; + __qdiv_t ans1,ans2; +#endif +/* + In case of error, tv_usec = 0 and tv_sec = VMS condition code. + The return from function is also set to -1. + This is not exactly as per the manual page. +*/ + + tp->tv_usec = 0; + +#ifdef __VAX + if (base_adjust[0]==0 && base_adjust[1]==0) { +#else + if (base_adjust==0) { /* Need to determine epoch adjustment */ +#endif + ret=sys$bintim(&dscepoch,&base_adjust); + if (1 != (ret &&1)) { + tp->tv_sec = ret; + return -1; + } + } + + ret=sys$gettim(&quad); /* Get VMS system time */ + if ((1 && ret) == 1) { +#ifdef __VAX + quad[0] -= base_adjust[0]; /* convert to epoch offset */ + quad[1] -= base_adjust[1]; /* convert 2nd half of quadword */ + div_100ns_to_secs = DIV_100NS_TO_SECS; + div_100ns_to_usecs = DIV_100NS_TO_USECS; + lib$ediv(&div_100ns_to_secs,&quad,&quo,&rem); + quad1[0] = rem; + quad1[1] = 0L; + lib$ediv(&div_100ns_to_usecs,&quad1,&quo1,&rem1); + tp->tv_sec = quo; /* Whole seconds */ + tp->tv_usec = quo1; /* Micro-seconds */ +#else + quad -= base_adjust; /* convert to epoch offset */ + ans1=qdiv(quad,DIV_100NS_TO_SECS); + ans2=qdiv(ans1.rem,DIV_100NS_TO_USECS); + tp->tv_sec = ans1.quot; /* Whole seconds */ + tp->tv_usec = ans2.quot; /* Micro-seconds */ +#endif + } else { + tp->tv_sec = ret; + return -1; + } +# ifdef VMSISH_TIME +# ifdef RTL_USES_UTC + if (VMSISH_TIME) tp->tv_sec = _toloc(tp->tv_sec); +# else + if (!VMSISH_TIME) tp->tv_sec = _toutc(tp->tv_sec); +# endif +# endif + return 0; +} +#endif + + + /* Do not use H A S _ N A N O S L E E P + * so that Perl Configure doesn't scan for it (and pull in -lrt and + * the like which are not usually good ideas for the default Perl). + * (We are part of the core perl now.) + * The TIME_HIRES_NANOSLEEP is set by Makefile.PL. */ +#if !defined(HAS_USLEEP) && defined(TIME_HIRES_NANOSLEEP) +#define HAS_USLEEP +#define usleep hrt_usleep /* could conflict with ncurses for static build */ + +void +hrt_usleep(unsigned long usec) /* This is used to emulate usleep. */ +{ + struct timespec res; + res.tv_sec = usec / IV_1E6; + res.tv_nsec = ( usec - res.tv_sec * IV_1E6 ) * 1000; + nanosleep(&res, NULL); +} + +#endif /* #if !defined(HAS_USLEEP) && defined(TIME_HIRES_NANOSLEEP) */ + +#if !defined(HAS_USLEEP) && defined(HAS_SELECT) +#ifndef SELECT_IS_BROKEN +#define HAS_USLEEP +#define usleep hrt_usleep /* could conflict with ncurses for static build */ + +void +hrt_usleep(unsigned long usec) +{ + struct timeval tv; + tv.tv_sec = 0; + tv.tv_usec = usec; + select(0, (Select_fd_set_t)NULL, (Select_fd_set_t)NULL, + (Select_fd_set_t)NULL, &tv); +} +#endif +#endif /* #if !defined(HAS_USLEEP) && defined(HAS_SELECT) */ + +#if !defined(HAS_USLEEP) && defined(WIN32) +#define HAS_USLEEP +#define usleep hrt_usleep /* could conflict with ncurses for static build */ + +void +hrt_usleep(unsigned long usec) +{ + long msec; + msec = usec / 1000; + Sleep (msec); +} +#endif /* #if !defined(HAS_USLEEP) && defined(WIN32) */ + +#if !defined(HAS_USLEEP) && defined(HAS_POLL) +#define HAS_USLEEP +#define usleep hrt_usleep /* could conflict with ncurses for static build */ + +void +hrt_usleep(unsigned long usec) +{ + int msec = usec / 1000; + poll(0, 0, msec); +} + +#endif /* #if !defined(HAS_USLEEP) && defined(HAS_POLL) */ + +#if defined(HAS_SETITIMER) && defined(ITIMER_REAL) + +static int +hrt_ualarm_itimero(struct itimerval* itv, int usec, int uinterval) +{ + itv->it_value.tv_sec = usec / IV_1E6; + itv->it_value.tv_usec = usec % IV_1E6; + itv->it_interval.tv_sec = uinterval / IV_1E6; + itv->it_interval.tv_usec = uinterval % IV_1E6; + return setitimer(ITIMER_REAL, itv, 0); +} + +int +hrt_ualarm_itimer(int usec, int uinterval) +{ + struct itimerval itv; + return hrt_ualarm_itimero(&itv, usec, uinterval); +} + +#ifdef HAS_UALARM +int +hrt_ualarm(int usec, int interval) /* for binary compat before 1.91 */ +{ + return hrt_ualarm_itimer(usec, interval); +} +#endif /* #ifdef HAS_UALARM */ +#endif /* #if !defined(HAS_UALARM) && defined(HAS_SETITIMER) */ + +#if !defined(HAS_UALARM) && defined(HAS_SETITIMER) +#define HAS_UALARM +#define ualarm hrt_ualarm_itimer /* could conflict with ncurses for static build */ +#endif + +#if !defined(HAS_UALARM) && defined(VMS) +#define HAS_UALARM +#define ualarm vms_ualarm + +#include <lib$routines.h> +#include <ssdef.h> +#include <starlet.h> +#include <descrip.h> +#include <signal.h> +#include <jpidef.h> +#include <psldef.h> + +#define VMSERR(s) (!((s)&1)) + +static void +us_to_VMS(useconds_t mseconds, unsigned long v[]) +{ + int iss; + unsigned long qq[2]; + + qq[0] = mseconds; + qq[1] = 0; + v[0] = v[1] = 0; + + iss = lib$addx(qq,qq,qq); + if (VMSERR(iss)) lib$signal(iss); + iss = lib$subx(v,qq,v); + if (VMSERR(iss)) lib$signal(iss); + iss = lib$addx(qq,qq,qq); + if (VMSERR(iss)) lib$signal(iss); + iss = lib$subx(v,qq,v); + if (VMSERR(iss)) lib$signal(iss); + iss = lib$subx(v,qq,v); + if (VMSERR(iss)) lib$signal(iss); +} + +static int +VMS_to_us(unsigned long v[]) +{ + int iss; + unsigned long div=10,quot, rem; + + iss = lib$ediv(&div,v,",&rem); + if (VMSERR(iss)) lib$signal(iss); + + return quot; +} + +typedef unsigned short word; +typedef struct _ualarm { + int function; + int repeat; + unsigned long delay[2]; + unsigned long interval[2]; + unsigned long remain[2]; +} Alarm; + + +static int alarm_ef; +static Alarm *a0, alarm_base; +#define UAL_NULL 0 +#define UAL_SET 1 +#define UAL_CLEAR 2 +#define UAL_ACTIVE 4 +static void ualarm_AST(Alarm *a); + +static int +vms_ualarm(int mseconds, int interval) +{ + Alarm *a, abase; + struct item_list3 { + word length; + word code; + void *bufaddr; + void *retlenaddr; + } ; + static struct item_list3 itmlst[2]; + static int first = 1; + unsigned long asten; + int iss, enabled; + + if (first) { + first = 0; + itmlst[0].code = JPI$_ASTEN; + itmlst[0].length = sizeof(asten); + itmlst[0].retlenaddr = NULL; + itmlst[1].code = 0; + itmlst[1].length = 0; + itmlst[1].bufaddr = NULL; + itmlst[1].retlenaddr = NULL; + + iss = lib$get_ef(&alarm_ef); + if (VMSERR(iss)) lib$signal(iss); + + a0 = &alarm_base; + a0->function = UAL_NULL; + } + itmlst[0].bufaddr = &asten; + + iss = sys$getjpiw(0,0,0,itmlst,0,0,0); + if (VMSERR(iss)) lib$signal(iss); + if (!(asten&0x08)) return -1; + + a = &abase; + if (mseconds) { + a->function = UAL_SET; + } else { + a->function = UAL_CLEAR; + } + + us_to_VMS(mseconds, a->delay); + if (interval) { + us_to_VMS(interval, a->interval); + a->repeat = 1; + } else + a->repeat = 0; + + iss = sys$clref(alarm_ef); + if (VMSERR(iss)) lib$signal(iss); + + iss = sys$dclast(ualarm_AST,a,0); + if (VMSERR(iss)) lib$signal(iss); + + iss = sys$waitfr(alarm_ef); + if (VMSERR(iss)) lib$signal(iss); + + if (a->function == UAL_ACTIVE) + return VMS_to_us(a->remain); + else + return 0; +} + + + +static void +ualarm_AST(Alarm *a) +{ + int iss; + unsigned long now[2]; + + iss = sys$gettim(now); + if (VMSERR(iss)) lib$signal(iss); + + if (a->function == UAL_SET || a->function == UAL_CLEAR) { + if (a0->function == UAL_ACTIVE) { + iss = sys$cantim(a0,PSL$C_USER); + if (VMSERR(iss)) lib$signal(iss); + + iss = lib$subx(a0->remain, now, a->remain); + if (VMSERR(iss)) lib$signal(iss); + + if (a->remain[1] & 0x80000000) + a->remain[0] = a->remain[1] = 0; + } + + if (a->function == UAL_SET) { + a->function = a0->function; + a0->function = UAL_ACTIVE; + a0->repeat = a->repeat; + if (a0->repeat) { + a0->interval[0] = a->interval[0]; + a0->interval[1] = a->interval[1]; + } + a0->delay[0] = a->delay[0]; + a0->delay[1] = a->delay[1]; + + iss = lib$subx(now, a0->delay, a0->remain); + if (VMSERR(iss)) lib$signal(iss); + + iss = sys$setimr(0,a0->delay,ualarm_AST,a0); + if (VMSERR(iss)) lib$signal(iss); + } else { + a->function = a0->function; + a0->function = UAL_NULL; + } + iss = sys$setef(alarm_ef); + if (VMSERR(iss)) lib$signal(iss); + } else if (a->function == UAL_ACTIVE) { + if (a->repeat) { + iss = lib$subx(now, a->interval, a->remain); + if (VMSERR(iss)) lib$signal(iss); + + iss = sys$setimr(0,a->interval,ualarm_AST,a); + if (VMSERR(iss)) lib$signal(iss); + } else { + a->function = UAL_NULL; + } + iss = sys$wake(0,0); + if (VMSERR(iss)) lib$signal(iss); + lib$signal(SS$_ASTFLT); + } else { + lib$signal(SS$_BADPARAM); + } +} + +#endif /* #if !defined(HAS_UALARM) && defined(VMS) */ + +#ifdef HAS_GETTIMEOFDAY + +static int +myU2time(pTHX_ UV *ret) +{ + struct timeval Tp; + int status; + status = gettimeofday (&Tp, NULL); + ret[0] = Tp.tv_sec; + ret[1] = Tp.tv_usec; + return status; +} + +static NV +myNVtime() +{ +#ifdef WIN32 + dTHX; +#endif + struct timeval Tp; + int status; + status = gettimeofday (&Tp, NULL); + return status == 0 ? Tp.tv_sec + (Tp.tv_usec / NV_1E6) : -1.0; +} + +#endif /* #ifdef HAS_GETTIMEOFDAY */ + +static void +hrstatns(UV atime, UV mtime, UV ctime, UV *atime_nsec, UV *mtime_nsec, UV *ctime_nsec) +{ + dTHXR; + *atime_nsec = 0; + *mtime_nsec = 0; + *ctime_nsec = 0; +#ifdef TIME_HIRES_STAT +#if TIME_HIRES_STAT == 1 + *atime_nsec = PL_statcache.st_atimespec.tv_nsec; + *mtime_nsec = PL_statcache.st_mtimespec.tv_nsec; + *ctime_nsec = PL_statcache.st_ctimespec.tv_nsec; +#endif +#if TIME_HIRES_STAT == 2 + *atime_nsec = PL_statcache.st_atimensec; + *mtime_nsec = PL_statcache.st_mtimensec; + *ctime_nsec = PL_statcache.st_ctimensec; +#endif +#if TIME_HIRES_STAT == 3 + *atime_nsec = PL_statcache.st_atime_n; + *mtime_nsec = PL_statcache.st_mtime_n; + *ctime_nsec = PL_statcache.st_ctime_n; +#endif +#if TIME_HIRES_STAT == 4 + *atime_nsec = PL_statcache.st_atim.tv_nsec; + *mtime_nsec = PL_statcache.st_mtim.tv_nsec; + *ctime_nsec = PL_statcache.st_ctim.tv_nsec; +#endif +#if TIME_HIRES_STAT == 5 + *atime_nsec = PL_statcache.st_uatime * 1000; + *mtime_nsec = PL_statcache.st_umtime * 1000; + *ctime_nsec = PL_statcache.st_uctime * 1000; +#endif +#endif +} + +#include "const-c.inc" + +MODULE = Time::HiRes PACKAGE = Time::HiRes + +PROTOTYPES: ENABLE + +BOOT: +{ +#ifdef MY_CXT_KEY + MY_CXT_INIT; +#endif +#ifdef ATLEASTFIVEOHOHFIVE +# ifdef HAS_GETTIMEOFDAY + { + hv_store(PL_modglobal, "Time::NVtime", 12, newSViv(PTR2IV(myNVtime)), 0); + hv_store(PL_modglobal, "Time::U2time", 12, newSViv(PTR2IV(myU2time)), 0); + } +# endif +#endif +} + +#if defined(USE_ITHREADS) && defined(MY_CXT_KEY) + +void +CLONE(...) + CODE: + MY_CXT_CLONE; + +#endif + +INCLUDE: const-xs.inc + +#if defined(HAS_USLEEP) && defined(HAS_GETTIMEOFDAY) + +NV +usleep(useconds) + NV useconds + PREINIT: + struct timeval Ta, Tb; + CODE: + gettimeofday(&Ta, NULL); + if (items > 0) { + if (useconds > 1E6) { + IV seconds = (IV) (useconds / 1E6); + /* If usleep() has been implemented using setitimer() + * then this contortion is unnecessary-- but usleep() + * may be implemented in some other way, so let's contort. */ + if (seconds) { + sleep(seconds); + useconds -= 1E6 * seconds; + } + } else if (useconds < 0.0) + croak("Time::HiRes::usleep(%"NVgf"): negative time not invented yet", useconds); + usleep((U32)useconds); + } else + PerlProc_pause(); + gettimeofday(&Tb, NULL); +#if 0 + printf("[%ld %ld] [%ld %ld]\n", Tb.tv_sec, Tb.tv_usec, Ta.tv_sec, Ta.tv_usec); +#endif + RETVAL = 1E6*(Tb.tv_sec-Ta.tv_sec)+(NV)((IV)Tb.tv_usec-(IV)Ta.tv_usec); + + OUTPUT: + RETVAL + +#if defined(TIME_HIRES_NANOSLEEP) + +NV +nanosleep(nsec) + NV nsec + PREINIT: + struct timespec sleepfor, unslept; + CODE: + if (nsec < 0.0) + croak("Time::HiRes::nanosleep(%"NVgf"): negative time not invented yet", nsec); + sleepfor.tv_sec = (Time_t)(nsec / 1e9); + sleepfor.tv_nsec = (long)(nsec - ((NV)sleepfor.tv_sec) * 1e9); + if (!nanosleep(&sleepfor, &unslept)) { + RETVAL = nsec; + } else { + sleepfor.tv_sec -= unslept.tv_sec; + sleepfor.tv_nsec -= unslept.tv_nsec; + if (sleepfor.tv_nsec < 0) { + sleepfor.tv_sec--; + sleepfor.tv_nsec += 1000000000; + } + RETVAL = ((NV)sleepfor.tv_sec) * 1e9 + ((NV)sleepfor.tv_nsec); + } + OUTPUT: + RETVAL + +#else /* #if defined(TIME_HIRES_NANOSLEEP) */ + +NV +nanosleep(nsec) + NV nsec + CODE: + croak("Time::HiRes::nanosleep(): unimplemented in this platform"); + RETVAL = 0.0; + +#endif /* #if defined(TIME_HIRES_NANOSLEEP) */ + +NV +sleep(...) + PREINIT: + struct timeval Ta, Tb; + CODE: + gettimeofday(&Ta, NULL); + if (items > 0) { + NV seconds = SvNV(ST(0)); + if (seconds >= 0.0) { + UV useconds = (UV)(1E6 * (seconds - (UV)seconds)); + if (seconds >= 1.0) + sleep((U32)seconds); + if ((IV)useconds < 0) { +#if defined(__sparc64__) && defined(__GNUC__) + /* Sparc64 gcc 2.95.3 (e.g. on NetBSD) has a bug + * where (0.5 - (UV)(0.5)) will under certain + * circumstances (if the double is cast to UV more + * than once?) evaluate to -0.5, instead of 0.5. */ + useconds = -(IV)useconds; +#endif /* #if defined(__sparc64__) && defined(__GNUC__) */ + if ((IV)useconds < 0) + croak("Time::HiRes::sleep(%"NVgf"): internal error: useconds < 0 (unsigned %"UVuf" signed %"IVdf")", seconds, useconds, (IV)useconds); + } + usleep(useconds); + } else + croak("Time::HiRes::sleep(%"NVgf"): negative time not invented yet", seconds); + } else + PerlProc_pause(); + gettimeofday(&Tb, NULL); +#if 0 + printf("[%ld %ld] [%ld %ld]\n", Tb.tv_sec, Tb.tv_usec, Ta.tv_sec, Ta.tv_usec); +#endif + RETVAL = (NV)(Tb.tv_sec-Ta.tv_sec)+0.000001*(NV)(Tb.tv_usec-Ta.tv_usec); + + OUTPUT: + RETVAL + +#else /* #if defined(HAS_USLEEP) && defined(HAS_GETTIMEOFDAY) */ + +NV +usleep(useconds) + NV useconds + CODE: + croak("Time::HiRes::usleep(): unimplemented in this platform"); + RETVAL = 0.0; + +#endif /* #if defined(HAS_USLEEP) && defined(HAS_GETTIMEOFDAY) */ + +#ifdef HAS_UALARM + +IV +ualarm(useconds,uinterval=0) + int useconds + int uinterval + CODE: + if (useconds < 0 || uinterval < 0) + croak("Time::HiRes::ualarm(%d, %d): negative time not invented yet", useconds, uinterval); +#if defined(HAS_SETITIMER) && defined(ITIMER_REAL) + { + struct itimerval itv; + if (hrt_ualarm_itimero(&itv, useconds, uinterval)) { + RETVAL = itv.it_value.tv_sec + IV_1E6 * itv.it_value.tv_usec; + } else { + RETVAL = 0; + } + } +#else + if (useconds >= IV_1E6 || uinterval >= IV_1E6) + croak("Time::HiRes::ualarm(%d, %d): useconds or uinterval equal to or more than %"IVdf, useconds, uinterval, IV_1E6); + RETVAL = ualarm(useconds, uinterval); +#endif + + OUTPUT: + RETVAL + +NV +alarm(seconds,interval=0) + NV seconds + NV interval + CODE: + if (seconds < 0.0 || interval < 0.0) + croak("Time::HiRes::alarm(%"NVgf", %"NVgf"): negative time not invented yet", seconds, interval); + { + IV useconds = IV_1E6 * seconds; + IV uinterval = IV_1E6 * interval; +#if defined(HAS_SETITIMER) && defined(ITIMER_REAL) + { + struct itimerval itv; + if (hrt_ualarm_itimero(&itv, useconds, uinterval)) { + RETVAL = (NV)itv.it_value.tv_sec + (NV)itv.it_value.tv_usec / NV_1E6; + } else { + RETVAL = 0; + } + } +#else + if (useconds >= IV_1E6 || uinterval >= IV_1E6) + croak("Time::HiRes::alarm(%d, %d): seconds or interval equal to or more than 1.0 ", useconds, uinterval, IV_1E6); + RETVAL = (NV)ualarm( useconds, uinterval ) / NV_1E6; +#endif + } + + OUTPUT: + RETVAL + +#else + +int +ualarm(useconds,interval=0) + int useconds + int interval + CODE: + croak("Time::HiRes::ualarm(): unimplemented in this platform"); + RETVAL = -1; + +NV +alarm(seconds,interval=0) + NV seconds + NV interval + CODE: + croak("Time::HiRes::alarm(): unimplemented in this platform"); + RETVAL = 0.0; + +#endif /* #ifdef HAS_UALARM */ + +#ifdef HAS_GETTIMEOFDAY +# ifdef MACOS_TRADITIONAL /* fix epoch TZ and use unsigned time_t */ +void +gettimeofday() + PREINIT: + struct timeval Tp; + struct timezone Tz; + PPCODE: + int status; + status = gettimeofday (&Tp, &Tz); + + if (status == 0) { + Tp.tv_sec += Tz.tz_minuteswest * 60; /* adjust for TZ */ + if (GIMME == G_ARRAY) { + EXTEND(sp, 2); + /* Mac OS (Classic) has unsigned time_t */ + PUSHs(sv_2mortal(newSVuv(Tp.tv_sec))); + PUSHs(sv_2mortal(newSViv(Tp.tv_usec))); + } else { + EXTEND(sp, 1); + PUSHs(sv_2mortal(newSVnv(Tp.tv_sec + (Tp.tv_usec / NV_1E6)))); + } + } + +NV +time() + PREINIT: + struct timeval Tp; + struct timezone Tz; + CODE: + int status; + status = gettimeofday (&Tp, &Tz); + if (status == 0) { + Tp.tv_sec += Tz.tz_minuteswest * 60; /* adjust for TZ */ + RETVAL = Tp.tv_sec + (Tp.tv_usec / NV_1E6); + } else { + RETVAL = -1.0; + } + OUTPUT: + RETVAL + +# else /* MACOS_TRADITIONAL */ +void +gettimeofday() + PREINIT: + struct timeval Tp; + PPCODE: + int status; + status = gettimeofday (&Tp, NULL); + if (status == 0) { + if (GIMME == G_ARRAY) { + EXTEND(sp, 2); + PUSHs(sv_2mortal(newSViv(Tp.tv_sec))); + PUSHs(sv_2mortal(newSViv(Tp.tv_usec))); + } else { + EXTEND(sp, 1); + PUSHs(sv_2mortal(newSVnv(Tp.tv_sec + (Tp.tv_usec / NV_1E6)))); + } + } + +NV +time() + PREINIT: + struct timeval Tp; + CODE: + int status; + status = gettimeofday (&Tp, NULL); + if (status == 0) { + RETVAL = Tp.tv_sec + (Tp.tv_usec / NV_1E6); + } else { + RETVAL = -1.0; + } + OUTPUT: + RETVAL + +# endif /* MACOS_TRADITIONAL */ +#endif /* #ifdef HAS_GETTIMEOFDAY */ + +#if defined(HAS_GETITIMER) && defined(HAS_SETITIMER) + +#define TV2NV(tv) ((NV)((tv).tv_sec) + 0.000001 * (NV)((tv).tv_usec)) + +void +setitimer(which, seconds, interval = 0) + int which + NV seconds + NV interval + PREINIT: + struct itimerval newit; + struct itimerval oldit; + PPCODE: + if (seconds < 0.0 || interval < 0.0) + croak("Time::HiRes::setitimer(%"IVdf", %"NVgf", %"NVgf"): negative time not invented yet", (IV)which, seconds, interval); + newit.it_value.tv_sec = (IV)seconds; + newit.it_value.tv_usec = + (IV)((seconds - (NV)newit.it_value.tv_sec) * NV_1E6); + newit.it_interval.tv_sec = (IV)interval; + newit.it_interval.tv_usec = + (IV)((interval - (NV)newit.it_interval.tv_sec) * NV_1E6); + if (setitimer(which, &newit, &oldit) == 0) { + EXTEND(sp, 1); + PUSHs(sv_2mortal(newSVnv(TV2NV(oldit.it_value)))); + if (GIMME == G_ARRAY) { + EXTEND(sp, 1); + PUSHs(sv_2mortal(newSVnv(TV2NV(oldit.it_interval)))); + } + } + +void +getitimer(which) + int which + PREINIT: + struct itimerval nowit; + PPCODE: + if (getitimer(which, &nowit) == 0) { + EXTEND(sp, 1); + PUSHs(sv_2mortal(newSVnv(TV2NV(nowit.it_value)))); + if (GIMME == G_ARRAY) { + EXTEND(sp, 1); + PUSHs(sv_2mortal(newSVnv(TV2NV(nowit.it_interval)))); + } + } + +#endif /* #if defined(HAS_GETITIMER) && defined(HAS_SETITIMER) */ + +#if defined(TIME_HIRES_CLOCK_GETTIME) + +NV +clock_gettime(clock_id = CLOCK_REALTIME) + int clock_id + PREINIT: + struct timespec ts; + int status = -1; + CODE: +#ifdef TIME_HIRES_CLOCK_GETTIME_SYSCALL + status = syscall(SYS_clock_gettime, clock_id, &ts); +#else + status = clock_gettime(clock_id, &ts); +#endif + RETVAL = status == 0 ? ts.tv_sec + (NV) ts.tv_nsec / (NV) 1e9 : -1; + + OUTPUT: + RETVAL + +#else /* if defined(TIME_HIRES_CLOCK_GETTIME) */ + +NV +clock_gettime(clock_id = 0) + int clock_id + CODE: + croak("Time::HiRes::clock_gettime(): unimplemented in this platform"); + RETVAL = 0.0; + +#endif /* #if defined(TIME_HIRES_CLOCK_GETTIME) */ + +#if defined(TIME_HIRES_CLOCK_GETRES) + +NV +clock_getres(clock_id = CLOCK_REALTIME) + int clock_id + PREINIT: + int status = -1; + struct timespec ts; + CODE: +#ifdef TIME_HIRES_CLOCK_GETRES_SYSCALL + status = syscall(SYS_clock_getres, clock_id, &ts); +#else + status = clock_getres(clock_id, &ts); +#endif + RETVAL = status == 0 ? ts.tv_sec + (NV) ts.tv_nsec / (NV) 1e9 : -1; + + OUTPUT: + RETVAL + +#else /* if defined(TIME_HIRES_CLOCK_GETRES) */ + +NV +clock_getres(clock_id = 0) + int clock_id + CODE: + croak("Time::HiRes::clock_getres(): unimplemented in this platform"); + RETVAL = 0.0; + +#endif /* #if defined(TIME_HIRES_CLOCK_GETRES) */ + +#if defined(TIME_HIRES_CLOCK_NANOSLEEP) && defined(TIMER_ABSTIME) + +NV +clock_nanosleep(clock_id, nsec, flags = 0) + int clock_id + NV nsec + int flags + PREINIT: + struct timespec sleepfor, unslept; + CODE: + if (nsec < 0.0) + croak("Time::HiRes::clock_nanosleep(..., %"NVgf"): negative time not invented yet", nsec); + sleepfor.tv_sec = (Time_t)(nsec / 1e9); + sleepfor.tv_nsec = (long)(nsec - ((NV)sleepfor.tv_sec) * 1e9); + if (!clock_nanosleep(clock_id, flags, &sleepfor, &unslept)) { + RETVAL = nsec; + } else { + sleepfor.tv_sec -= unslept.tv_sec; + sleepfor.tv_nsec -= unslept.tv_nsec; + if (sleepfor.tv_nsec < 0) { + sleepfor.tv_sec--; + sleepfor.tv_nsec += 1000000000; + } + RETVAL = ((NV)sleepfor.tv_sec) * 1e9 + ((NV)sleepfor.tv_nsec); + } + OUTPUT: + RETVAL + +#else /* if defined(TIME_HIRES_CLOCK_NANOSLEEP) && defined(TIMER_ABSTIME) */ + +NV +clock_nanosleep() + CODE: + croak("Time::HiRes::clock_nanosleep(): unimplemented in this platform"); + RETVAL = 0.0; + +#endif /* #if defined(TIME_HIRES_CLOCK_NANOSLEEP) && defined(TIMER_ABSTIME) */ + +#if defined(TIME_HIRES_CLOCK) && defined(CLOCKS_PER_SEC) + +NV +clock() + PREINIT: + clock_t clocks; + CODE: + clocks = clock(); + RETVAL = clocks == -1 ? -1 : (NV)clocks / (NV)CLOCKS_PER_SEC; + + OUTPUT: + RETVAL + +#else /* if defined(TIME_HIRES_CLOCK) && defined(CLOCKS_PER_SEC) */ + +NV +clock() + CODE: + croak("Time::HiRes::clock(): unimplemented in this platform"); + RETVAL = 0.0; + +#endif /* #if defined(TIME_HIRES_CLOCK) && defined(CLOCKS_PER_SEC) */ + +void +stat(...) +PROTOTYPE: ;$ + PPCODE: + PUSHMARK(SP); + XPUSHs(sv_2mortal(newSVsv(items == 1 ? ST(0) : DEFSV))); + PUTBACK; + ENTER; + PL_laststatval = -1; + (void)*(PL_ppaddr[OP_STAT])(aTHXR); + SPAGAIN; + LEAVE; + if (PL_laststatval == 0) { + /* We assume that pp_stat() left us with 13 valid stack items, + * and that the timestamps are at offsets 8, 9, and 10. */ + UV atime = SvUV(ST( 8)); + UV mtime = SvUV(ST( 9)); + UV ctime = SvUV(ST(10)); + UV atime_nsec; + UV mtime_nsec; + UV ctime_nsec; + hrstatns(atime, mtime, ctime, + &atime_nsec, &mtime_nsec, &ctime_nsec); + if (atime_nsec) + ST( 8) = sv_2mortal(newSVnv(atime + 1e-9 * (NV) atime_nsec)); + if (mtime_nsec) + ST( 9) = sv_2mortal(newSVnv(mtime + 1e-9 * (NV) mtime_nsec)); + if (ctime_nsec) + ST(10) = sv_2mortal(newSVnv(ctime + 1e-9 * (NV) ctime_nsec)); + XSRETURN(13); + } + XSRETURN(0); diff --git a/ext/Time-HiRes/Makefile.PL b/ext/Time-HiRes/Makefile.PL new file mode 100644 index 0000000000..c44199835f --- /dev/null +++ b/ext/Time-HiRes/Makefile.PL @@ -0,0 +1,879 @@ +#!/usr/bin/perl +# +# In general we trust %Config, but for nanosleep() this trust +# may be misplaced (it may be linkable but not really functional). +# Use $ENV{FORCE_NANOSLEEP_SCAN} to force rescanning whether there +# really is hope. + +require 5.002; + +use Config; +use ExtUtils::MakeMaker; +use strict; + +my $VERBOSE = $ENV{VERBOSE}; +my $DEFINE; +my $LIBS = []; +my $XSOPT = ''; +my $SYSCALL_H; + +use vars qw($self); # Used in 'sourcing' the hints. + +# TBD: Can we just use $Config(exe_ext) here instead of this complex +# expression? +my $ld_exeext = ($^O eq 'cygwin' || + $^O eq 'os2' && $Config{ldflags} =~ /-Zexe\b/) ? '.exe' : + (($^O eq 'vos') ? $Config{exe_ext} : ''); + +unless($ENV{PERL_CORE}) { + $ENV{PERL_CORE} = 1 if grep { $_ eq 'PERL_CORE=1' } @ARGV; +} + +# Perls 5.002 and 5.003 did not have File::Spec, fake what we need. + +sub my_dirsep { + $^O eq 'VMS' ? '.' : + $^O =~ /mswin32|netware|djgpp/i ? '\\' : + $^O eq 'MacOS' ? ':' + : '/'; +} + +sub my_catdir { + shift; + my $catdir = join(my_dirsep, @_); + $^O eq 'VMS' ? "[$catdir]" : $catdir; +} + +sub my_catfile { + shift; + return join(my_dirsep, @_) unless $^O eq 'VMS'; + my $file = pop; + return my_catdir (undef, @_) . $file; +} + +sub my_updir { + shift; + $^O eq 'VMS' ? "-" : ".."; +} + +BEGIN { + eval { require File::Spec }; + if ($@) { + *File::Spec::catdir = \&my_catdir; + *File::Spec::updir = \&my_updir; + *File::Spec::catfile = \&my_catfile; + } +} + +# Avoid 'used only once' warnings. +my $nop1 = *File::Spec::catdir; +my $nop2 = *File::Spec::updir; +my $nop3 = *File::Spec::catfile; + +# if you have 5.004_03 (and some slightly older versions?), xsubpp +# tries to generate line numbers in the C code generated from the .xs. +# unfortunately, it is a little buggy around #ifdef'd code. +# my choice is leave it in and have people with old perls complain +# about the "Usage" bug, or leave it out and be unable to compile myself +# without changing it, and then I'd always forget to change it before a +# release. Sorry, Edward :) + +sub try_compile_and_link { + my ($c, %args) = @_; + + my ($ok) = 0; + my ($tmp) = "tmp$$"; + local(*TMPC); + + my $obj_ext = $Config{obj_ext} || ".o"; + unlink("$tmp.c", "$tmp$obj_ext"); + + if (open(TMPC, ">$tmp.c")) { + print TMPC $c; + close(TMPC); + + my $cccmd = $args{cccmd}; + + my $errornull; + + my $COREincdir; + + if ($ENV{PERL_CORE}) { + my $updir = File::Spec->updir; + $COREincdir = File::Spec->catdir(($updir) x 2); + } else { + $COREincdir = File::Spec->catdir($Config{'archlibexp'}, 'CORE'); + } + + if ($ENV{PERL_CORE}) { + unless (-f File::Spec->catfile($COREincdir, "EXTERN.h")) { + die <<__EOD__; +Your environment variable PERL_CORE is '$ENV{PERL_CORE}' but there +is no EXTERN.h in $COREincdir. +Cannot continue, aborting. +__EOD__ + } + } + + my $ccflags = $Config{'ccflags'} . ' ' . "-I$COREincdir"; + + if ($^O eq 'VMS') { + if ($ENV{PERL_CORE}) { + # Fragile if the extensions change hierarchy within + # the Perl core but this should do for now. + $cccmd = "$Config{'cc'} /include=([---]) $tmp.c"; + } else { + my $perl_core = $Config{'installarchlib'}; + $perl_core =~ s/\]$/.CORE]/; + $cccmd = "$Config{'cc'} /include=(perl_root:[000000],$perl_core) $tmp.c"; + } + } + + if ($args{silent} || !$VERBOSE) { + $errornull = "2>/dev/null" unless defined $errornull; + } else { + $errornull = ''; + } + + $cccmd = "$Config{'cc'} -o $tmp $ccflags $tmp.c @$LIBS $errornull" + unless defined $cccmd; + + if ($^O eq 'VMS') { + open( CMDFILE, ">$tmp.com" ); + print CMDFILE "\$ SET MESSAGE/NOFACILITY/NOSEVERITY/NOIDENT/NOTEXT\n"; + print CMDFILE "\$ $cccmd\n"; + print CMDFILE "\$ IF \$SEVERITY .NE. 1 THEN EXIT 44\n"; # escalate + close CMDFILE; + system("\@ $tmp.com"); + $ok = $?==0; + for ("$tmp.c", "$tmp$obj_ext", "$tmp.com", "$tmp$Config{exe_ext}") { + 1 while unlink $_; + } + } + else + { + my $tmp_exe = "$tmp$ld_exeext"; + printf "cccmd = $cccmd\n" if $VERBOSE; + my $res = system($cccmd); + $ok = defined($res) && $res == 0 && -s $tmp_exe && -x _; + + if ( $ok && exists $args{run} && $args{run}) { + my $tmp_exe = + File::Spec->catfile(File::Spec->curdir, $tmp_exe); + printf "Running $tmp_exe..." if $VERBOSE; + if (system($tmp_exe) == 0) { + $ok = 1; + } else { + $ok = 0; + my $errno = $? >> 8; + local $! = $errno; + printf <<EOF; + +*** The test run of '$tmp_exe' failed: status $? +*** (the status means: errno = $errno or '$!') +*** DO NOT PANIC: this just means that *some* functionality will be missing. +EOF + } + } + unlink("$tmp.c", $tmp_exe); + } + } + + return $ok; +} + +my $TIME_HEADERS = <<EOH; +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" +#ifdef I_SYS_TYPES +# include <sys/types.h> +#endif +#ifdef I_SYS_TIME +# include <sys/time.h> +#endif +#ifdef I_SYS_SELECT +# include <sys/select.h> /* struct timeval might be hidden in here */ +#endif +EOH + +sub has_gettimeofday { + # confusing but true (if condition true ==> -DHAS_GETTIMEOFDAY already) + return 0 if $Config{d_gettimeod}; + return 1 if try_compile_and_link(<<EOM); +$TIME_HEADERS +static int foo() +{ + struct timeval tv; + gettimeofday(&tv, 0); +} +int main(int argc, char** argv) +{ + foo(); +} +EOM + return 0; +} + +sub has_x { + my ($x, %args) = @_; + + return 1 if + try_compile_and_link(<<EOM, %args); +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#ifdef I_UNISTD +# include <unistd.h> +#endif + +#ifdef I_SYS_TYPES +# include <sys/types.h> +#endif + +#ifdef I_SYS_TIME +# include <sys/time.h> +#endif + +int main(int argc, char** argv) +{ + $x; +} +EOM + return 0; +} + +sub has_nanosleep { + print "testing... "; + return 1 if + try_compile_and_link(<<EOM, run => 1); +#include <time.h> +#include <sys/time.h> +#include <stdio.h> +#include <stdlib.h> +#include <errno.h> + +/* int nanosleep(const struct timespec *rqtp, struct timespec *rmtp); */ + +int main(int argc, char** argv) { + struct timespec ts1, ts2; + int ret; + ts1.tv_sec = 0; + ts1.tv_nsec = 750000000; + ts2.tv_sec = 0; + ts2.tv_nsec = 0; + errno = 0; + ret = nanosleep(&ts1, &ts2); /* E.g. in AIX nanosleep() fails and sets errno to ENOSYS. */ + ret == 0 ? exit(0) : exit(errno ? errno : -1); +} +EOM +} + +sub has_include { + my ($inc) = @_; + return 1 if + try_compile_and_link(<<EOM); +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#include <$inc> +int main(int argc, char** argv) +{ + return 0; +} +EOM + return 0; +} + +sub has_clock_xxx_syscall { + my $x = shift; + return 0 unless defined $SYSCALL_H; + return 1 if + try_compile_and_link(<<EOM, run => 1); +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" +#include <$SYSCALL_H> +int main(int argc, char** argv) +{ + struct timespec ts; + /* Many Linuxes get ENOSYS even though the syscall exists. */ + /* All implementations are supposed to support CLOCK_REALTIME. */ + int ret = syscall(SYS_clock_$x, CLOCK_REALTIME, &ts); + ret == 0 ? exit(0) : exit(errno ? errno : -1); +} +EOM +} + +sub has_clock_xxx { + my $xxx = shift; + return 1 if + try_compile_and_link(<<EOM, run => 1); +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" +int main(int argc, char** argv) +{ + struct timespec ts; + int ret = clock_$xxx(CLOCK_REALTIME, &ts); /* Many Linuxes get ENOSYS. */ + /* All implementations are supposed to support CLOCK_REALTIME. */ + ret == 0 ? exit(0) : exit(errno ? errno : -1); +} +EOM +} + +sub has_clock { + return 1 if + try_compile_and_link(<<EOM, run => 1); +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" +int main(int argc, char** argv) +{ + clock_t tictoc; + clock_t ret = clock(); + ret == (clock_t)-1 ? exit(errno ? errno : -1) : exit(0); +} +EOM +} + +sub has_clock_nanosleep { + return 1 if + try_compile_and_link(<<EOM, run => 1); +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" +#include <time.h> +int main(int argc, char** argv) +{ + int ret; + struct timespec ts1; + struct timespec ts2; + ts1.tv_sec = 0; + ts1.tv_nsec = 750000000;; + ret = clock_nanosleep(CLOCK_MONOTONIC, 0, &ts1, &ts2); + ret == 0 ? exit(0) : exit(errno ? errno : -1); +} +EOM +} + +sub DEFINE { + my ($def, $val) = @_; + my $define = defined $val ? "$def=$val" : $def ; + unless ($DEFINE =~ /(?:^| )-D\Q$define\E(?: |$)/) { + $DEFINE .= " -D$define"; + } +} + +sub init { + my $hints = File::Spec->catfile("hints", "$^O.pl"); + if (-f $hints) { + print "Using hints $hints...\n"; + local $self; + do $hints; + if (exists $self->{LIBS}) { + $LIBS = $self->{LIBS}; + print "Extra libraries: @$LIBS...\n"; + } + } + + $DEFINE = ''; + + if ($Config{d_syscall}) { + print "Have syscall()... looking for syscall.h... "; + if (has_include('syscall.h')) { + $SYSCALL_H = 'syscall.h'; + } elsif (has_include('sys/syscall.h')) { + $SYSCALL_H = 'sys/syscall.h'; + } + } else { + print "No syscall()...\n"; + } + + if ($Config{d_syscall}) { + if (defined $SYSCALL_H) { + print "found <$SYSCALL_H>.\n"; + } else { + print "NOT found.\n"; + } + } + + print "Looking for gettimeofday()... "; + my $has_gettimeofday; + if (exists $Config{d_gettimeod}) { + $has_gettimeofday++ if $Config{d_gettimeod}; + } elsif (has_gettimeofday()) { + $DEFINE .= ' -DHAS_GETTIMEOFDAY'; + $has_gettimeofday++; + } + + if ($has_gettimeofday) { + print "found.\n"; + } else { + die <<EOD +Your operating system does not seem to have the gettimeofday() function. +(or, at least, I cannot find it) + +There is no way Time::HiRes is going to work. + +I am awfully sorry but I cannot go further. + +Aborting configuration. + +EOD + } + + print "Looking for setitimer()... "; + my $has_setitimer; + if (exists $Config{d_setitimer}) { + $has_setitimer++ if $Config{d_setitimer}; + } elsif (has_x("setitimer(ITIMER_REAL, 0, 0)")) { + $has_setitimer++; + $DEFINE .= ' -DHAS_SETITIMER'; + } + + if ($has_setitimer) { + print "found.\n"; + } else { + print "NOT found.\n"; + } + + print "Looking for getitimer()... "; + my $has_getitimer; + if (exists $Config{'d_getitimer'}) { + $has_getitimer++ if $Config{'d_getitimer'}; + } elsif (has_x("getitimer(ITIMER_REAL, 0)")) { + $has_getitimer++; + $DEFINE .= ' -DHAS_GETITIMER'; + } + + if ($has_getitimer) { + print "found.\n"; + } else { + print "NOT found.\n"; + } + + if ($has_setitimer && $has_getitimer) { + print "You have interval timers (both setitimer and getitimer).\n"; + } else { + print "You do not have interval timers.\n"; + } + + print "Looking for ualarm()... "; + my $has_ualarm; + if (exists $Config{d_ualarm}) { + $has_ualarm++ if $Config{d_ualarm}; + } elsif (has_x ("ualarm (0, 0)")) { + $has_ualarm++; + $DEFINE .= ' -DHAS_UALARM'; + } + + if ($has_ualarm) { + print "found.\n"; + } else { + print "NOT found.\n"; + if ($has_setitimer) { + print "But you have setitimer().\n"; + print "We can make a Time::HiRes::ualarm().\n"; + } + } + + print "Looking for usleep()... "; + my $has_usleep; + if (exists $Config{d_usleep}) { + $has_usleep++ if $Config{d_usleep}; + } elsif (has_x ("usleep (0)")) { + $has_usleep++; + $DEFINE .= ' -DHAS_USLEEP'; + } + + if ($has_usleep) { + print "found.\n"; + } else { + print "NOT found.\n"; + print "Let's see if you have select()... "; + if ($Config{'d_select'}) { + print "found.\n"; + print "We can make a Time::HiRes::usleep().\n"; + } else { + print "NOT found.\n"; + print "You won't have a Time::HiRes::usleep().\n"; + } + } + + print "Looking for nanosleep()... "; + my $has_nanosleep; + if ($ENV{FORCE_NANOSLEEP_SCAN}) { + print "forced scan... "; + if (has_nanosleep()) { + $has_nanosleep++; + $DEFINE .= ' -DTIME_HIRES_NANOSLEEP'; + } + } + elsif (exists $Config{d_nanosleep}) { + print "believing \$Config{d_nanosleep}... "; + if ($Config{d_nanosleep}) { + $has_nanosleep++; + $DEFINE .= ' -DTIME_HIRES_NANOSLEEP'; + } + } elsif ($^O =~ /^(mpeix)$/) { + # MPE/iX falsely finds nanosleep from its libc equivalent. + print "skipping because in $^O... "; + } else { + if (has_nanosleep()) { + $has_nanosleep++; + $DEFINE .= ' -DTIME_HIRES_NANOSLEEP'; + } + } + + if ($has_nanosleep) { + print "found.\n"; + print "You can mix subsecond sleeps with signals, if you want to.\n"; + print "(It's still not portable, though.)\n"; + } else { + print "NOT found.\n"; + my $nt = ($^O eq 'os2' ? '' : 'not'); + print "You can$nt mix subsecond sleeps with signals.\n"; + print "(It would not be portable anyway.)\n"; + } + + print "Looking for clock_gettime()... "; + my $has_clock_gettime; + if (exists $Config{d_clock_gettime}) { + $has_clock_gettime++ if $Config{d_clock_gettime}; # Unlikely... + } elsif (has_clock_xxx('gettime')) { + $has_clock_gettime++; + $DEFINE .= ' -DTIME_HIRES_CLOCK_GETTIME'; + } elsif (defined $SYSCALL_H && has_clock_xxx_syscall('gettime')) { + $has_clock_gettime++; + $DEFINE .= ' -DTIME_HIRES_CLOCK_GETTIME -DTIME_HIRES_CLOCK_GETTIME_SYSCALL'; + } + + if ($has_clock_gettime) { + if ($DEFINE =~ /-DTIME_HIRES_CLOCK_GETTIME_SYSCALL/) { + print "found (via syscall).\n"; + } else { + print "found.\n"; + } + } else { + print "NOT found.\n"; + } + + print "Looking for clock_getres()... "; + my $has_clock_getres; + if (exists $Config{d_clock_getres}) { + $has_clock_getres++ if $Config{d_clock_getres}; # Unlikely... + } elsif (has_clock_xxx('getres')) { + $has_clock_getres++; + $DEFINE .= ' -DTIME_HIRES_CLOCK_GETRES'; + } elsif (defined $SYSCALL_H && has_clock_xxx_syscall('getres')) { + $has_clock_getres++; + $DEFINE .= ' -DTIME_HIRES_CLOCK_GETRES -DTIME_HIRES_CLOCK_GETRES_SYSCALL'; + } + + if ($has_clock_getres) { + if ($DEFINE =~ /-DTIME_HIRES_CLOCK_GETRES_SYSCALL/) { + print "found (via syscall).\n"; + } else { + print "found.\n"; + } + } else { + print "NOT found.\n"; + } + + print "Looking for clock_nanosleep()... "; + my $has_clock_nanosleep; + if (exists $Config{d_clock_nanosleep}) { + $has_clock_nanosleep++ if $Config{d_clock_nanosleep}; # Unlikely... + } elsif (has_clock_nanosleep()) { + $has_clock_nanosleep++; + $DEFINE .= ' -DTIME_HIRES_CLOCK_NANOSLEEP'; + } + + if ($has_clock_nanosleep) { + print "found.\n"; + } else { + print "NOT found.\n"; + } + + print "Looking for clock()... "; + my $has_clock; + if (exists $Config{d_clock}) { + $has_clock++ if $Config{d_clock}; # Unlikely... + } elsif (has_clock()) { + $has_clock++; + $DEFINE .= ' -DTIME_HIRES_CLOCK'; + } + + if ($has_clock) { + print "found.\n"; + } else { + print "NOT found.\n"; + } + + print "Looking for stat() subsecond timestamps...\n"; + + print "Trying struct stat st_atimespec.tv_nsec..."; + my $has_stat_st_xtimespec; + if (try_compile_and_link(<<EOM)) { +$TIME_HEADERS +#include <sys/stat.h> +int main(int argc, char** argv) { + struct stat st; + st.st_atimespec.tv_nsec = 0; +} +EOM + $has_stat_st_xtimespec++; + DEFINE('TIME_HIRES_STAT', 1); + } + + if ($has_stat_st_xtimespec) { + print "found.\n"; + } else { + print "NOT found.\n"; + } + + print "Trying struct stat st_atimensec..."; + my $has_stat_st_xtimensec; + if (try_compile_and_link(<<EOM)) { +$TIME_HEADERS +#include <sys/stat.h> +int main(int argc, char** argv) { + struct stat st; + st.st_atimensec = 0; +} +EOM + $has_stat_st_xtimensec++; + DEFINE('TIME_HIRES_STAT', 2); + } + + if ($has_stat_st_xtimensec) { + print "found.\n"; + } else { + print "NOT found.\n"; + } + + print "Trying struct stat st_atime_n..."; + my $has_stat_st_xtime_n; + if (try_compile_and_link(<<EOM)) { +$TIME_HEADERS +#include <sys/stat.h> +int main(int argc, char** argv) { + struct stat st; + st.st_atime_n = 0; +} +EOM + $has_stat_st_xtime_n++; + DEFINE('TIME_HIRES_STAT', 3); + } + + if ($has_stat_st_xtime_n) { + print "found.\n"; + } else { + print "NOT found.\n"; + } + + print "Trying struct stat st_atim.tv_nsec..."; + my $has_stat_st_xtim; + if (try_compile_and_link(<<EOM)) { +$TIME_HEADERS +#include <sys/stat.h> +int main(int argc, char** argv) { + struct stat st; + st.st_atim.tv_nsec = 0; +} +EOM + $has_stat_st_xtim++; + DEFINE('TIME_HIRES_STAT', 4); + } + + if ($has_stat_st_xtim) { + print "found.\n"; + } else { + print "NOT found.\n"; + } + + print "Trying struct stat st_uatime..."; + my $has_stat_st_uxtime; + if (try_compile_and_link(<<EOM)) { +$TIME_HEADERS +#include <sys/stat.h> +int main(int argc, char** argv) { + struct stat st; + st.st_uatime = 0; +} +EOM + $has_stat_st_uxtime++; + DEFINE('TIME_HIRES_STAT', 5); + } + + if ($has_stat_st_uxtime) { + print "found.\n"; + } else { + print "NOT found.\n"; + } + + if ($DEFINE =~ /-DTIME_HIRES_STAT=\d+/) { + print "You seem to have stat() subsecond timestamps.\n"; + print "(Your struct stat has them, but the filesystems must help.)\n"; + } else { + print "You do not seem to have stat subsecond timestamps.\n"; + } + + my $has_w32api_windows_h; + + if ($^O eq 'cygwin') { + print "Looking for <w32api/windows.h>... "; + if (has_include('w32api/windows.h')) { + $has_w32api_windows_h++; + DEFINE('HAS_W32API_WINDOWS_H'); + } + if ($has_w32api_windows_h) { + print "found.\n"; + } else { + print "NOT found.\n"; + } + } + + if ($DEFINE) { + $DEFINE =~ s/^\s+//; + if (open(XDEFINE, ">xdefine")) { + print XDEFINE $DEFINE, "\n"; + close(XDEFINE); + } + } +} + +sub doMakefile { + my @makefileopts = (); + + if ($] >= 5.005) { + push (@makefileopts, + 'AUTHOR' => 'Jarkko Hietaniemi <jhi@iki.fi>', + 'ABSTRACT_FROM' => 'HiRes.pm', + ); + DEFINE('ATLEASTFIVEOHOHFIVE'); + } + + push (@makefileopts, + 'NAME' => 'Time::HiRes', + 'VERSION_FROM' => 'HiRes.pm', # finds $VERSION + 'LIBS' => $LIBS, # e.g., '-lm' + 'DEFINE' => $DEFINE, # e.g., '-DHAS_SOMETHING' + 'XSOPT' => $XSOPT, + # Do not even think about 'INC' => '-I/usr/ucbinclude', + # Solaris will avenge. + 'INC' => '', # e.g., '-I/usr/include/other' + 'INSTALLDIRS' => ($] >= 5.008 ? 'perl' : 'site'), + 'dist' => { + 'CI' => 'ci -l', + 'COMPRESS' => 'gzip -9f', + 'SUFFIX' => 'gz', + }, + clean => { FILES => "xdefine" }, + realclean => { FILES=> 'const-c.inc const-xs.inc' }, + ); + + if ($ENV{PERL_CORE}) { + push @makefileopts, MAN3PODS => {}; + } + + WriteMakefile(@makefileopts); +} + +sub doConstants { + if (eval {require ExtUtils::Constant; 1}) { + my @names = qw(CLOCK_HIGHRES CLOCK_MONOTONIC + CLOCK_PROCESS_CPUTIME_ID + CLOCK_REALTIME + CLOCK_SOFTTIME + CLOCK_THREAD_CPUTIME_ID + CLOCK_TIMEOFDAY + CLOCKS_PER_SEC + ITIMER_REAL ITIMER_VIRTUAL ITIMER_PROF + ITIMER_REALPROF + TIMER_ABSTIME); + foreach (qw (d_usleep d_ualarm d_gettimeofday d_getitimer d_setitimer + d_nanosleep d_clock_gettime d_clock_getres + d_clock d_clock_nanosleep d_hires_stat)) { + my $macro = $_; + if ($macro =~ /^(d_nanosleep|d_clock_gettime|d_clock_getres|d_clock|d_clock_nanosleep)$/) { + $macro =~ s/^d_(.+)/TIME_HIRES_\U$1/; + } elsif ($macro =~ /^(d_hires_stat)$/) { + my $d_hires_stat = 0; + $d_hires_stat = $1 if ($DEFINE =~ /-DTIME_HIRES_STAT=(\d+)/); + push @names, {name => $_, macro => "TIME_HIRES_STAT", value => $d_hires_stat, + default => ["IV", "0"]}; + next; + } else { + $macro =~ s/^d_(.+)/HAS_\U$1/; + } + push @names, {name => $_, macro => $macro, value => 1, + default => ["IV", "0"]}; + } + ExtUtils::Constant::WriteConstants( + NAME => 'Time::HiRes', + NAMES => \@names, + ); + } else { + my $file; + foreach $file ('const-c.inc', 'const-xs.inc') { + my $fallback = File::Spec->catfile('fallback', $file); + local $/; + open IN, "<$fallback" or die "Can't open $fallback: $!"; + open OUT, ">$file" or die "Can't open $file: $!"; + print OUT <IN> or die $!; + close OUT or die "Can't close $file: $!"; + close IN or die "Can't close $fallback: $!"; + } + } +} + +sub main { + if (-f "Makefile" and -f "xdefine" && !(@ARGV && $ARGV[0] eq '--configure')) { + print qq[$0: The "xdefine" exists, skipping the configure step.\n]; + print qq[("$^X $0 --configure" to force the configure step)\n]; + } else { + print "Configuring Time::HiRes...\n"; + 1 while unlink("define"); + if ($^O =~ /Win32/i) { + DEFINE('SELECT_IS_BROKEN'); + $LIBS = []; + print "System is $^O, skipping full configure...\n"; + open(XDEFINE, ">xdefine") or die "$0: Cannot create xdefine: $!\n"; + close(XDEFINE); + } else { + init(); + } + doMakefile; + doConstants; + } + my $make = $Config{'make'} || "make"; + unless (exists $ENV{PERL_CORE} && $ENV{PERL_CORE}) { + print <<EOM; +Now you may issue '$make'. Do not forget also '$make test'. +EOM + if ($] == 5.008 && + ((exists $ENV{LC_ALL} && $ENV{LC_ALL} =~ /utf-?8/i) || + (exists $ENV{LC_CTYPE} && $ENV{LC_CTYPE} =~ /utf-?8/i) || + (exists $ENV{LANG} && $ENV{LANG} =~ /utf-?8/i))) { + print <<EOM; + +NOTE: if you get an error like this (the Makefile line number may vary): +Makefile:91: *** missing separator +then set the environment variable LC_ALL to "C" and retry +from scratch (re-run perl "Makefile.PL"). +(And consider upgrading your Perl to, say, at least Perl 5.8.8.) +(You got this message because you seem to have + an UTF-8 locale active in your shell environment, this used + to cause broken Makefiles to be created from Makefile.PLs) +EOM + } + } +} + +&main; + +# EOF diff --git a/ext/Time-HiRes/fallback/const-c.inc b/ext/Time-HiRes/fallback/const-c.inc new file mode 100644 index 0000000000..a8626172af --- /dev/null +++ b/ext/Time-HiRes/fallback/const-c.inc @@ -0,0 +1,393 @@ +#define PERL_constant_NOTFOUND 1 +#define PERL_constant_NOTDEF 2 +#define PERL_constant_ISIV 3 +#define PERL_constant_ISNO 4 +#define PERL_constant_ISNV 5 +#define PERL_constant_ISPV 6 +#define PERL_constant_ISPVN 7 +#define PERL_constant_ISSV 8 +#define PERL_constant_ISUNDEF 9 +#define PERL_constant_ISUV 10 +#define PERL_constant_ISYES 11 + +#ifndef NVTYPE +typedef double NV; /* 5.6 and later define NVTYPE, and typedef NV to it. */ +#endif +#ifndef aTHX_ +#define aTHX_ /* 5.6 or later define this for threading support. */ +#endif +#ifndef pTHX_ +#define pTHX_ /* 5.6 or later define this for threading support. */ +#endif +static int +constant_11 (pTHX_ const char *name, IV *iv_return) { + /* When generated this function returned values for the list of names given + here. However, subsequent manual editing may have added or removed some. + ITIMER_PROF ITIMER_REAL d_getitimer d_nanosleep d_setitimer */ + /* Offset 7 gives the best switch position. */ + switch (name[7]) { + case 'P': + if (memEQ(name, "ITIMER_PROF", 11)) { + /* ^ */ +#ifdef ITIMER_PROF + *iv_return = ITIMER_PROF; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'R': + if (memEQ(name, "ITIMER_REAL", 11)) { + /* ^ */ +#ifdef ITIMER_REAL + *iv_return = ITIMER_REAL; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'i': + if (memEQ(name, "d_getitimer", 11)) { + /* ^ */ +#ifdef HAS_GETITIMER + *iv_return = 1; + return PERL_constant_ISIV; +#else + *iv_return = 0; + return PERL_constant_ISIV; +#endif + } + if (memEQ(name, "d_setitimer", 11)) { + /* ^ */ +#ifdef HAS_SETITIMER + *iv_return = 1; + return PERL_constant_ISIV; +#else + *iv_return = 0; + return PERL_constant_ISIV; +#endif + } + break; + case 'l': + if (memEQ(name, "d_nanosleep", 11)) { + /* ^ */ +#ifdef TIME_HIRES_NANOSLEEP + *iv_return = 1; + return PERL_constant_ISIV; +#else + *iv_return = 0; + return PERL_constant_ISIV; +#endif + } + break; + } + return PERL_constant_NOTFOUND; +} + +static int +constant_14 (pTHX_ const char *name, IV *iv_return) { + /* When generated this function returned values for the list of names given + here. However, subsequent manual editing may have added or removed some. + CLOCKS_PER_SEC CLOCK_REALTIME CLOCK_SOFTTIME ITIMER_VIRTUAL d_clock_getres + d_gettimeofday */ + /* Offset 8 gives the best switch position. */ + switch (name[8]) { + case 'A': + if (memEQ(name, "CLOCK_REALTIME", 14)) { + /* ^ */ +#ifdef CLOCK_REALTIME + *iv_return = CLOCK_REALTIME; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'E': + if (memEQ(name, "CLOCKS_PER_SEC", 14)) { + /* ^ */ +#ifdef CLOCKS_PER_SEC + *iv_return = CLOCKS_PER_SEC; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'F': + if (memEQ(name, "CLOCK_SOFTTIME", 14)) { + /* ^ */ +#ifdef CLOCK_SOFTTIME + *iv_return = CLOCK_SOFTTIME; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'I': + if (memEQ(name, "ITIMER_VIRTUAL", 14)) { + /* ^ */ +#ifdef ITIMER_VIRTUAL + *iv_return = ITIMER_VIRTUAL; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'e': + if (memEQ(name, "d_gettimeofday", 14)) { + /* ^ */ +#ifdef HAS_GETTIMEOFDAY + *iv_return = 1; + return PERL_constant_ISIV; +#else + *iv_return = 0; + return PERL_constant_ISIV; +#endif + } + break; + case 'g': + if (memEQ(name, "d_clock_getres", 14)) { + /* ^ */ +#ifdef TIME_HIRES_CLOCK_GETRES + *iv_return = 1; + return PERL_constant_ISIV; +#else + *iv_return = 0; + return PERL_constant_ISIV; +#endif + } + break; + } + return PERL_constant_NOTFOUND; +} + +static int +constant_15 (pTHX_ const char *name, IV *iv_return) { + /* When generated this function returned values for the list of names given + here. However, subsequent manual editing may have added or removed some. + CLOCK_MONOTONIC CLOCK_TIMEOFDAY ITIMER_REALPROF d_clock_gettime */ + /* Offset 7 gives the best switch position. */ + switch (name[7]) { + case 'I': + if (memEQ(name, "CLOCK_TIMEOFDAY", 15)) { + /* ^ */ +#ifdef CLOCK_TIMEOFDAY + *iv_return = CLOCK_TIMEOFDAY; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'O': + if (memEQ(name, "CLOCK_MONOTONIC", 15)) { + /* ^ */ +#ifdef CLOCK_MONOTONIC + *iv_return = CLOCK_MONOTONIC; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'R': + if (memEQ(name, "ITIMER_REALPROF", 15)) { + /* ^ */ +#ifdef ITIMER_REALPROF + *iv_return = ITIMER_REALPROF; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case '_': + if (memEQ(name, "d_clock_gettime", 15)) { + /* ^ */ +#ifdef TIME_HIRES_CLOCK_GETTIME + *iv_return = 1; + return PERL_constant_ISIV; +#else + *iv_return = 0; + return PERL_constant_ISIV; +#endif + } + break; + } + return PERL_constant_NOTFOUND; +} + +static int +constant (pTHX_ const char *name, STRLEN len, IV *iv_return) { + /* Initially switch on the length of the name. */ + /* When generated this function returned values for the list of names given + in this section of perl code. Rather than manually editing these functions + to add or remove constants, which would result in this comment and section + of code becoming inaccurate, we recommend that you edit this section of + code, and use it to regenerate a new set of constant functions which you + then use to replace the originals. + + Regenerate these constant functions by feeding this entire source file to + perl -x + +#!perl -w +use ExtUtils::Constant qw (constant_types C_constant XS_constant); + +my $types = {map {($_, 1)} qw(IV)}; +my @names = (qw(CLOCKS_PER_SEC CLOCK_HIGHRES CLOCK_MONOTONIC + CLOCK_PROCESS_CPUTIME_ID CLOCK_REALTIME CLOCK_SOFTTIME + CLOCK_THREAD_CPUTIME_ID CLOCK_TIMEOFDAY ITIMER_PROF ITIMER_REAL + ITIMER_REALPROF ITIMER_VIRTUAL TIMER_ABSTIME), + {name=>"d_clock", type=>"IV", macro=>"TIME_HIRES_CLOCK", value=>"1", default=>["IV", "0"]}, + {name=>"d_clock_getres", type=>"IV", macro=>"TIME_HIRES_CLOCK_GETRES", value=>"1", default=>["IV", "0"]}, + {name=>"d_clock_gettime", type=>"IV", macro=>"TIME_HIRES_CLOCK_GETTIME", value=>"1", default=>["IV", "0"]}, + {name=>"d_clock_nanosleep", type=>"IV", macro=>"TIME_HIRES_CLOCK_NANOSLEEP", value=>"1", default=>["IV", "0"]}, + {name=>"d_getitimer", type=>"IV", macro=>"HAS_GETITIMER", value=>"1", default=>["IV", "0"]}, + {name=>"d_gettimeofday", type=>"IV", macro=>"HAS_GETTIMEOFDAY", value=>"1", default=>["IV", "0"]}, + {name=>"d_hires_stat", type=>"IV", macro=>"TIME_HIRES_STAT", value=>"1", default=>["IV", "0"]}, + {name=>"d_nanosleep", type=>"IV", macro=>"TIME_HIRES_NANOSLEEP", value=>"1", default=>["IV", "0"]}, + {name=>"d_setitimer", type=>"IV", macro=>"HAS_SETITIMER", value=>"1", default=>["IV", "0"]}, + {name=>"d_ualarm", type=>"IV", macro=>"HAS_UALARM", value=>"1", default=>["IV", "0"]}, + {name=>"d_usleep", type=>"IV", macro=>"HAS_USLEEP", value=>"1", default=>["IV", "0"]}); + +print constant_types(); # macro defs +foreach (C_constant ("Time::HiRes", 'constant', 'IV', $types, undef, 3, @names) ) { + print $_, "\n"; # C constant subs +} +print "#### XS Section:\n"; +print XS_constant ("Time::HiRes", $types); +__END__ + */ + + switch (len) { + case 7: + if (memEQ(name, "d_clock", 7)) { +#ifdef TIME_HIRES_CLOCK + *iv_return = 1; + return PERL_constant_ISIV; +#else + *iv_return = 0; + return PERL_constant_ISIV; +#endif + } + break; + case 8: + /* Names all of length 8. */ + /* d_ualarm d_usleep */ + /* Offset 7 gives the best switch position. */ + switch (name[7]) { + case 'm': + if (memEQ(name, "d_ualar", 7)) { + /* m */ +#ifdef HAS_UALARM + *iv_return = 1; + return PERL_constant_ISIV; +#else + *iv_return = 0; + return PERL_constant_ISIV; +#endif + } + break; + case 'p': + if (memEQ(name, "d_uslee", 7)) { + /* p */ +#ifdef HAS_USLEEP + *iv_return = 1; + return PERL_constant_ISIV; +#else + *iv_return = 0; + return PERL_constant_ISIV; +#endif + } + break; + } + break; + case 11: + return constant_11 (aTHX_ name, iv_return); + break; + case 12: + if (memEQ(name, "d_hires_stat", 12)) { +#ifdef TIME_HIRES_STAT + *iv_return = 1; + return PERL_constant_ISIV; +#else + *iv_return = 0; + return PERL_constant_ISIV; +#endif + } + break; + case 13: + /* Names all of length 13. */ + /* CLOCK_HIGHRES TIMER_ABSTIME */ + /* Offset 2 gives the best switch position. */ + switch (name[2]) { + case 'M': + if (memEQ(name, "TIMER_ABSTIME", 13)) { + /* ^ */ +#ifdef TIMER_ABSTIME + *iv_return = TIMER_ABSTIME; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'O': + if (memEQ(name, "CLOCK_HIGHRES", 13)) { + /* ^ */ +#ifdef CLOCK_HIGHRES + *iv_return = CLOCK_HIGHRES; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + } + break; + case 14: + return constant_14 (aTHX_ name, iv_return); + break; + case 15: + return constant_15 (aTHX_ name, iv_return); + break; + case 17: + if (memEQ(name, "d_clock_nanosleep", 17)) { +#ifdef TIME_HIRES_CLOCK_NANOSLEEP + *iv_return = 1; + return PERL_constant_ISIV; +#else + *iv_return = 0; + return PERL_constant_ISIV; +#endif + } + break; + case 23: + if (memEQ(name, "CLOCK_THREAD_CPUTIME_ID", 23)) { +#ifdef CLOCK_THREAD_CPUTIME_ID + *iv_return = CLOCK_THREAD_CPUTIME_ID; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 24: + if (memEQ(name, "CLOCK_PROCESS_CPUTIME_ID", 24)) { +#ifdef CLOCK_PROCESS_CPUTIME_ID + *iv_return = CLOCK_PROCESS_CPUTIME_ID; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + } + return PERL_constant_NOTFOUND; +} + diff --git a/ext/Time-HiRes/fallback/const-xs.inc b/ext/Time-HiRes/fallback/const-xs.inc new file mode 100644 index 0000000000..c84dd051dd --- /dev/null +++ b/ext/Time-HiRes/fallback/const-xs.inc @@ -0,0 +1,88 @@ +void +constant(sv) + PREINIT: +#ifdef dXSTARG + dXSTARG; /* Faster if we have it. */ +#else + dTARGET; +#endif + STRLEN len; + int type; + IV iv; + /* NV nv; Uncomment this if you need to return NVs */ + /* const char *pv; Uncomment this if you need to return PVs */ + INPUT: + SV * sv; + const char * s = SvPV(sv, len); + PPCODE: + /* Change this to constant(aTHX_ s, len, &iv, &nv); + if you need to return both NVs and IVs */ + type = constant(aTHX_ s, len, &iv); + /* Return 1 or 2 items. First is error message, or undef if no error. + Second, if present, is found value */ + switch (type) { + case PERL_constant_NOTFOUND: + sv = sv_2mortal(newSVpvf("%s is not a valid Time::HiRes macro", s)); + PUSHs(sv); + break; + case PERL_constant_NOTDEF: + sv = sv_2mortal(newSVpvf( + "Your vendor has not defined Time::HiRes macro %s, used", s)); + PUSHs(sv); + break; + case PERL_constant_ISIV: + EXTEND(SP, 1); + PUSHs(&PL_sv_undef); + PUSHi(iv); + break; + /* Uncomment this if you need to return NOs + case PERL_constant_ISNO: + EXTEND(SP, 1); + PUSHs(&PL_sv_undef); + PUSHs(&PL_sv_no); + break; */ + /* Uncomment this if you need to return NVs + case PERL_constant_ISNV: + EXTEND(SP, 1); + PUSHs(&PL_sv_undef); + PUSHn(nv); + break; */ + /* Uncomment this if you need to return PVs + case PERL_constant_ISPV: + EXTEND(SP, 1); + PUSHs(&PL_sv_undef); + PUSHp(pv, strlen(pv)); + break; */ + /* Uncomment this if you need to return PVNs + case PERL_constant_ISPVN: + EXTEND(SP, 1); + PUSHs(&PL_sv_undef); + PUSHp(pv, iv); + break; */ + /* Uncomment this if you need to return SVs + case PERL_constant_ISSV: + EXTEND(SP, 1); + PUSHs(&PL_sv_undef); + PUSHs(sv); + break; */ + /* Uncomment this if you need to return UNDEFs + case PERL_constant_ISUNDEF: + break; */ + /* Uncomment this if you need to return UVs + case PERL_constant_ISUV: + EXTEND(SP, 1); + PUSHs(&PL_sv_undef); + PUSHu((UV)iv); + break; */ + /* Uncomment this if you need to return YESs + case PERL_constant_ISYES: + EXTEND(SP, 1); + PUSHs(&PL_sv_undef); + PUSHs(&PL_sv_yes); + break; */ + default: + sv = sv_2mortal(newSVpvf( + "Unexpected return type %d while processing Time::HiRes macro %s, used", + type, s)); + PUSHs(sv); + } diff --git a/ext/Time-HiRes/hints/aix.pl b/ext/Time-HiRes/hints/aix.pl new file mode 100644 index 0000000000..bbb7fa8342 --- /dev/null +++ b/ext/Time-HiRes/hints/aix.pl @@ -0,0 +1,18 @@ +# Many AIX installations seem not to have the right PATH +# for the C compiler. Steal the logic from Perl's hints/aix.sh. +use Config; +unless ($Config{gccversion}) { + my $cc = $Config{cc}; + if (! -x $cc && -x "/usr/vac/bin/$cc") { + unless (":$ENV{PATH}:" =~ m{:/usr/vac/bin:}) { + die <<__EOE__; +*** +*** You either implicitly or explicitly specified an IBM C compiler, +*** but you do not seem to have one in /usr/bin, but you seem to have +*** the VAC installed in /usr/vac, but you do not have the /usr/vac/bin +*** in your PATH. I suggest adding that and retrying Makefile.PL. +*** +__EOE__ + } + } +} diff --git a/ext/Time-HiRes/hints/dec_osf.pl b/ext/Time-HiRes/hints/dec_osf.pl new file mode 100644 index 0000000000..b19d149e70 --- /dev/null +++ b/ext/Time-HiRes/hints/dec_osf.pl @@ -0,0 +1,3 @@ +# needs to explicitly link against librt to pull in nanosleep +$self->{LIBS} = ['-lrt']; + diff --git a/ext/Time-HiRes/hints/dynixptx.pl b/ext/Time-HiRes/hints/dynixptx.pl new file mode 100644 index 0000000000..0a1e5db38f --- /dev/null +++ b/ext/Time-HiRes/hints/dynixptx.pl @@ -0,0 +1,5 @@ +# uname -v +# V4.5.2 +# needs to explicitly link against libc to pull in usleep +$self->{LIBS} = ['-lc']; + diff --git a/ext/Time-HiRes/hints/irix.pl b/ext/Time-HiRes/hints/irix.pl new file mode 100644 index 0000000000..83d98bcab6 --- /dev/null +++ b/ext/Time-HiRes/hints/irix.pl @@ -0,0 +1,6 @@ +use Config; +if ($Config{osvers} == 5) { + $self->{CCFLAGS} = $Config{ccflags}; + $self->{CCFLAGS} =~ s/-ansiposix //; + $self->{CCFLAGS} =~ s/-D_POSIX_SOURCE /-D_POSIX_4SOURCE /; +} diff --git a/ext/Time-HiRes/hints/linux.pl b/ext/Time-HiRes/hints/linux.pl new file mode 100644 index 0000000000..84ce5221b1 --- /dev/null +++ b/ext/Time-HiRes/hints/linux.pl @@ -0,0 +1,2 @@ +# needs to explicitly link against librt to pull in clock_nanosleep +$self->{LIBS} = ['-lrt']; diff --git a/ext/Time-HiRes/hints/sco.pl b/ext/Time-HiRes/hints/sco.pl new file mode 100644 index 0000000000..22f2764347 --- /dev/null +++ b/ext/Time-HiRes/hints/sco.pl @@ -0,0 +1,4 @@ +# osr5 needs to explicitly link against libc to pull in usleep +# what's the reason for -lm? +$self->{LIBS} = ['-lm', '-lc']; + diff --git a/ext/Time-HiRes/hints/solaris.pl b/ext/Time-HiRes/hints/solaris.pl new file mode 100644 index 0000000000..6cc80e7bc5 --- /dev/null +++ b/ext/Time-HiRes/hints/solaris.pl @@ -0,0 +1,10 @@ +# 2.6 has nanosleep in -lposix4, after that it's in -lrt +my $r = `/usr/bin/uname -r`; +chomp($r); +if (substr($r, 2) <= 6) { + $self->{LIBS} = ['-lposix4']; +} else { + $self->{LIBS} = ['-lrt']; +} + + diff --git a/ext/Time-HiRes/hints/svr4.pl b/ext/Time-HiRes/hints/svr4.pl new file mode 100644 index 0000000000..75128724f2 --- /dev/null +++ b/ext/Time-HiRes/hints/svr4.pl @@ -0,0 +1,4 @@ +# NCR MP-RAS needs to explicitly link against libc to pull in usleep +# what's the reason for -lm? +$self->{LIBS} = ['-lm', '-lc']; + diff --git a/ext/Time-HiRes/t/HiRes.t b/ext/Time-HiRes/t/HiRes.t new file mode 100644 index 0000000000..373c328d0a --- /dev/null +++ b/ext/Time-HiRes/t/HiRes.t @@ -0,0 +1,783 @@ +#!./perl -w + +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + if (" $Config{'extensions'} " !~ m[ Time/HiRes ]) { + print "1..0 # Skip -- Perl configured without Time::HiRes module\n"; + exit 0; + } + } +} + +BEGIN { $| = 1; print "1..40\n"; } + +END { print "not ok 1\n" unless $loaded } + +use Time::HiRes 1.9704; # Remember to bump this once in a while. +use Time::HiRes qw(tv_interval); + +$loaded = 1; + +print "ok 1\n"; + +use strict; + +my $have_gettimeofday = &Time::HiRes::d_gettimeofday; +my $have_usleep = &Time::HiRes::d_usleep; +my $have_nanosleep = &Time::HiRes::d_nanosleep; +my $have_ualarm = &Time::HiRes::d_ualarm; +my $have_clock_gettime = &Time::HiRes::d_clock_gettime; +my $have_clock_getres = &Time::HiRes::d_clock_getres; +my $have_clock_nanosleep = &Time::HiRes::d_clock_nanosleep; +my $have_clock = &Time::HiRes::d_clock; +my $have_hires_stat = &Time::HiRes::d_hires_stat; + +sub has_symbol { + my $symbol = shift; + eval "use Time::HiRes qw($symbol)"; + return 0 unless $@ eq ''; + eval "my \$a = $symbol"; + return $@ eq ''; +} + +printf "# have_gettimeofday = %d\n", $have_gettimeofday; +printf "# have_usleep = %d\n", $have_usleep; +printf "# have_nanosleep = %d\n", $have_nanosleep; +printf "# have_ualarm = %d\n", $have_ualarm; +printf "# have_clock_gettime = %d\n", $have_clock_gettime; +printf "# have_clock_getres = %d\n", $have_clock_getres; +printf "# have_clock_nanosleep = %d\n", $have_clock_nanosleep; +printf "# have_clock = %d\n", $have_clock; +printf "# have_hires_stat = %d\n", $have_hires_stat; + +import Time::HiRes 'gettimeofday' if $have_gettimeofday; +import Time::HiRes 'usleep' if $have_usleep; +import Time::HiRes 'nanosleep' if $have_nanosleep; +import Time::HiRes 'ualarm' if $have_ualarm; +import Time::HiRes 'clock_gettime' if $have_clock_gettime; +import Time::HiRes 'clock_getres' if $have_clock_getres; +import Time::HiRes 'clock_nanosleep' if $have_clock_nanosleep; +import Time::HiRes 'clock' if $have_clock; + +use Config; + +use Time::HiRes qw(gettimeofday); + +my $have_alarm = $Config{d_alarm}; +my $have_fork = $Config{d_fork}; +my $waitfor = 360; # 30-45 seconds is normal (load affects this). +my $timer_pid; +my $TheEnd; + +if ($have_fork) { + print "# I am the main process $$, starting the timer process...\n"; + $timer_pid = fork(); + if (defined $timer_pid) { + if ($timer_pid == 0) { # We are the kid, set up the timer. + my $ppid = getppid(); + print "# I am the timer process $$, sleeping for $waitfor seconds...\n"; + sleep($waitfor - 2); # Workaround for perlbug #49073 + sleep(2); # Wait for parent to exit + if (kill(0, $ppid)) { # Check if parent still exists + warn "\n$0: overall time allowed for tests (${waitfor}s) exceeded!\n"; + print "# Terminating main process $ppid...\n"; + kill('KILL', $ppid); + print "# This is the timer process $$, over and out.\n"; + } + exit(0); + } else { + print "# The timer process $timer_pid launched, continuing testing...\n"; + $TheEnd = time() + $waitfor; + } + } else { + warn "$0: fork failed: $!\n"; + } +} else { + print "# No timer process (need fork)\n"; +} + +my $xdefine = ''; + +if (open(XDEFINE, "xdefine")) { + chomp($xdefine = <XDEFINE>); + close(XDEFINE); +} + +# Ideally, we'd like to test that the timers are rather precise. +# However, if the system is busy, there are no guarantees on how +# quickly we will return. This limit used to be 10%, but that +# was occasionally triggered falsely. +# So let's try 25%. +# Another possibility might be to print "ok" if the test completes fine +# with (say) 10% slosh, "skip - system may have been busy?" if the test +# completes fine with (say) 30% slosh, and fail otherwise. If you do that, +# consider changing over to test.pl at the same time. +# --A.D., Nov 27, 2001 +my $limit = 0.25; # 25% is acceptable slosh for testing timers + +sub skip { + map { print "ok $_ # skipped\n" } @_; +} + +sub ok { + my ($n, $result, @info) = @_; + if ($result) { + print "ok $n\n"; + } + else { + print "not ok $n\n"; + print "# @info\n" if @info; + } +} + +unless ($have_gettimeofday) { + skip 2..6; +} +else { + my @one = gettimeofday(); + ok 2, @one == 2, 'gettimeofday returned ', 0+@one, ' args'; + ok 3, $one[0] > 850_000_000, "@one too small"; + + sleep 1; + + my @two = gettimeofday(); + ok 4, ($two[0] > $one[0] || ($two[0] == $one[0] && $two[1] > $one[1])), + "@two is not greater than @one"; + + my $f = Time::HiRes::time(); + ok 5, $f > 850_000_000, "$f too small"; + ok 6, $f - $two[0] < 2, "$f - $two[0] >= 2"; +} + +unless ($have_usleep) { + skip 7..8; +} +else { + use Time::HiRes qw(usleep); + my $one = time; + usleep(10_000); + my $two = time; + usleep(10_000); + my $three = time; + ok 7, $one == $two || $two == $three, "slept too long, $one $two $three"; + + unless ($have_gettimeofday) { + skip 8; + } + else { + my $f = Time::HiRes::time(); + usleep(500_000); + my $f2 = Time::HiRes::time(); + my $d = $f2 - $f; + ok 8, $d > 0.4 && $d < 0.9, "slept $d secs $f to $f2"; + } +} + +# Two-arg tv_interval() is always available. +{ + my $f = tv_interval [5, 100_000], [10, 500_000]; + ok 9, abs($f - 5.4) < 0.001, $f; +} + +unless ($have_gettimeofday) { + skip 10; +} +else { + my $r = [gettimeofday()]; + my $f = tv_interval $r; + ok 10, $f < 2, $f; +} + +unless ($have_usleep && $have_gettimeofday) { + skip 11; +} +else { + my $r = [ gettimeofday() ]; + Time::HiRes::sleep( 0.5 ); + my $f = tv_interval $r; + ok 11, $f > 0.4 && $f < 0.9, "slept $f instead of 0.5 secs."; +} + +unless ($have_ualarm && $have_alarm) { + skip 12..13; +} +else { + my $tick = 0; + local $SIG{ ALRM } = sub { $tick++ }; + + my $one = time; $tick = 0; ualarm(10_000); while ($tick == 0) { } + my $two = time; $tick = 0; ualarm(10_000); while ($tick == 0) { } + my $three = time; + ok 12, $one == $two || $two == $three, "slept too long, $one $two $three"; + print "# tick = $tick, one = $one, two = $two, three = $three\n"; + + $tick = 0; ualarm(10_000, 10_000); while ($tick < 3) { } + ok 13, 1; + ualarm(0); + print "# tick = $tick, one = $one, two = $two, three = $three\n"; +} + +# Did we even get close? + +unless ($have_gettimeofday) { + skip 14; +} else { + my ($s, $n, $i) = (0); + for $i (1 .. 100) { + $s += Time::HiRes::time() - time(); + $n++; + } + # $s should be, at worst, equal to $n + # (time() may be rounding down, up, or closest), + # but allow 10% of slop. + ok 14, abs($s) / $n <= 1.10, "Time::HiRes::time() not close to time()"; + print "# s = $s, n = $n, s/n = ", abs($s)/$n, "\n"; +} + +my $has_ualarm = $Config{d_ualarm}; + +$has_ualarm ||= $xdefine =~ /-DHAS_UALARM/; + +my $can_subsecond_alarm = + defined &Time::HiRes::gettimeofday && + defined &Time::HiRes::ualarm && + defined &Time::HiRes::usleep && + $has_ualarm; + +unless ($can_subsecond_alarm) { + for (15..17) { + print "ok $_ # Skip: no gettimeofday or no ualarm or no usleep\n"; + } +} else { + use Time::HiRes qw(time alarm sleep); + eval { require POSIX }; + my $use_sigaction = + !$@ && defined &POSIX::sigaction && &POSIX::SIGALRM > 0; + + my ($f, $r, $i, $not, $ok); + + $f = time; + print "# time...$f\n"; + print "ok 15\n"; + + $r = [Time::HiRes::gettimeofday()]; + sleep (0.5); + print "# sleep...", Time::HiRes::tv_interval($r), "\nok 16\n"; + + $r = [Time::HiRes::gettimeofday()]; + $i = 5; + my $oldaction; + if ($use_sigaction) { + $oldaction = new POSIX::SigAction; + printf "# sigaction tick, ALRM = %d\n", &POSIX::SIGALRM; + + # Perl's deferred signals may be too wimpy to break through + # a restartable select(), so use POSIX::sigaction if available. + + POSIX::sigaction(&POSIX::SIGALRM, + POSIX::SigAction->new("tick"), + $oldaction) + or die "Error setting SIGALRM handler with sigaction: $!\n"; + } else { + print "# SIG tick\n"; + $SIG{ALRM} = "tick"; + } + + # On VMS timers can not interrupt select. + if ($^O eq 'VMS') { + $ok = "Skip: VMS select() does not get interrupted."; + } else { + while ($i > 0) { + alarm(0.3); + select (undef, undef, undef, 3); + my $ival = Time::HiRes::tv_interval ($r); + print "# Select returned! $i $ival\n"; + print "# ", abs($ival/3 - 1), "\n"; + # Whether select() gets restarted after signals is + # implementation dependent. If it is restarted, we + # will get about 3.3 seconds: 3 from the select, 0.3 + # from the alarm. If this happens, let's just skip + # this particular test. --jhi + if (abs($ival/3.3 - 1) < $limit) { + $ok = "Skip: your select() may get restarted by your SIGALRM (or just retry test)"; + undef $not; + last; + } + my $exp = 0.3 * (5 - $i); + if ($exp == 0) { + $not = "while: divisor became zero"; + last; + } + # This test is more sensitive, so impose a softer limit. + if (abs($ival/$exp - 1) > 4*$limit) { + my $ratio = abs($ival/$exp); + $not = "while: $exp sleep took $ival ratio $ratio"; + last; + } + $ok = $i; + } + } + + sub tick { + $i--; + my $ival = Time::HiRes::tv_interval ($r); + print "# Tick! $i $ival\n"; + my $exp = 0.3 * (5 - $i); + if ($exp == 0) { + $not = "tick: divisor became zero"; + last; + } + # This test is more sensitive, so impose a softer limit. + if (abs($ival/$exp - 1) > 4*$limit) { + my $ratio = abs($ival/$exp); + $not = "tick: $exp sleep took $ival ratio $ratio"; + $i = 0; + } + } + + if ($use_sigaction) { + POSIX::sigaction(&POSIX::SIGALRM, $oldaction); + } else { + alarm(0); # can't cancel usig %SIG + } + + print $not ? "not ok 17 # $not\n" : "ok 17 # $ok\n"; +} + +unless (defined &Time::HiRes::setitimer + && defined &Time::HiRes::getitimer + && has_symbol('ITIMER_VIRTUAL') + && $Config{sig_name} =~ m/\bVTALRM\b/ + && $^O ne 'nto' # nto: QNX 6 has the API but no implementation + && $^O ne 'haiku' # haiku: has the API but no implementation + ) { + for (18..19) { + print "ok $_ # Skip: no virtual interval timers\n"; + } +} else { + use Time::HiRes qw(setitimer getitimer ITIMER_VIRTUAL); + + my $i = 3; + my $r = [Time::HiRes::gettimeofday()]; + + $SIG{VTALRM} = sub { + $i ? $i-- : setitimer(&ITIMER_VIRTUAL, 0); + print "# Tick! $i ", Time::HiRes::tv_interval($r), "\n"; + }; + + print "# setitimer: ", join(" ", setitimer(ITIMER_VIRTUAL, 0.5, 0.4)), "\n"; + + # Assume interval timer granularity of $limit * 0.5 seconds. Too bold? + my $virt = getitimer(&ITIMER_VIRTUAL); + print "not " unless defined $virt && abs($virt / 0.5) - 1 < $limit; + print "ok 18\n"; + + print "# getitimer: ", join(" ", getitimer(ITIMER_VIRTUAL)), "\n"; + + while (getitimer(&ITIMER_VIRTUAL)) { + my $j; + for (1..1000) { $j++ } # Can't be unbreakable, must test getitimer(). + } + + print "# getitimer: ", join(" ", getitimer(ITIMER_VIRTUAL)), "\n"; + + $virt = getitimer(&ITIMER_VIRTUAL); + print "not " unless defined $virt && $virt == 0; + print "ok 19\n"; + + $SIG{VTALRM} = 'DEFAULT'; +} + +if ($have_gettimeofday && + $have_usleep) { + use Time::HiRes qw(usleep); + + my ($t0, $td); + + my $sleep = 1.5; # seconds + my $msg; + + $t0 = gettimeofday(); + $a = abs(sleep($sleep) / $sleep - 1.0); + $td = gettimeofday() - $t0; + my $ratio = 1.0 + $a; + + $msg = "$td went by while sleeping $sleep, ratio $ratio.\n"; + + if ($td < $sleep * (1 + $limit)) { + print $a < $limit ? "ok 20 # $msg" : "not ok 20 # $msg"; + } else { + print "ok 20 # Skip: $msg"; + } + + $t0 = gettimeofday(); + $a = abs(usleep($sleep * 1E6) / ($sleep * 1E6) - 1.0); + $td = gettimeofday() - $t0; + $ratio = 1.0 + $a; + + $msg = "$td went by while sleeping $sleep, ratio $ratio.\n"; + + if ($td < $sleep * (1 + $limit)) { + print $a < $limit ? "ok 21 # $msg" : "not ok 21 # $msg"; + } else { + print "ok 21 # Skip: $msg"; + } + +} else { + for (20..21) { + print "ok $_ # Skip: no gettimeofday\n"; + } +} + +unless ($have_nanosleep) { + skip 22..23; +} +else { + my $one = CORE::time; + nanosleep(10_000_000); + my $two = CORE::time; + nanosleep(10_000_000); + my $three = CORE::time; + ok 22, $one == $two || $two == $three, "slept too long, $one $two $three"; + + unless ($have_gettimeofday) { + skip 23; + } + else { + my $f = Time::HiRes::time(); + nanosleep(500_000_000); + my $f2 = Time::HiRes::time(); + my $d = $f2 - $f; + ok 23, $d > 0.4 && $d < 0.9, "slept $d secs $f to $f2"; + } +} + +eval { sleep(-1) }; +print $@ =~ /::sleep\(-1\): negative time not invented yet/ ? + "ok 24\n" : "not ok 24\n"; + +eval { usleep(-2) }; +print $@ =~ /::usleep\(-2\): negative time not invented yet/ ? + "ok 25\n" : "not ok 25\n"; + +if ($have_ualarm) { + eval { alarm(-3) }; + print $@ =~ /::alarm\(-3, 0\): negative time not invented yet/ ? + "ok 26\n" : "not ok 26\n"; + + eval { ualarm(-4) }; + print $@ =~ /::ualarm\(-4, 0\): negative time not invented yet/ ? + "ok 27\n" : "not ok 27\n"; +} else { + skip 26; + skip 27; +} + +if ($have_nanosleep) { + eval { nanosleep(-5) }; + print $@ =~ /::nanosleep\(-5\): negative time not invented yet/ ? + "ok 28\n" : "not ok 28\n"; +} else { + skip 28; +} + +# Find the loop size N (a for() loop 0..N-1) +# that will take more than T seconds. + +if ($have_ualarm && $] >= 5.008001) { + # http://groups.google.com/group/perl.perl5.porters/browse_thread/thread/adaffaaf939b042e/20dafc298df737f0%2320dafc298df737f0?sa=X&oi=groupsr&start=0&num=3 + # Perl changes [18765] and [18770], perl bug [perl #20920] + + print "# Finding delay loop...\n"; + + my $T = 0.01; + use Time::HiRes qw(time); + my $DelayN = 1024; + my $i; + N: { + do { + my $t0 = time(); + for ($i = 0; $i < $DelayN; $i++) { } + my $t1 = time(); + my $dt = $t1 - $t0; + print "# N = $DelayN, t1 = $t1, t0 = $t0, dt = $dt\n"; + last N if $dt > $T; + $DelayN *= 2; + } while (1); + } + + # The time-burner which takes at least T (default 1) seconds. + my $Delay = sub { + my $c = @_ ? shift : 1; + my $n = $c * $DelayN; + my $i; + for ($i = 0; $i < $n; $i++) { } + }; + + # Next setup a periodic timer (the two-argument alarm() of + # Time::HiRes, behind the curtains the libc getitimer() or + # ualarm()) which has a signal handler that takes so much time (on + # the first initial invocation) that the first periodic invocation + # (second invocation) will happen before the first invocation has + # finished. In Perl 5.8.0 the "safe signals" concept was + # implemented, with unfortunately at least one bug that caused a + # core dump on reentering the handler. This bug was fixed by the + # time of Perl 5.8.1. + + # Do not try mixing sleep() and alarm() for testing this. + + my $a = 0; # Number of alarms we receive. + my $A = 2; # Number of alarms we will handle before disarming. + # (We may well get $A + 1 alarms.) + + $SIG{ALRM} = sub { + $a++; + print "# Alarm $a - ", time(), "\n"; + alarm(0) if $a >= $A; # Disarm the alarm. + $Delay->(2); # Try burning CPU at least for 2T seconds. + }; + + use Time::HiRes qw(alarm); + alarm($T, $T); # Arm the alarm. + + $Delay->(10); # Try burning CPU at least for 10T seconds. + + print "ok 29\n"; # Not core dumping by now is considered to be the success. +} else { + skip 29; +} + +if ($have_clock_gettime && + # All implementations of clock_gettime() + # are SUPPOSED TO support CLOCK_REALTIME. + has_symbol('CLOCK_REALTIME')) { + my $ok = 0; + TRY: { + for my $try (1..3) { + print "# CLOCK_REALTIME: try = $try\n"; + my $t0 = clock_gettime(&CLOCK_REALTIME); + use Time::HiRes qw(sleep); + my $T = 1.5; + sleep($T); + my $t1 = clock_gettime(&CLOCK_REALTIME); + if ($t0 > 0 && $t1 > $t0) { + print "# t1 = $t1, t0 = $t0\n"; + my $dt = $t1 - $t0; + my $rt = abs(1 - $dt / $T); + print "# dt = $dt, rt = $rt\n"; + if ($rt <= 2 * $limit) { + $ok = 1; + last TRY; + } + } else { + print "# Error: t0 = $t0, t1 = $t1\n"; + } + my $r = rand() + rand(); + printf "# Sleeping for %.6f seconds...\n", $r; + sleep($r); + } + } + if ($ok) { + print "ok 30\n"; + } else { + print "not ok 30\n"; + } +} else { + print "# No clock_gettime\n"; + skip 30; +} + +if ($have_clock_getres) { + my $tr = clock_getres(); + if ($tr > 0) { + print "ok 31 # tr = $tr\n"; + } else { + print "not ok 31 # tr = $tr\n"; + } +} else { + print "# No clock_getres\n"; + skip 31; +} + +if ($have_clock_nanosleep && + has_symbol('CLOCK_REALTIME')) { + my $s = 1.5e9; + my $t = clock_nanosleep(&CLOCK_REALTIME, $s); + my $r = abs(1 - $t / $s); + if ($r < 2 * $limit) { + print "ok 32\n"; + } else { + print "not ok 32 # $t = $t, r = $r\n"; + } +} else { + print "# No clock_nanosleep\n"; + skip 32; +} + +if ($have_clock) { + my @clock = clock(); + print "# clock = @clock\n"; + for my $i (1..3) { + for (my $j = 0; $j < 1e6; $j++) { } + push @clock, clock(); + print "# clock = @clock\n"; + } + if ($clock[0] >= 0 && + $clock[1] > $clock[0] && + $clock[2] > $clock[1] && + $clock[3] > $clock[2]) { + print "ok 33\n"; + } else { + print "not ok 33\n"; + } +} else { + skip 33; +} + +sub bellish { # Cheap emulation of a bell curve. + my ($min, $max) = @_; + my $rand = ($max - $min) / 5; + my $sum = 0; + for my $i (0..4) { + $sum += rand($rand); + } + return $min + $sum; +} + +if ($have_ualarm) { + # 1_100_000 sligthly over 1_000_000, + # 2_200_000 slightly over 2**31/1000, + # 4_300_000 slightly over 2**32/1000. + for my $t ([34, 100_000], + [35, 1_100_000], + [36, 2_200_000], + [37, 4_300_000]) { + my ($i, $n) = @$t; + my $ok; + for my $retry (1..10) { + my $alarmed = 0; + local $SIG{ ALRM } = sub { $alarmed++ }; + my $t0 = Time::HiRes::time(); + print "# t0 = $t0\n"; + print "# ualarm($n)\n"; + ualarm($n); 1 while $alarmed == 0; + my $t1 = Time::HiRes::time(); + print "# t1 = $t1\n"; + my $dt = $t1 - $t0; + print "# dt = $dt\n"; + my $r = $dt / ($n/1e6); + print "# r = $r\n"; + $ok = + ($n < 1_000_000 || # Too much noise. + ($r >= 0.8 && $r <= 1.6)); + last if $ok; + my $nap = bellish(3, 15); + printf "# Retrying in %.1f seconds...\n", $nap; + Time::HiRes::sleep($nap); + } + ok $i, $ok, "ualarm($n) close enough"; + } +} else { + print "# No ualarm\n"; + skip 34..37; +} + +if ($^O =~ /^(cygwin|MSWin)/) { + print "# $^O: timestamps may not be good enough\n"; + skip 38; +} elsif (&Time::HiRes::d_hires_stat) { + my @stat; + my @atime; + my @mtime; + for (1..5) { + Time::HiRes::sleep(rand(0.1) + 0.1); + open(X, ">$$"); + print X $$; + close(X); + @stat = Time::HiRes::stat($$); + push @mtime, $stat[9]; + Time::HiRes::sleep(rand(0.1) + 0.1); + open(X, "<$$"); + <X>; + close(X); + @stat = Time::HiRes::stat($$); + push @atime, $stat[8]; + } + 1 while unlink $$; + print "# mtime = @mtime\n"; + print "# atime = @atime\n"; + my $ai = 0; + my $mi = 0; + my $ss = 0; + for (my $i = 1; $i < @atime; $i++) { + if ($atime[$i] >= $atime[$i-1]) { + $ai++; + } + if ($atime[$i] > int($atime[$i])) { + $ss++; + } + } + for (my $i = 1; $i < @mtime; $i++) { + if ($mtime[$i] >= $mtime[$i-1]) { + $mi++; + } + if ($mtime[$i] > int($mtime[$i])) { + $ss++; + } + } + print "# ai = $ai, mi = $mi, ss = $ss\n"; + # Need at least 75% of monotonical increase and + # 20% of subsecond results. Yes, this is guessing. + if ($ss == 0) { + print "# No subsecond timestamps detected\n"; + skip 38; + } elsif ($mi/(@mtime-1) >= 0.75 && $ai/(@atime-1) >= 0.75 && + $ss/(@mtime+@atime) >= 0.2) { + print "ok 38\n"; + } else { + print "not ok 38\n"; + } +} else { + print "# No effectual d_hires_stat\n"; + skip 38; +} + +unless ($can_subsecond_alarm) { + skip 39..40; +} else { + { + my $alrm; + $SIG{ALRM} = sub { $alrm++ }; + Time::HiRes::alarm(0.1); + my $t0 = time(); + 1 while time() - $t0 <= 1; + print $alrm ? "ok 39\n" : "not ok 39\n"; + } + { + my $alrm; + $SIG{ALRM} = sub { $alrm++ }; + Time::HiRes::alarm(1.1); + my $t0 = time(); + 1 while time() - $t0 <= 2; + print $alrm ? "ok 40\n" : "not ok 40\n"; + } +} + +END { + if ($timer_pid) { # Only in the main process. + my $left = $TheEnd - time(); + printf "# I am the main process $$, terminating the timer process $timer_pid\n# before it terminates me in %d seconds (testing took %d seconds).\n", $left, $waitfor - $left; + if (kill(0, $timer_pid)) { + local $? = 0; + my $kill = kill('KILL', $timer_pid); # We are done, the timer can go. + wait(); + printf "# kill KILL $timer_pid = %d\n", $kill; + } + unlink("ktrace.out"); # Used in BSD system call tracing. + print "# All done.\n"; + } +} + diff --git a/ext/Time-HiRes/typemap b/ext/Time-HiRes/typemap new file mode 100644 index 0000000000..1124eb6483 --- /dev/null +++ b/ext/Time-HiRes/typemap @@ -0,0 +1,313 @@ +# basic C types +int T_IV +unsigned T_UV +unsigned int T_UV +long T_IV +unsigned long T_UV +short T_IV +unsigned short T_UV +char T_CHAR +unsigned char T_U_CHAR +char * T_PV +unsigned char * T_PV +const char * T_PV +caddr_t T_PV +wchar_t * T_PV +wchar_t T_IV +bool_t T_IV +size_t T_UV +ssize_t T_IV +time_t T_NV +unsigned long * T_OPAQUEPTR +char ** T_PACKEDARRAY +void * T_PTR +Time_t * T_PV +SV * T_SV +SVREF T_SVREF +AV * T_AVREF +HV * T_HVREF +CV * T_CVREF + +IV T_IV +UV T_UV +NV T_NV +I32 T_IV +I16 T_IV +I8 T_IV +STRLEN T_UV +U32 T_U_LONG +U16 T_U_SHORT +U8 T_UV +Result T_U_CHAR +Boolean T_BOOL +float T_FLOAT +double T_DOUBLE +SysRet T_SYSRET +SysRetLong T_SYSRET +FILE * T_STDIO +PerlIO * T_INOUT +FileHandle T_PTROBJ +InputStream T_IN +InOutStream T_INOUT +OutputStream T_OUT +bool T_BOOL + +############################################################################# +INPUT +T_SV + $var = $arg +T_SVREF + if (SvROK($arg)) + $var = (SV*)SvRV($arg); + else + Perl_croak(aTHX_ \"$var is not a reference\") +T_AVREF + if (SvROK($arg) && SvTYPE(SvRV($arg))==SVt_PVAV) + $var = (AV*)SvRV($arg); + else + Perl_croak(aTHX_ \"$var is not an array reference\") +T_HVREF + if (SvROK($arg) && SvTYPE(SvRV($arg))==SVt_PVHV) + $var = (HV*)SvRV($arg); + else + Perl_croak(aTHX_ \"$var is not a hash reference\") +T_CVREF + if (SvROK($arg) && SvTYPE(SvRV($arg))==SVt_PVCV) + $var = (CV*)SvRV($arg); + else + Perl_croak(aTHX_ \"$var is not a code reference\") +T_SYSRET + $var NOT IMPLEMENTED +T_UV + $var = ($type)SvUV($arg) +T_IV + $var = ($type)SvIV($arg) +T_INT + $var = (int)SvIV($arg) +T_ENUM + $var = ($type)SvIV($arg) +T_BOOL + $var = (bool)SvTRUE($arg) +T_U_INT + $var = (unsigned int)SvUV($arg) +T_SHORT + $var = (short)SvIV($arg) +T_U_SHORT + $var = (unsigned short)SvUV($arg) +T_LONG + $var = (long)SvIV($arg) +T_U_LONG + $var = (unsigned long)SvUV($arg) +T_CHAR + $var = (char)*SvPV_nolen($arg) +T_U_CHAR + $var = (unsigned char)SvUV($arg) +T_FLOAT + $var = (float)SvNV($arg) +T_NV + $var = ($type)SvNV($arg) +T_DOUBLE + $var = (double)SvNV($arg) +T_PV + $var = ($type)SvPV_nolen($arg) +T_PTR + $var = INT2PTR($type,SvIV($arg)) +T_PTRREF + if (SvROK($arg)) { + IV tmp = SvIV((SV*)SvRV($arg)); + $var = INT2PTR($type,tmp); + } + else + Perl_croak(aTHX_ \"$var is not a reference\") +T_REF_IV_REF + if (sv_isa($arg, \"${ntype}\")) { + IV tmp = SvIV((SV*)SvRV($arg)); + $var = *INT2PTR($type *, tmp); + } + else + Perl_croak(aTHX_ \"$var is not of type ${ntype}\") +T_REF_IV_PTR + if (sv_isa($arg, \"${ntype}\")) { + IV tmp = SvIV((SV*)SvRV($arg)); + $var = INT2PTR($type, tmp); + } + else + Perl_croak(aTHX_ \"$var is not of type ${ntype}\") +T_PTROBJ + if (sv_derived_from($arg, \"${ntype}\")) { + IV tmp = SvIV((SV*)SvRV($arg)); + $var = INT2PTR($type,tmp); + } + else + Perl_croak(aTHX_ \"$var is not of type ${ntype}\") +T_PTRDESC + if (sv_isa($arg, \"${ntype}\")) { + IV tmp = SvIV((SV*)SvRV($arg)); + ${type}_desc = (\U${type}_DESC\E*) tmp; + $var = ${type}_desc->ptr; + } + else + Perl_croak(aTHX_ \"$var is not of type ${ntype}\") +T_REFREF + if (SvROK($arg)) { + IV tmp = SvIV((SV*)SvRV($arg)); + $var = *INT2PTR($type,tmp); + } + else + Perl_croak(aTHX_ \"$var is not a reference\") +T_REFOBJ + if (sv_isa($arg, \"${ntype}\")) { + IV tmp = SvIV((SV*)SvRV($arg)); + $var = *INT2PTR($type,tmp); + } + else + Perl_croak(aTHX_ \"$var is not of type ${ntype}\") +T_OPAQUE + $var = *($type *)SvPV_nolen($arg) +T_OPAQUEPTR + $var = ($type)SvPV_nolen($arg) +T_PACKED + $var = XS_unpack_$ntype($arg) +T_PACKEDARRAY + $var = XS_unpack_$ntype($arg) +T_CALLBACK + $var = make_perl_cb_$type($arg) +T_ARRAY + U32 ix_$var = $argoff; + $var = $ntype(items -= $argoff); + while (items--) { + DO_ARRAY_ELEM; + ix_$var++; + } + /* this is the number of elements in the array */ + ix_$var -= $argoff +T_STDIO + $var = PerlIO_findFILE(IoIFP(sv_2io($arg))) +T_IN + $var = IoIFP(sv_2io($arg)) +T_INOUT + $var = IoIFP(sv_2io($arg)) +T_OUT + $var = IoOFP(sv_2io($arg)) +############################################################################# +OUTPUT +T_SV + $arg = $var; +T_SVREF + $arg = newRV((SV*)$var); +T_AVREF + $arg = newRV((SV*)$var); +T_HVREF + $arg = newRV((SV*)$var); +T_CVREF + $arg = newRV((SV*)$var); +T_IV + sv_setiv($arg, (IV)$var); +T_UV + sv_setuv($arg, (UV)$var); +T_INT + sv_setiv($arg, (IV)$var); +T_SYSRET + if ($var != -1) { + if ($var == 0) + sv_setpvn($arg, "0 but true", 10); + else + sv_setiv($arg, (IV)$var); + } +T_ENUM + sv_setiv($arg, (IV)$var); +T_BOOL + $arg = boolSV($var); +T_U_INT + sv_setuv($arg, (UV)$var); +T_SHORT + sv_setiv($arg, (IV)$var); +T_U_SHORT + sv_setuv($arg, (UV)$var); +T_LONG + sv_setiv($arg, (IV)$var); +T_U_LONG + sv_setuv($arg, (UV)$var); +T_CHAR + sv_setpvn($arg, (char *)&$var, 1); +T_U_CHAR + sv_setuv($arg, (UV)$var); +T_FLOAT + sv_setnv($arg, (double)$var); +T_NV + sv_setnv($arg, (NV)$var); +T_DOUBLE + sv_setnv($arg, (double)$var); +T_PV + sv_setpv((SV*)$arg, $var); +T_PTR + sv_setiv($arg, PTR2IV($var)); +T_PTRREF + sv_setref_pv($arg, Nullch, (void*)$var); +T_REF_IV_REF + sv_setref_pv($arg, \"${ntype}\", (void*)new $ntype($var)); +T_REF_IV_PTR + sv_setref_pv($arg, \"${ntype}\", (void*)$var); +T_PTROBJ + sv_setref_pv($arg, \"${ntype}\", (void*)$var); +T_PTRDESC + sv_setref_pv($arg, \"${ntype}\", (void*)new\U${type}_DESC\E($var)); +T_REFREF + NOT_IMPLEMENTED +T_REFOBJ + NOT IMPLEMENTED +T_OPAQUE + sv_setpvn($arg, (char *)&$var, sizeof($var)); +T_OPAQUEPTR + sv_setpvn($arg, (char *)$var, sizeof(*$var)); +T_PACKED + XS_pack_$ntype($arg, $var); +T_PACKEDARRAY + XS_pack_$ntype($arg, $var, count_$ntype); +T_DATAUNIT + sv_setpvn($arg, $var.chp(), $var.size()); +T_CALLBACK + sv_setpvn($arg, $var.context.value().chp(), + $var.context.value().size()); +T_ARRAY + { + U32 ix_$var; + EXTEND(SP,size_$var); + for (ix_$var = 0; ix_$var < size_$var; ix_$var++) { + ST(ix_$var) = sv_newmortal(); + DO_ARRAY_ELEM + } + } +T_STDIO + { + GV *gv = newGVgen("$Package"); + PerlIO *fp = PerlIO_importFILE($var,0); + if ( fp && do_open(gv, "+<&", 3, FALSE, 0, 0, fp) ) + sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); + else + $arg = &PL_sv_undef; + } +T_IN + { + GV *gv = newGVgen("$Package"); + if ( do_open(gv, "<&", 2, FALSE, 0, 0, $var) ) + sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); + else + $arg = &PL_sv_undef; + } +T_INOUT + { + GV *gv = newGVgen("$Package"); + if ( do_open(gv, "+<&", 3, FALSE, 0, 0, $var) ) + sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); + else + $arg = &PL_sv_undef; + } +T_OUT + { + GV *gv = newGVgen("$Package"); + if ( do_open(gv, "+>&", 3, FALSE, 0, 0, $var) ) + sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); + else + $arg = &PL_sv_undef; + } |