module Foreign.LibLTDL (
Advice(..),
DLException(..),
DLHandle(..),
SearchPath,
dlInit,
dlExit,
dlOpen,
dlOpenExt,
dlOpenAdvise,
dlClose,
dlSym,
dlSetSearchPath,
dlGetSearchPath,
dlForEachFile,
dlMakeResident,
dlIsResident
) where
import Control.Exception
import Control.Monad (liftM)
import Data.List (foldl')
import Data.Typeable
import Foreign
import Foreign.C.String
import Foreign.C.Types
import Foreign.LibLTDL.Internal
type SearchPath = [FilePath]
foreign import ccall "wrapper"
mkCallback :: (CString -> Ptr a -> IO CInt) -> IO (FunPtr (CString -> Ptr a -> IO CInt))
newtype DLException = DLException String
deriving (Show, Typeable)
instance Exception DLException
withNULLCString :: Maybe String -> (CString -> IO a) -> IO a
withNULLCString Nothing f = f nullPtr
withNULLCString (Just s) f = withCString s f
withCSearchPath :: SearchPath -> (CString -> IO a) -> IO a
withCSearchPath path f =
withCString (foldl' (\x y -> x ++ lT_PATHSEP_CHAR : y) [] path) f
withNULLCSearchPath :: Maybe SearchPath -> (CString -> IO a) -> IO a
withNULLCSearchPath Nothing f =
f nullPtr
withNULLCSearchPath (Just path) f =
withCString (foldl' (\x y -> x ++ lT_PATHSEP_CHAR : y) [] path) f
checkDLResult :: CInt -> IO ()
checkDLResult i
| i < 0 = dlError
| otherwise = return ()
checkDLOpenResult :: (CString -> IO DLHandle) -> Maybe String -> IO DLHandle
checkDLOpenResult dlopen maybe_filename =
withNULLCString maybe_filename $ \cfilename -> do
h <- dlopen cfilename
if unDLHandle h == nullPtr
then dlError
else return h
dlError :: IO a
dlError = c_lt_dlerror >>= peekCString >>= throwIO . DLException
dlInit :: IO ()
dlInit = c_lt_dlinit >>= checkDLResult
dlExit :: IO ()
dlExit = c_lt_dlinit >>= checkDLResult
dlOpen :: Maybe String -> IO DLHandle
dlOpen = checkDLOpenResult c_lt_dlopen
dlOpenExt :: Maybe String -> IO DLHandle
dlOpenExt = checkDLOpenResult c_lt_dlopenext
data Advice = Ext
| Global
| Local
| Resident
| Preload
deriving (Eq, Ord, Enum, Show)
withAdvice :: [Advice] -> (Ptr DLAdvise -> IO a) -> IO a
withAdvice flags f =
alloca $ \advPtr -> do
c_lt_dladvise_init advPtr >>= checkDLResult
c_lt_dladvise_ext advPtr >>= checkDLResult
(mapM_ (setFlag advPtr) flags >> f advPtr)
`finally` (c_lt_dladvise_destroy advPtr >>= checkDLResult)
where
setFlag :: Ptr DLAdvise -> Advice -> IO ()
setFlag advPtr Ext = c_lt_dladvise_ext advPtr >>= checkDLResult
setFlag advPtr Global = c_lt_dladvise_global advPtr >>= checkDLResult
setFlag advPtr Local = c_lt_dladvise_local advPtr >>= checkDLResult
setFlag advPtr Resident = c_lt_dladvise_resident advPtr >>= checkDLResult
setFlag advPtr Preload = c_lt_dladvise_preload advPtr >>= checkDLResult
dlOpenAdvise :: [Advice] -> Maybe String -> IO DLHandle
dlOpenAdvise flags name =
withAdvice flags $ \advPtr -> do
adv <- peek advPtr
checkDLOpenResult (\cname -> c_lt_dlopenadvise cname adv) name
dlClose :: DLHandle -> IO ()
dlClose h =
c_lt_dlclose h >>= checkDLResult
dlSym :: DLHandle -> String -> IO (FunPtr a)
dlSym h name =
withCString name $ \cname -> do
fptr <- c_lt_dlsym h cname
if fptr == nullFunPtr
then dlError
else return fptr
dlSetSearchPath :: SearchPath -> IO ()
dlSetSearchPath path =
withCSearchPath path $ \cpath ->
c_lt_dlsetsearchpath cpath >>= checkDLResult
dlGetSearchPath :: IO SearchPath
dlGetSearchPath = do
cpath <- c_lt_dlgetsearchpath
if cpath == nullPtr
then return []
else peekCString cpath >>= return . paths
where
paths :: String -> SearchPath
paths s =
let (p, s') = break (== lT_PATHSEP_CHAR) s
in p : case s' of
[] -> []
(_:s'') -> paths s''
dlForEachFile :: Maybe SearchPath -> (String -> IO Int) -> IO Int
dlForEachFile path f =
withNULLCSearchPath path $ \cpath -> do
callback' <- mkCallback callback
result <- c_lt_dlforeachfile cpath callback' nullPtr
freeHaskellFunPtr callback'
return (fromIntegral result)
where
callback :: CString -> Ptr a -> IO CInt
callback cfilename _ =
peekCString cfilename >>= f >>= return . fromIntegral
dlMakeResident :: DLHandle -> IO ()
dlMakeResident h =
c_lt_dlmakeresident h >>= checkDLResult
dlIsResident :: DLHandle -> IO Bool
dlIsResident h = do
result <- c_lt_dlisresident h
case result of
1 -> return True
_ -> return False