rpms/perl
3
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity
88c196e7f4
perl/perl-update-Time-HiRes.patch
Štěpán Kasal 26b7a08961 - remove compatibility obsolete sitelib directories 
- use a better BuildRoot
- drop a redundant mkdir in %%install
- call patchlevel.h only once; rm patchlevel.bak
- update modules Sys::Syslog, Module::Load::Conditional, Module::CoreList,
    Test::Harness, Test::Simple, CGI.pm (dropping the upstreamed patch),
    File::Path (that includes our perl-5.10.0-CVE-2008-2827.patch),
    constant, Pod::Simple, Archive::Tar, Archive::Extract, File::Fetch,
    File::Temp, IPC::Cmd, Time::HiRes, Module::Build, ExtUtils::CBuilder
- standardize the patches for updating embedded modules
- work around a bug in Module::Build tests bu setting TMPDIR to a directory
    inside the source tree
2009-03-11 21:12:37 +00:00

687 lines
24 KiB
Diff
Raw Blame History

Time-HiRes-1.9719
diff -urN perl-5.10.0.orig/ext/Time/HiRes/Changes perl-5.10.0/ext/Time/HiRes/Changes
--- perl-5.10.0.orig/ext/Time/HiRes/Changes 2007-12-18 11:47:07.000000000 +0100
+++ perl-5.10.0/ext/Time/HiRes/Changes 2009-03-10 17:48:02.000000000 +0100
@@ -1,5 +1,66 @@
Revision history for the Perl extension Time::HiRes.
+1.9719 [2009-01-04]
+ - As with QNX, Haiku has the API of interval timers but not
+ the implementation (bleadperl change #34630), hence skip
+ the tests, via David Mitchell.
+
+1.9718 [2008-12-31]
+ - .xs code cleanup from Albert Dvornik
+ - in the #39 and #40 do not do us I did, mixing alarm() and
+ sleep(). Now instead spin until enough time has passed.
+
+1.9717 [2008-12-30]
+ - Skip the tests added in 1.9716 (#39, #40) if there's no subsecond
+ alarm capability, like with the older subsecond alarm tests
+
+1.9716 [2008-12-26]
+ - Change documentation to agree with reality: there are
+ no interval timers in Win32.
+ - Address [rt.cpan.org #35899] (problem in subsecond sleeps),
+ add two tests to guard against this problem
+ - Address [rt.cpan.org #36600] 'Division by zero' failure in test suite
+ - Address [rt.cpan.org #37340] [PATCH] Address timer process in test
+ - Address [rt.cpan.org#40311 ] bad implementation of hrt_usleep
+ with TIME_HIRES_NANOSLEEP
+
+1.9715 [2008-04-08]
+ - Silly me: Makefile.PL does need to accept arguments other than mine.
+ Some testing frameworks obviously do this.
+ - Add retrying for tests 34..37, which are the most commonly
+ failing tests. If this helps, consider extending the retry
+ framework to all the tests. [Inspired by Slaven Rezic,
+ [rt.cpan.org #34711] Occasional failures of test 35 or 36 (FreeBSD)]
+
+1.9714 [2008-04-07]
+ - Under Perl 5.6.* NVgf needs to be "g", reported by Zefram,
+ it seems that ppport.h 3.13 gets this wrong.
+ - remove the check in Makefile.PL for 5.7.2, shouldn't be
+ (a) necessary (b) relevant
+ - add logic to Makefile.PL to skip configure/write Makefile
+ step if the "xdefine" file already exists, indicating that
+ the configure step has already been done, one can still
+ force (re)configure by "perl Makefile.PL configure",
+ or of course by "make clean && perl Makefile.PL".
+
+1.9713 [2008-04-04]
+ - for alarm() and ualarm() [Perl] prefer setitimer() [C]
+ instead of ualarm() [C] since ualarm() [C] cannot portably
+ (and standards-compliantly) be used for more than 999_999
+ microseconds (rt.cpan.org #34655)
+ - it seems that HP-UX has started (at least in 11.31 ia64)
+ #defining the CLOCK_REALTIME et alia (instead of having
+ them just as enums)
+ - document all the diagnostics
+
+1.9712 [2008-02-09]
+ - move the sub tick in the test file back to where it used to be
+ - in the "consider upgrading" message recommend at least Perl 5.8.8
+ and make the message to appear only for 5.8.0 since 5.8.1 and
+ later have the problem fixed
+ - VOS tweak for Makefile (core perl change #33259)
+ - since the test #17 seems to fail often, relax its limits a bit
+
1.9711 [2007-11-29]
- lost VMS test skippage from Craig Berry
- reformat the test code a little
diff -urN perl-5.10.0.orig/ext/Time/HiRes/HiRes.pm perl-5.10.0/ext/Time/HiRes/HiRes.pm
--- perl-5.10.0.orig/ext/Time/HiRes/HiRes.pm 2007-12-18 11:47:07.000000000 +0100
+++ perl-5.10.0/ext/Time/HiRes/HiRes.pm 2009-03-10 17:48:02.000000000 +0100
@@ -22,8 +22,8 @@
d_clock d_clock_nanosleep
stat
);
-
-$VERSION = '1.9711';
+
+$VERSION = '1.9719';
$XS_VERSION = $VERSION;
$VERSION = eval $VERSION;
@@ -209,6 +209,9 @@
Issues a C<ualarm> call; the C<$interval_useconds> is optional and
will be zero if unspecified, resulting in C<alarm>-like behaviour.
+Returns the remaining time in the alarm in microseconds, or C<undef>
+if an error occurred.
+
ualarm(0) will cancel an outstanding ualarm().
Note that the interaction between alarms and sleeps is unspecified.
@@ -260,10 +263,14 @@
=item alarm ( $floating_seconds [, $interval_floating_seconds ] )
The C<SIGALRM> signal is sent after the specified number of seconds.
-Implemented using C<ualarm()>. The C<$interval_floating_seconds> argument
-is optional and will be zero if unspecified, resulting in C<alarm()>-like
-behaviour. This function can be imported, resulting in a nice drop-in
-replacement for the C<alarm> provided with perl, see the L</EXAMPLES> below.
+Implemented using C<setitimer()> if available, C<ualarm()> if not.
+The C<$interval_floating_seconds> argument is optional and will be
+zero if unspecified, resulting in C<alarm()>-like behaviour. This
+function can be imported, resulting in a nice drop-in replacement for
+the C<alarm> provided with perl, see the L</EXAMPLES> below.
+
+Returns the remaining time in the alarm in seconds, or C<undef>
+if an error occurred.
B<NOTE 1>: With some combinations of operating systems and Perl
releases C<SIGALRM> restarts C<select()>, instead of interrupting it.
@@ -292,9 +299,9 @@
There are usually three or four interval timers (signals) available: the
C<$which> can be C<ITIMER_REAL>, C<ITIMER_VIRTUAL>, C<ITIMER_PROF>, or
C<ITIMER_REALPROF>. Note that which ones are available depends: true
-UNIX platforms usually have the first three, but (for example) Win32
-and Cygwin have only C<ITIMER_REAL>, and only Solaris seems to have
-C<ITIMER_REALPROF> (which is used to profile multithreaded programs).
+UNIX platforms usually have the first three, but only Solaris seems to
+have C<ITIMER_REALPROF> (which is used to profile multithreaded programs).
+Win32 unfortunately does not haveinterval timers.
C<ITIMER_REAL> results in C<alarm()>-like behaviour. Time is counted in
I<real time>; that is, wallclock time. C<SIGALRM> is delivered when
@@ -337,8 +344,8 @@
CLOCK_REALTIME is zero, it might be one, or something else.
Another potentially useful (but not available everywhere) value is
C<CLOCK_MONOTONIC>, which guarantees a monotonically increasing time
-value (unlike time(), which can be adjusted). See your system
-documentation for other possibly supported values.
+value (unlike time() or gettimeofday(), which can be adjusted).
+See your system documentation for other possibly supported values.
=item clock_getres ( $which )
@@ -528,6 +535,15 @@
Something went horribly wrong-- the number of microseconds that cannot
become negative just became negative. Maybe your compiler is broken?
+=head2 useconds or uinterval equal to or more than 1000000
+
+In some platforms it is not possible to get an alarm with subsecond
+resolution and later than one second.
+
+=head2 unimplemented in this platform
+
+Some calls simply aren't available, real or emulated, on every platform.
+
=head1 CAVEATS
Notice that the core C<time()> maybe rounding rather than truncating.
@@ -544,6 +560,9 @@
Note that since Time::HiRes 1.77 the clock_gettime(CLOCK_MONOTONIC)
might help in this (in case your system supports CLOCK_MONOTONIC).
+Some systems have APIs but not implementations: for example QNX and Haiku
+have the interval timer APIs but not the functionality.
+
=head1 SEE ALSO
Perl modules L<BSD::Resource>, L<Time::TAI64>.
@@ -563,7 +582,8 @@
Copyright (c) 1996-2002 Douglas E. Wegscheid. All rights reserved.
-Copyright (c) 2002, 2003, 2004, 2005, 2006, 2007 Jarkko Hietaniemi. All rights reserved.
+Copyright (c) 2002, 2003, 2004, 2005, 2006, 2007, 2008 Jarkko Hietaniemi.
+All rights reserved.
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
diff -urN perl-5.10.0.orig/ext/Time/HiRes/HiRes.xs perl-5.10.0/ext/Time/HiRes/HiRes.xs
--- perl-5.10.0.orig/ext/Time/HiRes/HiRes.xs 2007-12-18 11:47:07.000000000 +0100
+++ perl-5.10.0/ext/Time/HiRes/HiRes.xs 2009-03-10 17:48:02.000000000 +0100
@@ -2,7 +2,8 @@
*
* Copyright (c) 1996-2002 Douglas E. Wegscheid. All rights reserved.
*
- * Copyright (c) 2002,2003,2004,2005,2006,2007 Jarkko Hietaniemi. All rights reserved.
+ * Copyright (c) 2002,2003,2004,2005,2006,2007,2008 Jarkko Hietaniemi.
+ * All rights reserved.
*
* This program is free software; you can redistribute it and/or modify
* it under the same terms as Perl itself.
@@ -37,6 +38,13 @@
}
#endif
+/* At least ppport.h 3.13 gets this wrong: one really cannot
+ * have NVgf as anything else than "g" under Perl 5.6.x. */
+#if PERL_REVISION == 5 && PERL_VERSION == 6
+# undef NVgf
+# define NVgf "g"
+#endif
+
#define IV_1E6 1000000
#define IV_1E7 10000000
#define IV_1E9 1000000000
@@ -71,9 +79,13 @@
/* 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
-# define CLOCK_REALTIME CLOCK_REALTIME
-# define CLOCK_VIRTUAL CLOCK_VIRTUAL
-# define CLOCK_PROFILE CLOCK_PROFILE
+/* However, it seems that at least in HP-UX 11.31 ia64 there *are*
+ * defines for these, so let's try detecting them. */
+# ifndef CLOCK_REALTIME
+# define CLOCK_REALTIME CLOCK_REALTIME
+# define CLOCK_VIRTUAL CLOCK_VIRTUAL
+# define CLOCK_PROFILE CLOCK_PROFILE
+# endif
# endif /* # ifdef __hpux */
#endif /* #if defined(TIME_HIRES_CLOCK_GETTIME) && defined(_STRUCT_ITIMERSPEC) */
@@ -390,10 +402,10 @@
* The TIME_HIRES_NANOSLEEP is set by Makefile.PL. */
#if !defined(HAS_USLEEP) && defined(TIME_HIRES_NANOSLEEP)
#define HAS_USLEEP
-#define usleep hrt_nanosleep /* could conflict with ncurses for static build */
+#define usleep hrt_usleep /* could conflict with ncurses for static build */
void
-hrt_nanosleep(unsigned long usec) /* This is used to emulate usleep. */
+hrt_usleep(unsigned long usec) /* This is used to emulate usleep. */
{
struct timespec res;
res.tv_sec = usec / IV_1E6;
@@ -433,21 +445,6 @@
}
#endif /* #if !defined(HAS_USLEEP) && defined(WIN32) */
-#if !defined(HAS_USLEEP) && defined(TIME_HIRES_NANOSLEEP)
-#define HAS_USLEEP
-#define usleep hrt_usleep /* could conflict with ncurses for static build */
-
-void
-hrt_usleep(unsigned long usec)
-{
- struct timespec ts1;
- ts1.tv_sec = usec * 1000; /* Ignoring wraparound. */
- ts1.tv_nsec = 0;
- nanosleep(&ts1, NULL);
-}
-
-#endif /* #if !defined(HAS_USLEEP) && defined(TIME_HIRES_NANOSLEEP) */
-
#if !defined(HAS_USLEEP) && defined(HAS_POLL)
#define HAS_USLEEP
#define usleep hrt_usleep /* could conflict with ncurses for static build */
@@ -462,16 +459,24 @@
#endif /* #if !defined(HAS_USLEEP) && defined(HAS_POLL) */
#if defined(HAS_SETITIMER) && defined(ITIMER_REAL)
+
+static int
+hrt_ualarm_itimero(struct itimerval* itv, int usec, int uinterval)
+{
+ itv->it_value.tv_sec = usec / IV_1E6;
+ itv->it_value.tv_usec = usec % IV_1E6;
+ itv->it_interval.tv_sec = uinterval / IV_1E6;
+ itv->it_interval.tv_usec = uinterval % IV_1E6;
+ return setitimer(ITIMER_REAL, itv, 0);
+}
+
int
-hrt_ualarm_itimer(int usec, int interval)
+hrt_ualarm_itimer(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 = interval / IV_1E6;
- itv.it_interval.tv_usec = interval % IV_1E6;
- return setitimer(ITIMER_REAL, &itv, 0);
+ struct itimerval itv;
+ return hrt_ualarm_itimero(&itv, usec, uinterval);
}
+
#ifdef HAS_UALARM
int
hrt_ualarm(int usec, int interval) /* for binary compat before 1.91 */
@@ -898,21 +903,27 @@
#ifdef HAS_UALARM
-int
-ualarm(useconds,interval=0)
+IV
+ualarm(useconds,uinterval=0)
int useconds
- int interval
+ int uinterval
CODE:
- if (useconds < 0 || interval < 0)
- croak("Time::HiRes::ualarm(%d, %d): negative time not invented yet", useconds, interval);
- if (useconds >= IV_1E6 || interval >= IV_1E6)
+ 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)
- RETVAL = hrt_ualarm_itimer(useconds, interval);
+ {
+ struct itimerval itv;
+ if (hrt_ualarm_itimero(&itv, useconds, uinterval)) {
+ RETVAL = itv.it_value.tv_sec + IV_1E6 * itv.it_value.tv_usec;
+ } else {
+ RETVAL = 0;
+ }
+ }
#else
- croak("Time::HiRes::ualarm(%d, %d): useconds or interval equal or more than %"IVdf, useconds, interval, IV_1E6);
+ 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
- else
- RETVAL = ualarm(useconds, interval);
OUTPUT:
RETVAL
@@ -924,8 +935,24 @@
CODE:
if (seconds < 0.0 || interval < 0.0)
croak("Time::HiRes::alarm(%"NVgf", %"NVgf"): negative time not invented yet", seconds, interval);
- RETVAL = (NV)ualarm((IV)(seconds * IV_1E6),
- (IV)(interval * IV_1E6)) / NV_1E6;
+ {
+ IV useconds = IV_1E6 * seconds;
+ IV uinterval = IV_1E6 * interval;
+#if defined(HAS_SETITIMER) && defined(ITIMER_REAL)
+ {
+ struct itimerval itv;
+ if (hrt_ualarm_itimero(&itv, useconds, uinterval)) {
+ RETVAL = (NV)itv.it_value.tv_sec + (NV)itv.it_value.tv_usec / NV_1E6;
+ } else {
+ RETVAL = 0;
+ }
+ }
+#else
+ if (useconds >= IV_1E6 || uinterval >= IV_1E6)
+ croak("Time::HiRes::alarm(%d, %d): seconds or interval equal to or more than 1.0 ", useconds, uinterval, IV_1E6);
+ RETVAL = (NV)ualarm( useconds, uinterval ) / NV_1E6;
+#endif
+ }
OUTPUT:
RETVAL
diff -urN perl-5.10.0.orig/ext/Time/HiRes/Makefile.PL perl-5.10.0/ext/Time/HiRes/Makefile.PL
--- perl-5.10.0.orig/ext/Time/HiRes/Makefile.PL 2007-12-18 11:47:07.000000000 +0100
+++ perl-5.10.0/ext/Time/HiRes/Makefile.PL 2009-03-10 17:48:02.000000000 +0100
@@ -19,8 +19,11 @@
use vars qw($self); # Used in 'sourcing' the hints.
+# TBD: Can we just use $Config(exe_ext) here instead of this complex
+# expression?
my $ld_exeext = ($^O eq 'cygwin' ||
- $^O eq 'os2' && $Config{ldflags} =~ /-Zexe\b/) ? '.exe' : '';
+ $^O eq 'os2' && $Config{ldflags} =~ /-Zexe\b/) ? '.exe' :
+ (($^O eq 'vos') ? $Config{exe_ext} : '');
unless($ENV{PERL_CORE}) {
$ENV{PERL_CORE} = 1 if grep { $_ eq 'PERL_CORE=1' } @ARGV;
@@ -829,38 +832,43 @@
}
sub main {
- print "Configuring Time::HiRes...\n";
- if ($] == 5.007002) {
- die "Cannot Configure Time::HiRes for Perl $], aborting.\n";
- }
-
- if ($^O =~ /Win32/i) {
- DEFINE('SELECT_IS_BROKEN');
- $LIBS = [];
- print "System is $^O, skipping full configure...\n";
- } else {
- init();
+ if (-f "xdefine" && !(@ARGV && $ARGV[0] eq '--configure')) {
+ print qq[$0: The "xdefine" exists, skipping the configure step.\n];
+ print qq[("$^X $0 --configure" to force the configure step)\n];
+ } else {
+ print "Configuring Time::HiRes...\n";
+ 1 while unlink("define");
+ if ($^O =~ /Win32/i) {
+ DEFINE('SELECT_IS_BROKEN');
+ $LIBS = [];
+ print "System is $^O, skipping full configure...\n";
+ open(XDEFINE, ">xdefine") or die "$0: Cannot create xdefine: $!\n";
+ close(XDEFINE);
+ } else {
+ init();
+ }
+ doMakefile;
+ doConstants;
}
- doMakefile;
- doConstants;
my $make = $Config{'make'} || "make";
unless (exists $ENV{PERL_CORE} && $ENV{PERL_CORE}) {
print <<EOM;
Now you may issue '$make'. Do not forget also '$make test'.
EOM
- if ((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)) {
+ if ($] == 5.008 &&
+ ((exists $ENV{LC_ALL} && $ENV{LC_ALL} =~ /utf-?8/i) ||
+ (exists $ENV{LC_CTYPE} && $ENV{LC_CTYPE} =~ /utf-?8/i) ||
+ (exists $ENV{LANG} && $ENV{LANG} =~ /utf-?8/i))) {
print <<EOM;
NOTE: if you get an error like this (the Makefile line number may vary):
Makefile:91: *** missing separator
then set the environment variable LC_ALL to "C" and retry
from scratch (re-run perl "Makefile.PL").
-(And consider upgrading your Perl.)
+(And consider upgrading your Perl to, say, at least Perl 5.8.8.)
(You got this message because you seem to have
an UTF-8 locale active in your shell environment, this used
- to cause broken Makefiles to be created from Makefile.PLs.)
+ to cause broken Makefiles to be created from Makefile.PLs)
EOM
}
}
diff -urN perl-5.10.0.orig/ext/Time/HiRes/t/HiRes.t perl-5.10.0/ext/Time/HiRes/t/HiRes.t
--- perl-5.10.0.orig/ext/Time/HiRes/t/HiRes.t 2007-12-18 11:47:07.000000000 +0100
+++ perl-5.10.0/ext/Time/HiRes/t/HiRes.t 2009-03-10 17:48:02.000000000 +0100
@@ -12,7 +12,7 @@
}
}
-BEGIN { $| = 1; print "1..38\n"; }
+BEGIN { $| = 1; print "1..40\n"; }
END { print "not ok 1\n" unless $loaded }
@@ -68,7 +68,7 @@
my $have_alarm = $Config{d_alarm};
my $have_fork = $Config{d_fork};
-my $waitfor = 180; # 30-45 seconds is normal (load affects this).
+my $waitfor = 360; # 30-45 seconds is normal (load affects this).
my $timer_pid;
my $TheEnd;
@@ -79,11 +79,14 @@
if ($timer_pid == 0) { # We are the kid, set up the timer.
my $ppid = getppid();
print "# I am the timer process $$, sleeping for $waitfor seconds...\n";
- sleep($waitfor);
- warn "\n$0: overall time allowed for tests (${waitfor}s) exceeded!\n";
- print "# Terminating main process $ppid...\n";
- kill('TERM', $ppid);
- print "# This is the timer process $$, over and out.\n";
+ sleep($waitfor - 2); # Workaround for perlbug #49073
+ sleep(2); # Wait for parent to exit
+ if (kill(0, $ppid)) { # Check if parent still exists
+ warn "\n$0: overall time allowed for tests (${waitfor}s) exceeded!\n";
+ print "# Terminating main process $ppid...\n";
+ kill('KILL', $ppid);
+ print "# This is the timer process $$, over and out.\n";
+ }
exit(0);
} else {
print "# The timer process $timer_pid launched, continuing testing...\n";
@@ -238,10 +241,13 @@
$has_ualarm ||= $xdefine =~ /-DHAS_UALARM/;
-unless ( defined &Time::HiRes::gettimeofday
- && defined &Time::HiRes::ualarm
- && defined &Time::HiRes::usleep
- && $has_ualarm) {
+my $can_subsecond_alarm =
+ defined &Time::HiRes::gettimeofday &&
+ defined &Time::HiRes::ualarm &&
+ defined &Time::HiRes::usleep &&
+ $has_ualarm;
+
+unless ($can_subsecond_alarm) {
for (15..17) {
print "ok $_ # Skip: no gettimeofday or no ualarm or no usleep\n";
}
@@ -271,19 +277,6 @@
# Perl's deferred signals may be too wimpy to break through
# a restartable select(), so use POSIX::sigaction if available.
- sub tick {
- $i--;
- my $ival = Time::HiRes::tv_interval ($r);
- print "# Tick! $i $ival\n";
- my $exp = 0.3 * (5 - $i);
- # 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;
- }
- }
-
POSIX::sigaction(&POSIX::SIGALRM,
POSIX::SigAction->new("tick"),
$oldaction)
@@ -314,8 +307,12 @@
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) > 3*$limit) {
+ if (abs($ival/$exp - 1) > 4*$limit) {
my $ratio = abs($ival/$exp);
$not = "while: $exp sleep took $ival ratio $ratio";
last;
@@ -324,6 +321,23 @@
}
}
+ sub tick {
+ $i--;
+ my $ival = Time::HiRes::tv_interval ($r);
+ print "# Tick! $i $ival\n";
+ my $exp = 0.3 * (5 - $i);
+ if ($exp == 0) {
+ $not = "tick: divisor became zero";
+ last;
+ }
+ # This test is more sensitive, so impose a softer limit.
+ if (abs($ival/$exp - 1) > 4*$limit) {
+ my $ratio = abs($ival/$exp);
+ $not = "tick: $exp sleep took $ival ratio $ratio";
+ $i = 0;
+ }
+ }
+
if ($use_sigaction) {
POSIX::sigaction(&POSIX::SIGALRM, $oldaction);
} else {
@@ -333,11 +347,13 @@
print $not ? "not ok 17 # $not\n" : "ok 17 # $ok\n";
}
-unless ( defined &Time::HiRes::setitimer
+unless (defined &Time::HiRes::setitimer
&& defined &Time::HiRes::getitimer
&& has_symbol('ITIMER_VIRTUAL')
&& $Config{sig_name} =~ m/\bVTALRM\b/
- && $^O !~ /^(nto)$/) { # nto: QNX 6 has the API but no implementation
+ && $^O ne 'nto' # nto: QNX 6 has the API but no implementation
+ && $^O ne 'haiku' # haiku: has the API but no implementation
+ ) {
for (18..19) {
print "ok $_ # Skip: no virtual interval timers\n";
}
@@ -502,13 +518,14 @@
};
# Next setup a periodic timer (the two-argument alarm() of
- # Time::HiRes, behind the curtains the libc ualarm()) which has
- # a signal handler that takes so much time (on the first initial
- # invocation) that the first periodic invocation (second invocation)
- # will happen before the first invocation has finished. In Perl 5.8.0
- # the "safe signals" concept was implemented, with unfortunately at least
- # one bug that caused a core dump on reentering the handler. This bug
- # was fixed by the time of Perl 5.8.1.
+ # Time::HiRes, behind the curtains the libc getitimer() or
+ # ualarm()) which has a signal handler that takes so much time (on
+ # the first initial invocation) that the first periodic invocation
+ # (second invocation) will happen before the first invocation has
+ # finished. In Perl 5.8.0 the "safe signals" concept was
+ # implemented, with unfortunately at least one bug that caused a
+ # core dump on reentering the handler. This bug was fixed by the
+ # time of Perl 5.8.1.
# Do not try mixing sleep() and alarm() for testing this.
@@ -620,6 +637,16 @@
skip 33;
}
+sub bellish { # Cheap emulation of a bell curve.
+ my ($min, $max) = @_;
+ my $rand = ($max - $min) / 5;
+ my $sum = 0;
+ for my $i (0..4) {
+ $sum += rand($rand);
+ }
+ return $min + $sum;
+}
+
if ($have_ualarm) {
# 1_100_000 sligthly over 1_000_000,
# 2_200_000 slightly over 2**31/1000,
@@ -629,21 +656,29 @@
[36, 2_200_000],
[37, 4_300_000]) {
my ($i, $n) = @$t;
- my $alarmed = 0;
- local $SIG{ ALRM } = sub { $alarmed++ };
- my $t0 = Time::HiRes::time();
- print "# t0 = $t0\n";
- print "# ualarm($n)\n";
- ualarm($n); 1 while $alarmed == 0;
- my $t1 = Time::HiRes::time();
- print "# t1 = $t1\n";
- my $dt = $t1 - $t0;
- print "# dt = $dt\n";
- my $r = $dt / ($n/1e6);
- print "# r = $r\n";
- ok $i,
- ($n < 1_000_000 || # Too much noise.
- $r >= 0.8 && $r <= 1.6), "ualarm($n) close enough";
+ my $ok;
+ for my $retry (1..10) {
+ my $alarmed = 0;
+ local $SIG{ ALRM } = sub { $alarmed++ };
+ my $t0 = Time::HiRes::time();
+ print "# t0 = $t0\n";
+ print "# ualarm($n)\n";
+ ualarm($n); 1 while $alarmed == 0;
+ my $t1 = Time::HiRes::time();
+ print "# t1 = $t1\n";
+ my $dt = $t1 - $t0;
+ print "# dt = $dt\n";
+ my $r = $dt / ($n/1e6);
+ print "# r = $r\n";
+ $ok =
+ ($n < 1_000_000 || # Too much noise.
+ ($r >= 0.8 && $r <= 1.6));
+ last if $ok;
+ my $nap = bellish(3, 15);
+ printf "# Retrying in %.1f seconds...\n", $nap;
+ Time::HiRes::sleep($nap);
+ }
+ ok $i, $ok, "ualarm($n) close enough";
}
} else {
print "# No ualarm\n";
@@ -710,12 +745,37 @@
skip 38;
}
+unless ($can_subsecond_alarm) {
+ skip 39..40;
+} else {
+ {
+ my $alrm;
+ $SIG{ALRM} = sub { $alrm++ };
+ Time::HiRes::alarm(0.1);
+ my $t0 = time();
+ 1 while time() - $t0 <= 1;
+ print $alrm ? "ok 39\n" : "not ok 39\n";
+ }
+ {
+ my $alrm;
+ $SIG{ALRM} = sub { $alrm++ };
+ Time::HiRes::alarm(1.1);
+ my $t0 = time();
+ 1 while time() - $t0 <= 2;
+ print $alrm ? "ok 40\n" : "not ok 40\n";
+ }
+}
+
END {
if ($timer_pid) { # Only in the main process.
my $left = $TheEnd - time();
printf "# I am the main process $$, terminating the timer process $timer_pid\n# before it terminates me in %d seconds (testing took %d seconds).\n", $left, $waitfor - $left;
- my $kill = kill('TERM', $timer_pid); # We are done, the timer can go.
- printf "# kill TERM $timer_pid = %d\n", $kill;
+ if (kill(0, $timer_pid)) {
+ local $? = 0;
+ my $kill = kill('KILL', $timer_pid); # We are done, the timer can go.
+ wait();
+ printf "# kill KILL $timer_pid = %d\n", $kill;
+ }
unlink("ktrace.out"); # Used in BSD system call tracing.
print "# All done.\n";
}
Reference in New Issue View Git Blame Copy Permalink