From: Steve Peters Date: Tue, 25 Oct 2005 11:56:53 +0000 (+0000) Subject: Upgrade to Time-HiRes-1.76 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=3d0346a5d1004526830c70905c56755aecc6a442;p=p5sagit%2Fp5-mst-13.2.git Upgrade to Time-HiRes-1.76 p4raw-id: //depot/perl@25845 --- diff --git a/ext/Time/HiRes/Changes b/ext/Time/HiRes/Changes index 8c25a10..3f7adc2 100644 --- a/ext/Time/HiRes/Changes +++ b/ext/Time/HiRes/Changes @@ -1,5 +1,13 @@ Revision history for Perl extension Time::HiRes. +1.76 [2005-10-22] + - testing for nanosleep had wrong logic which caused nanosleep + to become undefined for e.g. Mac OS X + - added a test for a core dump that was introduced by Perl 5.8.0 + safe signals and was fixed for the time of 5.8.1 (one report of + the core dump was [perl #20920]), the test skipped pre-5.8.1. + - *cough* s/unanosleep/nanosleep/g; *cough* + 1.75 [2005-10-18] - installation patch from Gisle Aas: in Perls 5.8.x and later use MakeMaker INSTALLDIRS value of 'perl' instead of 'site'. diff --git a/ext/Time/HiRes/HiRes.pm b/ext/Time/HiRes/HiRes.pm index 1a38b1e..70aab16 100644 --- a/ext/Time/HiRes/HiRes.pm +++ b/ext/Time/HiRes/HiRes.pm @@ -15,7 +15,7 @@ require DynaLoader; d_usleep d_ualarm d_gettimeofday d_getitimer d_setitimer d_nanosleep); -$VERSION = '1.75'; +$VERSION = '1.76'; $XS_VERSION = $VERSION; $VERSION = eval $VERSION; diff --git a/ext/Time/HiRes/HiRes.xs b/ext/Time/HiRes/HiRes.xs index df4ea06..dbd6590 100644 --- a/ext/Time/HiRes/HiRes.xs +++ b/ext/Time/HiRes/HiRes.xs @@ -362,10 +362,10 @@ gettimeofday (struct timeval *tp, void *tpz) * The TIME_HIRES_NANOSLEEP is set by Makefile.PL. */ #if !defined(HAS_USLEEP) && defined(TIME_HIRES_NANOSLEEP) #define HAS_USLEEP -#define usleep hrt_unanosleep /* could conflict with ncurses for static build */ +#define usleep hrt_nanosleep /* could conflict with ncurses for static build */ void -hrt_unanosleep(unsigned long usec) /* This is used to emulate usleep. */ +hrt_nanosleep(unsigned long usec) /* This is used to emulate usleep. */ { struct timespec res; res.tv_sec = usec/1000/1000; @@ -934,4 +934,3 @@ getitimer(which) #endif /* #if defined(HAS_GETITIMER) && defined(HAS_SETITIMER) */ - diff --git a/ext/Time/HiRes/Makefile.PL b/ext/Time/HiRes/Makefile.PL index 386958f..edc42de 100644 --- a/ext/Time/HiRes/Makefile.PL +++ b/ext/Time/HiRes/Makefile.PL @@ -1,7 +1,7 @@ #!/usr/bin/perl # # In general we trust %Config, but for nanosleep() this trust -# may be misplaces (it may be linkable but not really functional). +# may be misplaced (it may be linkable but not really functional). # Use $ENV{FORCE_NANOSLEEP_SCAN} to force rescanning whether there # really is hope. @@ -222,7 +222,7 @@ EOM } sub has_nanosleep { - print "Trying out nanosleep... "; + print "testing... "; return 1 if try_compile_and_link(< 1); #include @@ -383,16 +383,27 @@ EOD print "Looking for nanosleep()... "; my $has_nanosleep; - if (exists $Config{d_nanosleep} && !$ENV{FORCE_NANOSLEEP_SCAN}) { - # Believe $Config{d_nanosleep}. + if ($ENV{FORCE_NANOSLEEP_SCAN}) { + print "forced scan... "; + if (has_nanosleep()) { + $has_nanosleep++; + $DEFINE .= ' -DTIME_HIRES_NANOSLEEP'; + } + } + elsif (exists $Config{d_nanosleep}) { + print "believing \$Config{d_nanosleep}... "; if ($Config{d_nanosleep}) { $has_nanosleep++; $DEFINE .= ' -DTIME_HIRES_NANOSLEEP'; } - } elsif ($^O ne 'mpeix' && # MPE/iX falsely finds nanosleep. - has_nanosleep()) { - $has_nanosleep++; - $DEFINE .= ' -DTIME_HIRES_NANOSLEEP'; + } elsif ($^O =~ /^(mpeix)$/) { + # MPE/iX falsely finds nanosleep from its libc equivalent. + print "skipping because in $^O... "; + } else { + if (has_nanosleep()) { + $has_nanosleep++; + $DEFINE .= ' -DTIME_HIRES_NANOSLEEP'; + } } if ($has_nanosleep) { diff --git a/ext/Time/HiRes/t/HiRes.t b/ext/Time/HiRes/t/HiRes.t index 3bc58ed..e7d383c 100644 --- a/ext/Time/HiRes/t/HiRes.t +++ b/ext/Time/HiRes/t/HiRes.t @@ -12,7 +12,7 @@ BEGIN { } } -BEGIN { $| = 1; print "1..28\n"; } +BEGIN { $| = 1; print "1..29\n"; } END { print "not ok 1\n" unless $loaded } @@ -30,6 +30,12 @@ my $have_nanosleep = defined &Time::HiRes::nanosleep; my $have_ualarm = defined &Time::HiRes::ualarm; my $have_time = defined &Time::HiRes::time; +printf "# have_gettimeofday = %d\n", $have_gettimeofday; +printf "# have_usleep = %d\n", $have_usleep; +printf "# have_nanosleep = %d\n", $have_nanosleep; +printf "# have_ualarm = %d\n", $have_ualarm; +printf "# have_time = %d\n", $have_time; + import Time::HiRes 'gettimeofday' if $have_gettimeofday; import Time::HiRes 'usleep' if $have_usleep; import Time::HiRes 'nanosleep' if $have_nanosleep; @@ -39,26 +45,29 @@ use Config; my $have_alarm = $Config{d_alarm}; my $have_fork = $Config{d_fork}; -my $waitfor = 60; # 10 seconds is normal. -my $pid; +my $waitfor = 60; # 10-20 seconds is normal (load affects this). +my $timer_pid; if ($have_fork) { - print "# I am process $$, starting the timer process\n"; - if (defined ($pid = fork())) { - if ($pid == 0) { # We are the kid, set up the timer. - print "# I am timer process $$\n"; + print "# I am the main process $$, starting the timer process...\n"; + $timer_pid = fork(); + if (defined $timer_pid) { + if ($timer_pid == 0) { # We are the kid, set up the timer. + 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 the testing process\n"; + warn "\n$0: overall time allowed for tests (${waitfor}s) exceeded!\n"; + print "# Terminating the main process...\n"; kill('TERM', getppid()); - print "# Timer process exiting\n"; + print "# This is the timer process $$, over and out.\n"; exit(0); + } else { + print "# Timer process $timer_pid launched, continuing testing...\n"; } } else { warn "$0: fork failed: $!\n"; } } else { - print "# No timer process\n"; + print "# No timer process (need fork)\n"; } my $xdefine = ''; @@ -95,7 +104,7 @@ sub ok { } } -if (!$have_gettimeofday) { +unless ($have_gettimeofday) { skip 2..6; } else { @@ -114,7 +123,7 @@ else { ok 6, $f - $two[0] < 2, "$f - $two[0] >= 2"; } -if (!$have_usleep) { +unless ($have_usleep) { skip 7..8; } else { @@ -125,7 +134,7 @@ else { my $three = time; ok 7, $one == $two || $two == $three, "slept too long, $one $two $three"; - if (!$have_gettimeofday) { + unless ($have_gettimeofday) { skip 8; } else { @@ -143,7 +152,7 @@ else { ok 9, abs($f - 5.4) < 0.001, $f; } -if (!$have_gettimeofday) { +unless ($have_gettimeofday) { skip 10; } else { @@ -152,7 +161,7 @@ else { ok 10, $f < 2, $f; } -if (!$have_usleep || !$have_gettimeofday) { +unless ($have_usleep && $have_gettimeofday) { skip 11; } else { @@ -162,7 +171,7 @@ else { ok 11, $f > 0.4 && $f < 0.9, "slept $f instead of 0.5 secs."; } -if (!$have_ualarm || !$have_alarm) { +unless ($have_ualarm && $have_alarm) { skip 12..13; } else { @@ -183,7 +192,7 @@ else { # Did we even get close? -if (!$have_time) { +unless ($have_time) { skip 14; } else { my ($s, $n, $i) = (0); @@ -350,7 +359,7 @@ if ($have_gettimeofday) { } } -if (!$have_nanosleep) { +unless ($have_nanosleep) { skip 22..23; } else { @@ -361,7 +370,7 @@ else { my $three = CORE::time; ok 22, $one == $two || $two == $three, "slept too long, $one $two $three"; - if (!$have_gettimeofday) { + unless ($have_gettimeofday) { skip 23; } else { @@ -402,9 +411,24 @@ if ($have_nanosleep) { skip 28; } -if (defined $pid) { - print "# I am process $$, terminating the timer process $pid\n"; - kill('TERM', $pid); # We are done, the timer can go. - unlink("ktrace.out"); +if ($have_ualarm && $] >= 5.008001) { + # http://groups.google.com/group/perl.perl5.porters/browse_thread/thread/adaffaaf939b042e/20dafc298df737f0%2320dafc298df737f0?sa=X&oi=groupsr&start=0&num=3 + # Perl changes [18765] and [18770], perl bug [perl #20920] + use Time::HiRes qw(alarm); + $SIG{ALRM} = sub { 1 for 1..100000 }; + alarm(0.01, 0.01); + sleep(1); + print "ok 29\n"; # Not core dumping by now is considered to be the success. +} else { + skip 29; +} + +END { + if (defined $timer_pid) { + print "# I am the main process $$, terminating the timer process $timer_pid.\n"; + kill('TERM', $timer_pid); # We are done, the timer can go. + unlink("ktrace.out"); # Used in BSD system call tracing. + print "# All done.\n"; + } }