mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

Fix dirContentsRecursive, which had missed some files in deeply nested subdirectories. Could affect various parts of git-annex.

Browse source
This commit is contained in:
Joey Hess 2012-11-26 16:45:55 -04:00
parent 58f4a28f8a
commit 44a7387eba
2 changed files with 16 additions and 10 deletions
Download patch file Download diff file Expand all files Collapse all files

19
Utility/Directory.hs
View file

@ -36,23 +36,22 @@ dirContents d = map (d </>) . filter (not . dirCruft) <$> getDirectoryContents d
- and lazily. If the directory does not exist, no exception is thrown, - and lazily. If the directory does not exist, no exception is thrown,
- instead, [] is returned. -} - instead, [] is returned. -}
dirContentsRecursive :: FilePath -> IO [FilePath] dirContentsRecursive :: FilePath -> IO [FilePath]
dirContentsRecursive topdir = dirContentsRecursive' topdir [""] dirContentsRecursive topdir = dirContentsRecursive' [topdir]
dirContentsRecursive' :: FilePath -> [FilePath] -> IO [FilePath] dirContentsRecursive' :: [FilePath] -> IO [FilePath]
dirContentsRecursive' _ [] = return [] dirContentsRecursive' [] = return []
dirContentsRecursive' topdir (dir:dirs) = unsafeInterleaveIO $ do dirContentsRecursive' (dir:dirs) = unsafeInterleaveIO $ do
(files, dirs') <- collect [] [] =<< catchDefaultIO [] (dirContents (topdir </> dir)) (files, dirs') <- collect [] [] =<< catchDefaultIO [] (dirContents dir)
files' <- dirContentsRecursive' topdir (dirs' ++ dirs) files' <- dirContentsRecursive' (dirs' ++ dirs)
return (files ++ files') return (files ++ files')
where where
collect files dirs' [] = return (reverse files, reverse dirs') collect files dirs' [] = return (reverse files, reverse dirs')
collect files dirs' (entry:entries) collect files dirs' (entry:entries)
| dirCruft entry = collect files dirs' entries | dirCruft entry = collect files dirs' entries
| otherwise = do | otherwise = do
let dirEntry = dir </> entry ifM (doesDirectoryExist entry)
ifM (doesDirectoryExist $ topdir </> dirEntry) ( collect files (entry:dirs') entries
( collect files (dirEntry:dirs') entries , collect (entry:files) dirs' entries
, collect (dirEntry:files) dirs' entries
) )
{- Moves one filename to another. {- Moves one filename to another.

7
debian/changelog vendored
View file

@ -1,3 +1,10 @@
git-annex (3.20121127) UNRELEASED; urgency=low
* Fix dirContentsRecursive, which had missed some files in deeply nested
subdirectories. Could affect various parts of git-annex.
-- Joey Hess <joeyh@debian.org> Mon, 26 Nov 2012 16:45:19 -0400
git-annex (3.20121126) unstable; urgency=low git-annex (3.20121126) unstable; urgency=low
* New webdav and Amazon glacier special remotes. * New webdav and Amazon glacier special remotes.