[commit: packages/directory] master: Improve support for long paths on Windows (f77655a)
git at git.haskell.org
git at git.haskell.org
Mon Apr 17 21:35:40 UTC 2017
Repository : ssh://git@git.haskell.org/directory
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/f77655a2e17c6f7076c7cf9d7de83f5b7f585b63/directory
>---------------------------------------------------------------
commit f77655a2e17c6f7076c7cf9d7de83f5b7f585b63
Author: Phil Ruffwind <rf at rufflewind.com>
Date: Sun Mar 5 06:03:15 2017 -0500
Improve support for long paths on Windows
It's still incomplete. The main problem seems to be functions that use
the Windows POSIX interface (c_stat).
Testing may be difficult since the file system itself may not support
long paths (e.g. FAT).
Note that if setCurrentDirectory receives \\?\ then getCurrentDirectory
will return the same. This can break other things if they didn't expect
\\?\, so we will try to strip the prefix if possible.
>---------------------------------------------------------------
f77655a2e17c6f7076c7cf9d7de83f5b7f585b63
System/Directory.hs | 44 +++++++++++++++++++++++------------
System/Directory/Internal/Windows.hsc | 11 +++++----
changelog.md | 10 ++++++++
3 files changed, 46 insertions(+), 19 deletions(-)
diff --git a/System/Directory.hs b/System/Directory.hs
index 0f32863..ec5a656 100644
--- a/System/Directory.hs
+++ b/System/Directory.hs
@@ -376,7 +376,8 @@ The path refers to an existing non-directory object.
createDirectory :: FilePath -> IO ()
createDirectory path = do
#ifdef mingw32_HOST_OS
- Win32.createDirectory path Nothing
+ (`ioeSetFileName` path) `modifyIOError` do
+ Win32.createDirectory (toExtendedLengthPath path) Nothing
#else
Posix.createDirectory path 0o777
#endif
@@ -505,7 +506,8 @@ The operand refers to an existing non-directory object.
removeDirectory :: FilePath -> IO ()
removeDirectory path =
#ifdef mingw32_HOST_OS
- Win32.removeDirectory path
+ (`ioeSetFileName` path) `modifyIOError` do
+ Win32.removeDirectory (toExtendedLengthPath path)
#else
Posix.removeDirectory path
#endif
@@ -650,7 +652,8 @@ The operand refers to an existing directory.
removeFile :: FilePath -> IO ()
removeFile path =
#ifdef mingw32_HOST_OS
- Win32.deleteFile path
+ (`ioeSetFileName` path) `modifyIOError` do
+ Win32.deleteFile (toExtendedLengthPath path)
#else
Posix.removeLink path
#endif
@@ -836,7 +839,10 @@ renamePath :: FilePath -- ^ Old path
-> IO ()
renamePath opath npath = (`ioeAddLocation` "renamePath") `modifyIOError` do
#ifdef mingw32_HOST_OS
- Win32.moveFileEx opath npath Win32.mOVEFILE_REPLACE_EXISTING
+ (`ioeSetFileName` opath) `modifyIOError` do
+ Win32.moveFileEx (toExtendedLengthPath opath)
+ (toExtendedLengthPath npath)
+ Win32.mOVEFILE_REPLACE_EXISTING
#else
Posix.rename opath npath
#endif
@@ -956,7 +962,10 @@ copyFileWithMetadata src dst =
(`ioeAddLocation` "copyFileWithMetadata") `modifyIOError` doCopy
where
#ifdef mingw32_HOST_OS
- doCopy = Win32.copyFile src dst False
+ doCopy = (`ioeSetFileName` src) `modifyIOError` do
+ Win32.copyFile (toExtendedLengthPath src)
+ (toExtendedLengthPath dst)
+ False
#else
doCopy = do
st <- Posix.getFileStatus src
@@ -1074,7 +1083,8 @@ canonicalizePath = \ path ->
transform = attemptRealpath getFinalPathName
simplify path =
- Win32.getFullPathName path
+ (fromExtendedLengthPath <$>
+ Win32.getFullPathName (toExtendedLengthPath path))
`catchIOError` \ _ ->
return path
#else
@@ -1381,7 +1391,7 @@ getDirectoryContents path =
else loop (acc . (e:))
#else
bracket
- (Win32.findFirstFile (path </> "*"))
+ (Win32.findFirstFile (toExtendedLengthPath (path </> "*")))
(\(h,_) -> Win32.findClose h)
(\(h,fdat) -> loop h fdat [])
where
@@ -1469,7 +1479,7 @@ getCurrentDirectory =
getCwd
where
#ifdef mingw32_HOST_OS
- getCwd = Win32.getCurrentDirectory
+ getCwd = fromExtendedLengthPath <$> Win32.getCurrentDirectory
#else
getCwd = Posix.getWorkingDirectory
#endif
@@ -1508,11 +1518,12 @@ getCurrentDirectory =
-- @[ENOTDIR]@
--
setCurrentDirectory :: FilePath -> IO ()
-setCurrentDirectory =
+setCurrentDirectory path = do
#ifdef mingw32_HOST_OS
- Win32.setCurrentDirectory
+ (`ioeSetFileName` path) `modifyIOError` do
+ Win32.setCurrentDirectory (toExtendedLengthPath path)
#else
- Posix.changeWorkingDirectory
+ Posix.changeWorkingDirectory path
#endif
-- | Run an 'IO' action with the given working directory and restore the
@@ -1688,9 +1699,10 @@ removeDirectoryLink path =
-- @since 1.3.0.0
pathIsSymbolicLink :: FilePath -> IO Bool
pathIsSymbolicLink path =
- (`ioeAddLocation` "pathIsSymbolicLink") `modifyIOError` do
+ ((`ioeAddLocation` "pathIsSymbolicLink") .
+ (`ioeSetFileName` path)) `modifyIOError` do
#ifdef mingw32_HOST_OS
- isReparsePoint <$> Win32.getFileAttributes path
+ isReparsePoint <$> Win32.getFileAttributes (toExtendedLengthPath path)
where
isReparsePoint attr = attr .&. win32_fILE_ATTRIBUTE_REPARSE_POINT /= 0
#else
@@ -1726,8 +1738,10 @@ getSymbolicLinkTarget path =
#ifdef mingw32_HOST_OS
-- | Open the handle of an existing file or directory.
openFileHandle :: String -> Win32.AccessMode -> IO Win32.HANDLE
-openFileHandle path mode = Win32.createFile path mode share Nothing
- Win32.oPEN_EXISTING flags Nothing
+openFileHandle path mode =
+ (`ioeSetFileName` path) `modifyIOError` do
+ Win32.createFile (toExtendedLengthPath path) mode share Nothing
+ Win32.oPEN_EXISTING flags Nothing
where share = win32_fILE_SHARE_DELETE
.|. Win32.fILE_SHARE_READ
.|. Win32.fILE_SHARE_WRITE
diff --git a/System/Directory/Internal/Windows.hsc b/System/Directory/Internal/Windows.hsc
index b46e8f8..98dc6d1 100644
--- a/System/Directory/Internal/Windows.hsc
+++ b/System/Directory/Internal/Windows.hsc
@@ -407,10 +407,13 @@ foreign import WINAPI unsafe "windows.h CreateSymbolicLinkW"
where unsupportedErrorMsg = "Not supported on Windows XP or older"
#endif
-createSymbolicLink :: Bool -> String -> String -> IO ()
-createSymbolicLink isDir target link = do
- -- toExtendedLengthPath ensures the target gets normalised properly
- win32_createSymbolicLink link (normaliseSeparators target) isDir
+createSymbolicLink :: Bool -> FilePath -> FilePath -> IO ()
+createSymbolicLink isDir target link =
+ (`ioeSetFileName` link) `modifyIOError` do
+ -- normaliseSeparators ensures the target gets normalised properly
+ win32_createSymbolicLink (toExtendedLengthPath link)
+ (normaliseSeparators target)
+ isDir
foreign import ccall unsafe "_wchmod"
c_wchmod :: CWString -> CMode -> IO CInt
diff --git a/changelog.md b/changelog.md
index f528faf..30ba3c7 100644
--- a/changelog.md
+++ b/changelog.md
@@ -6,6 +6,16 @@ Changelog for the [`directory`][1] package
* Fix a bug where `createFileLink` and `createDirectoryLink` failed to
handle `..` in absolute paths.
+ * Improve support (partially) for paths longer than 260 characters on
+ Windows. To achieve this, many functions will now automatically prepend
+ `\\?\` before calling the Windows API. Side effects of this change:
+ * After calling `setCurrentDirectory`, calls to the Windows API function
+ `GetCurrentDirectory` will return a path with the `\\?\` prefix. The
+ Haskell function `getCurrentDirectory` mitigates this problem by
+ automatically stripping the prefix.
+ * The `\\?\` prefix may show up in the error messages of the affected
+ functions.
+
## 1.3.1.0 (March 2017)
* `findFile` (and similar functions): when an absolute path is given, the
More information about the ghc-commits
mailing list