Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP

Comparing changes

Choose two branches to see what’s changed or to start a new pull request. If you need to, you can also compare across forks.

Open a pull request

Create a new pull request by comparing changes across two branches. If you need to, you can also compare across forks.
base fork: 23Skidoo/cabal
...
head fork: 23Skidoo/cabal
  • 3 commits
  • 3 files changed
  • 0 commit comments
  • 2 contributors
Commits on Nov 17, 2012
@23Skidoo Add a cross-platform setenv implementation.
This is a simplified version of Simon Hengel's patch for the 'base' library [1]
(without unsetEnv and the unix dependency). Tested on Windows and Linux.

[1] http://thread.gmane.org/gmane.comp.lang.haskell.libraries/18001
c70913b
@23Skidoo Make sandbox commands temporarily add .cabal-sandbox/bin to $PATH.
Fixes #1120.
7dc0a10
Commits on Nov 18, 2012
@tibbe tibbe Merge branch 'sandbox-setenv' of https://github.com/23Skidoo/cabal 001dbc8
View
57 cabal-install/Distribution/Client/Sandbox.hs
@@ -46,18 +46,24 @@ import Distribution.Simple.Setup ( Flag(..), toFlag
, BuildFlags(..), HaddockFlags(..)
, buildCommand, fromFlagOrDefault )
import Distribution.Simple.Utils ( die, debug, notice, info
+ , intercalate
, createDirectoryIfMissingVerbose )
import Distribution.Verbosity ( Verbosity, lessVerbose )
+import Distribution.Compat.SetEnv ( setEnv )
import qualified Distribution.Client.Index as Index
import qualified Distribution.Simple.Register as Register
+import Control.Exception ( bracket_ )
import Control.Monad ( unless, when )
import Data.Monoid ( mappend, mempty )
+import Data.List ( delete )
import System.Directory ( canonicalizePath
, doesDirectoryExist
, getCurrentDirectory
, removeDirectoryRecursive
, removeFile )
-import System.FilePath ( (</>) )
+import System.Environment ( getEnv )
+import System.FilePath ( (</>), getSearchPath
+ , searchPathSeparator )
-- | Load the default package environment file. In addition to a
@@ -85,6 +91,29 @@ tryGetIndexFilePath pkgEnv = do
_ -> die $ "Distribution.Client.Sandbox.tryGetIndexFilePath: " ++
"too many local repos found"
+-- | Temporarily add $SANDBOX_DIR/bin to $PATH.
+withSandboxBinDirOnSearchPath :: FilePath -> IO a -> IO a
+withSandboxBinDirOnSearchPath sandboxDir = bracket_ addBinDir rmBinDir
+ where
+ -- TODO: Instead of modifying the global process state, it'd be better to
+ -- set the environment individually for each subprocess invocation. This
+ -- will have to wait until the Shell monad is implemented; without it the
+ -- required changes are too intrusive.
+ addBinDir :: IO ()
+ addBinDir = do
+ oldPath <- getEnv "PATH"
+ let newPath = sandboxBin ++ (searchPathSeparator:oldPath)
+ setEnv "PATH" newPath
+
+ rmBinDir :: IO ()
+ rmBinDir = do
+ oldPath <- getSearchPath
+ let newPath = intercalate [searchPathSeparator]
+ (delete sandboxBin oldPath)
+ setEnv "PATH" newPath
+
+ sandboxBin = sandboxDir </> "bin"
+
-- | Initialise a package DB for this compiler if it doesn't exist.
initPackageDBIfNeeded :: Verbosity -> ConfigFlags
-> Compiler -> ProgramConfiguration
@@ -177,15 +206,16 @@ sandboxConfigure verbosity
let configFlags'' = setPackageDB sandboxDir comp configFlags'
initPackageDBIfNeeded verbosity configFlags'' comp conf
- configure verbosity
- (configPackageDB' configFlags'') (globalRepos globalFlags')
- comp conf configFlags'' configExFlags' extraArgs
+ withSandboxBinDirOnSearchPath sandboxDir $
+ configure verbosity
+ (configPackageDB' configFlags'') (globalRepos globalFlags')
+ comp conf configFlags'' configExFlags' extraArgs
-- | Entry point for the 'cabal sandbox-build' command.
sandboxBuild :: Verbosity -> SandboxFlags -> BuildFlags -> [String] -> IO ()
sandboxBuild verbosity _sandboxFlags buildFlags' extraArgs = do
-- Check that the sandbox exists.
- _ <- tryLoadSandboxConfig verbosity
+ (sandboxDir, _) <- tryLoadSandboxConfig verbosity
let setupScriptOptions = defaultSetupScriptOptions {
useDistPref = fromFlagOrDefault
@@ -195,8 +225,10 @@ sandboxBuild verbosity _sandboxFlags buildFlags' extraArgs = do
buildFlags = buildFlags' {
buildVerbosity = toFlag verbosity
}
- setupWrapper verbosity setupScriptOptions Nothing
- (buildCommand defaultProgramConfiguration) (const buildFlags) extraArgs
+
+ withSandboxBinDirOnSearchPath sandboxDir $
+ setupWrapper verbosity setupScriptOptions Nothing
+ (buildCommand defaultProgramConfiguration) (const buildFlags) extraArgs
-- | Entry point for the 'cabal sandbox-install' command.
sandboxInstall :: Verbosity -> SandboxFlags -> ConfigFlags -> ConfigExFlags
@@ -234,11 +266,12 @@ sandboxInstall verbosity _sandboxFlags configFlags configExFlags
let configFlags'' = setPackageDB sandboxDir comp configFlags'
initPackageDBIfNeeded verbosity configFlags'' comp conf
- install verbosity
- (configPackageDB' configFlags'') (globalRepos globalFlags')
- comp conf
- globalFlags' configFlags'' configExFlags' installFlags' haddockFlags
- targets
+ withSandboxBinDirOnSearchPath sandboxDir $
+ install verbosity
+ (configPackageDB' configFlags'') (globalRepos globalFlags')
+ comp conf
+ globalFlags' configFlags'' configExFlags' installFlags' haddockFlags
+ targets
configPackageDB' :: ConfigFlags -> PackageDBStack
configPackageDB' cfg =
View
96 cabal-install/Distribution/Compat/SetEnv.hs
@@ -0,0 +1,96 @@
+{-# LANGUAGE CPP, ForeignFunctionInterface #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module : Distribution.Compat.SetEnv
+-- 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.Compat.SetEnv (
+ setEnv
+) where
+
+#ifdef __GLASGOW_HASKELL__
+#ifdef mingw32_HOST_OS
+import GHC.Windows
+import Foreign.Safe
+import Foreign.C
+import Control.Monad
+#else
+import Foreign.C.Types
+import Foreign.C.String
+import Foreign.C.Error (throwErrnoIfMinus1_)
+#endif /* mingw32_HOST_OS */
+
+#if __GLASGOW_HASKELL__ > 611
+import System.Posix.Internals ( withFilePath )
+#else
+withFilePath :: FilePath -> (CString -> IO a) -> IO a
+withFilePath = withCString
+#endif /* __GLASGOW_HASKELL__ > 611 */
+
+#ifdef mingw32_HOST_OS
+# 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
+
+foreign import WINDOWS_CCONV unsafe "windows.h GetLastError"
+ c_GetLastError:: IO DWORD
+
+eRROR_ENVVAR_NOT_FOUND :: DWORD
+eRROR_ENVVAR_NOT_FOUND = 203
+
+#endif /* mingw32_HOST_OS */
+#endif /* __GLASGOW_HASKELL__ */
+
+-- | @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 succeds if a value
+ -- starts with NUL.
+ value = takeWhile (/= '\NUL') value_
+
+setEnv_ :: String -> String -> IO ()
+#ifdef __GLASGOW_HASKELL__
+
+#ifdef mingw32_HOST_OS
+setEnv_ key value = withCWString key $ \k -> withCWString value $ \v -> do
+ success <- c_SetEnvironmentVariable k v
+ unless success (throwGetLastError "setEnv")
+
+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 */
+
+#else
+-- setEnv is a no-op on non-GHC compilers since we depend on GHC.Windows.
+setEnv_ _key _value = return ()
+#endif /* __GLASGOW_HASKELL__ */
View
1  cabal-install/cabal-install.cabal
@@ -109,6 +109,7 @@ Executable cabal
Distribution.Client.Win32SelfUpgrade
Distribution.Compat.Exception
Distribution.Compat.FilePerms
+ Distribution.Compat.SetEnv
Distribution.Compat.Time
Paths_cabal_install

No commit comments for this range

Something went wrong with that request. Please try again.