diff options
| author | Ricardo Signes <rjbs@cpan.org> | 2016-02-08 16:20:58 -0500 |
|---|---|---|
| committer | Ricardo Signes <rjbs@cpan.org> | 2016-02-08 19:02:37 -0500 |
| commit | 91ba54d4eff96de92a378e0a8244218e8fe89bea (patch) | |
| tree | ebafcea0c323971df841c8260a0ac6cd8aaa2c6f /cpan | |
| parent | 84279daf2591f1fa128c1c258e8010ca25930fb3 (diff) | |
| download | perl-91ba54d4eff96de92a378e0a8244218e8fe89bea.tar.gz | |
move Time-HiRes from cpan to dist
Diffstat (limited to 'cpan')
26 files changed, 0 insertions, 4565 deletions
diff --git a/cpan/Time-HiRes/HiRes.pm b/cpan/Time-HiRes/HiRes.pm deleted file mode 100644 index 843d586961..0000000000 --- a/cpan/Time-HiRes/HiRes.pm +++ /dev/null @@ -1,603 +0,0 @@ -package Time::HiRes; - -{ use 5.006; } -use strict; - -require Exporter; -require DynaLoader; - -our @ISA = qw(Exporter DynaLoader); - -our @EXPORT = qw( ); -our @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 lstat - ); - -our $VERSION = '1.9728'; -our $XS_VERSION = $VERSION; -$VERSION = eval $VERSION; - -our $AUTOLOAD; -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 lstat ); - - 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 lstat ); - - my @stat = stat("file"); - my @stat = stat(FH); - my @stat = lstat("file"); - -=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 surprised -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 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 have interval 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 - -=item lstat - -=item lstat FH - -=item lstat EXPR - -As L<perlfunc/stat> or L<perlfunc/lstat> -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 likewise for lstat), -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_gettime(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 NV (*)() - 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: - - NV (*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(NV(*)(), SvIV(*svp)); - printf("The current time is: %" NVff "\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. - -Copyright (C) 2011, 2012, 2013 Andrew Main (Zefram) <zefram@fysh.org> - -This program is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut diff --git a/cpan/Time-HiRes/HiRes.xs b/cpan/Time-HiRes/HiRes.xs deleted file mode 100644 index a4cece2562..0000000000 --- a/cpan/Time-HiRes/HiRes.xs +++ /dev/null @@ -1,1338 +0,0 @@ -/* - * - * Copyright (c) 1996-2002 Douglas E. Wegscheid. All rights reserved. - * - * Copyright (c) 2002-2010 Jarkko Hietaniemi. - * All rights reserved. - * - * Copyright (C) 2011, 2012, 2013 Andrew Main (Zefram) <zefram@fysh.org> - * - * 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 - -#define PERL_VERSION_DECIMAL(r,v,s) (r*1000000 + v*1000 + s) -#define PERL_DECIMAL_VERSION \ - PERL_VERSION_DECIMAL(PERL_REVISION,PERL_VERSION,PERL_SUBVERSION) -#define PERL_VERSION_GE(r,v,s) \ - (PERL_DECIMAL_VERSION >= PERL_VERSION_DECIMAL(r,v,s)) - -/* 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 - -#if PERL_VERSION_GE(5,7,3) && !PERL_VERSION_GE(5,10,1) -# undef SAVEOP -# define SAVEOP() SAVEVPTR(PL_op) -#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 *oitv, int usec, int uinterval) -{ - struct itimerval itv; - 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, oitv); -} - -int -hrt_ualarm_itimer(int usec, int uinterval) -{ - return hrt_ualarm_itimero(NULL, 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_nsec, UV *mtime_nsec, UV *ctime_nsec) -{ - dTHX; -#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; -#elif TIME_HIRES_STAT == 2 - *atime_nsec = PL_statcache.st_atimensec; - *mtime_nsec = PL_statcache.st_mtimensec; - *ctime_nsec = PL_statcache.st_ctimensec; -#elif 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; -#elif 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; -#elif 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; -#else /* !TIME_HIRES_STAT */ - *atime_nsec = 0; - *mtime_nsec = 0; - *ctime_nsec = 0; -#endif /* !TIME_HIRES_STAT */ -} - -#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 - { - (void) hv_store(PL_modglobal, "Time::NVtime", 12, - newSViv(PTR2IV(myNVtime)), 0); - (void) 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: - PERL_UNUSED_ARG(nsec); - croak("Time::HiRes::nanosleep(): unimplemented in this platform"); - RETVAL = 0.0; - OUTPUT: - RETVAL - -#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: - PERL_UNUSED_ARG(useconds); - croak("Time::HiRes::usleep(): unimplemented in this platform"); - RETVAL = 0.0; - OUTPUT: - RETVAL - -#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)) { - /* To conform to ualarm's interface, we're actually ignoring - an error here. */ - RETVAL = 0; - } else { - RETVAL = itv.it_value.tv_sec * IV_1E6 + itv.it_value.tv_usec; - } - } -#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 iseconds = (IV)seconds; - IV iinterval = (IV)interval; - NV fseconds = seconds - iseconds; - NV finterval = interval - iinterval; - IV useconds, uinterval; - if (fseconds >= 1.0 || finterval >= 1.0) - croak("Time::HiRes::alarm(%"NVgf", %"NVgf"): seconds or interval too large to split correctly", seconds, interval); - useconds = IV_1E6 * fseconds; - uinterval = IV_1E6 * finterval; -#if defined(HAS_SETITIMER) && defined(ITIMER_REAL) - { - struct itimerval nitv, oitv; - nitv.it_value.tv_sec = iseconds; - nitv.it_value.tv_usec = useconds; - nitv.it_interval.tv_sec = iinterval; - nitv.it_interval.tv_usec = uinterval; - if (setitimer(ITIMER_REAL, &nitv, &oitv)) { - /* To conform to alarm's interface, we're actually ignoring - an error here. */ - RETVAL = 0; - } else { - RETVAL = oitv.it_value.tv_sec + ((NV)oitv.it_value.tv_usec) / NV_1E6; - } - } -#else - if (iseconds || iinterval) - croak("Time::HiRes::alarm(%"NVgf", %"NVgf"): seconds or interval equal to or more than 1.0 ", seconds, interval); - RETVAL = (NV)ualarm( useconds, uinterval ) / NV_1E6; -#endif - } - - OUTPUT: - RETVAL - -#else - -int -ualarm(useconds,interval=0) - int useconds - int interval - CODE: - PERL_UNUSED_ARG(useconds); - PERL_UNUSED_ARG(interval); - croak("Time::HiRes::ualarm(): unimplemented in this platform"); - RETVAL = -1; - OUTPUT: - RETVAL - -NV -alarm(seconds,interval=0) - NV seconds - NV interval - CODE: - PERL_UNUSED_ARG(seconds); - PERL_UNUSED_ARG(interval); - croak("Time::HiRes::alarm(): unimplemented in this platform"); - RETVAL = 0.0; - OUTPUT: - RETVAL - -#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); - /* on some platforms the 1st arg to setitimer is an enum, which - * causes -Wc++-compat to complain about passing an int instead - */ -#ifdef GCC_DIAG_IGNORE - GCC_DIAG_IGNORE(-Wc++-compat); -#endif - 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)))); - } - } -#ifdef GCC_DIAG_RESTORE - GCC_DIAG_RESTORE; -#endif - -void -getitimer(which) - int which - PREINIT: - struct itimerval nowit; - PPCODE: - /* on some platforms the 1st arg to getitimer is an enum, which - * causes -Wc++-compat to complain about passing an int instead - */ -#ifdef GCC_DIAG_IGNORE - GCC_DIAG_IGNORE(-Wc++-compat); -#endif - 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)))); - } - } -#ifdef GCC_DIAG_RESTORE - GCC_DIAG_RESTORE; -#endif - -#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: - PERL_UNUSED_ARG(clock_id); - croak("Time::HiRes::clock_gettime(): unimplemented in this platform"); - RETVAL = 0.0; - OUTPUT: - RETVAL - -#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: - PERL_UNUSED_ARG(clock_id); - croak("Time::HiRes::clock_getres(): unimplemented in this platform"); - RETVAL = 0.0; - OUTPUT: - RETVAL - -#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(clock_id, nsec, flags = 0) - int clock_id - NV nsec - int flags - CODE: - PERL_UNUSED_ARG(clock_id); - PERL_UNUSED_ARG(nsec); - PERL_UNUSED_ARG(flags); - croak("Time::HiRes::clock_nanosleep(): unimplemented in this platform"); - RETVAL = 0.0; - OUTPUT: - RETVAL - -#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 == (clock_t) -1 ? (clock_t) -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; - OUTPUT: - RETVAL - -#endif /* #if defined(TIME_HIRES_CLOCK) && defined(CLOCKS_PER_SEC) */ - -void -stat(...) -PROTOTYPE: ;$ - PREINIT: - OP fakeop; - int nret; - ALIAS: - Time::HiRes::lstat = 1 - PPCODE: - XPUSHs(sv_2mortal(newSVsv(items == 1 ? ST(0) : DEFSV))); - PUTBACK; - ENTER; - PL_laststatval = -1; - SAVEOP(); - Zero(&fakeop, 1, OP); - fakeop.op_type = ix ? OP_LSTAT : OP_STAT; - fakeop.op_ppaddr = PL_ppaddr[fakeop.op_type]; - fakeop.op_flags = GIMME_V == G_ARRAY ? OPf_WANT_LIST : - GIMME_V == G_SCALAR ? OPf_WANT_SCALAR : OPf_WANT_VOID; - PL_op = &fakeop; - (void)fakeop.op_ppaddr(aTHX); - SPAGAIN; - LEAVE; - nret = SP+1 - &ST(0); - if (nret == 13) { - 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_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(nret); diff --git a/cpan/Time-HiRes/Makefile.PL b/cpan/Time-HiRes/Makefile.PL deleted file mode 100644 index bbdd7a7227..0000000000 --- a/cpan/Time-HiRes/Makefile.PL +++ /dev/null @@ -1,912 +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. - -{ use 5.006; } - -use Config; -use ExtUtils::MakeMaker; -use strict; - -my $VERBOSE = $ENV{VERBOSE}; -my $DEFINE; -my $LIBS = []; -my $XSOPT = ''; -my $SYSCALL_H; - -our $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" - . ' -DPERL_NO_INLINE_FUNCTIONS'; - - if ($^O eq 'VMS') { - $cccmd = "$Config{'cc'} /include=($COREincdir) $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); - my @run = $tmp_exe; - unshift @run, $Config{run} if $Config{run} && -e $Config{run}; - printf "Running $tmp_exe..." if $VERBOSE; - if (system(@run) == 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 && $] < 5.011 ? 'perl' : 'site'), - 'PREREQ_PM' => { - 'Carp' => 0, - 'Config' => 0, - 'DynaLoader' => 0, - 'Exporter' => 0, - 'ExtUtils::MakeMaker' => 0, - 'Test::More' => "0.82", - 'strict' => 0, - }, - 'dist' => { - 'CI' => 'ci -l', - 'COMPRESS' => 'gzip -9f', - 'SUFFIX' => 'gz', - }, - clean => { FILES => "xdefine" }, - realclean => { FILES=> 'const-c.inc const-xs.inc' }, - ); - - if ($^O eq "MSWin32" && !(grep { /\ALD[A-Z]*=/ } @ARGV)) { - my $libperl = $Config{libperl} || ""; - my $gccversion = $Config{gccversion} || ""; - if ($gccversion =~ /\A3\.4\.[0-9]+/ and $libperl =~ /\.lib\z/) { - # Avoid broken linkage with ActivePerl, by linking directly - # against the Perl DLL rather than the import library. - (my $llibperl = "-l$libperl") =~ s/\.lib\z//; - my $lddlflags = $Config{lddlflags} || ""; - my $ldflags = $Config{ldflags} || ""; - s/-L(?:".*?"|\S+)//g foreach $lddlflags, $ldflags; - my $libdirs = join ' ', - map { s/(?<!\\)((?:\\\\)*")/\\$1/g; qq[-L"$_"] } - @Config{qw/bin sitebin/}; - push @makefileopts, macro => { - LDDLFLAGS => "$lddlflags $libdirs $llibperl", - LDFLAGS => "$ldflags $libdirs $llibperl", - PERL_ARCHIVE => "", - }; - } - } - - if ($ENV{PERL_CORE}) { - push @makefileopts, MAN3PODS => {}; - } - - if ($ExtUtils::MakeMaker::VERSION >= 6.48) { - push @makefileopts, (MIN_PERL_VERSION => '5.008',); - } - - if ($ExtUtils::MakeMaker::VERSION >= 6.31) { - push @makefileopts, (LICENSE => 'perl_5'); - } - - 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 "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/cpan/Time-HiRes/fallback/const-c.inc b/cpan/Time-HiRes/fallback/const-c.inc deleted file mode 100644 index a8626172af..0000000000 --- a/cpan/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/cpan/Time-HiRes/fallback/const-xs.inc b/cpan/Time-HiRes/fallback/const-xs.inc deleted file mode 100644 index c84dd051dd..0000000000 --- a/cpan/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/cpan/Time-HiRes/hints/aix.pl b/cpan/Time-HiRes/hints/aix.pl deleted file mode 100644 index bbb7fa8342..0000000000 --- a/cpan/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/cpan/Time-HiRes/hints/dec_osf.pl b/cpan/Time-HiRes/hints/dec_osf.pl deleted file mode 100644 index b19d149e70..0000000000 --- a/cpan/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/cpan/Time-HiRes/hints/dynixptx.pl b/cpan/Time-HiRes/hints/dynixptx.pl deleted file mode 100644 index 0a1e5db38f..0000000000 --- a/cpan/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/cpan/Time-HiRes/hints/irix.pl b/cpan/Time-HiRes/hints/irix.pl deleted file mode 100644 index 83d98bcab6..0000000000 --- a/cpan/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/cpan/Time-HiRes/hints/linux.pl b/cpan/Time-HiRes/hints/linux.pl deleted file mode 100644 index 84ce5221b1..0000000000 --- a/cpan/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/cpan/Time-HiRes/hints/sco.pl b/cpan/Time-HiRes/hints/sco.pl deleted file mode 100644 index 22f2764347..0000000000 --- a/cpan/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/cpan/Time-HiRes/hints/solaris.pl b/cpan/Time-HiRes/hints/solaris.pl deleted file mode 100644 index 6cc80e7bc5..0000000000 --- a/cpan/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/cpan/Time-HiRes/hints/svr4.pl b/cpan/Time-HiRes/hints/svr4.pl deleted file mode 100644 index 75128724f2..0000000000 --- a/cpan/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/cpan/Time-HiRes/t/Watchdog.pm b/cpan/Time-HiRes/t/Watchdog.pm deleted file mode 100644 index 83e854396f..0000000000 --- a/cpan/Time-HiRes/t/Watchdog.pm +++ /dev/null @@ -1,54 +0,0 @@ -package t::Watchdog; - -use strict; - -use Config; -use Test::More; - -my $waitfor = 360; # 30-45 seconds is normal (load affects this). -my $watchdog_pid; -my $TheEnd; - -if ($Config{d_fork}) { - note "I am the main process $$, starting the watchdog process..."; - $watchdog_pid = fork(); - if (defined $watchdog_pid) { - if ($watchdog_pid == 0) { # We are the kid, set up the watchdog. - my $ppid = getppid(); - note "I am the watchdog process $$, sleeping for $waitfor seconds..."; - 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"; - note "Terminating main process $ppid..."; - kill('KILL', $ppid); - note "This is the watchdog process $$, over and out."; - } - exit(0); - } else { - note "The watchdog process $watchdog_pid launched, continuing testing..."; - $TheEnd = time() + $waitfor; - } - } else { - warn "$0: fork failed: $!\n"; - } -} else { - note "No watchdog process (need fork)"; -} - -END { - if ($watchdog_pid) { # Only in the main process. - my $left = $TheEnd - time(); - note sprintf "I am the main process $$, terminating the watchdog process $watchdog_pid before it terminates me in %d seconds (testing took %d seconds).", $left, $waitfor - $left; - if (kill(0, $watchdog_pid)) { - local $? = 0; - my $kill = kill('KILL', $watchdog_pid); # We are done, the watchdog can go. - wait(); - note sprintf "kill KILL $watchdog_pid = %d", $kill; - } - unlink("ktrace.out"); # Used in BSD system call tracing. - note "All done."; - } -} - -1; diff --git a/cpan/Time-HiRes/t/alarm.t b/cpan/Time-HiRes/t/alarm.t deleted file mode 100644 index 841694f67c..0000000000 --- a/cpan/Time-HiRes/t/alarm.t +++ /dev/null @@ -1,222 +0,0 @@ -use strict; - -use Test::More 0.82 tests => 10; -use t::Watchdog; - -BEGIN { require_ok "Time::HiRes"; } - -use Config; - -my $limit = 0.25; # 25% is acceptable slosh for testing timers - -my $xdefine = ''; -if (open(XDEFINE, "xdefine")) { - chomp($xdefine = <XDEFINE> || ""); - close(XDEFINE); -} - -my $can_subsecond_alarm = - defined &Time::HiRes::gettimeofday && - defined &Time::HiRes::ualarm && - defined &Time::HiRes::usleep && - ($Config{d_ualarm} || $xdefine =~ /-DHAS_UALARM/); - -SKIP: { - skip "no subsecond alarm", 1 unless $can_subsecond_alarm; - eval { require POSIX }; - my $use_sigaction = - !$@ && defined &POSIX::sigaction && &POSIX::SIGALRM > 0; - - my ($r, $i, $not, $ok); - - $r = [Time::HiRes::gettimeofday()]; - $i = 5; - my $oldaction; - if ($use_sigaction) { - $oldaction = new POSIX::SigAction; - note sprintf "sigaction tick, ALRM = %d", &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 { - note "SIG tick"; - $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) { - Time::HiRes::alarm(0.3); - select (undef, undef, undef, 3); - my $ival = Time::HiRes::tv_interval ($r); - note "Select returned! $i $ival"; - note abs($ival/3 - 1); - # 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); - note "Tick! $i $ival"; - 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 { - Time::HiRes::alarm(0); # can't cancel usig %SIG - } - - ok !$not; - note $not || $ok; -} - -SKIP: { - skip "no ualarm", 1 unless &Time::HiRes::d_ualarm; - eval { Time::HiRes::alarm(-3) }; - like $@, qr/::alarm\(-3, 0\): negative time not invented yet/, - "negative time error"; -} - -# Find the loop size N (a for() loop 0..N-1) -# that will take more than T seconds. - -SKIP: { - skip "no ualarm", 1 unless &Time::HiRes::d_ualarm; - skip "perl bug", 1 unless $] >= 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] - - note "Finding delay loop..."; - - my $T = 0.01; - my $DelayN = 1024; - my $i; - N: { - do { - my $t0 = Time::HiRes::time(); - for ($i = 0; $i < $DelayN; $i++) { } - my $t1 = Time::HiRes::time(); - my $dt = $t1 - $t0; - note "N = $DelayN, t1 = $t1, t0 = $t0, dt = $dt"; - 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++; - note "Alarm $a - ", Time::HiRes::time(); - Time::HiRes::alarm(0) if $a >= $A; # Disarm the alarm. - $Delay->(2); # Try burning CPU at least for 2T seconds. - }; - - Time::HiRes::alarm($T, $T); # Arm the alarm. - - $Delay->(10); # Try burning CPU at least for 10T seconds. - - ok 1; # Not core dumping by now is considered to be the success. -} - -SKIP: { - skip "no subsecond alarm", 6 unless $can_subsecond_alarm; - { - my $alrm; - $SIG{ALRM} = sub { $alrm++ }; - Time::HiRes::alarm(0.1); - my $t0 = Time::HiRes::time(); - 1 while Time::HiRes::time() - $t0 <= 1; - ok $alrm; - } - { - my $alrm; - $SIG{ALRM} = sub { $alrm++ }; - Time::HiRes::alarm(1.1); - my $t0 = Time::HiRes::time(); - 1 while Time::HiRes::time() - $t0 <= 2; - ok $alrm; - } - - { - my $alrm = 0; - $SIG{ALRM} = sub { $alrm++ }; - my $got = Time::HiRes::alarm(2.7); - ok $got == 0 or note $got; - - my $t0 = Time::HiRes::time(); - 1 while Time::HiRes::time() - $t0 <= 1; - - $got = Time::HiRes::alarm(0); - ok $got > 0 && $got < 1.8 or note $got; - - ok $alrm == 0 or note $alrm; - - $got = Time::HiRes::alarm(0); - ok $got == 0 or note $got; - } -} - -1; diff --git a/cpan/Time-HiRes/t/clock.t b/cpan/Time-HiRes/t/clock.t deleted file mode 100644 index 6d11dd2ca0..0000000000 --- a/cpan/Time-HiRes/t/clock.t +++ /dev/null @@ -1,94 +0,0 @@ -use strict; - -use Test::More 0.82 tests => 5; -use t::Watchdog; - -BEGIN { require_ok "Time::HiRes"; } - -sub has_symbol { - my $symbol = shift; - eval "use Time::HiRes qw($symbol)"; - return 0 unless $@ eq ''; - eval "my \$a = $symbol"; - return $@ eq ''; -} - -note sprintf "have_clock_gettime = %d", &Time::HiRes::d_clock_gettime; -note sprintf "have_clock_getres = %d", &Time::HiRes::d_clock_getres; -note sprintf "have_clock_nanosleep = %d", &Time::HiRes::d_clock_nanosleep; -note sprintf "have_clock = %d", &Time::HiRes::d_clock; - -# 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 - -SKIP: { - skip "no clock_gettime", 1 - unless &Time::HiRes::d_clock_gettime && has_symbol("CLOCK_REALTIME"); - my $ok = 0; - TRY: { - for my $try (1..3) { - note "CLOCK_REALTIME: try = $try"; - my $t0 = Time::HiRes::clock_gettime(&CLOCK_REALTIME); - my $T = 1.5; - Time::HiRes::sleep($T); - my $t1 = Time::HiRes::clock_gettime(&CLOCK_REALTIME); - if ($t0 > 0 && $t1 > $t0) { - note "t1 = $t1, t0 = $t0"; - my $dt = $t1 - $t0; - my $rt = abs(1 - $dt / $T); - note "dt = $dt, rt = $rt"; - if ($rt <= 2 * $limit) { - $ok = 1; - last TRY; - } - } else { - note "Error: t0 = $t0, t1 = $t1"; - } - my $r = rand() + rand(); - note sprintf "Sleeping for %.6f seconds...\n", $r; - Time::HiRes::sleep($r); - } - } - ok $ok; -} - -SKIP: { - skip "no clock_getres", 1 unless &Time::HiRes::d_clock_getres; - my $tr = Time::HiRes::clock_getres(); - ok $tr > 0 or note "tr = $tr"; -} - -SKIP: { - skip "no clock_nanosleep", 1 - unless &Time::HiRes::d_clock_nanosleep && has_symbol("CLOCK_REALTIME"); - my $s = 1.5e9; - my $t = Time::HiRes::clock_nanosleep(&CLOCK_REALTIME, $s); - my $r = abs(1 - $t / $s); - ok $r < 2 * $limit or note "t = $t, r = $r"; -} - -SKIP: { - skip "no clock", 1 unless &Time::HiRes::d_clock; - my @clock = Time::HiRes::clock(); - note "clock = @clock"; - for my $i (1..3) { - for (my $j = 0; $j < 1e6; $j++) { } - push @clock, Time::HiRes::clock(); - note "clock = @clock"; - } - ok $clock[0] >= 0 && - $clock[1] > $clock[0] && - $clock[2] > $clock[1] && - $clock[3] > $clock[2]; -} - -1; diff --git a/cpan/Time-HiRes/t/gettimeofday.t b/cpan/Time-HiRes/t/gettimeofday.t deleted file mode 100644 index 8f7c5f3039..0000000000 --- a/cpan/Time-HiRes/t/gettimeofday.t +++ /dev/null @@ -1,33 +0,0 @@ -use strict; - -BEGIN { - require Time::HiRes; - unless(&Time::HiRes::d_gettimeofday) { - require Test::More; - Test::More::plan(skip_all => "no gettimeofday()"); - } -} - -use Test::More 0.82 tests => 6; -use t::Watchdog; - -my @one = Time::HiRes::gettimeofday(); -note 'gettimeofday returned ', 0+@one, ' args'; -ok @one == 2; -ok $one[0] > 850_000_000 or note "@one too small"; - -sleep 1; - -my @two = Time::HiRes::gettimeofday(); -ok $two[0] > $one[0] || ($two[0] == $one[0] && $two[1] > $one[1]) - or note "@two is not greater than @one"; - -my $f = Time::HiRes::time(); -ok $f > 850_000_000 or note "$f too small"; -ok $f - $two[0] < 2 or note "$f - $two[0] >= 2"; - -my $r = [Time::HiRes::gettimeofday()]; -my $g = Time::HiRes::tv_interval $r; -ok $g < 2 or note $g; - -1; diff --git a/cpan/Time-HiRes/t/itimer.t b/cpan/Time-HiRes/t/itimer.t deleted file mode 100644 index 9eb2b93f6f..0000000000 --- a/cpan/Time-HiRes/t/itimer.t +++ /dev/null @@ -1,67 +0,0 @@ -use strict; - -sub has_symbol { - my $symbol = shift; - eval "use Time::HiRes qw($symbol)"; - return 0 unless $@ eq ''; - eval "my \$a = $symbol"; - return $@ eq ''; -} - -use Config; - -BEGIN { - require Time::HiRes; - 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 - && $^O ne 'gnu' # GNU/Hurd: has the API but no implementation - ) { - require Test::More; - Test::More::plan(skip_all => "no itimer"); - } -} - -use Test::More 0.82 tests => 2; -use t::Watchdog; - -my $limit = 0.25; # 25% is acceptable slosh for testing timers - -my $i = 3; -my $r = [Time::HiRes::gettimeofday()]; - -$SIG{VTALRM} = sub { - $i ? $i-- : Time::HiRes::setitimer(&Time::HiRes::ITIMER_VIRTUAL, 0); - note "Tick! $i ", Time::HiRes::tv_interval($r); -}; - -note "setitimer: ", join(" ", - Time::HiRes::setitimer(&Time::HiRes::ITIMER_VIRTUAL, 0.5, 0.4)); - -# Assume interval timer granularity of $limit * 0.5 seconds. Too bold? -my $virt = Time::HiRes::getitimer(&Time::HiRes::ITIMER_VIRTUAL); -ok(defined $virt && abs($virt / 0.5) - 1 < $limit, - "ITIMER_VIRTUAL defined with sufficient granularity") - or diag "virt=" . (defined $virt ? $virt : 'undef'); - -note "getitimer: ", join(" ", - Time::HiRes::getitimer(&Time::HiRes::ITIMER_VIRTUAL)); - -while (Time::HiRes::getitimer(&Time::HiRes::ITIMER_VIRTUAL)) { - my $j; - for (1..1000) { $j++ } # Can't be unbreakable, must test getitimer(). -} - -note "getitimer: ", join(" ", - Time::HiRes::getitimer(&Time::HiRes::ITIMER_VIRTUAL)); - -$virt = Time::HiRes::getitimer(&Time::HiRes::ITIMER_VIRTUAL); -note "at end, i=$i"; -is($virt, 0, "time left should be zero"); - -$SIG{VTALRM} = 'DEFAULT'; - -1; diff --git a/cpan/Time-HiRes/t/nanosleep.t b/cpan/Time-HiRes/t/nanosleep.t deleted file mode 100644 index aef9db6163..0000000000 --- a/cpan/Time-HiRes/t/nanosleep.t +++ /dev/null @@ -1,35 +0,0 @@ -use strict; - -BEGIN { - require Time::HiRes; - unless(&Time::HiRes::d_nanosleep) { - require Test::More; - Test::More::plan(skip_all => "no nanosleep()"); - } -} - -use Test::More 0.82 tests => 3; -use t::Watchdog; - -eval { Time::HiRes::nanosleep(-5) }; -like $@, qr/::nanosleep\(-5\): negative time not invented yet/, - "negative time error"; - -my $one = CORE::time; -Time::HiRes::nanosleep(10_000_000); -my $two = CORE::time; -Time::HiRes::nanosleep(10_000_000); -my $three = CORE::time; -ok $one == $two || $two == $three - or note "slept too long, $one $two $three"; - -SKIP: { - skip "no gettimeofday", 1 unless &Time::HiRes::d_gettimeofday; - my $f = Time::HiRes::time(); - Time::HiRes::nanosleep(500_000_000); - my $f2 = Time::HiRes::time(); - my $d = $f2 - $f; - ok $d > 0.4 && $d < 0.9 or note "slept $d secs $f to $f2"; -} - -1; diff --git a/cpan/Time-HiRes/t/sleep.t b/cpan/Time-HiRes/t/sleep.t deleted file mode 100644 index e7cc6271a8..0000000000 --- a/cpan/Time-HiRes/t/sleep.t +++ /dev/null @@ -1,38 +0,0 @@ -use strict; - -use Test::More 0.82 tests => 4; -use t::Watchdog; - -BEGIN { require_ok "Time::HiRes"; } - -use Config; - -my $xdefine = ''; -if (open(XDEFINE, "xdefine")) { - chomp($xdefine = <XDEFINE> || ""); - close(XDEFINE); -} - -my $can_subsecond_alarm = - defined &Time::HiRes::gettimeofday && - defined &Time::HiRes::ualarm && - defined &Time::HiRes::usleep && - ($Config{d_ualarm} || $xdefine =~ /-DHAS_UALARM/); - -eval { Time::HiRes::sleep(-1) }; -like $@, qr/::sleep\(-1\): negative time not invented yet/, - "negative time error"; - -SKIP: { - skip "no subsecond alarm", 2 unless $can_subsecond_alarm; - my $f = Time::HiRes::time; - note "time...$f"; - ok 1; - - my $r = [Time::HiRes::gettimeofday()]; - Time::HiRes::sleep (0.5); - note "sleep...", Time::HiRes::tv_interval($r); - ok 1; -} - -1; diff --git a/cpan/Time-HiRes/t/stat.t b/cpan/Time-HiRes/t/stat.t deleted file mode 100644 index eca9da12e3..0000000000 --- a/cpan/Time-HiRes/t/stat.t +++ /dev/null @@ -1,100 +0,0 @@ -use strict; - -BEGIN { - require Time::HiRes; - unless(&Time::HiRes::d_hires_stat) { - require Test::More; - Test::More::plan(skip_all => "no hi-res stat"); - } - if($^O =~ /\A(?:cygwin|MSWin)/) { - require Test::More; - Test::More::plan(skip_all => - "$^O file timestamps not reliable enough for stat test"); - } -} - -use Test::More 0.82 tests => 43; -use t::Watchdog; - -my $limit = 0.25; # 25% is acceptable slosh for testing timers - -my @atime; -my @mtime; -for (1..5) { - Time::HiRes::sleep(rand(0.1) + 0.1); - open(X, ">$$"); - print X $$; - close(X); - my($a, $stat, $b) = ("a", [Time::HiRes::stat($$)], "b"); - is $a, "a"; - is $b, "b"; - is ref($stat), "ARRAY"; - push @mtime, $stat->[9]; - ($a, my $lstat, $b) = ("a", [Time::HiRes::lstat($$)], "b"); - is $a, "a"; - is $b, "b"; - is_deeply $lstat, $stat; - Time::HiRes::sleep(rand(0.1) + 0.1); - open(X, "<$$"); - <X>; - close(X); - $stat = [Time::HiRes::stat($$)]; - push @atime, $stat->[8]; - $lstat = [Time::HiRes::lstat($$)]; - is_deeply $lstat, $stat; -} -1 while unlink $$; -note "mtime = @mtime"; -note "atime = @atime"; -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++; - } -} -note "ai = $ai, mi = $mi, ss = $ss"; -# Need at least 75% of monotonical increase and -# 20% of subsecond results. Yes, this is guessing. -SKIP: { - skip "no subsecond timestamps detected", 1 if $ss == 0; - ok $mi/(@mtime-1) >= 0.75 && $ai/(@atime-1) >= 0.75 && - $ss/(@mtime+@atime) >= 0.2; -} - -my $targetname = "tgt$$"; -my $linkname = "link$$"; -SKIP: { - open(X, ">$targetname"); - print X $$; - close(X); - eval { symlink $targetname, $linkname or die "can't symlink: $!"; }; - skip "can't symlink", 7 if $@ ne ""; - my @tgt_stat = Time::HiRes::stat($targetname); - my @tgt_lstat = Time::HiRes::lstat($targetname); - my @lnk_stat = Time::HiRes::stat($linkname); - my @lnk_lstat = Time::HiRes::lstat($linkname); - is scalar(@tgt_stat), 13; - is scalar(@tgt_lstat), 13; - is scalar(@lnk_stat), 13; - is scalar(@lnk_lstat), 13; - is_deeply \@tgt_stat, \@tgt_lstat; - is_deeply \@tgt_stat, \@lnk_stat; - isnt $lnk_lstat[2], $tgt_stat[2]; -} -1 while unlink $linkname; -1 while unlink $targetname; - -1; diff --git a/cpan/Time-HiRes/t/time.t b/cpan/Time-HiRes/t/time.t deleted file mode 100644 index feec4799d9..0000000000 --- a/cpan/Time-HiRes/t/time.t +++ /dev/null @@ -1,23 +0,0 @@ -use strict; - -use Test::More 0.82 tests => 2; -use t::Watchdog; - -BEGIN { require_ok "Time::HiRes"; } - -SKIP: { - skip "no gettimeofday", 1 unless &Time::HiRes::d_gettimeofday; - my ($s, $n, $i) = (0); - for $i (1 .. 100) { - $s += Time::HiRes::time() - CORE::time(); - $n++; - } - # $s should be, at worst, equal to $n - # (CORE::time() may be rounding down, up, or closest), - # but allow 10% of slop. - ok abs($s) / $n <= 1.10 - or note "Time::HiRes::time() not close to CORE::time()"; - note "s = $s, n = $n, s/n = ", abs($s)/$n; -} - -1; diff --git a/cpan/Time-HiRes/t/tv_interval.t b/cpan/Time-HiRes/t/tv_interval.t deleted file mode 100644 index bffcf39ec1..0000000000 --- a/cpan/Time-HiRes/t/tv_interval.t +++ /dev/null @@ -1,10 +0,0 @@ -use strict; - -use Test::More 0.82 tests => 2; - -BEGIN { require_ok "Time::HiRes"; } - -my $f = Time::HiRes::tv_interval [5, 100_000], [10, 500_000]; -ok abs($f - 5.4) < 0.001 or note $f; - -1; diff --git a/cpan/Time-HiRes/t/ualarm.t b/cpan/Time-HiRes/t/ualarm.t deleted file mode 100644 index 12ef4b52cc..0000000000 --- a/cpan/Time-HiRes/t/ualarm.t +++ /dev/null @@ -1,112 +0,0 @@ -use strict; - -BEGIN { - require Time::HiRes; - unless(&Time::HiRes::d_ualarm) { - require Test::More; - Test::More::plan(skip_all => "no ualarm()"); - } -} - -use Test::More 0.82 tests => 12; -use t::Watchdog; - -use Config; - -SKIP: { - skip "no alarm", 2 unless $Config{d_alarm}; - my $tick = 0; - local $SIG{ ALRM } = sub { $tick++ }; - - my $one = CORE::time; - $tick = 0; Time::HiRes::ualarm(10_000); while ($tick == 0) { } - my $two = CORE::time; - $tick = 0; Time::HiRes::ualarm(10_000); while ($tick == 0) { } - my $three = CORE::time; - ok $one == $two || $two == $three - or note "slept too long, $one $two $three"; - note "tick = $tick, one = $one, two = $two, three = $three"; - - $tick = 0; Time::HiRes::ualarm(10_000, 10_000); while ($tick < 3) { } - ok 1; - Time::HiRes::ualarm(0); - note "tick = $tick, one = $one, two = $two, three = $three"; -} - -eval { Time::HiRes::ualarm(-4) }; -like $@, qr/::ualarm\(-4, 0\): negative time not invented yet/, - "negative time error"; - -# Find the loop size N (a for() loop 0..N-1) -# that will take more than T seconds. - -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; -} - -# 1_100_000 slightly over 1_000_000, -# 2_200_000 slightly over 2**31/1000, -# 4_300_000 slightly over 2**32/1000. -for my $n (100_000, 1_100_000, 2_200_000, 4_300_000) { - my $ok; - for my $retry (1..10) { - my $alarmed = 0; - local $SIG{ ALRM } = sub { $alarmed++ }; - my $t0 = Time::HiRes::time(); - note "t0 = $t0"; - note "ualarm($n)"; - Time::HiRes::ualarm($n); 1 while $alarmed == 0; - my $t1 = Time::HiRes::time(); - note "t1 = $t1"; - my $dt = $t1 - $t0; - note "dt = $dt"; - my $r = $dt / ($n/1e6); - note "r = $r"; - $ok = - ($n < 1_000_000 || # Too much noise. - ($r >= 0.8 && $r <= 1.6)); - last if $ok; - my $nap = bellish(3, 15); - note sprintf "Retrying in %.1f seconds...\n", $nap; - Time::HiRes::sleep($nap); - } - ok $ok or note "ualarm($n) close enough"; -} - -{ - my $alrm0 = 0; - - $SIG{ALRM} = sub { $alrm0++ }; - my $t0 = Time::HiRes::time(); - my $got0 = Time::HiRes::ualarm(500_000); - - my($alrm, $t1); - do { - $alrm = $alrm0; - $t1 = Time::HiRes::time(); - } while $t1 - $t0 <= 0.3; - my $got1 = Time::HiRes::ualarm(0); - - note "t0 = $t0"; - note "got0 = $got0"; - note "t1 = $t1"; - note "t1 - t0 = ", ($t1 - $t0); - note "got1 = $got1"; - ok $got0 == 0 or note $got0; - SKIP: { - skip "alarm interval exceeded", 2 if $t1 - $t0 >= 0.5; - ok $got1 > 0; - ok $alrm == 0; - } - ok $got1 < 300_000; - my $got2 = Time::HiRes::ualarm(0); - ok $got2 == 0 or note $got2; -} - -1; diff --git a/cpan/Time-HiRes/t/usleep.t b/cpan/Time-HiRes/t/usleep.t deleted file mode 100644 index 0d6bacfac3..0000000000 --- a/cpan/Time-HiRes/t/usleep.t +++ /dev/null @@ -1,78 +0,0 @@ -use strict; - -BEGIN { - require Time::HiRes; - unless(&Time::HiRes::d_usleep) { - require Test::More; - Test::More::plan(skip_all => "no usleep()"); - } -} - -use Test::More 0.82 tests => 6; -use t::Watchdog; - -eval { Time::HiRes::usleep(-2) }; -like $@, qr/::usleep\(-2\): negative time not invented yet/, - "negative time error"; - -my $limit = 0.25; # 25% is acceptable slosh for testing timers - -my $one = CORE::time; -Time::HiRes::usleep(10_000); -my $two = CORE::time; -Time::HiRes::usleep(10_000); -my $three = CORE::time; -ok $one == $two || $two == $three -or note "slept too long, $one $two $three"; - -SKIP: { - skip "no gettimeofday", 1 unless &Time::HiRes::d_gettimeofday; - my $f = Time::HiRes::time(); - Time::HiRes::usleep(500_000); - my $f2 = Time::HiRes::time(); - my $d = $f2 - $f; - ok $d > 0.4 && $d < 0.9 or note "slept $d secs $f to $f2"; -} - -SKIP: { - skip "no gettimeofday", 1 unless &Time::HiRes::d_gettimeofday; - my $r = [ Time::HiRes::gettimeofday() ]; - Time::HiRes::sleep( 0.5 ); - my $f = Time::HiRes::tv_interval $r; - ok $f > 0.4 && $f < 0.9 or note "slept $f instead of 0.5 secs."; -} - -SKIP: { - skip "no gettimeofday", 2 unless &Time::HiRes::d_gettimeofday; - - my ($t0, $td); - - my $sleep = 1.5; # seconds - my $msg; - - $t0 = Time::HiRes::gettimeofday(); - $a = abs(Time::HiRes::sleep($sleep) / $sleep - 1.0); - $td = Time::HiRes::gettimeofday() - $t0; - my $ratio = 1.0 + $a; - - $msg = "$td went by while sleeping $sleep, ratio $ratio.\n"; - - SKIP: { - skip $msg, 1 unless $td < $sleep * (1 + $limit); - ok $a < $limit or note $msg; - } - - $t0 = Time::HiRes::gettimeofday(); - $a = abs(Time::HiRes::usleep($sleep * 1E6) / ($sleep * 1E6) - 1.0); - $td = Time::HiRes::gettimeofday() - $t0; - $ratio = 1.0 + $a; - - $msg = "$td went by while sleeping $sleep, ratio $ratio.\n"; - - SKIP: { - skip $msg, 1 unless $td < $sleep * (1 + $limit); - ok $a < $limit or note $msg; - } -} - -1; diff --git a/cpan/Time-HiRes/typemap b/cpan/Time-HiRes/typemap deleted file mode 100644 index 1124eb6483..0000000000 --- a/cpan/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; - } |