xref: /openbsd/gnu/usr.bin/perl/dist/Time-HiRes/t/utime.t (revision 56d68f1e) 
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}
135print "# \$^O = $^O, atime = $atime, mtime = $mtime\n";
136
137my $skip_atime = $^O eq 'netbsd' && tempfile_has_noatime_mount();
138
139if ($skip_atime) {
140    printf("# Skipping atime tests because tempfiles seem to be in a filesystem mounted with 'noatime' ($^O)\n'");
141}
142
143print "# utime \$fh\n";
144{
145    my ($fh, $filename) = tempfile( "Time-HiRes-utime-XXXXXXXXX", UNLINK => 1 );
146    is Time::HiRes::utime($atime, $mtime, $fh), 1, "One file changed";
147    my ($got_atime, $got_mtime) = ( Time::HiRes::stat($filename) )[8, 9];
148    SKIP: {
149        skip("noatime mount", 1) if $skip_atime;
150        is $got_atime, $atime, "atime set correctly";
151    }
152    is $got_mtime, $mtime, "mtime set correctly";
153};
154
155print "#utime \$filename\n";
156{
157    my ($fh, $filename) = tempfile( "Time-HiRes-utime-XXXXXXXXX", UNLINK => 1 );
158    is Time::HiRes::utime($atime, $mtime, $filename), 1, "One file changed";
159    my ($got_atime, $got_mtime) = ( Time::HiRes::stat($fh) )[8, 9];
160    SKIP: {
161        skip("noatime mount", 1) if $skip_atime;
162        is $got_atime, $atime, "atime set correctly";
163    }
164    is $got_mtime, $mtime, "mtime set correctly";
165};
166
167print "#utime \$filename round-trip\n";
168{
169    my ($fh, $filename) = tempfile( "Time-HiRes-utime-XXXXXXXXX", UNLINK => 1 );
170    # this fractional part is not exactly representable
171    my $t = 1000000000.12345;
172    is Time::HiRes::utime($t, $t, $filename), 1, "One file changed";
173    my ($got_atime, $got_mtime) = ( Time::HiRes::stat($fh) )[8, 9];
174    is Time::HiRes::utime($got_atime, $got_mtime, $filename), 1, "One file changed";
175    my ($got_atime2, $got_mtime2) = ( Time::HiRes::stat($fh) )[8, 9];
176    is $got_atime, $got_atime2, "atime round trip ok";
177    is $got_mtime, $got_mtime2, "mtime round trip ok";
178};
179
180print "utime \$filename and \$fh\n";
181{
182    my ($fh1, $filename1) = tempfile( "Time-HiRes-utime-XXXXXXXXX", UNLINK => 1 );
183    my ($fh2, $filename2) = tempfile( "Time-HiRes-utime-XXXXXXXXX", UNLINK => 1 );
184    is Time::HiRes::utime($atime, $mtime, $filename1, $fh2), 2, "Two files changed";
185    {
186        my ($got_atime, $got_mtime) = ( Time::HiRes::stat($fh1) )[8, 9];
187        SKIP: {
188            skip("noatime mount", 1) if $skip_atime;
189            is $got_atime, $atime, "File 1 atime set correctly";
190        }
191        is $got_mtime, $mtime, "File 1 mtime set correctly";
192    }
193    {
194        my ($got_atime, $got_mtime) = ( Time::HiRes::stat($filename2) )[8, 9];
195        SKIP: {
196            skip("noatime mount", 1) if $skip_atime;
197            is $got_atime, $atime, "File 2 atime set correctly";
198        }
199        is $got_mtime, $mtime, "File 2 mtime set correctly";
200    }
201};
202
203print "# utime undef sets time to now\n";
204{
205    my ($fh1, $filename1) = tempfile( "Time-HiRes-utime-XXXXXXXXX", UNLINK => 1 );
206    my ($fh2, $filename2) = tempfile( "Time-HiRes-utime-XXXXXXXXX", UNLINK => 1 );
207
208    my $now = Time::HiRes::time;
209    sleep(1);
210    is Time::HiRes::utime(undef, undef, $filename1, $fh2), 2, "Two files changed";
211
212    {
213        my ($got_atime, $got_mtime) = ( Time::HiRes::stat($fh1) )[8, 9];
214        SKIP: {
215            skip("noatime mount", 1) if $skip_atime;
216            cmp_ok $got_atime, '>=', $now, "File 1 atime set correctly";
217        }
218        cmp_ok $got_mtime, '>=', $now, "File 1 mtime set correctly";
219    }
220    {
221        my ($got_atime, $got_mtime) = ( Time::HiRes::stat($filename2) )[8, 9];
222        SKIP: {
223            skip("noatime mount", 1) if $skip_atime;
224            cmp_ok $got_atime, '>=', $now, "File 2 atime set correctly";
225        }
226        cmp_ok $got_mtime, '>=', $now, "File 2 mtime set correctly";
227    }
228};
229
230print "# negative atime dies\n";
231{
232    eval { Time::HiRes::utime(-4, $mtime) };
233    like $@, qr/::utime\(-4, 2\.22222\): negative time not invented yet/,
234         "negative time error";
235};
236
237print "# negative mtime dies;\n";
238{
239    eval { Time::HiRes::utime($atime, -4) };
240    like $@, qr/::utime\(1.11111, -4\): negative time not invented yet/,
241         "negative time error";
242};
243
244done_testing();
245
2461;
247