diff options
Diffstat (limited to 'libraries')
| -rw-r--r-- | libraries/base/System/Environment.hs | 96 | ||||
| -rw-r--r-- | libraries/base/base.cabal | 1 | ||||
| -rw-r--r-- | libraries/base/cbits/SetEnv.c | 11 | ||||
| -rw-r--r-- | libraries/base/configure.ac | 16 |
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-------------------------------------------------------------------- |