[project @ 2003-05-16 06:41:25 by stolz]

- move System.DL to System.Posix.DynamicLinker
- take ownership

There's a compiler warning when passing the 'const char*' result from
dlerror() to peekCString (discarded qualifier). Does an FFI-expert know
how to get rid of this warning?

1 files changed, 120 insertions, 0 deletions

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 ()