Skip executeFile001 in threaded2 way
[packages/unix.git] / System / Posix / Env.hsc
1 {-# LANGUAGE CApiFFI #-}
2 #if __GLASGOW_HASKELL__ >= 709
3 {-# LANGUAGE Safe #-}
4 #else
5 {-# LANGUAGE Trustworthy #-}
6 #endif
7 -----------------------------------------------------------------------------
8 -- |
9 -- Module      :  System.Posix.Env
10 -- Copyright   :  (c) The University of Glasgow 2002
11 -- License     :  BSD-style (see the file libraries/base/LICENSE)
12 --
13 -- Maintainer  :  libraries@haskell.org
14 -- Stability   :  provisional
15 -- Portability :  non-portable (requires POSIX)
16 --
17 -- POSIX environment support
18 --
19 -----------------------------------------------------------------------------
20
21 module System.Posix.Env (
22       getEnv
23     , getEnvDefault
24     , getEnvironmentPrim
25     , getEnvironment
26     , setEnvironment
27     , putEnv
28     , setEnv
29     , unsetEnv
30     , clearEnv
31 ) where
32
33 #include "HsUnix.h"
34
35 import Foreign.C.Error (throwErrnoIfMinus1_)
36 import Foreign.C.Types
37 import Foreign.C.String
38 import Foreign.Marshal.Array
39 import Foreign.Ptr
40 import Foreign.Storable
41 import Control.Monad
42 import Data.Maybe (fromMaybe)
43 import System.Posix.Internals
44
45 #if !MIN_VERSION_base(4,7,0)
46 -- needed for backported local 'newFilePath' binding in 'putEnv'
47 import GHC.IO.Encoding (getFileSystemEncoding)
48 import qualified GHC.Foreign as GHC (newCString)
49 #endif
50
51 -- |'getEnv' looks up a variable in the environment.
52
53 getEnv ::
54   String            {- ^ variable name  -} ->
55   IO (Maybe String) {- ^ variable value -}
56 getEnv name = do
57   litstring <- withFilePath name c_getenv
58   if litstring /= nullPtr
59      then liftM Just $ peekFilePath litstring
60      else return Nothing
61
62 -- |'getEnvDefault' is a wrapper around 'getEnv' where the
63 -- programmer can specify a fallback if the variable is not found
64 -- in the environment.
65
66 getEnvDefault ::
67   String    {- ^ variable name                    -} ->
68   String    {- ^ fallback value                   -} ->
69   IO String {- ^ variable value or fallback value -}
70 getEnvDefault name fallback = liftM (fromMaybe fallback) (getEnv name)
71
72 foreign import ccall unsafe "getenv"
73    c_getenv :: CString -> IO CString
74
75 getEnvironmentPrim :: IO [String]
76 getEnvironmentPrim = do
77   c_environ <- getCEnviron
78   -- environ can be NULL
79   if c_environ == nullPtr
80     then return []
81     else do
82       arr <- peekArray0 nullPtr c_environ
83       mapM peekFilePath arr
84
85 getCEnviron :: IO (Ptr CString)
86 #if HAVE__NSGETENVIRON
87 -- You should not access @char **environ@ directly on Darwin in a bundle/shared library.
88 -- See #2458 and http://developer.apple.com/library/mac/#documentation/Darwin/Reference/ManPages/man7/environ.7.html
89 getCEnviron = nsGetEnviron >>= peek
90
91 foreign import ccall unsafe "_NSGetEnviron"
92    nsGetEnviron :: IO (Ptr (Ptr CString))
93 #else
94 getCEnviron = peek c_environ_p
95 foreign import ccall unsafe "&environ"
96    c_environ_p :: Ptr (Ptr CString)
97 #endif
98
99 -- |'getEnvironment' retrieves the entire environment as a
100 -- list of @(key,value)@ pairs.
101
102 getEnvironment :: IO [(String,String)] {- ^ @[(key,value)]@ -}
103 getEnvironment = do
104   env <- getEnvironmentPrim
105   return $ map (dropEq.(break ((==) '='))) env
106  where
107    dropEq (x,'=':ys) = (x,ys)
108    dropEq (x,_)      = error $ "getEnvironment: insane variable " ++ x
109
110 -- |'setEnvironment' resets the entire environment to the given list of
111 -- @(key,value)@ pairs.
112
113 setEnvironment ::
114   [(String,String)] {- ^ @[(key,value)]@ -} ->
115   IO ()
116 setEnvironment env = do
117   clearEnv
118   forM_ env $ \(key,value) ->
119     setEnv key value True {-overwrite-}
120
121 -- |The 'unsetEnv' function deletes all instances of the variable name
122 -- from the environment.
123
124 unsetEnv :: String {- ^ variable name -} -> IO ()
125 #if HAVE_UNSETENV
126 # if !UNSETENV_RETURNS_VOID
127 unsetEnv name = withFilePath name $ \ s ->
128   throwErrnoIfMinus1_ "unsetenv" (c_unsetenv s)
129
130 -- POSIX.1-2001 compliant unsetenv(3)
131 foreign import capi unsafe "HsUnix.h unsetenv"
132    c_unsetenv :: CString -> IO CInt
133 # else
134 unsetEnv name = withFilePath name c_unsetenv
135
136 -- pre-POSIX unsetenv(3) returning @void@
137 foreign import capi unsafe "HsUnix.h unsetenv"
138    c_unsetenv :: CString -> IO ()
139 # endif
140 #else
141 unsetEnv name = putEnv (name ++ "=")
142 #endif
143
144 -- |'putEnv' function takes an argument of the form @name=value@
145 -- and is equivalent to @setEnv(key,value,True{-overwrite-})@.
146
147 putEnv :: String {- ^ "key=value" -} -> IO ()
148 putEnv keyvalue = do s <- newFilePath keyvalue
149                      -- Do not free `s` after calling putenv.
150                      -- According to SUSv2, the string passed to putenv
151                      -- becomes part of the environment. #7342
152                      throwErrnoIfMinus1_ "putenv" (c_putenv s)
153 #if !MIN_VERSION_base(4,7,0)
154     where
155       newFilePath :: FilePath -> IO CString
156       newFilePath fp = getFileSystemEncoding >>= \enc -> GHC.newCString enc fp
157 #endif
158
159 foreign import ccall unsafe "putenv"
160    c_putenv :: CString -> IO CInt
161
162 {- |The 'setEnv' function inserts or resets the environment variable name in
163      the current environment list.  If the variable @name@ does not exist in the
164      list, it is inserted with the given value.  If the variable does exist,
165      the argument @overwrite@ is tested; if @overwrite@ is @False@, the variable is
166      not reset, otherwise it is reset to the given value.
167 -}
168
169 setEnv ::
170   String {- ^ variable name  -} ->
171   String {- ^ variable value -} ->
172   Bool   {- ^ overwrite      -} ->
173   IO ()
174 #ifdef HAVE_SETENV
175 setEnv key value ovrwrt = do
176   withFilePath key $ \ keyP ->
177     withFilePath value $ \ valueP ->
178       throwErrnoIfMinus1_ "setenv" $
179         c_setenv keyP valueP (fromIntegral (fromEnum ovrwrt))
180
181 foreign import ccall unsafe "setenv"
182    c_setenv :: CString -> CString -> CInt -> IO CInt
183 #else
184 setEnv key value True = putEnv (key++"="++value)
185 setEnv key value False = do
186   res <- getEnv key
187   case res of
188     Just _  -> return ()
189     Nothing -> putEnv (key++"="++value)
190 #endif
191
192 -- |The 'clearEnv' function clears the environment of all name-value pairs.
193 clearEnv :: IO ()
194 #if HAVE_CLEARENV
195 clearEnv = void c_clearenv
196
197 foreign import ccall unsafe "clearenv"
198   c_clearenv :: IO Int
199 #else
200 -- Fallback to 'environ[0] = NULL'.
201 clearEnv = do
202   c_environ <- getCEnviron
203   unless (c_environ == nullPtr) $
204     poke c_environ nullPtr
205 #endif