rpms
/
perl-Time-HiRes
2
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
perl-Time-HiRes/Time-HiRes-1.9760-Upgrade-t...

5432 lines
168 KiB
Diff
Raw Blame History

From 8ee999ad66e2b3c8b4ca87a543c081fc248719d5 Mon Sep 17 00:00:00 2001
From: Jitka Plesnikova <jplesnik@redhat.com>
Date: Tue, 21 Apr 2020 10:24:17 +0200
Subject: [PATCH] Upgrade to 1.9764
---
HiRes.pm | 141 ++--
HiRes.xs | 1721 ++++++++++++++++++++++++----------------------
Makefile.PL | 689 +++++++++----------
t/Watchdog.pm | 54 +-
t/alarm.t | 204 +++---
t/clock.t | 62 +-
t/gettimeofday.t | 6 +-
t/itimer.t | 18 +-
t/nanosleep.t | 6 +-
t/sleep.t | 6 +-
t/stat.t | 20 +-
t/time.t | 6 +-
t/ualarm.t | 60 +-
t/usleep.t | 14 +-
t/utime.t | 304 ++++----
typemap | 454 ++++++------
16 files changed, 1891 insertions(+), 1874 deletions(-)
diff --git a/HiRes.pm b/HiRes.pm
index 08eefc8..433ca31 100644
--- a/HiRes.pm
+++ b/HiRes.pm
@@ -11,46 +11,46 @@ our @ISA = qw(Exporter);
our @EXPORT = qw( );
# More or less this same list is in Makefile.PL. Should unify.
our @EXPORT_OK = qw (usleep sleep ualarm alarm gettimeofday time tv_interval
- getitimer setitimer nanosleep clock_gettime clock_getres
- clock clock_nanosleep
- CLOCKS_PER_SEC
- CLOCK_BOOTTIME
- CLOCK_HIGHRES
- CLOCK_MONOTONIC
- CLOCK_MONOTONIC_COARSE
- CLOCK_MONOTONIC_FAST
- CLOCK_MONOTONIC_PRECISE
- CLOCK_MONOTONIC_RAW
- CLOCK_PROCESS_CPUTIME_ID
- CLOCK_PROF
- CLOCK_REALTIME
- CLOCK_REALTIME_COARSE
- CLOCK_REALTIME_FAST
- CLOCK_REALTIME_PRECISE
- CLOCK_REALTIME_RAW
- CLOCK_SECOND
- CLOCK_SOFTTIME
- CLOCK_THREAD_CPUTIME_ID
- CLOCK_TIMEOFDAY
- CLOCK_UPTIME
- CLOCK_UPTIME_COARSE
- CLOCK_UPTIME_FAST
- CLOCK_UPTIME_PRECISE
- CLOCK_UPTIME_RAW
- CLOCK_VIRTUAL
- ITIMER_PROF
- ITIMER_REAL
- ITIMER_REALPROF
- ITIMER_VIRTUAL
- 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 d_hires_stat
- d_futimens d_utimensat d_hires_utime
- stat lstat utime
- );
-
-our $VERSION = '1.9760';
+ getitimer setitimer nanosleep clock_gettime clock_getres
+ clock clock_nanosleep
+ CLOCKS_PER_SEC
+ CLOCK_BOOTTIME
+ CLOCK_HIGHRES
+ CLOCK_MONOTONIC
+ CLOCK_MONOTONIC_COARSE
+ CLOCK_MONOTONIC_FAST
+ CLOCK_MONOTONIC_PRECISE
+ CLOCK_MONOTONIC_RAW
+ CLOCK_PROCESS_CPUTIME_ID
+ CLOCK_PROF
+ CLOCK_REALTIME
+ CLOCK_REALTIME_COARSE
+ CLOCK_REALTIME_FAST
+ CLOCK_REALTIME_PRECISE
+ CLOCK_REALTIME_RAW
+ CLOCK_SECOND
+ CLOCK_SOFTTIME
+ CLOCK_THREAD_CPUTIME_ID
+ CLOCK_TIMEOFDAY
+ CLOCK_UPTIME
+ CLOCK_UPTIME_COARSE
+ CLOCK_UPTIME_FAST
+ CLOCK_UPTIME_PRECISE
+ CLOCK_UPTIME_RAW
+ CLOCK_VIRTUAL
+ ITIMER_PROF
+ ITIMER_REAL
+ ITIMER_REALPROF
+ ITIMER_VIRTUAL
+ 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 d_hires_stat
+ d_futimens d_utimensat d_hires_utime
+ stat lstat utime
+ );
+
+our $VERSION = '1.9764';
our $XS_VERSION = $VERSION;
$VERSION = eval $VERSION;
@@ -67,8 +67,8 @@ sub AUTOLOAD {
die "$error at $file line $line.\n";
}
{
- no strict 'refs';
- *$AUTOLOAD = sub { $val };
+ no strict 'refs';
+ *$AUTOLOAD = sub { $val };
}
goto &$AUTOLOAD;
}
@@ -76,17 +76,17 @@ sub 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 'utime' && !&d_hires_utime) ||
- ($i eq 'ualarm' && !&d_ualarm)) {
- require Carp;
- Carp::croak("Time::HiRes::$i(): unimplemented in this platform");
- }
+ 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 'utime' && !&d_hires_utime) ||
+ ($i eq 'ualarm' && !&d_ualarm)) {
+ require Carp;
+ Carp::croak("Time::HiRes::$i(): unimplemented in this platform");
+ }
}
Time::HiRes->export_to_level(1, $this, @_);
}
@@ -114,7 +114,7 @@ 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
+ clock_gettime clock_getres clock_nanosleep clock
stat lstat utime);
usleep ($microseconds);
@@ -143,7 +143,7 @@ Time::HiRes - High resolution alarm, sleep, gettimeofday, interval timers
getitimer ($which);
use Time::HiRes qw( clock_gettime clock_getres clock_nanosleep
- ITIMER_REAL ITIMER_VIRTUAL ITIMER_PROF
+ ITIMER_REAL ITIMER_VIRTUAL ITIMER_PROF
ITIMER_REALPROF );
$realtime = clock_gettime(CLOCK_REALTIME);
@@ -221,8 +221,8 @@ 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()>.
+See also L<C<Time::HiRes::sleep()>|/sleep ( $floating_seconds )>, and
+L<C<clock_nanosleep()>|/clock_nanosleep ( $which, $nanoseconds, $flags = 0)>.
Do not expect usleep() to be exact down to one microsecond.
@@ -232,8 +232,10 @@ 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()>.
+a I<thread yield>. See also
+L<C<Time::HiRes::sleep()>|/sleep ( $floating_seconds )>,
+L<C<Time::HiRes::usleep()>|/usleep ( $useconds )>, and
+L<C<clock_nanosleep()>|/clock_nanosleep ( $which, $nanoseconds, $flags = 0)>.
Do not expect nanosleep() to be exact down to one nanosecond.
Getting even accuracy of one thousand nanoseconds is good.
@@ -250,7 +252,7 @@ ualarm(0) will cancel an outstanding ualarm().
Note that the interaction between alarms and sleeps is unspecified.
-=item tv_interval
+=item tv_interval
tv_interval ( $ref_to_gettimeofday [, $ref_to_later_gettimeofday] )
@@ -356,7 +358,7 @@ 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.
+See your L<C<setitimer(2)>> documentation.
=item getitimer ( $which )
@@ -404,8 +406,10 @@ 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()>.
+like a I<thread yield>. See also
+L<C<Time::HiRes::sleep()>|/sleep ( $floating_seconds )>,
+L<C<Time::HiRes::usleep()>|/usleep ( $useconds )>, and
+L<C<Time::HiRes::nanosleep()>|/nanosleep ( $nanoseconds )>.
Do not expect clock_nanosleep() to be exact down to one nanosecond.
Getting even accuracy of one thousand nanoseconds is good.
@@ -515,7 +519,7 @@ Returns the number of files successfully changed.
# get seconds and microseconds since the epoch
($s, $usec) = gettimeofday();
- # measure elapsed time
+ # measure elapsed time
# (could also do by subtracting 2 gettimeofday return values)
$t0 = [gettimeofday];
# do bunch of stuff here
@@ -524,7 +528,7 @@ Returns the number of files successfully changed.
$t0_t1 = tv_interval $t0, $t1;
$elapsed = tv_interval ($t0, [gettimeofday]);
- $elapsed = tv_interval ($t0); # equivalent code
+ $elapsed = tv_interval ($t0); # equivalent code
#
# replacements for time, alarm and sleep that know about
@@ -650,9 +654,10 @@ gnukfreebsd seems to have non-functional futimens() and utimensat()
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>.
+Your system documentation for L<C<clock(3)>>, L<C<clock_gettime(2)>>,
+L<C<clock_getres(3)>>, L<C<clock_nanosleep(3)>>, L<C<clock_settime(2)>>,
+L<C<getitimer(2)>>, L<C<gettimeofday(2)>>, L<C<setitimer(2)>>, L<C<sleep(3)>>,
+L<C<stat(2)>>, L<C<ualarm(3)>>.
=head1 AUTHORS
diff --git a/HiRes.xs b/HiRes.xs
index 97e870c..8002472 100644
--- a/HiRes.xs
+++ b/HiRes.xs
@@ -1,12 +1,12 @@
/*
- *
+ *
* 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.
*/
@@ -22,21 +22,21 @@ extern "C" {
# include "ppport.h"
#endif
#if defined(__CYGWIN__) && defined(HAS_W32API_WINDOWS_H)
-# include <w32api/windows.h>
-# define CYGWIN_WITH_W32API
+# include <w32api/windows.h>
+# define CYGWIN_WITH_W32API
#endif
#ifdef WIN32
-# include <time.h>
+# include <time.h>
#else
-# include <sys/time.h>
+# include <sys/time.h>
#endif
#ifdef HAS_SELECT
-# ifdef I_SYS_SELECT
-# include <sys/select.h>
-# endif
+# 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>
+# include <syscall.h>
#endif
#ifdef __cplusplus
}
@@ -44,29 +44,22 @@ extern "C" {
#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)
+ 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))
+ (PERL_DECIMAL_VERSION >= PERL_VERSION_DECIMAL(r,v,s))
#ifndef GCC_DIAG_IGNORE
-# define GCC_DIAG_IGNORE(x)
-# define GCC_DIAG_RESTORE
+# define GCC_DIAG_IGNORE(x)
+# define GCC_DIAG_RESTORE
#endif
#ifndef GCC_DIAG_IGNORE_STMT
-# define GCC_DIAG_IGNORE_STMT(x) GCC_DIAG_IGNORE(x) NOOP
-# define GCC_DIAG_RESTORE_STMT GCC_DIAG_RESTORE NOOP
-#endif
-
-/* At least ppport.h 3.13 gets this wrong: one really cannot
- * have NVgf as anything else than "g" under Perl 5.6.x. */
-#if PERL_REVISION == 5 && PERL_VERSION == 6
-# undef NVgf
-# define NVgf "g"
+# define GCC_DIAG_IGNORE_STMT(x) GCC_DIAG_IGNORE(x) NOOP
+# define GCC_DIAG_RESTORE_STMT GCC_DIAG_RESTORE NOOP
#endif
#if PERL_VERSION_GE(5,7,3) && !PERL_VERSION_GE(5,10,1)
-# undef SAVEOP
-# define SAVEOP() SAVEVPTR(PL_op)
+# undef SAVEOP
+# define SAVEOP() SAVEVPTR(PL_op)
#endif
#define IV_1E6 1000000
@@ -78,14 +71,14 @@ extern "C" {
#define NV_1E9 1000000000.0
#ifndef PerlProc_pause
-# define PerlProc_pause() Pause()
+# define PerlProc_pause() Pause()
#endif
#ifdef HAS_PAUSE
-# define Pause pause
+# define Pause pause
#else
-# undef Pause /* In case perl.h did it already. */
-# define Pause() sleep(~0) /* Zzz for a long time. */
+# 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
@@ -93,9 +86,9 @@ extern "C" {
* Neither are ITIMER_PROF or ITIMER_REALPROF implemented. --jhi
*/
#if defined(__CYGWIN__) || defined(WIN32)
-# undef ITIMER_VIRTUAL
-# undef ITIMER_PROF
-# undef ITIMER_REALPROF
+# undef ITIMER_VIRTUAL
+# undef ITIMER_PROF
+# undef ITIMER_REALPROF
#endif
#ifndef TIME_HIRES_CLOCKID_T
@@ -106,37 +99,37 @@ typedef int clockid_t;
/* 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
+# 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 */
+# 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
+# ifndef HAS_GETTIMEOFDAY
+# define HAS_GETTIMEOFDAY
+# endif
/* shows up in winsock.h?
struct timeval {
- long tv_sec;
- long tv_usec;
+ long tv_sec;
+ long tv_usec;
}
*/
typedef union {
- unsigned __int64 ft_i64;
- FILETIME ft_val;
+ unsigned __int64 ft_i64;
+ FILETIME ft_val;
} FT_t;
-#define MY_CXT_KEY "Time::HiRes_" XS_VERSION
+# define MY_CXT_KEY "Time::HiRes_" XS_VERSION
typedef struct {
unsigned long run_count;
@@ -146,27 +139,35 @@ typedef struct {
unsigned __int64 reset_time;
} my_cxt_t;
+/* Visual C++ 2013 and older don't have the timespec structure */
+# if defined(_MSC_VER) && _MSC_VER < 1900
+struct timespec {
+ time_t tv_sec;
+ long tv_nsec;
+};
+# endif
+
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
+# 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) */
@@ -174,50 +175,82 @@ START_MY_CXT
/* 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)
+# undef gettimeofday
+# define gettimeofday(tp, not_used) _gettimeofday(aTHX_ tp, not_used)
+
+# undef GetSystemTimePreciseAsFileTime
+# define GetSystemTimePreciseAsFileTime(out) _GetSystemTimePreciseAsFileTime(aTHX_ out)
+
+# undef clock_gettime
+# define clock_gettime(clock_id, tp) _clock_gettime(aTHX_ clock_id, tp)
+
+# undef clock_getres
+# define clock_getres(clock_id, tp) _clock_getres(clock_id, tp)
+
+# ifndef CLOCK_REALTIME
+# define CLOCK_REALTIME 1
+# define CLOCK_MONOTONIC 2
+# endif
/* 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 */
+# 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 */
+# define MAX_PERF_COUNTER_TICKS Const64(300000000) /* 300 seconds */
-static int
-_gettimeofday(pTHX_ struct timeval *tp, void *not_used)
+/*
+ * Windows 8 introduced GetSystemTimePreciseAsFileTime(), but currently we have
+ * to support older systems, so for now we provide our own implementation.
+ * In the future we will switch to the real deal.
+ */
+static void
+_GetSystemTimePreciseAsFileTime(pTHX_ FILETIME *out)
{
dMY_CXT;
-
- unsigned __int64 ticks;
FT_t ft;
- PERL_UNUSED_ARG(not_used);
if (MY_CXT.run_count++ == 0 ||
- MY_CXT.base_systime_as_filetime.ft_i64 > MY_CXT.reset_time) {
+ 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;
+ MY_CXT.reset_time = ft.ft_i64 + MAX_PERF_COUNTER_TICKS;
}
else {
- __int64 diff;
+ __int64 diff;
+ unsigned __int64 ticks;
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;
+ 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;
- }
+ }
}
+ *out = ft.ft_val;
+
+ return;
+}
+
+static int
+_gettimeofday(pTHX_ struct timeval *tp, void *not_used)
+{
+ FT_t ft;
+
+ PERL_UNUSED_ARG(not_used);
+
+ GetSystemTimePreciseAsFileTime(&ft.ft_val);
+
/* seconds since epoch */
tp->tv_sec = (long)((ft.ft_i64 - EPOCH_BIAS) / Const64(IV_1E7));
@@ -226,54 +259,107 @@ _gettimeofday(pTHX_ struct timeval *tp, void *not_used)
return 0;
}
-#endif
-#if defined(WIN32) && !defined(ATLEASTFIVEOHOHFIVE)
-static unsigned int
-sleep(unsigned int t)
+static int
+_clock_gettime(pTHX_ clockid_t clock_id, struct timespec *tp)
{
- Sleep(t*1000);
+ FT_t ft;
+
+ switch (clock_id) {
+ case CLOCK_REALTIME: {
+ FT_t ft;
+
+ GetSystemTimePreciseAsFileTime(&ft.ft_val);
+ tp->tv_sec = (time_t)((ft.ft_i64 - EPOCH_BIAS) / IV_1E7);
+ tp->tv_nsec = (long)((ft.ft_i64 % IV_1E7) * 100);
+ break;
+ }
+ case CLOCK_MONOTONIC: {
+ unsigned __int64 freq, ticks;
+
+ QueryPerformanceFrequency((LARGE_INTEGER*)&freq);
+ QueryPerformanceCounter((LARGE_INTEGER*)&ticks);
+
+ tp->tv_sec = (time_t)(ticks / freq);
+ tp->tv_nsec = (long)((IV_1E9 * (ticks % freq)) / freq);
+ break;
+ }
+ default:
+ errno = EINVAL;
+ return 1;
+ }
+
return 0;
}
-#endif
+
+static int
+_clock_getres(clockid_t clock_id, struct timespec *tp)
+{
+ unsigned __int64 freq, qpc_res_ns;
+
+ QueryPerformanceFrequency((LARGE_INTEGER*)&freq);
+ qpc_res_ns = IV_1E9 > freq ? IV_1E9 / freq : 1;
+
+ switch (clock_id) {
+ case CLOCK_REALTIME:
+ tp->tv_sec = 0;
+ /* the resolution can't be smaller than 100ns because our implementation
+ * of CLOCK_REALTIME is using FILETIME internally */
+ tp->tv_nsec = (long)(qpc_res_ns > 100 ? qpc_res_ns : 100);
+ break;
+
+ case CLOCK_MONOTONIC:
+ tp->tv_sec = 0;
+ tp->tv_nsec = (long)qpc_res_ns;
+ break;
+
+ default:
+ errno = EINVAL;
+ return 1;
+ }
+
+ return 0;
+}
+
+#endif /* #if defined(WIN32) || defined(CYGWIN_WITH_W32API) */
#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
+# 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
+# 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
+# ifdef __VAX
static long base_adjust[2]={0L,0L};
-#else
+# else
static __int64 base_adjust=0;
-#endif
+# 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
+ This code gleefully swiped from VMS.C
*/
/* method used to handle UTC conversions:
@@ -282,115 +368,115 @@ static __int64 base_adjust=0;
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 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;
+ struct tm *rsltmp;
- if ((rsltmp = localtime(&loc)) == NULL) return -1;
- loc -= utc_offset_secs;
- if (rsltmp->tm_isdst) loc -= 3600;
- return loc;
+ 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;
+ struct tm *rsltmp;
- utc += utc_offset_secs;
- if ((rsltmp = localtime(&utc)) == NULL) return -1;
- if (rsltmp->tm_isdst) utc += 3600;
- return utc;
+ 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 _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))))
+# 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)
+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 */
+ struct tm *tm_p;
- gmtime_emulation_type++;
- if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
- char off[LNM$C_NAMLENGTH+1];;
+ 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 (!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);
+ 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;
+ 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
-/*
+ 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;
+ 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
+# 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;
+ tp->tv_sec = ret;
+ return -1;
}
- }
+ }
- ret=sys$gettim(&quad); /* Get VMS system time */
- if ((1 && ret) == 1) {
-#ifdef __VAX
+ 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;
@@ -401,27 +487,27 @@ gettimeofday (struct timeval *tp, void *tpz)
lib$ediv(&div_100ns_to_usecs,&quad1,&quo1,&rem1);
tp->tv_sec = quo; /* Whole seconds */
tp->tv_usec = quo1; /* Micro-seconds */
-#else
+# 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 {
+# 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;
+ }
+# 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
+#endif /* #if !defined(HAS_GETTIMEOFDAY) && defined(VMS) */
/* Do not use H A S _ N A N O S L E E P
@@ -430,8 +516,8 @@ gettimeofday (struct timeval *tp, void *tpz)
* (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 */
+# define HAS_USLEEP
+# define usleep hrt_usleep /* could conflict with ncurses for static build */
static void
hrt_usleep(unsigned long usec) /* This is used to emulate usleep. */
@@ -445,9 +531,9 @@ hrt_usleep(unsigned long usec) /* This is used to emulate usleep. */
#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 */
+# ifndef SELECT_IS_BROKEN
+# define HAS_USLEEP
+# define usleep hrt_usleep /* could conflict with ncurses for static build */
static void
hrt_usleep(unsigned long usec)
@@ -456,14 +542,14 @@ hrt_usleep(unsigned long usec)
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);
+ (Select_fd_set_t)NULL, &tv);
}
-#endif
+# 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 */
+# define HAS_USLEEP
+# define usleep hrt_usleep /* could conflict with ncurses for static build */
static void
hrt_usleep(unsigned long usec)
@@ -475,8 +561,8 @@ hrt_usleep(unsigned long usec)
#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 */
+# define HAS_USLEEP
+# define usleep hrt_usleep /* could conflict with ncurses for static build */
static void
hrt_usleep(unsigned long usec)
@@ -492,34 +578,34 @@ hrt_usleep(unsigned long usec)
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);
+ 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);
}
#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 */
+# 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
+# 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>
+# 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))
+# define VMSERR(s) (!((s)&1))
static void
us_to_VMS(useconds_t mseconds, unsigned long v[])
@@ -567,13 +653,13 @@ typedef struct _ualarm {
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
+# define UAL_NULL 0
+# define UAL_SET 1
+# define UAL_CLEAR 2
+# define UAL_ACTIVE 4
static void ualarm_AST(Alarm *a);
-static int
+static int
vms_ualarm(int mseconds, int interval)
{
Alarm *a, abase;
@@ -605,7 +691,7 @@ vms_ualarm(int mseconds, int interval)
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;
@@ -621,7 +707,7 @@ vms_ualarm(int mseconds, int interval)
if (interval) {
us_to_VMS(interval, a->interval);
a->repeat = 1;
- } else
+ } else
a->repeat = 0;
iss = sys$clref(alarm_ef);
@@ -633,7 +719,7 @@ vms_ualarm(int mseconds, int interval)
iss = sys$waitfr(alarm_ef);
if (VMSERR(iss)) lib$signal(iss);
- if (a->function == UAL_ACTIVE)
+ if (a->function == UAL_ACTIVE)
return VMS_to_us(a->remain);
else
return 0;
@@ -658,7 +744,7 @@ ualarm_AST(Alarm *a)
iss = lib$subx(a0->remain, now, a->remain);
if (VMSERR(iss)) lib$signal(iss);
- if (a->remain[1] & 0x80000000)
+ if (a->remain[1] & 0x80000000)
a->remain[0] = a->remain[1] = 0;
}
@@ -709,24 +795,24 @@ ualarm_AST(Alarm *a)
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;
+ 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;
+# 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 */
@@ -734,31 +820,31 @@ myNVtime()
static void
hrstatns(UV *atime_nsec, UV *mtime_nsec, UV *ctime_nsec)
{
- dTHX;
+ 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;
+ *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;
+ *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;
+ *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;
+ *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;
+ *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;
+ *atime_nsec = 0;
+ *mtime_nsec = 0;
+ *ctime_nsec = 0;
#endif /* !TIME_HIRES_STAT */
}
@@ -770,157 +856,157 @@ hrstatns(UV *atime_nsec, UV *mtime_nsec, UV *ctime_nsec)
defined(TIME_HIRES_CLOCK_GETRES_EMULATION) || \
defined(TIME_HIRES_CLOCK_NANOSLEEP_EMULATION))
-#ifndef CLOCK_REALTIME
-# define CLOCK_REALTIME 0x01
-# define CLOCK_MONOTONIC 0x02
-#endif
+# ifndef CLOCK_REALTIME
+# define CLOCK_REALTIME 0x01
+# define CLOCK_MONOTONIC 0x02
+# endif
-#ifndef TIMER_ABSTIME
-# define TIMER_ABSTIME 0x01
-#endif
+# ifndef TIMER_ABSTIME
+# define TIMER_ABSTIME 0x01
+# endif
-#ifdef USE_ITHREADS
-# define PERL_DARWIN_MUTEX
-#endif
+# ifdef USE_ITHREADS
+# define PERL_DARWIN_MUTEX
+# endif
-#ifdef PERL_DARWIN_MUTEX
+# ifdef PERL_DARWIN_MUTEX
STATIC perl_mutex darwin_time_mutex;
-#endif
+# endif
-#include <mach/mach_time.h>
+# include <mach/mach_time.h>
static uint64_t absolute_time_init;
static mach_timebase_info_data_t timebase_info;
static struct timespec timespec_init;
static int darwin_time_init() {
- struct timeval tv;
- int success = 1;
-#ifdef PERL_DARWIN_MUTEX
- MUTEX_LOCK(&darwin_time_mutex);
-#endif
- if (absolute_time_init == 0) {
- /* mach_absolute_time() cannot fail */
- absolute_time_init = mach_absolute_time();
- success = mach_timebase_info(&timebase_info) == KERN_SUCCESS;
- if (success) {
- success = gettimeofday(&tv, NULL) == 0;
- if (success) {
- timespec_init.tv_sec = tv.tv_sec;
- timespec_init.tv_nsec = tv.tv_usec * 1000;
- }
+ struct timeval tv;
+ int success = 1;
+# ifdef PERL_DARWIN_MUTEX
+ MUTEX_LOCK(&darwin_time_mutex);
+# endif
+ if (absolute_time_init == 0) {
+ /* mach_absolute_time() cannot fail */
+ absolute_time_init = mach_absolute_time();
+ success = mach_timebase_info(&timebase_info) == KERN_SUCCESS;
+ if (success) {
+ success = gettimeofday(&tv, NULL) == 0;
+ if (success) {
+ timespec_init.tv_sec = tv.tv_sec;
+ timespec_init.tv_nsec = tv.tv_usec * 1000;
+ }
+ }
}
- }
-#ifdef PERL_DARWIN_MUTEX
- MUTEX_UNLOCK(&darwin_time_mutex);
-#endif
- return success;
+# ifdef PERL_DARWIN_MUTEX
+ MUTEX_UNLOCK(&darwin_time_mutex);
+# endif
+ return success;
}
-#ifdef TIME_HIRES_CLOCK_GETTIME_EMULATION
+# ifdef TIME_HIRES_CLOCK_GETTIME_EMULATION
static int th_clock_gettime(clockid_t clock_id, struct timespec *ts) {
- if (darwin_time_init() && timebase_info.denom) {
- switch (clock_id) {
- case CLOCK_REALTIME:
- {
- uint64_t nanos =
- ((mach_absolute_time() - absolute_time_init) *
- (uint64_t)timebase_info.numer) / (uint64_t)timebase_info.denom;
- ts->tv_sec = timespec_init.tv_sec + nanos / IV_1E9;
- ts->tv_nsec = timespec_init.tv_nsec + nanos % IV_1E9;
- return 0;
- }
-
- case CLOCK_MONOTONIC:
- {
- uint64_t nanos =
- (mach_absolute_time() *
- (uint64_t)timebase_info.numer) / (uint64_t)timebase_info.denom;
- ts->tv_sec = nanos / IV_1E9;
- ts->tv_nsec = nanos - ts->tv_sec * IV_1E9;
- return 0;
- }
-
- default:
- break;
+ if (darwin_time_init() && timebase_info.denom) {
+ switch (clock_id) {
+ case CLOCK_REALTIME:
+ {
+ uint64_t nanos =
+ ((mach_absolute_time() - absolute_time_init) *
+ (uint64_t)timebase_info.numer) / (uint64_t)timebase_info.denom;
+ ts->tv_sec = timespec_init.tv_sec + nanos / IV_1E9;
+ ts->tv_nsec = timespec_init.tv_nsec + nanos % IV_1E9;
+ return 0;
+ }
+
+ case CLOCK_MONOTONIC:
+ {
+ uint64_t nanos =
+ (mach_absolute_time() *
+ (uint64_t)timebase_info.numer) / (uint64_t)timebase_info.denom;
+ ts->tv_sec = nanos / IV_1E9;
+ ts->tv_nsec = nanos - ts->tv_sec * IV_1E9;
+ return 0;
+ }
+
+ default:
+ break;
+ }
}
- }
- SETERRNO(EINVAL, LIB_INVARG);
- return -1;
+ SETERRNO(EINVAL, LIB_INVARG);
+ return -1;
}
-#define clock_gettime(clock_id, ts) th_clock_gettime((clock_id), (ts))
+# define clock_gettime(clock_id, ts) th_clock_gettime((clock_id), (ts))
-#endif /* TIME_HIRES_CLOCK_GETTIME_EMULATION */
+# endif /* TIME_HIRES_CLOCK_GETTIME_EMULATION */
-#ifdef TIME_HIRES_CLOCK_GETRES_EMULATION
+# ifdef TIME_HIRES_CLOCK_GETRES_EMULATION
static int th_clock_getres(clockid_t clock_id, struct timespec *ts) {
- if (darwin_time_init() && timebase_info.denom) {
- switch (clock_id) {
- case CLOCK_REALTIME:
- case CLOCK_MONOTONIC:
- ts->tv_sec = 0;
- /* In newer kernels both the numer and denom are one,
- * resulting in conversion factor of one, which is of
- * course unrealistic. */
- ts->tv_nsec = timebase_info.numer / timebase_info.denom;
- return 0;
- default:
- break;
+ if (darwin_time_init() && timebase_info.denom) {
+ switch (clock_id) {
+ case CLOCK_REALTIME:
+ case CLOCK_MONOTONIC:
+ ts->tv_sec = 0;
+ /* In newer kernels both the numer and denom are one,
+ * resulting in conversion factor of one, which is of
+ * course unrealistic. */
+ ts->tv_nsec = timebase_info.numer / timebase_info.denom;
+ return 0;
+ default:
+ break;
+ }
}
- }
- SETERRNO(EINVAL, LIB_INVARG);
- return -1;
+ SETERRNO(EINVAL, LIB_INVARG);
+ return -1;
}
-#define clock_getres(clock_id, ts) th_clock_getres((clock_id), (ts))
-#endif /* TIME_HIRES_CLOCK_GETRES_EMULATION */
+# define clock_getres(clock_id, ts) th_clock_getres((clock_id), (ts))
+# endif /* TIME_HIRES_CLOCK_GETRES_EMULATION */
-#ifdef TIME_HIRES_CLOCK_NANOSLEEP_EMULATION
+# ifdef TIME_HIRES_CLOCK_NANOSLEEP_EMULATION
static int th_clock_nanosleep(clockid_t clock_id, int flags,
- const struct timespec *rqtp,
- struct timespec *rmtp) {
- if (darwin_time_init()) {
- switch (clock_id) {
- case CLOCK_REALTIME:
- case CLOCK_MONOTONIC:
- {
- uint64_t nanos = rqtp->tv_sec * IV_1E9 + rqtp->tv_nsec;
- int success;
- if ((flags & TIMER_ABSTIME)) {
- uint64_t back =
- timespec_init.tv_sec * IV_1E9 + timespec_init.tv_nsec;
- nanos = nanos > back ? nanos - back : 0;
- }
- success =
- mach_wait_until(mach_absolute_time() + nanos) == KERN_SUCCESS;
-
- /* In the relative sleep, the rmtp should be filled in with
- * the 'unused' part of the rqtp in case the sleep gets
- * interrupted by a signal. But it is unknown how signals
- * interact with mach_wait_until(). In the absolute sleep,
- * the rmtp should stay untouched. */
- rmtp->tv_sec = 0;
- rmtp->tv_nsec = 0;
-
- return success;
- }
+ const struct timespec *rqtp,
+ struct timespec *rmtp) {
+ if (darwin_time_init()) {
+ switch (clock_id) {
+ case CLOCK_REALTIME:
+ case CLOCK_MONOTONIC:
+ {
+ uint64_t nanos = rqtp->tv_sec * IV_1E9 + rqtp->tv_nsec;
+ int success;
+ if ((flags & TIMER_ABSTIME)) {
+ uint64_t back =
+ timespec_init.tv_sec * IV_1E9 + timespec_init.tv_nsec;
+ nanos = nanos > back ? nanos - back : 0;
+ }
+ success =
+ mach_wait_until(mach_absolute_time() + nanos) == KERN_SUCCESS;
+
+ /* In the relative sleep, the rmtp should be filled in with
+ * the 'unused' part of the rqtp in case the sleep gets
+ * interrupted by a signal. But it is unknown how signals
+ * interact with mach_wait_until(). In the absolute sleep,
+ * the rmtp should stay untouched. */
+ rmtp->tv_sec = 0;
+ rmtp->tv_nsec = 0;
+
+ return success;
+ }
- default:
- break;
+ default:
+ break;
+ }
}
- }
- SETERRNO(EINVAL, LIB_INVARG);
- return -1;
+ SETERRNO(EINVAL, LIB_INVARG);
+ return -1;
}
-#define clock_nanosleep(clock_id, flags, rqtp, rmtp) \
+# define clock_nanosleep(clock_id, flags, rqtp, rmtp) \
th_clock_nanosleep((clock_id), (flags), (rqtp), (rmtp))
-#endif /* TIME_HIRES_CLOCK_NANOSLEEP_EMULATION */
+# endif /* TIME_HIRES_CLOCK_NANOSLEEP_EMULATION */
#endif /* PERL_DARWIN */
@@ -937,25 +1023,25 @@ static int th_clock_nanosleep(clockid_t clock_id, int flags,
* are always available.
*/
#ifndef __has_builtin
-# define __has_builtin(x) 0 /* non-clang */
+# define __has_builtin(x) 0 /* non-clang */
#endif
#ifdef HAS_FUTIMENS
-# if defined(PERL_DARWIN) && __has_builtin(__builtin_available)
-# define FUTIMENS_AVAILABLE __builtin_available(macOS 10.13, *)
-# else
-# define FUTIMENS_AVAILABLE 1
-# endif
+# if defined(PERL_DARWIN) && __has_builtin(__builtin_available)
+# define FUTIMENS_AVAILABLE __builtin_available(macOS 10.13, *)
+# else
+# define FUTIMENS_AVAILABLE 1
+# endif
#else
-# define FUTIMENS_AVAILABLE 0
+# define FUTIMENS_AVAILABLE 0
#endif
#ifdef HAS_UTIMENSAT
-# if defined(PERL_DARWIN) && __has_builtin(__builtin_available)
-# define UTIMENSAT_AVAILABLE __builtin_available(macOS 10.13, *)
-# else
-# define UTIMENSAT_AVAILABLE 1
-# endif
+# if defined(PERL_DARWIN) && __has_builtin(__builtin_available)
+# define UTIMENSAT_AVAILABLE __builtin_available(macOS 10.13, *)
+# else
+# define UTIMENSAT_AVAILABLE 1
+# endif
#else
-# define UTIMENSAT_AVAILABLE 0
+# define UTIMENSAT_AVAILABLE 0
#endif
#include "const-c.inc"
@@ -976,23 +1062,23 @@ nanosleep_init(NV nsec,
static NV
nsec_without_unslept(struct timespec *sleepfor,
const struct timespec *unslept) {
- if (sleepfor->tv_sec >= unslept->tv_sec) {
- sleepfor->tv_sec -= unslept->tv_sec;
- if (sleepfor->tv_nsec >= unslept->tv_nsec) {
- sleepfor->tv_nsec -= unslept->tv_nsec;
- } else if (sleepfor->tv_sec > 0) {
- sleepfor->tv_sec--;
- sleepfor->tv_nsec += IV_1E9;
- sleepfor->tv_nsec -= unslept->tv_nsec;
+ if (sleepfor->tv_sec >= unslept->tv_sec) {
+ sleepfor->tv_sec -= unslept->tv_sec;
+ if (sleepfor->tv_nsec >= unslept->tv_nsec) {
+ sleepfor->tv_nsec -= unslept->tv_nsec;
+ } else if (sleepfor->tv_sec > 0) {
+ sleepfor->tv_sec--;
+ sleepfor->tv_nsec += IV_1E9;
+ sleepfor->tv_nsec -= unslept->tv_nsec;
+ } else {
+ sleepfor->tv_sec = 0;
+ sleepfor->tv_nsec = 0;
+ }
} else {
- sleepfor->tv_sec = 0;
- sleepfor->tv_nsec = 0;
+ sleepfor->tv_sec = 0;
+ sleepfor->tv_nsec = 0;
}
- } else {
- sleepfor->tv_sec = 0;
- sleepfor->tv_nsec = 0;
- }
- return ((NV)sleepfor->tv_sec) * NV_1E9 + ((NV)sleepfor->tv_nsec);
+ return ((NV)sleepfor->tv_sec) * NV_1E9 + ((NV)sleepfor->tv_nsec);
}
#endif
@@ -1000,17 +1086,17 @@ nsec_without_unslept(struct timespec *sleepfor,
/* In case Perl and/or Devel::PPPort are too old, minimally emulate
* IS_SAFE_PATHNAME() (which looks for zero bytes in the pathname). */
#ifndef IS_SAFE_PATHNAME
-#if PERL_VERSION >= 12 /* Perl_ck_warner is 5.10.0 -> */
-#ifdef WARN_SYSCALLS
-#define WARNEMUCAT WARN_SYSCALLS /* 5.22.0 -> */
-#else
-#define WARNEMUCAT WARN_MISC
-#endif
-#define WARNEMU(opname) Perl_ck_warner(aTHX_ packWARN(WARNEMUCAT), "Invalid \\0 character in pathname for %s",opname)
-#else
-#define WARNEMU(opname) Perl_warn(aTHX_ "Invalid \\0 character in pathname for %s",opname)
-#endif
-#define IS_SAFE_PATHNAME(pv, len, opname) (((len)>1)&&memchr((pv), 0, (len)-1)?(SETERRNO(ENOENT, LIB_INVARG),WARNEMU(opname),FALSE):(TRUE))
+# if PERL_VERSION >= 12 /* Perl_ck_warner is 5.10.0 -> */
+# ifdef WARN_SYSCALLS
+# define WARNEMUCAT WARN_SYSCALLS /* 5.22.0 -> */
+# else
+# define WARNEMUCAT WARN_MISC
+# endif
+# define WARNEMU(opname) Perl_ck_warner(aTHX_ packWARN(WARNEMUCAT), "Invalid \\0 character in pathname for %s",opname)
+# else
+# define WARNEMU(opname) Perl_warn(aTHX_ "Invalid \\0 character in pathname for %s",opname)
+# endif
+# define IS_SAFE_PATHNAME(pv, len, opname) (((len)>1)&&memchr((pv), 0, (len)-1)?(SETERRNO(ENOENT, LIB_INVARG),WARNEMU(opname),FALSE):(TRUE))
#endif
MODULE = Time::HiRes PACKAGE = Time::HiRes
@@ -1018,33 +1104,31 @@ MODULE = Time::HiRes PACKAGE = Time::HiRes
PROTOTYPES: ENABLE
BOOT:
-{
+ {
#ifdef MY_CXT_KEY
- MY_CXT_INIT;
+ 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
+#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
#if defined(PERL_DARWIN)
# if defined(USE_ITHREADS) && defined(PERL_DARWIN_MUTEX)
- MUTEX_INIT(&darwin_time_mutex);
+ MUTEX_INIT(&darwin_time_mutex);
# endif
#endif
-}
+ }
#if defined(USE_ITHREADS) && defined(MY_CXT_KEY)
void
CLONE(...)
CODE:
- MY_CXT_CLONE;
+ MY_CXT_CLONE;
#endif
@@ -1054,122 +1138,125 @@ INCLUDE: const-xs.inc
NV
usleep(useconds)
- NV useconds
- PREINIT:
- struct timeval Ta, Tb;
- CODE:
- gettimeofday(&Ta, NULL);
- if (items > 0) {
- if (useconds >= NV_1E6) {
- IV seconds = (IV) (useconds / NV_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 -= NV_1E6 * seconds;
- }
- } else if (useconds < 0.0)
- croak("Time::HiRes::usleep(%" NVgf
+ NV useconds
+ PREINIT:
+ struct timeval Ta, Tb;
+ CODE:
+ gettimeofday(&Ta, NULL);
+ if (items > 0) {
+ if (useconds >= NV_1E6) {
+ IV seconds = (IV) (useconds / NV_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 -= NV_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 = NV_1E6*(Tb.tv_sec-Ta.tv_sec)+(NV)((IV)Tb.tv_usec-(IV)Ta.tv_usec);
- OUTPUT:
- RETVAL
+ usleep((U32)useconds);
+ } else
+ PerlProc_pause();
-#if defined(TIME_HIRES_NANOSLEEP)
+ 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_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
+ NV nsec
+ PREINIT:
+ struct timespec sleepfor, unslept;
+ CODE:
+ if (nsec < 0.0)
+ croak("Time::HiRes::nanosleep(%" NVgf
"): negative time not invented yet", nsec);
nanosleep_init(nsec, &sleepfor, &unslept);
- if (nanosleep(&sleepfor, &unslept) == 0) {
- RETVAL = nsec;
- } else {
+ if (nanosleep(&sleepfor, &unslept) == 0) {
+ RETVAL = nsec;
+ } else {
RETVAL = nsec_without_unslept(&sleepfor, &unslept);
- }
+ }
OUTPUT:
- RETVAL
+ RETVAL
-#else /* #if defined(TIME_HIRES_NANOSLEEP) */
+# else /* #if defined(TIME_HIRES_NANOSLEEP) */
NV
nanosleep(nsec)
- NV nsec
+ NV nsec
CODE:
- PERL_UNUSED_ARG(nsec);
+ PERL_UNUSED_ARG(nsec);
croak("Time::HiRes::nanosleep(): unimplemented in this platform");
RETVAL = 0.0;
OUTPUT:
- RETVAL
+ RETVAL
-#endif /* #if defined(TIME_HIRES_NANOSLEEP) */
+# 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
+ 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);
+ } 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
+ OUTPUT:
+ RETVAL
#else /* #if defined(HAS_USLEEP) && defined(HAS_GETTIMEOFDAY) */
NV
usleep(useconds)
- NV useconds
+ NV useconds
CODE:
- PERL_UNUSED_ARG(useconds);
+ PERL_UNUSED_ARG(useconds);
croak("Time::HiRes::usleep(): unimplemented in this platform");
RETVAL = 0.0;
OUTPUT:
- RETVAL
+ RETVAL
#endif /* #if defined(HAS_USLEEP) && defined(HAS_GETTIMEOFDAY) */
@@ -1177,241 +1264,204 @@ usleep(useconds)
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
+ 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
+ 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
+ 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
+
+ {
+ 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
+
+ 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
+ RETVAL = (NV)ualarm( useconds, uinterval ) / NV_1E6;
+# endif
+ }
-#else
+ OUTPUT:
+ RETVAL
+
+#else /* #ifdef HAS_UALARM */
int
ualarm(useconds,interval=0)
- int useconds
- int interval
+ int useconds
+ int interval
CODE:
- PERL_UNUSED_ARG(useconds);
- PERL_UNUSED_ARG(interval);
+ PERL_UNUSED_ARG(useconds);
+ PERL_UNUSED_ARG(interval);
croak("Time::HiRes::ualarm(): unimplemented in this platform");
- RETVAL = -1;
+ RETVAL = -1;
OUTPUT:
- RETVAL
+ RETVAL
NV
alarm(seconds,interval=0)
- NV seconds
- NV interval
+ NV seconds
+ NV interval
CODE:
- PERL_UNUSED_ARG(seconds);
- PERL_UNUSED_ARG(interval);
+ PERL_UNUSED_ARG(seconds);
+ PERL_UNUSED_ARG(interval);
croak("Time::HiRes::alarm(): unimplemented in this platform");
- RETVAL = 0.0;
+ RETVAL = 0.0;
OUTPUT:
- RETVAL
+ 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:
+ PREINIT:
struct timeval Tp;
- PPCODE:
- int status;
+ 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))));
- }
+ 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:
+ PREINIT:
struct timeval Tp;
- CODE:
- int status;
+ CODE:
+ int status;
status = gettimeofday (&Tp, NULL);
- if (status == 0) {
+ if (status == 0) {
RETVAL = Tp.tv_sec + (Tp.tv_usec / NV_1E6);
- } else {
- RETVAL = -1.0;
- }
- OUTPUT:
- RETVAL
+ } 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))
+# 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
+ int which
+ NV seconds
+ NV interval
PREINIT:
- struct itimerval newit;
- struct itimerval oldit;
+ struct itimerval newit;
+ struct itimerval oldit;
PPCODE:
- if (seconds < 0.0 || interval < 0.0)
- croak("Time::HiRes::setitimer(%" IVdf ", %" NVgf ", %" NVgf
+ 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);
+ 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
*/
GCC_DIAG_IGNORE_STMT(-Wc++-compat);
- 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))));
- }
- }
+ 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))));
+ }
+ }
GCC_DIAG_RESTORE_STMT;
void
getitimer(which)
- int which
+ int which
PREINIT:
- struct itimerval nowit;
+ 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
*/
GCC_DIAG_IGNORE_STMT(-Wc++-compat);
- 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))));
- }
- }
+ 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))));
+ }
+ }
GCC_DIAG_RESTORE_STMT;
#endif /* #if defined(HAS_GETITIMER) && defined(HAS_SETITIMER) */
@@ -1422,82 +1472,83 @@ I32
utime(accessed, modified, ...)
PROTOTYPE: $$@
PREINIT:
- SV* accessed;
- SV* modified;
- SV* file;
+ SV* accessed;
+ SV* modified;
+ SV* file;
- struct timespec utbuf[2];
- struct timespec *utbufp = utbuf;
- int tot;
+ struct timespec utbuf[2];
+ struct timespec *utbufp = utbuf;
+ int tot;
CODE:
- accessed = ST(0);
- modified = ST(1);
- items -= 2;
- tot = 0;
-
- if ( accessed == &PL_sv_undef && modified == &PL_sv_undef )
- utbufp = NULL;
- else {
- if (SvNV(accessed) < 0.0 || SvNV(modified) < 0.0)
- croak("Time::HiRes::utime(%" NVgf ", %" NVgf
- "): negative time not invented yet",
- SvNV(accessed), SvNV(modified));
- Zero(&utbuf, sizeof utbuf, char);
-
- utbuf[0].tv_sec = (Time_t)SvNV(accessed); /* time accessed */
- utbuf[0].tv_nsec = (long)(
- (SvNV(accessed) - (NV)utbuf[0].tv_sec)
- * NV_1E9 + (NV)0.5);
-
- utbuf[1].tv_sec = (Time_t)SvNV(modified); /* time modified */
- utbuf[1].tv_nsec = (long)(
- (SvNV(modified) - (NV)utbuf[1].tv_sec)
- * NV_1E9 + (NV)0.5);
- }
-
- while (items > 0) {
- file = POPs; items--;
-
- if (SvROK(file) && GvIO(SvRV(file)) && IoIFP(sv_2io(SvRV(file)))) {
- int fd = PerlIO_fileno(IoIFP(sv_2io(file)));
- if (fd < 0) {
- SETERRNO(EBADF,RMS_IFI);
- } else {
-#ifdef HAS_FUTIMENS
- if (FUTIMENS_AVAILABLE) {
- if (futimens(fd, utbufp) == 0) {
- tot++;
- }
- } else {
- croak("futimens unimplemented in this platform");
- }
-#else /* HAS_FUTIMENS */
- croak("futimens unimplemented in this platform");
-#endif /* HAS_FUTIMENS */
+ accessed = ST(0);
+ modified = ST(1);
+ items -= 2;
+ tot = 0;
+
+ if ( accessed == &PL_sv_undef && modified == &PL_sv_undef )
+ utbufp = NULL;
+ else {
+ if (SvNV(accessed) < 0.0 || SvNV(modified) < 0.0)
+ croak("Time::HiRes::utime(%" NVgf ", %" NVgf
+ "): negative time not invented yet",
+ SvNV(accessed), SvNV(modified));
+ Zero(&utbuf, sizeof utbuf, char);
+
+ utbuf[0].tv_sec = (Time_t)SvNV(accessed); /* time accessed */
+ utbuf[0].tv_nsec = (long)(
+ (SvNV(accessed) - (NV)utbuf[0].tv_sec)
+ * NV_1E9 + (NV)0.5);
+
+ utbuf[1].tv_sec = (Time_t)SvNV(modified); /* time modified */
+ utbuf[1].tv_nsec = (long)(
+ (SvNV(modified) - (NV)utbuf[1].tv_sec)
+ * NV_1E9 + (NV)0.5);
+ }
+
+ while (items > 0) {
+ file = POPs; items--;
+
+ if (SvROK(file) && GvIO(SvRV(file)) && IoIFP(sv_2io(SvRV(file)))) {
+ int fd = PerlIO_fileno(IoIFP(sv_2io(file)));
+ if (fd < 0) {
+ SETERRNO(EBADF,RMS_IFI);
+ } else {
+# ifdef HAS_FUTIMENS
+ if (FUTIMENS_AVAILABLE) {
+ if (futimens(fd, utbufp) == 0) {
+ tot++;
}
- }
- else {
-#ifdef HAS_UTIMENSAT
- if (UTIMENSAT_AVAILABLE) {
+ } else {
+ croak("futimens unimplemented in this platform");
+ }
+# else /* HAS_FUTIMENS */
+ croak("futimens unimplemented in this platform");
+# endif /* HAS_FUTIMENS */
+ }
+ }
+ else {
+# ifdef HAS_UTIMENSAT
+ if (UTIMENSAT_AVAILABLE) {
STRLEN len;
char * name = SvPV(file, len);
if (IS_SAFE_PATHNAME(name, len, "utime") &&
utimensat(AT_FDCWD, name, utbufp, 0) == 0) {
- tot++;
+
+ tot++;
}
- } else {
+ } else {
croak("utimensat unimplemented in this platform");
- }
-#else /* HAS_UTIMENSAT */
- croak("utimensat unimplemented in this platform");
-#endif /* HAS_UTIMENSAT */
- }
- } /* while items */
- RETVAL = tot;
+ }
+# else /* HAS_UTIMENSAT */
+ croak("utimensat unimplemented in this platform");
+# endif /* HAS_UTIMENSAT */
+ }
+ } /* while items */
+ RETVAL = tot;
OUTPUT:
- RETVAL
+ RETVAL
#else /* #if defined(TIME_HIRES_UTIME) */
@@ -1507,7 +1558,7 @@ utime(accessed, modified, ...)
croak("Time::HiRes::utime(): unimplemented in this platform");
RETVAL = 0;
OUTPUT:
- RETVAL
+ RETVAL
#endif /* #if defined(TIME_HIRES_UTIME) */
@@ -1515,32 +1566,32 @@ utime(accessed, modified, ...)
NV
clock_gettime(clock_id = CLOCK_REALTIME)
- clockid_t clock_id
+ clockid_t clock_id
PREINIT:
- struct timespec ts;
- int status = -1;
+ 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;
+# 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
+ RETVAL
#else /* if defined(TIME_HIRES_CLOCK_GETTIME) */
NV
clock_gettime(clock_id = 0)
- clockid_t clock_id
+ clockid_t clock_id
CODE:
- PERL_UNUSED_ARG(clock_id);
+ PERL_UNUSED_ARG(clock_id);
croak("Time::HiRes::clock_gettime(): unimplemented in this platform");
RETVAL = 0.0;
OUTPUT:
- RETVAL
+ RETVAL
#endif /* #if defined(TIME_HIRES_CLOCK_GETTIME) */
@@ -1548,32 +1599,32 @@ clock_gettime(clock_id = 0)
NV
clock_getres(clock_id = CLOCK_REALTIME)
- clockid_t clock_id
+ clockid_t clock_id
PREINIT:
- int status = -1;
- struct timespec ts;
+ 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;
+# 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
+ RETVAL
#else /* if defined(TIME_HIRES_CLOCK_GETRES) */
NV
clock_getres(clock_id = 0)
- clockid_t clock_id
+ clockid_t clock_id
CODE:
- PERL_UNUSED_ARG(clock_id);
+ PERL_UNUSED_ARG(clock_id);
croak("Time::HiRes::clock_getres(): unimplemented in this platform");
RETVAL = 0.0;
OUTPUT:
- RETVAL
+ RETVAL
#endif /* #if defined(TIME_HIRES_CLOCK_GETRES) */
@@ -1581,39 +1632,39 @@ clock_getres(clock_id = 0)
NV
clock_nanosleep(clock_id, nsec, flags = 0)
- clockid_t clock_id
- NV nsec
- int flags
+ clockid_t clock_id
+ NV nsec
+ int flags
PREINIT:
- struct timespec sleepfor, unslept;
+ struct timespec sleepfor, unslept;
CODE:
- if (nsec < 0.0)
- croak("Time::HiRes::clock_nanosleep(..., %" NVgf
+ if (nsec < 0.0)
+ croak("Time::HiRes::clock_nanosleep(..., %" NVgf
"): negative time not invented yet", nsec);
nanosleep_init(nsec, &sleepfor, &unslept);
- if (clock_nanosleep(clock_id, flags, &sleepfor, &unslept) == 0) {
- RETVAL = nsec;
- } else {
+ if (clock_nanosleep(clock_id, flags, &sleepfor, &unslept) == 0) {
+ RETVAL = nsec;
+ } else {
RETVAL = nsec_without_unslept(&sleepfor, &unslept);
- }
+ }
OUTPUT:
- RETVAL
+ RETVAL
#else /* if defined(TIME_HIRES_CLOCK_NANOSLEEP) && defined(TIMER_ABSTIME) */
NV
clock_nanosleep(clock_id, nsec, flags = 0)
- clockid_t clock_id
- NV nsec
- int flags
+ clockid_t clock_id
+ NV nsec
+ int flags
CODE:
- PERL_UNUSED_ARG(clock_id);
- PERL_UNUSED_ARG(nsec);
- PERL_UNUSED_ARG(flags);
+ 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
+ RETVAL
#endif /* #if defined(TIME_HIRES_CLOCK_NANOSLEEP) && defined(TIMER_ABSTIME) */
@@ -1622,13 +1673,13 @@ clock_nanosleep(clock_id, nsec, flags = 0)
NV
clock()
PREINIT:
- clock_t clocks;
+ clock_t clocks;
CODE:
- clocks = clock();
- RETVAL = clocks == (clock_t) -1 ? (clock_t) -1 : (NV)clocks / (NV)CLOCKS_PER_SEC;
+ clocks = clock();
+ RETVAL = clocks == (clock_t) -1 ? (clock_t) -1 : (NV)clocks / (NV)CLOCKS_PER_SEC;
OUTPUT:
- RETVAL
+ RETVAL
#else /* if defined(TIME_HIRES_CLOCK) && defined(CLOCKS_PER_SEC) */
@@ -1638,7 +1689,7 @@ clock()
croak("Time::HiRes::clock(): unimplemented in this platform");
RETVAL = 0.0;
OUTPUT:
- RETVAL
+ RETVAL
#endif /* #if defined(TIME_HIRES_CLOCK) && defined(CLOCKS_PER_SEC) */
@@ -1646,39 +1697,39 @@ void
stat(...)
PROTOTYPE: ;$
PREINIT:
- OP fakeop;
- int nret;
+ OP fakeop;
+ int nret;
ALIAS:
- Time::HiRes::lstat = 1
+ 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 + (NV) atime_nsec / NV_1E9));
- if (mtime_nsec)
- ST( 9) = sv_2mortal(newSVnv(mtime + (NV) mtime_nsec / NV_1E9));
- if (ctime_nsec)
- ST(10) = sv_2mortal(newSVnv(ctime + (NV) ctime_nsec / NV_1E9));
- }
- XSRETURN(nret);
+ 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 + (NV) atime_nsec / NV_1E9));
+ if (mtime_nsec)
+ ST( 9) = sv_2mortal(newSVnv(mtime + (NV) mtime_nsec / NV_1E9));
+ if (ctime_nsec)
+ ST(10) = sv_2mortal(newSVnv(ctime + (NV) ctime_nsec / NV_1E9));
+ }
+ XSRETURN(nret);
diff --git a/Makefile.PL b/Makefile.PL
index 4e7018a..b635092 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -11,6 +11,8 @@ use Config;
use ExtUtils::MakeMaker;
use strict;
+use File::Spec;
+
my $VERBOSE = $ENV{VERBOSE};
my $DEFINE;
my $LIBS = [];
@@ -29,55 +31,6 @@ 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) = @_;
@@ -89,25 +42,25 @@ sub try_compile_and_link {
unlink("$tmp.c", "$tmp$obj_ext");
if (open(TMPC, '>', "$tmp.c")) {
- print TMPC $c;
- close(TMPC);
+ print TMPC $c;
+ close(TMPC);
- my $cccmd = $args{cccmd};
+ my $cccmd = $args{cccmd};
- my $errornull;
+ my $errornull;
- my $COREincdir;
+ 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}) {
+ 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__;
+ 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.
@@ -115,62 +68,62 @@ __EOD__
}
}
- my $ccflags = $Config{'ccflags'} . ' ' . "-I$COREincdir"
- . ' -DPERL_NO_INLINE_FUNCTIONS';
+ my $ccflags = $Config{'ccflags'} . ' ' . "-I$COREincdir"
+ . ' -DPERL_NO_INLINE_FUNCTIONS';
- if ($^O eq 'VMS') {
+ if ($^O eq 'VMS') {
$cccmd = "$Config{'cc'} /include=($COREincdir) $tmp.c";
}
if ($args{silent} || !$VERBOSE) {
- $errornull = "2>/dev/null" unless defined $errornull;
- } else {
- $errornull = '';
- }
+ $errornull = "2>/dev/null" unless defined $errornull;
+ } else {
+ $errornull = '';
+ }
$cccmd = "$Config{'cc'} -o $tmp $ccflags $tmp.c @$LIBS $errornull"
- unless defined $cccmd;
+ 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 $_;
- }
+ 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} && !$ENV{TIME_HIRES_DONT_RUN_PROBES} ) {
- 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;
+ 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} && !$ENV{TIME_HIRES_DONT_RUN_PROBES} ) {
+ 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);
+ }
+ }
+ unlink("$tmp.c", $tmp_exe);
}
}
@@ -188,7 +141,7 @@ my $TIME_HEADERS = <<EOH;
# include <sys/time.h>
#endif
#ifdef I_SYS_SELECT
-# include <sys/select.h> /* struct timeval might be hidden in here */
+# include <sys/select.h> /* struct timeval might be hidden in here */
#endif
EOH
@@ -233,7 +186,7 @@ sub has_x {
int main(int argc, char** argv)
{
- $x;
+ $x;
}
EOM
return 0;
@@ -276,7 +229,7 @@ sub has_include {
#include <$inc>
int main(int argc, char** argv)
{
- return 0;
+ return 0;
}
EOM
return 0;
@@ -422,56 +375,56 @@ sub DEFINE {
my ($def, $val) = @_;
my $define = defined $val ? "$def=$val" : $def ;
unless ($DEFINE =~ /(?:^| )-D\Q$define\E(?: |$)/) {
- $DEFINE .= " -D$define";
+ $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";
- }
+ 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';
- }
+ 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";
+ print "No syscall()...\n";
}
if ($Config{d_syscall}) {
- if (defined $SYSCALL_H) {
- print "found <$SYSCALL_H>.\n";
- } else {
- print "NOT found.\n";
- }
+ 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};
+ $has_gettimeofday++ if $Config{d_gettimeod};
} elsif (has_gettimeofday()) {
- $DEFINE .= ' -DHAS_GETTIMEOFDAY';
- $has_gettimeofday++;
+ $DEFINE .= ' -DHAS_GETTIMEOFDAY';
+ $has_gettimeofday++;
}
if ($has_gettimeofday) {
- print "found.\n";
+ print "found.\n";
} else {
- die <<EOD
+ die <<EOD
Your operating system does not seem to have the gettimeofday() function.
(or, at least, I cannot find it)
@@ -496,7 +449,7 @@ EOD
if ($has_setitimer) {
print "found.\n";
} else {
- print "NOT found.\n";
+ print "NOT found.\n";
}
print "Looking for getitimer()... ";
@@ -511,13 +464,13 @@ EOD
if ($has_getitimer) {
print "found.\n";
} else {
- print "NOT found.\n";
+ print "NOT found.\n";
}
if ($has_setitimer && $has_getitimer) {
- print "You have interval timers (both setitimer and getitimer).\n";
+ print "You have interval timers (both setitimer and getitimer).\n";
} else {
- print "You do NOT have interval timers.\n";
+ print "You do NOT have interval timers.\n";
}
print "Looking for ualarm()... ";
@@ -526,74 +479,71 @@ EOD
$has_ualarm++ if $Config{d_ualarm};
} elsif (has_x ("ualarm (0, 0)")) {
$has_ualarm++;
- $DEFINE .= ' -DHAS_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 "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};
+ $has_usleep++ if $Config{d_usleep};
} elsif (has_x ("usleep (0)")) {
- $has_usleep++;
- $DEFINE .= ' -DHAS_USLEEP';
+ $has_usleep++;
+ $DEFINE .= ' -DHAS_USLEEP';
}
if ($has_usleep) {
- print "found.\n";
+ print "found.\n";
} else {
- print "NOT found.\n";
+ 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 "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';
- }
+ 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... ";
+ print "believing \$Config{d_nanosleep}... ";
+ if ($Config{d_nanosleep}) {
+ $has_nanosleep++;
+ $DEFINE .= ' -DTIME_HIRES_NANOSLEEP';
+ }
} else {
- if (has_nanosleep()) {
- $has_nanosleep++;
- $DEFINE .= ' -DTIME_HIRES_NANOSLEEP';
- }
+ if (has_nanosleep()) {
+ $has_nanosleep++;
+ $DEFINE .= ' -DTIME_HIRES_NANOSLEEP';
+ }
}
if ($has_nanosleep) {
- print "found.\n";
+ 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 "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";
}
@@ -601,11 +551,11 @@ EOD
print "Looking for clockid_t... ";
my $has_clockid_t;
if (has_clockid_t()) {
- print "found.\n";
+ print "found.\n";
$has_clockid_t++;
- $DEFINE .= ' -DTIME_HIRES_CLOCKID_T';
+ $DEFINE .= ' -DTIME_HIRES_CLOCKID_T';
} else {
- print "NOT found, will use int.\n";
+ print "NOT found, will use int.\n";
}
print "Looking for clock_gettime()... ";
@@ -615,10 +565,10 @@ EOD
$has_clock_gettime++ if $Config{d_clock_gettime}; # Unlikely...
} elsif (has_clock_xxx('gettime')) {
$has_clock_gettime++;
- $DEFINE .= ' -DTIME_HIRES_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';
+ $DEFINE .= ' -DTIME_HIRES_CLOCK_GETTIME -DTIME_HIRES_CLOCK_GETTIME_SYSCALL';
} elsif ($^O eq 'darwin') {
$has_clock_gettime_emulation++;
$has_clock_gettime++;
@@ -627,14 +577,14 @@ EOD
if ($has_clock_gettime) {
if ($DEFINE =~ /-DTIME_HIRES_CLOCK_GETTIME_SYSCALL/) {
- print "found (via syscall).\n";
- } elsif ($has_clock_gettime_emulation) {
- print "found (via emulation).\n";
- } else {
- print "found.\n";
- }
+ print "found (via syscall).\n";
+ } elsif ($has_clock_gettime_emulation) {
+ print "found (via emulation).\n";
+ } else {
+ print "found.\n";
+ }
} else {
- print "NOT found.\n";
+ print "NOT found.\n";
}
print "Looking for clock_getres()... ";
@@ -644,10 +594,10 @@ EOD
$has_clock_getres++ if $Config{d_clock_getres}; # Unlikely...
} elsif (has_clock_xxx('getres')) {
$has_clock_getres++;
- $DEFINE .= ' -DTIME_HIRES_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';
+ $DEFINE .= ' -DTIME_HIRES_CLOCK_GETRES -DTIME_HIRES_CLOCK_GETRES_SYSCALL';
} elsif ($^O eq 'darwin') {
$has_clock_getres_emulation++;
$has_clock_getres++;
@@ -656,14 +606,14 @@ EOD
if ($has_clock_getres) {
if ($DEFINE =~ /-DTIME_HIRES_CLOCK_GETRES_SYSCALL/) {
- print "found (via syscall).\n";
- } elsif ($has_clock_getres_emulation) {
- print "found (via emulation).\n";
- } else {
- print "found.\n";
- }
+ print "found (via syscall).\n";
+ } elsif ($has_clock_getres_emulation) {
+ print "found (via emulation).\n";
+ } else {
+ print "found.\n";
+ }
} else {
- print "NOT found.\n";
+ print "NOT found.\n";
}
print "Looking for clock_nanosleep()... ";
@@ -673,21 +623,21 @@ EOD
$has_clock_nanosleep++ if $Config{d_clock_nanosleep}; # Unlikely...
} elsif (has_clock_nanosleep()) {
$has_clock_nanosleep++;
- $DEFINE .= ' -DTIME_HIRES_CLOCK_NANOSLEEP';
+ $DEFINE .= ' -DTIME_HIRES_CLOCK_NANOSLEEP';
} elsif ($^O eq 'darwin') {
$has_clock_nanosleep++;
$has_clock_nanosleep_emulation++;
- $DEFINE .= ' -DTIME_HIRES_CLOCK_NANOSLEEP -DTIME_HIRES_CLOCK_NANOSLEEP_EMULATION';
+ $DEFINE .= ' -DTIME_HIRES_CLOCK_NANOSLEEP -DTIME_HIRES_CLOCK_NANOSLEEP_EMULATION';
}
if ($has_clock_nanosleep) {
- if ($has_clock_nanosleep_emulation) {
- print "found (via emulation).\n";
- } else {
- print "found.\n";
- }
+ if ($has_clock_nanosleep_emulation) {
+ print "found (via emulation).\n";
+ } else {
+ print "found.\n";
+ }
} else {
- print "NOT found.\n";
+ print "NOT found.\n";
}
print "Looking for clock()... ";
@@ -696,44 +646,44 @@ EOD
$has_clock++ if $Config{d_clock}; # Unlikely...
} elsif (has_clock()) {
$has_clock++;
- $DEFINE .= ' -DTIME_HIRES_CLOCK';
+ $DEFINE .= ' -DTIME_HIRES_CLOCK';
}
if ($has_clock) {
print "found.\n";
} else {
- print "NOT found.\n";
+ print "NOT found.\n";
}
print "Looking for working futimens()... ";
my $has_futimens;
if (has_futimens()) {
$has_futimens++;
- $DEFINE .= ' -DHAS_FUTIMENS';
+ $DEFINE .= ' -DHAS_FUTIMENS';
}
if ($has_futimens) {
print "found.\n";
} else {
- print "NOT found.\n";
+ print "NOT found.\n";
}
print "Looking for working utimensat()... ";
my $has_utimensat;
if (has_utimensat()) {
$has_utimensat++;
- $DEFINE .= ' -DHAS_UTIMENSAT';
+ $DEFINE .= ' -DHAS_UTIMENSAT';
}
if ($has_utimensat) {
print "found.\n";
} else {
- print "NOT found.\n";
+ print "NOT found.\n";
}
my $has_hires_utime = ($has_futimens && $has_utimensat);
if ($has_hires_utime) {
- $DEFINE .= ' -DTIME_HIRES_UTIME';
+ $DEFINE .= ' -DTIME_HIRES_UTIME';
print "You seem to have subsecond timestamp setting.\n";
} else {
print "You do NOT seem to have subsecond timestamp setting.\n";
@@ -758,7 +708,7 @@ EOM
if ($has_stat_st_xtimespec) {
print "found.\n";
} else {
- print "NOT found.\n";
+ print "NOT found.\n";
}
print "Trying struct stat st_atimensec...";
@@ -778,7 +728,7 @@ EOM
if ($has_stat_st_xtimensec) {
print "found.\n";
} else {
- print "NOT found.\n";
+ print "NOT found.\n";
}
print "Trying struct stat st_atime_n...";
@@ -798,7 +748,7 @@ EOM
if ($has_stat_st_xtime_n) {
print "found.\n";
} else {
- print "NOT found.\n";
+ print "NOT found.\n";
}
print "Trying struct stat st_atim.tv_nsec...";
@@ -818,7 +768,7 @@ EOM
if ($has_stat_st_xtim) {
print "found.\n";
} else {
- print "NOT found.\n";
+ print "NOT found.\n";
}
print "Trying struct stat st_uatime...";
@@ -838,7 +788,7 @@ EOM
if ($has_stat_st_uxtime) {
print "found.\n";
} else {
- print "NOT found.\n";
+ print "NOT found.\n";
}
# See HiRes.xs hrstatns()
@@ -870,21 +820,21 @@ EOM
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');
- }
+ $has_w32api_windows_h++;
+ DEFINE('HAS_W32API_WINDOWS_H');
+ }
if ($has_w32api_windows_h) {
- print "found.\n";
- } else {
- print "NOT found.\n";
- }
+ print "found.\n";
+ } else {
+ print "NOT found.\n";
+ }
}
if ($DEFINE) {
$DEFINE =~ s/^\s+//;
if (open(XDEFINE, '>', 'xdefine')) {
- print XDEFINE $DEFINE, "\n";
- close(XDEFINE);
+ print XDEFINE $DEFINE, "\n";
+ close(XDEFINE);
}
}
}
@@ -892,74 +842,82 @@ EOM
sub doMakefile {
my @makefileopts = ();
- if ($] >= 5.005) {
- push (@makefileopts,
- 'AUTHOR' => 'Jarkko Hietaniemi <jhi@iki.fi>',
- 'ABSTRACT_FROM' => 'HiRes.pm',
- );
- DEFINE('ATLEASTFIVEOHOHFIVE');
- }
DEFINE('USE_PPPORT_H') unless $ENV{PERL_CORE};
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,
- 'Exporter' => 0,
- 'ExtUtils::MakeMaker' => 0,
- 'Test::More' => 0,
- 'XSLoader' => 0,
- 'strict' => 0,
- },
- 'dist' => {
- 'CI' => 'ci -l',
- 'COMPRESS' => 'gzip -9f',
- 'SUFFIX' => 'gz',
- },
+ 'NAME' => 'Time::HiRes',
+ 'AUTHOR' => 'Jarkko Hietaniemi <jhi@iki.fi>',
+ 'ABSTRACT_FROM' => 'HiRes.pm',
+ '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,
+ 'Exporter' => 0,
+ 'ExtUtils::MakeMaker' => 0,
+ 'Test::More' => 0,
+ 'XSLoader' => 0,
+ 'strict' => 0,
+ 'File::Spec' => 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 => "",
- };
- }
+ 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 => {};
+ push @makefileopts, MAN3PODS => {};
}
if ($ExtUtils::MakeMaker::VERSION >= 6.48) {
- push @makefileopts, (MIN_PERL_VERSION => '5.006',);
+ push @makefileopts, (MIN_PERL_VERSION => '5.006',);
}
if ($ExtUtils::MakeMaker::VERSION >= 6.31) {
- push @makefileopts, (LICENSE => 'perl_5');
+ push @makefileopts, (LICENSE => 'perl_5');
+ }
+
+ if ($ExtUtils::MakeMaker::VERSION >= 6.46) {
+ push @makefileopts, (
+ META_MERGE => {
+ resources => {
+ repository => 'git://perl5.git.perl.org/perl.git',
+ bugtracker => 'https://rt.perl.org/rt3/',
+ homepage => "http://dev.perl.org/",
+ },
+ },
+ )
}
WriteMakefile(@makefileopts);
@@ -968,119 +926,122 @@ sub doMakefile {
sub doConstants {
if (eval {require ExtUtils::Constant; 1}) {
# More or less this same list is in HiRes.pm. Should unify.
- my @names = qw(
- CLOCKS_PER_SEC
- CLOCK_BOOTTIME
- CLOCK_HIGHRES
- CLOCK_MONOTONIC
- CLOCK_MONOTONIC_COARSE
- CLOCK_MONOTONIC_FAST
- CLOCK_MONOTONIC_PRECISE
- CLOCK_MONOTONIC_RAW
- CLOCK_PROF
- CLOCK_PROCESS_CPUTIME_ID
- CLOCK_REALTIME
- CLOCK_REALTIME_COARSE
- CLOCK_REALTIME_FAST
- CLOCK_REALTIME_PRECISE
- CLOCK_REALTIME_RAW
- CLOCK_SECOND
- CLOCK_SOFTTIME
- CLOCK_THREAD_CPUTIME_ID
- CLOCK_TIMEOFDAY
- CLOCK_UPTIME
- CLOCK_UPTIME_COARSE
- CLOCK_UPTIME_FAST
- CLOCK_UPTIME_PRECISE
- CLOCK_UPTIME_RAW
- CLOCK_VIRTUAL
- ITIMER_PROF
- ITIMER_REAL
- ITIMER_REALPROF
- ITIMER_VIRTUAL
- TIMER_ABSTIME
+ my @names = qw(
+ CLOCKS_PER_SEC
+ CLOCK_BOOTTIME
+ CLOCK_HIGHRES
+ CLOCK_MONOTONIC
+ CLOCK_MONOTONIC_COARSE
+ CLOCK_MONOTONIC_FAST
+ CLOCK_MONOTONIC_PRECISE
+ CLOCK_MONOTONIC_RAW
+ CLOCK_PROF
+ CLOCK_PROCESS_CPUTIME_ID
+ CLOCK_REALTIME
+ CLOCK_REALTIME_COARSE
+ CLOCK_REALTIME_FAST
+ CLOCK_REALTIME_PRECISE
+ CLOCK_REALTIME_RAW
+ CLOCK_SECOND
+ CLOCK_SOFTTIME
+ CLOCK_THREAD_CPUTIME_ID
+ CLOCK_TIMEOFDAY
+ CLOCK_UPTIME
+ CLOCK_UPTIME_COARSE
+ CLOCK_UPTIME_FAST
+ CLOCK_UPTIME_PRECISE
+ CLOCK_UPTIME_RAW
+ CLOCK_VIRTUAL
+ ITIMER_PROF
+ ITIMER_REAL
+ ITIMER_REALPROF
+ ITIMER_VIRTUAL
+ 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
+ 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
d_futimens d_utimensat d_hires_utime)) {
- my $macro = $_;
- if ($macro =~ /^(d_nanosleep|d_clock)$/) {
- $macro =~ s/^d_(.+)/TIME_HIRES_\U$1/;
- } elsif ($macro =~ /^(d_hires_stat)$/) {
- my $d_hires_stat = $1 if ($DEFINE =~ /-DTIME_HIRES_STAT=(\d+)/);
+ my $macro = $_;
+ if ($macro =~ /^(d_nanosleep|d_clock)$/) {
+ $macro =~ s/^d_(.+)/TIME_HIRES_\U$1/;
+ } elsif ($macro =~ /^(d_hires_stat)$/) {
+ my $d_hires_stat = $1 if ($DEFINE =~ /-DTIME_HIRES_STAT=(\d+)/);
if (defined $d_hires_stat) {
push @names, {name => $_, macro => "TIME_HIRES_STAT", value => $d_hires_stat,
default => ["IV", "0"]};
next;
}
- } elsif ($macro =~ /^(d_hires_utime)$/) {
- my $d_hires_utime =
- ($DEFINE =~ /-DHAS_FUTIMENS/ ||
- $DEFINE =~ /-DHAS_UTIMENSAT/);
- push @names, {name => $_, macro => "TIME_HIRES_UTIME", value => $d_hires_utime,
- default => ["IV", "0"]};
- next;
- } elsif ($macro =~ /^(d_clock_gettime|d_clock_getres|d_clock_nanosleep)$/) {
- $macro =~ s/^d_(.+)/TIME_HIRES_\U$1/;
- my $val = ($DEFINE =~ /-D$macro\b/) ? 1 : 0;
- push @names, {name => $_, macro => $macro, value => $val,
- 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,
- );
+ } elsif ($macro =~ /^(d_hires_utime)$/) {
+ my $d_hires_utime =
+ ($DEFINE =~ /-DHAS_FUTIMENS/ ||
+ $DEFINE =~ /-DHAS_UTIMENSAT/);
+ push @names, {name => $_, macro => "TIME_HIRES_UTIME", value => $d_hires_utime,
+ default => ["IV", "0"]};
+ next;
+ } elsif ($macro =~ /^(d_clock_gettime|d_clock_getres|d_clock_nanosleep)$/) {
+ $macro =~ s/^d_(.+)/TIME_HIRES_\U$1/;
+ my $val = ($DEFINE =~ /-D$macro\b/) ? 1 : 0;
+ push @names, {name => $_, macro => $macro, value => $val,
+ 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: $!";
- }
+ 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] =~ /^--(?:configure|force)$/)) {
- print qq[$0: The "xdefine" exists, skipping the configure step.\n];
- print qq[Use "$^X $0 --configure"\n];
- print qq[or: "$^X $0 --force\n];
- print qq[to force the configure step.\n];
+ print qq[$0: The "xdefine" exists, skipping the configure step.\n];
+ print qq[Use "$^X $0 --configure"\n];
+ print qq[or: "$^X $0 --force\n];
+ print qq[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;
+ print "Configuring Time::HiRes...\n";
+ 1 while unlink("define");
+ if ($^O =~ /Win32/i) {
+ DEFINE('SELECT_IS_BROKEN');
+ # we provide our own implementations of those functions on win32
+ DEFINE('TIME_HIRES_CLOCK_GETTIME');
+ DEFINE('TIME_HIRES_CLOCK_GETRES');
+ $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;
+ 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))) {
+ ((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):
diff --git a/t/Watchdog.pm b/t/Watchdog.pm
index 44ec808..a93ab4f 100644
--- a/t/Watchdog.pm
+++ b/t/Watchdog.pm
@@ -13,24 +13,24 @@ if ($Config{d_fork}) {
print("# I am the main process $$, starting the watchdog process...\n");
$watchdog_pid = fork();
if (defined $watchdog_pid) {
- if ($watchdog_pid == 0) { # We are the kid, set up the watchdog.
- my $ppid = getppid();
- print("# I am the watchdog process $$, sleeping for $waitfor seconds...\n");
- sleep($waitfor - 2); # Workaround for perlbug #49073
- sleep(2); # Wait for parent to exit
- if (kill(0, $ppid)) { # Check if parent still exists
- warn "\n$0: overall time allowed for tests (${waitfor}s) exceeded!\n";
- print("Terminating main process $ppid...\n");
- kill('KILL', $ppid);
- print("# This is the watchdog process $$, over and out.\n");
- }
- exit(0);
- } else {
- print("# The watchdog process $watchdog_pid launched, continuing testing...\n");
- $TheEnd = time() + $waitfor;
- }
+ if ($watchdog_pid == 0) { # We are the kid, set up the watchdog.
+ my $ppid = getppid();
+ print("# I am the watchdog process $$, sleeping for $waitfor seconds...\n");
+ sleep($waitfor - 2); # Workaround for perlbug #49073
+ sleep(2); # Wait for parent to exit
+ if (kill(0, $ppid)) { # Check if parent still exists
+ warn "\n$0: overall time allowed for tests (${waitfor}s) exceeded!\n";
+ print("Terminating main process $ppid...\n");
+ kill('KILL', $ppid);
+ print("# This is the watchdog process $$, over and out.\n");
+ }
+ exit(0);
+ } else {
+ print("# The watchdog process $watchdog_pid launched, continuing testing...\n");
+ $TheEnd = time() + $waitfor;
+ }
} else {
- warn "$0: fork failed: $!\n";
+ warn "$0: fork failed: $!\n";
}
} else {
print("# No watchdog process (need fork)\n");
@@ -38,16 +38,16 @@ if ($Config{d_fork}) {
END {
if ($watchdog_pid) { # Only in the main process.
- my $left = $TheEnd - time();
- printf("# I am the main process $$, terminating the watchdog process $watchdog_pid before it terminates me in %d seconds (testing took %d seconds).\n", $left, $waitfor - $left);
- if (kill(0, $watchdog_pid)) {
- local $? = 0;
- my $kill = kill('KILL', $watchdog_pid); # We are done, the watchdog can go.
- wait();
- printf("# kill KILL $watchdog_pid = %d\n", $kill);
- }
- unlink("ktrace.out"); # Used in BSD system call tracing.
- print("# All done.\n");
+ my $left = $TheEnd - time();
+ printf("# I am the main process $$, terminating the watchdog process $watchdog_pid before it terminates me in %d seconds (testing took %d seconds).\n", $left, $waitfor - $left);
+ if (kill(0, $watchdog_pid)) {
+ local $? = 0;
+ my $kill = kill('KILL', $watchdog_pid); # We are done, the watchdog can go.
+ wait();
+ printf("# kill KILL $watchdog_pid = %d\n", $kill);
+ }
+ unlink("ktrace.out"); # Used in BSD system call tracing.
+ print("# All done.\n");
}
}
diff --git a/t/alarm.t b/t/alarm.t
index af34d2a..6ebf380 100644
--- a/t/alarm.t
+++ b/t/alarm.t
@@ -10,23 +10,23 @@ use Config;
my $limit = 0.25; # 25% is acceptable slosh for testing timers
-my $xdefine = '';
+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/);
+ 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;
+ !$@ && defined &POSIX::sigaction && &POSIX::SIGALRM > 0;
my ($r, $i, $not, $ok);
@@ -36,80 +36,80 @@ SKIP: {
$i = 5;
my $oldaction;
if ($use_sigaction) {
- $oldaction = new POSIX::SigAction;
- printf("# sigaction tick, ALRM = %d\n", &POSIX::SIGALRM);
+ $oldaction = new POSIX::SigAction;
+ printf("# sigaction tick, ALRM = %d\n", &POSIX::SIGALRM);
- # Perl's deferred signals may be too wimpy to break through
- # a restartable select(), so use POSIX::sigaction if available.
+ # Perl's deferred signals may be too wimpy to break through
+ # a restartable select(), so use POSIX::sigaction if available.
# In perl 5.6.2 you will get a likely bogus warning of
# "Use of uninitialized value in subroutine entry" from
# the following line.
- POSIX::sigaction(&POSIX::SIGALRM,
- POSIX::SigAction->new("tick"),
- $oldaction)
- or die "Error setting SIGALRM handler with sigaction: $!\n";
+ POSIX::sigaction(&POSIX::SIGALRM,
+ POSIX::SigAction->new("tick"),
+ $oldaction)
+ or die "Error setting SIGALRM handler with sigaction: $!\n";
} else {
- print("# SIG tick\n");
- $SIG{ALRM} = "tick";
+ print("# SIG tick\n");
+ $SIG{ALRM} = "tick";
}
# On VMS timers can not interrupt select.
if ($^O eq 'VMS') {
- $ok = "Skip: VMS select() does not get interrupted.";
+ $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);
- print("# Select returned! $i $ival\n");
- printf("# %s\n", 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;
- }
+ while ($i > 0) {
+ Time::HiRes::alarm(0.3);
+ select (undef, undef, undef, 3);
+ my $ival = Time::HiRes::tv_interval ($r);
+ print("# Select returned! $i $ival\n");
+ printf("# %s\n", 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);
- print("# Tick! $i $ival\n");
- my $exp = 0.3 * (5 - $i);
- if ($exp == 0) {
- $not = "tick: divisor became zero";
- last;
- }
- # This test is more sensitive, so impose a softer limit.
- if (abs($ival/$exp - 1) > 4*$limit) {
- my $ratio = abs($ival/$exp);
- $not = "tick: $exp sleep took $ival ratio $ratio";
- $i = 0;
- }
+ $i--;
+ my $ival = Time::HiRes::tv_interval ($r);
+ print("# Tick! $i $ival\n");
+ my $exp = 0.3 * (5 - $i);
+ if ($exp == 0) {
+ $not = "tick: divisor became zero";
+ last;
+ }
+ # This test is more sensitive, so impose a softer limit.
+ if (abs($ival/$exp - 1) > 4*$limit) {
+ my $ratio = abs($ival/$exp);
+ $not = "tick: $exp sleep took $ival ratio $ratio";
+ $i = 0;
+ }
}
if ($use_sigaction) {
- POSIX::sigaction(&POSIX::SIGALRM, $oldaction);
+ POSIX::sigaction(&POSIX::SIGALRM, $oldaction);
} else {
- Time::HiRes::alarm(0); # can't cancel usig %SIG
+ Time::HiRes::alarm(0); # can't cancel usig %SIG
}
print("# $not\n");
@@ -120,7 +120,7 @@ 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";
+ "negative time error";
}
# Find the loop size N (a for() loop 0..N-1)
@@ -139,22 +139,22 @@ SKIP: {
my $i;
N: {
do {
- my $t0 = Time::HiRes::time();
- for ($i = 0; $i < $DelayN; $i++) { }
- my $t1 = Time::HiRes::time();
- my $dt = $t1 - $t0;
- print("# N = $DelayN, t1 = $t1, t0 = $t0, dt = $dt\n");
- last N if $dt > $T;
- $DelayN *= 2;
+ my $t0 = Time::HiRes::time();
+ for ($i = 0; $i < $DelayN; $i++) { }
+ my $t1 = Time::HiRes::time();
+ my $dt = $t1 - $t0;
+ print("# N = $DelayN, t1 = $t1, t0 = $t0, dt = $dt\n");
+ last N if $dt > $T;
+ $DelayN *= 2;
} while (1);
}
# The time-burner which takes at least T (default 1) seconds.
my $Delay = sub {
- my $c = @_ ? shift : 1;
- my $n = $c * $DelayN;
- my $i;
- for ($i = 0; $i < $n; $i++) { }
+ 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
@@ -174,11 +174,11 @@ SKIP: {
# (We may well get $A + 1 alarms.)
$SIG{ALRM} = sub {
- $a++;
- printf("# Alarm $a - %s\n", Time::HiRes::time());
- Time::HiRes::alarm(0) if $a >= $A; # Disarm the alarm.
- $Delay->(2); # Try burning CPU at least for 2T seconds.
- };
+ $a++;
+ printf("# Alarm $a - %s\n", 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.
@@ -190,38 +190,38 @@ SKIP: {
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(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;
+ $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 print("# $got\n");
+ my $alrm = 0;
+ $SIG{ALRM} = sub { $alrm++ };
+ my $got = Time::HiRes::alarm(2.7);
+ ok $got == 0 or print("# $got\n");
- my $t0 = Time::HiRes::time();
- 1 while Time::HiRes::time() - $t0 <= 1;
+ my $t0 = Time::HiRes::time();
+ 1 while Time::HiRes::time() - $t0 <= 1;
- $got = Time::HiRes::alarm(0);
- ok $got > 0 && $got < 1.8 or print("# $got\n");
+ $got = Time::HiRes::alarm(0);
+ ok $got > 0 && $got < 1.8 or print("# $got\n");
- ok $alrm == 0 or print("# $alrm\n");
+ ok $alrm == 0 or print("# $alrm\n");
- $got = Time::HiRes::alarm(0);
- ok $got == 0 or print("# $got\n");
+ $got = Time::HiRes::alarm(0);
+ ok $got == 0 or print("# $got\n");
}
}
diff --git a/t/clock.t b/t/clock.t
index 64478b0..810d63a 100644
--- a/t/clock.t
+++ b/t/clock.t
@@ -22,7 +22,7 @@ printf("# have_clock = %d\n", &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.
+# 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
@@ -33,31 +33,31 @@ 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");
+ unless &Time::HiRes::d_clock_gettime && has_symbol("CLOCK_REALTIME");
my $ok = 0;
TRY: {
- for my $try (1..3) {
- print("# CLOCK_REALTIME: try = $try\n");
- 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) {
- print("# t1 = $t1, t0 = $t0\n");
- my $dt = $t1 - $t0;
- my $rt = abs(1 - $dt / $T);
- print("# dt = $dt, rt = $rt\n");
- if ($rt <= 2 * $limit) {
- $ok = 1;
- last TRY;
- }
- } else {
- print("# Error: t0 = $t0, t1 = $t1\n");
- }
- my $r = rand() + rand();
- printf("# Sleeping for %.6f seconds...\n", $r);
- Time::HiRes::sleep($r);
- }
+ for my $try (1..3) {
+ print("# CLOCK_REALTIME: try = $try\n");
+ 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) {
+ print("# t1 = $t1, t0 = $t0\n");
+ my $dt = $t1 - $t0;
+ my $rt = abs(1 - $dt / $T);
+ print("# dt = $dt, rt = $rt\n");
+ if ($rt <= 2 * $limit) {
+ $ok = 1;
+ last TRY;
+ }
+ } else {
+ print("# Error: t0 = $t0, t1 = $t1\n");
+ }
+ my $r = rand() + rand();
+ printf("# Sleeping for %.6f seconds...\n", $r);
+ Time::HiRes::sleep($r);
+ }
}
ok $ok;
}
@@ -70,7 +70,7 @@ SKIP: {
SKIP: {
skip "no clock_nanosleep", 1
- unless &Time::HiRes::d_clock_nanosleep && has_symbol("CLOCK_REALTIME");
+ 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);
@@ -79,7 +79,7 @@ SKIP: {
SKIP: {
skip "no clock", 1 unless &Time::HiRes::d_clock;
- skip "no CLOCKS_PER_SEC", 1 unless has_symbol("CLOCKS_PER_SEC");
+ skip "no CLOCKS_PER_SEC", 1 unless has_symbol("CLOCKS_PER_SEC");
my @clock = Time::HiRes::clock();
# If we have a relatively low precision clock() and we haven't seen much
# CPU usage thus far with clock(), we will want to have a bit longer delay.
@@ -89,13 +89,13 @@ SKIP: {
print("# clock = @clock\n");
for my $i (1..3) {
for (my $j = 0; $j < $delay; $j++) { }
- push @clock, Time::HiRes::clock();
- print("# clock = @clock\n");
+ push @clock, Time::HiRes::clock();
+ print("# clock = @clock\n");
}
ok $clock[0] >= 0 &&
- $clock[1] > $clock[0] &&
- $clock[2] > $clock[1] &&
- $clock[3] > $clock[2];
+ $clock[1] > $clock[0] &&
+ $clock[2] > $clock[1] &&
+ $clock[3] > $clock[2];
}
1;
diff --git a/t/gettimeofday.t b/t/gettimeofday.t
index 9f2fd7e..05cebbb 100644
--- a/t/gettimeofday.t
+++ b/t/gettimeofday.t
@@ -3,8 +3,8 @@ use strict;
BEGIN {
require Time::HiRes;
unless(&Time::HiRes::d_gettimeofday) {
- require Test::More;
- Test::More::plan(skip_all => "no gettimeofday()");
+ require Test::More;
+ Test::More::plan(skip_all => "no gettimeofday()");
}
}
@@ -21,7 +21,7 @@ sleep 1;
my @two = Time::HiRes::gettimeofday();
ok $two[0] > $one[0] || ($two[0] == $one[0] && $two[1] > $one[1])
- or print("# @two is not greater than @one\n");
+ or print("# @two is not greater than @one\n");
my $f = Time::HiRes::time();
ok $f > 850_000_000 or print("# $f too small\n");
diff --git a/t/itimer.t b/t/itimer.t
index 432b224..4e4ce6d 100644
--- a/t/itimer.t
+++ b/t/itimer.t
@@ -13,15 +13,15 @@ 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
+ && 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");
+ require Test::More;
+ Test::More::plan(skip_all => "no itimer");
}
}
@@ -37,7 +37,7 @@ my $r = [Time::HiRes::gettimeofday()];
$SIG{VTALRM} = sub {
$i ? $i-- : Time::HiRes::setitimer(&Time::HiRes::ITIMER_VIRTUAL, 0);
printf("# Tick! $i %s\n", Time::HiRes::tv_interval($r));
-};
+};
printf("# setitimer: %s\n", join(" ",
Time::HiRes::setitimer(&Time::HiRes::ITIMER_VIRTUAL, 0.5, 0.4)));
diff --git a/t/nanosleep.t b/t/nanosleep.t
index 98cc8d9..ff05637 100644
--- a/t/nanosleep.t
+++ b/t/nanosleep.t
@@ -3,8 +3,8 @@ use strict;
BEGIN {
require Time::HiRes;
unless(&Time::HiRes::d_nanosleep) {
- require Test::More;
- Test::More::plan(skip_all => "no nanosleep()");
+ require Test::More;
+ Test::More::plan(skip_all => "no nanosleep()");
}
}
@@ -14,7 +14,7 @@ use t::Watchdog;
eval { Time::HiRes::nanosleep(-5) };
like $@, qr/::nanosleep\(-5\): negative time not invented yet/,
- "negative time error";
+ "negative time error";
my $one = CORE::time;
Time::HiRes::nanosleep(10_000_000);
diff --git a/t/sleep.t b/t/sleep.t
index 0ab6340..0451650 100644
--- a/t/sleep.t
+++ b/t/sleep.t
@@ -8,7 +8,7 @@ BEGIN { require_ok "Time::HiRes"; }
use Config;
-my $xdefine = '';
+my $xdefine = '';
if (open(XDEFINE, "<", "xdefine")) {
chomp($xdefine = <XDEFINE> || "");
close(XDEFINE);
@@ -22,11 +22,11 @@ my $can_subsecond_alarm =
eval { Time::HiRes::sleep(-1) };
like $@, qr/::sleep\(-1\): negative time not invented yet/,
- "negative time error";
+ "negative time error";
SKIP: {
skip "no subsecond alarm", 2 unless $can_subsecond_alarm;
- my $f = Time::HiRes::time;
+ my $f = Time::HiRes::time;
print("# time...$f\n");
ok 1;
diff --git a/t/stat.t b/t/stat.t
index d5e22ac..f2f8e87 100644
--- a/t/stat.t
+++ b/t/stat.t
@@ -3,13 +3,13 @@ use strict;
BEGIN {
require Time::HiRes;
unless(&Time::HiRes::d_hires_stat) {
- require Test::More;
- Test::More::plan(skip_all => "no hi-res 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");
+ require Test::More;
+ Test::More::plan(skip_all =>
+ "$^O file timestamps not reliable enough for stat test");
}
}
@@ -50,18 +50,18 @@ my $mi = 0;
my $ss = 0;
for (my $i = 1; $i < @atime; $i++) {
if ($atime[$i] >= $atime[$i-1]) {
- $ai++;
+ $ai++;
}
if ($atime[$i] > int($atime[$i])) {
- $ss++;
+ $ss++;
}
}
for (my $i = 1; $i < @mtime; $i++) {
if ($mtime[$i] >= $mtime[$i-1]) {
- $mi++;
+ $mi++;
}
if ($mtime[$i] > int($mtime[$i])) {
- $ss++;
+ $ss++;
}
}
print("# ai = $ai, mi = $mi, ss = $ss\n");
@@ -70,7 +70,7 @@ print("# ai = $ai, mi = $mi, ss = $ss\n");
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;
+ $ss/(@mtime+@atime) >= 0.2;
}
my $targetname = "tgt$$";
diff --git a/t/time.t b/t/time.t
index 5db016f..ad42f47 100644
--- a/t/time.t
+++ b/t/time.t
@@ -10,14 +10,14 @@ 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 += 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 print("# Time::HiRes::time() not close to CORE::time()\n");
+ or print("# Time::HiRes::time() not close to CORE::time()\n");
printf("# s = $s, n = $n, s/n = %s\n", abs($s)/$n);
}
diff --git a/t/ualarm.t b/t/ualarm.t
index 0f9a829..d478224 100644
--- a/t/ualarm.t
+++ b/t/ualarm.t
@@ -3,8 +3,8 @@ use strict;
BEGIN {
require Time::HiRes;
unless(&Time::HiRes::d_ualarm) {
- require Test::More;
- Test::More::plan(skip_all => "no ualarm()");
+ require Test::More;
+ Test::More::plan(skip_all => "no ualarm()");
}
}
@@ -25,7 +25,7 @@ SKIP: {
$tick = 0; Time::HiRes::ualarm(10_000); while ($tick == 0) { }
my $three = CORE::time;
ok $one == $two || $two == $three
- or print("# slept too long, $one $two $three\n");
+ or print("# slept too long, $one $two $three\n");
print("# tick = $tick, one = $one, two = $two, three = $three\n");
$tick = 0; Time::HiRes::ualarm(10_000, 10_000); while ($tick < 3) { }
@@ -36,7 +36,7 @@ SKIP: {
eval { Time::HiRes::ualarm(-4) };
like $@, qr/::ualarm\(-4, 0\): negative time not invented yet/,
- "negative time error";
+ "negative time error";
# Find the loop size N (a for() loop 0..N-1)
# that will take more than T seconds.
@@ -44,9 +44,9 @@ like $@, qr/::ualarm\(-4, 0\): negative time not invented yet/,
sub bellish { # Cheap emulation of a bell curve.
my ($min, $max) = @_;
my $rand = ($max - $min) / 5;
- my $sum = 0;
+ my $sum = 0;
for my $i (0..4) {
- $sum += rand($rand);
+ $sum += rand($rand);
}
return $min + $sum;
}
@@ -57,25 +57,25 @@ sub bellish { # Cheap emulation of a bell curve.
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();
- print("# t0 = $t0\n");
- print("# ualarm($n)\n");
- Time::HiRes::ualarm($n); 1 while $alarmed == 0;
- my $t1 = Time::HiRes::time();
- print("# t1 = $t1\n");
- my $dt = $t1 - $t0;
- print("# dt = $dt\n");
- my $r = $dt / ($n/1e6);
- print("# r = $r\n");
- $ok =
- ($n < 1_000_000 || # Too much noise.
- ($r >= 0.8 && $r <= 1.6));
- last if $ok;
- my $nap = bellish(3, 15);
- printf("# Retrying in %.1f seconds...\n", $nap);
- Time::HiRes::sleep($nap);
+ my $alarmed = 0;
+ local $SIG{ ALRM } = sub { $alarmed++ };
+ my $t0 = Time::HiRes::time();
+ print("# t0 = $t0\n");
+ print("# ualarm($n)\n");
+ Time::HiRes::ualarm($n); 1 while $alarmed == 0;
+ my $t1 = Time::HiRes::time();
+ print("# t1 = $t1\n");
+ my $dt = $t1 - $t0;
+ print("# dt = $dt\n");
+ my $r = $dt / ($n/1e6);
+ print("# r = $r\n");
+ $ok =
+ ($n < 1_000_000 || # Too much noise.
+ ($r >= 0.8 && $r <= 1.6));
+ last if $ok;
+ my $nap = bellish(3, 15);
+ printf("# Retrying in %.1f seconds...\n", $nap);
+ Time::HiRes::sleep($nap);
}
ok $ok or print("# ualarm($n) close enough\n");
}
@@ -89,8 +89,8 @@ for my $n (100_000, 1_100_000, 2_200_000, 4_300_000) {
my($alrm, $t1);
do {
- $alrm = $alrm0;
- $t1 = Time::HiRes::time();
+ $alrm = $alrm0;
+ $t1 = Time::HiRes::time();
} while $t1 - $t0 <= 0.3;
my $got1 = Time::HiRes::ualarm(0);
@@ -101,9 +101,9 @@ for my $n (100_000, 1_100_000, 2_200_000, 4_300_000) {
print("# got1 = $got1\n");
ok $got0 == 0 or print("# $got0\n");
SKIP: {
- skip "alarm interval exceeded", 2 if $t1 - $t0 >= 0.5;
- ok $got1 > 0;
- ok $alrm == 0;
+ 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);
diff --git a/t/usleep.t b/t/usleep.t
index bb66cbe..396341d 100644
--- a/t/usleep.t
+++ b/t/usleep.t
@@ -3,8 +3,8 @@ use strict;
BEGIN {
require Time::HiRes;
unless(&Time::HiRes::d_usleep) {
- require Test::More;
- Test::More::plan(skip_all => "no usleep()");
+ require Test::More;
+ Test::More::plan(skip_all => "no usleep()");
}
}
@@ -14,7 +14,7 @@ use t::Watchdog;
eval { Time::HiRes::usleep(-2) };
like $@, qr/::usleep\(-2\): negative time not invented yet/,
- "negative time error";
+ "negative time error";
my $limit = 0.25; # 25% is acceptable slosh for testing timers
@@ -59,8 +59,8 @@ SKIP: {
$msg = "$td went by while sleeping $sleep, ratio $ratio.\n";
SKIP: {
- skip $msg, 1 unless $td < $sleep * (1 + $limit);
- ok $a < $limit or print("# $msg\n");
+ skip $msg, 1 unless $td < $sleep * (1 + $limit);
+ ok $a < $limit or print("# $msg\n");
}
$t0 = Time::HiRes::gettimeofday();
@@ -71,8 +71,8 @@ SKIP: {
$msg = "$td went by while sleeping $sleep, ratio $ratio.\n";
SKIP: {
- skip $msg, 1 unless $td < $sleep * (1 + $limit);
- ok $a < $limit or print("# $msg\n");
+ skip $msg, 1 unless $td < $sleep * (1 + $limit);
+ ok $a < $limit or print("# $msg\n");
}
}
diff --git a/t/utime.t b/t/utime.t
index bb4621a..e2399b8 100644
--- a/t/utime.t
+++ b/t/utime.t
@@ -1,92 +1,92 @@
use strict;
sub has_subsecond_file_times {
- require File::Temp;
- require Time::HiRes;
- my ($fh, $filename) = File::Temp::tempfile( "Time-HiRes-utime-XXXXXXXXX" );
- use File::Basename qw[dirname];
- my $dirname = dirname($filename);
- require Cwd;
- $dirname = &Cwd::getcwd if $dirname eq '.';
- print("\n# Testing for subsecond file timestamps (mtime) in $dirname\n");
- close $fh;
- my @mtimes;
- for (1..2) {
- open $fh, '>', $filename;
- print $fh "foo";
+ require File::Temp;
+ require Time::HiRes;
+ my ($fh, $filename) = File::Temp::tempfile( "Time-HiRes-utime-XXXXXXXXX" );
+ use File::Basename qw[dirname];
+ my $dirname = dirname($filename);
+ require Cwd;
+ $dirname = &Cwd::getcwd if $dirname eq '.';
+ print("\n# Testing for subsecond file timestamps (mtime) in $dirname\n");
close $fh;
- push @mtimes, (Time::HiRes::stat($filename))[9];
- Time::HiRes::sleep(.1) if $_ == 1;
- }
- my $delta = $mtimes[1] - $mtimes[0];
- # print STDERR "mtimes = @mtimes, delta = $delta\n";
- unlink $filename;
- my $ok = $delta > 0 && $delta < 1;
- printf("# Subsecond file timestamps in $dirname: %s\n",
- $ok ? "OK" : "NO");
- return $ok;
+ my @mtimes;
+ for (1..2) {
+ open $fh, '>', $filename;
+ print $fh "foo";
+ close $fh;
+ push @mtimes, (Time::HiRes::stat($filename))[9];
+ Time::HiRes::sleep(.1) if $_ == 1;
+ }
+ my $delta = $mtimes[1] - $mtimes[0];
+ # print STDERR "mtimes = @mtimes, delta = $delta\n";
+ unlink $filename;
+ my $ok = $delta > 0 && $delta < 1;
+ printf("# Subsecond file timestamps in $dirname: %s\n",
+ $ok ? "OK" : "NO");
+ return $ok;
}
sub get_filesys_of_tempfile {
- require File::Temp;
- require Time::HiRes;
- my ($fh, $filename) = File::Temp::tempfile( "Time-HiRes-utime-XXXXXXXXX" );
- my $filesys;
- if (open(my $df, "df $filename |")) {
- my @fs;
- while (<$df>) {
- next if /^Filesystem/;
- chomp;
- push @fs, $_;
- }
- if (@fs == 1) {
- if (defined $fs[0] && length($fs[0])) {
- $filesys = $fs[0];
- } else {
- printf("# Got empty result from 'df'\n");
- }
+ require File::Temp;
+ require Time::HiRes;
+ my ($fh, $filename) = File::Temp::tempfile( "Time-HiRes-utime-XXXXXXXXX" );
+ my $filesys;
+ if (open(my $df, "df $filename |")) {
+ my @fs;
+ while (<$df>) {
+ next if /^Filesystem/;
+ chomp;
+ push @fs, $_;
+ }
+ if (@fs == 1) {
+ if (defined $fs[0] && length($fs[0])) {
+ $filesys = $fs[0];
+ } else {
+ printf("# Got empty result from 'df'\n");
+ }
+ } else {
+ printf("# Expected one result from 'df', got %d\n", scalar(@fs));
+ }
} else {
- printf("# Expected one result from 'df', got %d\n", scalar(@fs));
+ # Too noisy to show by default.
+ # Can fail for too many reasons.
+ print "# Failed to run 'df $filename |': $!\n";
}
- } else {
- # Too noisy to show by default.
- # Can fail for too many reasons.
- print "# Failed to run 'df $filename |': $!\n";
- }
- return $filesys;
+ return $filesys;
}
sub get_mount_of_filesys {
- my ($filesys) = @_;
- # netbsd has /sbin/mount
- local $ENV{PATH} = "$ENV{PATH}:/sbin" if $^O =~ /^(?:netbsd)$/;
- if (defined $filesys) {
- my @fs = split(' ', $filesys);
- if (open(my $mount, "mount |")) {
- while (<$mount>) {
- chomp;
- my @mnt = split(' ');
- if ($mnt[0] eq $fs[0]) {
- return $_;
+ my ($filesys) = @_;
+ # netbsd has /sbin/mount
+ local $ENV{PATH} = "$ENV{PATH}:/sbin" if $^O =~ /^(?:netbsd)$/;
+ if (defined $filesys) {
+ my @fs = split(' ', $filesys);
+ if (open(my $mount, "mount |")) {
+ while (<$mount>) {
+ chomp;
+ my @mnt = split(' ');
+ if ($mnt[0] eq $fs[0]) {
+ return $_;
+ }
+ }
+ } else {
+ # Too noisy to show by default.
+ # The mount(8) might not be in the PATH, for example.
+ # Or this might be a completely non-UNIX system.
+ # print "# Failed to run 'mount |': $!\n";
}
- }
- } else {
- # Too noisy to show by default.
- # The mount(8) might not be in the PATH, for example.
- # Or this might be a completely non-UNIX system.
- # print "# Failed to run 'mount |': $!\n";
}
- }
- return;
+ return;
}
sub get_mount_of_tempfile {
- return get_mount_of_filesys(get_filesys_of_tempfile());
+ return get_mount_of_filesys(get_filesys_of_tempfile());
}
sub tempfile_has_noatime_mount {
- my ($mount) = get_mount_of_tempfile();
- return $mount =~ /\bnoatime\b/;
+ my ($mount) = get_mount_of_tempfile();
+ return $mount =~ /\bnoatime\b/;
}
BEGIN {
@@ -94,21 +94,21 @@ BEGIN {
require Test::More;
require File::Temp;
unless(&Time::HiRes::d_hires_utime) {
- Test::More::plan(skip_all => "no hires_utime");
+ Test::More::plan(skip_all => "no hires_utime");
}
unless(&Time::HiRes::d_hires_stat) {
# Being able to read subsecond timestamps is a reasonable
- # prerequisite for being able to write them.
- Test::More::plan(skip_all => "no hires_stat");
+ # prerequisite for being able to write them.
+ Test::More::plan(skip_all => "no hires_stat");
}
unless (&Time::HiRes::d_futimens) {
- Test::More::plan(skip_all => "no futimens()");
+ Test::More::plan(skip_all => "no futimens()");
}
unless (&Time::HiRes::d_utimensat) {
- Test::More::plan(skip_all => "no utimensat()");
+ Test::More::plan(skip_all => "no utimensat()");
}
unless (has_subsecond_file_times()) {
- Test::More::plan(skip_all => "No subsecond file timestamps");
+ Test::More::plan(skip_all => "No subsecond file timestamps");
}
}
@@ -128,117 +128,117 @@ my $atime = 1.111111111;
my $mtime = 2.222222222;
if ($^O eq 'cygwin') {
- # Cygwin timestamps have less precision.
- $atime = 1.1111111;
- $mtime = 2.2222222;
+ # Cygwin timestamps have less precision.
+ $atime = 1.1111111;
+ $mtime = 2.2222222;
}
print "# \$^O = $^O, atime = $atime, mtime = $mtime\n";
my $skip_atime = $^O eq 'netbsd' && tempfile_has_noatime_mount();
if ($skip_atime) {
- printf("# Skipping atime tests because tempfiles seem to be in a filesystem mounted with 'noatime' ($^O)\n'");
+ printf("# Skipping atime tests because tempfiles seem to be in a filesystem mounted with 'noatime' ($^O)\n'");
}
print "# utime \$fh\n";
{
- my ($fh, $filename) = tempfile( "Time-HiRes-utime-XXXXXXXXX", UNLINK => 1 );
- is Time::HiRes::utime($atime, $mtime, $fh), 1, "One file changed";
- my ($got_atime, $got_mtime) = ( Time::HiRes::stat($filename) )[8, 9];
- SKIP: {
- skip("noatime mount", 1) if $skip_atime;
- is $got_atime, $atime, "atime set correctly";
- }
- is $got_mtime, $mtime, "mtime set correctly";
+ my ($fh, $filename) = tempfile( "Time-HiRes-utime-XXXXXXXXX", UNLINK => 1 );
+ is Time::HiRes::utime($atime, $mtime, $fh), 1, "One file changed";
+ my ($got_atime, $got_mtime) = ( Time::HiRes::stat($filename) )[8, 9];
+ SKIP: {
+ skip("noatime mount", 1) if $skip_atime;
+ is $got_atime, $atime, "atime set correctly";
+ }
+ is $got_mtime, $mtime, "mtime set correctly";
};
print "#utime \$filename\n";
{
- my ($fh, $filename) = tempfile( "Time-HiRes-utime-XXXXXXXXX", UNLINK => 1 );
- is Time::HiRes::utime($atime, $mtime, $filename), 1, "One file changed";
- my ($got_atime, $got_mtime) = ( Time::HiRes::stat($fh) )[8, 9];
- SKIP: {
- skip("noatime mount", 1) if $skip_atime;
- is $got_atime, $atime, "atime set correctly";
- }
- is $got_mtime, $mtime, "mtime set correctly";
+ my ($fh, $filename) = tempfile( "Time-HiRes-utime-XXXXXXXXX", UNLINK => 1 );
+ is Time::HiRes::utime($atime, $mtime, $filename), 1, "One file changed";
+ my ($got_atime, $got_mtime) = ( Time::HiRes::stat($fh) )[8, 9];
+ SKIP: {
+ skip("noatime mount", 1) if $skip_atime;
+ is $got_atime, $atime, "atime set correctly";
+ }
+ is $got_mtime, $mtime, "mtime set correctly";
};
print "#utime \$filename round-trip\n";
{
- my ($fh, $filename) = tempfile( "Time-HiRes-utime-XXXXXXXXX", UNLINK => 1 );
- # this fractional part is not exactly representable
- my $t = 1000000000.12345;
- is Time::HiRes::utime($t, $t, $filename), 1, "One file changed";
- my ($got_atime, $got_mtime) = ( Time::HiRes::stat($fh) )[8, 9];
- is Time::HiRes::utime($got_atime, $got_mtime, $filename), 1, "One file changed";
- my ($got_atime2, $got_mtime2) = ( Time::HiRes::stat($fh) )[8, 9];
- is $got_atime, $got_atime2, "atime round trip ok";
- is $got_mtime, $got_mtime2, "mtime round trip ok";
+ my ($fh, $filename) = tempfile( "Time-HiRes-utime-XXXXXXXXX", UNLINK => 1 );
+ # this fractional part is not exactly representable
+ my $t = 1000000000.12345;
+ is Time::HiRes::utime($t, $t, $filename), 1, "One file changed";
+ my ($got_atime, $got_mtime) = ( Time::HiRes::stat($fh) )[8, 9];
+ is Time::HiRes::utime($got_atime, $got_mtime, $filename), 1, "One file changed";
+ my ($got_atime2, $got_mtime2) = ( Time::HiRes::stat($fh) )[8, 9];
+ is $got_atime, $got_atime2, "atime round trip ok";
+ is $got_mtime, $got_mtime2, "mtime round trip ok";
};
print "utime \$filename and \$fh\n";
{
- my ($fh1, $filename1) = tempfile( "Time-HiRes-utime-XXXXXXXXX", UNLINK => 1 );
- my ($fh2, $filename2) = tempfile( "Time-HiRes-utime-XXXXXXXXX", UNLINK => 1 );
- is Time::HiRes::utime($atime, $mtime, $filename1, $fh2), 2, "Two files changed";
- {
- my ($got_atime, $got_mtime) = ( Time::HiRes::stat($fh1) )[8, 9];
- SKIP: {
- skip("noatime mount", 1) if $skip_atime;
- is $got_atime, $atime, "File 1 atime set correctly";
- }
- is $got_mtime, $mtime, "File 1 mtime set correctly";
- }
- {
- my ($got_atime, $got_mtime) = ( Time::HiRes::stat($filename2) )[8, 9];
- SKIP: {
- skip("noatime mount", 1) if $skip_atime;
- is $got_atime, $atime, "File 2 atime set correctly";
- }
- is $got_mtime, $mtime, "File 2 mtime set correctly";
- }
+ my ($fh1, $filename1) = tempfile( "Time-HiRes-utime-XXXXXXXXX", UNLINK => 1 );
+ my ($fh2, $filename2) = tempfile( "Time-HiRes-utime-XXXXXXXXX", UNLINK => 1 );
+ is Time::HiRes::utime($atime, $mtime, $filename1, $fh2), 2, "Two files changed";
+ {
+ my ($got_atime, $got_mtime) = ( Time::HiRes::stat($fh1) )[8, 9];
+ SKIP: {
+ skip("noatime mount", 1) if $skip_atime;
+ is $got_atime, $atime, "File 1 atime set correctly";
+ }
+ is $got_mtime, $mtime, "File 1 mtime set correctly";
+ }
+ {
+ my ($got_atime, $got_mtime) = ( Time::HiRes::stat($filename2) )[8, 9];
+ SKIP: {
+ skip("noatime mount", 1) if $skip_atime;
+ is $got_atime, $atime, "File 2 atime set correctly";
+ }
+ is $got_mtime, $mtime, "File 2 mtime set correctly";
+ }
};
print "# utime undef sets time to now\n";
{
- my ($fh1, $filename1) = tempfile( "Time-HiRes-utime-XXXXXXXXX", UNLINK => 1 );
- my ($fh2, $filename2) = tempfile( "Time-HiRes-utime-XXXXXXXXX", UNLINK => 1 );
-
- my $now = Time::HiRes::time;
- sleep(1);
- is Time::HiRes::utime(undef, undef, $filename1, $fh2), 2, "Two files changed";
-
- {
- my ($got_atime, $got_mtime) = ( Time::HiRes::stat($fh1) )[8, 9];
- SKIP: {
- skip("noatime mount", 1) if $skip_atime;
- cmp_ok $got_atime, '>=', $now, "File 1 atime set correctly";
- }
- cmp_ok $got_mtime, '>=', $now, "File 1 mtime set correctly";
- }
- {
- my ($got_atime, $got_mtime) = ( Time::HiRes::stat($filename2) )[8, 9];
- SKIP: {
- skip("noatime mount", 1) if $skip_atime;
- cmp_ok $got_atime, '>=', $now, "File 2 atime set correctly";
- }
- cmp_ok $got_mtime, '>=', $now, "File 2 mtime set correctly";
- }
+ my ($fh1, $filename1) = tempfile( "Time-HiRes-utime-XXXXXXXXX", UNLINK => 1 );
+ my ($fh2, $filename2) = tempfile( "Time-HiRes-utime-XXXXXXXXX", UNLINK => 1 );
+
+ my $now = Time::HiRes::time;
+ sleep(1);
+ is Time::HiRes::utime(undef, undef, $filename1, $fh2), 2, "Two files changed";
+
+ {
+ my ($got_atime, $got_mtime) = ( Time::HiRes::stat($fh1) )[8, 9];
+ SKIP: {
+ skip("noatime mount", 1) if $skip_atime;
+ cmp_ok $got_atime, '>=', $now, "File 1 atime set correctly";
+ }
+ cmp_ok $got_mtime, '>=', $now, "File 1 mtime set correctly";
+ }
+ {
+ my ($got_atime, $got_mtime) = ( Time::HiRes::stat($filename2) )[8, 9];
+ SKIP: {
+ skip("noatime mount", 1) if $skip_atime;
+ cmp_ok $got_atime, '>=', $now, "File 2 atime set correctly";
+ }
+ cmp_ok $got_mtime, '>=', $now, "File 2 mtime set correctly";
+ }
};
print "# negative atime dies\n";
{
- eval { Time::HiRes::utime(-4, $mtime) };
- like $@, qr/::utime\(-4, 2\.22222\): negative time not invented yet/,
- "negative time error";
+ eval { Time::HiRes::utime(-4, $mtime) };
+ like $@, qr/::utime\(-4, 2\.22222\): negative time not invented yet/,
+ "negative time error";
};
print "# negative mtime dies;\n";
{
- eval { Time::HiRes::utime($atime, -4) };
- like $@, qr/::utime\(1.11111, -4\): negative time not invented yet/,
- "negative time error";
+ eval { Time::HiRes::utime($atime, -4) };
+ like $@, qr/::utime\(1.11111, -4\): negative time not invented yet/,
+ "negative time error";
};
done_testing();
diff --git a/typemap b/typemap
index ffe60e3..2772c92 100644
--- a/typemap
+++ b/typemap
@@ -1,319 +1,319 @@
# 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
+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
clockid_t T_IV
-IV T_IV
-UV T_UV
+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
+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
+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
+ $var = $arg
T_SVREF
- if (SvROK($arg))
- $var = (SV*)SvRV($arg);
- else
- Perl_croak(aTHX_ \"$var is not a reference\")
+ 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\")
+ 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\")
+ 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\")
+ 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
+ $var NOT IMPLEMENTED
T_UV
- $var = ($type)SvUV($arg)
+ $var = ($type)SvUV($arg)
T_IV
- $var = ($type)SvIV($arg)
+ $var = ($type)SvIV($arg)
T_INT
- $var = (int)SvIV($arg)
+ $var = (int)SvIV($arg)
T_ENUM
- $var = ($type)SvIV($arg)
+ $var = ($type)SvIV($arg)
T_BOOL
- $var = (bool)SvTRUE($arg)
+ $var = (bool)SvTRUE($arg)
T_U_INT
- $var = (unsigned int)SvUV($arg)
+ $var = (unsigned int)SvUV($arg)
T_SHORT
- $var = (short)SvIV($arg)
+ $var = (short)SvIV($arg)
T_U_SHORT
- $var = (unsigned short)SvUV($arg)
+ $var = (unsigned short)SvUV($arg)
T_LONG
- $var = (long)SvIV($arg)
+ $var = (long)SvIV($arg)
T_U_LONG
- $var = (unsigned long)SvUV($arg)
+ $var = (unsigned long)SvUV($arg)
T_CHAR
- $var = (char)*SvPV_nolen($arg)
+ $var = (char)*SvPV_nolen($arg)
T_U_CHAR
- $var = (unsigned char)SvUV($arg)
+ $var = (unsigned char)SvUV($arg)
T_FLOAT
- $var = (float)SvNV($arg)
+ $var = (float)SvNV($arg)
T_NV
- $var = ($type)SvNV($arg)
+ $var = ($type)SvNV($arg)
T_DOUBLE
- $var = (double)SvNV($arg)
+ $var = (double)SvNV($arg)
T_PV
- $var = ($type)SvPV_nolen($arg)
+ $var = ($type)SvPV_nolen($arg)
T_PTR
- $var = INT2PTR($type,SvIV($arg))
+ $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\")
+ 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}\")
+ 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}\")
+ 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}\")
+ 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}\")
+ 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\")
+ 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}\")
+ 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)
+ $var = *($type *)SvPV_nolen($arg)
T_OPAQUEPTR
- $var = ($type)SvPV_nolen($arg)
+ $var = ($type)SvPV_nolen($arg)
T_PACKED
- $var = XS_unpack_$ntype($arg)
+ $var = XS_unpack_$ntype($arg)
T_PACKEDARRAY
- $var = XS_unpack_$ntype($arg)
+ $var = XS_unpack_$ntype($arg)
T_CALLBACK
- $var = make_perl_cb_$type($arg)
+ $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
+ 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)))
+ $var = PerlIO_findFILE(IoIFP(sv_2io($arg)))
T_IN
- $var = IoIFP(sv_2io($arg))
+ $var = IoIFP(sv_2io($arg))
T_INOUT
- $var = IoIFP(sv_2io($arg))
+ $var = IoIFP(sv_2io($arg))
T_OUT
- $var = IoOFP(sv_2io($arg))
+ $var = IoOFP(sv_2io($arg))
#############################################################################
OUTPUT
T_SV
- $arg = $var;
+ $arg = $var;
T_SVREF
- $arg = newRV((SV*)$var);
+ $arg = newRV((SV*)$var);
T_AVREF
- $arg = newRV((SV*)$var);
+ $arg = newRV((SV*)$var);
T_HVREF
- $arg = newRV((SV*)$var);
+ $arg = newRV((SV*)$var);
T_CVREF
- $arg = newRV((SV*)$var);
+ $arg = newRV((SV*)$var);
T_IV
- sv_setiv($arg, (IV)$var);
+ sv_setiv($arg, (IV)$var);
T_UV
- sv_setuv($arg, (UV)$var);
+ sv_setuv($arg, (UV)$var);
T_INT
- sv_setiv($arg, (IV)$var);
+ 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);
- }
+ 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);
+ sv_setiv($arg, (IV)$var);
T_BOOL
- $arg = boolSV($var);
+ $arg = boolSV($var);
T_U_INT
- sv_setuv($arg, (UV)$var);
+ sv_setuv($arg, (UV)$var);
T_SHORT
- sv_setiv($arg, (IV)$var);
+ sv_setiv($arg, (IV)$var);
T_U_SHORT
- sv_setuv($arg, (UV)$var);
+ sv_setuv($arg, (UV)$var);
T_LONG
- sv_setiv($arg, (IV)$var);
+ sv_setiv($arg, (IV)$var);
T_U_LONG
- sv_setuv($arg, (UV)$var);
+ sv_setuv($arg, (UV)$var);
T_CHAR
- sv_setpvn($arg, (char *)&$var, 1);
+ sv_setpvn($arg, (char *)&$var, 1);
T_U_CHAR
- sv_setuv($arg, (UV)$var);
+ sv_setuv($arg, (UV)$var);
T_FLOAT
- sv_setnv($arg, (double)$var);
+ sv_setnv($arg, (double)$var);
T_NV
- sv_setnv($arg, (NV)$var);
+ sv_setnv($arg, (NV)$var);
T_DOUBLE
- sv_setnv($arg, (double)$var);
+ sv_setnv($arg, (double)$var);
T_PV
- sv_setpv((SV*)$arg, $var);
+ sv_setpv((SV*)$arg, $var);
T_PTR
- sv_setiv($arg, PTR2IV($var));
+ sv_setiv($arg, PTR2IV($var));
T_PTRREF
- sv_setref_pv($arg, Nullch, (void*)$var);
+ sv_setref_pv($arg, Nullch, (void*)$var);
T_REF_IV_REF
- sv_setref_pv($arg, \"${ntype}\", (void*)new $ntype($var));
+ sv_setref_pv($arg, \"${ntype}\", (void*)new $ntype($var));
T_REF_IV_PTR
- sv_setref_pv($arg, \"${ntype}\", (void*)$var);
+ sv_setref_pv($arg, \"${ntype}\", (void*)$var);
T_PTROBJ
- sv_setref_pv($arg, \"${ntype}\", (void*)$var);
+ sv_setref_pv($arg, \"${ntype}\", (void*)$var);
T_PTRDESC
- sv_setref_pv($arg, \"${ntype}\", (void*)new\U${type}_DESC\E($var));
+ sv_setref_pv($arg, \"${ntype}\", (void*)new\U${type}_DESC\E($var));
T_REFREF
- NOT_IMPLEMENTED
+ NOT_IMPLEMENTED
T_REFOBJ
- NOT IMPLEMENTED
+ NOT IMPLEMENTED
T_OPAQUE
- sv_setpvn($arg, (char *)&$var, sizeof($var));
+ sv_setpvn($arg, (char *)&$var, sizeof($var));
T_OPAQUEPTR
- sv_setpvn($arg, (char *)$var, sizeof(*$var));
+ sv_setpvn($arg, (char *)$var, sizeof(*$var));
T_PACKED
- XS_pack_$ntype($arg, $var);
+ XS_pack_$ntype($arg, $var);
T_PACKEDARRAY
- XS_pack_$ntype($arg, $var, count_$ntype);
-T_DATAUNIT
- sv_setpvn($arg, $var.chp(), $var.size());
+ 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());
+ 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
- }
+ {
+ 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 = (GV *)sv_newmortal();
- PerlIO *fp = PerlIO_importFILE($var,0);
- gv_init(gv, gv_stashpv("$Package",1),"__ANONIO__",10,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;
- }
+ {
+ GV *gv = (GV *)sv_newmortal();
+ PerlIO *fp = PerlIO_importFILE($var,0);
+ gv_init(gv, gv_stashpv("$Package",1),"__ANONIO__",10,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 = (GV *)sv_newmortal();
- gv_init(gv, gv_stashpv("$Package",1),"__ANONIO__",10,0);
- 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;
- }
+ {
+ GV *gv = (GV *)sv_newmortal();
+ gv_init(gv, gv_stashpv("$Package",1),"__ANONIO__",10,0);
+ 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 = (GV *)sv_newmortal();
- gv_init(gv, gv_stashpv("$Package",1),"__ANONIO__",10,0);
- 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;
- }
+ {
+ GV *gv = (GV *)sv_newmortal();
+ gv_init(gv, gv_stashpv("$Package",1),"__ANONIO__",10,0);
+ 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 = (GV *)sv_newmortal();
- gv_init(gv, gv_stashpv("$Package",1),"__ANONIO__",10,0);
- 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;
- }
+ {
+ GV *gv = (GV *)sv_newmortal();
+ gv_init(gv, gv_stashpv("$Package",1),"__ANONIO__",10,0);
+ 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;
+ }
--
2.21.1
Reference in New Issue View Git Blame Copy Permalink