rtld (empty) → 0.0.2
raw patch · 6 files changed
+531/−0 lines, 6 filesdep +basesetup-changed
Dependencies added: base
Files
- LICENSE +13/−0
- README.md +13/−0
- Setup.hs +2/−0
- System/RTLD.h +174/−0
- System/RTLD.hsc +275/−0
- rtld.cabal +54/−0
+ LICENSE view
@@ -0,0 +1,13 @@+Copyright (c) 2012-2014 Krzysztof Kardzis++Permission to use, copy, modify, and/or distribute this software for any+purpose with or without fee is hereby granted, provided that the above+copyright notice and this permission notice appear in all copies.++THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES+WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF+MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR+ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES+WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN+ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF+OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ README.md view
@@ -0,0 +1,13 @@+# System.RTLD [![Build Status][travis.img]][travis.htm]++Dynamic linker tools for Haskell.+++[![Analytics][ga.img]][ga.htm]++[ga.img]: https://ga-beacon.appspot.com/UA-53767359-1/github/rtld+[ga.htm]: https://github.com/igrigorik/ga-beacon++[travis.img]: https://travis-ci.org/kkardzis/rtld.svg+[travis.htm]: https://travis-ci.org/kkardzis/rtld+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ System/RTLD.h view
@@ -0,0 +1,174 @@+/* ------------------------------------------------------------------------- */+/* | */+/* Module : System.RTLD */+/* Copyright : Copyright © 2012-2014 Krzysztof Kardzis */+/* License : ISC License (MIT/BSD-style, see LICENSE file for details) */+/* */+/* Maintainer : Krzysztof Kardzis <kkardzis@gmail.com> */+/* Stability : experimental */+/* Portability : non-portable */+/* */+/* ------------------------------------------------------------------------- */++#include <string.h>+#include <stdio.h>+++/* ------------------------------------------------------------------------- */+/* SYMTABENTRY structure and some macros (for hsc2hs) */+/* ------------------------------------------------------------------------- */+typedef struct {int vmin; int vmax; char* name;} SYMTABENTRY;++#define TABLEN (sizeof (SYMTAB) / sizeof (*SYMTAB))++#define hsc_FPID(fn) \+ { int i; for (i = 0; i < TABLEN; i++) { \+ if (strcmp(#fn, SYMTAB[i].name) == 0) { \+ printf("("); hsc_const(i); printf(")"); \+ break; \+ }; \+ }; \+ }++#define hsc_alignof(type) \+ printf("(%ld)", (long) offsetof (struct {char x; type y;}, y));+++/* ------------------------------------------------------------------------- */+/* function import macros (for hsc2hs) */+/* ------------------------------------------------------------------------- */++#ifdef STDCALLCONV+# define hsc_SAFECALL(fn,ft...) CALL(fn, TYPE(ft), stdcall safe, ARGS(ft));+# define hsc_FASTCALL(fn,ft...) CALL(fn, TYPE(ft), stdcall unsafe, ARGS(ft));+#else+# define hsc_SAFECALL(fn,ft...) CALL(fn, TYPE(ft), ccall safe, ARGS(ft));+# define hsc_FASTCALL(fn,ft...) CALL(fn, TYPE(ft), ccall unsafe, ARGS(ft));+#endif++#define CALL(fn, ft, conv, args) \+ printf("\n"); \+ printf("{-# NOINLINE " #fn " #-}\n"); \+ printf(#fn " :: " str(ft) "\n"); \+ printf(#fn " " str(args) " = peekFP "); hsc_FPID(fn); \+ printf(" >>= \\fp -> " #fn "FC fp " str(args) "\n"); \+ printf("\n"); \+ printf("type FT" #fn " = " str(ft) "\n"); \+ printf("foreign import " #conv " \"dynamic\"\n"); \+ printf(" " #fn "FC :: FunPtr FT" #fn " -> FT" #fn "\n");++#define CASE(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,X,...) X++#define TYPE(...) CASE(__VA_ARGS__ \+ , T16(__VA_ARGS__) , T15(__VA_ARGS__) \+ , T14(__VA_ARGS__) , T13(__VA_ARGS__) \+ , T12(__VA_ARGS__) , T11(__VA_ARGS__) \+ , T10(__VA_ARGS__) , T09(__VA_ARGS__) \+ , T08(__VA_ARGS__) , T07(__VA_ARGS__) \+ , T06(__VA_ARGS__) , T05(__VA_ARGS__) \+ , T04(__VA_ARGS__) , T03(__VA_ARGS__) \+ , T02(__VA_ARGS__) , T01(__VA_ARGS__) \+ )++#define T16(a, ...) a -> T15(__VA_ARGS__)+#define T15(a, ...) a -> T14(__VA_ARGS__)+#define T14(a, ...) a -> T13(__VA_ARGS__)+#define T13(a, ...) a -> T12(__VA_ARGS__)+#define T12(a, ...) a -> T11(__VA_ARGS__)+#define T11(a, ...) a -> T10(__VA_ARGS__)+#define T10(a, ...) a -> T09(__VA_ARGS__)+#define T09(a, ...) a -> T08(__VA_ARGS__)+#define T08(a, ...) a -> T07(__VA_ARGS__)+#define T07(a, ...) a -> T06(__VA_ARGS__)+#define T06(a, ...) a -> T05(__VA_ARGS__)+#define T05(a, ...) a -> T04(__VA_ARGS__)+#define T04(a, ...) a -> T03(__VA_ARGS__)+#define T03(a, ...) a -> T02(__VA_ARGS__)+#define T02(a, ...) a -> T01(__VA_ARGS__)+#define T01(a ) a++#define ARGS(...) CASE(__VA_ARGS__ \+ , a b c d e f g h i j k l m n o \+ , a b c d e f g h i j k l m n \+ , a b c d e f g h i j k l m \+ , a b c d e f g h i j k l \+ , a b c d e f g h i j k \+ , a b c d e f g h i j \+ , a b c d e f g h i \+ , a b c d e f g h \+ , a b c d e f g \+ , a b c d e f \+ , a b c d e \+ , a b c d \+ , a b c \+ , a b \+ , a \+ , \+ )++#define str(s) #s+++/* ------------------------------------------------------------------------- */+/* callback import macros (for hsc2hs) */+/* ------------------------------------------------------------------------- */++#ifdef STDBACKCONV+# define BACKCONV "stdcall"+#else+# define BACKCONV "ccall"+#endif++#define hsc_WRAP(fn, ft) \+ printf("\n"); \+ printf("type " #fn " = " #ft "\n"); \+ printf("\n"); \+ printf("foreign import " BACKCONV " \"wrapper\"\n"); \+ printf(" wrap" #fn " :: " #fn " -> IO (FunPtr " #fn ")\n"); \+++/* ------------------------------------------------------------------------- */+/* constant import macros (for hsc2hs) */+/* ------------------------------------------------------------------------- */++#define hsc_ENUM(type, ...) \+ printf("data " #type "\n"); \+ { char *x, xs[] = #__VA_ARGS__; \+ printf(" = %s\n", strtok(xs,",")); \+ while ((x=strtok(NULL,",")) != NULL) { \+ printf(" |%s\n", x); \+ }; \+ }; \+ printf("\n"); \+ printf("instance ENUM " #type " where\n"); \+ printf(" enumlist = [ " #__VA_ARGS__ " ]\n"); \+ printf(" toENUM x = case x of\n"); \+ { char *x, xs[] = #__VA_ARGS__; \+ long long vs[] = {__VA_ARGS__}; int i=1; \+ printf(" %s -> %lld\n", strtok(xs,","), vs[0]); \+ while ((x=strtok(NULL,",")) != NULL) { \+ printf(" %s -> %lld\n", x, vs[i++]); \+ }; \+ }; \++#define hsc_GADT(type, ...) \+ printf("data " #type " where\n"); \+ { int i=0; struct {int v; char *s;} vs[] = {__VA_ARGS__}; \+ char xs[] = #__VA_ARGS__; char *x = strtok(xs,","); \+ do { printf(" %s :: %s\n", x+1, vs[i++].s); strtok(NULL,","); \+ } while ((x=strtok(NULL,",")) != NULL); \+ }; \+ printf("\ninstance ENUM (" #type ") where\n"); \+ printf(" enumlist = []\n"); \+ printf(" toENUM x = case x of\n"); \+ { int i=0; struct {long long v; char *s;} vs[] = {__VA_ARGS__}; \+ char xs[] = #__VA_ARGS__; char *x = strtok(xs,","); \+ do { printf(" %s -> %lld\n", x+1, vs[i++].v); strtok(NULL,","); \+ } while ((x=strtok(NULL,",")) != NULL); \+ }; \++#define T4(x) "(" #x ", " #x ", " #x ", " #x ")"+#define T3(x) "(" #x ", " #x ", " #x ")"+#define T2(x) "(" #x ", " #x ")"+#define T1(x) "(" #x ")"+
+ System/RTLD.hsc view
@@ -0,0 +1,275 @@+-------------------------------------------------------------------------------+-- |+-- Module : System.RTLD+-- Copyright : Copyright © 2012-2014 Krzysztof Kardzis+-- License : ISC License (MIT/BSD-style, see LICENSE file for details)+-- +-- Maintainer : Krzysztof Kardzis <kkardzis@gmail.com>+-- Stability : experimental+-- Portability : non-portable+--+-- <<https://ga-beacon.appspot.com/UA-53767359-1/hackage/rtld/RTLD>>+-------------------------------------------------------------------------------+{-# LANGUAGE ForeignFunctionInterface #-}++module System.RTLD+ ( RTLD (..)+ + , LIBH, dynload, dynfree, dynfunc, dynfail++ , SYMTABENTRY (..)+ , RTSO (..)+ , rtload+ , rtfree++ ) where++import Foreign.C.String+import Foreign.C.Types+import Foreign.Ptr+import Foreign.Storable+import Foreign.Marshal.Array+import Foreign.Marshal.Utils (toBool)+#ifdef WINRTLD+import Foreign.Marshal.Alloc (alloca)+#endif++import Control.Concurrent (MVar, modifyMVar_)+import Control.Exception (bracket_, bracketOnError)+import Control.Monad (when, void, foldM)++#include "RTLD.h"+++-------------------------------------------------------------------------------+class RTLD so where+ withlib :: so -> IO a -> IO a+ loadlib :: so -> IO ()+ freelib :: so -> IO ()++ withlib so = bracket_ (loadlib so) (freelib so)+++-------------------------------------------------------------------------------+type LIBH = Ptr ()+++-------------------------------------------------------------------------------+#ifdef WINRTLD++#define WIN32_LEAN_AND_MEAN+#include <windows.h>++dynload :: String -> IO LIBH+dynload xs = withCString xs loadLibrary++dynfunc :: LIBH -> Ptr CChar -> IO (FunPtr ())+dynfunc = getProcAddress++dynfree :: LIBH -> IO Bool+dynfree hm = fmap toBool (freeLibrary hm)++dynfail :: IO String+dynfail = alloca $ \csptr -> do+ err <- getLastError+ st <- formatMessage dwflags nullPtr err 0 csptr 0 nullPtr+ xs <- if (st==0) then return "" else peek csptr >>= peekCString+ _ <- peek csptr >>= \cs -> localFree (castPtr cs)+ return $ concat ["(", show err, ") ", xs]++dwflags :: DWORD+dwflags = #{const (FORMAT_MESSAGE_ALLOCATE_BUFFER|FORMAT_MESSAGE_FROM_SYSTEM)}++type FARPROC = FunPtr ()+type HMODULE = Ptr ()+type HLOCAL = Ptr ()+type LPCVOID = Ptr ()+type LPCSTR = Ptr CChar+type LPSTR = Ptr (Ptr CChar) -- actually should be (Ptr CChar)+type DWORD = CULong+type BOOL = CInt++foreign import stdcall "LoadLibraryA"+ loadLibrary :: LPCSTR -> IO HMODULE++foreign import stdcall "GetProcAddress"+ getProcAddress :: HMODULE -> LPCSTR -> IO FARPROC++foreign import stdcall "FreeLibrary"+ freeLibrary :: HMODULE -> IO BOOL++foreign import stdcall "GetLastError"+ getLastError :: IO DWORD++foreign import stdcall "FormatMessageA"+ formatMessage :: DWORD -> LPCVOID -> DWORD -> DWORD+ -> LPSTR -> DWORD -> Ptr () -> IO DWORD++foreign import stdcall "LocalFree"+ localFree :: HLOCAL -> IO HLOCAL++++-------------------------------------------------------------------------------+#else++#include <dlfcn.h>++dynload :: String -> IO LIBH+dynload xs = withCString xs (\cs -> dlopen cs #{const RTLD_LAZY})++dynfunc :: LIBH -> Ptr CChar -> IO (FunPtr ())+dynfunc = dlsym++dynfree :: LIBH -> IO Bool+dynfree hm = fmap (not . toBool) (dlclose hm)++dynfail :: IO String+dynfail = dlerror >>= peekCString++foreign import ccall "dlopen" dlopen :: Ptr CChar -> CInt -> IO (Ptr ())+foreign import ccall "dlsym" dlsym :: Ptr () -> Ptr CChar -> IO (FunPtr ())+foreign import ccall "dlclose" dlclose :: Ptr () -> IO CInt+foreign import ccall "dlerror" dlerror :: IO (Ptr CChar)++#endif++++++-------------------------------------------------------------------------------+newtype SYMTABENTRY = RTSYM (CInt,CInt,(Ptr CChar))++instance Storable SYMTABENTRY where+ sizeOf _ = #{size SYMTABENTRY}+ alignment _ = #{alignof SYMTABENTRY}+ poke _ _ = undefined+ peek ptr = do+ vmin <- #{peek SYMTABENTRY, vmin} ptr+ vmax <- #{peek SYMTABENTRY, vmax} ptr+ name <- #{peek SYMTABENTRY, name} ptr+ return (RTSYM (vmin,vmax,name))+++-------------------------------------------------------------------------------+data RTSO a = RTSO+ { rtPKGMVAR :: MVar (Maybe (a, LIBH, Int))+ , rtPKGNAME :: String+ , rtLIBNAME :: a -> String+ , rtSONAMES :: a -> [String]+ , rtONLOAD :: a -> IO ()+ , rtONFREE :: a -> IO ()+ , rtGETAPI :: a -> IO (Maybe a)+ , rtSYMTAB :: Ptr SYMTABENTRY+ , rtADRTAB :: Ptr (FunPtr ())+ , rtTABLEN :: Int+ }+++-------------------------------------------------------------------------------+rtload :: (Ord a, Enum a, Bounded a) => RTSO a -> a -> IO ()+rtload rtso rqApi =+ modifyMVar_ (rtPKGMVAR rtso) $ \state -> case state of+ Nothing -> libloadA rtso rqApi >>= \(ldApi,h) -> return (Just (ldApi,h,1))+ Just (ldApi,h,x) -> libtest rtso rqApi ldApi >> return (Just (ldApi,h,x+1))++rtfree :: RTSO a -> IO ()+rtfree rtso =+ modifyMVar_ (rtPKGMVAR rtso) $ \state -> case state of+ Nothing -> return Nothing+ Just (ldApi,h,1) -> libfree rtso ldApi h >> return Nothing+ Just (ldApi,h,x) -> return (Just (ldApi,h,x-1))+++-------------------------------------------------------------------------------+libloadA :: (Ord a, Enum a, Bounded a) => RTSO a -> a -> IO (a, LIBH)+libloadA rtso rqApi =+ bracketOnError+ (foldM mloadfile Nothing (rtSONAMES rtso rqApi))+ (maybe (return ()) (void . dynfree . fst))+ (maybe (libloadfailA rtso rqApi) (libloadB rtso rqApi))++mloadfile :: Maybe (LIBH, String) -> String -> IO (Maybe (LIBH, String))+mloadfile mlh@(Just _) _ = return mlh+mloadfile Nothing soname =+ let check libh = if (libh==nullPtr) then Nothing else (Just (libh,soname))+ in fmap check (dynload soname)++libloadfailA :: RTSO a -> a -> IO (a, LIBH)+libloadfailA rtso rqApi = error $ concat+ [ rtPKGNAME rtso, " failed to load ", rtLIBNAME rtso rqApi+ , " ", show (rtSONAMES rtso rqApi) ]+++-------------------------------------------------------------------------------+libloadB :: (Ord a, Enum a, Bounded a)+ => RTSO a -> a -> (LIBH, String) -> IO (a, LIBH)+libloadB rtso rqApi so@(libh, soname) =+ bracketOnError (symload rtso libh) (const $ symfree rtso)+ (maybe (libloadfailB rtso rqApi soname) (libloadC rtso rqApi so))++libloadC :: (Ord a) => RTSO a -> a -> (LIBH, String) -> a -> IO (a, LIBH)+libloadC rtso rqApi (libh, soname) smApi =+ bracketOnError (rtONLOAD rtso smApi) (\_ -> rtONFREE rtso smApi)+ $ \_ -> do+ ldApiM <- rtGETAPI rtso smApi+ case ldApiM of+ Nothing -> libloadfailB rtso rqApi soname+ Just ldApi -> if (ldApi>=rqApi && smApi>=rqApi)+ then return ((min ldApi smApi), libh)+ else libloadfailB rtso rqApi soname++libloadfailB :: RTSO a -> a -> String -> IO (a, LIBH)+libloadfailB rtso rqApi soname = error $ concat+ [ rtPKGNAME rtso, " failed to load ", rtLIBNAME rtso rqApi+ , " ('", soname, "' found, but version doesn't match)" ]+++-------------------------------------------------------------------------------+libtest :: (Ord a) => RTSO a -> a -> a -> IO ()+libtest rtso rqApi ldApi = when (rqApi > ldApi) (libtestfail rtso rqApi ldApi)++libtestfail :: RTSO a -> a -> a -> IO ()+libtestfail rtso rqApi ldApi = error $ concat+ [ rtPKGNAME rtso, " version mismatch: "+ , rtLIBNAME rtso rqApi, " required, but "+ , rtLIBNAME rtso ldApi, " already loaded" ]+++-------------------------------------------------------------------------------+libfree :: RTSO a -> a -> LIBH -> IO ()+libfree rtso ldApi libh = do+ rtONFREE rtso ldApi+ x <- symfree rtso >> dynfree libh+ when (not x) (libfreefail rtso ldApi)++libfreefail :: RTSO a -> a -> IO ()+libfreefail rtso ldApi = error $ concat+ [ rtPKGNAME rtso, " failed to free ", rtLIBNAME rtso ldApi ]+++-------------------------------------------------------------------------------+symload :: (Ord a, Enum a, Bounded a) => RTSO a -> LIBH -> IO (Maybe a)+symload rtso libh = do+ (vmins,vmaxs,names) <- fmap vpack $ peekArray (rtTABLEN rtso) (rtSYMTAB rtso)+ addrs <- mapM (dynfunc libh) names+ pokeArray (rtADRTAB rtso) addrs+ return $ case (vtags (zip3 vmins vmaxs addrs)) of+ [] -> Nothing+ xs -> Just (maximum xs)++symfree :: RTSO a -> IO ()+symfree rtso =+ pokeArray (rtADRTAB rtso) (take (rtTABLEN rtso) (repeat nullFunPtr))++vpack :: (Enum a) => [SYMTABENTRY] -> ([a], [a], [Ptr CChar])+vpack xs = unzip3 $ map (\(RTSYM (x,y,z)) -> (foo x, foo y, z)) xs+ where foo = toEnum . fromIntegral++vtags :: (Ord a, Enum a, Bounded a) => [(a,a,FunPtr ())] -> [a]+vtags xs = filter (\x -> all (vtest x) xs) [minBound .. maxBound]++vtest :: (Ord a, Enum a, Bounded a) => a -> (a,a,FunPtr ()) -> Bool+vtest vnom (vmin,vmax,addr) = (addr/=nullFunPtr) || (vnom<vmin) || (vnom>vmax)+
+ rtld.cabal view
@@ -0,0 +1,54 @@+name: rtld+version: 0.0.2+synopsis: dynamic linker tools for Haskell+author: Krzysztof Kardzis <kkardzis@gmail.com>+maintainer: Krzysztof Kardzis <kkardzis@gmail.com>+copyright: Copyright © 2012-2014 Krzysztof Kardzis+-- license: ISC License (MIT/BSD-style, see LICENSE file for details)+license: OtherLicense+license-file: LICENSE+category: System+stability: Experimental+build-type: Simple+cabal-version: >=1.6+homepage: https://github.com/kkardzis/rtld++description:+ Package @rtld@ provides simplistic interface to the dynamic linker/loader.+ It wraps 'dlopen/dlclose' family of functions ('LoadLibrary/FreeLibrary'+ on Windows) and tries to provide a common interface to dynamically load+ foreign libraries at runtime. It is used currently as a helper package+ for @curlhs@ (<http://hackage.haskell.org/package/curlhs>), but is not+ ready for the public use (more tests and design decisions needed).+ .+ Package is distributed under ISC License (MIT/BSD-style, see LICENSE file+ for details). It is marked as @OtherLicense@ due to limitations of Cabal.+ .+ <<https://ga-beacon.appspot.com/UA-53767359-1/hackage/rtld>>++extra-source-files:+ README.md++library+ ghc-options: -Wall -fwarn-tabs+ build-depends: base ==4.*+ exposed-modules: System.RTLD+ install-includes: RTLD.h+ include-dirs: System++ if os(windows)+ cpp-options: -DWINRTLD++ if os(OSX)+ cpp-options: -DOSXRTLD++ if os(linux)+ cpp-options: -DGNURTLD++ if os(freebsd)+ cpp-options: -DBSDRTLD++source-repository head+ location: https://github.com/kkardzis/rtld+ type: git+