[commit: base] master: Add System.Environment.getExecutablePath (#7029) (ca72c8e)

Repository : ssh://darcs.haskell.org//srv/darcs/packages/base

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/ca72c8e005ae78939645f27328bd81a91943453d

>---------------------------------------------------------------

commit ca72c8e005ae78939645f27328bd81a91943453d
Author: Paolo Capriotti <[email protected]>
Date:   Wed Jun 27 18:56:32 2012 +0100

    Add System.Environment.getExecutablePath (#7029)
    
    Patch by Johan Tibell <[email protected]>

>---------------------------------------------------------------

 System/Environment.hs                 |   11 ++-
 System/Environment/ExecutablePath.hsc |  172 +++++++++++++++++++++++++++++++++
 base.cabal                            |    1 +
 3 files changed, 180 insertions(+), 4 deletions(-)

diff --git a/System/Environment.hs b/System/Environment.hs
index 7be95ad..1f33213 100644
--- a/System/Environment.hs
+++ b/System/Environment.hs
@@ -17,10 +17,11 @@
 
 module System.Environment
     (
-      getArgs,       -- :: IO [String]
-      getProgName,   -- :: IO String
-      getEnv,        -- :: String -> IO String
-      lookupEnv,     -- :: String -> IO (Maybe String)
+      getArgs,            -- :: IO [String]
+      getProgName,        -- :: IO String
+      getExecutablePath,  -- :: IO FilePath
+      getEnv,             -- :: String -> IO String
+      lookupEnv,          -- :: String -> IO (Maybe String)
 #ifndef __NHC__
       withArgs,
       withProgName,
@@ -61,6 +62,8 @@ import System
   )
 #endif
 
+import System.Environment.ExecutablePath
+
 #ifdef mingw32_HOST_OS
 # if defined(i386_HOST_ARCH)
 #  define WINDOWS_CCONV stdcall
diff --git a/System/Environment/ExecutablePath.hsc b/System/Environment/ExecutablePath.hsc
new file mode 100644
index 0000000..10ef158
--- /dev/null
+++ b/System/Environment/ExecutablePath.hsc
@@ -0,0 +1,172 @@
+{-# LANGUAGE Safe #-}
+{-# LANGUAGE CPP, ForeignFunctionInterface #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Environment.ExecutablePath
+-- Copyright   :  (c) The University of Glasgow 2001
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer  :  [email protected]
+-- Stability   :  provisional
+-- Portability :  portable
+--
+-- Function to retrieve the absolute filepath of the current executable.
+--
+-----------------------------------------------------------------------------
+
+module System.Environment.ExecutablePath ( getExecutablePath ) where
+
+-- The imports are purposely kept completely disjoint to prevent edits
+-- to one OS implementation from breaking another.
+
+#if defined(darwin_HOST_OS)
+import Data.Word
+import Foreign.C
+import Foreign.Marshal.Alloc
+import Foreign.Ptr
+import Foreign.Storable
+import System.Posix.Internals
+#elif defined(linux_HOST_OS)
+import Foreign.C
+import Foreign.Marshal.Array
+import System.Posix.Internals
+#elif defined(mingw32_HOST_OS)
+import Data.Word
+import Foreign.C
+import Foreign.Marshal.Array
+import Foreign.Ptr
+import System.Posix.Internals
+#else
+import Foreign.C
+import Foreign.Marshal.Alloc
+import Foreign.Ptr
+import Foreign.Storable
+import System.Posix.Internals
+#endif
+
+-- The exported function is defined outside any if-guard to make sure
+-- every OS implements it with the same type.
+
+-- | Returns the absolute pathname of the current executable.
+--
+-- Note that for scripts and interactive sessions, this is the path to
+-- the interpreter (e.g. ghci.)
+getExecutablePath :: IO FilePath
+
+--------------------------------------------------------------------------------
+-- Mac OS X
+
+#if defined(darwin_HOST_OS)
+
+type UInt32 = Word32
+
+foreign import ccall unsafe "mach-o/dyld.h _NSGetExecutablePath"
+    c__NSGetExecutablePath :: CString -> Ptr UInt32 -> IO CInt
+
+-- | Returns the path of the main executable. The path may be a
+-- symbolic link and not the real file.
+--
+-- See dyld(3)
+_NSGetExecutablePath :: IO FilePath
+_NSGetExecutablePath =
+    allocaBytes 1024 $ \ buf ->  -- PATH_MAX is 1024 on OS X
+    alloca $ \ bufsize -> do
+        poke bufsize 1024
+        status <- c__NSGetExecutablePath buf bufsize
+        if status == 0
+            then peekFilePath buf
+            else do reqBufsize <- fromIntegral `fmap` peek bufsize
+                    allocaBytes reqBufsize $ \ newBuf -> do
+                        status2 <- c__NSGetExecutablePath newBuf bufsize
+                        if status2 == 0
+                             then peekFilePath newBuf
+                             else error "_NSGetExecutablePath: buffer too small"
+
+foreign import ccall unsafe "stdlib.h realpath"
+    c_realpath :: CString -> CString -> IO CString
+
+-- | Resolves all symbolic links, extra \/ characters, and references
+-- to \/.\/ and \/..\/. Returns an absolute pathname.
+--
+-- See realpath(3)
+realpath :: FilePath -> IO FilePath
+realpath path =
+    withFilePath path $ \ fileName ->
+    allocaBytes 1024 $ \ resolvedName -> do
+        _ <- throwErrnoIfNull "realpath" $ c_realpath fileName resolvedName
+        peekFilePath resolvedName
+
+getExecutablePath = _NSGetExecutablePath >>= realpath
+
+--------------------------------------------------------------------------------
+-- Linux
+
+#elif defined(linux_HOST_OS)
+
+foreign import ccall unsafe "readlink"
+    c_readlink :: CString -> CString -> CSize -> IO CInt
+
+-- | Reads the @FilePath@ pointed to by the symbolic link and returns
+-- it.
+--
+-- See readlink(2)
+readSymbolicLink :: FilePath -> IO FilePath
+readSymbolicLink file =
+    allocaArray0 4096 $ \buf -> do
+        withFilePath file $ \s -> do
+            len <- throwErrnoPathIfMinus1 "readSymbolicLink" file $
+                   c_readlink s buf 4096
+            peekFilePathLen (buf,fromIntegral len)
+
+getExecutablePath = readSymbolicLink $ "/proc/self/exe"
+
+--------------------------------------------------------------------------------
+-- Windows
+
+#elif defined(mingw32_HOST_OS)
+
+# if defined(i386_HOST_ARCH)
+##  define WINDOWS_CCONV stdcall
+# elif defined(x86_64_HOST_ARCH)
+##  define WINDOWS_CCONV ccall
+# else
+#  error Unknown mingw32 arch
+# endif
+
+foreign import WINDOWS_CCONV unsafe "windows.h GetModuleFileNameW"
+    c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32
+
+getExecutablePath = go 2048  -- plenty, PATH_MAX is 512 under Win32
+  where
+    go size = allocaArray (fromIntegral size) $ \ buf -> do
+        ret <- c_GetModuleFileName nullPtr buf size
+        case ret of
+            0 -> error "getExecutablePath: GetModuleFileNameW returned an error"
+            _ | ret < size -> peekFilePath buf
+              | otherwise  -> go (size * 2)
+
+--------------------------------------------------------------------------------
+-- Fallback to argv[0]
+
+#else
+
+foreign import ccall unsafe "getFullProgArgv"
+    c_getFullProgArgv :: Ptr CInt -> Ptr (Ptr CString) -> IO ()
+
+getExecutablePath =
+    alloca $ \ p_argc ->
+    alloca $ \ p_argv -> do
+        c_getFullProgArgv p_argc p_argv
+        argc <- peek p_argc
+        if argc > 0
+            -- If argc > 0 then argv[0] is guaranteed by the standard
+            -- to be a pointer to a null-terminated string.
+            then peek p_argv >>= peek >>= peekFilePath
+            else error $ "getExecutablePath: " ++ msg
+  where msg = "no OS specific implementation and program name couldn't be " ++
+              "found in argv"
+
+--------------------------------------------------------------------------------
+
+#endif
diff --git a/base.cabal b/base.cabal
index 2147744..213dd4e 100644
--- a/base.cabal
+++ b/base.cabal
@@ -216,6 +216,7 @@ Library {
         Control.Monad.ST.Imp
         Control.Monad.ST.Lazy.Imp
         Foreign.ForeignPtr.Imp
+        System.Environment.ExecutablePath
     c-sources:
         cbits/PrelIOUtils.c
         cbits/WCsubst.c