getExecutablePath: get path from sysctl on FreeBSD
authorFraser Tweedale <frase@frase.id.au>
Tue, 25 Jun 2019 02:17:30 +0000 (12:17 +1000)
committerBen Gamari <ben@smart-cactus.org>
Sun, 30 Jun 2019 11:40:21 +0000 (07:40 -0400)
(cherry picked from commit d35cec7a9c07a0fc3b40e45d64e5794c3567a523)

libraries/base/System/Environment/ExecutablePath.hsc

index 095b25c..0e7c9fd 100644 (file)
@@ -32,6 +32,14 @@ import System.Posix.Internals
 import Foreign.C
 import Foreign.Marshal.Array
 import System.Posix.Internals
+#elif defined(freebsd_HOST_OS)
+import Foreign.C
+import Foreign.Marshal.Alloc
+import Foreign.Marshal.Array
+import Foreign.Ptr
+import Foreign.Storable
+import System.Posix.Internals
+#include <sys/sysctl.h>
 #elif defined(mingw32_HOST_OS)
 import Control.Exception
 import Data.List
@@ -132,6 +140,45 @@ readSymbolicLink file =
 getExecutablePath = readSymbolicLink $ "/proc/self/exe"
 
 --------------------------------------------------------------------------------
+-- FreeBSD
+
+#elif defined(freebsd_HOST_OS)
+
+foreign import ccall unsafe "sysctl"
+  c_sysctl
+    :: Ptr CInt   -- MIB
+    -> CUInt      -- MIB size
+    -> Ptr CChar  -- old / current value buffer
+    -> Ptr CSize  -- old / current value buffer size
+    -> Ptr CChar  -- new value
+    -> CSize      -- new value size
+    -> IO CInt    -- result
+
+getExecutablePath = do
+  withArrayLen mib $ \n mibPtr -> do
+    let mibLen = fromIntegral n
+    alloca $ \bufSizePtr -> do
+      status <- c_sysctl mibPtr mibLen nullPtr bufSizePtr nullPtr 0
+      case status of
+        0 -> do
+          reqBufSize <- fromIntegral <$> peek bufSizePtr
+          allocaBytes reqBufSize $ \buf -> do
+            newStatus <- c_sysctl mibPtr mibLen buf bufSizePtr nullPtr 0
+            case newStatus of
+              0 -> peekFilePath buf
+              _ -> barf
+        _ -> barf
+  where
+    barf = throwErrno "getExecutablePath"
+    mib =
+      [ (#const CTL_KERN)
+      , (#const KERN_PROC)
+      , (#const KERN_PROC_PATHNAME)
+      , -1   -- current process
+      ]
+
+
+--------------------------------------------------------------------------------
 -- Windows
 
 #elif defined(mingw32_HOST_OS)