System/Environment.hs

   1 {-# LANGUAGE CPP, ForeignFunctionInterface #-}
   2
   3 -----------------------------------------------------------------------------
   4 -- |
   5 -- Module      :  System.Environment
   6 -- Copyright   :  (c) The University of Glasgow 2001
   7 -- License     :  BSD-style (see the file libraries/base/LICENSE)
   8 --
   9 -- Maintainer  :  libraries@haskell.org
  10 -- Stability   :  provisional
  11 -- Portability :  portable
  12 --
  13 -- Miscellaneous information about the system environment.
  14 --
  15 -----------------------------------------------------------------------------
  16
  17 module System.Environment
  18     (
  19       getArgs,       -- :: IO [String]
  20       getProgName,   -- :: IO String
  21       getEnv,        -- :: String -> IO String
  22 #ifndef __NHC__
  23       withArgs,
  24       withProgName,
  25 #endif
  26 #ifdef __GLASGOW_HASKELL__
  27       getEnvironment,
  28 #endif
  29   ) where
  30
  31 import Prelude
  32
  33 #ifdef __GLASGOW_HASKELL__
  34 import Foreign
  35 import Foreign.C
  36 import Control.Exception.Base   ( bracket )
  37 -- import GHC.IO
  38 import GHC.IO.Exception
  39 import GHC.IO.Encoding (fileSystemEncoding)
  40 import qualified GHC.Foreign as GHC
  41 import Data.List
  42 #ifdef mingw32_HOST_OS
  43 import GHC.Environment
  44 import GHC.Windows
  45 #else
  46 import Control.Monad
  47 #endif
  48 #endif
  49
  50 #ifdef __HUGS__
  51 import Hugs.System
  52 #endif
  53
  54 #ifdef __NHC__
  55 import System
  56   ( getArgs
  57   , getProgName
  58   , getEnv
  59   )
  60 #endif
  61
  62 #ifdef __GLASGOW_HASKELL__
  63 -- ---------------------------------------------------------------------------
  64 -- getArgs, getProgName, getEnv
  65
  66 #ifdef mingw32_HOST_OS
  67
  68 -- Ignore the arguments to hs_init on Windows for the sake of Unicode compat
  69
  70 getWin32ProgArgv_certainly :: IO [String]
  71 getWin32ProgArgv_certainly = do
  72         mb_argv <- getWin32ProgArgv
  73         case mb_argv of
  74           Nothing   -> fmap dropRTSArgs getFullArgs
  75           Just argv -> return argv
  76
  77 withWin32ProgArgv :: [String] -> IO a -> IO a
  78 withWin32ProgArgv argv act = bracket begin setWin32ProgArgv (\_ -> act)
  79   where
  80     begin = do
  81           mb_old_argv <- getWin32ProgArgv
  82           setWin32ProgArgv (Just argv)
  83           return mb_old_argv
  84
  85 getWin32ProgArgv :: IO (Maybe [String])
  86 getWin32ProgArgv = alloca $ \p_argc -> alloca $ \p_argv -> do
  87         c_getWin32ProgArgv p_argc p_argv
  88         argc <- peek p_argc
  89         argv_p <- peek p_argv
  90         if argv_p == nullPtr
  91          then return Nothing
  92          else do
  93           argv_ps <- peekArray (fromIntegral argc) argv_p
  94           fmap Just $ mapM peekCWString argv_ps
  95
  96 setWin32ProgArgv :: Maybe [String] -> IO ()
  97 setWin32ProgArgv Nothing = c_setWin32ProgArgv 0 nullPtr
  98 setWin32ProgArgv (Just argv) = withMany withCWString argv $ \argv_ps -> withArrayLen argv_ps $ \argc argv_p -> do
  99         c_setWin32ProgArgv (fromIntegral argc) argv_p
 100
 101 foreign import ccall unsafe "getWin32ProgArgv"
 102   c_getWin32ProgArgv :: Ptr CInt -> Ptr (Ptr CWString) -> IO ()
 103
 104 foreign import ccall unsafe "setWin32ProgArgv"
 105   c_setWin32ProgArgv :: CInt -> Ptr CWString -> IO ()
 106
 107 dropRTSArgs :: [String] -> [String]
 108 dropRTSArgs []             = []
 109 dropRTSArgs ("+RTS":rest)  = dropRTSArgs (dropWhile (/= "-RTS") rest)
 110 dropRTSArgs ("--RTS":rest) = rest
 111 dropRTSArgs ("-RTS":rest)  = dropRTSArgs rest
 112 dropRTSArgs (arg:rest)     = arg : dropRTSArgs rest
 113
 114 #endif
 115
 116 -- | Computation 'getArgs' returns a list of the program's command
 117 -- line arguments (not including the program name).
 118 getArgs :: IO [String]
 119
 120 #ifdef mingw32_HOST_OS
 121 getArgs =  fmap tail getWin32ProgArgv_certainly
 122 #else
 123 getArgs =
 124   alloca $ \ p_argc ->
 125   alloca $ \ p_argv -> do
 126    getProgArgv p_argc p_argv
 127    p    <- fromIntegral `liftM` peek p_argc
 128    argv <- peek p_argv
 129    peekArray (p - 1) (advancePtr argv 1) >>= mapM (GHC.peekCString fileSystemEncoding)
 130
 131 foreign import ccall unsafe "getProgArgv"
 132   getProgArgv :: Ptr CInt -> Ptr (Ptr CString) -> IO ()
 133 #endif
 134
 135 {-|
 136 Computation 'getProgName' returns the name of the program as it was
 137 invoked.
 138
 139 However, this is hard-to-impossible to implement on some non-Unix
 140 OSes, so instead, for maximum portability, we just return the leafname
 141 of the program as invoked. Even then there are some differences
 142 between platforms: on Windows, for example, a program invoked as foo
 143 is probably really @FOO.EXE@, and that is what 'getProgName' will return.
 144 -}
 145 getProgName :: IO String
 146 #ifdef mingw32_HOST_OS
 147 -- Ignore the arguments to hs_init on Windows for the sake of Unicode compat
 148 getProgName = fmap (basename . head) getWin32ProgArgv_certainly
 149 #else
 150 getProgName =
 151   alloca $ \ p_argc ->
 152   alloca $ \ p_argv -> do
 153      getProgArgv p_argc p_argv
 154      argv <- peek p_argv
 155      unpackProgName argv
 156
 157 unpackProgName  :: Ptr (Ptr CChar) -> IO String   -- argv[0]
 158 unpackProgName argv = do
 159   s <- peekElemOff argv 0 >>= GHC.peekCString fileSystemEncoding
 160   return (basename s)
 161 #endif
 162
 163 basename :: FilePath -> FilePath
 164 basename f = go f f
 165  where
 166   go acc [] = acc
 167   go acc (x:xs)
 168     | isPathSeparator x = go xs xs
 169     | otherwise         = go acc xs
 170
 171   isPathSeparator :: Char -> Bool
 172   isPathSeparator '/'  = True
 173 #ifdef mingw32_HOST_OS
 174   isPathSeparator '\\' = True
 175 #endif
 176   isPathSeparator _    = False
 177
 178
 179 -- | Computation 'getEnv' @var@ returns the value
 180 -- of the environment variable @var@.
 181 --
 182 -- This computation may fail with:
 183 --
 184 --  * 'System.IO.Error.isDoesNotExistError' if the environment variable
 185 --    does not exist.
 186
 187 getEnv :: String -> IO String
 188 #ifdef mingw32_HOST_OS
 189 getEnv name = withCWString name $ \s -> try_size s 256
 190   where
 191     try_size s size = allocaArray (fromIntegral size) $ \p_value -> do
 192       res <- c_GetEnvironmentVariable s p_value size
 193       case res of
 194         0 -> do
 195                   err <- c_GetLastError
 196                   if err == eRROR_ENVVAR_NOT_FOUND
 197                    then ioe_missingEnvVar name
 198                    else throwGetLastError "getEnv"
 199         _ | res > size -> try_size s res -- Rare: size increased between calls to GetEnvironmentVariable
 200           | otherwise  -> peekCWString p_value
 201
 202 eRROR_ENVVAR_NOT_FOUND :: DWORD
 203 eRROR_ENVVAR_NOT_FOUND = 203
 204
 205 foreign import stdcall unsafe "windows.h GetLastError"
 206   c_GetLastError:: IO DWORD
 207
 208 foreign import stdcall unsafe "windows.h GetEnvironmentVariableW"
 209   c_GetEnvironmentVariable :: LPTSTR -> LPTSTR -> DWORD -> IO DWORD
 210 #else
 211 getEnv name =
 212     withCString name $ \s -> do
 213       litstring <- c_getenv s
 214       if litstring /= nullPtr
 215         then GHC.peekCString fileSystemEncoding litstring
 216         else ioe_missingEnvVar name
 217
 218 foreign import ccall unsafe "getenv"
 219    c_getenv :: CString -> IO (Ptr CChar)
 220 #endif
 221
 222 ioe_missingEnvVar :: String -> IO a
 223 ioe_missingEnvVar name = ioException (IOError Nothing NoSuchThing "getEnv"
 224                                                                                           "no environment variable" Nothing (Just name))
 225
 226 {-|
 227 'withArgs' @args act@ - while executing action @act@, have 'getArgs'
 228 return @args@.
 229 -}
 230 withArgs :: [String] -> IO a -> IO a
 231 withArgs xs act = do
 232    p <- System.Environment.getProgName
 233    withArgv (p:xs) act
 234
 235 {-|
 236 'withProgName' @name act@ - while executing action @act@,
 237 have 'getProgName' return @name@.
 238 -}
 239 withProgName :: String -> IO a -> IO a
 240 withProgName nm act = do
 241    xs <- System.Environment.getArgs
 242    withArgv (nm:xs) act
 243
 244 -- Worker routine which marshals and replaces an argv vector for
 245 -- the duration of an action.
 246
 247 withArgv :: [String] -> IO a -> IO a
 248
 249 #ifdef mingw32_HOST_OS
 250 -- We have to reflect the updated arguments in the RTS-side variables as
 251 -- well, because the RTS still consults them for error messages and the like.
 252 -- If we don't do this then ghc-e005 fails.
 253 withArgv new_args act = withWin32ProgArgv new_args $ withProgArgv new_args act
 254 #else
 255 withArgv = withProgArgv
 256 #endif
 257
 258 withProgArgv :: [String] -> IO a -> IO a
 259 withProgArgv new_args act = do
 260   pName <- System.Environment.getProgName
 261   existing_args <- System.Environment.getArgs
 262   bracket (setProgArgv new_args)
 263           (\argv -> do _ <- setProgArgv (pName:existing_args)
 264                        freeProgArgv argv)
 265           (const act)
 266
 267 freeProgArgv :: Ptr CString -> IO ()
 268 freeProgArgv argv = do
 269   size <- lengthArray0 nullPtr argv
 270   sequence_ [peek (argv `advancePtr` i) >>= free | i <- [size, size-1 .. 0]]
 271   free argv
 272
 273 setProgArgv :: [String] -> IO (Ptr CString)
 274 setProgArgv argv = do
 275   vs <- mapM (GHC.newCString fileSystemEncoding) argv >>= newArray0 nullPtr
 276   c_setProgArgv (genericLength argv) vs
 277   return vs
 278
 279 foreign import ccall unsafe "setProgArgv"
 280   c_setProgArgv  :: CInt -> Ptr CString -> IO ()
 281
 282 -- |'getEnvironment' retrieves the entire environment as a
 283 -- list of @(key,value)@ pairs.
 284 --
 285 -- If an environment entry does not contain an @\'=\'@ character,
 286 -- the @key@ is the whole entry and the @value@ is the empty string.
 287 getEnvironment :: IO [(String, String)]
 288
 289 #ifdef mingw32_HOST_OS
 290 getEnvironment = bracket c_GetEnvironmentStrings c_FreeEnvironmentStrings $ \pBlock ->
 291     if pBlock == nullPtr then return []
 292      else go pBlock
 293   where
 294     go pBlock = do
 295         -- The block is terminated by a null byte where there
 296         -- should be an environment variable of the form X=Y
 297         c <- peek pBlock
 298         if c == 0 then return []
 299          else do
 300           -- Seek the next pair (or terminating null):
 301           pBlock' <- seekNull pBlock False
 302           -- We now know the length in bytes, but ignore it when
 303           -- getting the actual String:
 304           str <- peekCWString pBlock
 305           fmap (divvy str :) $ go pBlock'
 306
 307     -- Returns pointer to the byte *after* the next null
 308     seekNull pBlock done = do
 309         let pBlock' = pBlock `plusPtr` sizeOf (undefined :: CWchar)
 310         if done then return pBlock'
 311          else do
 312            c <- peek pBlock'
 313            seekNull pBlock' (c == (0 :: Word8 ))
 314
 315 foreign import stdcall unsafe "windows.h GetEnvironmentStringsW"
 316   c_GetEnvironmentStrings :: IO (Ptr CWchar)
 317
 318 foreign import stdcall unsafe "windows.h FreeEnvironmentStringsW"
 319   c_FreeEnvironmentStrings :: Ptr CWchar -> IO Bool
 320 #else
 321 getEnvironment = do
 322    pBlock <- getEnvBlock
 323    if pBlock == nullPtr then return []
 324     else do
 325       stuff <- peekArray0 nullPtr pBlock >>= mapM (GHC.peekCString fileSystemEncoding)
 326       return (map divvy stuff)
 327
 328 foreign import ccall unsafe "__hscore_environ"
 329   getEnvBlock :: IO (Ptr CString)
 330 #endif
 331
 332 divvy :: String -> (String, String)
 333 divvy str =
 334   case break (=='=') str of
 335     (xs,[])        -> (xs,[]) -- don't barf (like Posix.getEnvironment)
 336     (name,_:value) -> (name,value)
 337 #endif  /* __GLASGOW_HASKELL__ */