X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=System%2FEnvironment.hs;h=3271e29422e0adaf98c46412597bc8744a3d8940;hb=bb534f206682be14daf72b33c6105ab27295c6ac;hp=d2b0d38e541fb854b5ae6f15f18016614d3efa0c;hpb=7f1f4e7a695c402ddd3a1dc2cc7114e649a78ebc;p=ghc-base.git diff --git a/System/Environment.hs b/System/Environment.hs index d2b0d38..3271e29 100644 --- a/System/Environment.hs +++ b/System/Environment.hs @@ -1,83 +1,195 @@ ----------------------------------------------------------------------------- --- +-- | -- 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.1 2001/06/28 14:15:04 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 Foreign import Foreign.C - -#ifdef __GLASGOW_HASKELL__ +import Control.Exception ( bracket ) +import Control.Monad import GHC.IOBase #endif +#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 = do - argv <- peek prog_argv_label - argc <- peek prog_argc_label - peekArray (fromIntegral argc - 1) (advancePtr argv 1) >>= mapM peekCString +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 label "prog_argv" prog_argv_label :: Ptr (Ptr (Ptr CChar)) -foreign label "prog_argc" prog_argc_label :: Ptr CInt + +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 = do - argv <- peek prog_argv_label - unpackProgName argv - +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 s <- peekElemOff argv 0 >>= peekCString - return (de_slash "" s) + return (basename s) where - -- re-start accumulating at every '/' - de_slash :: String -> String -> String - de_slash acc [] = reverse acc - de_slash _acc ('/':xs) = de_slash [] xs - de_slash acc (x:xs) = de_slash (x:acc) xs + 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 --- 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 = - withUnsafeCString name $ \s -> do + withCString name $ \s -> do litstring <- c_getenv s if litstring /= nullPtr then peekCString litstring else ioException (IOError Nothing NoSuchThing "getEnv" "no environment variable" (Just name)) -foreign import ccall "getenv" unsafe - c_getenv :: UnsafeCString -> IO (Ptr CChar) +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 (length argv) vs + return vs + +foreign import ccall unsafe "setProgArgv" + setArgsPrim :: Int -> 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__ */