dist/Time-HiRes/t/utime.t

   1 use strict;
   2
   3 sub 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
  30 sub 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
  59 sub 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
  83 sub get_mount_of_tempfile {
  84     return get_mount_of_filesys(get_filesys_of_tempfile());
  85 }
  86
  87 sub tempfile_has_noatime_mount {
  88     my ($mount) = get_mount_of_tempfile();
  89     return $mount =~ /\bnoatime\b/;
  90 }
  91
  92 BEGIN {
  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
 115 use Test::More tests => 22;
 116 BEGIN { push @INC, '.' }
 117 use t::Watchdog;
 118 use File::Temp qw( tempfile );
 119
 120 BEGIN {
 121   *done_testing = sub {} unless defined &done_testing;
 122 }
 123
 124 use Config;
 125
 126 # Hope initially for nanosecond accuracy.
 127 my $atime = 1.111111111;
 128 my $mtime = 2.222222222;
 129
 130 if ($^O eq 'cygwin') {
 131     # Cygwin timestamps have less precision.
 132     $atime = 1.1111111;
 133     $mtime = 2.2222222;
 134 }
 135 if ($^O eq 'dragonfly') {
 136     # Dragonfly (hammer2?) timestamps have less precision.
 137     $atime = 1.111111;
 138     $mtime = 2.222222;
 139 }
 140 print "# \$^O = $^O, atime = $atime, mtime = $mtime\n";
 141
 142 my $skip_atime = $^O eq 'netbsd' && tempfile_has_noatime_mount();
 143 $skip_atime = 1 if $^O eq 'dragonfly'; # noatime by default
 144
 145 if ($skip_atime) {
 146     printf("# Skipping atime tests because tempfiles seem to be in a filesystem mounted with 'noatime' ($^O)\n'");
 147 }
 148
 149 print "# 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
 161 print "#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
 173 print "#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
 186 print "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
 209 print "# 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
 236 print "# 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
 243 print "# 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
 250 done_testing();
 251
 252 1;