X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=System%2FEnvironment.hs;h=cf73c3d9bc7df05506f425b03ea7302d0bed15fc;hb=1c5d86f9ab468292f9a52b079e25578ac83d07e2;hp=d2b0d38e541fb854b5ae6f15f18016614d3efa0c;hpb=7f1f4e7a695c402ddd3a1dc2cc7114e649a78ebc;p=ghc-base.git diff --git a/System/Environment.hs b/System/Environment.hs index d2b0d38..cf73c3d 100644 --- a/System/Environment.hs +++ b/System/Environment.hs @@ -1,83 +1,337 @@ +{-# 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.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 +import Control.Exception.Base ( bracket ) +-- import GHC.IO +import GHC.IO.Exception +import GHC.IO.Encoding (fileSystemEncoding) +import qualified GHC.Foreign as GHC +import Data.List +#ifdef mingw32_HOST_OS +import GHC.Environment +import GHC.Windows +#else +import Control.Monad +#endif +#endif -#ifdef __GLASGOW_HASKELL__ -import GHC.IOBase +#ifdef __HUGS__ +import Hugs.System +#endif + +#ifdef __NHC__ +import System + ( getArgs + , getProgName + , getEnv + ) #endif +#ifdef __GLASGOW_HASKELL__ -- --------------------------------------------------------------------------- -- getArgs, getProgName, getEnv --- Computation `getArgs' returns a list of the program's command --- line arguments (not including the program name). +#ifdef mingw32_HOST_OS + +-- Ignore the arguments to hs_init on Windows for the sake of Unicode compat + +getWin32ProgArgv_certainly :: IO [String] +getWin32ProgArgv_certainly = do + mb_argv <- getWin32ProgArgv + case mb_argv of + Nothing -> fmap dropRTSArgs getFullArgs + Just argv -> return argv +withWin32ProgArgv :: [String] -> IO a -> IO a +withWin32ProgArgv argv act = bracket begin setWin32ProgArgv (\_ -> act) + where + begin = do + mb_old_argv <- getWin32ProgArgv + setWin32ProgArgv (Just argv) + return mb_old_argv + +getWin32ProgArgv :: IO (Maybe [String]) +getWin32ProgArgv = alloca $ \p_argc -> alloca $ \p_argv -> do + c_getWin32ProgArgv p_argc p_argv + argc <- peek p_argc + argv_p <- peek p_argv + if argv_p == nullPtr + then return Nothing + else do + argv_ps <- peekArray (fromIntegral argc) argv_p + fmap Just $ mapM peekCWString argv_ps + +setWin32ProgArgv :: Maybe [String] -> IO () +setWin32ProgArgv Nothing = c_setWin32ProgArgv 0 nullPtr +setWin32ProgArgv (Just argv) = withMany withCWString argv $ \argv_ps -> withArrayLen argv_ps $ \argc argv_p -> do + c_setWin32ProgArgv (fromIntegral argc) argv_p + +foreign import ccall unsafe "getWin32ProgArgv" + c_getWin32ProgArgv :: Ptr CInt -> Ptr (Ptr CWString) -> IO () + +foreign import ccall unsafe "setWin32ProgArgv" + c_setWin32ProgArgv :: CInt -> Ptr CWString -> IO () + +dropRTSArgs :: [String] -> [String] +dropRTSArgs [] = [] +dropRTSArgs ("+RTS":rest) = dropRTSArgs (dropWhile (/= "-RTS") rest) +dropRTSArgs ("--RTS":rest) = rest +dropRTSArgs ("-RTS":rest) = dropRTSArgs rest +dropRTSArgs (arg:rest) = arg : dropRTSArgs rest + +#endif + +-- | Computation 'getArgs' returns a list of the program's command +-- line arguments (not including the program name). getArgs :: IO [String] -getArgs = do - argv <- peek prog_argv_label - argc <- peek prog_argc_label - peekArray (fromIntegral argc - 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 +#ifdef mingw32_HOST_OS +getArgs = fmap tail getWin32ProgArgv_certainly +#else +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 (GHC.peekCString fileSystemEncoding) + +foreign import ccall unsafe "getProgArgv" + getProgArgv :: Ptr CInt -> Ptr (Ptr CString) -> IO () +#endif --- 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 - -unpackProgName :: Ptr (Ptr CChar) -> IO String -- argv[0] -unpackProgName argv = do - s <- peekElemOff argv 0 >>= peekCString - return (de_slash "" 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 +#ifdef mingw32_HOST_OS +-- Ignore the arguments to hs_init on Windows for the sake of Unicode compat +getProgName = fmap (basename . head) getWin32ProgArgv_certainly +#else +getProgName = + alloca $ \ p_argc -> + alloca $ \ p_argv -> do + getProgArgv p_argc p_argv + argv <- peek p_argv + unpackProgName argv --- Computation `getEnv var' returns the value --- of the environment variable {\em var}. +unpackProgName :: Ptr (Ptr CChar) -> IO String -- argv[0] +unpackProgName argv = do + s <- peekElemOff argv 0 >>= GHC.peekCString fileSystemEncoding + return (basename s) +#endif --- This computation may fail with --- NoSuchThing: The environment variable does not exist. +basename :: FilePath -> FilePath +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 @var@. +-- +-- This computation may fail with: +-- +-- * 'System.IO.Error.isDoesNotExistError' if the environment variable +-- does not exist. getEnv :: String -> IO String +#ifdef mingw32_HOST_OS +getEnv name = withCWString name $ \s -> try_size s 256 + where + try_size s size = allocaArray (fromIntegral size) $ \p_value -> do + res <- c_GetEnvironmentVariable s p_value size + case res of + 0 -> do + err <- c_GetLastError + if err == eRROR_ENVVAR_NOT_FOUND + then ioe_missingEnvVar name + else throwGetLastError "getEnv" + _ | res > size -> try_size s res -- Rare: size increased between calls to GetEnvironmentVariable + | otherwise -> peekCWString p_value + +eRROR_ENVVAR_NOT_FOUND :: DWORD +eRROR_ENVVAR_NOT_FOUND = 203 + +foreign import stdcall unsafe "windows.h GetLastError" + c_GetLastError:: IO DWORD + +foreign import stdcall unsafe "windows.h GetEnvironmentVariableW" + c_GetEnvironmentVariable :: LPTSTR -> LPTSTR -> DWORD -> IO DWORD +#else 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)) + then GHC.peekCString fileSystemEncoding litstring + else ioe_missingEnvVar name + +foreign import ccall unsafe "getenv" + c_getenv :: CString -> IO (Ptr CChar) +#endif + +ioe_missingEnvVar :: String -> IO a +ioe_missingEnvVar name = ioException (IOError Nothing NoSuchThing "getEnv" + "no environment variable" Nothing (Just name)) + +{-| +'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 + +#ifdef mingw32_HOST_OS +-- We have to reflect the updated arguments in the RTS-side variables as +-- well, because the RTS still consults them for error messages and the like. +-- If we don't do this then ghc-e005 fails. +withArgv new_args act = withWin32ProgArgv new_args $ withProgArgv new_args act +#else +withArgv = withProgArgv +#endif + +withProgArgv :: [String] -> IO a -> IO a +withProgArgv new_args act = do + pName <- System.Environment.getProgName + existing_args <- System.Environment.getArgs + bracket (setProgArgv new_args) + (\argv -> do _ <- setProgArgv (pName:existing_args) + freeProgArgv argv) + (const act) + +freeProgArgv :: Ptr CString -> IO () +freeProgArgv argv = do + size <- lengthArray0 nullPtr argv + sequence_ [peek (argv `advancePtr` i) >>= free | i <- [size, size-1 .. 0]] + free argv + +setProgArgv :: [String] -> IO (Ptr CString) +setProgArgv argv = do + vs <- mapM (GHC.newCString fileSystemEncoding) argv >>= newArray0 nullPtr + c_setProgArgv (genericLength argv) vs + return vs + +foreign import ccall unsafe "setProgArgv" + c_setProgArgv :: 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)] + +#ifdef mingw32_HOST_OS +getEnvironment = bracket c_GetEnvironmentStrings c_FreeEnvironmentStrings $ \pBlock -> + if pBlock == nullPtr then return [] + else go pBlock + where + go pBlock = do + -- The block is terminated by a null byte where there + -- should be an environment variable of the form X=Y + c <- peek pBlock + if c == 0 then return [] + else do + -- Seek the next pair (or terminating null): + pBlock' <- seekNull pBlock False + -- We now know the length in bytes, but ignore it when + -- getting the actual String: + str <- peekCWString pBlock + fmap (divvy str :) $ go pBlock' + + -- Returns pointer to the byte *after* the next null + seekNull pBlock done = do + let pBlock' = pBlock `plusPtr` sizeOf (undefined :: CWchar) + if done then return pBlock' + else do + c <- peek pBlock' + seekNull pBlock' (c == (0 :: Word8 )) + +foreign import stdcall unsafe "windows.h GetEnvironmentStringsW" + c_GetEnvironmentStrings :: IO (Ptr CWchar) + +foreign import stdcall unsafe "windows.h FreeEnvironmentStringsW" + c_FreeEnvironmentStrings :: Ptr CWchar -> IO Bool +#else +getEnvironment = do + pBlock <- getEnvBlock + if pBlock == nullPtr then return [] + else do + stuff <- peekArray0 nullPtr pBlock >>= mapM (GHC.peekCString fileSystemEncoding) + return (map divvy stuff) + +foreign import ccall unsafe "__hscore_environ" + getEnvBlock :: IO (Ptr CString) +#endif -foreign import ccall "getenv" unsafe - c_getenv :: UnsafeCString -> IO (Ptr CChar) +divvy :: String -> (String, String) +divvy str = + case break (=='=') str of + (xs,[]) -> (xs,[]) -- don't barf (like Posix.getEnvironment) + (name,_:value) -> (name,value) +#endif /* __GLASGOW_HASKELL__ */