remove absNormPathUnix again
Moving toward dropping MissingH dep. I think I've addressed the problem identified earlier in09a66f702d
. On Windows, absPathFrom "/tmp/repo/xxx" "y/bar" would be "/tmp/repo/xxx\\y/bar", which then confuses relPathDirToFile. Fixed by converting to unix (git) style paths. Also, relPathDirToFile was splitting only on \\ on windows and not / which broke the example in09a66f702d
of relPathDirToFile (absPathFrom "/tmp/repo/xxx" "y/bar") "/tmp/repo/.git/annex/objects/xxx" Now, on windows, that will yield "..\\..\\..\\.git/annex/objects/xxx" which once converted to unix style paths is what we want.
This commit is contained in:
parent
e40d9a1b12
commit
18b9a4b802
2 changed files with 9 additions and 22 deletions
|
@ -172,7 +172,7 @@ gitAnnexLocation' key r config crippled symlinkssupported checker gitdir
|
||||||
gitAnnexLink :: FilePath -> Key -> Git.Repo -> GitConfig -> IO FilePath
|
gitAnnexLink :: FilePath -> Key -> Git.Repo -> GitConfig -> IO FilePath
|
||||||
gitAnnexLink file key r config = do
|
gitAnnexLink file key r config = do
|
||||||
currdir <- getCurrentDirectory
|
currdir <- getCurrentDirectory
|
||||||
let absfile = fromMaybe whoops $ absNormPathUnix currdir file
|
let absfile = absNormPathUnix currdir file
|
||||||
let gitdir = getgitdir currdir
|
let gitdir = getgitdir currdir
|
||||||
loc <- gitAnnexLocation' key r config False False (\_ -> return True) gitdir
|
loc <- gitAnnexLocation' key r config False False (\_ -> return True) gitdir
|
||||||
toInternalGitPath <$> relPathDirToFile (parentDir absfile) loc
|
toInternalGitPath <$> relPathDirToFile (parentDir absfile) loc
|
||||||
|
@ -182,10 +182,10 @@ gitAnnexLink file key r config = do
|
||||||
- supporting symlinks; generate link target that will
|
- supporting symlinks; generate link target that will
|
||||||
- work portably. -}
|
- work portably. -}
|
||||||
| not (coreSymlinks config) && needsSubmoduleFixup r =
|
| not (coreSymlinks config) && needsSubmoduleFixup r =
|
||||||
fromMaybe whoops $ absNormPathUnix currdir $
|
absNormPathUnix currdir $ Git.repoPath r </> ".git"
|
||||||
Git.repoPath r </> ".git"
|
|
||||||
| otherwise = Git.localGitDir r
|
| otherwise = Git.localGitDir r
|
||||||
whoops = error $ "unable to normalize " ++ file
|
absNormPathUnix d p = toInternalGitPath $
|
||||||
|
absPathFrom (toInternalGitPath d) (toInternalGitPath p)
|
||||||
|
|
||||||
{- Calculates a symlink target as would be used in a typical git
|
{- Calculates a symlink target as would be used in a typical git
|
||||||
- repository, with .git in the top of the work tree. -}
|
- repository, with .git in the top of the work tree. -}
|
||||||
|
|
|
@ -25,7 +25,6 @@ import System.Posix.Files
|
||||||
import Utility.Exception
|
import Utility.Exception
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
import qualified "MissingH" System.Path as MissingH
|
|
||||||
import Utility.Monad
|
import Utility.Monad
|
||||||
import Utility.UserInfo
|
import Utility.UserInfo
|
||||||
import Utility.Directory
|
import Utility.Directory
|
||||||
|
@ -68,18 +67,6 @@ simplifyPath path = dropTrailingPathSeparator $
|
||||||
absPathFrom :: FilePath -> FilePath -> FilePath
|
absPathFrom :: FilePath -> FilePath -> FilePath
|
||||||
absPathFrom dir path = simplifyPath (combine dir path)
|
absPathFrom dir path = simplifyPath (combine dir path)
|
||||||
|
|
||||||
{- On Windows, this converts the paths to unix-style, in order to run
|
|
||||||
- MissingH's absNormPath on them. -}
|
|
||||||
absNormPathUnix :: FilePath -> FilePath -> Maybe FilePath
|
|
||||||
#ifndef mingw32_HOST_OS
|
|
||||||
absNormPathUnix dir path = MissingH.absNormPath dir path
|
|
||||||
#else
|
|
||||||
absNormPathUnix dir path = todos <$> MissingH.absNormPath (fromdos dir) (fromdos path)
|
|
||||||
where
|
|
||||||
fromdos = replace "\\" "/"
|
|
||||||
todos = replace "/" "\\"
|
|
||||||
#endif
|
|
||||||
|
|
||||||
{- takeDirectory "foo/bar/" is "foo/bar". This instead yields "foo" -}
|
{- takeDirectory "foo/bar/" is "foo/bar". This instead yields "foo" -}
|
||||||
parentDir :: FilePath -> FilePath
|
parentDir :: FilePath -> FilePath
|
||||||
parentDir = takeDirectory . dropTrailingPathSeparator
|
parentDir = takeDirectory . dropTrailingPathSeparator
|
||||||
|
@ -149,13 +136,13 @@ relPathDirToFile from to = relPathDirToFileAbs <$> absPath from <*> absPath to
|
||||||
relPathDirToFileAbs :: FilePath -> FilePath -> FilePath
|
relPathDirToFileAbs :: FilePath -> FilePath -> FilePath
|
||||||
relPathDirToFileAbs from to
|
relPathDirToFileAbs from to
|
||||||
| takeDrive from /= takeDrive to = to
|
| takeDrive from /= takeDrive to = to
|
||||||
| otherwise = intercalate s $ dotdots ++ uncommon
|
| otherwise = joinPath $ dotdots ++ uncommon
|
||||||
where
|
where
|
||||||
s = [pathSeparator]
|
pfrom = sp from
|
||||||
pfrom = split s from
|
pto = sp to
|
||||||
pto = split s to
|
sp = dropTrailingPathSeparator . splitPath
|
||||||
common = map fst $ takeWhile same $ zip pfrom pto
|
common = map fst $ takeWhile same $ zip pfrom pto
|
||||||
same (c,d) = c == d
|
same (c,d) = c = d
|
||||||
uncommon = drop numcommon pto
|
uncommon = drop numcommon pto
|
||||||
dotdots = replicate (length pfrom - numcommon) ".."
|
dotdots = replicate (length pfrom - numcommon) ".."
|
||||||
numcommon = length common
|
numcommon = length common
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue