Commit 80940e24 authored by ttuegel's avatar ttuegel
Browse files

Move D.Client.Compat.Environment into Cabal

parent 2af1c1d5
{-# 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 */
{-# 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 */
......@@ -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 )
......
......@@ -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
......
......@@ -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 (..))
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment