X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=System%2FEnvironment.hs;h=247a905e055980b6a06f330f8fb21e7430142e4c;hb=8afc9fecd586d3c4f7ef9c69fb1686a79e5f441d;hp=25131da073cee1d8ac507ab118475e041c73c1fc;hpb=ca606df5fd7f8ba284659c44c0eff67ab79fa93f;p=ghc-base.git diff --git a/System/Environment.hs b/System/Environment.hs index 25131da..247a905 100644 --- a/System/Environment.hs +++ b/System/Environment.hs @@ -13,25 +13,29 @@ ----------------------------------------------------------------------------- module System.Environment - ( - getArgs, -- :: IO [String] + ( + getArgs, -- :: IO [String] getProgName, -- :: IO String getEnv, -- :: String -> IO String #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 ( bracket ) +import Control.Exception.Base ( bracket ) import Control.Monad -import GHC.IOBase -#include "config.h" +-- import GHC.IO +import GHC.IO.Exception #endif #ifdef __HUGS__ @@ -54,15 +58,15 @@ import System #ifdef __GLASGOW_HASKELL__ getArgs :: IO [String] -getArgs = - alloca $ \ p_argc -> +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 () @@ -77,15 +81,15 @@ between platforms: on Windows, for example, a program invoked as foo is probably really @FOO.EXE@, and that is what 'getProgName' will return. -} getProgName :: IO String -getProgName = +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 -- argv[0] -unpackProgName argv = do + +unpackProgName :: Ptr (Ptr CChar) -> IO String -- argv[0] +unpackProgName argv = do s <- peekElemOff argv 0 >>= peekCString return (basename s) where @@ -93,13 +97,13 @@ unpackProgName argv = do basename f = go f f where go acc [] = acc - go acc (x:xs) + go acc (x:xs) | isPathSeparator x = go xs xs | otherwise = go acc xs isPathSeparator :: Char -> Bool isPathSeparator '/' = True -#ifdef mingw32_TARGET_OS +#ifdef mingw32_HOST_OS isPathSeparator '\\' = True #endif isPathSeparator _ = False @@ -118,15 +122,15 @@ getEnv name = withCString name $ \s -> do litstring <- c_getenv s if litstring /= nullPtr - then peekCString litstring + then peekCString litstring else ioException (IOError Nothing NoSuchThing "getEnv" - "no environment variable" (Just name)) + "no environment variable" Nothing (Just name)) foreign import ccall unsafe "getenv" c_getenv :: CString -> IO (Ptr CChar) {-| -@withArgs args act@ - while executing action @act@, have 'System.getArgs' +'withArgs' @args act@ - while executing action @act@, have 'getArgs' return @args@. -} withArgs :: [String] -> IO a -> IO a @@ -135,8 +139,8 @@ withArgs xs act = do withArgv (p:xs) act {-| -@withProgName name act@ - while executing action @act@, -have 'System.getProgName' return @name@. +'withProgName' @name act@ - while executing action @act@, +have 'getProgName' return @name@. -} withProgName :: String -> IO a -> IO a withProgName nm act = do @@ -150,9 +154,9 @@ 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) + bracket (setArgs new_args) + (\argv -> do setArgs (pName:existing_args); freeArgv argv) + (const act) freeArgv :: Ptr CString -> IO () freeArgv argv = do @@ -163,9 +167,31 @@ freeArgv argv = do setArgs :: [String] -> IO (Ptr CString) setArgs argv = do vs <- mapM newCString argv >>= newArray0 nullPtr - setArgsPrim (length argv) vs + setArgsPrim (genericLength argv) vs return vs foreign import ccall unsafe "setProgArgv" - setArgsPrim :: Int -> Ptr CString -> IO () + setArgsPrim :: CInt -> Ptr CString -> IO () + +-- |'getEnvironment' retrieves the entire environment as a +-- list of @(key,value)@ pairs. +-- +-- If an environment entry does not contain an @\'=\'@ character, +-- the @key@ is the whole entry and the @value@ is the empty string. + +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,[]) -- don't barf (like Posix.getEnvironment) + (name,_:value) -> (name,value) + +foreign import ccall unsafe "__hscore_environ" + getEnvBlock :: IO (Ptr CString) #endif /* __GLASGOW_HASKELL__ */