X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=System%2FEnvironment.hs;h=b85bc42e5e0c1a104780b60e19b7ac1b711e6a43;hb=85ed71ab833a40f5acfeb4610a0aa3c3c3e1a35b;hp=a0761d59951bdbb1710a976edecd3058c815a6cb;hpb=dbe5ad2718b2133d8c4205589905cf14acd73dcf;p=ghc-base.git

diff --git a/System/Environment.hs b/System/Environment.hs
index a0761d5..b85bc42 100644
--- a/System/Environment.hs
+++ b/System/Environment.hs
@@ -13,27 +13,29 @@
 -----------------------------------------------------------------------------
 
 module System.Environment
-    ( 
-      getArgs,	     -- :: IO [String]
+    (
+      getArgs,       -- :: IO [String]
       getProgName,   -- :: IO String
       getEnv,        -- :: String -> IO String
-#ifdef __GLASGOW_HASKELL__
+#ifndef __NHC__
       withArgs,
       withProgName,
 #endif
+#ifdef __GLASGOW_HASKELL__
+      getEnvironment,
+#endif
   ) where
 
 import Prelude
-#ifndef __NHC__
-import Control.Exception 	( bracket )
-#endif
 
 #ifdef __GLASGOW_HASKELL__
+import Data.List
 import Foreign
 import Foreign.C
+import Control.Exception.Base   ( bracket )
 import Control.Monad
-import GHC.IOBase
-#include "config.h"
+-- import GHC.IO
+import GHC.IO.Exception
 #endif
 
 #ifdef __HUGS__
@@ -56,15 +58,15 @@ import System
 
 #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 ()
 
@@ -79,15 +81,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
@@ -95,13 +97,13 @@ 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
@@ -120,16 +122,16 @@ 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)
 
 {-|
-@withArgs args act@ - while executing action @act@, have 'System.getArgs'
-return @args@ (GHC only).
+'withArgs' @args act@ - while executing action @act@, have 'getArgs'
+return @args@.
 -}
 withArgs :: [String] -> IO a -> IO a
 withArgs xs act = do
@@ -137,8 +139,8 @@ withArgs xs act = do
    withArgv (p:xs) act
 
 {-|
-@withProgName name act@ - while executing action @act@,
-have 'System.getProgName' return @name@ (GHC only).
+'withProgName' @name act@ - while executing action @act@,
+have 'getProgName' return @name@.
 -}
 withProgName :: String -> IO a -> IO a
 withProgName nm act = do
@@ -152,9 +154,10 @@ 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
@@ -165,9 +168,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__ */