{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls, TypeSynonymInstances #-} {-# CFILES Database/Berkeley/dbxml_helper.cpp #-} module Database.Berkeley.DbXml ( ExceptionCode(..), getDbXmlError, DbXmlFlag(..), XmlManager, xmlManager_create, XmlContainer, ContainerType(..), xmlManager_openContainer, XmlTransaction, xmlManager_createTransaction, xmlTransaction_commit, xmlTransaction_abort, xmlContainer_getDocument, xmlContainer_getName, xmlDocument_getContent, XmlQueryContext, ReturnType(..), EvaluationType(..), xmlManager_createQueryContext, xmlManager_query, XmlResults, XmlResultsReturnable, xmlResults_hasNext, xmlResults_next, xmlManager_prepare, xmlQueryContext_setDefaultCollection, XmlValue, xmlNone, xmlString, xmlBool, xmlDouble, xmlValue_asString, xmlValue_asString8Bit, xmlQueryContext_setVariableValue, XmlQueryExpression, xmlQueryExpression_execute, xmlManager_createDocument, xmlDocument_getName, xmlDocument_setName, xmlManager_createUpdateContext, xmlDocument_setContent, xmlContainer_updateDocument, xmlContainer_putDocument, xmlContainer_deleteDocument ) where import Foreign.C import Foreign.Marshal.Alloc import Foreign.Storable import Foreign.Ptr import Foreign.ForeignPtr import Foreign.Marshal.Utils import Data.Bits import Database.Berkeley.Db import Database.Berkeley.Util import Data.Maybe import System.IO.Error import Data.Char import Data.Bits import System.IO.Unsafe toUtf8 :: String -> String toUtf8 = concatMap charToUtf8 charToUtf8 :: Char -> String charToUtf8 ch = let c = ord(ch)::Int f0 = c .&. 0x3f f1 = (c `shiftR` 6) .&. 0x3f f2 = (c `shiftR` 12) .&. 0x3f f3 = (c `shiftR` 18) .&. 0x07 in case c of _ | c <= 0x007f -> [ch] _ | c <= 0x07ff -> [chr(0xc0 .|. f1),chr(0x80 .|. f0)] _ | c <= 0xffff -> [chr(0xe0 .|. f2),chr(0x80 .|. f1),chr(0x80 .|. f0)] _ -> [chr(0xf0 .|. f3),chr(0x80 .|. f2),chr(0x80 .|. f1),chr(0x80 .|. f0)] {- charFromUtf8 :: String -> (Char, String) charFromUtf8 (ch:chs) = let c = ord(ch)::Int in case c of _ | (c .&. 0x80) == 0 -> (c, cs) _ | (c .&. 0xc0) == 0xe0 -> ((c .&. 0x1f) `shiftL` 6) .|. -} fromUtf8 :: String -> String fromUtf8 t = t -- to do {-fromUtf8 [] = [] fromUtf8 t = let (c, rest) = charFromUtf8 in (c:fromUtf8 rest)-} data ExceptionCode = INTERNAL_ERROR | --An internal error occured. CONTAINER_OPEN | --The container is open. CONTAINER_CLOSED | --The container is closed. NULL_POINTER | --null pointer exception INDEXER_PARSER_ERROR | --XML Indexer could not parse a document. DATABASE_ERROR | --Berkeley DB reported a database problem. QUERY_PARSER_ERROR | --The query parser was unable to parse the expression. UNUSED1_ERROR | --Unused QUERY_EVALUATION_ERROR | --The query evaluator was unable to execute the expression. UNUSED2_ERROR | --Unused LAZY_EVALUATION | --XmlResults is lazily evaluated. DOCUMENT_NOT_FOUND | --The specified document could not be found CONTAINER_EXISTS | --The container already exists. UNKNOWN_INDEX | --The indexing strategy name is unknown. INVALID_VALUE | --An invalid parameter was passed. VERSION_MISMATCH | --The container version and the dbxml library version are not compatible. EVENT_ERROR | --Error using the event reader CONTAINER_NOT_FOUND | --The specified container could not be found TRANSACTION_ERROR | --An XmlTransaction has already been committed or aborted UNIQUE_ERROR | --A uniqueness constraint has been violated NO_MEMORY_ERROR | --Unable to allocate memory OPERATION_TIMEOUT | --An operation timed out OPERATION_INTERRUPTED --An operation was explicitly interrupted deriving (Show,Eq) dbxmlErrFromNum 0 = Just INTERNAL_ERROR dbxmlErrFromNum 1 = Just CONTAINER_OPEN dbxmlErrFromNum 2 = Just CONTAINER_CLOSED dbxmlErrFromNum 3 = Just NULL_POINTER dbxmlErrFromNum 4 = Just INDEXER_PARSER_ERROR dbxmlErrFromNum 5 = Just DATABASE_ERROR dbxmlErrFromNum 6 = Just QUERY_PARSER_ERROR dbxmlErrFromNum 7 = Just UNUSED1_ERROR dbxmlErrFromNum 8 = Just QUERY_EVALUATION_ERROR dbxmlErrFromNum 9 = Just UNUSED2_ERROR dbxmlErrFromNum 10 = Just LAZY_EVALUATION dbxmlErrFromNum 11 = Just DOCUMENT_NOT_FOUND dbxmlErrFromNum 12 = Just CONTAINER_EXISTS dbxmlErrFromNum 13 = Just UNKNOWN_INDEX dbxmlErrFromNum 14 = Just INVALID_VALUE dbxmlErrFromNum 15 = Just VERSION_MISMATCH dbxmlErrFromNum 16 = Just EVENT_ERROR dbxmlErrFromNum 17 = Just CONTAINER_NOT_FOUND dbxmlErrFromNum 18 = Just TRANSACTION_ERROR dbxmlErrFromNum 19 = Just UNIQUE_ERROR dbxmlErrFromNum 20 = Just NO_MEMORY_ERROR dbxmlErrFromNum 21 = Just OPERATION_TIMEOUT dbxmlErrFromNum 22 = Just OPERATION_INTERRUPTED dbxmlErrFromNum _ = Nothing getDbXmlError :: IOError -> Maybe ExceptionCode getDbXmlError ioError = if isUserError ioError then let s = ioeGetErrorString ioError in case extract "dbxml=\"" s ['"'] of Just nStr -> dbxmlErrFromNum $ fromMaybe 0 $ maybeRead nStr Nothing -> Nothing else Nothing -- | Note: If you want to pass a Berkeley DB flag where the type is DbXmlFlag, -- use the DB_FLAG constructor. data DbXmlFlag = DBXML_ADOPT_DBENV | -- ^ take ownership of DbEnv DBXML_ALLOW_EXTERNAL_ACCESS | -- ^ allow FS and net access DBXML_ALLOW_AUTO_OPEN | -- ^ auto-open in queries -- | Flags used for container create/open DBXML_ALLOW_VALIDATION | -- ^ validate if specified DBXML_TRANSACTIONAL | -- ^ transactional container DBXML_CHKSUM | -- ^ use DB_CKSUM DBXML_ENCRYPT | -- ^ db->set_flags(DB_ENCRYPT); DBXML_INDEX_NODES | -- ^ use node indexes DBXML_NO_INDEX_NODES | -- ^ also used by lookupIndex DBXML_STATISTICS | -- ^ Store statistics about the data DBXML_NO_STATISTICS | -- ^ Do not store statistics about the data -- | these next three are only used by XmlContainer::lookupIndex, and can -- | safely re-use the preceding enumeration values. DBXML_REVERSE_ORDER | -- ^ return in reverse sort DBXML_INDEX_VALUES | -- ^ return values also DBXML_CACHE_DOCUMENTS | -- ^ ensure that two index entries that refer to the same document return the exact same XmlDocument object DBXML_LAZY_DOCS | -- ^ lazily materialize docs DBXML_DOCUMENT_PROJECTION | -- ^Use the document projection optimisation DBXML_NO_AUTO_COMMIT | -- ^ Do not auto transact the operation -- | below used for putDocument, and query operations (reuses enum) DBXML_WELL_FORMED_ONLY | -- ^ well-formed parser only -- | only used in putDocument, safe to reuse enum above DBXML_GEN_NAME | -- ^ generate name in putDoc DB_FLAG DbFlag -- ^ For wrapping a Berkeley DB flag dbxmlToNum DBXML_ADOPT_DBENV = 0x00000001 dbxmlToNum DBXML_ALLOW_EXTERNAL_ACCESS = 0x00000002 dbxmlToNum DBXML_ALLOW_AUTO_OPEN = 0x00000004 dbxmlToNum DBXML_ALLOW_VALIDATION = 0x00100000 dbxmlToNum DBXML_TRANSACTIONAL = 0x00200000 dbxmlToNum DBXML_CHKSUM = 0x00400000 dbxmlToNum DBXML_ENCRYPT = 0x00800000 dbxmlToNum DBXML_INDEX_NODES = 0x01000000 dbxmlToNum DBXML_NO_INDEX_NODES = 0x00010000 dbxmlToNum DBXML_STATISTICS = 0x02000000 dbxmlToNum DBXML_NO_STATISTICS = 0x04000000 dbxmlToNum DBXML_REVERSE_ORDER = 0x00100000 dbxmlToNum DBXML_INDEX_VALUES = 0x00200000 dbxmlToNum DBXML_CACHE_DOCUMENTS = 0x00400000 dbxmlToNum DBXML_LAZY_DOCS = 0x00800000 dbxmlToNum DBXML_DOCUMENT_PROJECTION = 0x80000000 dbxmlToNum DBXML_NO_AUTO_COMMIT = 0x00020000 dbxmlToNum DBXML_WELL_FORMED_ONLY = 0x01000000 dbxmlToNum DBXML_GEN_NAME = 0x02000000 dbxmlToNum (DB_FLAG f) = dbToNum f dbxmlOrFlags flags = foldr (.|.) 0 $ map dbxmlToNum flags throw :: String -> CInt -> String -> IO a throw func code extra = do ioError $ userError $ "db error func="++func++" db=\""++(show dbCode)++"\" dbxml=\""++(show dbXmlCode)++"\""++extra where dbCode = -(code `mod` 100000) dbXmlCode = (code `div` 100000) - 1 data XmlManager_struct type XmlManager = Ptr XmlManager_struct foreign import ccall unsafe "dbxml_helper.h _xmlManager" _xmlManager :: DbEnv -> CUInt -> Ptr XmlManager -> IO CInt xmlManager_create :: DbEnv -> [DbXmlFlag] -> IO XmlManager xmlManager_create dbenv flags = alloca $ \ptr -> do ret <- _xmlManager dbenv (dbxmlOrFlags flags) ptr if ret /= 0 then throw "xmlManager" ret "" else peek ptr data XmlContainer_struct type XmlContainer = ForeignPtr XmlContainer_struct foreign import ccall "dbxml_helper.h &_xmlContainer_delete" _xmlContainer_delete :: FunPtr (Ptr XmlContainer_struct -> IO ()) data ContainerType = NodeContainer | WholedocContainer foreign import ccall unsafe "dbxml_helper.h _xmlManager_openContainer" _xmlManager_openContainer :: XmlManager -> CString -> CUInt -> CInt -> CInt -> Ptr (Ptr XmlContainer_struct) -> IO CInt xmlManager_openContainer :: XmlManager -> String -> [DbXmlFlag] -> ContainerType -> Int -> IO XmlContainer xmlManager_openContainer mgr filename flags cType mode = alloca $ \ptr -> withCAString filename $ \c_filename -> do ret <- _xmlManager_openContainer mgr c_filename (dbxmlOrFlags flags) (numCType cType) (fromIntegral mode) ptr if ret /= 0 then throw "xmlManager_openContainer" ret "" else do p <- peek ptr newForeignPtr _xmlContainer_delete p where numCType NodeContainer = 0 numCType WholedocContainer = 1 data XmlTransaction_struct type XmlTransaction = ForeignPtr XmlTransaction_struct foreign import ccall "dbxml_helper.h &_xmlTransaction_delete" _xmlTransaction_delete :: FunPtr (Ptr XmlTransaction_struct -> IO ()) foreign import ccall unsafe "dbxml_helper.h _xmlManager_createTransaction" _xmlManager_createTransaction :: XmlManager -> CUInt -> Ptr (Ptr XmlTransaction_struct) -> IO CInt xmlManager_createTransaction :: XmlManager -> [DbFlag] -> IO XmlTransaction xmlManager_createTransaction mgr flags = alloca $ \ptr -> do ret <- _xmlManager_createTransaction mgr (dbOrFlags flags) ptr if ret /= 0 then throw "xmlManager_createTransaction" ret "" else do p <- peek ptr newForeignPtr _xmlTransaction_delete p foreign import ccall unsafe "dbxml_helper.h _xmlTransaction_commit" _xmlTransaction_commit :: Ptr XmlTransaction_struct -> IO CInt xmlTransaction_commit :: XmlTransaction -> IO () xmlTransaction_commit trans = do ret <- _xmlTransaction_commit (unsafeForeignPtrToPtr trans) touchForeignPtr trans if ret /= 0 then throw "xmlTransaction_commit" ret "" else return () foreign import ccall unsafe "dbxml_helper.h _xmlTransaction_abort" _xmlTransaction_abort :: Ptr XmlTransaction_struct -> IO CInt xmlTransaction_abort :: XmlTransaction -> IO () xmlTransaction_abort trans = do ret <- _xmlTransaction_abort (unsafeForeignPtrToPtr trans) touchForeignPtr trans if ret /= 0 then throw "xmlTransaction_abort" ret "" else return () data XmlDocument_struct type XmlDocument = ForeignPtr XmlDocument_struct foreign import ccall unsafe "dbxml_helper.h &_xmlDocument_delete" _xmlDocument_delete :: FunPtr (Ptr XmlDocument_struct -> IO ()) foreign import ccall unsafe "dbxml_helper.h _xmlContainer_getDocument" _xmlContainer_getDocument :: Ptr XmlContainer_struct -> Ptr XmlTransaction_struct -> CString -> CUInt -> Ptr (Ptr XmlDocument_struct) -> IO CInt xmlContainer_getDocument :: XmlContainer -> Maybe XmlTransaction -> String -> [DbFlag] -> IO XmlDocument xmlContainer_getDocument cont mTrans key flags = alloca $ \ptr -> withCAString (toUtf8 key) $ \c_key -> do let cont_ = unsafeForeignPtrToPtr cont ret <- case mTrans of Just trans -> do ret_ <- _xmlContainer_getDocument cont_ (unsafeForeignPtrToPtr trans) c_key (dbOrFlags flags) ptr touchForeignPtr trans return ret_ Nothing -> do _xmlContainer_getDocument cont_ nullPtr c_key (dbOrFlags flags) ptr touchForeignPtr cont if ret /= 0 then throw "xmlContainer_getDocument" ret "" else do p <- peek ptr newForeignPtr _xmlDocument_delete p foreign import ccall unsafe "db_helper.h _deleteString" _deleteString :: CString -> IO () foreign import ccall unsafe "dbxml_helper.h _xmlContainer_getName" _xmlContainer_getName :: Ptr XmlContainer_struct -> IO CString xmlContainer_getName :: XmlContainer -> String xmlContainer_getName cont = unsafePerformIO$ do let cont_ = unsafeForeignPtrToPtr cont cstr <- _xmlContainer_getName cont_ touchForeignPtr cont str <- peekCAString cstr _deleteString cstr return $ fromUtf8 str foreign import ccall unsafe "dbxml_helper.h _xmlDocument_getContent" _xmlDocument_getContent :: Ptr XmlDocument_struct -> Ptr CString -> IO CInt xmlDocument_getContent :: XmlDocument -> IO String xmlDocument_getContent doc = alloca$ \ptr -> do ret <- _xmlDocument_getContent (unsafeForeignPtrToPtr doc) ptr touchForeignPtr doc if ret /= 0 then throw "xmlDocument_getContent" ret "" else do cstr <- peek ptr str <- peekCAString cstr _deleteString cstr return $ fromUtf8 str data XmlQueryContext_struct type XmlQueryContext = ForeignPtr XmlQueryContext_struct foreign import ccall unsafe "dbxml_helper.h &_xmlQueryContext_delete" _xmlQueryContext_delete :: FunPtr (Ptr XmlQueryContext_struct -> IO ()) foreign import ccall unsafe "dbxml_helper.h _xmlManager_createQueryContext" _xmlManager_createQueryContext :: Ptr XmlManager_struct -> CInt -> CInt -> Ptr (Ptr XmlQueryContext_struct) -> IO CInt data ReturnType = LiveValues rtToInt LiveValues = 0 data EvaluationType = Eager | Lazy evToInt Eager = 0 evToInt Lazy = 1 xmlManager_createQueryContext :: XmlManager -> ReturnType -> EvaluationType -> IO XmlQueryContext xmlManager_createQueryContext mgr rt ev = alloca $ \ptr -> do ret <- _xmlManager_createQueryContext mgr (rtToInt rt) (evToInt ev) ptr if ret /= 0 then throw "xmlManager_createQueryContext" ret "" else do p <- peek ptr newForeignPtr _xmlQueryContext_delete p data XmlResults_struct type XmlResults = ForeignPtr XmlResults_struct foreign import ccall "dbxml_helper.h &_xmlResults_delete" _xmlResults_delete :: FunPtr (Ptr XmlResults_struct -> IO ()) foreign import ccall unsafe "dbxml_helper.h _xmlResults_hasNext" _xmlResults_hasNext :: Ptr XmlResults_struct -> Ptr CInt -> IO CInt xmlResults_hasNext :: XmlResults -> IO Bool xmlResults_hasNext res = alloca $ \ptr -> do ret <- _xmlResults_hasNext (unsafeForeignPtrToPtr res) ptr touchForeignPtr res if ret /= 0 then throw "xmlResults_hasNext" ret "" else do answer <- peek ptr return $ if answer /= 0 then True else False class XmlResultsReturnable a where xmlResults_next :: XmlResults -> IO (Maybe a) instance XmlResultsReturnable XmlDocument where xmlResults_next = xmlResults_nextDocument instance XmlResultsReturnable XmlValue where xmlResults_next = xmlResults_nextValue foreign import ccall unsafe "dbxml_helper.h _xmlResults_nextDocument" _xmlResults_nextDocument :: Ptr XmlResults_struct -> Ptr (Ptr XmlDocument_struct) -> IO CInt xmlResults_nextDocument :: XmlResults -> IO (Maybe XmlDocument) xmlResults_nextDocument res = alloca $ \ptr -> do ret <- _xmlResults_nextDocument (unsafeForeignPtrToPtr res) ptr touchForeignPtr res if ret /= 0 then throw "xmlResults_next" ret "XmlDocument" else do doc <- peek ptr if doc == nullPtr then return Nothing else do fp <- newForeignPtr _xmlDocument_delete doc return $ Just fp foreign import ccall unsafe "dbxml_helper.h _xmlResults_nextValue" _xmlResults_nextValue :: Ptr XmlResults_struct -> Ptr (Ptr XmlValue_struct) -> IO CInt xmlResults_nextValue :: XmlResults -> IO (Maybe XmlValue) xmlResults_nextValue res = alloca $ \ptr -> do ret <- _xmlResults_nextValue (unsafeForeignPtrToPtr res) ptr touchForeignPtr res if ret /= 0 then throw "xmlResults_next" ret "XmlValue" else do doc <- peek ptr if doc == nullPtr then return Nothing else do fp <- newForeignPtr _xmlValue_delete doc return $ Just fp -- Safe so it doesn't block other Haskell threads, since this one can take a while to execute foreign import ccall safe "dbxml_helper.h _xmlManager_query" _xmlManager_query :: Ptr XmlManager_struct -> Ptr XmlTransaction_struct -> CString -> Ptr XmlQueryContext_struct -> CUInt -> Ptr (Ptr XmlResults_struct) -> IO CInt xmlManager_query :: XmlManager -> Maybe XmlTransaction -> String -> XmlQueryContext -> [DbXmlFlag] -> IO XmlResults xmlManager_query mgr mTrans query ctx flags = alloca $ \ptr -> withCAString (toUtf8 query) $ \c_query -> do ret <- case mTrans of Just trans -> do ret_ <- _xmlManager_query mgr (unsafeForeignPtrToPtr trans) c_query (unsafeForeignPtrToPtr ctx) (dbxmlOrFlags flags) ptr touchForeignPtr trans return ret_ Nothing -> do _xmlManager_query mgr nullPtr c_query (unsafeForeignPtrToPtr ctx) (dbxmlOrFlags flags) ptr if ret /= 0 then throw "xmlManager_query" ret (" query="++query) else do p <- peek ptr newForeignPtr _xmlResults_delete p data XmlQueryExpression_struct type XmlQueryExpression = ForeignPtr XmlQueryExpression_struct foreign import ccall "dbxml_helper.h &_xmlQueryExpression_delete" _xmlQueryExpression_delete :: FunPtr (Ptr XmlQueryExpression_struct -> IO ()) foreign import ccall unsafe "dbxml_helper.h _xmlManager_prepare" _xmlManager_prepare :: Ptr XmlManager_struct -> Ptr XmlTransaction_struct -> CString -> Ptr XmlQueryContext_struct -> Ptr (Ptr XmlQueryExpression_struct) -> IO CInt xmlManager_prepare :: XmlManager -> Maybe XmlTransaction -> String -> XmlQueryContext -> IO XmlQueryExpression xmlManager_prepare mgr mTrans query ctx = alloca $ \ptr -> withCAString (toUtf8 query) $ \c_query -> do ret <- case mTrans of Just trans -> do ret_ <- _xmlManager_prepare mgr (unsafeForeignPtrToPtr trans) c_query (unsafeForeignPtrToPtr ctx) ptr touchForeignPtr trans return ret_ Nothing -> do _xmlManager_prepare mgr nullPtr c_query (unsafeForeignPtrToPtr ctx) ptr if ret /= 0 then throw "xmlManager_prepare" ret (" query="++query) else do p <- peek ptr newForeignPtr _xmlQueryExpression_delete p foreign import ccall unsafe "dbxml_helper.h _xmlQueryContext_setDefaultCollection" _xmlQueryContext_setDefaultCollection :: Ptr XmlQueryContext_struct -> CString -> IO CInt xmlQueryContext_setDefaultCollection :: XmlQueryContext -> String -> IO () xmlQueryContext_setDefaultCollection ctx coll = withCAString coll $ \c_coll -> do ret <- _xmlQueryContext_setDefaultCollection (unsafeForeignPtrToPtr ctx) c_coll touchForeignPtr ctx if ret /= 0 then throw "xmlQueryContext_setDefaultCollection" ret (" arg="++coll) else return () data XmlValue_struct type XmlValue = ForeignPtr XmlValue_struct foreign import ccall "dbxml_helper.h &_xmlValue_delete" _xmlValue_delete :: FunPtr (Ptr XmlValue_struct -> IO ()) foreign import ccall unsafe "dbxml_helper.h _xmlNone" _xmlNone :: IO (Ptr XmlValue_struct) xmlNone :: XmlValue xmlNone = unsafePerformIO$ do xv <- _xmlNone newForeignPtr _xmlValue_delete xv foreign import ccall unsafe "dbxml_helper.h _xmlString" _xmlString :: CString -> IO (Ptr XmlValue_struct) xmlString :: String -> XmlValue xmlString text = unsafePerformIO$ do withCAString (toUtf8 text) $ \c_text -> do xv <- _xmlString c_text newForeignPtr _xmlValue_delete xv foreign import ccall unsafe "dbxml_helper.h _xmlBool" _xmlBool :: CInt -> IO (Ptr XmlValue_struct) xmlBool :: Bool -> XmlValue xmlBool b = unsafePerformIO$ do xv <- _xmlBool$ if b then 1 else 0 newForeignPtr _xmlValue_delete xv foreign import ccall unsafe "dbxml_helper.h _xmlDouble" _xmlDouble :: CDouble -> IO (Ptr XmlValue_struct) xmlDouble :: Double -> XmlValue xmlDouble value = unsafePerformIO$ do xv <- _xmlDouble$ realToFrac value newForeignPtr _xmlValue_delete xv foreign import ccall unsafe "dbxml_helper.h _xmlValue_asString" _xmlValue_asString :: Ptr XmlValue_struct -> Ptr CString -> IO CInt -- | Get the string content of this XmlValue object and decode UTF-8 to return -- a Unicode string. xmlValue_asString :: XmlValue -> IO String xmlValue_asString value = alloca$ \ptr -> do ret <- _xmlValue_asString (unsafeForeignPtrToPtr value) ptr touchForeignPtr value if ret /= 0 then throw "xmlValue_asString" ret "" else do cstr <- peek ptr str <- peekCAString cstr _deleteString cstr return $ fromUtf8 str -- | Get the string content of this XmlValue object, returning the string as -- 8-bit data. This is what you need if you are going to feed it into an XML -- parser. xmlValue_asString8Bit :: XmlValue -> IO String xmlValue_asString8Bit value = alloca$ \ptr -> do ret <- _xmlValue_asString (unsafeForeignPtrToPtr value) ptr touchForeignPtr value cstr <- peek ptr str <- peekCAString cstr _deleteString cstr return str foreign import ccall unsafe "dbxml_helper.h _xmlQueryContext_setVariableValue" _xmlQueryContext_setVariableValue :: Ptr XmlQueryContext_struct -> CString -> Ptr XmlValue_struct -> IO CInt xmlQueryContext_setVariableValue :: XmlQueryContext -> String -> XmlValue -> IO () xmlQueryContext_setVariableValue ctx name value = withCAString (toUtf8 name) $ \c_name -> do ret <- _xmlQueryContext_setVariableValue (unsafeForeignPtrToPtr ctx) c_name (unsafeForeignPtrToPtr value) touchForeignPtr ctx touchForeignPtr value if ret /= 0 then throw "xmlQueryContext_setVariableValue" ret (" name="++name++" value="++(show value)) else return () -- Safe so it doesn't block other Haskell threads, since this one can take a while to execute foreign import ccall safe "dbxml_helper.h _xmlQueryExpression_execute" _xmlQueryExpression_execute :: Ptr XmlQueryExpression_struct -> Ptr XmlTransaction_struct -> Ptr XmlValue_struct -> Ptr XmlQueryContext_struct -> CUInt -> Ptr (Ptr XmlResults_struct) -> IO CInt xmlQueryExpression_execute :: XmlQueryExpression -> Maybe XmlTransaction -> Maybe XmlValue -> XmlQueryContext -> [DbXmlFlag] -> IO XmlResults xmlQueryExpression_execute exp mTrans mContextItem qctx flags = alloca$ \ptr -> do let p2p = unsafeForeignPtrToPtr let exp_ = p2p exp let qctx_ = p2p qctx let flags_ = (dbxmlOrFlags flags) ret <- case (mTrans, mContextItem) of (Just trans, Just contextItem) -> do ret <- _xmlQueryExpression_execute exp_ (p2p trans) (p2p contextItem) qctx_ flags_ ptr touchForeignPtr trans touchForeignPtr contextItem return ret (Just trans, Nothing) -> do ret <- _xmlQueryExpression_execute exp_ (p2p trans) nullPtr qctx_ flags_ ptr touchForeignPtr trans return ret (Nothing, Just contextItem) -> do ret <- _xmlQueryExpression_execute exp_ nullPtr (p2p contextItem) qctx_ flags_ ptr touchForeignPtr contextItem return ret (Nothing, Nothing) -> do _xmlQueryExpression_execute exp_ nullPtr nullPtr qctx_ flags_ ptr touchForeignPtr exp touchForeignPtr qctx if ret /= 0 then throw "xmlQueryExpression_execute" ret "" else do p <- peek ptr newForeignPtr _xmlResults_delete p foreign import ccall unsafe "dbxml_helper.h _xmlManager_createDocument" _xmlManager_createDocument :: Ptr XmlManager_struct -> Ptr (Ptr XmlDocument_struct) -> IO CInt xmlManager_createDocument :: XmlManager -> IO XmlDocument xmlManager_createDocument mgr = alloca$ \ptr -> do ret <- _xmlManager_createDocument mgr ptr if ret /= 0 then throw "xmlManager_createDocument" ret "" else do p <- peek ptr newForeignPtr _xmlDocument_delete p foreign import ccall unsafe "dbxml_helper.h _xmlDocument_getName" _xmlDocument_getName :: Ptr XmlDocument_struct -> Ptr CString -> IO CInt xmlDocument_getName :: XmlDocument -> IO String xmlDocument_getName doc = alloca$ \ptr -> do ret <- _xmlDocument_getName (unsafeForeignPtrToPtr doc) ptr touchForeignPtr doc if ret /= 0 then throw "xmlDocument_getName" ret "" else do cstr <- peek ptr str <- peekCAString cstr _deleteString cstr return $ fromUtf8 str foreign import ccall unsafe "dbxml_helper.h _xmlDocument_setName" _xmlDocument_setName :: Ptr XmlDocument_struct -> CString -> IO CInt xmlDocument_setName :: XmlDocument -> String -> IO () xmlDocument_setName doc name = withCAString name$ \c_name -> do ret <- _xmlDocument_setName (unsafeForeignPtrToPtr doc) c_name touchForeignPtr doc if ret /= 0 then throw "xmlDocument_setName" ret "" else return () data XmlUpdateContext_struct type XmlUpdateContext = ForeignPtr XmlUpdateContext_struct foreign import ccall "dbxml_helper.h &_xmlUpdateContext_delete" _xmlUpdateContext_delete :: FunPtr (Ptr XmlUpdateContext_struct -> IO ()) foreign import ccall unsafe "dbxml_helper.h _xmlManager_createUpdateContext" _xmlManager_createUpdateContext :: Ptr XmlManager_struct -> Ptr (Ptr XmlUpdateContext_struct) -> IO CInt xmlManager_createUpdateContext :: XmlManager -> IO XmlUpdateContext xmlManager_createUpdateContext mgr = alloca$ \ptr -> do ret <- _xmlManager_createUpdateContext mgr ptr if ret /= 0 then throw "xmlManager_createUpdateContext" ret "" else do p <- peek ptr newForeignPtr _xmlUpdateContext_delete p foreign import ccall unsafe "dbxml_helper.h _xmlDocument_setContent" _xmlDocument_setContent :: Ptr XmlDocument_struct -> CString -> IO CInt xmlDocument_setContent :: XmlDocument -> String -> IO () xmlDocument_setContent doc text = withCAString text$ \c_text -> do ret <- _xmlDocument_setContent (unsafeForeignPtrToPtr doc) c_text touchForeignPtr doc if ret /= 0 then throw "xmlDocument_setContent" ret "" else return () foreign import ccall unsafe "dbxml_helper.h _xmlContainer_updateDocument" _xmlContainer_updateDocument :: Ptr XmlContainer_struct -> Ptr XmlTransaction_struct -> Ptr XmlDocument_struct -> Ptr XmlUpdateContext_struct -> IO CInt xmlContainer_updateDocument :: XmlContainer -> Maybe XmlTransaction -> XmlDocument -> XmlUpdateContext -> IO () xmlContainer_updateDocument cont mTrans doc uctx = do let cont_ = unsafeForeignPtrToPtr cont let doc_ = unsafeForeignPtrToPtr doc let uctx_ = unsafeForeignPtrToPtr uctx ret <- case mTrans of Just trans -> do let trans_ = unsafeForeignPtrToPtr trans ret <- _xmlContainer_updateDocument cont_ trans_ doc_ uctx_ touchForeignPtr trans return ret Nothing -> do _xmlContainer_updateDocument cont_ nullPtr doc_ uctx_ touchForeignPtr cont touchForeignPtr doc touchForeignPtr uctx if ret /= 0 then throw "xmlContainer_updateDocument" ret "" else return () foreign import ccall unsafe "dbxml_helper.h _xmlContainer_putDocument" _xmlContainer_putDocument :: Ptr XmlContainer_struct -> Ptr XmlTransaction_struct -> Ptr XmlDocument_struct -> Ptr XmlUpdateContext_struct -> CUInt -> IO CInt xmlContainer_putDocument :: XmlContainer -> Maybe XmlTransaction -> XmlDocument -> XmlUpdateContext -> [DbXmlFlag] -> IO () xmlContainer_putDocument cont mTrans doc uctx flags = do let cont_ = unsafeForeignPtrToPtr cont let doc_ = unsafeForeignPtrToPtr doc let uctx_ = unsafeForeignPtrToPtr uctx ret <- case mTrans of Just trans -> do let trans_ = unsafeForeignPtrToPtr trans ret <- _xmlContainer_putDocument cont_ trans_ doc_ uctx_ (dbxmlOrFlags flags) touchForeignPtr trans return ret Nothing -> do _xmlContainer_putDocument cont_ nullPtr doc_ uctx_ (dbxmlOrFlags flags) touchForeignPtr cont touchForeignPtr doc touchForeignPtr uctx if ret /= 0 then throw "xmlContainer_updateDocument" ret "" else return () foreign import ccall unsafe "dbxml_helper.h _xmlContainer_deleteDocument" _xmlContainer_deleteDocument :: Ptr XmlContainer_struct -> Ptr XmlTransaction_struct -> Ptr XmlDocument_struct -> Ptr XmlUpdateContext_struct -> IO CInt xmlContainer_deleteDocument :: XmlContainer -> Maybe XmlTransaction -> XmlDocument -> XmlUpdateContext -> IO () xmlContainer_deleteDocument cont mTrans doc uctx = do let cont_ = unsafeForeignPtrToPtr cont let doc_ = unsafeForeignPtrToPtr doc let uctx_ = unsafeForeignPtrToPtr uctx ret <- case mTrans of Just trans -> do let trans_ = unsafeForeignPtrToPtr trans ret <- _xmlContainer_deleteDocument cont_ trans_ doc_ uctx_ touchForeignPtr trans return ret Nothing -> do _xmlContainer_deleteDocument cont_ nullPtr doc_ uctx_ touchForeignPtr cont touchForeignPtr doc touchForeignPtr uctx if ret /= 0 then throw "xmlContainer_deleteDocument" ret "" else return ()