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