[commit: base] master: Add setEnv/unsetEnv to System.Environment; fixes #7427 (60d5d2e)
Ian Lynagh
igloo at earth.li
Sat Jun 15 14:05:52 CEST 2013
Repository : ssh://darcs.haskell.org//srv/darcs/packages/base
On branch : master
https://github.com/ghc/packages-base/commit/60d5d2e8ae4250e4a241feba4af514e883fdea2d
>---------------------------------------------------------------
commit 60d5d2e8ae4250e4a241feba4af514e883fdea2d
Author: Ian Lynagh <ian at well-typed.com>
Date: Sat Jun 15 12:46:21 2013 +0100
Add setEnv/unsetEnv to System.Environment; fixes #7427
Patch from Simon Hengel.
>---------------------------------------------------------------
System/Environment.hs | 96 +++++++++++++++++++++++++++++++++++++++++++++++-
base.cabal | 1 +
cbits/SetEnv.c | 11 ++++++
configure.ac | 16 ++++++++
4 files changed, 122 insertions(+), 2 deletions(-)
diff --git a/System/Environment.hs b/System/Environment.hs
index c66764d..d99d960 100644
--- a/System/Environment.hs
+++ b/System/Environment.hs
@@ -22,6 +22,8 @@ module System.Environment
getExecutablePath,
getEnv,
lookupEnv,
+ setEnv,
+ unsetEnv,
withArgs,
withProgName,
#ifdef __GLASGOW_HASKELL__
@@ -34,17 +36,19 @@ import Prelude
#ifdef __GLASGOW_HASKELL__
import Foreign.Safe
import Foreign.C
-import Control.Exception.Base ( bracket )
+import System.IO.Error (mkIOError)
+import Control.Exception.Base (bracket, throwIO)
-- import GHC.IO
import GHC.IO.Exception
import GHC.IO.Encoding (getFileSystemEncoding)
import qualified GHC.Foreign as GHC
import Data.List
+import Control.Monad
#ifdef mingw32_HOST_OS
import GHC.Environment
import GHC.Windows
#else
-import Control.Monad
+import System.Posix.Internals (withFilePath)
#endif
#endif
@@ -65,6 +69,9 @@ import System.Environment.ExecutablePath
#endif
#ifdef __GLASGOW_HASKELL__
+
+#include "HsBaseConfig.h"
+
-- ---------------------------------------------------------------------------
-- getArgs, getProgName, getEnv
@@ -247,6 +254,91 @@ ioe_missingEnvVar :: String -> IO a
ioe_missingEnvVar name = ioException (IOError Nothing NoSuchThing "getEnv"
"no environment variable" Nothing (Just name))
+-- | @setEnv name value@ sets the specified environment variable to @value at .
+--
+-- On Windows setting an environment variable to the /empty string/ removes
+-- that environment variable from the environment. For the sake of
+-- compatibility we adopt that behavior. In particular
+--
+-- @
+-- setEnv name \"\"
+-- @
+--
+-- has the same effect as
+--
+-- @
+-- `unsetEnv` name
+-- @
+--
+-- If you don't care about Windows support and want to set an environment
+-- variable to the empty string use @System.Posix.Env.setEnv@ from the @unix@
+-- package instead.
+--
+-- Throws `Control.Exception.IOException` if @name@ is the empty string or
+-- contains an equals sign.
+setEnv :: String -> String -> IO ()
+setEnv key_ value_
+ | null key = throwIO (mkIOError InvalidArgument "setEnv" Nothing Nothing)
+ | '=' `elem` key = throwIO (mkIOError InvalidArgument "setEnv" Nothing Nothing)
+ | null value = unsetEnv key
+ | otherwise = setEnv_ key value
+ where
+ key = takeWhile (/= '\NUL') key_
+ 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")
+
+foreign import WINDOWS_CCONV unsafe "windows.h SetEnvironmentVariableW"
+ c_SetEnvironmentVariable :: LPTSTR -> LPTSTR -> IO Bool
+#else
+
+-- NOTE: The 'setenv()' function is not available on all systems, hence we use
+-- 'putenv()'. This leaks memory, but so do common implementations of
+-- 'setenv()' (AFAIK).
+setEnv_ k v = putEnv (k ++ "=" ++ v)
+
+putEnv :: String -> IO ()
+putEnv keyvalue = do
+ s <- getFileSystemEncoding >>= (`GHC.newCString` keyvalue)
+ -- IMPORTANT: Do not free `s` after calling putenv!
+ --
+ -- According to SUSv2, the string passed to putenv becomes part of the
+ -- enviroment.
+ throwErrnoIf_ (/= 0) "putenv" (c_putenv s)
+
+foreign import ccall unsafe "putenv" c_putenv :: CString -> IO CInt
+#endif
+
+-- | @unSet name@ removes the specified environment variable from the
+-- environment of the current process.
+--
+-- Throws `Control.Exception.IOException` if @name@ is the empty string or
+-- contains an equals sign.
+unsetEnv :: String -> IO ()
+#ifdef mingw32_HOST_OS
+unsetEnv key = withCWString key $ \k -> do
+ success <- c_SetEnvironmentVariable k nullPtr
+ unless success $ do
+ -- We consider unsetting an environment variable that does not exist not as
+ -- an error, hence we ignore eRROR_ENVVAR_NOT_FOUND.
+ err <- c_GetLastError
+ unless (err == eRROR_ENVVAR_NOT_FOUND) $ do
+ throwGetLastError "unsetEnv"
+#else
+
+#ifdef HAVE_UNSETENV
+unsetEnv key = withFilePath key (throwErrnoIf_ (/= 0) "unsetEnv" . c_unsetenv)
+foreign import ccall unsafe "__hsbase_unsetenv" c_unsetenv :: CString -> IO CInt
+#else
+unsetEnv key = setEnv_ key ""
+#endif
+
+#endif
+
{-|
'withArgs' @args act@ - while executing action @act@, have 'getArgs'
return @args at .
diff --git a/base.cabal b/base.cabal
index bf90457..87a4a7b 100644
--- a/base.cabal
+++ b/base.cabal
@@ -228,6 +228,7 @@ Library {
cbits/inputReady.c
cbits/primFloat.c
cbits/md5.c
+ cbits/SetEnv.c
cbits/sysconf.c
include-dirs: include
includes: HsBase.h
diff --git a/cbits/SetEnv.c b/cbits/SetEnv.c
new file mode 100644
index 0000000..38f0ed5
--- /dev/null
+++ b/cbits/SetEnv.c
@@ -0,0 +1,11 @@
+#include "HsBase.h"
+#ifdef HAVE_UNSETENV
+int __hsbase_unsetenv(const char *name) {
+#ifdef UNSETENV_RETURNS_VOID
+ unsetenv(name);
+ return 0;
+#else
+ return unsetenv(name);
+#endif
+}
+#endif
diff --git a/configure.ac b/configure.ac
index eff1e02..d84c3cf 100644
--- a/configure.ac
+++ b/configure.ac
@@ -69,6 +69,22 @@ if test "$ac_cv_header_poll_h" = yes -a "$ac_cv_func_poll" = yes; then
AC_DEFINE([HAVE_POLL], [1], [Define if you have poll support.])
fi
+# unsetenv
+AC_CHECK_FUNCS([unsetenv])
+
+### POSIX.1003.1 unsetenv returns 0 or -1 (EINVAL), but older implementations
+### in common use return void.
+AC_CACHE_CHECK([return type of unsetenv], fptools_cv_func_unsetenv_return_type,
+ [AC_EGREP_HEADER(changequote(<, >)<void[ ]+unsetenv>changequote([, ]),
+ stdlib.h,
+ [fptools_cv_func_unsetenv_return_type=void],
+ [fptools_cv_func_unsetenv_return_type=int])])
+case "$fptools_cv_func_unsetenv_return_type" in
+ "void" )
+ AC_DEFINE([UNSETENV_RETURNS_VOID], [1], [Define if stdlib.h declares unsetenv to return void.])
+ ;;
+esac
+
dnl--------------------------------------------------------------------
dnl * Deal with arguments telling us iconv is somewhere odd
dnl--------------------------------------------------------------------
More information about the ghc-commits
mailing list