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