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
140
141
142
143
144
145
|
{- More control over touching a file.
-
- Copyright 2011 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
{-# LANGUAGE ForeignFunctionInterface, CPP #-}
module Utility.Touch (
TimeSpec(..),
touchBoth,
touch
) where
#if MIN_VERSION_unix(2,7,0)
import System.Posix.Files
import System.Posix.Types
newtype TimeSpec = TimeSpec EpochTime
{- Changes the access and modification times of an existing file.
Can follow symlinks, or not. Throws IO error on failure. -}
touchBoth :: FilePath -> TimeSpec -> TimeSpec -> Bool -> IO ()
touchBoth file (TimeSpec atime) (TimeSpec mtime) follow
| follow = setFileTimes file atime mtime
| otherwise = setSymbolicLinkTimesHiRes file (realToFrac atime) (realToFrac mtime)
touch :: FilePath -> TimeSpec -> Bool -> IO ()
touch file mtime = touchBoth file mtime mtime
#else
{- Compatability interface for old version of unix, to be removed eventally. -}
#include <sys/types.h>
#include <sys/stat.h>
#include <fcntl.h>
#include <sys/time.h>
#ifndef _BSD_SOURCE
#define _BSD_SOURCE
#endif
#if (defined UTIME_OMIT && defined UTIME_NOW && defined AT_FDCWD && defined AT_SYMLINK_NOFOLLOW)
#define use_utimensat 1
import Utility.FileSystemEncoding
import Control.Monad (when)
import Foreign
#endif
import Foreign.C
newtype TimeSpec = TimeSpec CTime
touchBoth :: FilePath -> TimeSpec -> TimeSpec -> Bool -> IO ()
touch :: FilePath -> TimeSpec -> Bool -> IO ()
touch file mtime = touchBoth file mtime mtime
#ifdef use_utimensat
at_fdcwd :: CInt
at_fdcwd = #const AT_FDCWD
at_symlink_nofollow :: CInt
at_symlink_nofollow = #const AT_SYMLINK_NOFOLLOW
instance Storable TimeSpec where
-- use the larger alignment of the two types in the struct
alignment _ = max sec_alignment nsec_alignment
where
sec_alignment = alignment (1::CTime)
nsec_alignment = alignment (1::CLong)
sizeOf _ = #{size struct timespec}
peek ptr = do
sec <- #{peek struct timespec, tv_sec} ptr
return $ TimeSpec sec
poke ptr (TimeSpec sec) = do
#{poke struct timespec, tv_sec} ptr sec
#{poke struct timespec, tv_nsec} ptr (0 :: CLong)
{- While its interface is beastly, utimensat is in recent
POSIX standards, unlike lutimes. -}
foreign import ccall "utimensat"
c_utimensat :: CInt -> CString -> Ptr TimeSpec -> CInt -> IO CInt
touchBoth file atime mtime follow =
allocaArray 2 $ \ptr ->
withFilePath file $ \f -> do
pokeArray ptr [atime, mtime]
r <- c_utimensat at_fdcwd f ptr flags
when (r /= 0) $ throwErrno "touchBoth"
where
flags
| follow = 0
| otherwise = at_symlink_nofollow
#else
#if 0
{- Using lutimes is needed for BSD.
-
- TODO: test if lutimes is available. May have to do it in configure.
- TODO: TimeSpec uses a CTime, while tv_sec is a CLong. It is implementation
- dependent whether these are the same; need to find a cast that works.
- (Without the cast it works on linux i386, but
- maybe not elsewhere.)
-}
instance Storable TimeSpec where
alignment _ = alignment (1::CLong)
sizeOf _ = #{size struct timeval}
peek ptr = do
sec <- #{peek struct timeval, tv_sec} ptr
return $ TimeSpec sec
poke ptr (TimeSpec sec) = do
#{poke struct timeval, tv_sec} ptr sec
#{poke struct timeval, tv_usec} ptr (0 :: CLong)
foreign import ccall "utimes"
c_utimes :: CString -> Ptr TimeSpec -> IO CInt
foreign import ccall "lutimes"
c_lutimes :: CString -> Ptr TimeSpec -> IO CInt
touchBoth file atime mtime follow =
allocaArray 2 $ \ptr ->
withFilePath file $ \f -> do
pokeArray ptr [atime, mtime]
r <- syscall f ptr
when (r /= 0) $
throwErrno "touchBoth"
where
syscall
| follow = c_lutimes
| otherwise = c_utimes
#else
#warning "utimensat and lutimes not available; building without symlink timestamp preservation support"
touchBoth _ _ _ _ = return ()
#endif
#endif
#endif
|
