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