Add setEnv/unsetEnv to System.Environment; fixes #7427

Patch from Simon Hengel.

4 files changed, 122 insertions, 2 deletions

diff --git a/libraries/base/System/Environment.hs b/libraries/base/System/Environment.hs
index c66764d40b..d99d960289 100644
--- a/libraries/base/System/Environment.hs
+++ b/libraries/base/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@.
+--
+-- 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@.
diff --git a/libraries/base/base.cabal b/libraries/base/base.cabal
index bf904575bc..87a4a7b4f7 100644
--- a/libraries/base/base.cabal
+++ b/libraries/base/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/libraries/base/cbits/SetEnv.c b/libraries/base/cbits/SetEnv.c
new file mode 100644
index 0000000000..38f0ed52b8
--- /dev/null
+++ b/libraries/base/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/libraries/base/configure.ac b/libraries/base/configure.ac
index eff1e026c7..d84c3cf27f 100644
--- a/libraries/base/configure.ac
+++ b/libraries/base/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--------------------------------------------------------------------