From 3f2ee0069d15f7a7d413167c0ad86d1545e6b534 Mon Sep 17 00:00:00 2001 From: Hugo van der Sanden Date: Sun, 20 Oct 2002 13:23:16 +0000 Subject: Update to Time::HiRes v1.38 p4raw-id: //depot/perl@18034 --- ext/Time/HiRes/Changes | 166 +++++++++++++++++- ext/Time/HiRes/HiRes.pm | 113 ++++++------- ext/Time/HiRes/HiRes.t | 40 +++-- ext/Time/HiRes/HiRes.xs | 170 ++++++++++++++----- ext/Time/HiRes/Makefile.PL | 408 ++++++++++++++++++++++++++++++++++++++++++++- ext/Time/HiRes/typemap | 313 ++++++++++++++++++++++++++++++++++ 6 files changed, 1082 insertions(+), 128 deletions(-) create mode 100644 ext/Time/HiRes/typemap (limited to 'ext') diff --git a/ext/Time/HiRes/Changes b/ext/Time/HiRes/Changes index 16fc02782f..3ba982d67f 100644 --- a/ext/Time/HiRes/Changes +++ b/ext/Time/HiRes/Changes @@ -1,5 +1,165 @@ Revision history for Perl extension Time::HiRes. +1.38 + - 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 + - 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 + - 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 + - small documentation tweaks + + +1.34 + - better VMS operation (Craig Berry) + +1.33 + - 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 + - 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 + - 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.30 + + - release 1.29_02 as 1.30 + +1.29_02 + + - fix a silly unclosed comment typo in HiRes.xs + - document and export REALTIME_REALPROF (Solaris) + +1.29_01 + + - 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 + + 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 subecond 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 @@ -7,7 +167,7 @@ Revision history for Perl extension Time::HiRes. Ilya Zakharevich - add C API stuff. From Joshua Pritikin - - VMS Makefile.PL fun. From pvhp@forte.com (Peter Prymmer) + - VMS Makefile.PL fun. From pvhp@forte.com (Peter Prymmer) - hopefully correct "-lc" fix for SCO. - add PPD stuff @@ -32,9 +192,9 @@ Revision history for Perl extension Time::HiRes. 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 + - 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 + - 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 diff --git a/ext/Time/HiRes/HiRes.pm b/ext/Time/HiRes/HiRes.pm index 6337532040..9886138b53 100644 --- a/ext/Time/HiRes/HiRes.pm +++ b/ext/Time/HiRes/HiRes.pm @@ -4,15 +4,18 @@ use strict; use vars qw($VERSION $XS_VERSION @ISA @EXPORT @EXPORT_OK $AUTOLOAD); require Exporter; -use XSLoader; +require DynaLoader; -@ISA = qw(Exporter); +@ISA = qw(Exporter DynaLoader); @EXPORT = qw( ); @EXPORT_OK = qw (usleep sleep ualarm alarm gettimeofday time tv_interval - getitimer setitimer ITIMER_REAL ITIMER_VIRTUAL ITIMER_PROF); - -$VERSION = '1.20_00'; + getitimer setitimer + ITIMER_REAL ITIMER_VIRTUAL ITIMER_PROF ITIMER_REALPROF + d_usleep d_ualarm d_gettimeofday d_getitimer d_setitimer + d_nanosleep); + +$VERSION = '1.38'; $XS_VERSION = $VERSION; $VERSION = eval $VERSION; @@ -31,7 +34,7 @@ sub AUTOLOAD { goto &$AUTOLOAD; } -XSLoader::load 'Time::HiRes', $XS_VERSION; +bootstrap Time::HiRes; # Preloaded methods go here. @@ -75,7 +78,7 @@ Time::HiRes - High resolution alarm, sleep, gettimeofday, interval timers alarm ($floating_seconds, $floating_interval); use Time::HiRes qw( setitimer getitimer - ITIMER_REAL ITIMER_VIRTUAL ITIMER_PROF ); + ITIMER_REAL ITIMER_VIRTUAL ITIMER_PROF ITIMER_REALPROF ); setitimer ($which, $floating_seconds, $floating_interval ); getitimer ($which); @@ -85,15 +88,28 @@ Time::HiRes - High resolution alarm, sleep, gettimeofday, interval timers The C module implements a Perl interface to the usleep, ualarm, gettimeofday, and setitimer/getitimer system calls. See the EXAMPLES section below and the test scripts for usage; see your system -documentation for the description of the underlying usleep, ualarm, -gettimeofday, and setitimer/getitimer calls. +documentation for the description of the underlying nanosleep or usleep, +ualarm, gettimeofday, and setitimer/getitimer calls. If your system lacks gettimeofday(2) or an emulation of it you don't -get gettimeofday() or the one-arg form of tv_interval(). -If you don't have usleep(3) or select(2) you don't get usleep() +get gettimeofday() or the one-arg form of tv_interval(). If you don't +have nanosleep() or usleep(3) or select(2) you don't get Time::HiRes::usleep() or sleep(). If your system don't have ualarm(3) or setitimer(2) you -don't get ualarm() or alarm(). If you try to import an unimplemented -function in the C statement it will fail at compile time. +don't get Time::HiRes::ualarm() or alarm(). + +If you try to import an unimplemented function in the C statement +it will fail at compile time. + +If your subsecond sleeping is implemented with nanosleep() instead of +usleep(), you can mix subsecond sleeping with signals since +nanosleep() does not use signals. This, however, is unportable +behavior, and you should first check for the truth value of +C<&Time::HiRes::d_nanosleep> to see whether you have nanosleep, +and then read carefully your nanosleep() C API documentation for +any peculiarities. (There is no separate interface to call nanosleep(); +just use Time::HiRes::sleep() or usleep() with small enough values. Also, +think twice whether using nanosecond accuracies in a Perl program is what +you should be doing.) The following functions can be imported from this module. No functions are exported by default. @@ -160,12 +176,18 @@ provided with perl, see the EXAMPLES below. =item alarm ( $floating_seconds [, $interval_floating_seconds ] ) -The SIGALRM signal is sent after the specfified number of seconds. +The SIGALRM signal is sent after the specified number of seconds. Implemented using ualarm(). The $interval_floating_seconds argument is optional and will be 0 if unspecified, resulting in alarm()-like behaviour. This function can be imported, resulting in a nice drop-in replacement for the C provided with perl, see the EXAMPLES below. +B: With some platform - Perl release combinations select() +gets restarted by SIGALRM, instead of dropping out of select(). +This means that an alarm() followed by a select() may together take +the sum of the times specified for the the alarm() and the select(), +not just the time of the alarm(). + =item setitimer C @@ -183,8 +205,12 @@ 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 three interval timers: the $which can be ITIMER_REAL, -ITIMER_VIRTUAL, or ITIMER_PROF. +There are usually three or four interval timers available: the $which +can be ITIMER_REAL, ITIMER_VIRTUAL, ITIMER_PROF, or ITIMER_REALPROF. +Note that which ones are available depends: true UNIX platforms have +usually all first three, but for example Win32 and Cygwin only have +ITIMER_REAL, and only Solaris seems to have ITIMER_REALPROF (which is +used to profile multithreaded programs). ITIMER_REAL results in alarm()-like behavior. Time is counted in I, that is, wallclock time. SIGALRM is delivered when @@ -300,58 +326,13 @@ R. Schertler J. Hietaniemi G. Aas -=head1 REVISION - -$Id: HiRes.pm,v 1.20 1999/03/16 02:26:13 wegscd Exp $ - -$Log: HiRes.pm,v $ -Revision 1.20 1999/03/16 02:26:13 wegscd -Add documentation for NVTime and U2Time. - -Revision 1.19 1998/09/30 02:34:42 wegscd -No changes, bump version. - -Revision 1.18 1998/07/07 02:41:35 wegscd -No changes, bump version. - -Revision 1.17 1998/07/02 01:45:13 wegscd -Bump version to 1.17 - -Revision 1.16 1997/11/13 02:06:36 wegscd -version bump to accomodate HiRes.xs fix. - -Revision 1.15 1997/11/11 02:17:59 wegscd -POD editing, courtesy of Gisle Aas. - -Revision 1.14 1997/11/06 03:14:35 wegscd -Update version # for Makefile.PL and HiRes.xs changes. - -Revision 1.13 1997/11/05 05:36:25 wegscd -change version # for Makefile.pl and HiRes.xs changes. - -Revision 1.12 1997/10/13 20:55:33 wegscd -Force a new version for Makefile.PL changes. - -Revision 1.11 1997/09/05 19:59:33 wegscd -New version to bump version for README and Makefile.PL fixes. -Fix bad RCS log. - -Revision 1.10 1997/05/23 01:11:38 wegscd -Conditional compilation; EXPORT_FAIL fixes. - -Revision 1.2 1996/12/30 13:28:40 wegscd -Update documentation for what to do when missing ualarm() and friends. - -Revision 1.1 1996/10/17 20:53:31 wegscd -Fix =head1 being next to __END__ so pod2man works +=head1 COPYRIGHT AND LICENSE -Revision 1.0 1996/09/03 18:25:15 wegscd -Initial revision +Copyright (c) 1996-2002 Douglas E. Wegscheid. All rights reserved. -=head1 COPYRIGHT +Copyright (c) 2002 Jarkko Hietaniemi. All rights reserved. -Copyright (c) 1996-1997 Douglas E. Wegscheid. -All rights reserved. This program is free software; you can -redistribute it and/or modify it under the same terms as Perl itself. +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.t b/ext/Time/HiRes/HiRes.t index 8a50f5029c..1cc2c7666c 100644 --- a/ext/Time/HiRes/HiRes.t +++ b/ext/Time/HiRes/HiRes.t @@ -1,8 +1,10 @@ #!./perl -w BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = '../lib'; + } } BEGIN { $| = 1; print "1..25\n"; } @@ -28,6 +30,13 @@ import Time::HiRes 'ualarm' if $have_ualarm; use Config; +my $xdefine; + +if (open(XDEFINE, "xdefine")) { + chomp($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 @@ -41,7 +50,7 @@ use Config; my $limit = 0.20; # 20% is acceptable slosh for testing timers sub skip { - map { print "ok $_ (skipped)\n" } @_; + map { print "ok $_ # skipped\n" } @_; } sub ok { @@ -130,14 +139,14 @@ else { my $tick = 0; local $SIG{ALRM} = sub { $tick++ }; - my $one = time; $tick = 0; ualarm(10_000); sleep until $tick; - my $two = time; $tick = 0; ualarm(10_000); sleep until $tick; + my $one = time; $tick = 0; ualarm(10_000); while ($tick == 0) { sleep } + my $two = time; $tick = 0; ualarm(10_000); while ($tick == 0) { sleep } my $three = time; ok 12, $one == $two || $two == $three, "slept too long, $one $two $three"; $tick = 0; ualarm(10_000, 10_000); - sleep until $tick >= 3; + while ($tick < 3) { sleep } ok 13, 1; ualarm(0); } @@ -158,12 +167,16 @@ if (!$have_time) { print "# s = $s, n = $n, s/n = ", $s/$n, "\n"; } -unless (defined &Time::HiRes::gettimeofday +my $has_ualarm = $Config{d_ualarm}; + +$has_ualarm ||= $xdefine =~ /-DHAS_UALARM/; + +unless ( defined &Time::HiRes::gettimeofday && defined &Time::HiRes::ualarm && defined &Time::HiRes::usleep - && $Config{d_ualarm}) { + && $has_ualarm) { for (15..17) { - print "ok $_ # skipped\n"; + print "ok $_ # Skip: no gettimeofday or no ualarm or no usleep\n"; } } else { use Time::HiRes qw (time alarm sleep); @@ -194,7 +207,7 @@ unless (defined &Time::HiRes::gettimeofday # 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() seems to get restarted by your SIGALRM"; + $ok = "Skip: your select() may get restarted by your SIGALRM (or just retry test)"; undef $not; last; } @@ -227,9 +240,9 @@ unless (defined &Time::HiRes::gettimeofday print $not ? "not ok 17 # $not\n" : "ok 17 # $ok\n"; } -unless (defined &Time::HiRes::setitimer +unless ( defined &Time::HiRes::setitimer && defined &Time::HiRes::getitimer - && exists &Time::HiRes::ITIMER_VIRTUAL + && eval 'Time::HiRes::ITIMER_VIRTUAL' && $Config{d_select} && $Config{sig_name} =~ m/\bVTALRM\b/) { for (18..19) { @@ -255,7 +268,8 @@ unless (defined &Time::HiRes::setitimer print "# getitimer: ", join(" ", getitimer(ITIMER_VIRTUAL)), "\n"; while (getitimer(ITIMER_VIRTUAL)) { - my $j; $j++ for 1..1000; # Can't be unbreakable, must test getitimer(). + my $j; + for (1..1000) { $j++ } # Can't be unbreakable, must test getitimer(). } print "# getitimer: ", join(" ", getitimer(ITIMER_VIRTUAL)), "\n"; diff --git a/ext/Time/HiRes/HiRes.xs b/ext/Time/HiRes/HiRes.xs index c66b92db08..5da54c6d19 100644 --- a/ext/Time/HiRes/HiRes.xs +++ b/ext/Time/HiRes/HiRes.xs @@ -18,11 +18,123 @@ extern "C" { } #endif +#ifndef aTHX_ +# define aTHX_ +# define pTHX_ +#endif + +#ifndef NVTYPE +# if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) +# define NVTYPE long double +# else +# define NVTYPE double +# endif +typedef NVTYPE NV; +#endif + +#ifndef IVdf +# ifdef IVSIZE +# if IVSIZE == LONGSIZE +# define IVdf "ld" +# else +# if IVSIZE == INTSIZE +# define IVdf "d" +# endif +# endif +# else +# define IVdf "ld" +# endif +#endif + +#ifndef NVef +# if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) && \ + defined(PERL_PRIgldbl) /* Not very likely, but let's try anyway. */ +# define NVgf PERL_PRIgldbl +# else +# define NVgf "g" +# endif +#endif + +#ifndef INT2PTR + +#if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE) +# define PTRV UV +# define INT2PTR(any,d) (any)(d) +#else +# if PTRSIZE == LONGSIZE +# define PTRV unsigned long +# else +# define PTRV unsigned +# endif +# define INT2PTR(any,d) (any)(PTRV)(d) +#endif +#define PTR2IV(p) INT2PTR(IV,p) + +#endif /* !INT2PTR */ + +#ifndef SvPV_nolen +static char * +sv_2pv_nolen(pTHX_ register SV *sv) +{ + STRLEN n_a; + return sv_2pv(sv, &n_a); +} +# define SvPV_nolen(sv) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? SvPVX(sv) : sv_2pv_nolen(sv)) +#endif + +#ifndef PerlProc_pause +# define PerlProc_pause() Pause() +#endif + +/* Though the cpp define ITIMER_VIRTUAL is available the functionality + * is not supported in Cygwin as of August 2002, 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 + static IV constant(char *name, int arg) { errno = 0; switch (*name) { + case 'd': + if (strEQ(name, "d_getitimer")) +#ifdef HAS_GETITIMER + return 1; +#else + return 0; +#endif + if (strEQ(name, "d_nanosleep")) +#ifdef HAS_NANOSLEEP + return 1; +#else + return 0; +#endif + if (strEQ(name, "d_setitimer")) +#ifdef HAS_SETITIMER + return 1; +#else + return 0; +#endif + if (strEQ(name, "d_ualarm")) +#ifdef HAS_UALARM + return 1; +#else + return 0; +#endif + if (strEQ(name, "d_usleep")) +#ifdef HAS_USLEEP + return 1; +#else + return 0; +#endif + break; case 'I': if (strEQ(name, "ITIMER_REAL")) #ifdef ITIMER_REAL @@ -287,6 +399,22 @@ gettimeofday (struct timeval *tp, void *tpz) } #endif + +#if !defined(HAS_USLEEP) && defined(HAS_NANOSLEEP) +#define HAS_USLEEP +#define usleep hrt_nanosleep /* could conflict with ncurses for static build */ + +void +hrt_nanosleep(unsigned long usec) +{ + struct timespec res; + res.tv_sec = usec/1000/1000; + res.tv_nsec = ( usec - res.tv_sec*1000*1000 ) * 1000; + nanosleep(&res, NULL); +} +#endif + + #if !defined(HAS_USLEEP) && defined(HAS_SELECT) #ifndef SELECT_IS_BROKEN #define HAS_USLEEP @@ -531,8 +659,6 @@ ualarm_AST(Alarm *a) #endif /* !HAS_UALARM && VMS */ - - #ifdef HAS_GETTIMEOFDAY static int @@ -562,6 +688,7 @@ MODULE = Time::HiRes PACKAGE = Time::HiRes PROTOTYPES: ENABLE BOOT: +#ifdef ATLEASTFIVEOHOHFIVE #ifdef HAS_GETTIMEOFDAY { UV auv[2]; @@ -570,6 +697,7 @@ BOOT: hv_store(PL_modglobal, "Time::U2time", 12, newSViv((IV) auv[0]), 0); } #endif +#endif IV constant(name, arg) @@ -779,41 +907,3 @@ getitimer(which) #endif -# $Id: HiRes.xs,v 1.11 1999/03/16 02:27:38 wegscd Exp wegscd $ - -# $Log: HiRes.xs,v $ -# Revision 1.11 1999/03/16 02:27:38 wegscd -# Add U2time, NVtime. Fix symbols for static link. -# -# Revision 1.10 1998/09/30 02:36:25 wegscd -# Add VMS changes. -# -# Revision 1.9 1998/07/07 02:42:06 wegscd -# Win32 usleep() -# -# Revision 1.8 1998/07/02 01:47:26 wegscd -# Add Win32 code for gettimeofday. -# -# Revision 1.7 1997/11/13 02:08:12 wegscd -# Add missing EXTEND in gettimeofday() scalar code. -# -# Revision 1.6 1997/11/11 02:32:35 wegscd -# Do something useful when calling gettimeofday() in a scalar context. -# The patch is courtesy of Gisle Aas. -# -# Revision 1.5 1997/11/06 03:10:47 wegscd -# Fake ualarm() if we have setitimer. -# -# Revision 1.4 1997/11/05 05:41:23 wegscd -# Turn prototypes ON (suggested by Gisle Aas) -# -# Revision 1.3 1997/10/13 20:56:15 wegscd -# Add PROTOTYPES: DISABLE -# -# Revision 1.2 1997/05/23 01:01:38 wegscd -# Conditional compilation, depending on what the OS gives us. -# -# Revision 1.1 1996/09/03 18:26:35 wegscd -# Initial revision -# -# diff --git a/ext/Time/HiRes/Makefile.PL b/ext/Time/HiRes/Makefile.PL index b7c6459162..ea8b85f993 100644 --- a/ext/Time/HiRes/Makefile.PL +++ b/ext/Time/HiRes/Makefile.PL @@ -1,13 +1,409 @@ + # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. # -use strict; +require 5.002; + +use Config; use ExtUtils::MakeMaker; -WriteMakefile( - 'NAME' => 'Time::HiRes', - MAN3PODS => {}, # Pods will be built by installman. - 'VERSION_FROM' => 'HiRes.pm', -); +# Perls 5.002 and 5.003 did not have File::Spec, fake what we need. + +my $VERBOSE = $ENV{VERBOSE}; + +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' ? "[$dirsep]" : $dirsep; +} + +sub my_updir { + shift; + $^O eq 'VMS' ? "-" : ".."; +} + +BEGIN { + eval { require File::Spec }; + if ($@) { + *File::Spec::catdir = \&my_catdir; + *File::Spec::updir = \&my_updir; + } +} + +# 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 TMPDIR { + my $TMPDIR = + (grep(defined $_ && -d $_ && -w _, + ((defined $ENV{'TMPDIR'} ? $ENV{'TMPDIR'} : undef), + qw(/var/tmp /usr/tmp /tmp))))[0] + unless defined $TMPDIR; + $TMPDIR || die "Cannot find writable temporary directory.\n"; +} + +sub try_compile_and_link { + my ($c, %args) = @_; + + my ($ok) = 0; + my ($tmp) = (($^O eq 'VMS') ? "sys\$scratch:tmp$$" : TMPDIR . '/' . "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); + + $cccmd = $args{cccmd}; + + my $errornull; + + my $COREincdir; + if ($ENV{PERL_CORE}) { + my $updir = File::Spec->updir; + $COREincdir = File::Spec->catdir(($updir) x 3); + } else { + $COREincdir = File::Spec->catdir($Config{'archlibexp'}, 'CORE'); + } + my $ccflags = $Config{'ccflags'} . ' ' . "-I$COREincdir"; + if ($^O eq 'VMS') { + if ($ENV{PERL_CORE}) { + $cccmd = "$Config{'cc'} /include=(perl_root:[000000]) $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 + { + printf "cccmd = $cccmd\n" if $VERBOSE; + system($cccmd); + $ok = -s $tmp && -x _; + unlink("$tmp.c", $tmp); + } + } + + $ok; +} + +sub has_gettimeofday { + # confusing but true (if condition true ==> -DHAS_GETTIMEOFDAY already) + return 0 if $Config{'d_gettimeod'} eq 'define'; + return 1 if try_compile_and_link(< +#endif + +#ifdef I_SYS_TIME +# include +#endif + +#ifdef I_SYS_SELECT +# include /* struct timeval might be hidden in here */ +#endif +static int foo() +{ + struct timeval tv; + gettimeofday(&tv, 0); +} +int main _((int argc, char** argv, char** env)) +{ + foo(); +} +EOM + return 0; +} + +sub has_x { + my ($x, %args) = @_; + + return 1 if + try_compile_and_link(< +#endif + +#ifdef I_SYS_TYPES +# include +#endif + +#ifdef I_SYS_TIME +# include +#endif + +int main _((int argc, char** argv, char** env)) +{ + $x; +} +EOM + return 0; +} + +sub unixinit { + $DEFINE = ''; + + $LIBS = []; + + # this might break the link, try it if it can't find some things you + # honestly think should be in there... + # $LIBS = ['-lucb -lbsd']; + + # ... but ucb is poison for Solaris, and probably Linux. honest. + $LIBS = [] if $Config{'osname'} eq 'solaris'; + $LIBS = [] if $Config{'osname'} eq 'linux'; + $LIBS = ['-lm'] if $Config{'osname'} =~ /sco/i; + $LIBS = ['-lc'] if $Config{'osname'} =~ /dynixptx/i; + + # For nanosleep + push @$LIBS, '-lrt' unless $Config{'osname'} =~ /irix/; + push @$LIBS, '-lposix4' ; + + my @goodlibs; + + select(STDOUT); $| = 1; + + print "Checking for libraries...\n"; + my $lib; + for $lib (@$LIBS) { + print "Checking for $lib...\n"; + $LIBS = [ $lib ]; + if ($Config{libs} =~ /\b$lib\b/ || has_x("time(0)")) { + push @goodlibs, $lib; + } + } + @$LIBS = @goodlibs; + print @$LIBS ? + "You have extra libraries: @$LIBS.\n" : + "You have no applicable extra libraries.\n"; + print "\n"; + + print "Looking for gettimeofday()...\n"; + my $has_gettimeofday; + if ($Config{'d_gettimeod'}) { + $has_gettimeofday++; + } elsif (has_gettimeofday()) { + $DEFINE .= ' -DHAS_GETTIMEOFDAY'; + $has_gettimeofday++; + } + + if ($has_gettimeofday) { + print "You have gettimeofday().\n\n"; + } else { + die <xdefine")) { + print XDEFINE $DEFINE, "\n"; + close(XDEFINE); + } + } +} + +sub doMakefile { + @makefileopts = (); + + if ($] >= 5.005) { + push (@makefileopts, + 'AUTHOR' => 'Jarkko Hietaniemi ', + 'ABSTRACT_FROM' => 'HiRes.pm', + ); + $DEFINE .= " -DATLEASTFIVEOHOHFIVE"; + } + + 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' => 'perl', + 'dist' => { + 'CI' => 'ci -l', + 'COMPRESS' => 'gzip -9f', + 'SUFFIX' => 'gz', + }, + clean => { FILES => "xdefine" }, + ); + + WriteMakefile(@makefileopts); +} + +sub main { + print <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; + } -- cgit v1.2.1