1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
|
use strict;
BEGIN {
require Time::HiRes;
require Test::More;
require File::Temp;
unless(&Time::HiRes::d_hires_utime) {
Test::More::plan(skip_all => "no hires_utime");
}
unless (&Time::HiRes::d_futimens) {
Test::More::plan(skip_all => "no futimens()");
}
unless (&Time::HiRes::d_utimensat) {
Test::More::plan(skip_all => "no utimensat()");
}
if ($^O eq 'gnukfreebsd') {
Test::More::plan(skip_all => "futimens() and utimensat() not working in $^O");
}
if ($^O eq 'linux' && -e '/proc/mounts') {
# The linux might be wrong when ext3
# is available in other operating systems,
# but then we need other methods for detecting
# the filesystem type of the tempfiles.
my ($fh, $fn) = File::Temp::tempfile( "Time-HiRes-utime-XXXXXXXXX", UNLINK => 1);
sub getfstype {
my ($fn) = @_;
my $cmd = "df $fn";
open(my $df, '-|', $cmd) or die "$cmd: $!";
my @df = <$df>; # Assume $df[0] is header line.
my $dev = +(split(" ", $df[1]))[0];
open(my $mounts, '<', '/proc/mounts') or die "/proc/mounts: $!";
while (<$mounts>) {
my @m = split(" ");
if ($m[0] eq $dev) { return $m[2] }
}
return;
}
my $fstype = getfstype($fn);
unless (defined $fstype) {
warn "Unknown fstype for $fn\n";
} else {
print "# fstype = $fstype\n";
if ($fstype eq 'ext3' || $fstype eq 'ext2') {
Test::More::plan(skip_all => "fstype $fstype has no subsecond timestamps in $^O");
}
}
}
}
use Test::More tests => 18;
BEGIN { push @INC, '.' }
use t::Watchdog;
use File::Temp qw( tempfile );
use Config;
# Hope initially for nanosecond accuracy.
my $atime = 1.111111111;
my $mtime = 2.222222222;
if ($^O eq 'cygwin') {
# Cygwin timestamps have less precision.
$atime = 1.1111111;
$mtime = 2.2222222;
}
print "# \$^O = $^O, atime = $atime, mtime = $mtime\n";
print "# utime \$fh\n";
{
my ($fh, $filename) = tempfile( "Time-HiRes-utime-XXXXXXXXX", UNLINK => 1 );
is Time::HiRes::utime($atime, $mtime, $fh), 1, "One file changed";
my ($got_atime, $got_mtime) = ( Time::HiRes::stat($filename) )[8, 9];
is $got_atime, $atime, "atime set correctly";
is $got_mtime, $mtime, "mtime set correctly";
};
print "#utime \$filename\n";
{
my ($fh, $filename) = tempfile( "Time-HiRes-utime-XXXXXXXXX", UNLINK => 1 );
is Time::HiRes::utime($atime, $mtime, $filename), 1, "One file changed";
my ($got_atime, $got_mtime) = ( Time::HiRes::stat($fh) )[8, 9];
is $got_atime, $atime, "atime set correctly";
is $got_mtime, $mtime, "mtime set correctly";
};
print "utime \$filename and \$fh\n";
{
my ($fh1, $filename1) = tempfile( "Time-HiRes-utime-XXXXXXXXX", UNLINK => 1 );
my ($fh2, $filename2) = tempfile( "Time-HiRes-utime-XXXXXXXXX", UNLINK => 1 );
is Time::HiRes::utime($atime, $mtime, $filename1, $fh2), 2, "Two files changed";
{
my ($got_atime, $got_mtime) = ( Time::HiRes::stat($fh1) )[8, 9];
is $got_atime, $atime, "File 1 atime set correctly";
is $got_mtime, $mtime, "File 1 mtime set correctly";
}
{
my ($got_atime, $got_mtime) = ( Time::HiRes::stat($filename2) )[8, 9];
is $got_atime, $atime, "File 2 atime set correctly";
is $got_mtime, $mtime, "File 2 mtime set correctly";
}
};
print "# utime undef sets time to now\n";
{
my ($fh1, $filename1) = tempfile( "Time-HiRes-utime-XXXXXXXXX", UNLINK => 1 );
my ($fh2, $filename2) = tempfile( "Time-HiRes-utime-XXXXXXXXX", UNLINK => 1 );
my $now = Time::HiRes::time;
is Time::HiRes::utime(undef, undef, $filename1, $fh2), 2, "Two files changed";
{
my ($got_atime, $got_mtime) = ( Time::HiRes::stat($fh1) )[8, 9];
cmp_ok abs( $got_atime - $now), '<', 0.1, "File 1 atime set correctly";
cmp_ok abs( $got_mtime - $now), '<', 0.1, "File 1 mtime set correctly";
}
{
my ($got_atime, $got_mtime) = ( Time::HiRes::stat($filename2) )[8, 9];
cmp_ok abs( $got_atime - $now), '<', 0.1, "File 2 atime set correctly";
cmp_ok abs( $got_mtime - $now), '<', 0.1, "File 2 mtime set correctly";
}
};
print "# negative atime dies\n";
{
eval { Time::HiRes::utime(-4, $mtime) };
like $@, qr/::utime\(-4, 2\.22222\): negative time not invented yet/,
"negative time error";
};
print "# negative mtime dies;\n";
{
eval { Time::HiRes::utime($atime, -4) };
like $@, qr/::utime\(1.11111, -4\): negative time not invented yet/,
"negative time error";
};
done_testing;
1;
|
