System/Environment.hs

   1 -----------------------------------------------------------------------------
   2 -- |
   3 -- Module      :  System.Environment
   4 -- Copyright   :  (c) The University of Glasgow 2001
   5 -- License     :  BSD-style (see the file libraries/base/LICENSE)
   6 --
   7 -- Maintainer  :  libraries@haskell.org
   8 -- Stability   :  provisional
   9 -- Portability :  portable
  10 --
  11 -- Miscellaneous information about the system environment.
  12 --
  13 -----------------------------------------------------------------------------
  14
  15 module System.Environment
  16     (
  17       getArgs,       -- :: IO [String]
  18       getProgName,   -- :: IO String
  19       getEnv,        -- :: String -> IO String
  20 #ifndef __NHC__
  21       withArgs,
  22       withProgName,
  23 #endif
  24 #ifdef __GLASGOW_HASKELL__
  25       getEnvironment,
  26 #endif
  27   ) where
  28
  29 import Prelude
  30
  31 #ifdef __GLASGOW_HASKELL__
  32 import Foreign
  33 import Foreign.C
  34 import Control.Exception        ( bracket )
  35 import Control.Monad
  36 import GHC.IOBase
  37 #endif
  38
  39 #ifdef __HUGS__
  40 import Hugs.System
  41 #endif
  42
  43 #ifdef __NHC__
  44 import System
  45   ( getArgs
  46   , getProgName
  47   , getEnv
  48   )
  49 #endif
  50
  51 -- ---------------------------------------------------------------------------
  52 -- getArgs, getProgName, getEnv
  53
  54 -- | Computation 'getArgs' returns a list of the program's command
  55 -- line arguments (not including the program name).
  56
  57 #ifdef __GLASGOW_HASKELL__
  58 getArgs :: IO [String]
  59 getArgs =
  60   alloca $ \ p_argc ->
  61   alloca $ \ p_argv -> do
  62    getProgArgv p_argc p_argv
  63    p    <- fromIntegral `liftM` peek p_argc
  64    argv <- peek p_argv
  65    peekArray (p - 1) (advancePtr argv 1) >>= mapM peekCString
  66
  67
  68 foreign import ccall unsafe "getProgArgv"
  69   getProgArgv :: Ptr CInt -> Ptr (Ptr CString) -> IO ()
  70
  71 {-|
  72 Computation 'getProgName' returns the name of the program as it was
  73 invoked.
  74
  75 However, this is hard-to-impossible to implement on some non-Unix
  76 OSes, so instead, for maximum portability, we just return the leafname
  77 of the program as invoked. Even then there are some differences
  78 between platforms: on Windows, for example, a program invoked as foo
  79 is probably really @FOO.EXE@, and that is what 'getProgName' will return.
  80 -}
  81 getProgName :: IO String
  82 getProgName =
  83   alloca $ \ p_argc ->
  84   alloca $ \ p_argv -> do
  85      getProgArgv p_argc p_argv
  86      argv <- peek p_argv
  87      unpackProgName argv
  88
  89 unpackProgName  :: Ptr (Ptr CChar) -> IO String   -- argv[0]
  90 unpackProgName argv = do
  91   s <- peekElemOff argv 0 >>= peekCString
  92   return (basename s)
  93   where
  94    basename :: String -> String
  95    basename f = go f f
  96     where
  97       go acc [] = acc
  98       go acc (x:xs)
  99         | isPathSeparator x = go xs xs
 100         | otherwise         = go acc xs
 101
 102    isPathSeparator :: Char -> Bool
 103    isPathSeparator '/'  = True
 104 #ifdef mingw32_HOST_OS
 105    isPathSeparator '\\' = True
 106 #endif
 107    isPathSeparator _    = False
 108
 109
 110 -- | Computation 'getEnv' @var@ returns the value
 111 -- of the environment variable @var@.
 112 --
 113 -- This computation may fail with:
 114 --
 115 --  * 'System.IO.Error.isDoesNotExistError' if the environment variable
 116 --    does not exist.
 117
 118 getEnv :: String -> IO String
 119 getEnv name =
 120     withCString name $ \s -> do
 121       litstring <- c_getenv s
 122       if litstring /= nullPtr
 123         then peekCString litstring
 124         else ioException (IOError Nothing NoSuchThing "getEnv"
 125                           "no environment variable" (Just name))
 126
 127 foreign import ccall unsafe "getenv"
 128    c_getenv :: CString -> IO (Ptr CChar)
 129
 130 {-|
 131 'withArgs' @args act@ - while executing action @act@, have 'getArgs'
 132 return @args@.
 133 -}
 134 withArgs :: [String] -> IO a -> IO a
 135 withArgs xs act = do
 136    p <- System.Environment.getProgName
 137    withArgv (p:xs) act
 138
 139 {-|
 140 'withProgName' @name act@ - while executing action @act@,
 141 have 'getProgName' return @name@.
 142 -}
 143 withProgName :: String -> IO a -> IO a
 144 withProgName nm act = do
 145    xs <- System.Environment.getArgs
 146    withArgv (nm:xs) act
 147
 148 -- Worker routine which marshals and replaces an argv vector for
 149 -- the duration of an action.
 150
 151 withArgv :: [String] -> IO a -> IO a
 152 withArgv new_args act = do
 153   pName <- System.Environment.getProgName
 154   existing_args <- System.Environment.getArgs
 155   bracket (setArgs new_args)
 156           (\argv -> do setArgs (pName:existing_args); freeArgv argv)
 157           (const act)
 158
 159 freeArgv :: Ptr CString -> IO ()
 160 freeArgv argv = do
 161   size <- lengthArray0 nullPtr argv
 162   sequence_ [peek (argv `advancePtr` i) >>= free | i <- [size, size-1 .. 0]]
 163   free argv
 164
 165 setArgs :: [String] -> IO (Ptr CString)
 166 setArgs argv = do
 167   vs <- mapM newCString argv >>= newArray0 nullPtr
 168   setArgsPrim (length argv) vs
 169   return vs
 170
 171 foreign import ccall unsafe "setProgArgv"
 172   setArgsPrim  :: Int -> Ptr CString -> IO ()
 173
 174 -- |'getEnvironment' retrieves the entire environment as a
 175 -- list of @(key,value)@ pairs.
 176 --
 177 -- If an environment entry does not contain an @\'=\'@ character,
 178 -- the @key@ is the whole entry and the @value@ is the empty string.
 179
 180 getEnvironment :: IO [(String, String)]
 181 getEnvironment = do
 182    pBlock <- getEnvBlock
 183    if pBlock == nullPtr then return []
 184     else do
 185       stuff <- peekArray0 nullPtr pBlock >>= mapM peekCString
 186       return (map divvy stuff)
 187   where
 188    divvy str =
 189       case break (=='=') str of
 190         (xs,[])        -> (xs,[]) -- don't barf (like Posix.getEnvironment)
 191         (name,_:value) -> (name,value)
 192
 193 foreign import ccall unsafe "__hscore_environ"
 194   getEnvBlock :: IO (Ptr CString)
 195 #endif  /* __GLASGOW_HASKELL__ */