BerkeleyDBXML 0.4 → 0.5
raw patch · 10 files changed
+146/−100 lines, 10 filesdep +bytestring
Dependencies added: bytestring
Files
- BerkeleyDBXML.cabal +4/−3
- ChangeLog +5/−0
- Database/Berkeley/Db.hs +29/−24
- Database/Berkeley/DbXml.hs +53/−52
- Database/Berkeley/Util.hs +10/−0
- Database/Berkeley/dbxml_helper.cpp +22/−9
- Database/Berkeley/dbxml_helper.h +2/−2
- README +5/−6
- examples/adventure/Adventure.hs +10/−3
- examples/tests/Test1.hs +6/−1
BerkeleyDBXML.cabal view
@@ -1,12 +1,12 @@ name: BerkeleyDBXML-version: 0.4+version: 0.5 license: BSD3 license-file: LICENSE cabal-version: >= 1.4 copyright: (c) Stephen Blackheath author: Stephen Blackheath maintainer: http://blacksapphire.com/antispam/-stability: alpha+stability: beta synopsis: Berkeley DB and Berkeley DB XML binding description: Berkeley DB XML is a powerful, fully transactional, XML-based database that uses@@ -30,6 +30,7 @@ homepage: http://www.haskell.org/haskellwiki/BerkeleyDBXML extra-source-files: README,+ ChangeLog, Database/Berkeley/db_helper.h, Database/Berkeley/dbxml_helper.h, examples/adventure/Makefile@@ -45,7 +46,7 @@ c-sources: Database/Berkeley/dbxml_helper.cpp other-modules: Database.Berkeley.Util- build-depends: base+ build-depends: base, bytestring >= 0.9 include-dirs: Database/Berkeley/ extra-libraries: db, dbxml, db_cxx, xqilla, xerces-c, xml2 ghc-options: -pgml c++
+ ChangeLog view
@@ -0,0 +1,5 @@+0.5 13 Dec 2008+ - Change all 'unsafe' to 'safe' so it'll work better in a threaded+ environment.+ - Change xmlDocument_getContent, xmlDocument_setContent, db_get and db_put+ so they all use Data.ByteString.ByteString instead of String.
Database/Berkeley/Db.hs view
@@ -66,6 +66,9 @@ import System.IO.Error import Foreign.ForeignPtr import System.IO.Unsafe+import Data.ByteString (ByteString)+import qualified Data.ByteString.Internal as BSI+import Data.Word data DbEnv_struct type DbEnv = Ptr DbEnv_struct@@ -157,7 +160,7 @@ throw func code = do ioError $ userError $ "db error func="++func++" db=\""++(show $ fromIntegral code)++"\"" -foreign import ccall unsafe "db_helper.h _dbenv_create__" _dbenv_create__+foreign import ccall safe "db_helper.h _dbenv_create__" _dbenv_create__ :: Ptr DbEnv -> CUInt -> IO CInt data DbEnvCreateFlag = DB_RPCCLIENT@@ -174,7 +177,7 @@ toNum DB_RPCCLIENT = 0x0000002 -foreign import ccall unsafe "db_helper.h _dbenv_get_lk_max_lockers" _dbenv_get_lk_max_lockers+foreign import ccall safe "db_helper.h _dbenv_get_lk_max_lockers" _dbenv_get_lk_max_lockers :: DbEnv -> Ptr CUInt -> IO CInt dbEnv_get_lk_max_lockers :: DbEnv -> IO Int@@ -187,7 +190,7 @@ ci <- peek ptr return $ fromIntegral ci -foreign import ccall unsafe "db_helper.h _dbenv_set_lk_max_lockers" _dbenv_set_lk_max_lockers+foreign import ccall safe "db_helper.h _dbenv_set_lk_max_lockers" _dbenv_set_lk_max_lockers :: DbEnv -> CUInt -> IO CInt dbEnv_set_lk_max_lockers :: DbEnv -> Int -> IO ()@@ -198,7 +201,7 @@ else return () -foreign import ccall unsafe "db_helper.h _dbenv_get_lk_max_locks" _dbenv_get_lk_max_locks+foreign import ccall safe "db_helper.h _dbenv_get_lk_max_locks" _dbenv_get_lk_max_locks :: DbEnv -> Ptr CUInt -> IO CInt dbEnv_get_lk_max_locks :: DbEnv -> IO Int@@ -211,7 +214,7 @@ ci <- peek ptr return $ fromIntegral ci -foreign import ccall unsafe "db_helper.h _dbenv_set_lk_max_locks" _dbenv_set_lk_max_locks+foreign import ccall safe "db_helper.h _dbenv_set_lk_max_locks" _dbenv_set_lk_max_locks :: DbEnv -> CUInt -> IO CInt dbEnv_set_lk_max_locks :: DbEnv -> Int -> IO ()@@ -222,7 +225,7 @@ else return () -foreign import ccall unsafe "db_helper.h _dbenv_get_lk_max_objects" _dbenv_get_lk_max_objects+foreign import ccall safe "db_helper.h _dbenv_get_lk_max_objects" _dbenv_get_lk_max_objects :: DbEnv -> Ptr CUInt -> IO CInt dbEnv_get_lk_max_objects :: DbEnv -> IO Int@@ -235,7 +238,7 @@ ci <- peek ptr return $ fromIntegral ci -foreign import ccall unsafe "db_helper.h _dbenv_set_lk_max_objects" _dbenv_set_lk_max_objects+foreign import ccall safe "db_helper.h _dbenv_set_lk_max_objects" _dbenv_set_lk_max_objects :: DbEnv -> CUInt -> IO CInt dbEnv_set_lk_max_objects :: DbEnv -> Int -> IO ()@@ -246,7 +249,7 @@ else return () -foreign import ccall unsafe "db_helper.h _dbenv_get_tx_max" _dbenv_get_tx_max+foreign import ccall safe "db_helper.h _dbenv_get_tx_max" _dbenv_get_tx_max :: DbEnv -> Ptr CUInt -> IO CInt dbEnv_get_tx_max :: DbEnv -> IO Int@@ -259,7 +262,7 @@ ci <- peek ptr return $ fromIntegral ci -foreign import ccall unsafe "db_helper.h _dbenv_set_tx_max" _dbenv_set_tx_max+foreign import ccall safe "db_helper.h _dbenv_set_tx_max" _dbenv_set_tx_max :: DbEnv -> CUInt -> IO CInt dbEnv_set_tx_max :: DbEnv -> Int -> IO ()@@ -270,7 +273,7 @@ else return () -foreign import ccall unsafe "db_helper.h _dbenv_get_cachesize" _dbenv_get_cachesize+foreign import ccall safe "db_helper.h _dbenv_get_cachesize" _dbenv_get_cachesize :: DbEnv -> Ptr CUInt -> Ptr CUInt -> Ptr Int -> IO CInt dbEnv_get_cache_size :: DbEnv -> IO (Int, Int, Int)@@ -285,7 +288,7 @@ c3 <- peek ptr3 return $ (fromIntegral c1, fromIntegral c2, fromIntegral c3) -foreign import ccall unsafe "db_helper.h _dbenv_set_cachesize" _dbenv_set_cachesize+foreign import ccall safe "db_helper.h _dbenv_set_cachesize" _dbenv_set_cachesize :: DbEnv -> CUInt -> CUInt -> CInt -> IO CInt dbEnv_set_cache_size :: DbEnv -> Int -> Int -> Int -> IO ()@@ -296,7 +299,7 @@ else return () -foreign import ccall unsafe "db_helper.h _dbenv_get_lg_regionmax" _dbenv_get_lg_regionmax+foreign import ccall safe "db_helper.h _dbenv_get_lg_regionmax" _dbenv_get_lg_regionmax :: DbEnv -> Ptr CUInt -> IO CInt dbEnv_get_lg_regionmax :: DbEnv -> IO Int@@ -309,7 +312,7 @@ ci <- peek ptr return $ fromIntegral ci -foreign import ccall unsafe "db_helper.h _dbenv_set_lg_regionmax" _dbenv_set_lg_regionmax+foreign import ccall safe "db_helper.h _dbenv_set_lg_regionmax" _dbenv_set_lg_regionmax :: DbEnv -> CUInt -> IO CInt dbEnv_set_lg_regionmax :: DbEnv -> Int -> IO ()@@ -320,7 +323,7 @@ else return () -foreign import ccall unsafe "db_helper.h _dbenv_open" _dbenv_open+foreign import ccall safe "db_helper.h _dbenv_open" _dbenv_open :: DbEnv -> CString -> CUInt -> CInt -> IO CInt data DbFlag =@@ -435,7 +438,7 @@ foreign import ccall "db_helper.h &_db_delete" _db_delete :: FunPtr (Ptr Db_struct -> IO ()) -foreign import ccall unsafe "db_helper.h _db_create" _db_create+foreign import ccall safe "db_helper.h _db_create" _db_create :: Ptr DbEnv_struct -> CUInt -> Ptr (Ptr Db_struct) -> IO CInt db_create :: DbEnv -> [DbFlag] -> IO Db@@ -448,7 +451,7 @@ p <- peek ptr newForeignPtr _db_delete p -foreign import ccall unsafe "db_helper.h _db_set_pagesize" _db_set_pagesize+foreign import ccall safe "db_helper.h _db_set_pagesize" _db_set_pagesize :: Ptr Db_struct -> CUInt -> IO CInt db_set_pagesize :: Db -> Int -> IO ()@@ -609,10 +612,13 @@ foreign import ccall unsafe "db_helper.h _freeString" _freeString :: CString -> IO () +foreign import ccall unsafe "db_helper.h &_freeString" _freeString_finalizer+ :: FunPtr (Ptr Word8 -> IO ())+ foreign import ccall "db_helper.h _db_get" _db_get- :: Ptr Db_struct -> Ptr DbTxn_struct -> CString -> CUInt -> Ptr CString -> Ptr CUInt -> CUInt -> IO CInt+ :: Ptr Db_struct -> Ptr DbTxn_struct -> CString -> CUInt -> Ptr (Ptr Word8) -> Ptr CUInt -> CUInt -> IO CInt -db_get :: Db -> Maybe DbTxn -> String -> [DbFlag] -> IO (Maybe String)+db_get :: Db -> Maybe DbTxn -> String -> [DbFlag] -> IO (Maybe ByteString) db_get db mTxn key flags = alloca$ \ptr1 -> alloca$ \ptr2 ->@@ -632,17 +638,16 @@ else do c_value <- peek ptr1 value_len <- peek ptr2- value <- peekCAStringLen (c_value, fromIntegral value_len)- _freeString c_value- return$ Just value+ str <- newForeignPtr _freeString_finalizer c_value+ return $ Just $ BSI.fromForeignPtr str 0 (fromIntegral value_len) foreign import ccall "db_helper.h _db_put" _db_put- :: Ptr Db_struct -> Ptr DbTxn_struct -> CString -> CUInt -> CString -> CUInt -> CUInt -> IO CInt+ :: Ptr Db_struct -> Ptr DbTxn_struct -> CString -> CUInt -> Ptr Word8 -> CUInt -> CUInt -> IO CInt -db_put :: Db -> Maybe DbTxn -> String -> String -> [DbFlag] -> IO ()+db_put :: Db -> Maybe DbTxn -> String -> ByteString -> [DbFlag] -> IO () db_put db mTxn key value flags = withCAStringLen key$ \(c_key, key_len) ->- withCAStringLen value$ \(c_value, value_len) ->+ withByteString value $ \c_value value_len -> withForeignPtr db$ \c_db -> do ret <- case mTxn of Nothing ->
Database/Berkeley/DbXml.hs view
@@ -78,6 +78,9 @@ import Data.Char import Data.Bits import System.IO.Unsafe+import Data.ByteString (ByteString)+import Data.Word+import qualified Data.ByteString.Internal as BSI toUtf8 :: String -> String toUtf8 = concatMap charToUtf8@@ -107,11 +110,6 @@ _ | (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.@@ -240,7 +238,7 @@ data XmlManager_struct type XmlManager = Ptr XmlManager_struct -foreign import ccall unsafe "dbxml_helper.h _xmlManager" _xmlManager+foreign import ccall safe "dbxml_helper.h _xmlManager" _xmlManager :: DbEnv -> CUInt -> Ptr XmlManager -> IO CInt xmlManager_create :: DbEnv -> [DbXmlFlag] -> IO XmlManager@@ -258,7 +256,7 @@ data ContainerType = NodeContainer | WholedocContainer -foreign import ccall unsafe "dbxml_helper.h _xmlManager_openContainer" _xmlManager_openContainer+foreign import ccall safe "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@@ -280,7 +278,7 @@ 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+foreign import ccall safe "dbxml_helper.h _xmlManager_createTransaction" _xmlManager_createTransaction :: XmlManager -> CUInt -> Ptr (Ptr XmlTransaction_struct) -> IO CInt xmlManager_createTransaction :: XmlManager -> [DbFlag] -> IO XmlTransaction@@ -293,7 +291,7 @@ p <- peek ptr newForeignPtr _xmlTransaction_delete p -foreign import ccall unsafe "dbxml_helper.h _xmlManager_createTransaction_DbTxn" _xmlManager_createTransaction_DbTxn+foreign import ccall safe "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@@ -307,7 +305,7 @@ p <- peek ptr newForeignPtr _xmlTransaction_delete p -foreign import ccall unsafe "dbxml_helper.h _xmlTransaction_commit" _xmlTransaction_commit+foreign import ccall safe "dbxml_helper.h _xmlTransaction_commit" _xmlTransaction_commit :: Ptr XmlTransaction_struct -> IO CInt xmlTransaction_commit :: XmlTransaction -> IO ()@@ -318,7 +316,7 @@ then throw "xmlTransaction_commit" ret "" else return () -foreign import ccall unsafe "dbxml_helper.h _xmlTransaction_abort" _xmlTransaction_abort+foreign import ccall safe "dbxml_helper.h _xmlTransaction_abort" _xmlTransaction_abort :: Ptr XmlTransaction_struct -> IO CInt xmlTransaction_abort :: XmlTransaction -> IO ()@@ -331,10 +329,10 @@ data XmlDocument_struct type XmlDocument = ForeignPtr XmlDocument_struct-foreign import ccall unsafe "dbxml_helper.h &_xmlDocument_delete" _xmlDocument_delete+foreign import ccall safe "dbxml_helper.h &_xmlDocument_delete" _xmlDocument_delete :: FunPtr (Ptr XmlDocument_struct -> IO ()) -foreign import ccall unsafe "dbxml_helper.h _xmlContainer_getDocument" _xmlContainer_getDocument+foreign import ccall safe "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@@ -359,7 +357,10 @@ foreign import ccall unsafe "db_helper.h _deleteString" _deleteString :: CString -> IO () -foreign import ccall unsafe "dbxml_helper.h _xmlContainer_getName" _xmlContainer_getName+foreign import ccall unsafe "dbxml_helper.h &_deleteString" _deleteString_finalizer+ :: FunPtr (Ptr Word8 -> IO ())++foreign import ccall safe "dbxml_helper.h _xmlContainer_getName" _xmlContainer_getName :: Ptr XmlContainer_struct -> IO CString xmlContainer_getName :: XmlContainer -> String@@ -369,29 +370,29 @@ touchForeignPtr cont str <- peekCAString cstr _deleteString cstr- return $ fromUtf8 str+ return str -foreign import ccall unsafe "dbxml_helper.h _xmlDocument_getContent" _xmlDocument_getContent- :: Ptr XmlDocument_struct -> Ptr CString -> IO CInt+foreign import ccall safe "dbxml_helper.h _xmlDocument_getContent" _xmlDocument_getContent+ :: Ptr XmlDocument_struct -> Ptr (Ptr Word8) -> Ptr CInt -> IO CInt -xmlDocument_getContent :: XmlDocument -> IO String-xmlDocument_getContent doc = alloca$ \ptr -> do- ret <- _xmlDocument_getContent (unsafeForeignPtrToPtr doc) ptr+xmlDocument_getContent :: XmlDocument -> IO ByteString+xmlDocument_getContent doc = alloca $ \ptr -> alloca $ \pLength -> do+ ret <- _xmlDocument_getContent (unsafeForeignPtrToPtr doc) ptr pLength touchForeignPtr doc if ret /= 0 then throw "xmlDocument_getContent" ret "" else do cstr <- peek ptr- str <- peekCAString cstr- _deleteString cstr- return $ fromUtf8 str+ length <- peek pLength+ str <- newForeignPtr _deleteString_finalizer cstr+ return $ BSI.fromForeignPtr str 0 (fromIntegral length) data XmlQueryContext_struct type XmlQueryContext = ForeignPtr XmlQueryContext_struct-foreign import ccall unsafe "dbxml_helper.h &_xmlQueryContext_delete" _xmlQueryContext_delete+foreign import ccall safe "dbxml_helper.h &_xmlQueryContext_delete" _xmlQueryContext_delete :: FunPtr (Ptr XmlQueryContext_struct -> IO ()) -foreign import ccall unsafe "dbxml_helper.h _xmlManager_createQueryContext" _xmlManager_createQueryContext+foreign import ccall safe "dbxml_helper.h _xmlManager_createQueryContext" _xmlManager_createQueryContext :: Ptr XmlManager_struct -> CInt -> CInt -> Ptr (Ptr XmlQueryContext_struct) -> IO CInt data ReturnType = LiveValues@@ -416,7 +417,7 @@ 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+foreign import ccall safe "dbxml_helper.h _xmlResults_hasNext" _xmlResults_hasNext :: Ptr XmlResults_struct -> Ptr CInt -> IO CInt xmlResults_hasNext :: XmlResults -> IO Bool@@ -439,7 +440,7 @@ instance XmlResultsReturnable XmlValue where xmlResults_next = xmlResults_nextValue -foreign import ccall unsafe "dbxml_helper.h _xmlResults_nextDocument" _xmlResults_nextDocument+foreign import ccall safe "dbxml_helper.h _xmlResults_nextDocument" _xmlResults_nextDocument :: Ptr XmlResults_struct -> Ptr (Ptr XmlDocument_struct) -> IO CInt xmlResults_nextDocument :: XmlResults -> IO (Maybe XmlDocument)@@ -457,7 +458,7 @@ fp <- newForeignPtr _xmlDocument_delete doc return $ Just fp -foreign import ccall unsafe "dbxml_helper.h _xmlResults_nextValue" _xmlResults_nextValue+foreign import ccall safe "dbxml_helper.h _xmlResults_nextValue" _xmlResults_nextValue :: Ptr XmlResults_struct -> Ptr (Ptr XmlValue_struct) -> IO CInt xmlResults_nextValue :: XmlResults -> IO (Maybe XmlValue)@@ -509,7 +510,7 @@ 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+foreign import ccall safe "dbxml_helper.h _xmlManager_prepare" _xmlManager_prepare :: Ptr XmlManager_struct -> Ptr XmlTransaction_struct -> CString -> Ptr XmlQueryContext_struct -> Ptr (Ptr XmlQueryExpression_struct) -> IO CInt @@ -532,7 +533,7 @@ p <- peek ptr newForeignPtr _xmlQueryExpression_delete p -foreign import ccall unsafe "dbxml_helper.h _xmlQueryContext_setDefaultCollection" _xmlQueryContext_setDefaultCollection+foreign import ccall safe "dbxml_helper.h _xmlQueryContext_setDefaultCollection" _xmlQueryContext_setDefaultCollection :: Ptr XmlQueryContext_struct -> CString -> IO CInt xmlQueryContext_setDefaultCollection :: XmlQueryContext -> String -> IO ()@@ -549,7 +550,7 @@ foreign import ccall "dbxml_helper.h &_xmlValue_delete" _xmlValue_delete :: FunPtr (Ptr XmlValue_struct -> IO ()) -foreign import ccall unsafe "dbxml_helper.h _xmlNone" _xmlNone+foreign import ccall safe "dbxml_helper.h _xmlNone" _xmlNone :: IO (Ptr XmlValue_struct) xmlNone :: XmlValue@@ -557,7 +558,7 @@ xv <- _xmlNone newForeignPtr _xmlValue_delete xv -foreign import ccall unsafe "dbxml_helper.h _xmlString" _xmlString+foreign import ccall safe "dbxml_helper.h _xmlString" _xmlString :: CString -> IO (Ptr XmlValue_struct) xmlString :: String -> XmlValue@@ -566,7 +567,7 @@ xv <- _xmlString c_text newForeignPtr _xmlValue_delete xv -foreign import ccall unsafe "dbxml_helper.h _xmlBool" _xmlBool+foreign import ccall safe "dbxml_helper.h _xmlBool" _xmlBool :: CInt -> IO (Ptr XmlValue_struct) xmlBool :: Bool -> XmlValue@@ -574,7 +575,7 @@ xv <- _xmlBool$ if b then 1 else 0 newForeignPtr _xmlValue_delete xv -foreign import ccall unsafe "dbxml_helper.h _xmlDouble" _xmlDouble+foreign import ccall safe "dbxml_helper.h _xmlDouble" _xmlDouble :: CDouble -> IO (Ptr XmlValue_struct) xmlDouble :: Double -> XmlValue@@ -582,7 +583,7 @@ xv <- _xmlDouble$ realToFrac value newForeignPtr _xmlValue_delete xv -foreign import ccall unsafe "dbxml_helper.h _xmlValue_asString" _xmlValue_asString+foreign import ccall safe "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@@ -597,7 +598,7 @@ cstr <- peek ptr str <- peekCAString cstr _deleteString cstr- return $ fromUtf8 str+ return 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@@ -611,7 +612,7 @@ _deleteString cstr return str -foreign import ccall unsafe "dbxml_helper.h _xmlQueryContext_setVariableValue" _xmlQueryContext_setVariableValue+foreign import ccall safe "dbxml_helper.h _xmlQueryContext_setVariableValue" _xmlQueryContext_setVariableValue :: Ptr XmlQueryContext_struct -> CString -> Ptr XmlValue_struct -> IO CInt xmlQueryContext_setVariableValue :: XmlQueryContext -> String -> XmlValue -> IO ()@@ -665,7 +666,7 @@ p <- peek ptr newForeignPtr _xmlResults_delete p -foreign import ccall unsafe "dbxml_helper.h _xmlManager_createDocument" _xmlManager_createDocument+foreign import ccall safe "dbxml_helper.h _xmlManager_createDocument" _xmlManager_createDocument :: Ptr XmlManager_struct -> Ptr (Ptr XmlDocument_struct) -> IO CInt xmlManager_createDocument :: XmlManager -> IO XmlDocument@@ -678,7 +679,7 @@ p <- peek ptr newForeignPtr _xmlDocument_delete p -foreign import ccall unsafe "dbxml_helper.h _xmlDocument_getName" _xmlDocument_getName+foreign import ccall safe "dbxml_helper.h _xmlDocument_getName" _xmlDocument_getName :: Ptr XmlDocument_struct -> Ptr CString -> IO CInt xmlDocument_getName :: XmlDocument -> IO String@@ -691,9 +692,9 @@ cstr <- peek ptr str <- peekCAString cstr _deleteString cstr- return $ fromUtf8 str+ return str -foreign import ccall unsafe "dbxml_helper.h _xmlDocument_setName" _xmlDocument_setName+foreign import ccall safe "dbxml_helper.h _xmlDocument_setName" _xmlDocument_setName :: Ptr XmlDocument_struct -> CString -> IO CInt xmlDocument_setName :: XmlDocument -> String -> IO ()@@ -709,7 +710,7 @@ 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+foreign import ccall safe "dbxml_helper.h _xmlManager_createUpdateContext" _xmlManager_createUpdateContext :: Ptr XmlManager_struct -> Ptr (Ptr XmlUpdateContext_struct) -> IO CInt xmlManager_createUpdateContext :: XmlManager -> IO XmlUpdateContext@@ -722,19 +723,19 @@ p <- peek ptr newForeignPtr _xmlUpdateContext_delete p -foreign import ccall unsafe "dbxml_helper.h _xmlDocument_setContent" _xmlDocument_setContent- :: Ptr XmlDocument_struct -> CString -> IO CInt+foreign import ccall safe "dbxml_helper.h _xmlDocument_setContent" _xmlDocument_setContent+ :: Ptr XmlDocument_struct -> Ptr Word8 -> CUInt -> IO CInt -xmlDocument_setContent :: XmlDocument -> String -> IO ()+xmlDocument_setContent :: XmlDocument -> ByteString -> IO () xmlDocument_setContent doc text =- withCAString text$ \c_text -> do- ret <- _xmlDocument_setContent (unsafeForeignPtrToPtr doc) c_text+ withByteString text$ \c_text text_length -> do+ ret <- _xmlDocument_setContent (unsafeForeignPtrToPtr doc) c_text (fromIntegral text_length) touchForeignPtr doc if ret /= 0 then throw "xmlDocument_setContent" ret "" else return () -foreign import ccall unsafe "dbxml_helper.h _xmlContainer_updateDocument" _xmlContainer_updateDocument+foreign import ccall safe "dbxml_helper.h _xmlContainer_updateDocument" _xmlContainer_updateDocument :: Ptr XmlContainer_struct -> Ptr XmlTransaction_struct -> Ptr XmlDocument_struct -> Ptr XmlUpdateContext_struct -> IO CInt @@ -758,7 +759,7 @@ then throw "xmlContainer_updateDocument" ret "" else return () -foreign import ccall unsafe "dbxml_helper.h _xmlContainer_putDocument" _xmlContainer_putDocument+foreign import ccall safe "dbxml_helper.h _xmlContainer_putDocument" _xmlContainer_putDocument :: Ptr XmlContainer_struct -> Ptr XmlTransaction_struct -> Ptr XmlDocument_struct -> Ptr XmlUpdateContext_struct -> CUInt -> IO CInt @@ -783,7 +784,7 @@ then throw "xmlContainer_updateDocument" ret "" else return () -foreign import ccall unsafe "dbxml_helper.h _xmlContainer_deleteDocument" _xmlContainer_deleteDocument+foreign import ccall safe "dbxml_helper.h _xmlContainer_deleteDocument" _xmlContainer_deleteDocument :: Ptr XmlContainer_struct -> Ptr XmlTransaction_struct -> Ptr XmlDocument_struct -> Ptr XmlUpdateContext_struct -> IO CInt @@ -807,7 +808,7 @@ then throw "xmlContainer_deleteDocument" ret "" else return () -foreign import ccall unsafe "dbxml_helper.h _xmlContainer_close" _xmlContainer_close+foreign import ccall safe "dbxml_helper.h _xmlContainer_close" _xmlContainer_close :: Ptr XmlContainer_struct -> IO () -- | Closes a container. Equivalent to destructing the XmlContainer object in C++. @@ -816,7 +817,7 @@ withForeignPtr cont$ \cont_ -> _xmlContainer_close cont_ -foreign import ccall unsafe "dbxml_helper.h _xmlManager_close" _xmlManager_close+foreign import ccall safe "dbxml_helper.h _xmlManager_close" _xmlManager_close :: Ptr XmlManager_struct -> IO () -- | Closes an XmlManager. Equivalent to destructing the XmlManager object in C++.
Database/Berkeley/Util.hs view
@@ -2,6 +2,11 @@ where import Data.List+import Data.ByteString (ByteString)+import qualified Data.ByteString.Internal as BSI+import Foreign.ForeignPtr+import Foreign.Ptr+import Data.Word locate :: (Eq a) => [a] -> [a] -> Maybe Int locate needle haystack = locate_ needle haystack 0 where@@ -25,3 +30,8 @@ Just idx -> Just $ toDelim line (idx+(length tag)) delims _ -> Nothing +withByteString :: ByteString -> (Ptr Word8 -> Int -> IO a) -> IO a+withByteString bs code = do+ let (fp, fp_offset, length) = BSI.toForeignPtr bs+ withForeignPtr fp $ \c_fp ->+ code (c_fp `plusPtr` fp_offset) length
Database/Berkeley/dbxml_helper.cpp view
@@ -28,17 +28,29 @@ : qe(qe), mi(mi) { pthread_mutex_lock(&mi->mutex);- mi->queryExpressions.insert(this);- pthread_mutex_unlock(&mi->mutex);+ try {+ mi->queryExpressions.insert(this);+ pthread_mutex_unlock(&mi->mutex);+ }+ catch (...) {+ pthread_mutex_unlock(&mi->mutex);+ throw;+ } } XmlQueryExpressionInfo::~XmlQueryExpressionInfo() { pthread_mutex_lock(&mi->mutex);- std::set<XmlQueryExpressionInfo*>::iterator it = mi->queryExpressions.find(this);- if (it != mi->queryExpressions.end())- mi->queryExpressions.erase(it);- pthread_mutex_unlock(&mi->mutex);+ try {+ std::set<XmlQueryExpressionInfo*>::iterator it = mi->queryExpressions.find(this);+ if (it != mi->queryExpressions.end())+ mi->queryExpressions.erase(it);+ pthread_mutex_unlock(&mi->mutex);+ }+ catch (...) {+ pthread_mutex_unlock(&mi->mutex);+ throw;+ } } static int asInt(XmlException& exc)@@ -181,7 +193,7 @@ delete doc; } -int _xmlDocument_getContent(DbXml::XmlDocument* doc, char** str)+int _xmlDocument_getContent(DbXml::XmlDocument* doc, char** str, int* length) { string s; try {@@ -191,6 +203,7 @@ *str = NULL; return asInt(exc); }+ *length = (int)s.length(); *str = new char[s.length()+1]; strcpy(*str, s.c_str()); return 0;@@ -450,10 +463,10 @@ } } -int _xmlDocument_setContent(DbXml::XmlDocument* doc, const char* text)+int _xmlDocument_setContent(DbXml::XmlDocument* doc, const char* text, unsigned int length) { try {- doc->setContent(text);+ doc->setContent(string(text, length)); return 0; } catch (XmlException& exc) {
Database/Berkeley/dbxml_helper.h view
@@ -42,7 +42,7 @@ const char* key, u_int32_t flags, DbXml::XmlDocument** doc); char* _xmlContainer_getName(DbXml::XmlContainer** cont); void _xmlDocument_delete(DbXml::XmlDocument* doc);- int _xmlDocument_getContent(DbXml::XmlDocument* doc, char** str);+ int _xmlDocument_getContent(DbXml::XmlDocument* doc, char** str, int* length); int _xmlManager_createQueryContext(XmlManagerInfo* mgr, int rt, int ev, DbXml::XmlQueryContext** ctx); void _xmlQueryContext_delete(DbXml::XmlQueryContext* ctx); void _xmlResults_delete(DbXml::XmlResults* res);@@ -69,7 +69,7 @@ int _xmlDocument_setName(DbXml::XmlDocument* doc, const char* name); void _xmlUpdateContext_delete(DbXml::XmlUpdateContext* ctx); int _xmlManager_createUpdateContext(XmlManagerInfo* mgr, DbXml::XmlUpdateContext** ctx);- int _xmlDocument_setContent(DbXml::XmlDocument* doc, const char* text);+ int _xmlDocument_setContent(DbXml::XmlDocument* doc, const char* text, unsigned int length); int _xmlContainer_updateDocument(DbXml::XmlContainer** cont, DbXml::XmlTransaction* trans, DbXml::XmlDocument* doc, DbXml::XmlUpdateContext* uctx); int _xmlContainer_putDocument(DbXml::XmlContainer** cont, DbXml::XmlTransaction* trans,
README view
@@ -1,9 +1,10 @@ Berkeley DB / Berkeley DB XML binding for Haskell-Version 0.3 01 Oct 2008+Version 0.5 13 Dec 2008 by Stephen Blackheath email me: http://blacksapphire.com/antispam/ darcs repository: http://blacksapphire.com/BerkeleyDBXML/+introduction/tutorial: http://haskell.org/haskellwiki/BerkeleyDBXML Berkeley DB XML is a powerful, fully transactional, XML-based database that uses@@ -24,7 +25,8 @@ If you just want Berkeley DB without Berkeley DB XML, you can do this by deleting the lines in BerkeleyDBXML.cabal that pertain to Berkeley DB XML. (The Berkeley DB-parts do not depend on the Berkeley DB XML parts.)+parts do not depend on the Berkeley DB XML parts.) I would like to make this a+build option. To install, use the standard Cabal install procedure: @@ -45,8 +47,5 @@ --extra-include-dirs=/usr/local/dbxml-2.4.16/include/dbxml/ \ --extra-lib-dirs=/usr/local/dbxml-2.4.16/lib/ -Cabal does not seem to check these very well. If you get the lib directory-wrong, you won't find out until you try to build the examples.--See the examples/ directory.+See the examples/ directory for examples.
examples/adventure/Adventure.hs view
@@ -18,6 +18,7 @@ import Control.Concurrent import Control.Monad import System.IO+import qualified Data.ByteString as B import Data.List import Data.Char import Data.Maybe@@ -185,6 +186,12 @@ Nothing -> do return [] +fromByteString :: B.ByteString -> String+fromByteString = map (chr . fromIntegral) . B.unpack++toByteString :: String -> B.ByteString+toByteString = B.pack . map (fromIntegral . ord)+ query_ :: XmlPickler p => (XmlManager, XmlContainer, XmlTransaction) -> PU p -> String -> [(String, XmlValue)] -> [DbXmlFlag] -> IO [(XmlDocument, p)] query_ (mgr, cont, trans) pickler queryText params flags = do@@ -196,7 +203,7 @@ res <- xmlManager_query mgr (Just trans) queryText qctx flags docs <- collectM (xmlResults_next res) records <- liftM (concat) $ forM docs $ \doc -> do- text <- xmlDocument_getContent doc+ text <- liftM fromByteString $ xmlDocument_getContent doc ps <- runX ( readString [ (a_validate, v_0),(a_remove_whitespace, v_1)] text >>> xunpickleVal pickler)@@ -217,14 +224,14 @@ create (mgr, cont, trans) p = do doc <- xmlManager_createDocument mgr text <- toXML p- xmlDocument_setContent doc text+ xmlDocument_setContent doc (toByteString text) uctx <- xmlManager_createUpdateContext mgr xmlContainer_putDocument cont (Just trans) doc uctx [DBXML_GEN_NAME] update :: XmlPickler p => (XmlManager, XmlContainer, XmlTransaction) -> XmlDocument -> p -> IO () update (mgr, cont, trans) doc p = do text <- toXML p- xmlDocument_setContent doc text+ xmlDocument_setContent doc (toByteString text) uctx <- xmlManager_createUpdateContext mgr xmlContainer_updateDocument cont (Just trans) doc uctx
examples/tests/Test1.hs view
@@ -3,13 +3,18 @@ import System.Environment import Database.Berkeley.Db import Control.Monad+import qualified Data.ByteString as B+import Data.Char +toByteString :: String -> B.ByteString+toByteString = B.pack . map (fromIntegral . ord)+ data Action = Read | Write | Fail deriving Eq writeDb :: Db -> IO () writeDb db = do forM_ testData$ \(country, capital) -> do- db_put db Nothing country capital []+ db_put db Nothing country (toByteString capital) [] readDb :: Db -> IO () readDb db = do