aboutsummaryrefslogtreecommitdiffhomepage
path: root/System/Posix
diff options
context:
space:
mode:
Diffstat (limited to 'System/Posix')
-rw-r--r--System/Posix/DynamicLinker.hsc95
-rw-r--r--System/Posix/DynamicLinker/Module.hsc120
-rw-r--r--System/Posix/DynamicLinker/Prim.hsc122
3 files changed, 337 insertions, 0 deletions
diff --git a/System/Posix/DynamicLinker.hsc b/System/Posix/DynamicLinker.hsc
new file mode 100644
index 0000000..6d13de5
--- /dev/null
+++ b/System/Posix/DynamicLinker.hsc
@@ -0,0 +1,95 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : System.Posix.DynamicLinker
+-- Copyright : (c) Volker Stolz <vs@foldr.org> 2003
+-- License : BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer : vs@foldr.org
+-- Stability : provisional
+-- Portability : non-portable (requires POSIX)
+--
+-- Dynamic linker support through dlopen()
+-----------------------------------------------------------------------------
+
+module System.Posix.DynamicLinker (
+
+ module System.Posix.DynamicLinker.Prim,
+ dlopen,
+ dlsym,
+ dlerror,
+ dlclose,
+ withDL, withDL_,
+ undl,
+ )
+
+-- Usage:
+-- ******
+--
+-- Let's assume you want to open a local shared library \'foo\' (.\/libfoo.so)
+-- offering a function
+-- @char \* mogrify (char\*,int)@
+-- and invoke @str = mogrify("test",1)@:
+--
+--
+-- type Fun = CString -> Int -> IO CString
+-- foreign import dynamic unsafe fun__ :: FunPtr Fun -> Fun
+--
+-- withDL "libfoo.so" [RTLD_NOW] \$ \\ mod -> do
+-- funptr <- dlsym mod "mogrify"
+-- let fun = fun__ funptr
+-- withCString "test" \$ \\ str -> do
+-- strptr <- fun str 1
+-- strstr <- peekCString strptr
+-- ...
+--
+
+where
+
+#include "HsUnix.h"
+
+import System.Posix.DynamicLinker.Prim
+import IO ( bracket )
+import Control.Monad ( liftM )
+import Foreign.Ptr ( Ptr, nullPtr, FunPtr, nullFunPtr )
+import Foreign.C.String ( withCString, peekCString )
+
+dlopen :: String -> [RTLDFlags] -> IO DL
+dlopen path flags = do
+ withCString path $ \ p -> do
+ liftM DLHandle $ throwDLErrorIf "dlopen" (== nullPtr) $ c_dlopen p (packRTLDFlags flags)
+
+dlclose :: DL -> IO ()
+dlclose (DLHandle h) = throwDLErrorIf_ "dlclose" (== 0) $ c_dlclose h
+dlclose h = error $ "dlclose: invalid argument" ++ (show h)
+
+dlerror :: IO String
+dlerror = c_dlerror >>= peekCString
+
+-- |'dlsym' returns the address binding of the symbol described in @symbol@,
+-- as it occurs in the shared object identified by @source@.
+
+dlsym :: DL -> String -> IO (FunPtr a)
+dlsym source symbol = do
+ withCString symbol $ \ s -> do
+ throwDLErrorIf "dlsym" (== nullFunPtr) $ c_dlsym (packDL source) s
+
+withDL :: String -> [RTLDFlags] -> (DL -> IO a) -> IO a
+withDL mod flags f = bracket (dlopen mod flags) (dlclose) f
+
+withDL_ :: String -> [RTLDFlags] -> (DL -> IO a) -> IO ()
+withDL_ mod flags f = withDL mod flags f >> return ()
+
+-- |'undl' obtains the raw handle. You mustn't do something like
+-- @withDL mod flags $ liftM undl >>= \ p -> use p@
+
+undl :: DL -> Ptr ()
+undl = packDL
+
+throwDLErrorIf :: String -> (a -> Bool) -> IO a -> IO a
+throwDLErrorIf s p f = do
+ r <- f
+ if (p r)
+ then dlerror >>= \ err -> ioError (userError ( s ++ ": " ++ err))
+ else return r
+
+throwDLErrorIf_ s p f = throwDLErrorIf s p f >> return ()
diff --git a/System/Posix/DynamicLinker/Module.hsc b/System/Posix/DynamicLinker/Module.hsc
new file mode 100644
index 0000000..351429a
--- /dev/null
+++ b/System/Posix/DynamicLinker/Module.hsc
@@ -0,0 +1,120 @@
+{-# OPTIONS -fffi #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : System.Posix.DynamicLinker.Module
+-- Copyright : (c) Volker Stolz <vs@foldr.org> 2003
+-- License : BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer : vs@foldr.org
+-- Stability : provisional
+-- Portability : non-portable (requires POSIX)
+--
+-- DLOpen support, old API
+-- Derived from GModule.chs by M.Weber & M.Chakravarty which is part of c2hs
+-- I left the API more or less the same, mostly the flags are different.
+--
+-----------------------------------------------------------------------------
+
+module System.Posix.DynamicLinker.Module (
+
+-- Usage:
+-- ******
+--
+-- Let's assume you want to open a local shared library 'foo' (./libfoo.so)
+-- offering a function
+-- char * mogrify (char*,int)
+-- and invoke str = mogrify("test",1):
+--
+-- type Fun = CString -> Int -> IO CString
+-- foreign import dynamic unsafe fun__ :: FunPtr Fun -> Fun
+--
+-- withModule (Just ".") ("libfoo.so") [RTLD_NOW] $ \ mod -> do
+-- funptr <- moduleSymbol mod "mogrify"
+-- let fun = fun__ funptr
+-- withCString "test" $ \ str -> do
+-- strptr <- fun str 1
+-- strstr <- peekCString strptr
+-- ...
+
+
+ moduleOpen -- :: String -> ModuleFlags -> IO Module
+ , moduleSymbol -- :: Source -> String -> IO (FunPtr a)
+ , moduleClose -- :: Module -> IO Bool
+ , moduleError -- :: IO String
+ , withModule -- :: Maybe String
+ -- -> String
+ -- -> [ModuleFlags ]
+ -- -> (Module -> IO a)
+ -- -> IO a
+ , withModule_ -- :: Maybe String
+ -- -> String
+ -- -> [ModuleFlags]
+ -- -> (Module -> IO a)
+ -- -> IO ()
+ )
+where
+
+#include "HsUnix.h"
+
+import System.Posix.DynamicLinker
+import Foreign.Ptr ( Ptr, nullPtr, FunPtr )
+import Foreign.C.String ( withCString )
+
+-- abstract handle for dynamically loaded module (EXPORTED)
+--
+newtype Module = Module (Ptr ())
+
+unModule :: Module -> (Ptr ())
+unModule (Module adr) = adr
+
+-- Opens a module (EXPORTED)
+--
+
+moduleOpen :: String -> [RTLDFlags] -> IO Module
+moduleOpen mod flags = do
+ modPtr <- withCString mod $ \ modAddr -> c_dlopen modAddr (packRTLDFlags flags)
+ if (modPtr == nullPtr)
+ then moduleError >>= \ err -> ioError (userError ("dlopen: " ++ err))
+ else return $ Module modPtr
+
+-- Gets a symbol pointer from a module (EXPORTED)
+--
+moduleSymbol :: Module -> String -> IO (FunPtr a)
+moduleSymbol mod sym = dlsym (DLHandle (unModule mod)) sym
+
+-- Closes a module (EXPORTED)
+--
+moduleClose :: Module -> IO ()
+moduleClose mod = dlclose (DLHandle (unModule mod))
+
+-- Gets a string describing the last module error (EXPORTED)
+--
+moduleError :: IO String
+moduleError = dlerror
+
+
+-- Convenience function, cares for module open- & closing
+-- additionally returns status of `moduleClose' (EXPORTED)
+--
+withModule :: Maybe String
+ -> String
+ -> [RTLDFlags]
+ -> (Module -> IO a)
+ -> IO a
+withModule dir mod flags p = do
+ let modPath = case dir of
+ Nothing -> mod
+ Just p -> p ++ if ((head (reverse p)) == '/')
+ then mod
+ else ('/':mod)
+ mod <- moduleOpen modPath flags
+ result <- p mod
+ moduleClose mod
+ return result
+
+withModule_ :: Maybe String
+ -> String
+ -> [RTLDFlags]
+ -> (Module -> IO a)
+ -> IO ()
+withModule_ dir mod flags p = withModule dir mod flags p >>= \ _ -> return ()
diff --git a/System/Posix/DynamicLinker/Prim.hsc b/System/Posix/DynamicLinker/Prim.hsc
new file mode 100644
index 0000000..00457f1
--- /dev/null
+++ b/System/Posix/DynamicLinker/Prim.hsc
@@ -0,0 +1,122 @@
+{-# OPTIONS -fffi #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : System.Posix.DynamicLinker.Prim
+-- Copyright : (c) Volker Stolz <vs@foldr.org> 2003
+-- License : BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer : vs@foldr.org
+-- Stability : provisional
+-- Portability : non-portable (requires POSIX)
+--
+-- DLOpen and friend
+-- Derived from GModule.chs by M.Weber & M.Chakravarty which is part of c2hs
+-- I left the API more or less the same, mostly the flags are different.
+--
+-----------------------------------------------------------------------------
+
+module System.Posix.DynamicLinker.Prim (
+ -- * low level API
+ c_dlopen,
+ c_dlsym,
+ c_dlerror,
+ c_dlclose,
+ -- dlAddr, -- XXX NYI
+ haveRtldNext,
+ haveRtldLocal,
+ packRTLDFlags,
+ RTLDFlags(..),
+ packDL,
+ DL(..)
+ )
+
+where
+
+#include "HsUnix.h"
+
+import Data.Bits ( (.|.) )
+import Foreign.Ptr ( Ptr, FunPtr, nullPtr )
+import Foreign.C.Types ( CInt )
+import Foreign.C.String ( CString )
+
+-- RTLD_NEXT madness
+-- On some host (e.g. SuSe Linux 7.2) RTLD_NEXT is not visible
+-- without setting _GNU_SOURCE. Since we don't want to set this
+-- flag, here's a different solution: You can use the Haskell
+-- function 'haveRtldNext' to check wether the flag is available
+-- to you. Ideally, this will be optimized by the compiler so
+-- that it should be as efficient as an #ifdef.
+-- If you fail to test the flag and use it although it is
+-- undefined, 'packOneModuleFlag' will bomb.
+-- The same applies to RTLD_LOCAL which isn't available on
+-- cygwin.
+
+haveRtldNext :: Bool
+
+#ifdef HAVE_RTLDNEXT
+haveRtldNext = True
+
+foreign import ccall unsafe "__hsunix_rtldNext" rtldNext :: Ptr a
+
+#else /* HAVE_RTLDNEXT */
+haveRtldNext = False
+#endif /* HAVE_RTLDNEXT */
+
+haveRtldLocal :: Bool
+
+#ifdef HAVE_RTLDLOCAL
+haveRtldLocal = True
+#else /* HAVE_RTLDLOCAL */
+haveRtldLocal = False
+#endif /* HAVE_RTLDLOCAL */
+
+data RTLDFlags
+ = RTLD_LAZY
+ | RTLD_NOW
+ | RTLD_GLOBAL
+ | RTLD_LOCAL
+ deriving (Show, Read)
+
+foreign import ccall unsafe "dlopen" c_dlopen :: CString -> CInt -> IO (Ptr ())
+foreign import ccall unsafe "dlsym" c_dlsym :: Ptr () -> CString -> IO (FunPtr a)
+foreign import ccall unsafe "dlerror" c_dlerror :: IO CString
+foreign import ccall unsafe "dlclose" c_dlclose :: (Ptr ()) -> IO CInt
+
+packRTLDFlags :: [RTLDFlags] -> CInt
+packRTLDFlags flags = foldl (\ s f -> (packRTLDFlag f) .|. s) 0 flags
+
+packRTLDFlag :: RTLDFlags -> CInt
+packRTLDFlag RTLD_LAZY = #const RTLD_LAZY
+
+#ifdef HAVE_RTLDNOW
+packRTLDFlag RTLD_NOW = #const RTLD_NOW
+#else /* HAVE_RTLDNOW */
+packRTLDFlag RTLD_NOW = error "RTLD_NOW not available"
+#endif /* HAVE_RTLDNOW */
+
+#ifdef HAVE_RTLDGLOBAL
+packRTLDFlag RTLD_GLOBAL = #const RTLD_GLOBAL
+#else /* HAVE_RTLDGLOBAL */
+packRTLDFlag RTLD_GLOBAL = error "RTLD_GLOBAL not available"
+#endif
+
+#ifdef HAVE_RTLDLOCAL
+packRTLDFlag RTLD_LOCAL = #const RTLD_LOCAL
+#else /* HAVE_RTLDLOCAL */
+packRTLDFlag RTLD_LOCAL = error "RTLD_LOCAL not available"
+#endif /* HAVE_RTLDLOCAL */
+
+-- |Flags for 'dlsym'. Notice that @Next@ might not be available on
+-- your particular platform!
+
+data DL = Null | Next | Default | DLHandle (Ptr ()) deriving (Show)
+
+packDL :: DL -> Ptr ()
+packDL Null = nullPtr
+#ifdef HAVE_RTLDNEXT
+packDL Next = rtldNext
+#else
+packDL Next = error "RTLD_NEXT not available"
+#endif
+packDL Default = nullPtr
+packDL (DLHandle h) = h
generated by cgit v1.2.3 (git 2.39.1) at 2024-07-02 05:49:28 +0000