From 8716488cb3bf92cb12be1776c49be2c55e590733 Mon Sep 17 00:00:00 2001 From: Jitka Plesnikova Date: Thu, 12 May 2022 15:21:50 +0200 Subject: [PATCH] Upgrade to 1.9770 --- HiRes.pm | 2 +- HiRes.xs | 9 ++++---- Makefile.PL | 22 +++++++++++++----- t/Watchdog.pm | 12 +++++----- t/stat.t | 62 ++++++++++++++++++++++++++++++--------------------- 5 files changed, 66 insertions(+), 41 deletions(-) diff --git a/HiRes.pm b/HiRes.pm index 9377c34..7e21047 100644 --- a/HiRes.pm +++ b/HiRes.pm @@ -50,7 +50,7 @@ our @EXPORT_OK = qw (usleep sleep ualarm alarm gettimeofday time tv_interval stat lstat utime ); -our $VERSION = '1.9767'; +our $VERSION = '1.9770'; our $XS_VERSION = $VERSION; $VERSION = eval $VERSION; diff --git a/HiRes.xs b/HiRes.xs index 1b97962..1eb7de3 100644 --- a/HiRes.xs +++ b/HiRes.xs @@ -20,6 +20,7 @@ extern "C" { #include "XSUB.h" #include "reentr.h" #ifdef USE_PPPORT_H +#define NEED_ck_warner # include "ppport.h" #endif #if defined(__CYGWIN__) && defined(HAS_W32API_WINDOWS_H) @@ -1192,7 +1193,7 @@ gettimeofday() int status; status = gettimeofday (&Tp, NULL); if (status == 0) { - if (GIMME == G_ARRAY) { + if (GIMME == G_LIST) { EXTEND(sp, 2); PUSHs(sv_2mortal(newSViv(Tp.tv_sec))); PUSHs(sv_2mortal(newSViv(Tp.tv_usec))); @@ -1249,7 +1250,7 @@ setitimer(which, seconds, interval = 0) if (setitimer(which, &newit, &oldit) == 0) { EXTEND(sp, 1); PUSHs(sv_2mortal(newSVnv(TV2NV(oldit.it_value)))); - if (GIMME == G_ARRAY) { + if (GIMME == G_LIST) { EXTEND(sp, 1); PUSHs(sv_2mortal(newSVnv(TV2NV(oldit.it_interval)))); } @@ -1269,7 +1270,7 @@ getitimer(which) if (getitimer(which, &nowit) == 0) { EXTEND(sp, 1); PUSHs(sv_2mortal(newSVnv(TV2NV(nowit.it_value)))); - if (GIMME == G_ARRAY) { + if (GIMME == G_LIST) { EXTEND(sp, 1); PUSHs(sv_2mortal(newSVnv(TV2NV(nowit.it_interval)))); } @@ -1522,7 +1523,7 @@ PROTOTYPE: ;$ 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 : + fakeop.op_flags = GIMME_V == G_LIST ? OPf_WANT_LIST : GIMME_V == G_SCALAR ? OPf_WANT_SCALAR : OPf_WANT_VOID; PL_op = &fakeop; (void)fakeop.op_ppaddr(aTHX); diff --git a/Makefile.PL b/Makefile.PL index c918cd1..e5ba503 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -562,7 +562,10 @@ EOD my $has_clock_gettime; my $has_clock_gettime_emulation; if (exists $Config{d_clock_gettime}) { - $has_clock_gettime++ if $Config{d_clock_gettime}; # Unlikely... + if ($Config{d_clock_gettime}) { # possibly set for cross-compilation + $has_clock_gettime++; + $DEFINE .= ' -DTIME_HIRES_CLOCK_GETTIME'; + } } elsif (has_clock_xxx('gettime')) { $has_clock_gettime++; $DEFINE .= ' -DTIME_HIRES_CLOCK_GETTIME'; @@ -591,7 +594,10 @@ EOD my $has_clock_getres; my $has_clock_getres_emulation; if (exists $Config{d_clock_getres}) { - $has_clock_getres++ if $Config{d_clock_getres}; # Unlikely... + if ($Config{d_clock_getres}) { # possibly set for cross-compilation + $has_clock_getres++; + $DEFINE .= ' -DTIME_HIRES_CLOCK_GETRES'; + } } elsif (has_clock_xxx('getres')) { $has_clock_getres++; $DEFINE .= ' -DTIME_HIRES_CLOCK_GETRES'; @@ -620,7 +626,10 @@ EOD my $has_clock_nanosleep; my $has_clock_nanosleep_emulation; if (exists $Config{d_clock_nanosleep}) { - $has_clock_nanosleep++ if $Config{d_clock_nanosleep}; # Unlikely... + if ($Config{d_clock_nanosleep}) { # possibly set for cross-compilation + $has_clock_nanosleep++; + $DEFINE .= ' -DTIME_HIRES_CLOCK_NANOSLEEP'; + } } elsif (has_clock_nanosleep()) { $has_clock_nanosleep++; $DEFINE .= ' -DTIME_HIRES_CLOCK_NANOSLEEP'; @@ -643,7 +652,10 @@ EOD print "Looking for clock()... "; my $has_clock; if (exists $Config{d_clock}) { - $has_clock++ if $Config{d_clock}; # Unlikely... + if ($Config{d_clock}) { # possibly set for cross-compilation + $has_clock++; + $DEFINE .= ' -DTIME_HIRES_CLOCK'; + } } elsif (has_clock()) { $has_clock++; $DEFINE .= ' -DTIME_HIRES_CLOCK'; @@ -861,7 +873,7 @@ sub doMakefile { 'Config' => 0, 'Exporter' => 0, 'ExtUtils::MakeMaker' => 0, - 'Test::More' => 0, + 'Test::More' => 0.84, 'XSLoader' => 0, 'strict' => 0, 'File::Spec' => 0, diff --git a/t/Watchdog.pm b/t/Watchdog.pm index a93ab4f..5f78a17 100644 --- a/t/Watchdog.pm +++ b/t/Watchdog.pm @@ -10,30 +10,30 @@ my $watchdog_pid; my $TheEnd; if ($Config{d_fork}) { - print("# I am the main process $$, starting the watchdog process...\n"); + note ("I am the main process $$, starting the watchdog process..."); $watchdog_pid = fork(); if (defined $watchdog_pid) { if ($watchdog_pid == 0) { # We are the kid, set up the watchdog. my $ppid = getppid(); - print("# I am the watchdog process $$, sleeping for $waitfor seconds...\n"); + note ("I am the watchdog process $$, sleeping for $waitfor seconds..."); sleep($waitfor - 2); # Workaround for perlbug #49073 sleep(2); # Wait for parent to exit if (kill(0, $ppid)) { # Check if parent still exists warn "\n$0: overall time allowed for tests (${waitfor}s) exceeded!\n"; print("Terminating main process $ppid...\n"); kill('KILL', $ppid); - print("# This is the watchdog process $$, over and out.\n"); + note ("This is the watchdog process $$, over and out."); } exit(0); } else { - print("# The watchdog process $watchdog_pid launched, continuing testing...\n"); + note ("The watchdog process $watchdog_pid launched, continuing testing..."); $TheEnd = time() + $waitfor; } } else { warn "$0: fork failed: $!\n"; } } else { - print("# No watchdog process (need fork)\n"); + note ("No watchdog process (need fork)"); } END { @@ -47,7 +47,7 @@ END { printf("# kill KILL $watchdog_pid = %d\n", $kill); } unlink("ktrace.out"); # Used in BSD system call tracing. - print("# All done.\n"); + note ("All done."); } } diff --git a/t/stat.t b/t/stat.t index f2f8e87..1f1fa96 100644 --- a/t/stat.t +++ b/t/stat.t @@ -20,31 +20,37 @@ use t::Watchdog; my @atime; my @mtime; for (1..5) { + note "cycle $_"; Time::HiRes::sleep(rand(0.1) + 0.1); open(X, '>', $$); print X $$; close(X); my($a, $stat, $b) = ("a", [Time::HiRes::stat($$)], "b"); - is $a, "a"; - is $b, "b"; - is ref($stat), "ARRAY"; + is $a, "a", "stat stack discipline"; + is $b, "b", "stat stack discipline"; + is ref($stat), "ARRAY", "stat returned array"; push @mtime, $stat->[9]; ($a, my $lstat, $b) = ("a", [Time::HiRes::lstat($$)], "b"); - is $a, "a"; - is $b, "b"; - is_deeply $lstat, $stat; - Time::HiRes::sleep(rand(0.1) + 0.1); - open(X, '<', $$); - ; - close(X); - $stat = [Time::HiRes::stat($$)]; - push @atime, $stat->[8]; - $lstat = [Time::HiRes::lstat($$)]; - is_deeply $lstat, $stat; + is $a, "a", "lstat stack discipline"; + is $b, "b", "lstat stack discipline"; + SKIP: { + if($^O eq "haiku") { + skip "testing stat access time on Haiku", 2; + } + is_deeply $lstat, $stat, "write: stat and lstat returned same values"; + Time::HiRes::sleep(rand(0.1) + 0.1); + open(X, '<', $$); + ; + close(X); + $stat = [Time::HiRes::stat($$)]; + push @atime, $stat->[8]; + $lstat = [Time::HiRes::lstat($$)]; + is_deeply $lstat, $stat, "read: stat and lstat returned same values"; + } } 1 while unlink $$; -print("# mtime = @mtime\n"); -print("# atime = @atime\n"); +note ("mtime = @mtime"); +note ("atime = @atime"); my $ai = 0; my $mi = 0; my $ss = 0; @@ -64,13 +70,15 @@ for (my $i = 1; $i < @mtime; $i++) { $ss++; } } -print("# ai = $ai, mi = $mi, ss = $ss\n"); +note ("ai = $ai, mi = $mi, ss = $ss"); # Need at least 75% of monotonical increase and # 20% of subsecond results. Yes, this is guessing. SKIP: { skip "no subsecond timestamps detected", 1 if $ss == 0; + skip "testing stat access on Haiku", 1 if $^O eq "haiku"; ok $mi/(@mtime-1) >= 0.75 && $ai/(@atime-1) >= 0.75 && - $ss/(@mtime+@atime) >= 0.2; + $ss/(@mtime+@atime) >= 0.2, + "monotonical increase and subsecond results within expected parameters"; } my $targetname = "tgt$$"; @@ -81,17 +89,21 @@ SKIP: { close(X); eval { symlink $targetname, $linkname or die "can't symlink: $!"; }; skip "can't symlink", 7 if $@ ne ""; + note "compare Time::HiRes::stat with ::lstat"; my @tgt_stat = Time::HiRes::stat($targetname); my @tgt_lstat = Time::HiRes::lstat($targetname); my @lnk_stat = Time::HiRes::stat($linkname); my @lnk_lstat = Time::HiRes::lstat($linkname); - is scalar(@tgt_stat), 13; - is scalar(@tgt_lstat), 13; - is scalar(@lnk_stat), 13; - is scalar(@lnk_lstat), 13; - is_deeply \@tgt_stat, \@tgt_lstat; - is_deeply \@tgt_stat, \@lnk_stat; - isnt $lnk_lstat[2], $tgt_stat[2]; + my $exp = 13; + is scalar(@tgt_stat), $exp, "stat on target"; + is scalar(@tgt_lstat), $exp, "lstat on target"; + is scalar(@lnk_stat), $exp, "stat on link"; + is scalar(@lnk_lstat), $exp, "lstat on link"; + skip "testing stat access on Haiku", 3 if $^O eq "haiku"; + is_deeply \@tgt_stat, \@tgt_lstat, "stat and lstat return same values on target"; + is_deeply \@tgt_stat, \@lnk_stat, "stat and lstat return same values on link"; + isnt $lnk_lstat[2], $tgt_stat[2], + "target stat mode value differs from link lstat mode value"; } 1 while unlink $linkname; 1 while unlink $targetname; -- 2.34.3