diff options
| -rw-r--r-- | System/Posix.hs | 2 | ||||
| -rw-r--r-- | System/Posix/Env.hsc | 111 | ||||
| -rw-r--r-- | include/HsUnix.h | 4 |
3 files changed, 116 insertions, 1 deletions
diff --git a/System/Posix.hs b/System/Posix.hs index c15bc24..c730294 100644 --- a/System/Posix.hs +++ b/System/Posix.hs @@ -19,6 +19,7 @@ module System.Posix ( module System.Posix.Files, module System.Posix.Unistd, module System.Posix.IO, + module System.Posix.Env, module System.Posix.Process, module System.Posix.Terminal, module System.Posix.Time, @@ -32,6 +33,7 @@ import System.Posix.Files import System.Posix.Unistd import System.Posix.Process import System.Posix.IO +import System.Posix.Env import System.Posix.Terminal import System.Posix.Time import System.Posix.User diff --git a/System/Posix/Env.hsc b/System/Posix/Env.hsc new file mode 100644 index 0000000..3692a5f --- /dev/null +++ b/System/Posix/Env.hsc @@ -0,0 +1,111 @@ +{-# OPTIONS -fffi #-} +----------------------------------------------------------------------------- +-- | +-- Module : System.Posix.Env +-- Copyright : (c) The University of Glasgow 2002 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : non-portable (requires POSIX) +-- +-- POSIX environment support +-- +----------------------------------------------------------------------------- + +module System.Posix.Env ( + getEnvVar, + getEnvVarDefault, + getEnvironmentPrim, + getEnvironment, + putEnv, + setEnv, + unsetEnv +) where + +#include "HsUnix.h" + +import Foreign.C.Error ( throwErrnoIfMinus1_ ) +import Foreign.C.Types ( CInt ) +import Foreign.C.String +import Foreign.Marshal.Array +import Foreign.Ptr +import Monad ( liftM ) +import Maybe ( fromMaybe ) + +-- |'getEnvVar' looks up a variable in the environment. + +getEnvVar :: String -> IO (Maybe String) +getEnvVar name = do + litstring <- withCString name c_getenv + if litstring /= nullPtr + then liftM Just $ peekCString litstring + else return Nothing + +-- |'getEnvVarDefault' is a wrapper around 'getEnvVar' where the +-- programmer can specify a fallback if the variable is not found +-- in the environment. + +getEnvVarDefault :: String -> String -> IO String +getEnvVarDefault name fallback = liftM (fromMaybe fallback) (getEnvVar name) + +foreign import ccall unsafe "getenv" + c_getenv :: CString -> IO CString + +getEnvironmentPrim :: IO [String] +getEnvironmentPrim = do + arr <- peekArray0 nullPtr c_environ + mapM peekCString arr + +foreign import ccall unsafe "__hsunix_environ" + c_environ :: Ptr CString + +-- |'getEnvironment' retrieves the entire environment as a +-- list of @(key,value)@ pairs. + +getEnvironment :: IO [(String,String)] +getEnvironment = do + env <- getEnvironmentPrim + return $ map (dropEq.(break ((==) '='))) env + where + dropEq (x,'=':ys) = (x,ys) + dropEq (x,_) = error $ "getEnvironment: insane variable " ++ x + +-- |The 'unsetenv' function deletes all instances of the variable name +-- from the environment. + +unsetEnv :: String -> IO () +unsetEnv name = withCString name c_unsetenv + +foreign import ccall unsafe "unsetenv" + c_unsetenv :: CString -> IO () + +-- |'putEnv' function takes an argument of the form @name=value@ +-- and is equivalent to @setEnv(key,value,True{-overwrite-})@. + +putEnv :: String -> IO () +putEnv keyvalue = withCString keyvalue $ \s -> + throwErrnoIfMinus1_ "putenv" (c_putenv s) + +foreign import ccall unsafe "putenv" + c_putenv :: CString -> IO CInt + +{- |The 'setenv' function inserts or resets the environment variable name in + the current environment list. If the variable @name@ does not exist in the + list, it is inserted with the given value. If the variable does exist, + the argument @overwrite@ is tested; if @overwrite@ is @False@, the variable is + not reset, otherwise it is reset to the given value. +-} + +setEnv :: String -> String -> Bool {-overwrite-} -> IO () +setEnv key value ovrwrt = do + withCString key $ \ keyP -> + withCString value $ \ valueP -> + throwErrnoIfMinus1_ "putenv" $ c_setenv keyP valueP (toInt ovrwrt) + where + toInt :: Bool -> CInt + toInt True = 1 + toInt False = 0 + +foreign import ccall unsafe "setenv" + c_setenv :: CString -> CString -> CInt -> IO CInt diff --git a/include/HsUnix.h b/include/HsUnix.h index 5488f71..cccbd7b 100644 --- a/include/HsUnix.h +++ b/include/HsUnix.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: HsUnix.h,v 1.4 2003/01/17 17:01:14 stolz Exp $ + * $Id: HsUnix.h,v 1.5 2003/02/28 16:09:16 stolz Exp $ * * (c) The University of Glasgow 2002 * @@ -63,6 +63,7 @@ extern int execvpe(char *name, char **argv, char **envp); extern void pPrPr_disableITimers (void); +extern char **environ; #ifndef INLINE #define INLINE extern inline @@ -74,6 +75,7 @@ INLINE int __hsunix_wifsignaled (int stat) { return WIFSIGNALED(stat); } INLINE int __hsunix_wtermsig (int stat) { return WTERMSIG(stat); } INLINE int __hsunix_wifstopped (int stat) { return WIFSTOPPED(stat); } INLINE int __hsunix_wstopsig (int stat) { return WSTOPSIG(stat); } +INLINE char ** __hsunix_environ () { return environ; } /* O_SYNC doesn't exist on Mac OS X and (at least some versions of) FreeBSD, fall back to O_FSYNC, which should be the same */ |