diff --git a/Cabal/Distribution/Compat/Environment.hs b/Cabal/Distribution/Compat/Environment.hs index fcabf0bcd37b33906b06f6fe9f03e13d3117a924..69cde27ec6623a99111a98d8c3c1d6ba283de752 100644 --- a/Cabal/Distribution/Compat/Environment.hs +++ b/Cabal/Distribution/Compat/Environment.hs @@ -1,7 +1,9 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE ForeignFunctionInterface #-} {-# OPTIONS_HADDOCK hide #-} -module Distribution.Compat.Environment (getEnvironment, lookupEnv) +module Distribution.Compat.Environment + ( getEnvironment, lookupEnv, setEnv ) where import qualified System.Environment as System @@ -12,8 +14,16 @@ import Distribution.Compat.Exception (catchIO) #endif #ifdef mingw32_HOST_OS +import Control.Monad import qualified Data.Char as Char (toUpper) -#endif +import Foreign.C +import GHC.Windows +#else +import Foreign.C.Types +import Foreign.C.String +import Foreign.C.Error (throwErrnoIfMinus1_) +import System.Posix.Internals ( withFilePath ) +#endif /* mingw32_HOST_OS */ getEnvironment :: IO [(String, String)] #ifdef mingw32_HOST_OS @@ -34,3 +44,46 @@ getEnvironment = System.getEnvironment lookupEnv :: String -> IO (Maybe String) lookupEnv name = (Just `fmap` System.getEnv name) `catchIO` const (return Nothing) #endif /* __GLASGOW_HASKELL__ < 706 */ + +-- | @setEnv name value@ sets the specified environment variable to @value@. +-- +-- Throws `Control.Exception.IOException` if either @name@ or @value@ is the +-- empty string or contains an equals sign. +setEnv :: String -> String -> IO () +setEnv key value_ + | null value = error "Distribuiton.Compat.setEnv: empty string" + | otherwise = setEnv_ key value + where + -- NOTE: Anything that follows NUL is ignored on both POSIX and Windows. We + -- still strip it manually so that the null check above succeeds if a value + -- starts with NUL. + value = takeWhile (/= '\NUL') value_ + +setEnv_ :: String -> String -> IO () + +#ifdef mingw32_HOST_OS + +setEnv_ key value = withCWString key $ \k -> withCWString value $ \v -> do + success <- c_SetEnvironmentVariable k v + unless success (throwGetLastError "setEnv") + +# if defined(i386_HOST_ARCH) +# define WINDOWS_CCONV stdcall +# elif defined(x86_64_HOST_ARCH) +# define WINDOWS_CCONV ccall +# else +# error Unknown mingw32 arch +# endif /* i386_HOST_ARCH */ + +foreign import WINDOWS_CCONV unsafe "windows.h SetEnvironmentVariableW" + c_SetEnvironmentVariable :: LPTSTR -> LPTSTR -> IO Bool +#else +setEnv_ key value = do + withFilePath key $ \ keyP -> + withFilePath value $ \ valueP -> + throwErrnoIfMinus1_ "setenv" $ + c_setenv keyP valueP (fromIntegral (fromEnum True)) + +foreign import ccall unsafe "setenv" + c_setenv :: CString -> CString -> CInt -> IO CInt +#endif /* mingw32_HOST_OS */ diff --git a/cabal-install/Distribution/Client/Compat/Environment.hs b/cabal-install/Distribution/Client/Compat/Environment.hs deleted file mode 100644 index e6cec7c97209edf09b5a09a852301b7c9660d5b1..0000000000000000000000000000000000000000 --- a/cabal-install/Distribution/Client/Compat/Environment.hs +++ /dev/null @@ -1,75 +0,0 @@ -{-# LANGUAGE CPP, ForeignFunctionInterface #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Compat.Environment --- Copyright : (c) Simon Hengel 2012 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : cabal-devel@haskell.org --- Stability : provisional --- Portability : portable --- --- A cross-platform library for setting environment variables. --- ------------------------------------------------------------------------------ - -module Distribution.Client.Compat.Environment ( - lookupEnv, setEnv -) where - -#ifdef mingw32_HOST_OS -import GHC.Windows -import Foreign.C -import Control.Monad -#else -import Foreign.C.Types -import Foreign.C.String -import Foreign.C.Error (throwErrnoIfMinus1_) -import System.Posix.Internals ( withFilePath ) -#endif /* mingw32_HOST_OS */ - -import Distribution.Compat.Environment (lookupEnv) - --- | @setEnv name value@ sets the specified environment variable to @value@. --- --- Throws `Control.Exception.IOException` if either @name@ or @value@ is the --- empty string or contains an equals sign. -setEnv :: String -> String -> IO () -setEnv key value_ - | null value = error "Distribuiton.Compat.setEnv: empty string" - | otherwise = setEnv_ key value - where - -- NOTE: Anything that follows NUL is ignored on both POSIX and Windows. We - -- still strip it manually so that the null check above succeeds if a value - -- starts with NUL. - value = takeWhile (/= '\NUL') value_ - -setEnv_ :: String -> String -> IO () - -#ifdef mingw32_HOST_OS - -setEnv_ key value = withCWString key $ \k -> withCWString value $ \v -> do - success <- c_SetEnvironmentVariable k v - unless success (throwGetLastError "setEnv") - -# if defined(i386_HOST_ARCH) -# define WINDOWS_CCONV stdcall -# elif defined(x86_64_HOST_ARCH) -# define WINDOWS_CCONV ccall -# else -# error Unknown mingw32 arch -# endif /* i386_HOST_ARCH */ - -foreign import WINDOWS_CCONV unsafe "windows.h SetEnvironmentVariableW" - c_SetEnvironmentVariable :: LPTSTR -> LPTSTR -> IO Bool -#else -setEnv_ key value = do - withFilePath key $ \ keyP -> - withFilePath value $ \ valueP -> - throwErrnoIfMinus1_ "setenv" $ - c_setenv keyP valueP (fromIntegral (fromEnum True)) - -foreign import ccall unsafe "setenv" - c_setenv :: CString -> CString -> CInt -> IO CInt -#endif /* mingw32_HOST_OS */ diff --git a/cabal-install/Distribution/Client/Sandbox.hs b/cabal-install/Distribution/Client/Sandbox.hs index 832782ca3dfc6e3c18c7e746596639f476620891..f6770a4823203ab46c31f7e630cc60e4dc935d6b 100644 --- a/cabal-install/Distribution/Client/Sandbox.hs +++ b/cabal-install/Distribution/Client/Sandbox.hs @@ -96,7 +96,7 @@ import Distribution.Package ( Package(..) ) import Distribution.System ( Platform ) import Distribution.Text ( display ) import Distribution.Verbosity ( Verbosity, lessVerbose ) -import Distribution.Client.Compat.Environment ( lookupEnv, setEnv ) +import Distribution.Compat.Environment ( lookupEnv, setEnv ) import Distribution.Client.Compat.FilePerms ( setFileHidden ) import qualified Distribution.Client.Sandbox.Index as Index import Distribution.Simple.PackageIndex ( InstalledPackageIndex ) diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal index a4e9d2a07586c3958586dd8d2277c577ff8ad7e4..babfc0a52c5217644859c971ec3f092a73321e0f 100644 --- a/cabal-install/cabal-install.cabal +++ b/cabal-install/cabal-install.cabal @@ -119,7 +119,6 @@ executable cabal Distribution.Client.Utils.LabeledGraph Distribution.Client.World Distribution.Client.Win32SelfUpgrade - Distribution.Client.Compat.Environment Distribution.Client.Compat.ExecutablePath Distribution.Client.Compat.FilePerms Distribution.Client.Compat.Process diff --git a/cabal-install/tests/UnitTests/Distribution/Client/UserConfig.hs b/cabal-install/tests/UnitTests/Distribution/Client/UserConfig.hs index d0cf738724c40c78f773b6eb53bcf36c4c442585..4a9b900e3c26fb99189a44047601d17d290a12c1 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/UserConfig.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/UserConfig.hs @@ -14,7 +14,7 @@ import System.FilePath (takeDirectory) import Test.Tasty import Test.Tasty.HUnit -import Distribution.Client.Compat.Environment (lookupEnv, setEnv) +import Distribution.Compat.Environment (lookupEnv, setEnv) import Distribution.Client.Config import Distribution.Utils.NubList (fromNubList) import Distribution.Client.Setup (GlobalFlags (..), InstallFlags (..))