5432 lines
168 KiB
Diff
5432 lines
168 KiB
Diff
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
|
|
|