1use strict; 2 3sub has_subsecond_file_times { 4 require File::Temp; 5 require Time::HiRes; 6 my ($fh, $filename) = File::Temp::tempfile( "Time-HiRes-utime-XXXXXXXXX" ); 7 use File::Basename qw[dirname]; 8 my $dirname = dirname($filename); 9 require Cwd; 10 $dirname = &Cwd::getcwd if $dirname eq '.'; 11 print("\n# Testing for subsecond file timestamps (mtime) in $dirname\n"); 12 close $fh; 13 my @mtimes; 14 for (1..2) { 15 open $fh, '>', $filename; 16 print $fh "foo"; 17 close $fh; 18 push @mtimes, (Time::HiRes::stat($filename))[9]; 19 Time::HiRes::sleep(.1) if $_ == 1; 20 } 21 my $delta = $mtimes[1] - $mtimes[0]; 22 # print STDERR "mtimes = @mtimes, delta = $delta\n"; 23 unlink $filename; 24 my $ok = $delta > 0 && $delta < 1; 25 printf("# Subsecond file timestamps in $dirname: %s\n", 26 $ok ? "OK" : "NO"); 27 return $ok; 28} 29 30sub get_filesys_of_tempfile { 31 require File::Temp; 32 require Time::HiRes; 33 my ($fh, $filename) = File::Temp::tempfile( "Time-HiRes-utime-XXXXXXXXX" ); 34 my $filesys; 35 if (open(my $df, "df $filename |")) { 36 my @fs; 37 while (<$df>) { 38 next if /^Filesystem/; 39 chomp; 40 push @fs, $_; 41 } 42 if (@fs == 1) { 43 if (defined $fs[0] && length($fs[0])) { 44 $filesys = $fs[0]; 45 } else { 46 printf("# Got empty result from 'df'\n"); 47 } 48 } else { 49 printf("# Expected one result from 'df', got %d\n", scalar(@fs)); 50 } 51 } else { 52 # Too noisy to show by default. 53 # Can fail for too many reasons. 54 print "# Failed to run 'df $filename |': $!\n"; 55 } 56 return $filesys; 57} 58 59sub get_mount_of_filesys { 60 my ($filesys) = @_; 61 # netbsd has /sbin/mount 62 local $ENV{PATH} = "$ENV{PATH}:/sbin" if $^O =~ /^(?:netbsd)$/; 63 if (defined $filesys) { 64 my @fs = split(' ', $filesys); 65 if (open(my $mount, "mount |")) { 66 while (<$mount>) { 67 chomp; 68 my @mnt = split(' '); 69 if ($mnt[0] eq $fs[0]) { 70 return $_; 71 } 72 } 73 } else { 74 # Too noisy to show by default. 75 # The mount(8) might not be in the PATH, for example. 76 # Or this might be a completely non-UNIX system. 77 # print "# Failed to run 'mount |': $!\n"; 78 } 79 } 80 return; 81} 82 83sub get_mount_of_tempfile { 84 return get_mount_of_filesys(get_filesys_of_tempfile()); 85} 86 87sub tempfile_has_noatime_mount { 88 my ($mount) = get_mount_of_tempfile(); 89 return $mount =~ /\bnoatime\b/; 90} 91 92BEGIN { 93 require Time::HiRes; 94 require Test::More; 95 require File::Temp; 96 unless(&Time::HiRes::d_hires_utime) { 97 Test::More::plan(skip_all => "no hires_utime"); 98 } 99 unless(&Time::HiRes::d_hires_stat) { 100 # Being able to read subsecond timestamps is a reasonable 101 # prerequisite for being able to write them. 102 Test::More::plan(skip_all => "no hires_stat"); 103 } 104 unless (&Time::HiRes::d_futimens) { 105 Test::More::plan(skip_all => "no futimens()"); 106 } 107 unless (&Time::HiRes::d_utimensat) { 108 Test::More::plan(skip_all => "no utimensat()"); 109 } 110 unless (has_subsecond_file_times()) { 111 Test::More::plan(skip_all => "No subsecond file timestamps"); 112 } 113} 114 115use Test::More tests => 22; 116BEGIN { push @INC, '.' } 117use t::Watchdog; 118use File::Temp qw( tempfile ); 119 120BEGIN { 121 *done_testing = sub {} unless defined &done_testing; 122} 123 124use Config; 125 126# Hope initially for nanosecond accuracy. 127my $atime = 1.111111111; 128my $mtime = 2.222222222; 129 130if ($^O eq 'cygwin') { 131 # Cygwin timestamps have less precision. 132 $atime = 1.1111111; 133 $mtime = 2.2222222; 134} 135if ($^O eq 'dragonfly') { 136 # Dragonfly (hammer2?) timestamps have less precision. 137 $atime = 1.111111; 138 $mtime = 2.222222; 139} 140print "# \$^O = $^O, atime = $atime, mtime = $mtime\n"; 141 142my $skip_atime = $^O eq 'netbsd' && tempfile_has_noatime_mount(); 143$skip_atime = 1 if $^O eq 'dragonfly'; # noatime by default 144 145if ($skip_atime) { 146 printf("# Skipping atime tests because tempfiles seem to be in a filesystem mounted with 'noatime' ($^O)\n'"); 147} 148 149print "# utime \$fh\n"; 150{ 151 my ($fh, $filename) = tempfile( "Time-HiRes-utime-XXXXXXXXX", UNLINK => 1 ); 152 is Time::HiRes::utime($atime, $mtime, $fh), 1, "One file changed"; 153 my ($got_atime, $got_mtime) = ( Time::HiRes::stat($filename) )[8, 9]; 154 SKIP: { 155 skip("noatime mount", 1) if $skip_atime; 156 is $got_atime, $atime, "atime set correctly"; 157 } 158 is $got_mtime, $mtime, "mtime set correctly"; 159}; 160 161print "#utime \$filename\n"; 162{ 163 my ($fh, $filename) = tempfile( "Time-HiRes-utime-XXXXXXXXX", UNLINK => 1 ); 164 is Time::HiRes::utime($atime, $mtime, $filename), 1, "One file changed"; 165 my ($got_atime, $got_mtime) = ( Time::HiRes::stat($fh) )[8, 9]; 166 SKIP: { 167 skip("noatime mount", 1) if $skip_atime; 168 is $got_atime, $atime, "atime set correctly"; 169 } 170 is $got_mtime, $mtime, "mtime set correctly"; 171}; 172 173print "#utime \$filename round-trip\n"; 174{ 175 my ($fh, $filename) = tempfile( "Time-HiRes-utime-XXXXXXXXX", UNLINK => 1 ); 176 # this fractional part is not exactly representable 177 my $t = 1000000000.12345; 178 is Time::HiRes::utime($t, $t, $filename), 1, "One file changed"; 179 my ($got_atime, $got_mtime) = ( Time::HiRes::stat($fh) )[8, 9]; 180 is Time::HiRes::utime($got_atime, $got_mtime, $filename), 1, "One file changed"; 181 my ($got_atime2, $got_mtime2) = ( Time::HiRes::stat($fh) )[8, 9]; 182 is $got_atime, $got_atime2, "atime round trip ok"; 183 is $got_mtime, $got_mtime2, "mtime round trip ok"; 184}; 185 186print "utime \$filename and \$fh\n"; 187{ 188 my ($fh1, $filename1) = tempfile( "Time-HiRes-utime-XXXXXXXXX", UNLINK => 1 ); 189 my ($fh2, $filename2) = tempfile( "Time-HiRes-utime-XXXXXXXXX", UNLINK => 1 ); 190 is Time::HiRes::utime($atime, $mtime, $filename1, $fh2), 2, "Two files changed"; 191 { 192 my ($got_atime, $got_mtime) = ( Time::HiRes::stat($fh1) )[8, 9]; 193 SKIP: { 194 skip("noatime mount", 1) if $skip_atime; 195 is $got_atime, $atime, "File 1 atime set correctly"; 196 } 197 is $got_mtime, $mtime, "File 1 mtime set correctly"; 198 } 199 { 200 my ($got_atime, $got_mtime) = ( Time::HiRes::stat($filename2) )[8, 9]; 201 SKIP: { 202 skip("noatime mount", 1) if $skip_atime; 203 is $got_atime, $atime, "File 2 atime set correctly"; 204 } 205 is $got_mtime, $mtime, "File 2 mtime set correctly"; 206 } 207}; 208 209print "# utime undef sets time to now\n"; 210{ 211 my ($fh1, $filename1) = tempfile( "Time-HiRes-utime-XXXXXXXXX", UNLINK => 1 ); 212 my ($fh2, $filename2) = tempfile( "Time-HiRes-utime-XXXXXXXXX", UNLINK => 1 ); 213 214 my $now = Time::HiRes::time; 215 sleep(1); 216 is Time::HiRes::utime(undef, undef, $filename1, $fh2), 2, "Two files changed"; 217 218 { 219 my ($got_atime, $got_mtime) = ( Time::HiRes::stat($fh1) )[8, 9]; 220 SKIP: { 221 skip("noatime mount", 1) if $skip_atime; 222 cmp_ok $got_atime, '>=', $now, "File 1 atime set correctly"; 223 } 224 cmp_ok $got_mtime, '>=', $now, "File 1 mtime set correctly"; 225 } 226 { 227 my ($got_atime, $got_mtime) = ( Time::HiRes::stat($filename2) )[8, 9]; 228 SKIP: { 229 skip("noatime mount", 1) if $skip_atime; 230 cmp_ok $got_atime, '>=', $now, "File 2 atime set correctly"; 231 } 232 cmp_ok $got_mtime, '>=', $now, "File 2 mtime set correctly"; 233 } 234}; 235 236print "# negative atime dies\n"; 237{ 238 eval { Time::HiRes::utime(-4, $mtime) }; 239 like $@, qr/::utime\(-4, 2\.22222\): negative time not invented yet/, 240 "negative time error"; 241}; 242 243print "# negative mtime dies;\n"; 244{ 245 eval { Time::HiRes::utime($atime, -4) }; 246 like $@, qr/::utime\(1.11111, -4\): negative time not invented yet/, 247 "negative time error"; 248}; 249 250done_testing(); 251 2521; 253