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