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

File 0001-Add-setEnv-unsetEnv-to-System.Environment.patch, 6.6 KB (added by SimonHengel, 3 years ago)
  • System/Environment.hs

    From 1f8133a1d735bc2d371353f372127ff59da595f9 Mon Sep 17 00:00:00 2001
    From: Simon Hengel <[email protected]>
    Date: Sun, 18 Nov 2012 18:20:54 +0100
    Subject: [PATCH] Add setEnv/unsetEnv to System.Environment
    
    ---
     System/Environment.hs |   96 +++++++++++++++++++++++++++++++++++++++++++++++--
     base.cabal            |    1 +
     cbits/SetEnv.c        |   11 ++++++
     configure.ac          |   16 +++++++++
     4 files changed, 122 insertions(+), 2 deletions(-)
     create mode 100644 cbits/SetEnv.c
    
    diff --git a/System/Environment.hs b/System/Environment.hs
    index 184c910..7d3df4e 100644
    a b module System.Environment 
    2222      getExecutablePath,
    2323      getEnv,
    2424      lookupEnv,
     25      setEnv,
     26      unsetEnv,
    2527#ifndef __NHC__
    2628      withArgs,
    2729      withProgName,
    import Prelude 
    3638#ifdef __GLASGOW_HASKELL__
    3739import Foreign.Safe
    3840import Foreign.C
    39 import Control.Exception.Base   ( bracket )
     41import System.IO.Error (mkIOError)
     42import Control.Exception.Base (bracket, throwIO)
    4043-- import GHC.IO
    4144import GHC.IO.Exception
    4245import GHC.IO.Encoding (getFileSystemEncoding)
    4346import qualified GHC.Foreign as GHC
    4447import Data.List
     48import Control.Monad
    4549#ifdef mingw32_HOST_OS
    4650import GHC.Environment
    4751import GHC.Windows
    4852#else
    49 import Control.Monad
     53import System.Posix.Internals (withFilePath)
    5054#endif
    5155#endif
    5256
    import System.Environment.ExecutablePath 
    7579#endif
    7680
    7781#ifdef __GLASGOW_HASKELL__
     82
     83#include "HsBaseConfig.h"
     84
    7885-- ---------------------------------------------------------------------------
    7986-- getArgs, getProgName, getEnv
    8087
    ioe_missingEnvVar :: String -> IO a 
    257264ioe_missingEnvVar name = ioException (IOError Nothing NoSuchThing "getEnv"
    258265    "no environment variable" Nothing (Just name))
    259266
     267-- | @setEnv name value@ sets the specified environment variable to @value@.
     268--
     269-- On Windows setting an environment variable to the /empty string/ removes
     270-- that environment variable from the environment.  For the sake of
     271-- compatibility we adopt that behavior.  In particular
     272--
     273-- @
     274-- setEnv name \"\"
     275-- @
     276--
     277-- has the same effect as
     278--
     279-- @
     280-- `unsetEnv` name
     281-- @
     282--
     283-- If you don't care about Windows support and want to set an environment
     284-- variable to the empty string use @System.Posix.Env.setEnv@ from the @unix@
     285-- package instead.
     286--
     287-- Throws `Control.Exception.IOException` if @name@ is the empty string or
     288-- contains an equals sign.
     289setEnv :: String -> String -> IO ()
     290setEnv key_ value_
     291  | null key       = throwIO (mkIOError InvalidArgument "setEnv" Nothing Nothing)
     292  | '=' `elem` key = throwIO (mkIOError InvalidArgument "setEnv" Nothing Nothing)
     293  | null value     = unsetEnv key
     294  | otherwise      = setEnv_ key value
     295  where
     296    key   = takeWhile (/= '\NUL') key_
     297    value = takeWhile (/= '\NUL') value_
     298
     299setEnv_ :: String -> String -> IO ()
     300#ifdef mingw32_HOST_OS
     301setEnv_ key value = withCWString key $ \k -> withCWString value $ \v -> do
     302  success <- c_SetEnvironmentVariable k v
     303  unless success (throwGetLastError "setEnv")
     304
     305foreign import WINDOWS_CCONV unsafe "windows.h SetEnvironmentVariableW"
     306  c_SetEnvironmentVariable :: LPTSTR -> LPTSTR -> IO Bool
     307#else
     308
     309-- NOTE: The 'setenv()' function is not available on all systems, hence we use
     310-- 'putenv()'.  This leaks memory, but so do common implementations of
     311-- 'setenv()' (AFAIK).
     312setEnv_ k v = putEnv (k ++ "=" ++ v)
     313
     314putEnv :: String -> IO ()
     315putEnv keyvalue = do
     316  s <- getFileSystemEncoding >>= (`GHC.newCString` keyvalue)
     317  -- IMPORTANT: Do not free `s` after calling putenv!
     318  --
     319  -- According to SUSv2, the string passed to putenv becomes part of the
     320  -- enviroment.
     321  throwErrnoIf_ (/= 0) "putenv" (c_putenv s)
     322
     323foreign import ccall unsafe "putenv" c_putenv :: CString -> IO CInt
     324#endif
     325
     326-- | @unSet name@ removes the specified environment variable from the
     327-- environment of the current process.
     328--
     329-- Throws `Control.Exception.IOException` if @name@ is the empty string or
     330-- contains an equals sign.
     331unsetEnv :: String -> IO ()
     332#ifdef mingw32_HOST_OS
     333unsetEnv key = withCWString key $ \k -> do
     334  success <- c_SetEnvironmentVariable k nullPtr
     335  unless success $ do
     336    -- We consider unsetting an environment variable that does not exist not as
     337    -- an error, hence we ignore eRROR_ENVVAR_NOT_FOUND.
     338    err <- c_GetLastError
     339    unless (err == eRROR_ENVVAR_NOT_FOUND) $ do
     340      throwGetLastError "unsetEnv"
     341#else
     342
     343#ifdef HAVE_UNSETENV
     344unsetEnv key = withFilePath key (throwErrnoIf_ (/= 0) "unsetEnv" . c_unsetenv)
     345foreign import ccall unsafe "__hsbase_unsetenv" c_unsetenv :: CString -> IO CInt
     346#else
     347unsetEnv key = setEnv_ key ""
     348#endif
     349
     350#endif
     351
    260352{-|
    261353'withArgs' @args act@ - while executing action @act@, have 'getArgs'
    262354return @args@.
  • base.cabal

    diff --git a/base.cabal b/base.cabal
    index a7d3ce9..3995e5d 100644
    a b Library { 
    222222        cbits/inputReady.c
    223223        cbits/primFloat.c
    224224        cbits/md5.c
     225        cbits/SetEnv.c
    225226    include-dirs: include
    226227    includes:    HsBase.h
    227228    install-includes:    HsBase.h HsBaseConfig.h EventConfig.h WCsubst.h consUtils.h Typeable.h
  • new file cbits/SetEnv.c

    diff --git a/cbits/SetEnv.c b/cbits/SetEnv.c
    new file mode 100644
    index 0000000..38f0ed5
    - +  
     1#include "HsBase.h"
     2#ifdef HAVE_UNSETENV
     3int __hsbase_unsetenv(const char *name) {
     4#ifdef UNSETENV_RETURNS_VOID
     5    unsetenv(name);
     6    return 0;
     7#else
     8    return unsetenv(name);
     9#endif
     10}
     11#endif
  • configure.ac

    diff --git a/configure.ac b/configure.ac
    index b679520..f64e5a2 100644
    a b if test "$ac_cv_header_poll_h" = yes -a "$ac_cv_func_poll" = yes; then 
    6363  AC_DEFINE([HAVE_POLL], [1], [Define if you have poll support.])
    6464fi
    6565
     66# unsetenv
     67AC_CHECK_FUNCS([unsetenv])
     68
     69###  POSIX.1003.1 unsetenv returns 0 or -1 (EINVAL), but older implementations
     70###  in common use return void.
     71AC_CACHE_CHECK([return type of unsetenv], fptools_cv_func_unsetenv_return_type,
     72  [AC_EGREP_HEADER(changequote(<, >)<void[      ]+unsetenv>changequote([, ]),
     73                   stdlib.h,
     74                   [fptools_cv_func_unsetenv_return_type=void],
     75                   [fptools_cv_func_unsetenv_return_type=int])])
     76case "$fptools_cv_func_unsetenv_return_type" in
     77  "void" )
     78    AC_DEFINE([UNSETENV_RETURNS_VOID], [1], [Define if stdlib.h declares unsetenv to return void.])
     79  ;;
     80esac
     81
    6682dnl--------------------------------------------------------------------
    6783dnl * Deal with arguments telling us iconv is somewhere odd
    6884dnl--------------------------------------------------------------------