Ticket #7427: 0001-Add-setEnv-unsetEnv-to-System.Environment.patch

System/Environment.hs

@@ -22 +22 @@
       getExecutablePath,
       getEnv,
       lookupEnv,
+      setEnv,
+      unsetEnv,
 #ifndef __NHC__
       withArgs,
       withProgName,
@@ -36 +38 @@
 #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
 
@@ -75 +79 @@
 #endif
 
 #ifdef __GLASGOW_HASKELL__
+
+#include "HsBaseConfig.h"
+
 -- ---------------------------------------------------------------------------
 -- getArgs, getProgName, getEnv
 
@@ -257 +264 @@
 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@.

base.cabal

@@ -222 +222 @@
         cbits/inputReady.c
         cbits/primFloat.c
         cbits/md5.c
+        cbits/SetEnv.c
     include-dirs: include
     includes:    HsBase.h
     install-includes:    HsBase.h HsBaseConfig.h EventConfig.h WCsubst.h consUtils.h Typeable.h

(a) /dev/null vs. (b) b/cbits/SetEnv.c

@@ +1 @@
+#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

configure.ac

@@ -63 +63 @@
   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--------------------------------------------------------------------