cf73c3d9bc7df05506f425b03ea7302d0bed15fc
[packages/base.git] / System / Environment.hs
1 {-# LANGUAGE CPP, ForeignFunctionInterface #-}
2
3 -----------------------------------------------------------------------------
4 -- |
5 -- Module : System.Environment
6 -- Copyright : (c) The University of Glasgow 2001
7 -- License : BSD-style (see the file libraries/base/LICENSE)
8 --
9 -- Maintainer : libraries@haskell.org
10 -- Stability : provisional
11 -- Portability : portable
12 --
13 -- Miscellaneous information about the system environment.
14 --
15 -----------------------------------------------------------------------------
16
17 module System.Environment
18 (
19 getArgs, -- :: IO [String]
20 getProgName, -- :: IO String
21 getEnv, -- :: String -> IO String
22 #ifndef __NHC__
23 withArgs,
24 withProgName,
25 #endif
26 #ifdef __GLASGOW_HASKELL__
27 getEnvironment,
28 #endif
29 ) where
30
31 import Prelude
32
33 #ifdef __GLASGOW_HASKELL__
34 import Foreign
35 import Foreign.C
36 import Control.Exception.Base ( bracket )
37 -- import GHC.IO
38 import GHC.IO.Exception
39 import GHC.IO.Encoding (fileSystemEncoding)
40 import qualified GHC.Foreign as GHC
41 import Data.List
42 #ifdef mingw32_HOST_OS
43 import GHC.Environment
44 import GHC.Windows
45 #else
46 import Control.Monad
47 #endif
48 #endif
49
50 #ifdef __HUGS__
51 import Hugs.System
52 #endif
53
54 #ifdef __NHC__
55 import System
56 ( getArgs
57 , getProgName
58 , getEnv
59 )
60 #endif
61
62 #ifdef __GLASGOW_HASKELL__
63 -- ---------------------------------------------------------------------------
64 -- getArgs, getProgName, getEnv
65
66 #ifdef mingw32_HOST_OS
67
68 -- Ignore the arguments to hs_init on Windows for the sake of Unicode compat
69
70 getWin32ProgArgv_certainly :: IO [String]
71 getWin32ProgArgv_certainly = do
72 mb_argv <- getWin32ProgArgv
73 case mb_argv of
74 Nothing -> fmap dropRTSArgs getFullArgs
75 Just argv -> return argv
76
77 withWin32ProgArgv :: [String] -> IO a -> IO a
78 withWin32ProgArgv argv act = bracket begin setWin32ProgArgv (\_ -> act)
79 where
80 begin = do
81 mb_old_argv <- getWin32ProgArgv
82 setWin32ProgArgv (Just argv)
83 return mb_old_argv
84
85 getWin32ProgArgv :: IO (Maybe [String])
86 getWin32ProgArgv = alloca $ \p_argc -> alloca $ \p_argv -> do
87 c_getWin32ProgArgv p_argc p_argv
88 argc <- peek p_argc
89 argv_p <- peek p_argv
90 if argv_p == nullPtr
91 then return Nothing
92 else do
93 argv_ps <- peekArray (fromIntegral argc) argv_p
94 fmap Just $ mapM peekCWString argv_ps
95
96 setWin32ProgArgv :: Maybe [String] -> IO ()
97 setWin32ProgArgv Nothing = c_setWin32ProgArgv 0 nullPtr
98 setWin32ProgArgv (Just argv) = withMany withCWString argv $ \argv_ps -> withArrayLen argv_ps $ \argc argv_p -> do
99 c_setWin32ProgArgv (fromIntegral argc) argv_p
100
101 foreign import ccall unsafe "getWin32ProgArgv"
102 c_getWin32ProgArgv :: Ptr CInt -> Ptr (Ptr CWString) -> IO ()
103
104 foreign import ccall unsafe "setWin32ProgArgv"
105 c_setWin32ProgArgv :: CInt -> Ptr CWString -> IO ()
106
107 dropRTSArgs :: [String] -> [String]
108 dropRTSArgs [] = []
109 dropRTSArgs ("+RTS":rest) = dropRTSArgs (dropWhile (/= "-RTS") rest)
110 dropRTSArgs ("--RTS":rest) = rest
111 dropRTSArgs ("-RTS":rest) = dropRTSArgs rest
112 dropRTSArgs (arg:rest) = arg : dropRTSArgs rest
113
114 #endif
115
116 -- | Computation 'getArgs' returns a list of the program's command
117 -- line arguments (not including the program name).
118 getArgs :: IO [String]
119
120 #ifdef mingw32_HOST_OS
121 getArgs = fmap tail getWin32ProgArgv_certainly
122 #else
123 getArgs =
124 alloca $ \ p_argc ->
125 alloca $ \ p_argv -> do
126 getProgArgv p_argc p_argv
127 p <- fromIntegral `liftM` peek p_argc
128 argv <- peek p_argv
129 peekArray (p - 1) (advancePtr argv 1) >>= mapM (GHC.peekCString fileSystemEncoding)
130
131 foreign import ccall unsafe "getProgArgv"
132 getProgArgv :: Ptr CInt -> Ptr (Ptr CString) -> IO ()
133 #endif
134
135 {-|
136 Computation 'getProgName' returns the name of the program as it was
137 invoked.
138
139 However, this is hard-to-impossible to implement on some non-Unix
140 OSes, so instead, for maximum portability, we just return the leafname
141 of the program as invoked. Even then there are some differences
142 between platforms: on Windows, for example, a program invoked as foo
143 is probably really @FOO.EXE@, and that is what 'getProgName' will return.
144 -}
145 getProgName :: IO String
146 #ifdef mingw32_HOST_OS
147 -- Ignore the arguments to hs_init on Windows for the sake of Unicode compat
148 getProgName = fmap (basename . head) getWin32ProgArgv_certainly
149 #else
150 getProgName =
151 alloca $ \ p_argc ->
152 alloca $ \ p_argv -> do
153 getProgArgv p_argc p_argv
154 argv <- peek p_argv
155 unpackProgName argv
156
157 unpackProgName :: Ptr (Ptr CChar) -> IO String -- argv[0]
158 unpackProgName argv = do
159 s <- peekElemOff argv 0 >>= GHC.peekCString fileSystemEncoding
160 return (basename s)
161 #endif
162
163 basename :: FilePath -> FilePath
164 basename f = go f f
165 where
166 go acc [] = acc
167 go acc (x:xs)
168 | isPathSeparator x = go xs xs
169 | otherwise = go acc xs
170
171 isPathSeparator :: Char -> Bool
172 isPathSeparator '/' = True
173 #ifdef mingw32_HOST_OS
174 isPathSeparator '\\' = True
175 #endif
176 isPathSeparator _ = False
177
178
179 -- | Computation 'getEnv' @var@ returns the value
180 -- of the environment variable @var@.
181 --
182 -- This computation may fail with:
183 --
184 -- * 'System.IO.Error.isDoesNotExistError' if the environment variable
185 -- does not exist.
186
187 getEnv :: String -> IO String
188 #ifdef mingw32_HOST_OS
189 getEnv name = withCWString name $ \s -> try_size s 256
190 where
191 try_size s size = allocaArray (fromIntegral size) $ \p_value -> do
192 res <- c_GetEnvironmentVariable s p_value size
193 case res of
194 0 -> do
195 err <- c_GetLastError
196 if err == eRROR_ENVVAR_NOT_FOUND
197 then ioe_missingEnvVar name
198 else throwGetLastError "getEnv"
199 _ | res > size -> try_size s res -- Rare: size increased between calls to GetEnvironmentVariable
200 | otherwise -> peekCWString p_value
201
202 eRROR_ENVVAR_NOT_FOUND :: DWORD
203 eRROR_ENVVAR_NOT_FOUND = 203
204
205 foreign import stdcall unsafe "windows.h GetLastError"
206 c_GetLastError:: IO DWORD
207
208 foreign import stdcall unsafe "windows.h GetEnvironmentVariableW"
209 c_GetEnvironmentVariable :: LPTSTR -> LPTSTR -> DWORD -> IO DWORD
210 #else
211 getEnv name =
212 withCString name $ \s -> do
213 litstring <- c_getenv s
214 if litstring /= nullPtr
215 then GHC.peekCString fileSystemEncoding litstring
216 else ioe_missingEnvVar name
217
218 foreign import ccall unsafe "getenv"
219 c_getenv :: CString -> IO (Ptr CChar)
220 #endif
221
222 ioe_missingEnvVar :: String -> IO a
223 ioe_missingEnvVar name = ioException (IOError Nothing NoSuchThing "getEnv"
224 "no environment variable" Nothing (Just name))
225
226 {-|
227 'withArgs' @args act@ - while executing action @act@, have 'getArgs'
228 return @args@.
229 -}
230 withArgs :: [String] -> IO a -> IO a
231 withArgs xs act = do
232 p <- System.Environment.getProgName
233 withArgv (p:xs) act
234
235 {-|
236 'withProgName' @name act@ - while executing action @act@,
237 have 'getProgName' return @name@.
238 -}
239 withProgName :: String -> IO a -> IO a
240 withProgName nm act = do
241 xs <- System.Environment.getArgs
242 withArgv (nm:xs) act
243
244 -- Worker routine which marshals and replaces an argv vector for
245 -- the duration of an action.
246
247 withArgv :: [String] -> IO a -> IO a
248
249 #ifdef mingw32_HOST_OS
250 -- We have to reflect the updated arguments in the RTS-side variables as
251 -- well, because the RTS still consults them for error messages and the like.
252 -- If we don't do this then ghc-e005 fails.
253 withArgv new_args act = withWin32ProgArgv new_args $ withProgArgv new_args act
254 #else
255 withArgv = withProgArgv
256 #endif
257
258 withProgArgv :: [String] -> IO a -> IO a
259 withProgArgv new_args act = do
260 pName <- System.Environment.getProgName
261 existing_args <- System.Environment.getArgs
262 bracket (setProgArgv new_args)
263 (\argv -> do _ <- setProgArgv (pName:existing_args)
264 freeProgArgv argv)
265 (const act)
266
267 freeProgArgv :: Ptr CString -> IO ()
268 freeProgArgv argv = do
269 size <- lengthArray0 nullPtr argv
270 sequence_ [peek (argv `advancePtr` i) >>= free | i <- [size, size-1 .. 0]]
271 free argv
272
273 setProgArgv :: [String] -> IO (Ptr CString)
274 setProgArgv argv = do
275 vs <- mapM (GHC.newCString fileSystemEncoding) argv >>= newArray0 nullPtr
276 c_setProgArgv (genericLength argv) vs
277 return vs
278
279 foreign import ccall unsafe "setProgArgv"
280 c_setProgArgv :: CInt -> Ptr CString -> IO ()
281
282 -- |'getEnvironment' retrieves the entire environment as a
283 -- list of @(key,value)@ pairs.
284 --
285 -- If an environment entry does not contain an @\'=\'@ character,
286 -- the @key@ is the whole entry and the @value@ is the empty string.
287 getEnvironment :: IO [(String, String)]
288
289 #ifdef mingw32_HOST_OS
290 getEnvironment = bracket c_GetEnvironmentStrings c_FreeEnvironmentStrings $ \pBlock ->
291 if pBlock == nullPtr then return []
292 else go pBlock
293 where
294 go pBlock = do
295 -- The block is terminated by a null byte where there
296 -- should be an environment variable of the form X=Y
297 c <- peek pBlock
298 if c == 0 then return []
299 else do
300 -- Seek the next pair (or terminating null):
301 pBlock' <- seekNull pBlock False
302 -- We now know the length in bytes, but ignore it when
303 -- getting the actual String:
304 str <- peekCWString pBlock
305 fmap (divvy str :) $ go pBlock'
306
307 -- Returns pointer to the byte *after* the next null
308 seekNull pBlock done = do
309 let pBlock' = pBlock `plusPtr` sizeOf (undefined :: CWchar)
310 if done then return pBlock'
311 else do
312 c <- peek pBlock'
313 seekNull pBlock' (c == (0 :: Word8 ))
314
315 foreign import stdcall unsafe "windows.h GetEnvironmentStringsW"
316 c_GetEnvironmentStrings :: IO (Ptr CWchar)
317
318 foreign import stdcall unsafe "windows.h FreeEnvironmentStringsW"
319 c_FreeEnvironmentStrings :: Ptr CWchar -> IO Bool
320 #else
321 getEnvironment = do
322 pBlock <- getEnvBlock
323 if pBlock == nullPtr then return []
324 else do
325 stuff <- peekArray0 nullPtr pBlock >>= mapM (GHC.peekCString fileSystemEncoding)
326 return (map divvy stuff)
327
328 foreign import ccall unsafe "__hscore_environ"
329 getEnvBlock :: IO (Ptr CString)
330 #endif
331
332 divvy :: String -> (String, String)
333 divvy str =
334 case break (=='=') str of
335 (xs,[]) -> (xs,[]) -- don't barf (like Posix.getEnvironment)
336 (name,_:value) -> (name,value)
337 #endif /* __GLASGOW_HASKELL__ */