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