Initialize hs_init with UTF8 encoded arguments on Windows.
[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 qualified GHC.Foreign as GHC
42 import Control.Monad
43 #if defined(mingw32_HOST_OS)
44 import GHC.IO.Encoding (argvEncoding)
45 import GHC.Windows
46 #else
47 import GHC.IO.Encoding (getFileSystemEncoding, argvEncoding)
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 -- | Computation 'getArgs' returns a list of the program's command
69 -- line arguments (not including the program name).
70 getArgs :: IO [String]
71 getArgs =
72 alloca $ \ p_argc ->
73 alloca $ \ p_argv -> do
74 getProgArgv p_argc p_argv
75 p <- fromIntegral `liftM` peek p_argc
76 argv <- peek p_argv
77 enc <- argvEncoding
78 peekArray (p - 1) (advancePtr argv 1) >>= mapM (GHC.peekCString enc)
79
80
81 foreign import ccall unsafe "getProgArgv"
82 getProgArgv :: Ptr CInt -> Ptr (Ptr CString) -> IO ()
83
84 {-|
85 Computation 'getProgName' returns the name of the program as it was
86 invoked.
87
88 However, this is hard-to-impossible to implement on some non-Unix
89 OSes, so instead, for maximum portability, we just return the leafname
90 of the program as invoked. Even then there are some differences
91 between platforms: on Windows, for example, a program invoked as foo
92 is probably really @FOO.EXE@, and that is what 'getProgName' will return.
93 -}
94 getProgName :: IO String
95 -- Ignore the arguments to hs_init on Windows for the sake of Unicode compat
96 getProgName =
97 alloca $ \ p_argc ->
98 alloca $ \ p_argv -> do
99 getProgArgv p_argc p_argv
100 argv <- peek p_argv
101 unpackProgName argv
102
103 unpackProgName :: Ptr (Ptr CChar) -> IO String -- argv[0]
104 unpackProgName argv = do
105 enc <- argvEncoding
106 s <- peekElemOff argv 0 >>= GHC.peekCString enc
107 return (basename s)
108
109 basename :: FilePath -> FilePath
110 basename f = go f f
111 where
112 go acc [] = acc
113 go acc (x:xs)
114 | isPathSeparator x = go xs xs
115 | otherwise = go acc xs
116
117 isPathSeparator :: Char -> Bool
118 isPathSeparator '/' = True
119 #if defined(mingw32_HOST_OS)
120 isPathSeparator '\\' = True
121 #endif
122 isPathSeparator _ = False
123
124
125 -- | Computation 'getEnv' @var@ returns the value
126 -- of the environment variable @var@. For the inverse, POSIX users
127 -- can use 'System.Posix.Env.putEnv'.
128 --
129 -- This computation may fail with:
130 --
131 -- * 'System.IO.Error.isDoesNotExistError' if the environment variable
132 -- does not exist.
133
134 getEnv :: String -> IO String
135 getEnv name = lookupEnv name >>= maybe handleError return
136 where
137 #if defined(mingw32_HOST_OS)
138 handleError = do
139 err <- c_GetLastError
140 if err == eRROR_ENVVAR_NOT_FOUND
141 then ioe_missingEnvVar name
142 else throwGetLastError "getEnv"
143
144 eRROR_ENVVAR_NOT_FOUND :: DWORD
145 eRROR_ENVVAR_NOT_FOUND = 203
146
147 foreign import WINDOWS_CCONV unsafe "windows.h GetLastError"
148 c_GetLastError:: IO DWORD
149
150 #else
151 handleError = ioe_missingEnvVar name
152 #endif
153
154 -- | Return the value of the environment variable @var@, or @Nothing@ if
155 -- there is no such value.
156 --
157 -- For POSIX users, this is equivalent to 'System.Posix.Env.getEnv'.
158 --
159 -- @since 4.6.0.0
160 lookupEnv :: String -> IO (Maybe String)
161 #if defined(mingw32_HOST_OS)
162 lookupEnv name = withCWString name $ \s -> try_size s 256
163 where
164 try_size s size = allocaArray (fromIntegral size) $ \p_value -> do
165 res <- c_GetEnvironmentVariable s p_value size
166 case res of
167 0 -> return Nothing
168 _ | res > size -> try_size s res -- Rare: size increased between calls to GetEnvironmentVariable
169 | otherwise -> peekCWString p_value >>= return . Just
170
171 foreign import WINDOWS_CCONV unsafe "windows.h GetEnvironmentVariableW"
172 c_GetEnvironmentVariable :: LPWSTR -> LPWSTR -> DWORD -> IO DWORD
173 #else
174 lookupEnv name =
175 withCString name $ \s -> do
176 litstring <- c_getenv s
177 if litstring /= nullPtr
178 then do enc <- getFileSystemEncoding
179 result <- GHC.peekCString enc litstring
180 return $ Just result
181 else return Nothing
182
183 foreign import ccall unsafe "getenv"
184 c_getenv :: CString -> IO (Ptr CChar)
185 #endif
186
187 ioe_missingEnvVar :: String -> IO a
188 ioe_missingEnvVar name = ioException (IOError Nothing NoSuchThing "getEnv"
189 "no environment variable" Nothing (Just name))
190
191 -- | @setEnv name value@ sets the specified environment variable to @value@.
192 --
193 -- On Windows setting an environment variable to the /empty string/ removes
194 -- that environment variable from the environment. For the sake of
195 -- compatibility we adopt that behavior. In particular
196 --
197 -- @
198 -- setEnv name \"\"
199 -- @
200 --
201 -- has the same effect as
202 --
203 -- @
204 -- `unsetEnv` name
205 -- @
206 --
207 -- If you don't care about Windows support and want to set an environment
208 -- variable to the empty string use @System.Posix.Env.setEnv@ from the @unix@
209 -- package instead.
210 --
211 -- Throws `Control.Exception.IOException` if @name@ is the empty string or
212 -- contains an equals sign.
213 --
214 -- @since 4.7.0.0
215 setEnv :: String -> String -> IO ()
216 setEnv key_ value_
217 | null key = throwIO (mkIOError InvalidArgument "setEnv" Nothing Nothing)
218 | '=' `elem` key = throwIO (mkIOError InvalidArgument "setEnv" Nothing Nothing)
219 | null value = unsetEnv key
220 | otherwise = setEnv_ key value
221 where
222 key = takeWhile (/= '\NUL') key_
223 value = takeWhile (/= '\NUL') value_
224
225 setEnv_ :: String -> String -> IO ()
226 #if defined(mingw32_HOST_OS)
227 setEnv_ key value = withCWString key $ \k -> withCWString value $ \v -> do
228 success <- c_SetEnvironmentVariable k v
229 unless success (throwGetLastError "setEnv")
230
231 foreign import WINDOWS_CCONV unsafe "windows.h SetEnvironmentVariableW"
232 c_SetEnvironmentVariable :: LPTSTR -> LPTSTR -> IO Bool
233 #else
234
235 -- NOTE: The 'setenv()' function is not available on all systems, hence we use
236 -- 'putenv()'. This leaks memory, but so do common implementations of
237 -- 'setenv()' (AFAIK).
238 setEnv_ k v = putEnv (k ++ "=" ++ v)
239
240 putEnv :: String -> IO ()
241 putEnv keyvalue = do
242 s <- getFileSystemEncoding >>= (`GHC.newCString` keyvalue)
243 -- IMPORTANT: Do not free `s` after calling putenv!
244 --
245 -- According to SUSv2, the string passed to putenv becomes part of the
246 -- environment.
247 throwErrnoIf_ (/= 0) "putenv" (c_putenv s)
248
249 foreign import ccall unsafe "putenv" c_putenv :: CString -> IO CInt
250 #endif
251
252 -- | @unsetEnv name@ removes the specified environment variable from the
253 -- environment of the current process.
254 --
255 -- Throws `Control.Exception.IOException` if @name@ is the empty string or
256 -- contains an equals sign.
257 --
258 -- @since 4.7.0.0
259 unsetEnv :: String -> IO ()
260 #if defined(mingw32_HOST_OS)
261 unsetEnv key = withCWString key $ \k -> do
262 success <- c_SetEnvironmentVariable k nullPtr
263 unless success $ do
264 -- We consider unsetting an environment variable that does not exist not as
265 -- an error, hence we ignore eRROR_ENVVAR_NOT_FOUND.
266 err <- c_GetLastError
267 unless (err == eRROR_ENVVAR_NOT_FOUND) $ do
268 throwGetLastError "unsetEnv"
269 #else
270
271 #if defined(HAVE_UNSETENV)
272 unsetEnv key = withFilePath key (throwErrnoIf_ (/= 0) "unsetEnv" . c_unsetenv)
273 foreign import ccall unsafe "__hsbase_unsetenv" c_unsetenv :: CString -> IO CInt
274 #else
275 unsetEnv key = setEnv_ key ""
276 #endif
277
278 #endif
279
280 {-|
281 'withArgs' @args act@ - while executing action @act@, have 'getArgs'
282 return @args@.
283 -}
284 withArgs :: [String] -> IO a -> IO a
285 withArgs xs act = do
286 p <- System.Environment.getProgName
287 withArgv (p:xs) act
288
289 {-|
290 'withProgName' @name act@ - while executing action @act@,
291 have 'getProgName' return @name@.
292 -}
293 withProgName :: String -> IO a -> IO a
294 withProgName nm act = do
295 xs <- System.Environment.getArgs
296 withArgv (nm:xs) act
297
298 -- Worker routine which marshals and replaces an argv vector for
299 -- the duration of an action.
300
301 withArgv :: [String] -> IO a -> IO a
302 withArgv = withProgArgv
303
304 withProgArgv :: [String] -> IO a -> IO a
305 withProgArgv new_args act = do
306 pName <- System.Environment.getProgName
307 existing_args <- System.Environment.getArgs
308 bracket_ (setProgArgv new_args)
309 (setProgArgv (pName:existing_args))
310 act
311
312 setProgArgv :: [String] -> IO ()
313 setProgArgv argv = do
314 enc <- argvEncoding
315 GHC.withCStringsLen enc argv $ \len css ->
316 c_setProgArgv (fromIntegral len) css
317
318 -- setProgArgv copies the arguments
319 foreign import ccall unsafe "setProgArgv"
320 c_setProgArgv :: CInt -> Ptr CString -> IO ()
321
322 -- |'getEnvironment' retrieves the entire environment as a
323 -- list of @(key,value)@ pairs.
324 --
325 -- If an environment entry does not contain an @\'=\'@ character,
326 -- the @key@ is the whole entry and the @value@ is the empty string.
327 getEnvironment :: IO [(String, String)]
328
329 #if defined(mingw32_HOST_OS)
330 getEnvironment = bracket c_GetEnvironmentStrings c_FreeEnvironmentStrings $ \pBlock ->
331 if pBlock == nullPtr then return []
332 else go pBlock
333 where
334 go pBlock = do
335 -- The block is terminated by a null byte where there
336 -- should be an environment variable of the form X=Y
337 c <- peek pBlock
338 if c == 0 then return []
339 else do
340 -- Seek the next pair (or terminating null):
341 pBlock' <- seekNull pBlock False
342 -- We now know the length in bytes, but ignore it when
343 -- getting the actual String:
344 str <- peekCWString pBlock
345 fmap (divvy str :) $ go pBlock'
346
347 -- Returns pointer to the byte *after* the next null
348 seekNull pBlock done = do
349 let pBlock' = pBlock `plusPtr` sizeOf (undefined :: CWchar)
350 if done then return pBlock'
351 else do
352 c <- peek pBlock'
353 seekNull pBlock' (c == (0 :: Word8 ))
354
355 foreign import WINDOWS_CCONV unsafe "windows.h GetEnvironmentStringsW"
356 c_GetEnvironmentStrings :: IO (Ptr CWchar)
357
358 foreign import WINDOWS_CCONV unsafe "windows.h FreeEnvironmentStringsW"
359 c_FreeEnvironmentStrings :: Ptr CWchar -> IO Bool
360 #else
361 getEnvironment = do
362 pBlock <- getEnvBlock
363 if pBlock == nullPtr then return []
364 else do
365 enc <- getFileSystemEncoding
366 stuff <- peekArray0 nullPtr pBlock >>= mapM (GHC.peekCString enc)
367 return (map divvy stuff)
368
369 foreign import ccall unsafe "__hscore_environ"
370 getEnvBlock :: IO (Ptr CString)
371 #endif
372
373 divvy :: String -> (String, String)
374 divvy str =
375 case break (=='=') str of
376 (xs,[]) -> (xs,[]) -- don't barf (like Posix.getEnvironment)
377 (name,_:value) -> (name,value)