directory 1.2.3.1 → 1.2.4.0

raw patch · 12 files changed

+192/−58 lines, 12 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• System/Directory.hs +16/−3
• System/Directory/Internal.hsc +3/−7
• System/Directory/Internal/C_utimensat.hsc +1/−1
• System/Directory/Internal/Config.hs +14/−0
• System/Directory/Internal/Posix.hsc +1/−1
• changelog.md +12/−0
• configure +30/−0
• configure.ac +20/−0
• directory.cabal +2/−1
• tests/CreateDirectoryIfMissing001.hs +22/−15
• tests/Util.hs +70/−29
• tests/util.inl +1/−1

@@ -53,9 +53,11 @@     , makeRelativeToCurrentDirectory     , findExecutable     , findExecutables+    , findExecutablesInDirectories     , findFile     , findFiles     , findFilesWith+    , exeExtension      -- * Existence tests     , doesFileExist@@ -905,6 +907,10 @@ -- | Given a file name, searches for the file and returns a list of all -- occurences that are executable. --+-- On Windows, this only returns the first ocurrence, if any.  It uses the+-- @SearchPath@ from the Win32 API, so the caveats noted in 'findExecutable'+-- apply here as well.+-- -- @since 1.2.2.0 findExecutables :: String -> IO [FilePath] findExecutables binary = do@@ -913,14 +919,21 @@     return $ maybeToList file #else     path <- getEnv "PATH"-    findFilesWith isExecutable (splitSearchPath path) (binary <.> exeExtension)+    findExecutablesInDirectories (splitSearchPath path) binary+#endif++-- | Given a file name, searches for the file on the given paths and returns a+-- list of all occurences that are executable.+--+-- @since 1.2.4.0+findExecutablesInDirectories :: [FilePath] -> String -> IO [FilePath]+findExecutablesInDirectories path binary =+    findFilesWith isExecutable path (binary <.> exeExtension)   where isExecutable file = do             perms <- getPermissions file             return $ executable perms-#endif  -- | Search through the given set of directories for the given file.--- Used by 'findExecutable' on non-windows platforms. findFile :: [FilePath] -> String -> IO (Maybe FilePath) findFile path fileName = do     files <- findFiles path fileName

@@ -1,7 +1,7 @@ #include <HsDirectoryConfig.h>  module System.Directory.Internal-  ( module System.Directory.Internal+  ( module System.Directory.Internal.Config  #ifdef HAVE_UTIMENSAT   , module System.Directory.Internal.C_utimensat@@ -13,7 +13,8 @@   , module System.Directory.Internal.Posix #endif -) where+  ) where+import System.Directory.Internal.Config  #ifdef HAVE_UTIMENSAT import System.Directory.Internal.C_utimensat@@ -24,8 +25,3 @@ #else import System.Directory.Internal.Posix #endif---- | Filename extension for executable files (including the dot if any)---   (usually @\"\"@ on POSIX systems and @\".exe\"@ on Windows or OS\/2).-exeExtension :: String-exeExtension = (#const_str EXE_EXTENSION)

@@ -42,7 +42,7 @@     (sec,  frac)  = if frac' < 0 then (sec' - 1, frac' + 1) else (sec', frac')     (sec', frac') = properFraction (toRational t) -foreign import ccall unsafe "utimensat" c_utimensat+foreign import ccall "utimensat" c_utimensat   :: CInt -> CString -> Ptr CTimeSpec -> CInt -> IO CInt  #endif

@@ -0,0 +1,14 @@+{-# LANGUAGE CPP #-}+#include <HsDirectoryConfig.h>+module System.Directory.Internal.Config where++-- | Filename extension for executable files (including the dot if any)+--   (usually @\"\"@ on POSIX systems and @\".exe\"@ on Windows or OS\/2).+--+-- @since 1.2.4.0+exeExtension :: String+exeExtension = EXE_EXTENSION+-- We avoid using #const_str from hsc because it breaks cross-compilation+-- builds, so we use this ugly workaround where we simply paste the C string+-- literal directly in here.  This will probably break if the EXE_EXTENSION+-- contains strange characters, but hopefully no sane OS would ever do that.

@@ -25,7 +25,7 @@ c_PATH_MAX = Nothing #endif -foreign import ccall unsafe "realpath" c_realpath+foreign import ccall "realpath" c_realpath   :: CString -> CString -> IO CString  withRealpath :: CString -> (CString -> IO a) -> IO a

@@ -1,6 +1,18 @@ Changelog for the [`directory`][1] package ========================================== +## 1.2.4.0 (September 2015)++  * Work around lack of `#const_str` when cross-compiling+    ([haskell-cafe](F7D))++  * Add `findExecutablesInDirectories`+    ([#33](https://github.com/haskell/directory/pull/33))++  * Add `exeExtension`++[F7D]: https://mail.haskell.org/pipermail/haskell-cafe/2015-August/120892.html+ ## 1.2.3.1 (August 2015)    * Restore support for Safe Haskell with base < 4.8

@@ -675,7 +675,9 @@ ac_subst_files='' ac_user_opts=' enable_option_checking+with_gcc with_cc+with_compiler '       ac_precious_vars='build_alias host_alias@@ -1295,6 +1297,7 @@   --with-PACKAGE[=ARG]    use PACKAGE [ARG=yes]   --without-PACKAGE       do not use PACKAGE (same as --with-PACKAGE=no) C compiler+GHC compiler  Some influential environment variables:   CC          C compiler command@@ -2096,10 +2099,37 @@ ac_config_headers="$ac_config_headers include/HsDirectoryConfig.h"  +# Autoconf chokes on spaces, but we may receive a path from Cabal containing+# spaces.  In that case, we just ignore Cabal's suggestion.+set_with_gcc() {+    case $withval in+        *" "*)+            { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: --with-gcc ignored due to presence of spaces" >&5+$as_echo "$as_me: WARNING: --with-gcc ignored due to presence of spaces" >&2;};;+        *)+            CC=$withval+    esac+} +# inherit the C compiler from Cabal but allow it to be overridden by --with-cc+# because Cabal puts its own flags at the end++# Check whether --with-gcc was given.+if test "${with_gcc+set}" = set; then :+  withval=$with_gcc; set_with_gcc+fi++ # Check whether --with-cc was given. if test "${with_cc+set}" = set; then :   withval=$with_cc; CC=$withval+fi++# avoid warnings when run via Cabal++# Check whether --with-compiler was given.+if test "${with_compiler+set}" = set; then :+  withval=$with_compiler; fi  ac_ext=c

@@ -5,9 +5,29 @@  AC_CONFIG_HEADERS([include/HsDirectoryConfig.h]) +# Autoconf chokes on spaces, but we may receive a path from Cabal containing+# spaces.  In that case, we just ignore Cabal's suggestion.+set_with_gcc() {+    case $withval in+        *" "*)+            AC_MSG_WARN([--with-gcc ignored due to presence of spaces]);;+        *)+            CC=$withval+    esac+}++# inherit the C compiler from Cabal but allow it to be overridden by --with-cc+# because Cabal puts its own flags at the end+AC_ARG_WITH([gcc],+            [C compiler],+            [set_with_gcc]) AC_ARG_WITH([cc],             [C compiler],             [CC=$withval])+# avoid warnings when run via Cabal+AC_ARG_WITH([compiler],+            [GHC compiler],+            []) AC_PROG_CC()  # check for specific header (.h) files that we are interested in

@@ -1,5 +1,5 @@ name:           directory-version:        1.2.3.1+version:        1.2.4.0 -- NOTE: Don't forget to update ./changelog.md license:        BSD3 license-file:   LICENSE@@ -45,6 +45,7 @@         System.Directory     other-modules:         System.Directory.Internal+        System.Directory.Internal.Config         System.Directory.Internal.C_utimensat         System.Directory.Internal.Posix         System.Directory.Internal.Windows

@@ -5,8 +5,8 @@ import Control.Concurrent (forkIO, newEmptyMVar, putMVar, takeMVar) import qualified Control.Exception as E import Control.Monad (replicateM_)+import Data.Monoid ((<>)) import System.FilePath ((</>), addTrailingPathSeparator)-import System.IO (hFlush, stdout) import System.IO.Error(isAlreadyExistsError, isDoesNotExistError,                        isPermissionError) #ifndef mingw32_HOST_OS@@ -30,12 +30,11 @@    createDirectoryIfMissing True  (addTrailingPathSeparator testdir_a) -  putStrLn "testing for race conditions ..."-  hFlush stdout+  T(inform) "testing for race conditions ..."   raceCheck1+  T(inform) "testing for race conditions ..."   raceCheck2-  putStrLn "done."-  hFlush stdout+  T(inform) "done."   cleanup    writeFile testdir testdir@@ -52,31 +51,36 @@    where -    testdir = "createDirectoryIfMissing001.d"+    testname = "CreateDirectoryIfMissing001"++    testdir = testname <> ".d"     testdir_a = testdir </> "a" +    numRepeats = T.readArg _t testname "num-repeats" 10000+    numThreads = T.readArg _t testname "num-threads" 4+     -- Look for race conditions (bug #2808 on GHC Trac).  This fails with     -- +RTS -N2 and directory 1.0.0.2.     raceCheck1 = do       m <- newEmptyMVar       _ <- forkIO $ do-        replicateM_ 10000 create+        replicateM_ numRepeats create         putMVar m ()       _ <- forkIO $ do-        replicateM_ 10000 cleanup+        replicateM_ numRepeats cleanup         putMVar m ()       replicateM_ 2 (takeMVar m)      -- This test fails on Windows (see bug #2924 on GHC Trac):     raceCheck2 = do       m <- newEmptyMVar-      replicateM_ 4 $+      replicateM_ numThreads $         forkIO $ do-          replicateM_ 10000 $ do+          replicateM_ numRepeats $ do             create             cleanup           putMVar m ()-      replicateM_ 4 (takeMVar m)+      replicateM_ numThreads (takeMVar m)      -- createDirectoryIfMissing is allowed to fail with isDoesNotExistError if     -- another process/thread removes one of the directories during the process@@ -86,7 +90,7 @@     -- (see bug #2924 on GHC Trac)     create =       createDirectoryIfMissing True testdir_a `E.catch` \ e ->-      if isDoesNotExistError e || isPermissionError e+      if isDoesNotExistError e || isPermissionError e || isInappropriateTypeError e       then return ()       else ioError e @@ -98,7 +102,10 @@ #ifdef mingw32_HOST_OS     isNotADirectoryError = isAlreadyExistsError #else-    isNotADirectoryError e = case ioeGetErrorType e of-      InappropriateType -> True-      _                 -> False+    isNotADirectoryError = isInappropriateTypeError #endif++    isInappropriateTypeError = isInappropriateTypeErrorType . ioeGetErrorType++    isInappropriateTypeErrorType InappropriateType = True+    isInappropriateTypeErrorType _                 = False

@@ -3,10 +3,14 @@ import Prelude (Eq(..), Num(..), Ord(..), RealFrac(..), Show(..),                 Bool(..), Double, Either(..), Int, Integer, Maybe(..), String,                 ($), (.), otherwise)+import Data.Char (toLower)+import Data.Functor ((<$>)) import Data.IORef (IORef, newIORef, readIORef, writeIORef)-import Data.List (elem, intercalate)+import Data.List (drop, elem, intercalate, lookup, reverse, span)+import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) import Data.Time.Clock (NominalDiffTime, UTCTime, diffUTCTime)+import Control.Arrow (second) import Control.Concurrent (forkIO, killThread) import Control.Concurrent.MVar (newEmptyMVar, putMVar, readMVar) import Control.Exception (SomeException, bracket_, catch,@@ -14,12 +18,14 @@ import Control.Monad (Monad(..), unless, when) import System.Directory (createDirectory, makeAbsolute,                          removeDirectoryRecursive, withCurrentDirectory)+import System.Environment (getArgs) import System.Exit (exitFailure) import System.FilePath (FilePath, normalise) import System.IO (IO, hFlush, hPutStrLn, putStrLn, stderr, stdout) import System.IO.Error (IOError, isDoesNotExistError,                         ioError, tryIOError, userError) import System.Timeout (timeout)+import Text.Read (Read, reads)  modifyIORef' :: IORef a -> (a -> a) -> IO () modifyIORef' r f = do@@ -45,35 +51,32 @@   { testCounter  :: IORef Int   , testSilent   :: Bool   , testKeepDirs :: Bool-  }--defaultTestEnv :: IORef Int -> TestEnv-defaultTestEnv counter =-  TestEnv-  { testCounter  = counter-  , testSilent   = False-  , testKeepDirs = False+  , testArgs     :: [(String, String)]   } -showSuccess :: TestEnv -> [String] -> IO ()-showSuccess TestEnv{testSilent = True}  _   = return ()-showSuccess TestEnv{testSilent = False} msg = do+printInfo :: TestEnv -> [String] -> IO ()+printInfo TestEnv{testSilent = True}  _   = return ()+printInfo TestEnv{testSilent = False} msg = do   putStrLn (intercalate ": " msg)   hFlush stdout -showFailure :: TestEnv -> [String] -> IO ()-showFailure TestEnv{testCounter = n} msg = do-  modifyIORef' n (+ 1)+printErr :: [String] -> IO ()+printErr msg = do   hPutStrLn stderr ("*** " <> intercalate ": " msg)   hFlush stderr +printFailure :: TestEnv -> [String] -> IO ()+printFailure TestEnv{testCounter = n} msg = do+  modifyIORef' n (+ 1)+  printErr msg+ check :: TestEnv -> Bool -> [String] -> [String] -> [String] -> IO ()-check t True  prefix msg _   = showSuccess t (prefix <> msg)-check t False prefix _   msg = showFailure t (prefix <> msg)+check t True  prefix msg _   = printInfo t (prefix <> msg)+check t False prefix _   msg = printFailure t (prefix <> msg)  checkEither :: TestEnv -> [String] -> Either [String] [String] -> IO ()-checkEither t prefix (Right msg) = showSuccess t (prefix <> msg)-checkEither t prefix (Left  msg) = showFailure t (prefix <> msg)+checkEither t prefix (Right msg) = printInfo t (prefix <> msg)+checkEither t prefix (Left  msg) = printFailure t (prefix <> msg)  showContext :: Show a => String -> Integer -> a -> String showContext file line context =@@ -82,6 +85,10 @@     "()" -> ""     s    -> ":" <> s +inform :: TestEnv -> String -> Integer -> String -> IO ()+inform t file line msg =+  printInfo t [showContext file line (), msg]+ expect :: Show a => TestEnv -> String -> Integer -> a -> Bool -> IO () expect t file line context x =   check t x@@ -124,14 +131,15 @@             | otherwise -> Left  ["got wrong exception: ", show e]     Right _             -> Left  ["did not throw an exception"] -withNewDirectory :: FilePath -> IO a -> IO a-withNewDirectory dir action = do+withNewDirectory :: Bool -> FilePath -> IO a -> IO a+withNewDirectory keep dir action = do   dir' <- makeAbsolute dir-  bracket_ (createDirectory          dir')-           (removeDirectoryRecursive dir') action+  bracket_ (createDirectory dir') (cleanup dir') action+  where cleanup dir' | keep      = return ()+                     | otherwise = removeDirectoryRecursive dir' -isolateWorkingDirectory :: FilePath -> IO a -> IO a-isolateWorkingDirectory dir action = do+isolateWorkingDirectory :: Bool -> FilePath -> IO a -> IO a+isolateWorkingDirectory keep dir action = do   when (normalise dir `elem` [".", "./"]) $     ioError (userError ("isolateWorkingDirectory cannot be used " <>                         "with current directory"))@@ -139,7 +147,7 @@   removeDirectoryRecursive dir' `catch` \ e ->     unless (isDoesNotExistError e) $       ioError e-  withNewDirectory dir' $+  withNewDirectory keep dir' $     withCurrentDirectory dir' $       action @@ -151,13 +159,46 @@     Right () -> return ()  isolatedRun :: TestEnv -> String -> (TestEnv -> IO ()) -> IO ()-isolatedRun t name action = do-  run t name (isolateWorkingDirectory ("test-" <> name <> ".tmp") . action)+isolatedRun t@TestEnv{testKeepDirs = keep} name =+  run t name .+  (isolateWorkingDirectory keep ("dist/test-" <> name <> ".tmp") .) +tryRead :: Read a => String -> Maybe a+tryRead s =+  case reads s of+    [(x, "")] -> Just x+    _         -> Nothing++getArg :: (String -> Maybe a) -> TestEnv -> String -> String -> a -> a+getArg parse TestEnv{testArgs = args} testname name defaultValue =+  fromMaybe defaultValue (lookup (prefix <> name) args >>= parse)+  where prefix | testname == "" = ""+               | otherwise      = testname <> "."++readArg :: Read a => TestEnv -> String -> String -> a -> a+readArg = getArg tryRead++readBool :: String -> Maybe Bool+readBool s = Just $+  case toLower <$> s of+    'y' : _ -> True+    't' : _ -> True+    _       -> False++parseArgs :: [String] -> [(String, String)]+parseArgs = reverse . (second (drop 1) . span (/= '=') <$>)+ testMain :: (TestEnv -> IO ()) -> IO () testMain action = do+  args <- parseArgs <$> getArgs   counter <- newIORef 0-  action (defaultTestEnv counter)+  let t = TestEnv+          { testCounter  = counter+          , testSilent   = getArg readBool t "" "silent" False+          , testKeepDirs = getArg readBool t "" "keep-dirs" False+          , testArgs     = args+          }+  action t   n <- readIORef (counter)   unless (n == 0) $ do     putStrLn ("[" <> show n <> " failures]")

@@ -1,4 +1,4 @@-#define T(expect) (T./**/expect _t __FILE__ __LINE__)+#define T(f) (T./**/f _t __FILE__ __LINE__)  import Util (TestEnv) import qualified Util as T