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