X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=System%2FEnvironment.hs;h=247a905e055980b6a06f330f8fb21e7430142e4c;hb=8afc9fecd586d3c4f7ef9c69fb1686a79e5f441d;hp=6b7c57075a8c4e07998bb46b9e026968f4446587;hpb=260e7f2ed9a43c6ecf5a556d77817f39ed2893ab;p=ghc-base.git diff --git a/System/Environment.hs b/System/Environment.hs index 6b7c570..247a905 100644 --- a/System/Environment.hs +++ b/System/Environment.hs @@ -1,67 +1,95 @@ ----------------------------------------------------------------------------- --- +-- | -- 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.3 2001/12/21 15:07:26 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 "getProgArgv" unsafe + +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 @@ -69,32 +97,101 @@ 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 "getenv" unsafe +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__ */