8397fc30b5d65dba7164242c42a1755022522e55
[packages/base.git] / System / Environment.hs
1 {-# LANGUAGE Safe #-}
2 {-# LANGUAGE CPP, ForeignFunctionInterface #-}
3
4 -----------------------------------------------------------------------------
5 -- |
6 -- Module : System.Environment
7 -- Copyright : (c) The University of Glasgow 2001
8 -- License : BSD-style (see the file libraries/base/LICENSE)
9 --
10 -- Maintainer : libraries@haskell.org
11 -- Stability : provisional
12 -- Portability : portable
13 --
14 -- Miscellaneous information about the system environment.
15 --
16 -----------------------------------------------------------------------------
17
18 module System.Environment
19 (
20 getArgs,
21 getProgName,
22 getExecutablePath,
23 getEnv,
24 lookupEnv,
25 setEnv,
26 unsetEnv,
27 withArgs,
28 withProgName,
29 getEnvironment,
30 ) where
31
32 import Prelude
33
34 import Foreign.Safe
35 import Foreign.C
36 import System.IO.Error (mkIOError)
37 import Control.Exception.Base (bracket, throwIO)
38 -- import GHC.IO
39 import GHC.IO.Exception
40 import GHC.IO.Encoding (getFileSystemEncoding)
41 import qualified GHC.Foreign as GHC
42 import Data.List
43 import Control.Monad
44 #ifdef mingw32_HOST_OS
45 import GHC.Environment
46 import GHC.Windows
47 #else
48 import System.Posix.Internals (withFilePath)
49 #endif
50
51 import System.Environment.ExecutablePath
52
53 #ifdef mingw32_HOST_OS
54 # if defined(i386_HOST_ARCH)
55 # define WINDOWS_CCONV stdcall
56 # elif defined(x86_64_HOST_ARCH)
57 # define WINDOWS_CCONV ccall
58 # else
59 # error Unknown mingw32 arch
60 # endif
61 #endif
62
63 #include "HsBaseConfig.h"
64
65 -- ---------------------------------------------------------------------------
66 -- getArgs, getProgName, getEnv
67
68 #ifdef mingw32_HOST_OS
69
70 -- Ignore the arguments to hs_init on Windows for the sake of Unicode compat
71
72 getWin32ProgArgv_certainly :: IO [String]
73 getWin32ProgArgv_certainly = do
74 mb_argv <- getWin32ProgArgv
75 case mb_argv of
76 Nothing -> fmap dropRTSArgs getFullArgs
77 Just argv -> return argv
78
79 withWin32ProgArgv :: [String] -> IO a -> IO a
80 withWin32ProgArgv argv act = bracket begin setWin32ProgArgv (\_ -> act)
81 where
82 begin = do
83 mb_old_argv <- getWin32ProgArgv
84 setWin32ProgArgv (Just argv)
85 return mb_old_argv
86
87 getWin32ProgArgv :: IO (Maybe [String])
88 getWin32ProgArgv = alloca $ \p_argc -> alloca $ \p_argv -> do
89 c_getWin32ProgArgv p_argc p_argv
90 argc <- peek p_argc
91 argv_p <- peek p_argv
92 if argv_p == nullPtr
93 then return Nothing
94 else do
95 argv_ps <- peekArray (fromIntegral argc) argv_p
96 fmap Just $ mapM peekCWString argv_ps
97
98 setWin32ProgArgv :: Maybe [String] -> IO ()
99 setWin32ProgArgv Nothing = c_setWin32ProgArgv 0 nullPtr
100 setWin32ProgArgv (Just argv) = withMany withCWString argv $ \argv_ps -> withArrayLen argv_ps $ \argc argv_p -> do
101 c_setWin32ProgArgv (fromIntegral argc) argv_p
102
103 foreign import ccall unsafe "getWin32ProgArgv"
104 c_getWin32ProgArgv :: Ptr CInt -> Ptr (Ptr CWString) -> IO ()
105
106 foreign import ccall unsafe "setWin32ProgArgv"
107 c_setWin32ProgArgv :: CInt -> Ptr CWString -> IO ()
108
109 dropRTSArgs :: [String] -> [String]
110 dropRTSArgs [] = []
111 dropRTSArgs ("+RTS":rest) = dropRTSArgs (dropWhile (/= "-RTS") rest)
112 dropRTSArgs ("--RTS":rest) = rest
113 dropRTSArgs ("-RTS":rest) = dropRTSArgs rest
114 dropRTSArgs (arg:rest) = arg : dropRTSArgs rest
115
116 #endif
117
118 -- | Computation 'getArgs' returns a list of the program's command
119 -- line arguments (not including the program name).
120 getArgs :: IO [String]
121
122 #ifdef mingw32_HOST_OS
123 getArgs = fmap tail getWin32ProgArgv_certainly
124 #else
125 getArgs =
126 alloca $ \ p_argc ->
127 alloca $ \ p_argv -> do
128 getProgArgv p_argc p_argv
129 p <- fromIntegral `liftM` peek p_argc
130 argv <- peek p_argv
131 enc <- getFileSystemEncoding
132 peekArray (p - 1) (advancePtr argv 1) >>= mapM (GHC.peekCString enc)
133
134 foreign import ccall unsafe "getProgArgv"
135 getProgArgv :: Ptr CInt -> Ptr (Ptr CString) -> IO ()
136 #endif
137
138 {-|
139 Computation 'getProgName' returns the name of the program as it was
140 invoked.
141
142 However, this is hard-to-impossible to implement on some non-Unix
143 OSes, so instead, for maximum portability, we just return the leafname
144 of the program as invoked. Even then there are some differences
145 between platforms: on Windows, for example, a program invoked as foo
146 is probably really @FOO.EXE@, and that is what 'getProgName' will return.
147 -}
148 getProgName :: IO String
149 #ifdef mingw32_HOST_OS
150 -- Ignore the arguments to hs_init on Windows for the sake of Unicode compat
151 getProgName = fmap (basename . head) getWin32ProgArgv_certainly
152 #else
153 getProgName =
154 alloca $ \ p_argc ->
155 alloca $ \ p_argv -> do
156 getProgArgv p_argc p_argv
157 argv <- peek p_argv
158 unpackProgName argv
159
160 unpackProgName :: Ptr (Ptr CChar) -> IO String -- argv[0]
161 unpackProgName argv = do
162 enc <- getFileSystemEncoding
163 s <- peekElemOff argv 0 >>= GHC.peekCString enc
164 return (basename s)
165 #endif
166
167 basename :: FilePath -> FilePath
168 basename f = go f f
169 where
170 go acc [] = acc
171 go acc (x:xs)
172 | isPathSeparator x = go xs xs
173 | otherwise = go acc xs
174
175 isPathSeparator :: Char -> Bool
176 isPathSeparator '/' = True
177 #ifdef mingw32_HOST_OS
178 isPathSeparator '\\' = True
179 #endif
180 isPathSeparator _ = False
181
182
183 -- | Computation 'getEnv' @var@ returns the value
184 -- of the environment variable @var@. For the inverse, POSIX users
185 -- can use 'System.Posix.Env.putEnv'.
186 --
187 -- This computation may fail with:
188 --
189 -- * 'System.IO.Error.isDoesNotExistError' if the environment variable
190 -- does not exist.
191
192 getEnv :: String -> IO String
193 getEnv name = lookupEnv name >>= maybe handleError return
194 where
195 #ifdef mingw32_HOST_OS
196 handleError = do
197 err <- c_GetLastError
198 if err == eRROR_ENVVAR_NOT_FOUND
199 then ioe_missingEnvVar name
200 else throwGetLastError "getEnv"
201
202 eRROR_ENVVAR_NOT_FOUND :: DWORD
203 eRROR_ENVVAR_NOT_FOUND = 203
204
205 foreign import WINDOWS_CCONV unsafe "windows.h GetLastError"
206 c_GetLastError:: IO DWORD
207
208 #else
209 handleError = ioe_missingEnvVar name
210 #endif
211
212 -- | Return the value of the environment variable @var@, or @Nothing@ if
213 -- there is no such value.
214 --
215 -- For POSIX users, this is equivalent to 'System.Posix.Env.getEnv'.
216 lookupEnv :: String -> IO (Maybe String)
217 #ifdef mingw32_HOST_OS
218 lookupEnv name = withCWString name $ \s -> try_size s 256
219 where
220 try_size s size = allocaArray (fromIntegral size) $ \p_value -> do
221 res <- c_GetEnvironmentVariable s p_value size
222 case res of
223 0 -> return Nothing
224 _ | res > size -> try_size s res -- Rare: size increased between calls to GetEnvironmentVariable
225 | otherwise -> peekCWString p_value >>= return . Just
226
227 foreign import WINDOWS_CCONV unsafe "windows.h GetEnvironmentVariableW"
228 c_GetEnvironmentVariable :: LPWSTR -> LPWSTR -> DWORD -> IO DWORD
229 #else
230 lookupEnv name =
231 withCString name $ \s -> do
232 litstring <- c_getenv s
233 if litstring /= nullPtr
234 then do enc <- getFileSystemEncoding
235 result <- GHC.peekCString enc litstring
236 return $ Just result
237 else return Nothing
238
239 foreign import ccall unsafe "getenv"
240 c_getenv :: CString -> IO (Ptr CChar)
241 #endif
242
243 ioe_missingEnvVar :: String -> IO a
244 ioe_missingEnvVar name = ioException (IOError Nothing NoSuchThing "getEnv"
245 "no environment variable" Nothing (Just name))
246
247 -- | @setEnv name value@ sets the specified environment variable to @value@.
248 --
249 -- On Windows setting an environment variable to the /empty string/ removes
250 -- that environment variable from the environment. For the sake of
251 -- compatibility we adopt that behavior. In particular
252 --
253 -- @
254 -- setEnv name \"\"
255 -- @
256 --
257 -- has the same effect as
258 --
259 -- @
260 -- `unsetEnv` name
261 -- @
262 --
263 -- If you don't care about Windows support and want to set an environment
264 -- variable to the empty string use @System.Posix.Env.setEnv@ from the @unix@
265 -- package instead.
266 --
267 -- Throws `Control.Exception.IOException` if @name@ is the empty string or
268 -- contains an equals sign.
269 setEnv :: String -> String -> IO ()
270 setEnv key_ value_
271 | null key = throwIO (mkIOError InvalidArgument "setEnv" Nothing Nothing)
272 | '=' `elem` key = throwIO (mkIOError InvalidArgument "setEnv" Nothing Nothing)
273 | null value = unsetEnv key
274 | otherwise = setEnv_ key value
275 where
276 key = takeWhile (/= '\NUL') key_
277 value = takeWhile (/= '\NUL') value_
278
279 setEnv_ :: String -> String -> IO ()
280 #ifdef mingw32_HOST_OS
281 setEnv_ key value = withCWString key $ \k -> withCWString value $ \v -> do
282 success <- c_SetEnvironmentVariable k v
283 unless success (throwGetLastError "setEnv")
284
285 foreign import WINDOWS_CCONV unsafe "windows.h SetEnvironmentVariableW"
286 c_SetEnvironmentVariable :: LPTSTR -> LPTSTR -> IO Bool
287 #else
288
289 -- NOTE: The 'setenv()' function is not available on all systems, hence we use
290 -- 'putenv()'. This leaks memory, but so do common implementations of
291 -- 'setenv()' (AFAIK).
292 setEnv_ k v = putEnv (k ++ "=" ++ v)
293
294 putEnv :: String -> IO ()
295 putEnv keyvalue = do
296 s <- getFileSystemEncoding >>= (`GHC.newCString` keyvalue)
297 -- IMPORTANT: Do not free `s` after calling putenv!
298 --
299 -- According to SUSv2, the string passed to putenv becomes part of the
300 -- enviroment.
301 throwErrnoIf_ (/= 0) "putenv" (c_putenv s)
302
303 foreign import ccall unsafe "putenv" c_putenv :: CString -> IO CInt
304 #endif
305
306 -- | @unSet name@ removes the specified environment variable from the
307 -- environment of the current process.
308 --
309 -- Throws `Control.Exception.IOException` if @name@ is the empty string or
310 -- contains an equals sign.
311 unsetEnv :: String -> IO ()
312 #ifdef mingw32_HOST_OS
313 unsetEnv key = withCWString key $ \k -> do
314 success <- c_SetEnvironmentVariable k nullPtr
315 unless success $ do
316 -- We consider unsetting an environment variable that does not exist not as
317 -- an error, hence we ignore eRROR_ENVVAR_NOT_FOUND.
318 err <- c_GetLastError
319 unless (err == eRROR_ENVVAR_NOT_FOUND) $ do
320 throwGetLastError "unsetEnv"
321 #else
322
323 #ifdef HAVE_UNSETENV
324 unsetEnv key = withFilePath key (throwErrnoIf_ (/= 0) "unsetEnv" . c_unsetenv)
325 foreign import ccall unsafe "__hsbase_unsetenv" c_unsetenv :: CString -> IO CInt
326 #else
327 unsetEnv key = setEnv_ key ""
328 #endif
329
330 #endif
331
332 {-|
333 'withArgs' @args act@ - while executing action @act@, have 'getArgs'
334 return @args@.
335 -}
336 withArgs :: [String] -> IO a -> IO a
337 withArgs xs act = do
338 p <- System.Environment.getProgName
339 withArgv (p:xs) act
340
341 {-|
342 'withProgName' @name act@ - while executing action @act@,
343 have 'getProgName' return @name@.
344 -}
345 withProgName :: String -> IO a -> IO a
346 withProgName nm act = do
347 xs <- System.Environment.getArgs
348 withArgv (nm:xs) act
349
350 -- Worker routine which marshals and replaces an argv vector for
351 -- the duration of an action.
352
353 withArgv :: [String] -> IO a -> IO a
354
355 #ifdef mingw32_HOST_OS
356 -- We have to reflect the updated arguments in the RTS-side variables as
357 -- well, because the RTS still consults them for error messages and the like.
358 -- If we don't do this then ghc-e005 fails.
359 withArgv new_args act = withWin32ProgArgv new_args $ withProgArgv new_args act
360 #else
361 withArgv = withProgArgv
362 #endif
363
364 withProgArgv :: [String] -> IO a -> IO a
365 withProgArgv new_args act = do
366 pName <- System.Environment.getProgName
367 existing_args <- System.Environment.getArgs
368 bracket (setProgArgv new_args)
369 (\argv -> do _ <- setProgArgv (pName:existing_args)
370 freeProgArgv argv)
371 (const act)
372
373 freeProgArgv :: Ptr CString -> IO ()
374 freeProgArgv argv = do
375 size <- lengthArray0 nullPtr argv
376 sequence_ [ peek (argv `advancePtr` i) >>= free
377 | i <- [size - 1, size - 2 .. 0]]
378 free argv
379
380 setProgArgv :: [String] -> IO (Ptr CString)
381 setProgArgv argv = do
382 enc <- getFileSystemEncoding
383 vs <- mapM (GHC.newCString enc) argv >>= newArray0 nullPtr
384 c_setProgArgv (genericLength argv) vs
385 return vs
386
387 foreign import ccall unsafe "setProgArgv"
388 c_setProgArgv :: CInt -> Ptr CString -> IO ()
389
390 -- |'getEnvironment' retrieves the entire environment as a
391 -- list of @(key,value)@ pairs.
392 --
393 -- If an environment entry does not contain an @\'=\'@ character,
394 -- the @key@ is the whole entry and the @value@ is the empty string.
395 getEnvironment :: IO [(String, String)]
396
397 #ifdef mingw32_HOST_OS
398 getEnvironment = bracket c_GetEnvironmentStrings c_FreeEnvironmentStrings $ \pBlock ->
399 if pBlock == nullPtr then return []
400 else go pBlock
401 where
402 go pBlock = do
403 -- The block is terminated by a null byte where there
404 -- should be an environment variable of the form X=Y
405 c <- peek pBlock
406 if c == 0 then return []
407 else do
408 -- Seek the next pair (or terminating null):
409 pBlock' <- seekNull pBlock False
410 -- We now know the length in bytes, but ignore it when
411 -- getting the actual String:
412 str <- peekCWString pBlock
413 fmap (divvy str :) $ go pBlock'
414
415 -- Returns pointer to the byte *after* the next null
416 seekNull pBlock done = do
417 let pBlock' = pBlock `plusPtr` sizeOf (undefined :: CWchar)
418 if done then return pBlock'
419 else do
420 c <- peek pBlock'
421 seekNull pBlock' (c == (0 :: Word8 ))
422
423 foreign import WINDOWS_CCONV unsafe "windows.h GetEnvironmentStringsW"
424 c_GetEnvironmentStrings :: IO (Ptr CWchar)
425
426 foreign import WINDOWS_CCONV unsafe "windows.h FreeEnvironmentStringsW"
427 c_FreeEnvironmentStrings :: Ptr CWchar -> IO Bool
428 #else
429 getEnvironment = do
430 pBlock <- getEnvBlock
431 if pBlock == nullPtr then return []
432 else do
433 enc <- getFileSystemEncoding
434 stuff <- peekArray0 nullPtr pBlock >>= mapM (GHC.peekCString enc)
435 return (map divvy stuff)
436
437 foreign import ccall unsafe "__hscore_environ"
438 getEnvBlock :: IO (Ptr CString)
439 #endif
440
441 divvy :: String -> (String, String)
442 divvy str =
443 case break (=='=') str of
444 (xs,[]) -> (xs,[]) -- don't barf (like Posix.getEnvironment)
445 (name,_:value) -> (name,value)