BerkeleyDBXML-0.3: Database/Berkeley/DbXml.hs
{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls, TypeSynonymInstances #-}
{-# CFILES Database/Berkeley/dbxml_helper.cpp #-}
-- | All IO monad functions can throw exceptions. Use getDbXmlError to fetch the
-- error code.
module Database.Berkeley.DbXml (
-- * General
DbXmlFlag(..),
ExceptionCode(..),
XmlResults,
XmlResultsReturnable,
getDbXmlError,
-- * XmlContainer
XmlContainer,
xmlContainer_close,
xmlContainer_deleteDocument,
xmlContainer_getDocument,
xmlContainer_getName,
xmlContainer_putDocument,
xmlContainer_updateDocument,
-- * XmlDocument
XmlDocument,
xmlDocument_getContent,
xmlDocument_getName,
xmlDocument_setContent,
xmlDocument_setName,
-- * XmlManager
XmlManager,
xmlManager_close,
xmlManager_create,
xmlManager_createDocument,
ReturnType(..),
EvaluationType(..),
xmlManager_createQueryContext,
xmlManager_createTransaction,
xmlManager_createTransaction_DbTxn,
xmlManager_createUpdateContext,
ContainerType(..),
xmlManager_openContainer,
xmlManager_prepare,
xmlManager_query,
-- * XmlQueryContext
XmlQueryContext,
xmlQueryContext_setDefaultCollection,
xmlQueryContext_setVariableValue,
-- * XmlQueryExpression
XmlQueryExpression,
xmlQueryExpression_execute,
-- * XmlResults
xmlResults_hasNext,
xmlResults_next,
-- * XmlTransaction
XmlTransaction,
xmlTransaction_abort,
xmlTransaction_commit,
-- * XmlValue
XmlValue,
xmlBool,
xmlDouble,
xmlNone,
xmlString,
xmlValue_asString,
xmlValue_asString8Bit
) 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
-- | Helper specific to Haskell binding: Fetches a Berkeley DB XML ExceptionCode
-- value out of a Haskell IOError so the caller can check the return code.
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 _xmlManager_createTransaction_DbTxn" _xmlManager_createTransaction_DbTxn
:: XmlManager -> Ptr DbTxn_struct -> Ptr (Ptr XmlTransaction_struct) -> IO CInt
xmlManager_createTransaction_DbTxn :: XmlManager -> DbTxn -> IO XmlTransaction
xmlManager_createTransaction_DbTxn mgr dbtxn =
alloca $ \ptr ->
withForeignPtr dbtxn$ \c_dbtxn -> do
ret <- _xmlManager_createTransaction_DbTxn mgr c_dbtxn ptr
if ret /= 0
then throw "xmlManager_createTransaction_DbTxn" 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 ()
foreign import ccall unsafe "dbxml_helper.h _xmlContainer_close" _xmlContainer_close
:: Ptr XmlContainer_struct -> IO ()
-- | Closes a container. Equivalent to destructing the XmlContainer object in C++.
xmlContainer_close :: XmlContainer -> IO ()
xmlContainer_close cont =
withForeignPtr cont$ \cont_ ->
_xmlContainer_close cont_
foreign import ccall unsafe "dbxml_helper.h _xmlManager_close" _xmlManager_close
:: Ptr XmlManager_struct -> IO ()
-- | Closes an XmlManager. Equivalent to destructing the XmlManager object in C++.
xmlManager_close :: XmlManager -> IO ()
xmlManager_close mgr =
_xmlManager_close mgr