diff options
| author | Nicholas Clark <nick@ccl4.org> | 2009-10-02 17:12:07 +0100 |
|---|---|---|
| committer | Nicholas Clark <nick@ccl4.org> | 2009-10-02 17:12:07 +0100 |
| commit | a9ddcb5ded01c01d3a9c527d5ad650f8a5a0c91a (patch) | |
| tree | d0f8a97e5e3fcc96e5f155bb0bbbd0d1514f0a50 /ext | |
| parent | a03926b2cd3c47c0a9631ed10568cfe6401527f1 (diff) | |
| download | perl-a9ddcb5ded01c01d3a9c527d5ad650f8a5a0c91a.tar.gz | |
Move Time::HiRes from ext/ to cpan/
Diffstat (limited to 'ext')
| -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, 0 insertions, 5244 deletions
diff --git a/ext/Time-HiRes/.gitignore b/ext/Time-HiRes/.gitignore deleted file mode 100644 index a89cf3eadf..0000000000 --- a/ext/Time-HiRes/.gitignore +++ /dev/null @@ -1,2 +0,0 @@ -*.inc -/xdefine diff --git a/ext/Time-HiRes/Changes b/ext/Time-HiRes/Changes deleted file mode 100644 index ffec191c1e..0000000000 --- a/ext/Time-HiRes/Changes +++ /dev/null @@ -1,886 +0,0 @@ -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 deleted file mode 100644 index da4d45a96e..0000000000 --- a/ext/Time-HiRes/HiRes.pm +++ /dev/null @@ -1,591 +0,0 @@ -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 deleted file mode 100644 index 69eee69333..0000000000 --- a/ext/Time-HiRes/HiRes.xs +++ /dev/null @@ -1,1257 +0,0 @@ -/* - * - * 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 deleted file mode 100644 index c44199835f..0000000000 --- a/ext/Time-HiRes/Makefile.PL +++ /dev/null @@ -1,879 +0,0 @@ -#!/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 deleted file mode 100644 index a8626172af..0000000000 --- a/ext/Time-HiRes/fallback/const-c.inc +++ /dev/null @@ -1,393 +0,0 @@ -#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 deleted file mode 100644 index c84dd051dd..0000000000 --- a/ext/Time-HiRes/fallback/const-xs.inc +++ /dev/null @@ -1,88 +0,0 @@ -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 deleted file mode 100644 index bbb7fa8342..0000000000 --- a/ext/Time-HiRes/hints/aix.pl +++ /dev/null @@ -1,18 +0,0 @@ -# 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 deleted file mode 100644 index b19d149e70..0000000000 --- a/ext/Time-HiRes/hints/dec_osf.pl +++ /dev/null @@ -1,3 +0,0 @@ -# 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 deleted file mode 100644 index 0a1e5db38f..0000000000 --- a/ext/Time-HiRes/hints/dynixptx.pl +++ /dev/null @@ -1,5 +0,0 @@ -# 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 deleted file mode 100644 index 83d98bcab6..0000000000 --- a/ext/Time-HiRes/hints/irix.pl +++ /dev/null @@ -1,6 +0,0 @@ -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 deleted file mode 100644 index 84ce5221b1..0000000000 --- a/ext/Time-HiRes/hints/linux.pl +++ /dev/null @@ -1,2 +0,0 @@ -# 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 deleted file mode 100644 index 22f2764347..0000000000 --- a/ext/Time-HiRes/hints/sco.pl +++ /dev/null @@ -1,4 +0,0 @@ -# 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 deleted file mode 100644 index 6cc80e7bc5..0000000000 --- a/ext/Time-HiRes/hints/solaris.pl +++ /dev/null @@ -1,10 +0,0 @@ -# 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 deleted file mode 100644 index 75128724f2..0000000000 --- a/ext/Time-HiRes/hints/svr4.pl +++ /dev/null @@ -1,4 +0,0 @@ -# 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 deleted file mode 100644 index 373c328d0a..0000000000 --- a/ext/Time-HiRes/t/HiRes.t +++ /dev/null @@ -1,783 +0,0 @@ -#!./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 deleted file mode 100644 index 1124eb6483..0000000000 --- a/ext/Time-HiRes/typemap +++ /dev/null @@ -1,313 +0,0 @@ -# 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; - } |