Repository : ssh://darcs.haskell.org//srv/darcs/packages/base On branch : ghc-7.4
http://hackage.haskell.org/trac/ghc/changeset/35c90716b1cb13606eb002cc0d4222e07e1a629c >--------------------------------------------------------------- commit 35c90716b1cb13606eb002cc0d4222e07e1a629c Author: Paolo Capriotti <[email protected]> Date: Thu Jun 7 11:18:00 2012 +0100 Allow openTempFile to retry when it hits a directory (#4968). Windows returns an EACCES error instead of EEXIST when a call to `open` fails due to an existing directory, so add a special case for this situation. MERGED from commit 6172212097337923b621be9e12b3542c34cad10e >--------------------------------------------------------------- System/IO.hs | 30 +++++++++++++++++++++++++++--- cbits/Win32Utils.c | 6 ++++++ 2 files changed, 33 insertions(+), 3 deletions(-) diff --git a/System/IO.hs b/System/IO.hs index 860d2b6..31aa0e8 100644 --- a/System/IO.hs +++ b/System/IO.hs @@ -1,5 +1,6 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE CPP, NoImplicitPrelude #-} +{-# LANGUAGE ForeignFunctionInterface #-} ----------------------------------------------------------------------------- -- | @@ -240,6 +241,9 @@ import Data.Bits import Data.List import Data.Maybe import Foreign.C.Error +#ifdef mingw32_HOST_OS +import Foreign.C.String +#endif import Foreign.C.Types import System.Posix.Internals import System.Posix.Types @@ -623,10 +627,30 @@ openNewFile filepath binary mode = do if fd < 0 then do errno <- getErrno - if errno == eEXIST - then return FileExists - else return (OpenNewError errno) + case errno of + _ | errno == eEXIST -> return FileExists +# ifdef mingw32_HOST_OS + -- If c_open throws EACCES on windows, it could mean that filepath is a + -- directory. In this case, we want to return FileExists so that the + -- enclosing openTempFile can try again instead of failing outright. + -- See bug #4968. + _ | errno == eACCES -> do + withCString filepath $ \path -> do + -- There is a race here: the directory might have been moved or + -- deleted between the c_open call and the next line, but there + -- doesn't seem to be any direct way to detect that the c_open call + -- failed because of an existing directory. + exists <- c_fileExists path + return $ if exists + then FileExists + else OpenNewError errno +# endif + _ -> return (OpenNewError errno) else return (NewFileCreated fd) + +# ifdef mingw32_HOST_OS +foreign import ccall "file_exists" c_fileExists :: CString -> IO Bool +# endif #endif -- XXX Should use filepath library diff --git a/cbits/Win32Utils.c b/cbits/Win32Utils.c index fd4d1eb..d6759db 100644 --- a/cbits/Win32Utils.c +++ b/cbits/Win32Utils.c @@ -122,5 +122,11 @@ HsWord64 getUSecOfDay(void) return t; } +BOOL file_exists(LPCTSTR path) +{ + DWORD r = GetFileAttributes(path); + return r != INVALID_FILE_ATTRIBUTES; +} + #endif _______________________________________________ Cvs-libraries mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-libraries
