Add Haddock `/Since: 4.7.0.0/` comments to new symbols
[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 --
270 -- /Since: 4.7.0.0/
271 setEnv :: String -> String -> IO ()
272 setEnv key_ value_
273 | null key = throwIO (mkIOError InvalidArgument "setEnv" Nothing Nothing)
274 | '=' `elem` key = throwIO (mkIOError InvalidArgument "setEnv" Nothing Nothing)
275 | null value = unsetEnv key
276 | otherwise = setEnv_ key value
277 where
278 key = takeWhile (/= '\NUL') key_
279 value = takeWhile (/= '\NUL') value_
280
281 setEnv_ :: String -> String -> IO ()
282 #ifdef mingw32_HOST_OS
283 setEnv_ key value = withCWString key $ \k -> withCWString value $ \v -> do
284 success <- c_SetEnvironmentVariable k v
285 unless success (throwGetLastError "setEnv")
286
287 foreign import WINDOWS_CCONV unsafe "windows.h SetEnvironmentVariableW"
288 c_SetEnvironmentVariable :: LPTSTR -> LPTSTR -> IO Bool
289 #else
290
291 -- NOTE: The 'setenv()' function is not available on all systems, hence we use
292 -- 'putenv()'. This leaks memory, but so do common implementations of
293 -- 'setenv()' (AFAIK).
294 setEnv_ k v = putEnv (k ++ "=" ++ v)
295
296 putEnv :: String -> IO ()
297 putEnv keyvalue = do
298 s <- getFileSystemEncoding >>= (`GHC.newCString` keyvalue)
299 -- IMPORTANT: Do not free `s` after calling putenv!
300 --
301 -- According to SUSv2, the string passed to putenv becomes part of the
302 -- enviroment.
303 throwErrnoIf_ (/= 0) "putenv" (c_putenv s)
304
305 foreign import ccall unsafe "putenv" c_putenv :: CString -> IO CInt
306 #endif
307
308 -- | @unSet name@ removes the specified environment variable from the
309 -- environment of the current process.
310 --
311 -- Throws `Control.Exception.IOException` if @name@ is the empty string or
312 -- contains an equals sign.
313 --
314 -- /Since: 4.7.0.0/
315 unsetEnv :: String -> IO ()
316 #ifdef mingw32_HOST_OS
317 unsetEnv key = withCWString key $ \k -> do
318 success <- c_SetEnvironmentVariable k nullPtr
319 unless success $ do
320 -- We consider unsetting an environment variable that does not exist not as
321 -- an error, hence we ignore eRROR_ENVVAR_NOT_FOUND.
322 err <- c_GetLastError
323 unless (err == eRROR_ENVVAR_NOT_FOUND) $ do
324 throwGetLastError "unsetEnv"
325 #else
326
327 #ifdef HAVE_UNSETENV
328 unsetEnv key = withFilePath key (throwErrnoIf_ (/= 0) "unsetEnv" . c_unsetenv)
329 foreign import ccall unsafe "__hsbase_unsetenv" c_unsetenv :: CString -> IO CInt
330 #else
331 unsetEnv key = setEnv_ key ""
332 #endif
333
334 #endif
335
336 {-|
337 'withArgs' @args act@ - while executing action @act@, have 'getArgs'
338 return @args@.
339 -}
340 withArgs :: [String] -> IO a -> IO a
341 withArgs xs act = do
342 p <- System.Environment.getProgName
343 withArgv (p:xs) act
344
345 {-|
346 'withProgName' @name act@ - while executing action @act@,
347 have 'getProgName' return @name@.
348 -}
349 withProgName :: String -> IO a -> IO a
350 withProgName nm act = do
351 xs <- System.Environment.getArgs
352 withArgv (nm:xs) act
353
354 -- Worker routine which marshals and replaces an argv vector for
355 -- the duration of an action.
356
357 withArgv :: [String] -> IO a -> IO a
358
359 #ifdef mingw32_HOST_OS
360 -- We have to reflect the updated arguments in the RTS-side variables as
361 -- well, because the RTS still consults them for error messages and the like.
362 -- If we don't do this then ghc-e005 fails.
363 withArgv new_args act = withWin32ProgArgv new_args $ withProgArgv new_args act
364 #else
365 withArgv = withProgArgv
366 #endif
367
368 withProgArgv :: [String] -> IO a -> IO a
369 withProgArgv new_args act = do
370 pName <- System.Environment.getProgName
371 existing_args <- System.Environment.getArgs
372 bracket (setProgArgv new_args)
373 (\argv -> do _ <- setProgArgv (pName:existing_args)
374 freeProgArgv argv)
375 (const act)
376
377 freeProgArgv :: Ptr CString -> IO ()
378 freeProgArgv argv = do
379 size <- lengthArray0 nullPtr argv
380 sequence_ [ peek (argv `advancePtr` i) >>= free
381 | i <- [size - 1, size - 2 .. 0]]
382 free argv
383
384 setProgArgv :: [String] -> IO (Ptr CString)
385 setProgArgv argv = do
386 enc <- getFileSystemEncoding
387 vs <- mapM (GHC.newCString enc) argv >>= newArray0 nullPtr
388 c_setProgArgv (genericLength argv) vs
389 return vs
390
391 foreign import ccall unsafe "setProgArgv"
392 c_setProgArgv :: CInt -> Ptr CString -> IO ()
393
394 -- |'getEnvironment' retrieves the entire environment as a
395 -- list of @(key,value)@ pairs.
396 --
397 -- If an environment entry does not contain an @\'=\'@ character,
398 -- the @key@ is the whole entry and the @value@ is the empty string.
399 getEnvironment :: IO [(String, String)]
400
401 #ifdef mingw32_HOST_OS
402 getEnvironment = bracket c_GetEnvironmentStrings c_FreeEnvironmentStrings $ \pBlock ->
403 if pBlock == nullPtr then return []
404 else go pBlock
405 where
406 go pBlock = do
407 -- The block is terminated by a null byte where there
408 -- should be an environment variable of the form X=Y
409 c <- peek pBlock
410 if c == 0 then return []
411 else do
412 -- Seek the next pair (or terminating null):
413 pBlock' <- seekNull pBlock False
414 -- We now know the length in bytes, but ignore it when
415 -- getting the actual String:
416 str <- peekCWString pBlock
417 fmap (divvy str :) $ go pBlock'
418
419 -- Returns pointer to the byte *after* the next null
420 seekNull pBlock done = do
421 let pBlock' = pBlock `plusPtr` sizeOf (undefined :: CWchar)
422 if done then return pBlock'
423 else do
424 c <- peek pBlock'
425 seekNull pBlock' (c == (0 :: Word8 ))
426
427 foreign import WINDOWS_CCONV unsafe "windows.h GetEnvironmentStringsW"
428 c_GetEnvironmentStrings :: IO (Ptr CWchar)
429
430 foreign import WINDOWS_CCONV unsafe "windows.h FreeEnvironmentStringsW"
431 c_FreeEnvironmentStrings :: Ptr CWchar -> IO Bool
432 #else
433 getEnvironment = do
434 pBlock <- getEnvBlock
435 if pBlock == nullPtr then return []
436 else do
437 enc <- getFileSystemEncoding
438 stuff <- peekArray0 nullPtr pBlock >>= mapM (GHC.peekCString enc)
439 return (map divvy stuff)
440
441 foreign import ccall unsafe "__hscore_environ"
442 getEnvBlock :: IO (Ptr CString)
443 #endif
444
445 divvy :: String -> (String, String)
446 divvy str =
447 case break (=='=') str of
448 (xs,[]) -> (xs,[]) -- don't barf (like Posix.getEnvironment)
449 (name,_:value) -> (name,value)