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

diff --git a/System/Environment.hs b/System/Environment.hs
index bd285e5..2b6dec2 100644
--- a/System/Environment.hs
+++ b/System/Environment.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE CPP, ForeignFunctionInterface #-}
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  System.Environment
@@ -13,25 +15,29 @@
 -----------------------------------------------------------------------------
 
 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
 
 #ifdef __GLASGOW_HASKELL__
+import Data.List
 import Foreign
 import Foreign.C
-import Control.Exception 	( bracket )
+import Control.Exception.Base   ( bracket )
 import Control.Monad
-import GHC.IOBase
-#include "ghcconfig.h"
+-- import GHC.IO
+import GHC.IO.Exception
 #endif
 
 #ifdef __HUGS__
@@ -54,15 +60,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 ()
 
@@ -77,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
@@ -93,13 +99,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
@@ -118,9 +124,9 @@ 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)
@@ -150,9 +156,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
@@ -163,9 +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__ */