module System.Environment
(
getArgs,
getProgName,
getEnv,
#ifndef __NHC__
withArgs,
withProgName,
#endif
#ifdef __GLASGOW_HASKELL__
getEnvironment,
#endif
) where
import Prelude
#ifdef __GLASGOW_HASKELL__
import Data.List
import Foreign
import Foreign.C
import Control.Exception.Base ( bracket )
import Control.Monad
import GHC.IO.Exception
#endif
#ifdef __HUGS__
import Hugs.System
#endif
#ifdef __NHC__
import System
( getArgs
, getProgName
, getEnv
)
#endif
#ifdef __GLASGOW_HASKELL__
getArgs :: IO [String]
getArgs =
alloca $ \ p_argc ->
alloca $ \ p_argv -> do
getProgArgv p_argc p_argv
p <- fromIntegral `liftM` peek p_argc
argv <- peek p_argv
peekArray (p 1) (advancePtr argv 1) >>= mapM peekCString
foreign import ccall unsafe "getProgArgv"
getProgArgv :: Ptr CInt -> Ptr (Ptr CString) -> IO ()
getProgName :: IO String
getProgName =
alloca $ \ p_argc ->
alloca $ \ p_argv -> do
getProgArgv p_argc p_argv
argv <- peek p_argv
unpackProgName argv
unpackProgName :: Ptr (Ptr CChar) -> IO String
unpackProgName argv = do
s <- peekElemOff argv 0 >>= peekCString
return (basename s)
where
basename :: String -> String
basename f = go f f
where
go acc [] = acc
go acc (x:xs)
| isPathSeparator x = go xs xs
| otherwise = go acc xs
isPathSeparator :: Char -> Bool
isPathSeparator '/' = True
#ifdef mingw32_HOST_OS
isPathSeparator '\\' = True
#endif
isPathSeparator _ = False
getEnv :: String -> IO String
getEnv name =
withCString name $ \s -> do
litstring <- c_getenv s
if litstring /= nullPtr
then peekCString litstring
else ioException (IOError Nothing NoSuchThing "getEnv"
"no environment variable" Nothing (Just name))
foreign import ccall unsafe "getenv"
c_getenv :: CString -> IO (Ptr CChar)
withArgs :: [String] -> IO a -> IO a
withArgs xs act = do
p <- System.Environment.getProgName
withArgv (p:xs) act
withProgName :: String -> IO a -> IO a
withProgName nm act = do
xs <- System.Environment.getArgs
withArgv (nm:xs) act
withArgv :: [String] -> IO a -> IO a
withArgv new_args act = do
pName <- System.Environment.getProgName
existing_args <- System.Environment.getArgs
bracket (setArgs new_args)
(\argv -> do _ <- setArgs (pName:existing_args)
freeArgv argv)
(const act)
freeArgv :: Ptr CString -> IO ()
freeArgv argv = do
size <- lengthArray0 nullPtr argv
sequence_ [peek (argv `advancePtr` i) >>= free | i <- [size, size1 .. 0]]
free argv
setArgs :: [String] -> IO (Ptr CString)
setArgs argv = do
vs <- mapM newCString argv >>= newArray0 nullPtr
setArgsPrim (genericLength argv) vs
return vs
foreign import ccall unsafe "setProgArgv"
setArgsPrim :: CInt -> Ptr CString -> IO ()
getEnvironment :: IO [(String, String)]
getEnvironment = do
pBlock <- getEnvBlock
if pBlock == nullPtr then return []
else do
stuff <- peekArray0 nullPtr pBlock >>= mapM peekCString
return (map divvy stuff)
where
divvy str =
case break (=='=') str of
(xs,[]) -> (xs,[])
(name,_:value) -> (name,value)
foreign import ccall unsafe "__hscore_environ"
getEnvBlock :: IO (Ptr CString)
#endif /* __GLASGOW_HASKELL__ */