X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=System%2FEnvironment.hs;h=2b6dec272d6df2a74278c75c80e7463353181a22;hb=41e8fba828acbae1751628af50849f5352b27873;hp=117b7db0a3d24610838429688022ba6dfd566dc9;hpb=9fa9bc17072a58c0bae2cce4764d38677e96ac29;p=ghc-base.git diff --git a/System/Environment.hs b/System/Environment.hs index 117b7db..2b6dec2 100644 --- a/System/Environment.hs +++ b/System/Environment.hs @@ -1,68 +1,97 @@ +{-# LANGUAGE CPP, ForeignFunctionInterface #-} + ----------------------------------------------------------------------------- -- | -- Module : System.Environment -- Copyright : (c) The University of Glasgow 2001 --- License : BSD-style (see the file libraries/core/LICENSE) +-- License : BSD-style (see the file libraries/base/LICENSE) -- -- Maintainer : libraries@haskell.org -- Stability : provisional -- Portability : portable -- --- $Id: Environment.hs,v 1.6 2002/04/24 16:31:45 simonmar Exp $ --- -- Miscellaneous information about the system environment. -- ----------------------------------------------------------------------------- module System.Environment - ( - , getArgs -- :: IO [String] - , getProgName -- :: IO String - , getEnv -- :: String -> 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.Base ( bracket ) import Control.Monad +-- import GHC.IO +import GHC.IO.Exception +#endif -#ifdef __GLASGOW_HASKELL__ -import GHC.IOBase +#ifdef __HUGS__ +import Hugs.System +#endif + +#ifdef __NHC__ +import System + ( getArgs + , getProgName + , getEnv + ) #endif -- --------------------------------------------------------------------------- -- getArgs, getProgName, getEnv --- Computation `getArgs' returns a list of the program's command +-- | Computation 'getArgs' returns a list of the program's command -- line arguments (not including the program name). +#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 () --- Computation `getProgName' returns the name of the program --- as it was invoked. +{-| +Computation 'getProgName' returns the name of the program as it was +invoked. +However, this is hard-to-impossible to implement on some non-Unix +OSes, so instead, for maximum portability, we just return the leafname +of the program as invoked. Even then there are some differences +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 @@ -70,32 +99,102 @@ 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 --- Computation `getEnv var' returns the value --- of the environment variable {\em var}. - --- This computation may fail with --- NoSuchThing: The environment variable does not exist. +-- | Computation 'getEnv' @var@ returns the value +-- of the environment variable @var@. +-- +-- This computation may fail with: +-- +-- * 'System.IO.Error.isDoesNotExistError' if the environment variable +-- does not exist. getEnv :: String -> IO String 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 'getArgs' +return @args@. +-} +withArgs :: [String] -> IO a -> IO a +withArgs xs act = do + p <- System.Environment.getProgName + withArgv (p:xs) act + +{-| +'withProgName' @name act@ - while executing action @act@, +have 'getProgName' return @name@. +-} +withProgName :: String -> IO a -> IO a +withProgName nm act = do + xs <- System.Environment.getArgs + withArgv (nm:xs) act + +-- Worker routine which marshals and replaces an argv vector for +-- the duration of an action. + +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, size-1 .. 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' 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__ */