These patches implement the win32 side of Ian's Compat.hs patches, with a
couple of additional fixes. Tested on Windows XP with both ghc-6.2.2 and 6.4.
The hsc2hs one is a bit ugly, the problem is that win32 hsc2hs doesn't handle
forward slashes for its output argument, for some reason. At least not my
version.
Sat Jul 30 02:48:29 CEST 2005 Ian Lynagh <[EMAIL PROTECTED]>
* Start Compat.hs, and move stdout_is_a_pipe from compat.c
Sat Jul 30 03:01:18 CEST 2005 Ian Lynagh <[EMAIL PROTECTED]>
* Remove unused function
Sat Jul 30 04:09:18 CEST 2005 Ian Lynagh <[EMAIL PROTECTED]>
* Move mkstemp to Compat.hs
Sat Jul 30 14:22:55 CEST 2005 Ian Lynagh <[EMAIL PROTECTED]>
* Remove is_symlink
Sat Jul 30 15:12:05 CEST 2005 Ian Lynagh <[EMAIL PROTECTED]>
* Move maybe_relink out of compat.c
Sat Jul 30 15:40:30 CEST 2005 Ian Lynagh <[EMAIL PROTECTED]>
* Split the raw mode stuff out into its own .hsc file. Windows needs some TLC
Sat Jul 30 16:17:03 CEST 2005 Ian Lynagh <[EMAIL PROTECTED]>
* Move atomic_create/sloppy_atomic_create to Compat
Sun Jul 31 13:40:11 CEST 2005 [EMAIL PROTECTED]
* Rename compat.c to c_compat.c to avoid object filename conflict with
Compat.hs
Tue Aug 9 00:04:44 CEST 2005 [EMAIL PROTECTED]
* call hsc2hs without output filename argument
Tue Aug 9 22:01:48 CEST 2005 [EMAIL PROTECTED]
* implement RawMode with library functions instead of ffi
Tue Aug 9 22:04:33 CEST 2005 [EMAIL PROTECTED]
* Implement parts of System.Posix.(IO|Files) for win32
Wed Aug 10 23:13:03 CEST 2005 Peter Strand <[EMAIL PROTECTED]>
* fix mkstemp implementation for win32
New patches:
[Start Compat.hs, and move stdout_is_a_pipe from compat.c
Ian Lynagh <[EMAIL PROTECTED]>**20050730004829] {
addfile ./Compat.hs
hunk ./Compat.hs 1
+
+module Compat (stdout_is_a_pipe) where
+
+import System.Posix.Files ( getFdStatus, isNamedPipe )
+import System.Posix.IO ( stdOutput )
+
+stdout_is_a_pipe :: IO Bool
+stdout_is_a_pipe
+ = do stat <- getFdStatus stdOutput
+ return (isNamedPipe stat)
+
hunk ./GNUmakefile 21
- CheckFileSystem.lhs ColourPrinter.lhs Curl.hs DarcsIO.lhs \
+ CheckFileSystem.lhs ColourPrinter.lhs Compat.hs Curl.hs DarcsIO.lhs \
hunk ./SignalHandler.lhs 32
-import Foreign.C ( CInt )
hunk ./SignalHandler.lhs 33
+import Compat ( stdout_is_a_pipe )
hunk ./SignalHandler.lhs 43
-foreign import ccall unsafe "static compat.h stdout_is_a_pipe"
- stdout_is_a_pipe :: IO CInt
-
hunk ./SignalHandler.lhs 58
- when (is_pipe /= 0) $
+ when is_pipe $
hunk ./compat.c 13
-int stdout_is_a_pipe() {
- struct stat s;
- int ret;
- ret = fstat(STDOUT_FILENO, &s);
- if (ret == 0)
- return !S_ISFIFO(s.st_mode);
- else
- return 0;
-}
-
hunk ./compat.h 26
-int stdout_is_a_pipe();
-
}
[Remove unused function
Ian Lynagh <[EMAIL PROTECTED]>**20050730010118] {
hunk ./compat.c 183
-int pipe(int fildes[2]) {
- return _pipe(fildes, 8 * (2<<10), O_BINARY);
-}
-
}
[Move mkstemp to Compat.hs
Ian Lynagh <[EMAIL PROTECTED]>**20050730020918] {
hunk ./Compat.hs 2
-module Compat (stdout_is_a_pipe) where
+{-# OPTIONS -fffi #-}
hunk ./Compat.hs 4
+module Compat (stdout_is_a_pipe, mkstemp, mk_stdout_temp, canonFilename) where
+
+import DarcsUtils ( withCurrentDirectory )
+#ifdef WIN32
+import DarcsUtils ( showHexLen )
+#endif
+
+#ifdef WIN32
+import Control.Exception ( Exception(IOException), throwIO )
+#endif
+import Control.Monad ( liftM )
+#ifdef WIN32
+import Data.Bits ( (.&.) )
+#endif
+#ifndef WIN32
+import Foreign.C.Error ( throwErrno )
+import Foreign.C.String ( CString, withCString, peekCString )
+import Foreign.C.Types ( CInt )
+#endif
+import System.Directory ( getCurrentDirectory )
+import System.IO ( Handle, hFlush, stdout, stderr, hSetBuffering,
+ BufferMode(NoBuffering), hSetBinaryMode )
+#ifdef WIN32
+import System.IO.Error ( mkIOError, illegalOperationErrorType )
+#endif
hunk ./Compat.hs 30
-import System.Posix.IO ( stdOutput )
+#ifdef WIN32
+import System.Posix.Files ( stdFileMode )
+#endif
+import System.Posix.IO ( stdOutput, stdError, fdToHandle, dupTo )
+#ifdef WIN32
+import System.Posix.IO ( defaultFileFlags, openFd,
+ exclusive, OpenMode(WriteOnly) )
+#endif
+import System.Posix.Types ( Fd(..) )
+#ifdef WIN32
+import System.Random ( randomIO )
+#endif
hunk ./Compat.hs 47
+
+canonFilename :: FilePath -> IO FilePath
+canonFilename f@(_:':':_) = return f -- absolute windows paths
+canonFilename f@('/':_) = return f
+canonFilename ('.':'/':f) = do cd <- getCurrentDirectory
+ return $ cd ++ "/" ++ f
+canonFilename f = case reverse $ dropWhile (/='/') $ reverse f of
+ "" -> liftM (++('/':f)) getCurrentDirectory
+ rd -> withCurrentDirectory rd $
+ do fd <- getCurrentDirectory
+ return $ fd ++ "/" ++ simplefilename
+ where
+ simplefilename = reverse $ takeWhile (/='/') $ reverse f
+
+#ifdef WIN32
+mkstemp_core :: FilePath -> IO (Fd, String)
+mkstemp_core fp
+ = do fp' <- case splitAt 6 fp of
+ ("XXXXXX", rev_fp) -> return $ reverse rev_fp
+ _ -> let e = mkIOError illegalOperationErrorType
+ "mkstemp" Nothing (Just fp)
+ in throwIO (IOException e)
+ r <- randomIO
+ let fp'' = fp' ++ (showHexLen 6 (r .&. 0xFFFFFF :: Int))
+ fd <- openFd fp WriteOnly (Just stdFileMode) flags
+ return (fd, fp'')
+ where flags = defaultFileFlags { exclusive = True }
+#else
+mkstemp_core :: String -> IO (Fd, String)
+mkstemp_core str = withCString (str++"XXXXXX") $
+ \cstr -> do fd <- c_mkstemp cstr
+ if fd < 0
+ then throwErrno $ "Failed to create temporary file "++str
+ else do str' <- peekCString cstr
+ fname <- canonFilename str'
+ return (Fd fd, fname)
+
+foreign import ccall unsafe "static stdlib.h mkstemp"
+ c_mkstemp :: CString -> IO CInt
+#endif
+
+mkstemp :: String -> IO (Handle, String)
+mkstemp str = do (fd, fn) <- mkstemp_core str
+ h <- fdToHandle fd
+ hSetBinaryMode h True
+ return (h, fn)
+
+mk_stdout_temp :: String -> IO String
+mk_stdout_temp str = do (fd, fn) <- mkstemp_core str
+ hFlush stdout
+ hFlush stderr
+ dupTo fd stdOutput
+ dupTo fd stdError
+ hFlush stdout
+ hFlush stderr
+ hSetBuffering stdout NoBuffering
+ hSetBuffering stderr NoBuffering
+ return fn
hunk ./DarcsUtils.lhs 9
+ showHexLen,
hunk ./DarcsUtils.lhs 12
+import Numeric ( showHex )
hunk ./DarcsUtils.lhs 25
+
+showHexLen :: (Integral a) => Int -> a -> String
+showHexLen n x = let s = showHex x ""
+ in replicate (n - length s) ' ' ++ s
hunk ./Lock.lhs 37
-import GHC.Handle ( hSetBinaryMode )
hunk ./Lock.lhs 44
-import Foreign.C ( withCString, CString, peekCString,
+import Foreign.C ( withCString, CString,
hunk ./Lock.lhs 47
-import Workaround ( fileMode, getFileStatus, setFileMode, openFd, )
+import Workaround ( fileMode, getFileStatus, setFileMode )
hunk ./Lock.lhs 57
+import Compat ( mkstemp, mk_stdout_temp, canonFilename )
hunk ./Lock.lhs 111
-
-canonFilename :: FilePath -> IO FilePath
-canonFilename f@(_:':':_) = return f -- absolute windows paths
-canonFilename f@('/':_) = return f
-canonFilename ('.':'/':f) = do cd <- getCurrentDirectory
- return $ cd ++ "/" ++ f
-canonFilename f = case reverse $ dropWhile (/='/') $ reverse f of
- "" -> liftM (++('/':f)) getCurrentDirectory
- rd -> withCurrentDirectory rd $
- do fd <- getCurrentDirectory
- return $ fd ++ "/" ++ simplefilename
- where
- simplefilename = reverse $ takeWhile (/='/') $ reverse f
hunk ./Lock.lhs 137
-
-mk_stdout_temp :: String -> IO String
-mk_stdout_temp str = withCString (str++"XXXXXX") $
- \cstr -> do fd <- c_mkstemp cstr
- if fd < 0
- then throwErrno $ "Failed to create temporary file "++str
- else do str' <- peekCString cstr
- fname <- canonFilename str'
- hFlush stdout
- hFlush stderr
- c_dup2 fd 1
- c_dup2 fd 2
- hFlush stdout
- hFlush stderr
- hSetBuffering stdout NoBuffering
- hSetBuffering stderr NoBuffering
- return fname
-
-mkstemp :: String -> IO (Handle, String)
-mkstemp str = withCString (str++"XXXXXX") $
- \cstr -> do fd <- c_mkstemp cstr
- if fd < 0
- then throwErrno $ "Failed to create temporary file "++str
- else do str' <- peekCString cstr
- fname <- canonFilename str'
- h <- openFd (fromIntegral fd) Nothing fname ReadWriteMode True False
- hSetBinaryMode h True
- return (h, fname)
-
-foreign import ccall unsafe "static unistd.h dup2" c_dup2 :: CInt -> CInt -> IO CInt
-foreign import ccall unsafe "static stdlib.h mkstemp" c_mkstemp :: CString -> IO CInt
hunk ./compat.c 161
-int mkstemp(char *p)
-{
- static int inited_rand = 0;
- size_t len = strlen(p);
- if (len < 6 || strcmp(p+len-6, "XXXXXX")) {
- errno = EINVAL;
- return -1;
- }
- if (!inited_rand) {
- srand(time(NULL));
- inited_rand = 1;
- }
- // WARNING! The following is written for the win32 version of snprintf,
- // which differs from the POSIX snprintf in how it treats the second
- // argument. The win32 snprintf doesn't print a nul character on
- // overflow, so the second argument had better be one less than the
- // size of the buffer, and the last character of the buffer had better
- // be preset to nul.
- snprintf(p+len-6, 6, "%06x", rand()<<16 ^ rand());
- return open(p, O_CREAT | O_EXCL | O_RDWR, 0666);
-}
-
hunk ./compat.h 10
-int mkstemp(char *p);
-int pipe( int fildes[2] );
}
[Remove is_symlink
Ian Lynagh <[EMAIL PROTECTED]>**20050730122255] {
hunk ./Lock.lhs 58
+import System.Posix.Files ( getSymbolicLinkStatus, isDirectory )
hunk ./Lock.lhs 206
-foreign import ccall unsafe "static compat.h is_symlink" is_symlink
- :: CString -> IO CInt
-
hunk ./Lock.lhs 208
- fe <- doesDirectoryExist f
- if not fe then return False
- else withCString f $ \cf-> (0==) `liftM` is_symlink cf
+ fs <- getSymbolicLinkStatus f
+ return (isDirectory fs)
hunk ./SlurpDirectory.lhs 59
-import Foreign.C.String
-import Foreign.C ( CInt )
hunk ./SlurpDirectory.lhs 286
-foreign import ccall unsafe "static compat.h is_symlink" is_symlink
- :: CString -> IO CInt
-
hunk ./SlurpDirectory.lhs 287
-isFileReallySymlink f = do
- withCString f $ \cf -> do sym <- is_symlink cf
- return $ sym /= 0
+isFileReallySymlink f = do fs <- getSymbolicLinkStatus f
+ return (isSymbolicLink fs)
hunk ./SlurpDirectory.lhs 291
-doesFileReallyExist f = do
- fe <- doesFileExist f
- if not fe then return False
- else do symlink <- isFileReallySymlink f
- return $ not symlink
+doesFileReallyExist f = do fs <- getSymbolicLinkStatus f
+ return (isRegularFile fs)
+
hunk ./SlurpDirectory.lhs 295
-doesDirectoryReallyExist f = do
- fe <- doesDirectoryExist f
- if not fe then return False
- else do symlink <- isFileReallySymlink f
- return $ not symlink
+doesDirectoryReallyExist f = do fs <- getSymbolicLinkStatus f
+ return (isDirectory fs)
hunk ./compat.c 161
-int is_symlink(const char *file) {
- return 0; /* FIXME: should ignore windows shortcuts */
-}
-
hunk ./compat.c 256
-
-int is_symlink(const char *file) {
- struct stat buf;
- if (lstat(file, &buf)) return 0; /* treat error as non-symlink */
- return S_ISLNK(buf.st_mode);
-}
-
hunk ./compat.h 22
-int is_symlink(const char *file);
-
}
[Move maybe_relink out of compat.c
Ian Lynagh <[EMAIL PROTECTED]>**20050730131205] {
hunk ./Compat.hs 4
-module Compat (stdout_is_a_pipe, mkstemp, mk_stdout_temp, canonFilename) where
+module Compat (stdout_is_a_pipe, mkstemp, mk_stdout_temp, canonFilename,
+ maybe_relink) where
+
+import Prelude hiding ( catch )
hunk ./Compat.hs 10
-#ifdef WIN32
hunk ./Compat.hs 11
+#ifndef WIN32
+import DarcsUtils ( add_to_error_loc, isUnsupportedOperationError )
+import FastPackedString ( readFileLazily )
hunk ./Compat.hs 16
-#ifdef WIN32
hunk ./Compat.hs 17
+#ifndef WIN32
+import Control.Exception ( catch )
+import Control.Monad ( unless )
hunk ./Compat.hs 22
-#ifdef WIN32
hunk ./Compat.hs 23
-#endif
hunk ./Compat.hs 24
+import Data.Bits ( xor, shiftR )
hunk ./Compat.hs 28
+import System.Directory ( removeFile, renameFile )
hunk ./Compat.hs 33
+#ifndef WIN32
+import System.IO ( hPutStrLn )
+import System.IO.Error ( isDoesNotExistError, isPermissionError )
+#endif
hunk ./Compat.hs 41
+#ifndef WIN32
+import System.Posix.Files ( getFileStatus, isRegularFile, createLink,
+ modificationTime, fileID, fileSize, deviceID )
+#endif
hunk ./Compat.hs 56
+#endif
+#ifndef WIN32
+import System.Time ( getClockTime, ClockTime(TOD) )
hunk ./Compat.hs 123
+
+#ifdef WIN32
+
+maybe_relink :: Bool -> FilePath -> FilePath -> IO Bool
+maybe_relink _ _ _ = return False
+
+#else
+
+{-
+Tries to link src to dst if both files exist and have the same
+contents. If careful is false only the file sizes are compared; if
+it is true, the full contents are compared.
+
+This code assumes that dst cannot change behind our back -- the
+caller is supposed to protect it by a lock. On the other hand, it
+does handle simultaneous access to src, but only if src is never
+modified in place. It should also be safe over NFS.
+
+Assumes that rename cannot fail mid-way on a single filesystem.
+-}
+
+maybe_relink :: Bool -> FilePath -> FilePath -> IO Bool
+maybe_relink careful src dst = do
+ m_src_stat <- (liftM Just $ getFileStatus src) `catch` \e ->
+ case e of
+ IOException e'
+ | isDoesNotExistError e'
+ -> return Nothing
+ _ -> throwIO (add_to_error_loc e ("Relinking " ++ dst))
+ case m_src_stat of
+ Nothing -> return False
+ Just src_stat -> do
+ dst_stat <- getFileStatus dst
+
+ unless (isRegularFile src_stat)
+ (fail (src ++ " is not a regular file"))
+ unless (isRegularFile dst_stat)
+ (fail (dst ++ " is not a regular file"))
+
+ if deviceID src_stat /= deviceID dst_stat then return False
+ else if fileID src_stat == fileID dst_stat then return True
+ else if fileSize src_stat /= fileSize dst_stat then return False
+ else do TOD _ usec <- getClockTime
+ let x = (shiftR usec 16 `xor` usec) .&. 0xFFFF
+ tempname = dst ++ showHexLen 4 x
+ {- link is atomic even on NFS, we will fail
+ gracefully if the name is not unique. -}
+ do createLink src tempname
+ temp_stat <- getFileStatus tempname
+ {- Check for a race condition. The size and
+ mtime checks are gratuitious, but they don't
+ cost much, and might save your data if
+ you're on a filesystem without i-nodes. -}
+ if fileID temp_stat /= fileID src_stat ||
+ fileSize temp_stat /= fileSize src_stat ||
+ modificationTime temp_stat /=
+ modificationTime src_stat
+ then do hPutStrLn stderr "race condition avoided"
+ removeFile tempname
+ return False
+ else if careful
+ then do lf1 <- readFileLazily tempname
+ lf2 <- readFileLazily dst
+ {- This == test is technically too
+ strong, but will pretty much
+ always br right in practice -}
+ if lf1 == lf2
+ then do renameFile tempname dst
+ return True
+ else do removeFile tempname
+ return False
+ else do renameFile tempname dst
+ return True
+ `catch` \e -> do removeFile tempname `catch`
+ \_ -> return ()
+ throwIO e
+ `catch` \e -> case e of
+ IOException e'
+ | isPermissionError e' || isUnsupportedOperationError e' ->
+ return False
+ _ -> throwIO (add_to_error_loc e ("Relinking " ++ dst))
+
+#endif
hunk ./DarcsUtils.lhs 9
- showHexLen,
+ showHexLen, add_to_error_loc, isUnsupportedOperationError,
hunk ./DarcsUtils.lhs 12
+import Control.Exception ( Exception(IOException) )
+import GHC.IOBase ( IOException(ioe_location),
+ IOErrorType(UnsupportedOperation) )
+import System.IO.Error ( ioeGetErrorType )
hunk ./DarcsUtils.lhs 33
+
+add_to_error_loc :: Exception -> String -> Exception
+add_to_error_loc (IOException ioe) s
+ = IOException $ ioe { ioe_location = s ++ ": " ++ ioe_location ioe }
+add_to_error_loc e _ = e
+
+isUnsupportedOperationError :: IOError -> Bool
+isUnsupportedOperationError = isUnsupportedOperationErrorType . ioeGetErrorType
+
+isUnsupportedOperationErrorType :: IOErrorType -> Bool
+isUnsupportedOperationErrorType UnsupportedOperation = True
+isUnsupportedOperationErrorType _ = False
hunk ./FastPackedString.hs 45
+ readFileLazily, -- :: FilePath -> IO LazyFile
hunk ./FastPackedString.hs 819
+ deriving Eq
hunk ./FastPackedString.hs 848
- else do let read_rest = do
- -- We might be making too big a fp here
- fp <- mallocForeignPtr blocksize
- debugForeignPtr fp $ "gzReadFileLazily "++f
- lread <- withForeignPtr fp
- $ \p -> hGetBuf h p blocksize
- case lread of
- 0 -> return []
- l -> do rest <- unsafeInterleaveIO read_rest
- return (PS fp 0 l:rest)
- rest <- unsafeInterleaveIO read_rest
- return $ LazyPackedStrings (header:rest)
+ else liftM (LazyPackedStrings . (header:)) $ readHandleLazily h
+ where blocksize = 1024
+
+readFileLazily :: FilePath -> IO LazyFile
+readFileLazily f =
+#if defined(__GLASGOW_HASKELL__)
+ if use_mmap
+ then liftM MMappedPackedString (mmapFilePS f)
+ else
+#endif
+ do h <- openBinaryFile f ReadMode
+ liftM LazyPackedStrings $ readHandleLazily h
+
+readHandleLazily :: Handle -> IO [PackedString]
+readHandleLazily h
+ = do let read_rest = do
+ -- We might be making too big a fp here
+ fp <- mallocForeignPtr blocksize
+ debugForeignPtr fp ("readHandleLazily " ++ show h)
+ lread <- withForeignPtr fp
+ $ \p -> hGetBuf h p blocksize
+ case lread of
+ 0 -> return []
+ l -> do rest <- unsafeInterleaveIO read_rest
+ return (PS fp 0 l:rest)
+ unsafeInterleaveIO read_rest
hunk ./Lock.lhs 57
-import Compat ( mkstemp, mk_stdout_temp, canonFilename )
+import Compat ( mkstemp, mk_stdout_temp, canonFilename, maybe_relink )
hunk ./Lock.lhs 296
-foreign import ccall unsafe "compat.h maybe_relink" c_maybe_relink
- :: CString -> CString -> CInt -> IO CInt
-
hunk ./Lock.lhs 301
-maybeRelink src dst =
- withCString src $ \csrc ->
- withCString dst $ \cdst ->
- do rc <- c_maybe_relink csrc cdst 1
- (case rc of
- 0 -> return True
- 1 -> return True
- -1 -> throwErrno ("Relinking " ++ dst)
- -2 -> return False
- -3 -> do putStrLn ("Relinking: race condition avoided on file " ++
- dst)
- return False
- _ -> fail ("Unexpected situation when relinking " ++ dst))
+maybeRelink src dst = maybe_relink True src dst
hunk ./compat.c 258
-#ifdef _WIN32
-int
-maybe_relink(const char *src, const char *dst, int careful)
-{
- return 0;
-}
-
-#else
-
-/* Tries to link src to dst if both files exist and have the same
- contents. If careful is false only the file sizes are compared; if
- it is true, the full contents are compared.
-
- This code assumes that dst cannot change behind our back -- the
- caller is supposed to protect it by a lock. On the other hand, it
- does handle simultaneous access to src, but only if src is never
- modified in place. It should also be safe over NFS.
-
- Assumes that rename cannot fail mid-way on a single filesystem.
-
- Returns 1 on success, 0 if the files are already linked, -1 for an
- error in errno, -2 if the files cannot be linked because they are not
- the same, on different devices, or on a filesystem with no support for
- hard links, -3 if there was a race condition, -4 if something unexpected
- happened. */
-
-int
-maybe_relink(char *src, char *dst, int careful)
-{
-#define RELINK_BUFFER_SIZE 8192
-
- int len, rc, saved_errno;
- char *tempname;
- struct stat srcstat, dststat, tempstat;
- struct timeval now;
-
- rc = stat(src, &srcstat);
- if(rc < 0) {
- if(errno == ENOENT)
- return -2;
- else
- return -1;
- }
-
- rc = stat(dst, &dststat);
- if(rc < 0) return -1;
-
- if(!S_ISREG(srcstat.st_mode) || !S_ISREG(dststat.st_mode)) {
- return -4;
- }
-
- if(srcstat.st_dev != dststat.st_dev) {
- return -2;
- }
-
- if(srcstat.st_ino == dststat.st_ino)
- /* Files are already linked */
- return 0;
-
- if(srcstat.st_size != dststat.st_size)
- return -2;
-
- /* link is atomic even on NFS, we will fail gracefully if the name
- is not unique. */
- gettimeofday(&now, NULL);
- rc = strlen(dst) + 6;
- tempname = malloc(rc);
- if(tempname == NULL) return -1;
- len = snprintf(tempname, rc, "%s-%04x", dst,
- ((unsigned)(now.tv_usec ^ (now.tv_usec >> 16))) & 0xFFFF);
- if(len < 0 || len >= rc) {
- free(tempname);
- return -4;
- }
-
- rc = link(src, tempname);
- if(rc < 0) {
- /* We need to try to remove the link in case this was a
- problem with NFS over an unreliable transport. */
- goto fail;
- }
-
- rc = stat(tempname, &tempstat);
- if(rc < 0) goto fail;
-
- /* Check for a race condition. The size and mtime checks are
- gratuitious, but they don't cost much, and might save your data
- if you're on a filesystem without i-nodes. */
- if(tempstat.st_ino != srcstat.st_ino ||
- tempstat.st_size != srcstat.st_size ||
- tempstat.st_mtime != srcstat.st_mtime) {
- unlink(tempname);
- free(tempname);
- return -3;
- }
- if(careful) {
- int fd1, fd2, i, rc1, rc2;
- char buf1[RELINK_BUFFER_SIZE], buf2[RELINK_BUFFER_SIZE];
-
- fd1 = open(tempname, O_RDONLY);
- if(fd1 < 0) goto fail;
- fd2 = open(dst, O_RDONLY);
- if(fd2 < 0) { close(fd1); goto fail; }
-
- i = 0;
- /* This comparison is approximate: it doesn't deal with short
- reads and EINTR. It's okay, as these cases are rare and if
- they happen, we're still safe. */
- while(i < tempstat.st_size) {
- rc1 = read(fd1, buf1, RELINK_BUFFER_SIZE);
- if(rc1 < 0) { close(fd1); close(fd2); goto fail; }
- rc2 = read(fd2, buf2, RELINK_BUFFER_SIZE);
- if(rc2 < 0) { close(fd1); close(fd2); goto fail; }
- if(rc1 == 0 || rc1 != rc2 || memcmp(buf1, buf2, rc1) != 0) {
- close(fd1); close(fd2);
- unlink(tempname);
- free(tempname);
- return -2;
- }
- i += rc1;
- }
- close(fd1); close(fd2);
- }
-
- rc = rename(tempname, dst);
- if(rc < 0) goto fail;
-
- free(tempname);
- return 1;
-
- fail:
- saved_errno = errno;
- unlink(tempname);
- free(tempname);
- errno = saved_errno;
- if(errno == EPERM || errno == EOPNOTSUPP)
- return -2;
- return -1;
-
-#undef RELINK_BUFFER_SIZE
-}
-
-#endif
hunk ./compat.h 22
-int maybe_relink(const char *src, const char *dst, int careful);
}
[Split the raw mode stuff out into its own .hsc file. Windows needs some TLC
Ian Lynagh <[EMAIL PROTECTED]>**20050730134030] {
hunk ./GNUmakefile 32
- PrintPatch.lhs Printer.lhs RegChars.lhs \
+ PrintPatch.lhs Printer.lhs RawMode.hs RegChars.lhs \
hunk ./GNUmakefile 249
+ rm -f RawMode.hs
addfile ./RawMode.hsc
hunk ./RawMode.hsc 1
+
+module RawMode (get_raw_mode, set_raw_mode) where
+
+#ifdef _WIN32
+
+-- Various details are missing, unfinished and compilation etc not tested
+-- as I don't have Windows.
+
+#include <XXX.h>
+
+type DWORD = #type DWORD
+type HANDLE = #type HANDLE
+
+foreign import ccall unsafe "XXX.h GetStdHandle"
+ c_GetStdHandle :: Handle -> IO c_STD_INPUT_HANDLE
+
+foreign import ccall unsafe "XXX.h GetConsoleMode"
+ c_GetConsoleMode :: Handle -> Ptr DWORD -> IO ()
+
+get_mode :: IO DWORD
+get_mode = do stdin_handle <- c_GetStdHandle (#const STD_INPUT_HANDLE)
+ p <- malloc
+ c_GetConsoleMode stdin_handle p
+ console_mode <- peek p
+ free p
+ return console_mode
+
+int get_raw_mode()
+{
+ return (get_mode() & ENABLE_LINE_INPUT) == 0;
+}
+
+void set_raw_mode(int raw)
+{
+ HANDLE stdin_handle = GetStdHandle(STD_INPUT_HANDLE);
+ DWORD console_mode = get_mode();
+ if (raw)
+ console_mode &= ~(ENABLE_LINE_INPUT|ENABLE_ECHO_INPUT);
+ else
+ console_mode |= ENABLE_LINE_INPUT|ENABLE_ECHO_INPUT;
+ if (!SetConsoleMode(stdin_handle, console_mode))
+ fprintf(stderr, "SetConsoleMode error: %x\n", GetLastError());
+}
+
+#else
+
+get_raw_mode :: IO Bool
+get_raw_mode = return False
+
+set_raw_mode :: Bool -> IO ()
+set_raw_mode _ = return ()
+
+#endif
+
hunk ./SelectChanges.lhs 54
-import Foreign.C ( CInt )
hunk ./SelectChanges.lhs 78
+import RawMode ( get_raw_mode, set_raw_mode )
hunk ./SelectChanges.lhs 215
-foreign import ccall "compat.h get_raw_mode" get_raw_mode :: IO CInt
-foreign import ccall "compat.h set_raw_mode" set_raw_mode :: CInt -> IO ()
-
hunk ./SelectChanges.lhs 222
- set_raw_mode 1
+ set_raw_mode True
hunk ./autoconf.mk.in 91
+%.hs : %.hsc
+ hsc2hs $< -o $@
+
hunk ./compat.c 160
-#ifdef _WIN32
-static DWORD get_mode()
-{
- DWORD console_mode;
- HANDLE stdin_handle = GetStdHandle(STD_INPUT_HANDLE);
- GetConsoleMode(stdin_handle, &console_mode);
- return console_mode;
-}
-
-int get_raw_mode()
-{
- return (get_mode() & ENABLE_LINE_INPUT) == 0;
-}
-
-void set_raw_mode(int raw)
-{
- HANDLE stdin_handle = GetStdHandle(STD_INPUT_HANDLE);
- DWORD console_mode = get_mode();
- if (raw)
- console_mode &= ~(ENABLE_LINE_INPUT|ENABLE_ECHO_INPUT);
- else
- console_mode |= ENABLE_LINE_INPUT|ENABLE_ECHO_INPUT;
- if (!SetConsoleMode(stdin_handle, console_mode))
- fprintf(stderr, "SetConsoleMode error: %x\n", GetLastError());
-}
-
-
-#else
-
-int get_raw_mode()
-{
- return 0;
-}
-
-void set_raw_mode(int raw)
-{
-}
+#ifndef _WIN32
hunk ./compat.h 13
-int get_raw_mode();
-void set_raw_mode(int raw);
-
}
[Move atomic_create/sloppy_atomic_create to Compat
Ian Lynagh <[EMAIL PROTECTED]>**20050730141703] {
hunk ./Compat.hs 5
- maybe_relink) where
+ maybe_relink, atomic_create, sloppy_atomic_create) where
hunk ./Compat.hs 12
-import DarcsUtils ( add_to_error_loc, isUnsupportedOperationError )
+import DarcsUtils ( add_to_error_loc, isUnsupportedOperationError,
+ isHardwareFaultError )
hunk ./Compat.hs 19
-import Control.Exception ( catch )
-import Control.Monad ( unless )
+import Control.Exception ( catch, finally )
+import Control.Monad ( when, unless )
hunk ./Compat.hs 26
+import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
+import Data.Maybe ( isJust )
hunk ./Compat.hs 31
+import Network.BSD ( getHostName )
hunk ./Compat.hs 39
-import System.IO.Error ( isDoesNotExistError, isPermissionError )
+import System.IO.Error ( isDoesNotExistError, isPermissionError,
+ alreadyExistsErrorType, isAlreadyExistsError,
+ ioeSetErrorType )
hunk ./Compat.hs 46
-import System.Posix.Files ( getFdStatus, isNamedPipe )
hunk ./Compat.hs 47
-import System.Posix.Files ( getFileStatus, isRegularFile, createLink,
- modificationTime, fileID, fileSize, deviceID )
+import System.IO.Unsafe ( unsafePerformIO )
+import System.Posix.Env ( getEnv )
hunk ./Compat.hs 50
+import System.Posix.Files ( getFdStatus, isNamedPipe )
hunk ./Compat.hs 53
+#else
+import System.Posix.Files ( getFileStatus, isRegularFile, createLink,
+ modificationTime, fileID, fileSize, deviceID,
+ linkCount, stdFileMode )
hunk ./Compat.hs 58
-import System.Posix.IO ( stdOutput, stdError, fdToHandle, dupTo )
+import System.Posix.IO ( openFd, closeFd, stdOutput, stdError, fdToHandle,
+ dupTo, defaultFileFlags, exclusive,
+ OpenMode(WriteOnly) )
hunk ./Compat.hs 65
+#ifndef WIN32
+import System.Posix.Process ( getProcessID )
+#endif
hunk ./Compat.hs 220
+#endif
+
+sloppy_atomic_create :: FilePath -> IO ()
+sloppy_atomic_create fp
+ = do fd <- openFd fp WriteOnly (Just stdFileMode) flags
+ closeFd fd
+ where flags = defaultFileFlags { exclusive = True }
+
+atomic_create :: FilePath -> IO ()
+
+#ifdef _WIN32
+
+atomic_create fp = sloppy_atomic_create fp
+
+#else
+
+{-# NOINLINE hostname_ref #-}
+hostname_ref :: IORef (Maybe String)
+hostname_ref = unsafePerformIO (newIORef Nothing)
+
+get_hostname :: IO String
+get_hostname
+ = getHostName `catch` \_ ->
+ do hPutStrLn stderr "Error reading hostname when locking."
+ return "kremvax"
+
+careful_atomic_create :: FilePath -> IO ()
+{-
+O_EXCL is not available over NFSv2, and even under NFSv3, it is
+broken on many systems. The following protocol is provably
+safe assuming that:
+- creation of hard links is atomic;
+- stat hits the server rather than working from the cache.
+-}
+careful_atomic_create fp =
+ do m_hostname <- readIORef hostname_ref
+ hostname <- case m_hostname of
+ Just hostname -> return hostname
+ Nothing -> do
+ hostname <- get_hostname
+ let hostname' = take 15
+ $ takeWhile ('.' /=) hostname
+ writeIORef hostname_ref (Just hostname')
+ return hostname'
+ pid <- getProcessID
+ TOD _ usec <- getClockTime
+
+ let directory = case break ('/' ==) $ reverse fp of
+ (_, xs) -> reverse xs
+ file = directory
+ ++ "darcs_lock_"
+ ++ hostname
+ ++ showHexLen 4 (pid .&. 0xFFFF)
+ ++ showHexLen 4 ((shiftR usec 16 `xor` usec) .&. 0xFFFF)
+
+ finally (do sloppy_atomic_create file
+ createLink file fp `catch` \e ->
+ case e of
+ IOException e'
+ {- Linux returns EPERM when making hard
+ links on filesystems that don't support
+ them.
+ It seems that MacOS returns EOPNOTSUPP
+ on filesystems that don't support hard
+ links. -}
+ | isPermissionError e' ||
+ isUnsupportedOperationError e' ->
+ sloppy_atomic_create fp
+ {- The link may still have been successful
+ if we're running over UDP and got EEXIST
+ or EIO. Check the file's link count. -}
+ | isAlreadyExistsError e' ||
+ isHardwareFaultError e' ->
+ do fs <- getFileStatus file
+ let e'' = ioeSetErrorType e'
+ alreadyExistsErrorType
+ when (linkCount fs /= 2)
+ (throwIO (IOException e''))
+ _ -> throwIO e
+ )
+ (removeFile file `catch` \e ->
+ case e of
+ IOException e' | isDoesNotExistError e' -> return ()
+ _ -> throwIO e)
+
+atomic_create fp = do m <- getEnv "DARCS_SLOPPY_LOCKS"
+ if isJust m
+ then sloppy_atomic_create fp
+ else careful_atomic_create fp
hunk ./DarcsUtils.lhs 9
- showHexLen, add_to_error_loc, isUnsupportedOperationError,
+ showHexLen, add_to_error_loc,
+ isUnsupportedOperationError, isHardwareFaultError,
hunk ./DarcsUtils.lhs 15
- IOErrorType(UnsupportedOperation) )
+ IOErrorType(UnsupportedOperation, HardwareFault) )
hunk ./DarcsUtils.lhs 46
+
+isHardwareFaultError :: IOError -> Bool
+isHardwareFaultError = isHardwareFaultErrorType . ioeGetErrorType
+
+isHardwareFaultErrorType :: IOErrorType -> Bool
+isHardwareFaultErrorType HardwareFault = True
+isHardwareFaultErrorType _ = False
hunk ./GNUmakefile 14
-GHCFLAGS += -Wall -Werror -package util -I.
+GHCFLAGS += -Wall -Werror -package util -package network -I.
hunk ./Lock.lhs 34
-import IO hiding ( bracket )
-import System.IO ( openBinaryFile )
-import Control.Exception ( bracket, catchJust, ioErrors, finally )
+import System.IO ( openBinaryFile, hClose, hPutStr, Handle,
+ IOMode(WriteMode, AppendMode) )
+import System.IO.Error ( isDoesNotExistError, isAlreadyExistsError )
+import Control.Exception ( bracket, catchJust, ioErrors, finally, throwIO,
+ Exception(IOException), catch, try )
hunk ./Lock.lhs 45
-import Foreign
-import Foreign.C ( withCString, CString,
- throwErrno, getErrno, eEXIST, CInt, CUInt )
+import Foreign.C ( CUInt )
hunk ./Lock.lhs 50
-import DarcsUtils ( catchall )
+import DarcsUtils ( catchall, add_to_error_loc )
hunk ./Lock.lhs 57
-import Compat ( mkstemp, mk_stdout_temp, canonFilename, maybe_relink )
+import Compat ( mkstemp, mk_stdout_temp, canonFilename, maybe_relink,
+ atomic_create, sloppy_atomic_create )
hunk ./Lock.lhs 62
-takeLock :: String -> IO Bool
hunk ./Lock.lhs 88
-takeLock s = withCString s $ \cstr -> do
- rc <- c_atomic_create cstr
- if rc >= 0 then return True
- else do errno <- getErrno
- if errno == eEXIST
- then return False
- else do pwd <- getCurrentDirectory
- throwErrno $ "takeLock "++s++" in "++pwd
+takeLock :: FilePath -> IO Bool
+takeLock fp =
+ do atomic_create fp
+ return True
+ `catch` \e -> case e of
+ IOException e'
+ | isAlreadyExistsError e' ->
+ return False
+ _ -> do pwd <- getCurrentDirectory
+ throwIO $ add_to_error_loc e
+ ("takeLock "++fp++" in "++pwd)
hunk ./Lock.lhs 100
-foreign import ccall unsafe "compat.h atomic_create" c_atomic_create
- :: CString -> IO CInt
-
-takeFile :: String -> IO Bool
-takeFile s = withCString s $ \cstr -> do
- rc <- c_sloppy_create cstr
- if rc >= 0 then return True
- else do errno <- getErrno
- if errno == eEXIST
- then return False
- else do pwd <- getCurrentDirectory
- throwErrno $ "takeFile "++s++" in "++pwd
-
-foreign import ccall unsafe "compat.h sloppy_atomic_create" c_sloppy_create
- :: CString -> IO CInt
+takeFile :: FilePath -> IO Bool
+takeFile fp =
+ do sloppy_atomic_create fp
+ return True
+ `catch` \e -> case e of
+ IOException e'
+ | isAlreadyExistsError e' ->
+ return False
+ _ -> do pwd <- getCurrentDirectory
+ throwIO $ add_to_error_loc e
+ ("takeFile "++fp++" in "++pwd)
hunk ./Lock.lhs 187
- `IO.catch` (\e -> if isAlreadyExistsError e
- then create_directory name (n+1)
- else ioError e)
+ `catch` (\e -> case e of
+ IOException e'
+ | isAlreadyExistsError e' ->
+ create_directory name (n+1)
+ _ -> throwIO e)
hunk ./compat.c 18
-int sloppy_atomic_create(const char *p)
-{
- int fd;
- fd = open(p, O_WRONLY | O_EXCL | O_CREAT, 0666);
- if(fd < 0)
- return -1;
- close(fd);
- return 1;
-}
-
-#ifdef _WIN32
-
-int atomic_create(const char *p)
-{
- return sloppy_atomic_create(p);
-}
-
-#else
-
-static int careful_atomic_create(const char *p)
-{
- /* O_EXCL is not available over NFSv2, and even under NFSv3, it is
- broken on many systems. The following protocol is provably
- safe assuming that:
- - creation of hard links is atomic;
- - stat hits the server rather than working from the cache.
- */
-
- static char hostname[65] = {'\0'};
- int fd, rc, saved_errno;
-#define FILENAME_SIZE (11 + 15 + 8 + 1)
- char *filename;
- char *lastslash;
- int dirlen;
- struct timeval now;
- struct stat sb;
-
- if(hostname[0] == '\0') {
- char *c;
- /* POSIX guarantees 65 is enough. */
- rc = gethostname(hostname, 65);
- if(rc < 0 || rc >= 65) {
- fprintf(stderr, "Error reading hostname when locking.\n");
- strcpy(hostname, "kremvax");
- }
- c = strchr(hostname, '.');
- if(c != NULL)
- *c = '\0';
- hostname[15] = '\0';
- }
-
- lastslash = strrchr(p, '/');
- dirlen = lastslash ? lastslash - p + 1 : 0;
-
- filename = malloc(dirlen + FILENAME_SIZE);
- if(filename == NULL)
- return -1;
-
- if(dirlen > 0)
- memcpy(filename, p, dirlen);
- filename[dirlen] = '\0';
-
- gettimeofday(&now, NULL);
-
- rc = snprintf(filename + dirlen, FILENAME_SIZE, "darcs_lock_%s%04x%04x",
- hostname, ((unsigned)getpid()) & 0xFFFF,
- ((unsigned)(now.tv_usec ^ (now.tv_usec >> 16))) & 0xFFFF);
- if(rc < 0 || rc >= FILENAME_SIZE) {
- fprintf(stderr, "Error writing to lock filename (%d)\n",
- rc < 0 ? errno : 0);
- goto fail2;
- }
-
- fd = open(filename, O_WRONLY | O_EXCL | O_CREAT, 0666);
- if(fd < 0)
- goto fail2;
-
- /* Paranoia: should cause the client to flush its metadata cache. */
- rc = close(fd);
- if(rc < 0) {
- fprintf(stderr, "Error closing file %s. (%d)\n", filename, errno);
- goto fail;
- }
-
- rc = link(filename, p);
- if(rc >= 0)
- goto success;
- else if(errno == EPERM || errno == EOPNOTSUPP) {
- /* Linux returns EPERM when making hard links on filesystems
- that don't support them. */
- /* It seems that MacOS returns EOPNOTSUPP on filesystems that
- don't support hard links. */
- unlink(filename);
- free(filename);
- return sloppy_atomic_create(p);
- } else if(errno != EEXIST && errno != EIO)
- goto fail;
-
- /* The link may still have been successful if we're running over
- UDP and got EEXIST or EIO. Check the file's link count. */
-
- rc = stat(filename, &sb);
- if(rc < 0) {
- goto fail;
- }
-
- if(sb.st_nlink != 2) {
- errno = EEXIST;
- goto fail;
- }
-
- success:
- unlink(filename);
- free(filename);
- return 1;
-
- fail:
- saved_errno = errno;
- unlink(filename);
- errno = saved_errno;
- fail2:
- free(filename);
- return -1;
-}
-
-int atomic_create(const char *p)
-{
- static int sloppy = -1;
-
- if(sloppy < 0) {
- char *s = getenv("DARCS_SLOPPY_LOCKS");
- sloppy = (s != NULL);
- }
-
- if(sloppy)
- return sloppy_atomic_create(p);
- else
- return careful_atomic_create(p);
-}
-
-#endif
-
hunk ./compat.h 6
-int sloppy_atomic_create(const char *p);
-int atomic_create(const char *p);
-
-#ifdef _WIN32
-int renamefile(const char *from, const char *to);
-#endif
-
}
[Rename compat.c to c_compat.c to avoid object filename conflict with Compat.hs
[EMAIL PROTECTED] {
move ./compat.c ./c_compat.c
hunk ./Compat.hs 61
-#ifdef WIN32
-import System.Posix.IO ( defaultFileFlags, openFd,
- exclusive, OpenMode(WriteOnly) )
-#endif
hunk ./GNUmakefile 59
-C_OBJS := compat.o fpstring.o $(GIT_C_OBJS)
+C_OBJS := c_compat.o fpstring.o $(GIT_C_OBJS)
}
[call hsc2hs without output filename argument
[EMAIL PROTECTED] {
hunk ./autoconf.mk.in 92
- hsc2hs $< -o $@
+ hsc2hs $<
}
[implement RawMode with library functions instead of ffi
[EMAIL PROTECTED] {
move ./RawMode.hsc ./RawMode.hs
hunk ./GNUmakefile 249
- rm -f RawMode.hs
hunk ./RawMode.hs 4
-#ifdef _WIN32
+#ifdef WIN32
hunk ./RawMode.hs 6
--- Various details are missing, unfinished and compilation etc not tested
--- as I don't have Windows.
+import Monad ( liftM )
+import DarcsUtils ( catchall )
+import System.Posix.Internals ( getEcho, setCooked, setEcho )
hunk ./RawMode.hs 10
-#include <XXX.h>
+get_raw_mode :: IO Bool
+get_raw_mode = not `liftM` getEcho 0
+ `catchall` return False -- getEcho sometimes fails when called from scripts
hunk ./RawMode.hs 14
-type DWORD = #type DWORD
-type HANDLE = #type HANDLE
-
-foreign import ccall unsafe "XXX.h GetStdHandle"
- c_GetStdHandle :: Handle -> IO c_STD_INPUT_HANDLE
-
-foreign import ccall unsafe "XXX.h GetConsoleMode"
- c_GetConsoleMode :: Handle -> Ptr DWORD -> IO ()
-
-get_mode :: IO DWORD
-get_mode = do stdin_handle <- c_GetStdHandle (#const STD_INPUT_HANDLE)
- p <- malloc
- c_GetConsoleMode stdin_handle p
- console_mode <- peek p
- free p
- return console_mode
-
-int get_raw_mode()
-{
- return (get_mode() & ENABLE_LINE_INPUT) == 0;
-}
-
-void set_raw_mode(int raw)
-{
- HANDLE stdin_handle = GetStdHandle(STD_INPUT_HANDLE);
- DWORD console_mode = get_mode();
- if (raw)
- console_mode &= ~(ENABLE_LINE_INPUT|ENABLE_ECHO_INPUT);
- else
- console_mode |= ENABLE_LINE_INPUT|ENABLE_ECHO_INPUT;
- if (!SetConsoleMode(stdin_handle, console_mode))
- fprintf(stderr, "SetConsoleMode error: %x\n", GetLastError());
-}
+set_raw_mode :: Bool -> IO ()
+set_raw_mode raw = setCooked 0 normal >> setEcho 0 normal
+ where normal = not raw
}
[Implement parts of System.Posix.(IO|Files) for win32
[EMAIL PROTECTED] {
adddir ./win32/System/Posix
hunk ./Compat.hs 226
-#ifdef _WIN32
+#ifdef WIN32
hunk ./External.hs 20
-import System.Posix ( getSymbolicLinkStatus, isRegularFile, isDirectory )
+import System.Posix.Files ( getSymbolicLinkStatus, isRegularFile, isDirectory )
hunk ./GNUmakefile 63
-DARCS_FILES += win32/System/Posix.hs win32/CtrlC.hs
+DARCS_FILES += win32/System/Posix.hs win32/System/Posix/Files.hs \
+ win32/System/Posix/IO.hs win32/CtrlC.hs
hunk ./GNUmakefile 66
-UNIT_FILES += win32/System/Posix.hs
-CREATEREPO_FILES += win32/System/Posix.hs
+UNIT_FILES += win32/System/Posix.hs win32/System/Posix/Files.hs \
+ win32/System/Posix/IO.hs
+CREATEREPO_FILES += win32/System/Posix.hs win32/System/Posix/Files.hs \
+ win32/System/Posix/IO.hs
hunk ./GNUmakefile 260
+ rm -f win32/System/Posix/IO.hs win32/System/Posix/Files.hs
hunk ./SlurpDirectory.lhs 54
-import System.Posix
- ( EpochTime, getSymbolicLinkStatus, modificationTime,
- sleep, FileOffset, fileSize,
+import System.Posix.Types ( EpochTime, FileOffset )
+import System.Posix.Files
+ ( getSymbolicLinkStatus, modificationTime,
+ fileSize,
hunk ./SlurpDirectory.lhs 60
+import System.Posix ( sleep )
hunk ./win32/System/Posix.hs 4
-import Foreign
-import Foreign.Ptr
-import Foreign.C.Error
-import Foreign.C.Types
-import Foreign.C.String
+import Foreign.Ptr ( Ptr, castPtr, plusPtr )
+import Foreign.Storable ( peek, poke, sizeOf )
+import Foreign.C.Types ( CInt, CULong, CTime )
+import Foreign.C.String ( CString, withCString )
+import Foreign.Marshal.Alloc ( allocaBytes )
hunk ./win32/System/Posix.hs 10
-import Monad
+import System.Posix.Types ( EpochTime )
+import System.IO ( Handle )
hunk ./win32/System/Posix.hs 13
-import IO
-
-foreign import ccall "_stat" c_stat :: CString -> Ptr () -> IO Int
-
-
-type FileOffset = CInt
-
-data FileStatus = FileStatus {
- accessTime :: EpochTime,
- modificationTime :: EpochTime,
- fileSize :: FileOffset,
- isRegularFile :: Bool,
- isDirectory :: Bool,
- isSymbolicLink :: Bool
- }
-
-s_ifdir, s_ifreg :: CShort
-s_ifdir = 0x4000 :: CShort
-s_ifreg = 0x8000 :: CShort
-
-getFileStatus :: FilePath -> IO FileStatus
-getFileStatus path = do
- p <- mallocBytes 36
- r <- path `withCString` (`c_stat` p)
- when (r /= 0) $ throwErrno path
- md <- peek_short p 6
- sz <- peek_int p 20
- at <- peek_int p 24
- mt <- peek_int p 28
- free p
- let isReg = md .&. s_ifreg == s_ifreg
- let isDir = md .&. s_ifdir == s_ifdir
- return (FileStatus (EpochTime (fromInteger at)) (EpochTime (fromInteger mt)) sz isReg isDir False)
- where peek_int p o = do i <- peek (castPtr (plusPtr p o)) :: IO CInt
- return (fromIntegral i)
- peek_short p o = do peek (castPtr (plusPtr p o)) :: IO CShort
-
-getSymbolicLinkStatus :: FilePath -> IO FileStatus
-getSymbolicLinkStatus = getFileStatus
hunk ./win32/System/Posix.hs 17
-setFileTimes path (EpochTime atime) (EpochTime mtime) = path `withCString` \s -> do
- p <- mallocBytes 8
- poke (castPtr p :: Ptr Int32) (fromIntegral atime)
- poke (castPtr (plusPtr p 4) :: Ptr Int32) (fromIntegral mtime)
+setFileTimes path atime mtime = path `withCString` \s -> do
+ allocaBytes 8 $ \p -> do
+ poke (castPtr p :: Ptr CTime) (atime)
+ poke (castPtr (plusPtr p 4) :: Ptr CTime) (mtime)
hunk ./win32/System/Posix.hs 22
- free p
hunk ./win32/System/Posix.hs 25
-
-foreign import ccall "time" c_ctime :: CInt -> IO CInt
+foreign import ccall "time" c_ctime :: Ptr CTime -> IO CInt
hunk ./win32/System/Posix.hs 29
- t <- c_ctime 0
- return (EpochTime (fromIntegral t))
-
-newtype EpochTime = EpochTime Int32
- deriving (Eq, Ord, Num, Real, Integral, Enum, Show)
+ allocaBytes (sizeOf (undefined :: CTime)) $ \p -> do
+ c_ctime p
+ t <- peek p :: IO CTime
+ return t
hunk ./win32/System/Posix.hs 42
+
addfile ./win32/System/Posix/Files.hsc
hunk ./win32/System/Posix/Files.hsc 1
+module System.Posix.Files where
+
+import Foreign.Marshal.Alloc ( allocaBytes )
+import Foreign.C.Error ( throwErrnoIfMinus1Retry )
+import Foreign.C.String ( withCString )
+import Foreign.C.Types ( CTime, CInt )
+import Foreign.Ptr ( Ptr )
+
+import System.Posix.Internals
+ ( FDType, CStat, c_fstat, lstat,
+ sizeof_stat, statGetType,
+ st_mode, st_size, st_mtime,
+ s_isreg, s_isdir, s_isfifo, )
+import System.Posix.Types ( Fd(..), CMode, COff, EpochTime, FileOffset, FileMode )
+
+import Data.Bits ( (.|.) )
+
+data FileStatus = FileStatus {
+ fst_type :: FDType,
+ fst_mode :: CMode,
+ fst_mtime :: CTime,
+ fst_size :: COff
+ }
+
+getFdStatus :: Fd -> IO FileStatus
+getFdStatus (Fd fd) = do
+ do_stat (c_fstat fd)
+
+do_stat :: (Ptr CStat -> IO CInt) -> IO FileStatus
+do_stat stat_func = do
+ allocaBytes sizeof_stat $ \p -> do
+ throwErrnoIfMinus1Retry "do_stat" $
+ stat_func p
+ tp <- statGetType p
+ mode <- st_mode p
+ mtime <- st_mtime p
+ size <- st_size p
+ return (FileStatus tp mode mtime size)
+
+isNamedPipe :: FileStatus -> Bool
+isNamedPipe = s_isfifo . fst_mode
+
+isDirectory :: FileStatus -> Bool
+isDirectory = s_isdir . fst_mode
+
+isRegularFile :: FileStatus -> Bool
+isRegularFile = s_isreg . fst_mode
+
+isSymbolicLink :: FileStatus -> Bool
+isSymbolicLink = const False
+
+modificationTime :: FileStatus -> EpochTime
+modificationTime = fst_mtime
+
+fileSize :: FileStatus -> FileOffset
+fileSize = fst_size
+
+#include <sys/stat.h>
+stdFileMode :: FileMode
+stdFileMode = (#const S_IRUSR) .|. (#const S_IWUSR)
+
+
+
+getSymbolicLinkStatus :: FilePath -> IO FileStatus
+getSymbolicLinkStatus fp =
+ do_stat (\p -> (fp `withCString` (`lstat` p)))
+
addfile ./win32/System/Posix/IO.hsc
hunk ./win32/System/Posix/IO.hsc 1
+module System.Posix.IO where
+
+import Foreign.C.String ( withCString )
+import Foreign.C.Error ( throwErrnoIfMinus1, throwErrnoIfMinus1_ )
+
+import GHC.Handle ( fdToHandle )
+
+import System.Posix.Internals ( c_open, c_close, c_dup2 )
+import System.Posix.Types ( Fd(..), FileMode )
+import System.IO ( Handle )
+
+import Data.Bits ( (.|.) )
+
+
+stdOutput :: Fd
+stdOutput = Fd 1
+
+stdError :: Fd
+stdError = Fd 2
+
+data OpenFileFlags =
+ OpenFileFlags {
+ append :: Bool,
+ exclusive :: Bool,
+ noctty :: Bool,
+ nonBlock :: Bool,
+ trunc :: Bool
+ }
+
+
+-- Adapted from System.Posix.IO in ghc
+#include <fcntl.h>
+
+openFd :: FilePath -> OpenMode -> Maybe FileMode -> OpenFileFlags -> IO Fd
+openFd name how maybe_mode off = do
+ withCString name $ \s -> do
+ fd <- throwErrnoIfMinus1 "openFd" (c_open s all_flags mode_w)
+ return (Fd fd)
+ where
+ all_flags = binary .|. creat .|. flags .|. open_mode
+ flags =
+ (if append off then (#const O_APPEND) else 0) .|.
+ (if exclusive off then (#const O_EXCL) else 0) .|.
+ (if trunc off then (#const O_TRUNC) else 0)
+ binary = (#const O_BINARY)
+ (creat, mode_w) = maybe (0,0) (\x->((#const O_CREAT),x)) maybe_mode
+ open_mode = case how of
+ ReadOnly -> (#const O_RDONLY)
+ WriteOnly -> (#const O_WRONLY)
+ ReadWrite -> (#const O_RDWR)
+
+closeFd :: Fd -> IO ()
+closeFd (Fd fd) = throwErrnoIfMinus1_ "closeFd" (c_close fd)
+
+
+fdToHandle :: Fd -> IO Handle
+fdToHandle fd = GHC.Handle.fdToHandle (fromIntegral fd)
+
+dupTo :: Fd -> Fd -> IO Fd
+dupTo (Fd fd1) (Fd fd2) = do
+ r <- throwErrnoIfMinus1 "dupTo" (c_dup2 fd1 fd2)
+ return (Fd r)
+
+data OpenMode = ReadOnly | WriteOnly | ReadWrite
+
+defaultFileFlags :: OpenFileFlags
+defaultFileFlags = OpenFileFlags False False False False False
+
+
}
[fix mkstemp implementation for win32
Peter Strand <[EMAIL PROTECTED]>**20050810211303] {
hunk ./Compat.hs 17
-import Control.Exception ( Exception(IOException), throwIO )
hunk ./Compat.hs 18
+import Control.Exception ( Exception(IOException), throwIO )
hunk ./Compat.hs 43
-#ifdef WIN32
-import System.IO.Error ( mkIOError, illegalOperationErrorType )
-#endif
hunk ./Compat.hs 55
-import System.Posix.IO ( openFd, closeFd, stdOutput, stdError, fdToHandle,
+import System.Posix.IO ( openFd, closeFd, stdOutput, stdError,
hunk ./Compat.hs 68
+import qualified Workaround ( openFd )
+import System.IO ( IOMode(ReadWriteMode) )
hunk ./Compat.hs 92
- = do fp' <- case splitAt 6 fp of
- ("XXXXXX", rev_fp) -> return $ reverse rev_fp
- _ -> let e = mkIOError illegalOperationErrorType
- "mkstemp" Nothing (Just fp)
- in throwIO (IOException e)
- r <- randomIO
- let fp'' = fp' ++ (showHexLen 6 (r .&. 0xFFFFFF :: Int))
- fd <- openFd fp WriteOnly (Just stdFileMode) flags
- return (fd, fp'')
+ = do r <- randomIO
+ let fp' = fp ++ (showHexLen 6 (r .&. 0xFFFFFF :: Int))
+ fd <- openFd fp' WriteOnly (Just stdFileMode) flags
+ return (fd, fp')
hunk ./Compat.hs 112
-mkstemp str = do (fd, fn) <- mkstemp_core str
- h <- fdToHandle fd
+mkstemp str = do (Fd fd, fn) <- mkstemp_core str
+ h <- Workaround.openFd (fromIntegral fd) Nothing fn ReadWriteMode True False
}
Context:
[make repair work on partial repositories.
David Roundy <[EMAIL PROTECTED]>**20050805113001]
[Cleanup --verbose handling in repair command
Matt Lavin <[EMAIL PROTECTED]>**20050805020630]
[clean up Printer.wrap_text.
David Roundy <[EMAIL PROTECTED]>**20050808114844]
[add several changelog entries.
David Roundy <[EMAIL PROTECTED]>**20050808114800]
[improve EOD message a tad.
David Roundy <[EMAIL PROTECTED]>**20050807112644
This change also introduces a "wrapped_text" function in Printer, so we
won't have to worry so often about manually wrapping lines.
]
[changed ***DARCS*** to ***END OF DESCRIPTION***
Jason Dagit <[EMAIL PROTECTED]>**20050729032543]
[remove unused opts argument from apply_patches and apply_patches_with_feedback
Matt Lavin <[EMAIL PROTECTED]>**20050807031038]
[Use apply_patch_with_feedback from check and repair commands
Matt Lavin <[EMAIL PROTECTED]>**20050805020830]
[add code to read patch bundles with added CRs.
David Roundy <[EMAIL PROTECTED]>**20050806222631
I think this'll address bug #291.
]
[accept command-line flags in any order.
David Roundy <[EMAIL PROTECTED]>**20050806211828
In particular, we no longer require that --flags precede filename and
repository arguments.
]
[show patch numbers instead of dots on get
Matt Lavin <[EMAIL PROTECTED]>**20050804013649]
[add obliterate command as alias for unpull.
David Roundy <[EMAIL PROTECTED]>**20050804104929]
[Do not ask confirmation for revert -a
[EMAIL PROTECTED]
Giving -a as a parameter means the user expects all changes to be reverted.
Just like for unrevert and record go ahead with it do not ask for confirmation.
]
[clarify help text for 'd' in SelectPatches.
David Roundy <[EMAIL PROTECTED]>**20050806231117]
[Add --with-static-libs configure flag for linking static versions of libraries.
[EMAIL PROTECTED]
[add changelog entry for bug #477.
David Roundy <[EMAIL PROTECTED]>**20050806212148]
[changelog entry for bug #189.
David Roundy <[EMAIL PROTECTED]>**20050731132624]
[add description of how to add changelog entries to ChangeLog.README.
David Roundy <[EMAIL PROTECTED]>**20050806225901]
[Explain the missing ChangeLog
Mark Stosberg <[EMAIL PROTECTED]>**20050526135421
It should be easy for casual users and contributors to view and update the
ChangeLog.
Providing a README file in the place where people are most likely to look
provides a very useful clue.
However, it's still not clear to me exactly how the system works, so I have
left a stub to complete that documentation.
Mark
]
[fix obsolete error explanation in get_extra bug.
David Roundy <[EMAIL PROTECTED]>**20050804130610]
[simplify fix for bug 463; reuse /// from FilePathUtils
Matt Lavin <[EMAIL PROTECTED]>**20050804021130]
[Make curl exit with error on failed downloads
[EMAIL PROTECTED]
[Bump up AC_PREREQ version to 2.59.
[EMAIL PROTECTED]
[fix for bug 463 (with new test)
Matt Lavin <[EMAIL PROTECTED]>**20050802002116]
[bump version number, since I just made a release.
David Roundy <[EMAIL PROTECTED]>**20050731190756]
[Use simpler curl_version() function to get version string.
Kannan Goundan <[EMAIL PROTECTED]>**20050322221027]
[fix documentation on --reorder-patches.
David Roundy <[EMAIL PROTECTED]>**20050731185406]
[add changelog entry for bug #224.
David Roundy <[EMAIL PROTECTED]>**20050731133942]
[fix bug when editing long comment leaves empty file.
David Roundy <[EMAIL PROTECTED]>**20050731133612]
[TAG 1.0.4pre2
David Roundy <[EMAIL PROTECTED]>**20050731121029]
Patch bundle hash:
969d8f85fd7af3083ad81784d1e2a945cdcb07dc
_______________________________________________
darcs-devel mailing list
[email protected]
http://www.abridgegame.org/cgi-bin/mailman/listinfo/darcs-devel
