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