diff options
Diffstat (limited to 'libraries')
| -rw-r--r-- | libraries/base/GHC/IO/FD.hs | 61 | ||||
| -rw-r--r-- | libraries/base/cbits/Win32Utils.c | 17 | ||||
| -rw-r--r-- | libraries/base/include/HsBase.h | 4 | ||||
| -rw-r--r-- | libraries/base/tests/IO/countReaders001.stdout-mingw32 | 1 | ||||
| -rw-r--r-- | libraries/base/tests/IO/openFile005.stdout-mingw32 | 12 | ||||
| -rw-r--r-- | libraries/base/tests/IO/openFile007.stdout-mingw32 | 2 | ||||
| -rw-r--r-- | libraries/base/tests/IO/readFile001.stdout-mingw32 | 30 |
7 files changed, 47 insertions, 80 deletions
diff --git a/libraries/base/GHC/IO/FD.hs b/libraries/base/GHC/IO/FD.hs index 9422ddfdc5..bbd55cc33d 100644 --- a/libraries/base/GHC/IO/FD.hs +++ b/libraries/base/GHC/IO/FD.hs @@ -155,11 +155,7 @@ openFile filepath iomode non_blocking = let oflags1 = case iomode of ReadMode -> read_flags -#ifdef mingw32_HOST_OS - WriteMode -> write_flags .|. o_TRUNC -#else WriteMode -> write_flags -#endif ReadWriteMode -> rw_flags AppendMode -> append_flags @@ -167,7 +163,7 @@ openFile filepath iomode non_blocking = binary_flags = o_BINARY #else binary_flags = 0 -#endif +#endif oflags2 = oflags1 .|. binary_flags @@ -190,14 +186,11 @@ openFile filepath iomode non_blocking = `catchAny` \e -> do _ <- c_close fd throwIO e -#ifndef mingw32_HOST_OS - -- we want to truncate() if this is an open in WriteMode, but only - -- if the target is a RegularFile. ftruncate() fails on special files - -- like /dev/null. - if iomode == WriteMode && fd_type == RegularFile - then setSize fD 0 - else return () -#endif + -- we want to truncate() if this is an open in WriteMode, but only + -- if the target is a RegularFile. ftruncate() fails on special files + -- like /dev/null. + when (iomode == WriteMode && fd_type == RegularFile) $ + setSize fD 0 return (fD,fd_type) @@ -241,30 +234,27 @@ mkFD fd iomode mb_stat is_socket is_nonblock = do ReadMode -> False _ -> True -#ifdef mingw32_HOST_OS - _ <- setmode fd True -- unconditionally set binary mode - let _ = (dev,ino,write) -- warning suppression -#endif - case fd_type of Directory -> ioException (IOError Nothing InappropriateType "openFile" "is a directory" Nothing Nothing) -#ifndef mingw32_HOST_OS -- regular files need to be locked RegularFile -> do - -- On Windows we use explicit exclusion via sopen() to implement - -- this locking (see __hscore_open()); on Unix we have to - -- implment it in the RTS. - r <- lockFile fd dev ino (fromBool write) + -- On Windows we need an additional call to get a unique device id + -- and inode, since fstat just returns 0 for both. + (unique_dev, unique_ino) <- getUniqueFileInfo fd dev ino + r <- lockFile fd unique_dev unique_ino (fromBool write) when (r == -1) $ ioException (IOError Nothing ResourceBusy "openFile" "file is locked" Nothing Nothing) -#endif _other_type -> return () +#ifdef mingw32_HOST_OS + _ <- setmode fd True -- unconditionally set binary mode +#endif + return (FD{ fdFD = fd, #ifndef mingw32_HOST_OS fdIsNonBlocking = fromEnum is_nonblock @@ -274,6 +264,17 @@ mkFD fd iomode mb_stat is_socket is_nonblock = do }, fd_type) +getUniqueFileInfo :: CInt -> CDev -> CIno -> IO (Word64, Word64) +#ifndef mingw32_HOST_OS +getUniqueFileInfo _ dev ino = return (fromInteger dev, fromInteger ino) +#else +getUniqueFileInfo fd _ _ = do + with 0 $ \devptr -> do + with 0 $ \inoptr -> do + c_getUniqueFileInfo fd devptr inoptr + liftM2 (,) (peek devptr) (peek inoptr) +#endif + #ifdef mingw32_HOST_OS foreign import ccall unsafe "__hscore_setmode" setmode :: CInt -> Bool -> IO CInt @@ -304,9 +305,7 @@ stderr = stdFD 2 close :: FD -> IO () close fd = -#ifndef mingw32_HOST_OS (flip finally) (release fd) $ -#endif do let closer realFd = throwErrnoIfMinus1Retry_ "GHC.IO.FD.close" $ #ifdef mingw32_HOST_OS @@ -318,12 +317,8 @@ close fd = closeFdWith closer (fromIntegral (fdFD fd)) release :: FD -> IO () -#ifdef mingw32_HOST_OS -release _ = return () -#else release fd = do _ <- unlockFile (fdFD fd) return () -#endif #ifdef mingw32_HOST_OS foreign import stdcall unsafe "HsBase.h closesocket" @@ -657,11 +652,11 @@ throwErrnoIfMinus1RetryOnBlock loc f on_block = -- ----------------------------------------------------------------------------- -- Locking/unlocking -#ifndef mingw32_HOST_OS foreign import ccall unsafe "lockFile" - lockFile :: CInt -> CDev -> CIno -> CInt -> IO CInt + lockFile :: CInt -> Word64 -> Word64 -> CInt -> IO CInt foreign import ccall unsafe "unlockFile" unlockFile :: CInt -> IO CInt -#endif +foreign import ccall unsafe "get_unique_file_info" + c_getUniqueFileInfo :: CInt -> Ptr Word64 -> Ptr Word64 -> IO () diff --git a/libraries/base/cbits/Win32Utils.c b/libraries/base/cbits/Win32Utils.c index c084bd3a75..7327f45784 100644 --- a/libraries/base/cbits/Win32Utils.c +++ b/libraries/base/cbits/Win32Utils.c @@ -110,4 +110,21 @@ void maperrno (void) errno = EINVAL; } +int get_unique_file_info(int fd, HsWord64 *dev, HsWord64 *ino) +{ + HANDLE h = (HANDLE)_get_osfhandle(fd); + BY_HANDLE_FILE_INFORMATION info; + + if (GetFileInformationByHandle(h, &info)) + { + *dev = info.dwVolumeSerialNumber; + *ino = info.nFileIndexLow + | ((HsWord64)info.nFileIndexHigh << 32); + + return 0; + } + + return -1; +} + #endif diff --git a/libraries/base/include/HsBase.h b/libraries/base/include/HsBase.h index 5c4c1416ed..74ab816d84 100644 --- a/libraries/base/include/HsBase.h +++ b/libraries/base/include/HsBase.h @@ -529,10 +529,10 @@ extern void __hscore_set_saved_termios(int fd, void* ts); #ifdef __MINGW32__ INLINE int __hscore_open(wchar_t *file, int how, mode_t mode) { if ((how & O_WRONLY) || (how & O_RDWR) || (how & O_APPEND)) - return _wsopen(file,how | _O_NOINHERIT,_SH_DENYRW,mode); + return _wsopen(file,how | _O_NOINHERIT,_SH_DENYNO,mode); // _O_NOINHERIT: see #2650 else - return _wsopen(file,how | _O_NOINHERIT,_SH_DENYWR,mode); + return _wsopen(file,how | _O_NOINHERIT,_SH_DENYNO,mode); // _O_NOINHERIT: see #2650 } #else diff --git a/libraries/base/tests/IO/countReaders001.stdout-mingw32 b/libraries/base/tests/IO/countReaders001.stdout-mingw32 deleted file mode 100644 index bf80d9dc12..0000000000 --- a/libraries/base/tests/IO/countReaders001.stdout-mingw32 +++ /dev/null @@ -1 +0,0 @@ -Left countReaders001.txt: openFile: permission denied (Permission denied) diff --git a/libraries/base/tests/IO/openFile005.stdout-mingw32 b/libraries/base/tests/IO/openFile005.stdout-mingw32 deleted file mode 100644 index bf227989a9..0000000000 --- a/libraries/base/tests/IO/openFile005.stdout-mingw32 +++ /dev/null @@ -1,12 +0,0 @@ -two writes (should fail) -Left openFile005.out1: openFile: permission denied (Permission denied) -write and an append (should fail) -Left openFile005.out1: openFile: permission denied (Permission denied) -read/write and a write (should fail) -Left openFile005.out1: openFile: permission denied (Permission denied) -read and a read/write (should fail) -Left openFile005.out1: openFile: permission denied (Permission denied) -write and a read (should fail) -Left openFile005.out1: openFile: permission denied (Permission denied) -two writes, different files (silly, but should succeed) -two reads, should succeed diff --git a/libraries/base/tests/IO/openFile007.stdout-mingw32 b/libraries/base/tests/IO/openFile007.stdout-mingw32 deleted file mode 100644 index 26f0afe2b2..0000000000 --- a/libraries/base/tests/IO/openFile007.stdout-mingw32 +++ /dev/null @@ -1,2 +0,0 @@ -Left openFile007.out: openFile: permission denied (Permission denied) -hello, world diff --git a/libraries/base/tests/IO/readFile001.stdout-mingw32 b/libraries/base/tests/IO/readFile001.stdout-mingw32 deleted file mode 100644 index d086f3a209..0000000000 --- a/libraries/base/tests/IO/readFile001.stdout-mingw32 +++ /dev/null @@ -1,30 +0,0 @@ -Left readFile001.out: openFile: permission denied (Permission denied) --- !!! readFile test - -import System.IO -import System.IO.Error - -source = "readFile001.hs" -filename = "readFile001.out" - -main = do - s <- readFile source - h <- openFile filename WriteMode - hPutStrLn h s - hClose h - s <- readFile filename - - -- This open should fail, because the readFile hasn't been forced - -- and the file is therefore still locked. - tryIOError (openFile filename WriteMode) >>= print - - putStrLn s - - -- should be able to open it for writing now, because we've forced the - -- whole file. - h <- openFile filename WriteMode - - print h - - -{handle: readFile001.out} |