{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE CPP #-}
module GHC.Internal.System.Environment
(
getArgs,
getProgName,
executablePath,
getExecutablePath,
getEnv,
lookupEnv,
setEnv,
unsetEnv,
withArgs,
withProgName,
getEnvironment,
) where
import GHC.Internal.Data.Maybe (maybe)
import GHC.Internal.Ptr
import GHC.Internal.Foreign.C.Types
#if !defined(mingw32_HOST_OS)
import GHC.Internal.Foreign.C.Error
#endif
import GHC.Internal.Foreign.Marshal.Alloc
import GHC.Internal.Foreign.Marshal.Array
import GHC.Internal.Foreign.Storable
import GHC.Internal.Foreign.C.String
import qualified GHC.Internal.Foreign.C.String.Encoding as Enc
import GHC.Internal.System.IO.Error (mkIOError)
import GHC.Internal.Control.Exception.Base (bracket_, throwIO)
#if defined(mingw32_HOST_OS)
import GHC.Internal.Control.Exception.Base (bracket)
#endif
import GHC.Internal.Base
import GHC.Internal.List (null, elem, takeWhile, break)
import GHC.Internal.Num
import GHC.Internal.Real (fromIntegral)
import GHC.Internal.IO (FilePath)
import GHC.Internal.IO.Exception
#if defined(mingw32_HOST_OS)
import GHC.Internal.Control.Monad (unless)
import GHC.Internal.IO.Encoding (argvEncoding)
import GHC.Internal.Windows
import GHC.Internal.Word
#else
import GHC.Internal.IO.Encoding (getFileSystemEncoding, argvEncoding)
import GHC.Internal.System.Posix.Internals (withFilePath)
#endif
import GHC.Internal.System.Environment.ExecutablePath
#if defined(mingw32_HOST_OS)
# if defined(i386_HOST_ARCH)
# define WINDOWS_CCONV stdcall
# elif defined(x86_64_HOST_ARCH)
# define WINDOWS_CCONV ccall
# else
# error Unknown mingw32 arch
# endif
#endif
#include "HsBaseConfig.h"
getArgs :: IO [String]
getArgs :: IO [String]
getArgs =
(Ptr CInt -> IO [String]) -> IO [String]
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CInt -> IO [String]) -> IO [String])
-> (Ptr CInt -> IO [String]) -> IO [String]
forall a b. (a -> b) -> a -> b
$ \ Ptr CInt
p_argc ->
(Ptr (Ptr (Ptr CChar)) -> IO [String]) -> IO [String]
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr (Ptr (Ptr CChar)) -> IO [String]) -> IO [String])
-> (Ptr (Ptr (Ptr CChar)) -> IO [String]) -> IO [String]
forall a b. (a -> b) -> a -> b
$ \ Ptr (Ptr (Ptr CChar))
p_argv -> do
Ptr CInt -> Ptr (Ptr (Ptr CChar)) -> IO ()
getProgArgv Ptr CInt
p_argc Ptr (Ptr (Ptr CChar))
p_argv
p <- CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CInt -> Int) -> IO CInt -> IO Int
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` Ptr CInt -> IO CInt
forall a. Storable a => Ptr a -> IO a
peek Ptr CInt
p_argc
argv <- peek p_argv
enc <- argvEncoding
peekArray (p - 1) (advancePtr argv 1) >>= mapM (Enc.peekCString enc)
foreign import ccall unsafe "getProgArgv"
getProgArgv :: Ptr CInt -> Ptr (Ptr CString) -> IO ()
getProgName :: IO String
getProgName :: IO String
getProgName =
(Ptr CInt -> IO String) -> IO String
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CInt -> IO String) -> IO String)
-> (Ptr CInt -> IO String) -> IO String
forall a b. (a -> b) -> a -> b
$ \ Ptr CInt
p_argc ->
(Ptr (Ptr (Ptr CChar)) -> IO String) -> IO String
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr (Ptr (Ptr CChar)) -> IO String) -> IO String)
-> (Ptr (Ptr (Ptr CChar)) -> IO String) -> IO String
forall a b. (a -> b) -> a -> b
$ \ Ptr (Ptr (Ptr CChar))
p_argv -> do
Ptr CInt -> Ptr (Ptr (Ptr CChar)) -> IO ()
getProgArgv Ptr CInt
p_argc Ptr (Ptr (Ptr CChar))
p_argv
argv <- Ptr (Ptr (Ptr CChar)) -> IO (Ptr (Ptr CChar))
forall a. Storable a => Ptr a -> IO a
peek Ptr (Ptr (Ptr CChar))
p_argv
unpackProgName argv
unpackProgName :: Ptr (Ptr CChar) -> IO String
unpackProgName :: Ptr (Ptr CChar) -> IO String
unpackProgName Ptr (Ptr CChar)
argv = do
enc <- IO TextEncoding
argvEncoding
s <- peekElemOff argv 0 >>= Enc.peekCString enc
return (basename s)
basename :: FilePath -> FilePath
basename :: String -> String
basename String
f = String -> String -> String
go String
f String
f
where
go :: String -> String -> String
go String
acc [] = String
acc
go String
acc (Char
x:String
xs)
| Char -> Bool
isPathSeparator Char
x = String -> String -> String
go String
xs String
xs
| Bool
otherwise = String -> String -> String
go String
acc String
xs
isPathSeparator :: Char -> Bool
isPathSeparator :: Char -> Bool
isPathSeparator Char
'/' = Bool
True
#if defined(mingw32_HOST_OS)
isPathSeparator Char
'\\' = Bool
True
#endif
isPathSeparator Char
_ = Bool
False
getEnv :: String -> IO String
getEnv :: String -> IO String
getEnv String
name = String -> IO (Maybe String)
lookupEnv String
name IO (Maybe String) -> (Maybe String -> IO String) -> IO String
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO String -> (String -> IO String) -> Maybe String -> IO String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO String
forall {b}. IO b
handleError String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
where
#if defined(mingw32_HOST_OS)
handleError :: IO b
handleError = do
err <- IO DWORD
c_GetLastError
if err == eRROR_ENVVAR_NOT_FOUND
then ioe_missingEnvVar name
else throwGetLastError "getEnv"
eRROR_ENVVAR_NOT_FOUND :: DWORD
eRROR_ENVVAR_NOT_FOUND :: DWORD
eRROR_ENVVAR_NOT_FOUND = DWORD
203
foreign import WINDOWS_CCONV unsafe "windows.h GetLastError"
c_GetLastError:: IO DWORD
#else
handleError = ioe_missingEnvVar name
#endif
lookupEnv :: String -> IO (Maybe String)
#if defined(mingw32_HOST_OS)
lookupEnv :: String -> IO (Maybe String)
lookupEnv String
name = String -> (Ptr CWchar -> IO (Maybe String)) -> IO (Maybe String)
forall a. String -> (Ptr CWchar -> IO a) -> IO a
withCWString String
name ((Ptr CWchar -> IO (Maybe String)) -> IO (Maybe String))
-> (Ptr CWchar -> IO (Maybe String)) -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ \Ptr CWchar
s -> Ptr CWchar -> DWORD -> IO (Maybe String)
try_size Ptr CWchar
s DWORD
256
where
try_size :: Ptr CWchar -> DWORD -> IO (Maybe String)
try_size Ptr CWchar
s DWORD
size = Int -> (Ptr CWchar -> IO (Maybe String)) -> IO (Maybe String)
forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray (DWORD -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral DWORD
size) ((Ptr CWchar -> IO (Maybe String)) -> IO (Maybe String))
-> (Ptr CWchar -> IO (Maybe String)) -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ \Ptr CWchar
p_value -> do
res <- Ptr CWchar -> Ptr CWchar -> DWORD -> IO DWORD
c_GetEnvironmentVariable Ptr CWchar
s Ptr CWchar
p_value DWORD
size
case res of
DWORD
0 -> Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
DWORD
_ | DWORD
res DWORD -> DWORD -> Bool
forall a. Ord a => a -> a -> Bool
> DWORD
size -> Ptr CWchar -> DWORD -> IO (Maybe String)
try_size Ptr CWchar
s DWORD
res
| Bool
otherwise -> Ptr CWchar -> IO String
peekCWString Ptr CWchar
p_value IO String -> (String -> IO (Maybe String)) -> IO (Maybe String)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO (Maybe String))
-> (String -> Maybe String) -> String -> IO (Maybe String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe String
forall a. a -> Maybe a
Just
foreign import WINDOWS_CCONV unsafe "windows.h GetEnvironmentVariableW"
c_GetEnvironmentVariable :: LPWSTR -> LPWSTR -> DWORD -> IO DWORD
#else
lookupEnv name =
withCString name $ \s -> do
litstring <- c_getenv s
if litstring /= nullPtr
then do enc <- getFileSystemEncoding
result <- Enc.peekCString enc litstring
return $ Just result
else return Nothing
foreign import ccall unsafe "getenv"
c_getenv :: CString -> IO (Ptr CChar)
#endif
ioe_missingEnvVar :: String -> IO a
ioe_missingEnvVar :: forall a. String -> IO a
ioe_missingEnvVar String
name = IOError -> IO a
forall a. HasCallStack => IOError -> IO a
ioException (Maybe Handle
-> IOErrorType
-> String
-> String
-> Maybe CInt
-> Maybe String
-> IOError
IOError Maybe Handle
forall a. Maybe a
Nothing IOErrorType
NoSuchThing String
"getEnv"
String
"no environment variable" Maybe CInt
forall a. Maybe a
Nothing (String -> Maybe String
forall a. a -> Maybe a
Just String
name))
setEnv :: String -> String -> IO ()
setEnv :: String -> String -> IO ()
setEnv String
key_ String
value_
| String -> Bool
forall a. [a] -> Bool
null String
key = IOError -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (IOErrorType -> String -> Maybe Handle -> Maybe String -> IOError
mkIOError IOErrorType
InvalidArgument String
"setEnv" Maybe Handle
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing)
| Char
'=' Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
`elem` String
key = IOError -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (IOErrorType -> String -> Maybe Handle -> Maybe String -> IOError
mkIOError IOErrorType
InvalidArgument String
"setEnv" Maybe Handle
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing)
| String -> Bool
forall a. [a] -> Bool
null String
value = String -> IO ()
unsetEnv String
key
| Bool
otherwise = String -> String -> IO ()
setEnv_ String
key String
value
where
key :: String
key = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\NUL') String
key_
value :: String
value = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\NUL') String
value_
setEnv_ :: String -> String -> IO ()
#if defined(mingw32_HOST_OS)
setEnv_ :: String -> String -> IO ()
setEnv_ String
key String
value = String -> (Ptr CWchar -> IO ()) -> IO ()
forall a. String -> (Ptr CWchar -> IO a) -> IO a
withCWString String
key ((Ptr CWchar -> IO ()) -> IO ()) -> (Ptr CWchar -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr CWchar
k -> String -> (Ptr CWchar -> IO ()) -> IO ()
forall a. String -> (Ptr CWchar -> IO a) -> IO a
withCWString String
value ((Ptr CWchar -> IO ()) -> IO ()) -> (Ptr CWchar -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr CWchar
v -> do
success <- Ptr CWchar -> Ptr CWchar -> IO Bool
c_SetEnvironmentVariable Ptr CWchar
k Ptr CWchar
v
unless success (throwGetLastError "setEnv")
foreign import WINDOWS_CCONV unsafe "windows.h SetEnvironmentVariableW"
c_SetEnvironmentVariable :: LPTSTR -> LPTSTR -> IO Bool
#else
setEnv_ k v = putEnv (k ++ "=" ++ v)
putEnv :: String -> IO ()
putEnv keyvalue = do
s <- getFileSystemEncoding >>= (`Enc.newCString` keyvalue)
throwErrnoIf_ (/= 0) "putenv" (c_putenv s)
foreign import ccall unsafe "putenv" c_putenv :: CString -> IO CInt
#endif
unsetEnv :: String -> IO ()
#if defined(mingw32_HOST_OS)
unsetEnv :: String -> IO ()
unsetEnv String
key = String -> (Ptr CWchar -> IO ()) -> IO ()
forall a. String -> (Ptr CWchar -> IO a) -> IO a
withCWString String
key ((Ptr CWchar -> IO ()) -> IO ()) -> (Ptr CWchar -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr CWchar
k -> do
success <- Ptr CWchar -> Ptr CWchar -> IO Bool
c_SetEnvironmentVariable Ptr CWchar
k Ptr CWchar
forall a. Ptr a
nullPtr
unless success $ do
err <- c_GetLastError
unless (err == eRROR_ENVVAR_NOT_FOUND) $ do
throwGetLastError "unsetEnv"
#else
#if defined(HAVE_UNSETENV)
unsetEnv key = withFilePath key (throwErrnoIf_ (/= 0) "unsetEnv" . c_unsetenv)
foreign import ccall unsafe "__hsbase_unsetenv" c_unsetenv :: CString -> IO CInt
#else
unsetEnv key = setEnv_ key ""
#endif
#endif
withArgs :: [String] -> IO a -> IO a
withArgs :: forall a. [String] -> IO a -> IO a
withArgs [String]
xs IO a
act = do
p <- IO String
GHC.Internal.System.Environment.getProgName
withArgv (p:xs) act
withProgName :: String -> IO a -> IO a
withProgName :: forall a. String -> IO a -> IO a
withProgName String
nm IO a
act = do
xs <- IO [String]
GHC.Internal.System.Environment.getArgs
withArgv (nm:xs) act
withArgv :: [String] -> IO a -> IO a
withArgv :: forall a. [String] -> IO a -> IO a
withArgv = [String] -> IO a -> IO a
forall a. [String] -> IO a -> IO a
withProgArgv
withProgArgv :: [String] -> IO a -> IO a
withProgArgv :: forall a. [String] -> IO a -> IO a
withProgArgv [String]
new_args IO a
act = do
pName <- IO String
GHC.Internal.System.Environment.getProgName
existing_args <- GHC.Internal.System.Environment.getArgs
bracket_ (setProgArgv new_args)
(setProgArgv (pName:existing_args))
act
setProgArgv :: [String] -> IO ()
setProgArgv :: [String] -> IO ()
setProgArgv [String]
argv = do
enc <- IO TextEncoding
argvEncoding
Enc.withCStringsLen enc argv $ \Int
len Ptr (Ptr CChar)
css ->
CInt -> Ptr (Ptr CChar) -> IO ()
c_setProgArgv (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len) Ptr (Ptr CChar)
css
foreign import ccall unsafe "setProgArgv"
c_setProgArgv :: CInt -> Ptr CString -> IO ()
getEnvironment :: IO [(String, String)]
#if defined(mingw32_HOST_OS)
getEnvironment :: IO [(String, String)]
getEnvironment = IO (Ptr CWchar)
-> (Ptr CWchar -> IO Bool)
-> (Ptr CWchar -> IO [(String, String)])
-> IO [(String, String)]
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO (Ptr CWchar)
c_GetEnvironmentStrings Ptr CWchar -> IO Bool
c_FreeEnvironmentStrings ((Ptr CWchar -> IO [(String, String)]) -> IO [(String, String)])
-> (Ptr CWchar -> IO [(String, String)]) -> IO [(String, String)]
forall a b. (a -> b) -> a -> b
$ \Ptr CWchar
pBlock ->
if Ptr CWchar
pBlock Ptr CWchar -> Ptr CWchar -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr CWchar
forall a. Ptr a
nullPtr then [(String, String)] -> IO [(String, String)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
else Ptr CWchar -> IO [(String, String)]
go Ptr CWchar
pBlock
where
go :: Ptr CWchar -> IO [(String, String)]
go Ptr CWchar
pBlock = do
c <- Ptr CWchar -> IO CWchar
forall a. Storable a => Ptr a -> IO a
peek Ptr CWchar
pBlock
if c == 0 then return []
else do
pBlock' <- seekNull pBlock False
str <- peekCWString pBlock
fmap (divvy str :) $ go pBlock'
seekNull :: Ptr b -> Bool -> IO (Ptr b)
seekNull Ptr b
pBlock Bool
done = do
let pBlock' :: Ptr b
pBlock' = Ptr b
pBlock Ptr b -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` CWchar -> Int
forall a. Storable a => a -> Int
sizeOf (CWchar
forall a. HasCallStack => a
undefined :: CWchar)
if Bool
done then Ptr b -> IO (Ptr b)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Ptr b
forall a. Ptr a
pBlock'
else do
c <- Ptr Word8 -> IO Word8
forall a. Storable a => Ptr a -> IO a
peek Ptr Word8
forall a. Ptr a
pBlock'
seekNull pBlock' (c == (0 :: Word8 ))
foreign import WINDOWS_CCONV unsafe "windows.h GetEnvironmentStringsW"
c_GetEnvironmentStrings :: IO (Ptr CWchar)
foreign import WINDOWS_CCONV unsafe "windows.h FreeEnvironmentStringsW"
c_FreeEnvironmentStrings :: Ptr CWchar -> IO Bool
#else
getEnvironment = do
pBlock <- getEnvBlock
if pBlock == nullPtr then return []
else do
enc <- getFileSystemEncoding
stuff <- peekArray0 nullPtr pBlock >>= mapM (Enc.peekCString enc)
return (map divvy stuff)
foreign import ccall unsafe "__hscore_environ"
getEnvBlock :: IO (Ptr CString)
#endif
divvy :: String -> (String, String)
divvy :: String -> (String, String)
divvy String
str =
case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'=') String
str of
(String
xs,[]) -> (String
xs,[])
(String
name,Char
_:String
value) -> (String
name,String
value)