X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=System%2FEnvironment.hs;h=2b6dec272d6df2a74278c75c80e7463353181a22;hb=41e8fba828acbae1751628af50849f5352b27873;hp=02c11a7de116064bdfba365e03601c8e4dc0a3cd;hpb=30c6b2c1e57c8724fac6c284ace227584bccfb0b;p=ghc-base.git

diff --git a/System/Environment.hs b/System/Environment.hs
index 02c11a7..2b6dec2 100644
--- a/System/Environment.hs
+++ b/System/Environment.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE CPP, ForeignFunctionInterface #-}
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  System.Environment
@@ -13,48 +15,60 @@
 -----------------------------------------------------------------------------
 
 module System.Environment
-    ( 
-      getArgs,	     -- :: IO [String]
+    (
+      getArgs,       -- :: IO [String]
       getProgName,   -- :: IO String
       getEnv,        -- :: String -> IO String
+#ifndef __NHC__
       withArgs,
       withProgName,
+#endif
+#ifdef __GLASGOW_HASKELL__
+      getEnvironment,
+#endif
   ) where
 
 import Prelude
-import System.IO 	( bracket )
 
-#ifndef __HUGS__
+#ifdef __GLASGOW_HASKELL__
+import Data.List
 import Foreign
 import Foreign.C
+import Control.Exception.Base   ( bracket )
 import Control.Monad
-#endif
-
-#ifdef __GLASGOW_HASKELL__
-import GHC.IOBase
+-- import GHC.IO
+import GHC.IO.Exception
 #endif
 
 #ifdef __HUGS__
 import Hugs.System
 #endif
 
+#ifdef __NHC__
+import System
+  ( getArgs
+  , getProgName
+  , getEnv
+  )
+#endif
+
 -- ---------------------------------------------------------------------------
 -- getArgs, getProgName, getEnv
 
--- Computation `getArgs' returns a list of the program's command
+-- | Computation 'getArgs' returns a list of the program's command
 -- line arguments (not including the program name).
 
-#ifndef __HUGS__
+#ifdef __GLASGOW_HASKELL__
 getArgs :: IO [String]
-getArgs = 
-  alloca $ \ p_argc ->  
+getArgs =
+  alloca $ \ p_argc ->
   alloca $ \ p_argv -> do
    getProgArgv p_argc p_argv
    p    <- fromIntegral `liftM` peek p_argc
    argv <- peek p_argv
    peekArray (p - 1) (advancePtr argv 1) >>= mapM peekCString
 
-   
+
 foreign import ccall unsafe "getProgArgv"
   getProgArgv :: Ptr CInt -> Ptr (Ptr CString) -> IO ()
 
@@ -69,15 +83,15 @@ between platforms: on Windows, for example, a program invoked as foo
 is probably really @FOO.EXE@, and that is what 'getProgName' will return.
 -}
 getProgName :: IO String
-getProgName = 
+getProgName =
   alloca $ \ p_argc ->
   alloca $ \ p_argv -> do
      getProgArgv p_argc p_argv
      argv <- peek p_argv
      unpackProgName argv
-  
-unpackProgName	:: Ptr (Ptr CChar) -> IO String   -- argv[0]
-unpackProgName argv = do 
+
+unpackProgName  :: Ptr (Ptr CChar) -> IO String   -- argv[0]
+unpackProgName argv = do
   s <- peekElemOff argv 0 >>= peekCString
   return (basename s)
   where
@@ -85,48 +99,52 @@ unpackProgName argv = do
    basename f = go f f
     where
       go acc [] = acc
-      go acc (x:xs) 
+      go acc (x:xs)
         | isPathSeparator x = go xs xs
         | otherwise         = go acc xs
 
    isPathSeparator :: Char -> Bool
    isPathSeparator '/'  = True
-#ifdef mingw32_TARGET_OS 
+#ifdef mingw32_HOST_OS 
    isPathSeparator '\\' = True
 #endif
    isPathSeparator _    = False
 
 
--- Computation `getEnv var' returns the value
--- of the environment variable {\em var}.  
-
--- This computation may fail with
---    NoSuchThing: The environment variable does not exist.
+-- | Computation 'getEnv' @var@ returns the value
+-- of the environment variable @var@.  
+--
+-- This computation may fail with:
+--
+--  * 'System.IO.Error.isDoesNotExistError' if the environment variable
+--    does not exist.
 
 getEnv :: String -> IO String
 getEnv name =
     withCString name $ \s -> do
       litstring <- c_getenv s
       if litstring /= nullPtr
-	then peekCString litstring
+        then peekCString litstring
         else ioException (IOError Nothing NoSuchThing "getEnv"
-			  "no environment variable" (Just name))
+                          "no environment variable" Nothing (Just name))
 
 foreign import ccall unsafe "getenv"
    c_getenv :: CString -> IO (Ptr CChar)
-#endif  /* __HUGS__ */
 
 {-|
-@withArgs args act@ - while executing action @act@, have 'System.getArgs'
+'withArgs' @args act@ - while executing action @act@, have 'getArgs'
 return @args@.
 -}
+withArgs :: [String] -> IO a -> IO a
 withArgs xs act = do
    p <- System.Environment.getProgName
    withArgv (p:xs) act
 
 {-|
-@withProgName name act@ - while executing action @act@, have 'System.getProgName'return @name@.
+'withProgName' @name act@ - while executing action @act@,
+have 'getProgName' return @name@.
 -}
+withProgName :: String -> IO a -> IO a
 withProgName nm act = do
    xs <- System.Environment.getArgs
    withArgv (nm:xs) act
@@ -134,12 +152,14 @@ withProgName nm act = do
 -- Worker routine which marshals and replaces an argv vector for
 -- the duration of an action.
 
+withArgv :: [String] -> IO a -> IO a
 withArgv new_args act = do
   pName <- System.Environment.getProgName
   existing_args <- System.Environment.getArgs
-  bracket (setArgs new_args) 
-	  (\argv -> do setArgs (pName:existing_args); freeArgv argv)
-  	  (const act)
+  bracket (setArgs new_args)
+          (\argv -> do _ <- setArgs (pName:existing_args)
+                       freeArgv argv)
+          (const act)
 
 freeArgv :: Ptr CString -> IO ()
 freeArgv argv = do
@@ -150,8 +170,31 @@ freeArgv argv = do
 setArgs :: [String] -> IO (Ptr CString)
 setArgs argv = do
   vs <- mapM newCString argv >>= newArray0 nullPtr
-  setArgsPrim (length argv) vs
+  setArgsPrim (genericLength argv) vs
   return vs
 
 foreign import ccall unsafe "setProgArgv" 
-  setArgsPrim  :: Int -> Ptr CString -> IO ()
+  setArgsPrim  :: CInt -> Ptr CString -> IO ()
+
+-- |'getEnvironment' retrieves the entire environment as a
+-- list of @(key,value)@ pairs.
+--
+-- If an environment entry does not contain an @\'=\'@ character,
+-- the @key@ is the whole entry and the @value@ is the empty string.
+
+getEnvironment :: IO [(String, String)]
+getEnvironment = do
+   pBlock <- getEnvBlock
+   if pBlock == nullPtr then return []
+    else do
+      stuff <- peekArray0 nullPtr pBlock >>= mapM peekCString
+      return (map divvy stuff)
+  where
+   divvy str =
+      case break (=='=') str of
+        (xs,[])        -> (xs,[]) -- don't barf (like Posix.getEnvironment)
+        (name,_:value) -> (name,value)
+
+foreign import ccall unsafe "__hscore_environ" 
+  getEnvBlock :: IO (Ptr CString)
+#endif  /* __GLASGOW_HASKELL__ */