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