BerkeleyDBXML (empty) → 0.1
raw patch · 14 files changed
+2713/−0 lines, 14 filesdep +basesetup-changed
Dependencies added: base
Files
- BerkeleyDBXML.cabal +34/−0
- Database/Berkeley/Db.hs +665/−0
- Database/Berkeley/DbXml.hs +777/−0
- Database/Berkeley/Util.hs +27/−0
- Database/Berkeley/db_helper.cpp +314/−0
- Database/Berkeley/db_helper.h +45/−0
- Database/Berkeley/dbxml_helper.cpp +449/−0
- Database/Berkeley/dbxml_helper.h +56/−0
- LICENSE +27/−0
- README +51/−0
- Setup.hs +3/−0
- examples/Makefile +8/−0
- examples/Test1.hs +237/−0
- examples/Test2.hs +20/−0
+ BerkeleyDBXML.cabal view
@@ -0,0 +1,34 @@+name: BerkeleyDBXML+version: 0.1+license: BSD3+license-file: LICENSE+cabal-version: >= 1.4+copyright: (c) Stephen Blackheath+author: Stephen Blackheath+maintainer: http://blacksapphire.com/antispam/+stability: alpha+synopsis: Berkeley DB and Berkeley DB/XML binding for Haskell+description: Berkeley DB and Berkeley DB/XML binding for Haskell+category: Database+build-type: Simple+extra-source-files:+ README,+ Database/Berkeley/db_helper.h,+ Database/Berkeley/dbxml_helper.h,+ examples/Makefile,+ examples/Test1.hs,+ examples/Test2.hs++Library+ exposed-modules: Database.Berkeley.Db+ c-sources: Database/Berkeley/db_helper.cpp++ exposed-modules: Database.Berkeley.DbXml+ c-sources: Database/Berkeley/dbxml_helper.cpp++ other-modules: Database.Berkeley.Util+ build-depends: base+ include-dirs: Database/Berkeley/+ extra-libraries: db, dbxml, db_cxx, xqilla, xerces-c, xml2+ ghc-options: -pgml c+++
+ Database/Berkeley/Db.hs view
@@ -0,0 +1,665 @@+{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-}+{-# CFILES Database/Berkeley/db_helper.cpp #-}++module Database.Berkeley.Db (+ DbEnv,+ DbError(..),+ getDbError,+ dbEnv_create,+ dbEnv_get_lk_max_lockers,+ dbEnv_set_lk_max_lockers,+ dbEnv_get_lk_max_locks,+ dbEnv_set_lk_max_locks,+ dbEnv_get_lk_max_objects,+ dbEnv_set_lk_max_objects,+ dbEnv_get_tx_max,+ dbEnv_set_tx_max,+ dbEnv_get_cache_size,+ dbEnv_set_cache_size,+ dbEnv_get_lg_regionmax,+ dbEnv_set_lg_regionmax,+ DbFlag(..),+ dbEnv_open,+ dbToNum, -- ^ Used by DbXml+ dbOrFlags, -- ^ Used by DbXml+ Db,+ db_create,+ db_set_pagesize,+ DbType(..),+ DbTxn,+ db_open,+ dbEnv_txn_begin,+ dbEnv_txn_checkpoint,+ dbTxn_abort,+ dbTxn_commit,+ DbLocker,+ dbTxn_id,+ DbLockMode(..),+ dbEnv_lock_get,+ dbEnv_lock_put,+ db_get,+ db_put,+ db_close,+ dbEnv_close+ ) where++import Foreign.C+import Foreign.Marshal.Alloc+import Foreign.Storable+import Foreign.Ptr+import Control.Monad+import Data.Bits+import Database.Berkeley.Util+import Data.Maybe+import System.IO.Error+import Foreign.ForeignPtr+import System.IO.Unsafe++data DbEnv_struct+type DbEnv = Ptr DbEnv_struct++{-+ DB (user visible) error return codes.+ + !!!+ We don't want our error returns to conflict with other packages where+ possible, so pick a base error value that's hopefully not common. We+ document that we own the error name space from -30,800 to -30,999.+ -}+data DbError = + DB_BUFFER_SMALL | -- User memory too small for return.+ DB_DONOTINDEX | -- "Null" return from 2ndary callbk.+ DB_KEYEMPTY | -- Key/data deleted or never created.+ DB_KEYEXIST | -- The key/data pair already exists.+ DB_LOCK_DEADLOCK | -- Deadlock.+ DB_LOCK_NOTGRANTED | -- Lock unavailable.+ DB_LOG_BUFFER_FULL | -- In-memory log buffer full.+ DB_NOSERVER | -- Server panic return.+ DB_NOSERVER_HOME | -- Bad home sent to server.+ DB_NOSERVER_ID | -- Bad ID sent to server.+ DB_NOTFOUND | -- Key/data pair not found (EOF).+ DB_OLD_VERSION | -- Out-of-date version.+ DB_PAGE_NOTFOUND | -- Requested page not found.+ DB_REP_DUPMASTER | -- There are two masters.+ DB_REP_HANDLE_DEAD | -- Rolled back a commit.+ DB_REP_HOLDELECTION | -- Time to hold an election.+ DB_REP_IGNORE | -- This msg should be ignored.*/+ DB_REP_ISPERM | -- Cached not written perm written.*/+ DB_REP_JOIN_FAILURE | -- Unable to join replication group.+ DB_REP_LEASE_EXPIRED | -- Master lease has expired.+ DB_REP_LOCKOUT | -- API/Replication lockout now.+ DB_REP_NEWSITE | -- New site entered system.+ DB_REP_NOTPERM | -- Permanent log record not written.+ DB_REP_UNAVAIL | -- Site cannot currently be reached.+ DB_RUNRECOVERY | -- Panic return.+ DB_SECONDARY_BAD | -- Secondary index corrupt.+ DB_VERIFY_BAD | -- Verify failed; bad format.+ DB_VERSION_MISMATCH | -- Environment version mismatch.+ SYSTEM_ERROR Int+ deriving (Eq,Show)++dbErrFromNum (-30999) = Just DB_BUFFER_SMALL+dbErrFromNum (-30998) = Just DB_DONOTINDEX+dbErrFromNum (-30997) = Just DB_KEYEMPTY+dbErrFromNum (-30996) = Just DB_KEYEXIST+dbErrFromNum (-30995) = Just DB_LOCK_DEADLOCK+dbErrFromNum (-30994) = Just DB_LOCK_NOTGRANTED+dbErrFromNum (-30993) = Just DB_LOG_BUFFER_FULL+dbErrFromNum (-30992) = Just DB_NOSERVER+dbErrFromNum (-30991) = Just DB_NOSERVER_HOME+dbErrFromNum (-30990) = Just DB_NOSERVER_ID+dbErrFromNum (-30989) = Just DB_NOTFOUND+dbErrFromNum (-30988) = Just DB_OLD_VERSION+dbErrFromNum (-30987) = Just DB_PAGE_NOTFOUND+dbErrFromNum (-30986) = Just DB_REP_DUPMASTER+dbErrFromNum (-30985) = Just DB_REP_HANDLE_DEAD+dbErrFromNum (-30984) = Just DB_REP_HOLDELECTION+dbErrFromNum (-30983) = Just DB_REP_IGNORE+dbErrFromNum (-30982) = Just DB_REP_ISPERM+dbErrFromNum (-30981) = Just DB_REP_JOIN_FAILURE+dbErrFromNum (-30980) = Just DB_REP_LEASE_EXPIRED+dbErrFromNum (-30979) = Just DB_REP_LOCKOUT+dbErrFromNum (-30978) = Just DB_REP_NEWSITE+dbErrFromNum (-30977) = Just DB_REP_NOTPERM+dbErrFromNum (-30976) = Just DB_REP_UNAVAIL+dbErrFromNum (-30975) = Just DB_RUNRECOVERY+dbErrFromNum (-30974) = Just DB_SECONDARY_BAD+dbErrFromNum (-30973) = Just DB_VERIFY_BAD+dbErrFromNum (-30972) = Just DB_VERSION_MISMATCH+dbErrFromNum 0 = Nothing+dbErrFromNum n = Just (SYSTEM_ERROR n)++getDbError :: IOError -> Maybe DbError+getDbError ioError =+ if isUserError ioError+ then+ let s = ioeGetErrorString ioError in+ case extract "db=\"" s ['"'] of+ Just nStr -> dbErrFromNum $ fromMaybe 0 $ maybeRead nStr+ Nothing -> Nothing+ else Nothing++throw :: String -> CInt -> IO a+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__+ :: Ptr DbEnv -> CUInt -> IO CInt++data DbEnvCreateFlag = DB_RPCCLIENT++dbEnv_create :: [DbEnvCreateFlag] -> IO DbEnv+dbEnv_create flags =+ alloca $ \ptr -> do+ ret <- _dbenv_create__ ptr orFlags+ if ret /= 0+ then throw "_dbenv_create" ret+ else peek ptr+ where+ orFlags = foldr (.|.) 0 $ map toNum flags+ toNum DB_RPCCLIENT = 0x0000002+++foreign import ccall unsafe "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+dbEnv_get_lk_max_lockers dbenv =+ alloca $ \ptr -> do+ ret <- _dbenv_get_lk_max_lockers dbenv ptr+ if ret /= 0+ then throw "dbEnv_get_lk_max_lockers" ret+ else do+ ci <- peek ptr+ return $ fromIntegral ci++foreign import ccall unsafe "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 ()+dbEnv_set_lk_max_lockers dbenv max = do+ ret <- _dbenv_set_lk_max_lockers dbenv (fromIntegral max)+ if ret /= 0+ then throw "dbEnv_set_lk_max_lockers" ret+ else return ()++ +foreign import ccall unsafe "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+dbEnv_get_lk_max_locks dbenv =+ alloca $ \ptr -> do+ ret <- _dbenv_get_lk_max_locks dbenv ptr+ if ret /= 0+ then throw "dbEnv_get_lk_max_locks" ret+ else do+ ci <- peek ptr+ return $ fromIntegral ci++foreign import ccall unsafe "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 ()+dbEnv_set_lk_max_locks dbenv max = do+ ret <- _dbenv_set_lk_max_locks dbenv (fromIntegral max)+ if ret /= 0+ then throw "dbEnv_set_lk_max_locks" ret+ else return ()++ +foreign import ccall unsafe "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+dbEnv_get_lk_max_objects dbenv =+ alloca $ \ptr -> do+ ret <- _dbenv_get_lk_max_objects dbenv ptr+ if ret /= 0+ then throw "dbEnv_get_lk_max_objects" ret+ else do+ ci <- peek ptr+ return $ fromIntegral ci++foreign import ccall unsafe "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 ()+dbEnv_set_lk_max_objects dbenv max = do+ ret <- _dbenv_set_lk_max_objects dbenv (fromIntegral max)+ if ret /= 0+ then throw "dbEnv_set_lk_max_objects" ret+ else return ()++ +foreign import ccall unsafe "db_helper.h _dbenv_get_tx_max" _dbenv_get_tx_max+ :: DbEnv -> Ptr CUInt -> IO CInt++dbEnv_get_tx_max :: DbEnv -> IO Int+dbEnv_get_tx_max dbenv =+ alloca $ \ptr -> do+ ret <- _dbenv_get_tx_max dbenv ptr+ if ret /= 0+ then throw "dbEnv_get_tx_max" ret+ else do+ ci <- peek ptr+ return $ fromIntegral ci++foreign import ccall unsafe "db_helper.h _dbenv_set_tx_max" _dbenv_set_tx_max+ :: DbEnv -> CUInt -> IO CInt++dbEnv_set_tx_max :: DbEnv -> Int -> IO ()+dbEnv_set_tx_max dbenv max = do+ ret <- _dbenv_set_tx_max dbenv (fromIntegral max)+ if ret /= 0+ then throw "dbEnv_set_tx_max" ret+ else return ()+++foreign import ccall unsafe "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)+dbEnv_get_cache_size dbenv =+ alloca $ \ptr1 -> alloca $ \ptr2 -> alloca $ \ptr3 -> do+ ret <- _dbenv_get_cachesize dbenv ptr1 ptr2 ptr3+ if ret /= 0+ then throw "dbEnv_get_cache_size" ret+ else do+ c1 <- peek ptr1+ c2 <- peek ptr2+ c3 <- peek ptr3+ return $ (fromIntegral c1, fromIntegral c2, fromIntegral c3)++foreign import ccall unsafe "db_helper.h _dbenv_set_cachesize" _dbenv_set_cachesize+ :: DbEnv -> CUInt -> CUInt -> CInt -> IO CInt++dbEnv_set_cache_size :: DbEnv -> Int -> Int -> Int -> IO ()+dbEnv_set_cache_size dbenv gbytes bytes ncache = do+ ret <- _dbenv_set_cachesize dbenv (fromIntegral gbytes) (fromIntegral bytes) (fromIntegral ncache)+ if ret /= 0+ then throw "dbEnv_set_cache_size" ret+ else return ()+++foreign import ccall unsafe "db_helper.h _dbenv_get_lg_regionmax" _dbenv_get_lg_regionmax+ :: DbEnv -> Ptr CUInt -> IO CInt++dbEnv_get_lg_regionmax :: DbEnv -> IO Int+dbEnv_get_lg_regionmax dbenv =+ alloca $ \ptr -> do+ ret <- _dbenv_get_lg_regionmax dbenv ptr+ if ret /= 0+ then throw "dbEnv_get_lg_regionmax" ret+ else do+ ci <- peek ptr+ return $ fromIntegral ci++foreign import ccall unsafe "db_helper.h _dbenv_set_lg_regionmax" _dbenv_set_lg_regionmax+ :: DbEnv -> CUInt -> IO CInt++dbEnv_set_lg_regionmax :: DbEnv -> Int -> IO ()+dbEnv_set_lg_regionmax dbenv max = do+ ret <- _dbenv_set_lg_regionmax dbenv (fromIntegral max)+ if ret /= 0+ then throw "dbEnv_set_lg_regionmax" ret+ else return ()+++foreign import ccall unsafe "db_helper.h _dbenv_open" _dbenv_open+ :: DbEnv -> CString -> CUInt -> CInt -> IO CInt++data DbFlag =+ DB_CREATE |+ DB_DURABLE_UNKNOWN |+ DB_FORCE |+ DB_MULTIVERSION |+ DB_NOMMAP |+ DB_RDONLY |+ DB_RECOVER |+ DB_THREAD |+ DB_TRUNCATE |+ DB_TXN_NOSYNC |+ DB_TXN_NOWAIT |+ DB_TXN_NOT_DURABLE |+ DB_TXN_WRITE_NOSYNC |+ DB_SPARE_FLAG |+ DB_TXN_SYNC |+ DB_TXN_WAIT |+ DB_IGNORE_LEASE |+ DB_AUTO_COMMIT |+ DB_READ_COMMITTED |+ DB_DEGREE_2 |+ DB_READ_UNCOMMITTED |+ DB_DIRTY_READ |+ DB_TXN_SNAPSHOT |+ DB_CXX_NO_EXCEPTIONS |+ DB_XA_CREATE |+ DB_USE_ENVIRON |+ DB_USE_ENVIRON_ROOT |+ DB_INIT_CDB |+ DB_INIT_LOCK |+ DB_INIT_LOG |+ DB_INIT_MPOOL |+ DB_INIT_REP |+ DB_INIT_TXN |+ DB_LOCKDOWN |+ DB_PRIVATE |+ DB_RECOVER_FATAL |+ DB_REGISTER |+ DB_SYSTEM_MEM |+ DB_EXCL |+ DB_FCNTL_LOCKING |+ DB_NO_AUTO_COMMIT |+ DB_RDWRMASTER |+ DB_WRITEOPEN |+ DB_MULTIPLE |+ DB_MULTIPLE_KEY |+ DB_RMW |+ DB_LOCK_NOWAIT++dbToNum DB_CREATE = 0x0000001+dbToNum DB_DURABLE_UNKNOWN = 0x0000002+dbToNum DB_FORCE = 0x0000004+dbToNum DB_MULTIVERSION = 0x0000008+dbToNum DB_NOMMAP = 0x0000010+dbToNum DB_RDONLY = 0x0000020+dbToNum DB_RECOVER = 0x0000040+dbToNum DB_THREAD = 0x0000080+dbToNum DB_TRUNCATE = 0x0000100+dbToNum DB_TXN_NOSYNC = 0x0000200+dbToNum DB_TXN_NOWAIT = 0x0000400+dbToNum DB_TXN_NOT_DURABLE = 0x0000800+dbToNum DB_TXN_WRITE_NOSYNC = 0x0001000+dbToNum DB_SPARE_FLAG = 0x0002000+dbToNum DB_TXN_SYNC = 0x0004000+dbToNum DB_TXN_WAIT = 0x0008000+dbToNum DB_IGNORE_LEASE = 0x01000000+dbToNum DB_AUTO_COMMIT = 0x02000000+dbToNum DB_READ_COMMITTED = 0x04000000+dbToNum DB_DEGREE_2 = 0x04000000+dbToNum DB_READ_UNCOMMITTED = 0x08000000+dbToNum DB_DIRTY_READ = 0x08000000+dbToNum DB_TXN_SNAPSHOT = 0x10000000+dbToNum DB_CXX_NO_EXCEPTIONS = 0x0000001 +dbToNum DB_XA_CREATE = 0x0000002 +dbToNum DB_USE_ENVIRON = 0x0004000 +dbToNum DB_USE_ENVIRON_ROOT = 0x0008000 +dbToNum DB_INIT_CDB = 0x0010000 +dbToNum DB_INIT_LOCK = 0x0020000 +dbToNum DB_INIT_LOG = 0x0040000 +dbToNum DB_INIT_MPOOL = 0x0080000 +dbToNum DB_INIT_REP = 0x0100000 +dbToNum DB_INIT_TXN = 0x0200000 +dbToNum DB_LOCKDOWN = 0x0400000 +dbToNum DB_PRIVATE = 0x0800000 +dbToNum DB_RECOVER_FATAL = 0x1000000 +dbToNum DB_REGISTER = 0x2000000 +dbToNum DB_SYSTEM_MEM = 0x4000000 +dbToNum DB_EXCL = 0x0004000 +dbToNum DB_FCNTL_LOCKING = 0x0008000 +dbToNum DB_NO_AUTO_COMMIT = 0x0010000 +dbToNum DB_RDWRMASTER = 0x0020000 +dbToNum DB_WRITEOPEN = 0x0040000 +dbToNum DB_MULTIPLE = 0x10000000+dbToNum DB_MULTIPLE_KEY = 0x20000000+dbToNum DB_RMW = 0x40000000+dbToNum DB_LOCK_NOWAIT = 0x002++dbOrFlags flags = foldr (.|.) 0 $ map dbToNum flags++dbEnv_open :: DbEnv -> String -> [DbFlag] -> Int -> IO ()+dbEnv_open dbenv db_home flags mode =+ withCAString db_home $ \c_db_home -> do+ ret <- _dbenv_open dbenv c_db_home (dbOrFlags flags) (fromIntegral mode)+ if ret /= 0+ then throw "dbEnv_open" ret+ else return ()++data Db_struct+type Db = ForeignPtr Db_struct+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+ :: Ptr DbEnv_struct -> CUInt -> Ptr (Ptr Db_struct) -> IO CInt++db_create :: DbEnv -> [DbFlag] -> IO Db+db_create dbenv flags =+ alloca$ \ptr -> do+ ret <- _db_create dbenv (dbOrFlags flags) ptr+ if ret /= 0+ then throw "db_create" ret+ else do+ p <- peek ptr+ newForeignPtr _db_delete p++foreign import ccall unsafe "db_helper.h _db_set_pagesize" _db_set_pagesize+ :: Ptr Db_struct -> CUInt -> IO CInt++db_set_pagesize :: Db -> Int -> IO ()+db_set_pagesize db size =+ withForeignPtr db$ \c_db -> do+ ret <- _db_set_pagesize c_db (fromIntegral size)+ if ret /= 0+ then throw "db_set_pagesize" ret+ else return ()++data DbType = DB_BTREE | DB_HASH | DB_RECNO | DB_QUEUE | DB_UNKNOWN++dbTypeToNum DB_BTREE = 1+dbTypeToNum DB_HASH = 2+dbTypeToNum DB_RECNO = 3+dbTypeToNum DB_QUEUE = 4+dbTypeToNum DB_UNKNOWN = 5++data DbTxn_struct+type DbTxn = ForeignPtr DbTxn_struct+foreign import ccall "db_helper.h &_dbtxn_delete" _dbtxn_delete+ :: FunPtr (Ptr DbTxn_struct -> IO ())++foreign import ccall "db_helper.h _db_open" _db_open+ :: Ptr Db_struct -> Ptr DbTxn_struct -> CString -> CString -> CInt -> CUInt -> CInt -> IO CInt++db_open :: Db -> Maybe DbTxn -> String -> Maybe String -> DbType -> [DbFlag] -> Int -> IO ()+db_open db mTxn file mDatabase typ flags mode =+ withCAString file$ \c_file ->+ withForeignPtr db$ \c_db -> do+ ret <- case mTxn of+ Just dbtxn ->+ withForeignPtr dbtxn$ \c_dbtxn ->+ case mDatabase of+ Just database ->+ withCAString database$ \c_database ->+ _db_open c_db c_dbtxn c_file c_database+ (dbTypeToNum typ) (dbOrFlags flags) (fromIntegral mode)+ Nothing ->+ _db_open c_db c_dbtxn c_file nullPtr+ (dbTypeToNum typ) (dbOrFlags flags) (fromIntegral mode)+ Nothing ->+ case mDatabase of+ Just database ->+ withCAString database$ \c_database ->+ _db_open c_db nullPtr c_file c_database+ (dbTypeToNum typ) (dbOrFlags flags) (fromIntegral mode)+ Nothing ->+ _db_open c_db nullPtr c_file nullPtr+ (dbTypeToNum typ) (dbOrFlags flags) (fromIntegral mode)+ if ret /= 0+ then throw ("db_open file="++(show file)++" database="++(show mDatabase)) ret+ else return ()++foreign import ccall "db_helper.h _dbenv_txn_begin" _dbenv_txn_begin+ :: Ptr DbEnv_struct -> Ptr DbTxn_struct -> Ptr (Ptr DbTxn_struct) -> CUInt -> IO CInt++dbEnv_txn_begin :: DbEnv -> Maybe DbTxn -> [DbFlag] -> IO DbTxn+dbEnv_txn_begin dbenv mParent flags = do+ alloca$ \ptr -> do+ ret <- case mParent of+ Nothing -> do+ _dbenv_txn_begin dbenv nullPtr ptr (dbOrFlags flags)+ Just parent ->+ withForeignPtr parent$ \c_parent -> do+ _dbenv_txn_begin dbenv c_parent ptr (dbOrFlags flags)+ if ret /= 0+ then throw "dbEnv_txn_begin" ret+ else do+ p <- peek ptr+ newForeignPtr _dbtxn_delete p++foreign import ccall "db_helper.h _dbenv_txn_checkpoint" _dbenv_txn_checkpoint+ :: Ptr DbEnv_struct -> CUInt -> CUInt -> CUInt -> IO CInt++dbEnv_txn_checkpoint :: DbEnv -> CUInt -> CUInt -> [DbFlag] -> IO ()+dbEnv_txn_checkpoint dbenv kbyte min flags = do+ ret <- _dbenv_txn_checkpoint dbenv kbyte min (dbOrFlags flags)+ if ret /= 0+ then throw "dbEnv_txn_checkpoint" ret+ else return ()++foreign import ccall "db_helper.h _dbtxn_abort" _dbtxn_abort+ :: Ptr DbTxn_struct -> IO CInt++dbTxn_abort :: DbTxn -> IO ()+dbTxn_abort dbtxn = do+ withForeignPtr dbtxn$ \c_dbtxn -> do+ ret <- _dbtxn_abort c_dbtxn+ if ret /= 0+ then throw "dbTxn_abort" ret+ else return ()++foreign import ccall "db_helper.h _dbtxn_commit" _dbtxn_commit+ :: Ptr DbTxn_struct -> CUInt -> IO CInt++dbTxn_commit :: DbTxn -> [DbFlag] -> IO ()+dbTxn_commit dbtxn flags = do+ withForeignPtr dbtxn$ \c_dbtxn -> do+ ret <- _dbtxn_commit c_dbtxn (dbOrFlags flags)+ if ret /= 0+ then throw "dbTxn_commit" ret+ else return ()++newtype DbLocker = DbLocker CUInt++foreign import ccall "db_helper.h _dbtxn_id" _dbtxn_id+ :: Ptr DbTxn_struct -> IO CUInt++dbTxn_id :: DbTxn -> DbLocker+dbTxn_id dbtxn =+ unsafePerformIO$+ withForeignPtr dbtxn$ \c_dbtxn ->+ liftM DbLocker$ _dbtxn_id c_dbtxn+ +data DbLockMode = DB_LOCK_READ | DB_LOCK_WRITE | DB_LOCK_IWRITE | DB_LOCK_IREAD | DB_LOCK_IWR++dbLockModeToNum DB_LOCK_READ = 1+dbLockModeToNum DB_LOCK_WRITE = 2+dbLockModeToNum DB_LOCK_IWRITE = 4+dbLockModeToNum DB_LOCK_IREAD = 5+dbLockModeToNum DB_LOCK_IWR = 6++data DbLock_struct+type DbLock = ForeignPtr DbLock_struct+foreign import ccall "db_helper.h &_dblock_delete" _dblock_delete+ :: FunPtr (Ptr DbLock_struct -> IO ())++foreign import ccall "db_helper.h _dbenv_lock_get" _dbenv_lock_get+ :: Ptr DbEnv_struct -> CUInt -> CUInt -> CString -> CUInt -> CUInt -> Ptr (Ptr DbLock_struct) -> IO CInt++dbEnv_lock_get :: DbEnv -> DbLocker -> [DbFlag] -> String -> DbLockMode -> IO DbLock+dbEnv_lock_get dbenv (DbLocker locker) flags object lockMode =+ alloca$ \ptr ->+ withCAStringLen object$ \(c_object, object_len) -> do+ ret <- _dbenv_lock_get dbenv locker (dbOrFlags flags) c_object+ (fromIntegral object_len) (dbLockModeToNum lockMode) ptr+ if ret /= 0+ then throw "dbEnv_lock_get" ret+ else do+ p <- peek ptr+ newForeignPtr _dblock_delete p++foreign import ccall "db_helper.h _dbenv_lock_put" _dbenv_lock_put+ :: Ptr DbEnv_struct -> Ptr DbLock_struct -> IO CInt++dbEnv_lock_put :: DbEnv -> DbLock -> IO ()+dbEnv_lock_put dbenv dblock =+ withForeignPtr dblock$ \c_dblock -> do+ ret <- _dbenv_lock_put dbenv c_dblock+ if ret /= 0+ then throw "dbEnv_lock_put" ret+ else return ()++foreign import ccall unsafe "db_helper.h _deleteString" _deleteString+ :: CString -> IO ()++foreign import ccall unsafe "db_helper.h _freeString" _freeString+ :: CString -> 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++db_get :: Db -> Maybe DbTxn -> String -> [DbFlag] -> IO (Maybe String)+db_get db mTxn key flags =+ alloca$ \ptr1 ->+ alloca$ \ptr2 ->+ withCAStringLen key$ \(c_key, key_len) ->+ withForeignPtr db$ \c_db -> do+ ret <- case mTxn of+ Nothing ->+ _db_get c_db nullPtr c_key (fromIntegral key_len) ptr1 ptr2 (dbOrFlags flags)+ Just txn ->+ withForeignPtr txn$ \c_txn ->+ _db_get c_db c_txn c_key (fromIntegral key_len) ptr1 ptr2 (dbOrFlags flags)+ if ret /= 0+ then+ if (dbErrFromNum$ fromIntegral ret) == Just DB_NOTFOUND+ then return Nothing+ else throw "db_get" ret+ else do+ c_value <- peek ptr1+ value_len <- peek ptr2+ value <- peekCAStringLen (c_value, fromIntegral value_len)+ _freeString c_value+ return$ Just value++foreign import ccall "db_helper.h _db_put" _db_put+ :: Ptr Db_struct -> Ptr DbTxn_struct -> CString -> CUInt -> CString -> CUInt -> CUInt -> IO CInt++db_put :: Db -> Maybe DbTxn -> String -> String -> [DbFlag] -> IO ()+db_put db mTxn key value flags =+ withCAStringLen key$ \(c_key, key_len) ->+ withCAStringLen value$ \(c_value, value_len) ->+ withForeignPtr db$ \c_db -> do+ ret <- case mTxn of+ Nothing ->+ _db_put c_db nullPtr c_key (fromIntegral key_len)+ c_value (fromIntegral value_len) (dbOrFlags flags)+ Just txn ->+ withForeignPtr txn$ \c_txn ->+ _db_put c_db c_txn c_key (fromIntegral key_len)+ c_value (fromIntegral value_len) (dbOrFlags flags)+ if ret /= 0+ then throw "db_put" ret+ else return ()++foreign import ccall "db_helper.h _db_close" _db_close+ :: Ptr Db_struct -> CUInt -> IO CInt+ +db_close :: Db -> [DbFlag] -> IO ()+db_close db flags =+ withForeignPtr db$ \c_db -> do+ ret <- _db_close c_db (dbOrFlags flags)+ if ret /= 0+ then throw "db_close" ret+ else return ()++foreign import ccall "db_helper.h _dbenv_close" _dbenv_close+ :: Ptr DbEnv_struct -> CUInt -> IO CInt++dbEnv_close :: DbEnv -> [DbFlag] -> IO ()+dbEnv_close dbEnv flags = do+ ret <- _dbenv_close dbEnv (dbOrFlags flags)+ if ret /= 0+ then throw "dbEnv_close" ret+ else return ()+
+ Database/Berkeley/DbXml.hs view
@@ -0,0 +1,777 @@+{-# 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 ()+
+ Database/Berkeley/Util.hs view
@@ -0,0 +1,27 @@+module Database.Berkeley.Util+ where++import Data.List++locate :: (Eq a) => [a] -> [a] -> Maybe Int+locate needle haystack = locate_ needle haystack 0 where+ locate_ _ [] _ = Nothing+ locate_ needle haystack idx =+ if isPrefixOf needle haystack+ then Just idx+ else locate_ needle (tail haystack) (idx+1)++maybeRead :: Read a => String -> Maybe a +maybeRead s = case reads s of+ [(x, "")] -> Just x+ _ -> Nothing++toDelim :: String -> Int -> [Char] -> String+toDelim line idx delims = takeWhile (flip notElem delims) (drop idx line)++extract :: String -> String -> [Char] -> Maybe String+extract tag line delims =+ case locate tag line of+ Just idx -> Just $ toDelim line (idx+(length tag)) delims+ _ -> Nothing+
+ Database/Berkeley/db_helper.cpp view
@@ -0,0 +1,314 @@+#include "db_helper.h"++int _dbenv_create__(DbEnv** dbenv, u_int32_t flags) {+ *dbenv = new DbEnv(flags);+ return 0;+}++int _dbenv_get_lk_max_lockers(DbEnv *dbenv, u_int32_t *lk_maxp) {+ try {+ return dbenv->get_lk_max_lockers(lk_maxp);+ }+ catch (DbException& exc) {+ return exc.get_errno();+ }+}++int _dbenv_set_lk_max_lockers(DbEnv *dbenv, u_int32_t max) {+ try {+ return dbenv->set_lk_max_lockers(max);+ }+ catch (DbException& exc) {+ return exc.get_errno();+ }+}++int _dbenv_get_lk_max_locks(DbEnv *dbenv, u_int32_t *lk_maxp) {+ try {+ return dbenv->get_lk_max_locks(lk_maxp);+ }+ catch (DbException& exc) {+ return exc.get_errno();+ }+}++int _dbenv_set_lk_max_locks(DbEnv *dbenv, u_int32_t max) {+ try {+ return dbenv->set_lk_max_locks(max);+ }+ catch (DbException& exc) {+ return exc.get_errno();+ }+}++int _dbenv_get_lk_max_objects(DbEnv *dbenv, u_int32_t *lk_maxp) {+ try {+ return dbenv->get_lk_max_objects(lk_maxp);+ }+ catch (DbException& exc) {+ return exc.get_errno();+ }+}++int _dbenv_set_lk_max_objects(DbEnv *dbenv, u_int32_t max) {+ try {+ return dbenv->set_lk_max_objects(max);+ }+ catch (DbException& exc) {+ return exc.get_errno();+ }+}++int _dbenv_get_tx_max(DbEnv *dbenv, u_int32_t *lk_maxp) {+ try {+ return dbenv->get_tx_max(lk_maxp);+ }+ catch (DbException& exc) {+ return exc.get_errno();+ }+}++int _dbenv_set_tx_max(DbEnv *dbenv, u_int32_t max) {+ try {+ return dbenv->set_tx_max(max);+ }+ catch (DbException& exc) {+ return exc.get_errno();+ }+}++int _dbenv_get_cachesize(DbEnv *dbenv, u_int32_t *gbytesp, u_int32_t *bytesp, int *ncachep) {+ try {+ return dbenv->get_cachesize(gbytesp, bytesp, ncachep);+ }+ catch (DbException& exc) {+ return exc.get_errno();+ }+}++int _dbenv_set_cachesize(DbEnv *dbenv, u_int32_t gbytes, u_int32_t bytes, int ncache) {+ try {+ return dbenv->set_cachesize(gbytes, bytes, ncache);+ }+ catch (DbException& exc) {+ return exc.get_errno();+ }+}++int _dbenv_get_lg_regionmax(DbEnv *dbenv, u_int32_t *lk_maxp) {+ try {+ return dbenv->get_lg_regionmax(lk_maxp);+ }+ catch (DbException& exc) {+ return exc.get_errno();+ }+}++int _dbenv_set_lg_regionmax(DbEnv *dbenv, u_int32_t max) {+ try {+ return dbenv->set_lg_regionmax(max);+ }+ catch (DbException& exc) {+ return exc.get_errno();+ }+}++int _dbenv_open(DbEnv *dbenv, char *db_home, u_int32_t flags, int mode) {+ try {+ return dbenv->open(db_home, flags, mode);+ }+ catch (DbException& exc) {+ return exc.get_errno();+ }+}++int _db_create(DbEnv* dbenv, u_int32_t flags, Db** db)+{+ try {+ *db = new Db(dbenv, flags);+ return 0;+ }+ catch (DbException& exc) {+ return exc.get_errno();+ }+}++void _db_delete(Db* db)+{+ delete db;+}++int _db_set_pagesize(Db* db, u_int32_t pagesize)+{+ try {+ return db->set_pagesize(pagesize);+ }+ catch (DbException& exc) {+ return exc.get_errno();+ }+}++int _db_open(Db* db, DbTxn* txn, const char* file, const char* database,+ int type, u_int32_t flags, int mode)+{+ try {+ return db->open(txn, file, database, (DBTYPE) type, flags, mode);+ }+ catch (DbException& exc) {+ return exc.get_errno();+ }+}++int _dbenv_txn_begin(DbEnv* dbenv, DbTxn* parent, DbTxn** txn, u_int32_t flags)+{+ try {+ return dbenv->txn_begin(parent, txn, flags);+ }+ catch (DbException& exc) {+ return exc.get_errno();+ }+}++int _dbenv_txn_checkpoint(DbEnv* dbenv, u_int32_t kbyte, u_int32_t min, u_int32_t flags)+{+ try {+ return dbenv->txn_checkpoint(kbyte, min, flags);+ }+ catch (DbException& exc) {+ return exc.get_errno();+ }+}++int _dbtxn_abort(DbTxn* dbtxn)+{+ try {+ return dbtxn->abort();+ }+ catch (DbException& exc) {+ return exc.get_errno();+ }+}++int _dbtxn_commit(DbTxn* dbtxn, u_int32_t flags)+{+ try {+ return dbtxn->commit(flags);+ }+ catch (DbException& exc) {+ return exc.get_errno();+ }+}++void _dbtxn_delete(DbTxn* dbtxn)+{+ // dbtxn_abort or dbtxn_commit actually do the delete.+ // To do: Make it so memory leaks aren't possible.+}++u_int32_t _dbtxn_id(DbTxn* dbtxn)+{+ return dbtxn->id();+}++void _dblock_delete(DbLock* dblock)+{+ delete dblock;+}++int _dbenv_lock_get(DbEnv* dbenv, u_int32_t lockerID, u_int32_t flags,+ const char* object, u_int32_t object_len, u_int32_t lockmode, DbLock** dblock)+{+ Dbt dbt;+ memset(&dbt, 0, sizeof(dbt));+ dbt.set_data((void*)object);+ dbt.set_size(object_len);+ *dblock = new DbLock;+ try {+ int ret = dbenv->lock_get(lockerID, flags, &dbt, (db_lockmode_t)lockmode, *dblock);+ if (ret != 0) {+ delete *dblock;+ *dblock = NULL;+ }+ return ret;+ }+ catch (DbException& exc) {+ delete *dblock;+ *dblock = NULL;+ return exc.get_errno();+ }+}++int _dbenv_lock_put(DbEnv* dbenv, DbLock* dblock)+{+ try {+ dbenv->lock_put(dblock);+ }+ catch (DbException& exc) {+ return exc.get_errno();+ }+}++void _deleteString(char* str)+{+ delete[] str;+}++void _freeString(char* str)+{+ free(str);+}++int _db_get(Db* db, DbTxn* dbtxn, const char* key, u_int32_t key_len, char** value, u_int32_t* value_len, u_int32_t flags)+{+ Dbt keyDbt((void*)key, key_len);+ Dbt valueDbt;+ valueDbt.set_flags(DB_DBT_MALLOC);+ *value = NULL;+ *value_len = 0;+ try {+ int ret = db->get(dbtxn, &keyDbt, &valueDbt, flags);+ if (ret == 0) {+ *value = (char*)valueDbt.get_data();+ *value_len = valueDbt.get_size();+ }+ return ret;+ }+ catch (DbException& exc) {+ return exc.get_errno();+ }+}++int _db_put(Db* db, DbTxn* dbtxn, const char* key, u_int32_t key_len, char* value, u_int32_t value_len, u_int32_t flags)+{+ Dbt keyDbt((void*)key, key_len);+ Dbt valueDbt((void*)value, value_len);+ try {+ return db->put(dbtxn, &keyDbt, &valueDbt, flags);+ }+ catch (DbException& exc) {+ return exc.get_errno();+ }+}++int _db_close(Db* db, u_int32_t flags)+{+ try {+ return db->close(flags);+ }+ catch (DbException& exc) {+ return exc.get_errno();+ }+}++int _dbenv_close(DbEnv* dbEnv, u_int32_t flags)+{+ try {+ int ret = dbEnv->close(flags);+ delete dbEnv;+ return ret;+ }+ catch (DbException& exc) {+ return exc.get_errno();+ }+}+
+ Database/Berkeley/db_helper.h view
@@ -0,0 +1,45 @@+#ifndef _DB_HELPER_H_+#define _DB_HELPER_H_++#include "db_cxx.h"++extern "C" {+ int _dbenv_create__(DbEnv** dbenv, u_int32_t flags);+ int _dbenv_get_lk_max_lockers(DbEnv *dbenv, u_int32_t *lk_maxp);+ int _dbenv_set_lk_max_lockers(DbEnv *dbenv, u_int32_t max);+ int _dbenv_get_lk_max_locks(DbEnv *dbenv, u_int32_t *lk_maxp);+ int _dbenv_set_lk_max_locks(DbEnv *dbenv, u_int32_t max);+ int _dbenv_get_lk_max_objects(DbEnv *dbenv, u_int32_t *lk_maxp);+ int _dbenv_set_lk_max_objects(DbEnv *dbenv, u_int32_t max);+ int _dbenv_get_tx_max(DbEnv *dbenv, u_int32_t *lk_maxp);+ int _dbenv_set_tx_max(DbEnv *dbenv, u_int32_t max);+ int _dbenv_get_cachesize(DbEnv *dbenv, u_int32_t *gbytesp, u_int32_t *bytesp, int *ncachep);+ int _dbenv_set_cachesize(DbEnv *dbenv, u_int32_t gbytes, u_int32_t bytes, int ncache);+ int _dbenv_get_lg_regionmax(DbEnv *dbenv, u_int32_t *lk_maxp);+ int _dbenv_set_lg_regionmax(DbEnv *dbenv, u_int32_t max);+ int _dbenv_open(DbEnv *dbenv, char *db_home, u_int32_t flags, int mode);+ int _db_create(DbEnv* dbenv, u_int32_t flags, Db** db);+ void _db_delete(Db* db);+ int _db_set_pagesize(Db* db, u_int32_t pagesize);+ int _db_open(Db* db, DbTxn* txn, const char* file, const char* database,+ int type, u_int32_t flags, int mode);+ int _dbenv_txn_begin(DbEnv* dbenv, DbTxn* parent, DbTxn** txn, u_int32_t flags);+ int _dbenv_txn_checkpoint(DbEnv* dbenv, u_int32_t kbyte, u_int32_t min, u_int32_t flags);+ int _dbtxn_abort(DbTxn* dbtxn);+ int _dbtxn_commit(DbTxn* dbtxn, u_int32_t flags);+ void _dbtxn_delete(DbTxn* dbtxn);+ u_int32_t _dbtxn_id(DbTxn* dbtxn);+ void _dblock_delete(DbLock* dblock);+ int _dbenv_lock_get(DbEnv* dbenv, u_int32_t lockerID, u_int32_t flags,+ const char* object, u_int32_t object_len, u_int32_t lockmode, DbLock** dblock);+ int _dbenv_lock_put(DbEnv* dbenv, DbLock* dblock);+ void _deleteString(char* str);+ void _freeString(char* str);+ int _db_get(Db* db, DbTxn* dbtxn, const char* key, u_int32_t key_len, char** value, u_int32_t* value_len, u_int32_t flags);+ int _db_put(Db* db, DbTxn* dbtxn, const char* key, u_int32_t key_len, char* value, u_int32_t value_len, u_int32_t flags);+ int _db_close(Db* db, u_int32_t flags);+ int _dbenv_close(DbEnv* dbEnv, u_int32_t flags);+}++#endif+
+ Database/Berkeley/dbxml_helper.cpp view
@@ -0,0 +1,449 @@+#include "dbxml_helper.h"++#include "XmlManager.hpp"+#include "XmlException.hpp"++#include <string.h>++using namespace DbXml;+using namespace std;+++static int asInt(XmlException& exc)+{+ int dbE = exc.getDbErrno();+ if (dbE < 0)+ dbE = -dbE;+ return (exc.getExceptionCode() + 1) * 100000 + dbE;+}++int _xmlManager(DbEnv* dbenv, u_int32_t flags, DbXml::XmlManager** mgr)+{+ try {+ *mgr = new XmlManager(dbenv, flags);+ return 0;+ }+ catch (XmlException& exc) {+ *mgr = NULL;+ return asInt(exc);+ }+}++int _xmlManager_openContainer(DbXml::XmlManager* mgr, const char* name, u_int32_t flags,+ int cType, int mode, DbXml::XmlContainer** container)+{+ try {+ DbXml::XmlContainer c = mgr->openContainer(name, flags,+ cType == 0 ? XmlContainer::NodeContainer : XmlContainer::WholedocContainer,+ mode);+ *container = new DbXml::XmlContainer(c);+ return 0;+ }+ catch (XmlException& exc) {+ *container = NULL;+ return asInt(exc);+ }+}++void _xmlContainer_delete(DbXml::XmlContainer* cont)+{+ delete cont;+}++int _xmlManager_createTransaction(DbXml::XmlManager* mgr, u_int32_t flags, DbXml::XmlTransaction** trans)+{+ try {+ XmlTransaction t = mgr->createTransaction(flags);+ *trans = new XmlTransaction(t);+ return 0;+ }+ catch (XmlException& exc) {+ *trans = NULL;+ return asInt(exc);+ }+}++void _xmlTransaction_delete(DbXml::XmlTransaction* trans)+{+ delete trans;+}++int _xmlTransaction_commit(DbXml::XmlTransaction* trans)+{+ try {+ trans->commit();+ return 0;+ }+ catch (XmlException& exc) {+ return asInt(exc);+ }+}++int _xmlTransaction_abort(DbXml::XmlTransaction* trans)+{+ try {+ trans->abort();+ return 0;+ }+ catch (XmlException& exc) {+ return asInt(exc);+ }+}++int _xmlContainer_getDocument(DbXml::XmlContainer* cont, DbXml::XmlTransaction* trans,+ const char* key, u_int32_t flags, DbXml::XmlDocument** doc)+{+ try {+ XmlDocument d;+ if (trans != NULL)+ d = cont->getDocument(*trans, key, flags);+ else+ d = cont->getDocument(key, flags);+ *doc = new XmlDocument(d);+ return 0;+ }+ catch (XmlException& exc) {+ *doc = NULL;+ return asInt(exc);+ }+}++char* _xmlContainer_getName(DbXml::XmlContainer* cont)+{+ string s = cont->getName();+ char* str = new char[s.length()+1];+ strcpy(str, s.c_str());+ return str;+}++void _xmlDocument_delete(DbXml::XmlDocument* doc)+{+ delete doc;+}++int _xmlDocument_getContent(DbXml::XmlDocument* doc, char** str)+{+ string s;+ try {+ doc->getContent(s);+ }+ catch (XmlException& exc) {+ *str = NULL;+ return asInt(exc);+ }+ *str = new char[s.length()+1];+ strcpy(*str, s.c_str());+ return 0;+}++int _xmlManager_createQueryContext(DbXml::XmlManager* mgr, int rt, int ev, DbXml::XmlQueryContext** ctx)+{+ try {+ XmlQueryContext c = mgr->createQueryContext(+ XmlQueryContext::LiveValues,+ ev == 0 ? XmlQueryContext::Eager : XmlQueryContext::Lazy);+ *ctx = new XmlQueryContext(c);+ return 0;+ }+ catch (XmlException& exc) {+ *ctx = NULL;+ return asInt(exc);+ }+}++void _xmlQueryContext_delete(DbXml::XmlQueryContext* ctx)+{+ delete ctx;+}++void _xmlResults_delete(DbXml::XmlResults* res)+{+ delete res;+}++int _xmlResults_hasNext(DbXml::XmlResults* res, int* answer)+{+ try {+ *answer = res->hasNext();+ return 0;+ }+ catch (XmlException& exc) {+ return asInt(exc);+ }+}++int _xmlResults_nextDocument(DbXml::XmlResults* res, DbXml::XmlDocument** doc)+{+ *doc = new XmlDocument;+ try {+ if (!res->next(**doc)) {+ delete *doc;+ *doc = NULL;+ }+ return 0;+ }+ catch (XmlException& exc) {+ delete *doc;+ *doc = NULL;+ return asInt(exc);+ }+}++int _xmlResults_nextValue(DbXml::XmlResults* res, DbXml::XmlValue** val)+{+ *val = new XmlValue;+ try {+ if (!res->next(**val)) {+ delete *val;+ *val = NULL;+ }+ return 0;+ }+ catch (XmlException& exc) {+ delete *val;+ *val = NULL;+ return asInt(exc);+ }+}++int _xmlManager_query(DbXml::XmlManager* mgr, DbXml::XmlTransaction* trans,+ const char* query, DbXml::XmlQueryContext* ctx, u_int32_t flags, DbXml::XmlResults** res)+{+ try {+ XmlResults r;+ if (trans != NULL)+ r = mgr->query(*trans, query, *ctx, flags);+ else+ r = mgr->query(query, *ctx, flags);+ *res = new XmlResults(r);+ return 0;+ }+ catch (XmlException& exc) {+ *res = NULL;+ return asInt(exc);+ }+}++void _xmlQueryExpression_delete(DbXml::XmlQueryExpression* exp)+{+ delete exp;+}++int _xmlManager_prepare(DbXml::XmlManager* mgr, DbXml::XmlTransaction* trans,+ const char* query, DbXml::XmlQueryContext* ctx, DbXml::XmlQueryExpression** exp)+{+ try {+ XmlQueryExpression e;+ if (trans != NULL)+ e = mgr->prepare(*trans, query, *ctx);+ else+ e = mgr->prepare(query, *ctx);+ *exp = new XmlQueryExpression(e);+ return 0;+ }+ catch (XmlException& exc) {+ *exp = NULL;+ return asInt(exc);+ }+}++int _xmlQueryContext_setDefaultCollection(DbXml::XmlQueryContext* ctx, const char* coll)+{+ try {+ ctx->setDefaultCollection(coll);+ return 0;+ }+ catch (XmlException& exc) {+ return asInt(exc);+ }+}++int _xmlQueryContext_setVariableValue(DbXml::XmlQueryContext* ctx, const char* name, DbXml::XmlValue* value)+{+ try {+ ctx->setVariableValue(name, *value);+ return 0;+ }+ catch (XmlException& exc) {+ return asInt(exc);+ }+}++void _xmlValue_delete(DbXml::XmlValue* val)+{+ delete val;+}++DbXml::XmlValue* _xmlNone()+{+ return new XmlValue;+}++DbXml::XmlValue* _xmlString(const char* text)+{+ return new XmlValue(text);+}++DbXml::XmlValue* _xmlBool(int value)+{+ return new XmlValue((bool)value);+}++DbXml::XmlValue* _xmlDouble(double value)+{+ return new XmlValue(value);+}++int _xmlValue_asString(DbXml::XmlValue* value, char** str)+{+ string s;+ try {+ s = value->asString();+ }+ catch (XmlException& exc) {+ *str = NULL;+ return asInt(exc);+ }+ *str = new char[s.length()+1];+ strcpy(*str, s.c_str());+ return 0;+}++int _xmlQueryExpression_execute(DbXml::XmlQueryExpression* exp, DbXml::XmlTransaction* trans,+ DbXml::XmlValue* contextItem, DbXml::XmlQueryContext* qctx, u_int32_t flags, DbXml::XmlResults** res)+{+ try {+ XmlResults r;+ if (trans != NULL && contextItem != NULL)+ r = exp->execute(*trans, *contextItem, *qctx, flags);+ else+ if (trans != NULL && contextItem == NULL)+ r = exp->execute(*trans, *qctx, flags);+ else+ if (trans == NULL && contextItem != NULL)+ r = exp->execute(*contextItem, *qctx, flags);+ else+ r = exp->execute(*qctx, flags);+ *res = new XmlResults(r);+ return 0;+ }+ catch (XmlException& exc) {+ *res = NULL;+ return asInt(exc);+ }+}++int _xmlManager_createDocument(DbXml::XmlManager* mgr, DbXml::XmlDocument** doc)+{+ try {+ XmlDocument d = mgr->createDocument();+ *doc = new XmlDocument(d);+ return 0;+ }+ catch (XmlException& exc) {+ *doc = NULL;+ return asInt(exc);+ }+}++int _xmlDocument_getName(DbXml::XmlDocument* doc, char** name)+{+ string s;+ try {+ s = doc->getName();+ }+ catch (XmlException& exc) {+ *name = NULL;+ return asInt(exc);+ }+ *name = new char[s.length()+1];+ strcpy(*name, s.c_str());+ return 0;+}++int _xmlDocument_setName(DbXml::XmlDocument* doc, const char* name)+{+ try {+ doc->setName(name);+ return 0;+ }+ catch (XmlException& exc) {+ return asInt(exc);+ }+}++void _xmlUpdateContext_delete(DbXml::XmlUpdateContext* ctx)+{+ delete ctx;+}++int _xmlManager_createUpdateContext(DbXml::XmlManager* mgr, DbXml::XmlUpdateContext** ctx)+{+ try {+ XmlUpdateContext c = mgr->createUpdateContext();+ *ctx = new XmlUpdateContext(c);+ return 0;+ }+ catch (XmlException& exc) {+ *ctx = NULL;+ return asInt(exc);+ }+}++int _xmlDocument_setContent(DbXml::XmlDocument* doc, const char* text)+{+ try {+ doc->setContent(text);+ return 0;+ }+ catch (XmlException& exc) {+ *doc = NULL;+ return asInt(exc);+ }+}++int _xmlContainer_updateDocument(DbXml::XmlContainer* cont, DbXml::XmlTransaction* trans,+ DbXml::XmlDocument* doc, DbXml::XmlUpdateContext* uctx)+{+ try {+ if (trans != NULL)+ cont->updateDocument(*trans, *doc, *uctx);+ else+ cont->updateDocument(*doc, *uctx);+ return 0;+ }+ catch (XmlException& exc) {+ return asInt(exc);+ }+}++int _xmlContainer_putDocument(DbXml::XmlContainer* cont, DbXml::XmlTransaction* trans,+ DbXml::XmlDocument* doc, DbXml::XmlUpdateContext* uctx, u_int32_t flags)+{+ try {+ if (trans != NULL)+ cont->putDocument(*trans, *doc, *uctx, flags);+ else+ cont->putDocument(*doc, *uctx, flags);+ return 0;+ }+ catch (XmlException& exc) {+ return asInt(exc);+ }+}++int _xmlContainer_deleteDocument(DbXml::XmlContainer* cont, DbXml::XmlTransaction* trans,+ DbXml::XmlDocument* doc, DbXml::XmlUpdateContext* uctx)+{+ try {+ if (trans != NULL)+ cont->deleteDocument(*trans, *doc, *uctx);+ else+ cont->deleteDocument(*doc, *uctx);+ return 0;+ }+ catch (XmlException& exc) {+ return asInt(exc);+ }+}+
+ Database/Berkeley/dbxml_helper.h view
@@ -0,0 +1,56 @@+#ifndef _DBXML_HELPER_H_+#define _DBXML_HELPER_H_++#include <DbXml.hpp>++extern "C" {+ int _xmlManager(DbEnv* dbenv, u_int32_t flags, DbXml::XmlManager** mgr);+ int _xmlManager_openContainer(DbXml::XmlManager* mgr, const char* name, u_int32_t flags,+ int cType, int mode, DbXml::XmlContainer** container);+ void _xmlContainer_delete(DbXml::XmlContainer* cont);+ int _xmlManager_createTransaction(DbXml::XmlManager* mgr, u_int32_t flags, DbXml::XmlTransaction** trans);+ void _xmlTransaction_delete(DbXml::XmlTransaction* trans);+ int _xmlTransaction_commit(DbXml::XmlTransaction* trans);+ int _xmlTransaction_abort(DbXml::XmlTransaction* trans);+ int _xmlContainer_getDocument(DbXml::XmlContainer* cont, DbXml::XmlTransaction* trans,+ 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 _xmlManager_createQueryContext(DbXml::XmlManager* mgr, int rt, int ev, DbXml::XmlQueryContext** ctx);+ void _xmlQueryContext_delete(DbXml::XmlQueryContext* ctx);+ void _xmlResults_delete(DbXml::XmlResults* res);+ int _xmlResults_hasNext(DbXml::XmlResults* res, int* answer);+ int _xmlResults_nextDocument(DbXml::XmlResults* res, DbXml::XmlDocument** doc);+ int _xmlResults_nextValue(DbXml::XmlResults* res, DbXml::XmlValue** val);+ int _xmlManager_query(DbXml::XmlManager* mgr, DbXml::XmlTransaction* trans,+ const char* query, DbXml::XmlQueryContext* ctx, u_int32_t flags, DbXml::XmlResults** res);+ void _xmlQueryExpression_delete(DbXml::XmlQueryExpression* exp);+ int _xmlManager_prepare(DbXml::XmlManager* mgr, DbXml::XmlTransaction* trans,+ const char* query, DbXml::XmlQueryContext* ctx, DbXml::XmlQueryExpression** exp);+ int _xmlQueryContext_setDefaultCollection(DbXml::XmlQueryContext* ctx, const char* coll);+ int _xmlQueryContext_setVariableValue(DbXml::XmlQueryContext* ctx, const char* name, DbXml::XmlValue* value);+ void _xmlValue_delete(DbXml::XmlValue* exp);+ DbXml::XmlValue* _xmlNone();+ DbXml::XmlValue* _xmlString(const char* text);+ DbXml::XmlValue* _xmlBool(int value);+ DbXml::XmlValue* _xmlDouble(double value);+ int _xmlValue_asString(DbXml::XmlValue* value, char** str);+ int _xmlQueryExpression_execute(DbXml::XmlQueryExpression* exp, DbXml::XmlTransaction* trans,+ DbXml::XmlValue* contextItem, DbXml::XmlQueryContext* qctx, u_int32_t flags, DbXml::XmlResults** res);+ int _xmlManager_createDocument(DbXml::XmlManager* mgr, DbXml::XmlDocument** doc);+ int _xmlDocument_getName(DbXml::XmlDocument* doc, char** name);+ int _xmlDocument_setName(DbXml::XmlDocument* doc, const char* name);+ void _xmlUpdateContext_delete(DbXml::XmlUpdateContext* ctx);+ int _xmlManager_createUpdateContext(DbXml::XmlManager* mgr, DbXml::XmlUpdateContext** ctx);+ int _xmlDocument_setContent(DbXml::XmlDocument* doc, const char* text);+ int _xmlContainer_updateDocument(DbXml::XmlContainer* cont, DbXml::XmlTransaction* trans,+ DbXml::XmlDocument* doc, DbXml::XmlUpdateContext* uctx);+ int _xmlContainer_putDocument(DbXml::XmlContainer* cont, DbXml::XmlTransaction* trans,+ DbXml::XmlDocument* doc, DbXml::XmlUpdateContext* uctx, u_int32_t flags);+ int _xmlContainer_deleteDocument(DbXml::XmlContainer* cont, DbXml::XmlTransaction* trans,+ DbXml::XmlDocument* doc, DbXml::XmlUpdateContext* uctx);+}++#endif+
+ LICENSE view
@@ -0,0 +1,27 @@+/*+ * Copyright (c) 2008, Stephen Blackheath+ * All rights reserved.+ *+ * Redistribution and use in source and binary forms, with or without+ * modification, are permitted provided that the following conditions are met:+ * * Redistributions of source code must retain the above copyright+ * notice, this list of conditions and the following disclaimer.+ * * Redistributions in binary form must reproduce the above copyright+ * notice, this list of conditions and the following disclaimer in the+ * documentation and/or other materials provided with the distribution.+ * * Neither the name of the <organization> nor the+ * names of its contributors may be used to endorse or promote products+ * derived from this software without specific prior written permission.+ *+ * THIS SOFTWARE IS PROVIDED BY STEPHEN BLACKHEATH ''AS IS'' AND ANY+ * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+ * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+ * DISCLAIMED. IN NO EVENT SHALL STEPHEN BLACKHEATH BE LIABLE FOR ANY+ * DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+ * (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+ * LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND+ * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+ * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+ * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+ */+
+ README view
@@ -0,0 +1,51 @@+Berkeley DB / Berkeley DB/XML binding for Haskell+Version 0.1 23 Sep 2008+by Stephen Blackheath++email me: http://blacksapphire.com/antispam/+darcs repository: http://blacksapphire.com/BerkeleyDBXML/+++Berkeley DB/XML is a powerful, fully transactional, XML-based database that uses+XQuery as its query language. You can download it here:++http://www.oracle.com/database/berkeley-db/xml/index.html++This package provides a Haskell binding for Berkeley DB/XML. It is a tolerable+subset of the API, and I hope to improve it over time. I have stuck closely to+the C++ API, with some minor changes where a Haskell idiom seemed appropriate.+I hope that people will develop higher level wrappers for it. I have had great+success with the "pickler" interfaces in the HXT library. In a future version+of this package I will give some examples.++This package is in its very early stages, and needs some work, but it should+allow you to write a fairly serious application. If you find some part of the+API that is missing, and would like it added, please contact me.++I hope this package helps make Haskell better. I am partly motivated by a+belief that SQL is holding us back. An advanced language should have an+advanced database.++If you just want Berkeley DB without Berkeley DB/XML, you should be able to+achieve this easily by modifying the BerkeleyDBXML.cabal file. The Berkeley DB+parts do not depend on the Berkeley DB/XML parts. Some time I will make this+easier.++To install, use the standard Cabal install procedure:++runhaskell Setup.hs configure+runhaskell Setup.hs build+sudo runhaskell Setup.hs install++If Berkeley DB or DB/XML is not installed in the default location of /usr or+/usr/local, you will need to specify the paths in this way:++runhaskell Setup.hs configure \+ --extra-include-dirs=/usr/local/dbxml-2.4.13/include/dbxml/ \+ --extra-lib-dirs=/usr/local/dbxml-2.4.13/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.+
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple+main = defaultMain+
+ examples/Makefile view
@@ -0,0 +1,8 @@+all: test1 test2++test1: Test1.hs+ ghc --make -o $@ $<++test2: Test2.hs+ ghc --make -o $@ $<+
+ examples/Test1.hs view
@@ -0,0 +1,237 @@+module Main where++import System.Environment+import Database.Berkeley.Db+import Control.Monad++data Action = Read | Write | Fail deriving Eq++writeDb :: Db -> IO ()+writeDb db = do+ forM_ testData$ \(country, capital) -> do+ db_put db Nothing country capital []++readDb :: Db -> IO ()+readDb db = do+ forM_ testData$ \(country, capital) -> do+ capital <- db_get db Nothing country []+ putStrLn$ country ++ " - " ++ (show capital)++main = do+ args <- getArgs+ let action = case args of+ ["read"] -> Read+ ["write"] -> Write+ otherwise -> Fail+ if action == Fail+ then putStrLn "Please say 'read' or 'write' on the command line"+ else do+ dbenv <- dbEnv_create []+ dbEnv_open dbenv "." [DB_CREATE,DB_INIT_MPOOL] 0+ db <- db_create dbenv []+ db_set_pagesize db 2048+ db_open db Nothing "capitals.db" Nothing DB_HASH+ [DB_CREATE] 0+ if action == Read+ then readDb db+ else writeDb db+ db_close db []+ dbEnv_close dbenv []+ putStrLn "Finished."++testData = [+ ("Afghanistan", "Kabul"),+ ("Albania", "Tirane"),+ ("Algeria", "Algiers"),+ ("Andorra", "Andorra la Vella"),+ ("Angola", "Luanda"),+ ("Antigua and Barbuda", "Saint John's"),+ ("Argentina", "Buenos Aires"),+ ("Armenia", "Yerevan"),+ ("Australia", "Canberra"),+ ("Austria", "Vienna"),+ ("Azerbaijan", "Baku"),+ ("The Bahamas", "Nassau"),+ ("Bahrain", "Manama"),+ ("Bangladesh", "Dhaka"),+ ("Barbados", "Bridgetown"),+ ("Belarus", "Minsk"),+ ("Belgium", "Brussels"),+ ("Belize", "Belmopan"),+ ("Benin", "Porto-Novo"),+ ("Bhutan", "Thimphu"),+ ("Bolivia", "La Paz (administrative); Sucre (judicial)"),+ ("Bosnia and Herzegovina", "Sarajevo"),+ ("Botswana", "Gaborone"),+ ("Brazil", "Brasilia"),+ ("Brunei", "Bandar Seri Begawan"),+ ("Bulgaria", "Sofia"),+ ("Burkina Faso", "Ouagadougou"),+ ("Burundi", "Bujumbura"),+ ("Cambodia", "Phnom Penh"),+ ("Cameroon", "Yaounde"),+ ("Canada", "Ottawa"),+ ("Cape Verde", "Praia"),+ ("Central African Republic", "Bangui"),+ ("Chad", "N'Djamena"),+ ("Chile", "Santiago"),+ ("China", "Beijing"),+ ("Colombia", "Bogota"),+ ("Comoros", "Moroni"),+ ("Congo, Republic of the", "Brazzaville"),+ ("Congo, Democratic Republic of the", "Kinshasa"),+ ("Costa Rica", "San Jose"),+ ("Cote d'Ivoire", "Yamoussoukro (official); Abidjan (de facto)"),+ ("Croatia", "Zagreb"),+ ("Cuba", "Havana"),+ ("Cyprus", "Nicosia"),+ ("Czech Republic", "Prague"),+ ("Denmark", "Copenhagen"),+ ("Djibouti", "Djibouti"),+ ("Dominica", "Roseau"),+ ("Dominican Republic", "Santo Domingo"),+ ("East Timor (Timor-Leste)", "Dili"),+ ("Ecuador", "Quito"),+ ("Egypt", "Cairo"),+ ("El Salvador", "San Salvador"),+ ("Equatorial Guinea", "Malabo"),+ ("Eritrea", "Asmara"),+ ("Estonia", "Tallinn"),+ ("Ethiopia", "Addis Ababa"),+ ("Fiji", "Suva"),+ ("Finland", "Helsinki"),+ ("France", "Paris"),+ ("Gabon", "Libreville"),+ ("The Gambia", "Banjul"),+ ("Georgia", "Tbilisi"),+ ("Germany", "Berlin"),+ ("Ghana", "Accra"),+ ("Greece", "Athens"),+ ("Grenada", "Saint George's"),+ ("Guatemala", "Guatemala City"),+ ("Guinea", "Conakry"),+ ("Guinea-Bissau", "Bissau"),+ ("Guyana", "Georgetown"),+ ("Haiti", "Port-au-Prince"),+ ("Honduras", "Tegucigalpa"),+ ("Hungary", "Budapest"),+ ("Iceland", "Reykjavik"),+ ("India", "New Delhi"),+ ("Indonesia", "Jakarta"),+ ("Iran", "Tehran"),+ ("Iraq", "Baghdad"),+ ("Ireland", "Dublin"),+ ("Israel", "Jerusalem"),+ ("Italy", "Rome"),+ ("Jamaica", "Kingston"),+ ("Japan", "Tokyo"),+ ("Jordan", "Amman"),+ ("Kazakhstan", "Astana"),+ ("Kenya", "Nairobi"),+ ("Kiribati", "Tarawa Atoll"),+ ("Korea, North", "Pyongyang"),+ ("Korea, South", "Seoul"),+ ("Kosovo", "Pristina"),+ ("Kuwait", "Kuwait City"),+ ("Kyrgyzstan", "Bishkek"),+ ("Laos", "Vientiane"),+ ("Latvia", "Riga"),+ ("Lebanon", "Beirut"),+ ("Lesotho", "Maseru"),+ ("Liberia", "Monrovia"),+ ("Libya", "Tripoli"),+ ("Liechtenstein", "Vaduz"),+ ("Lithuania", "Vilnius"),+ ("Luxembourg", "Luxembourg"),+ ("Macedonia", "Skopje"),+ ("Madagascar", "Antananarivo"),+ ("Malawi", "Lilongwe"),+ ("Malaysia", "Kuala Lumpur"),+ ("Maldives", "Male"),+ ("Mali", "Bamako"),+ ("Malta", "Valletta"),+ ("Marshall Islands", "Majuro"),+ ("Mauritania", "Nouakchott"),+ ("Mauritius", "Port Louis"),+ ("Mexico", "Mexico City"),+ ("Micronesia, Federated States of", "Palikir"),+ ("Moldova", "Chisinau"),+ ("Monaco", "Monaco"),+ ("Mongolia", "Ulaanbaatar"),+ ("Montenegro", "Podgorica"),+ ("Morocco", "Rabat"),+ ("Mozambique", "Maputo"),+ ("Myanmar (Burma)", "Rangoon (Yangon); Naypyidaw or Nay Pyi Taw (administrative)"),+ ("Namibia", "Windhoek"),+ ("Nauru", "no official capital; government offices in Yaren District"),+ ("Nepal", "Kathmandu"),+ ("Netherlands", "Amsterdam; The Hague (seat of government)"),+ ("New Zealand", "Wellington"),+ ("Nicaragua", "Managua"),+ ("Niger", "Niamey"),+ ("Nigeria", "Abuja"),+ ("Norway", "Oslo"),+ ("Oman", "Muscat"),+ ("Pakistan", "Islamabad"),+ ("Palau", "Melekeok"),+ ("Panama", "Panama City"),+ ("Papua New Guinea", "Port Moresby"),+ ("Paraguay", "Asuncion"),+ ("Peru", "Lima"),+ ("Philippines", "Manila"),+ ("Poland", "Warsaw"),+ ("Portugal", "Lisbon"),+ ("Qatar", "Doha"),+ ("Romania", "Bucharest"),+ ("Russia", "Moscow"),+ ("Rwanda", "Kigali"),+ ("Saint Kitts and Nevis", "Basseterre"),+ ("Saint Lucia", "Castries"),+ ("Saint Vincent and the Grenadines", "Kingstown"),+ ("Samoa", "Apia"),+ ("San Marino", "San Marino"),+ ("Sao Tome and Principe", "Sao Tome"),+ ("Saudi Arabia", "Riyadh"),+ ("Senegal", "Dakar"),+ ("Serbia", "Belgrade"),+ ("Seychelles", "Victoria"),+ ("Sierra Leone", "Freetown"),+ ("Singapore", "Singapore"),+ ("Slovakia", "Bratislava"),+ ("Slovenia", "Ljubljana"),+ ("Solomon Islands", "Honiara"),+ ("Somalia", "Mogadishu"),+ ("South Africa", "Pretoria (administrative); Cape Town (legislative); Bloemfontein (judiciary)"),+ ("Spain", "Madrid"),+ ("Sri Lanka", "Colombo; Sri Jayewardenepura Kotte (legislative)"),+ ("Sudan", "Khartoum"),+ ("Suriname", "Paramaribo"),+ ("Swaziland", "Mbabane"),+ ("Sweden", "Stockholm"),+ ("Switzerland", "Bern"),+ ("Syria", "Damascus"),+ ("Taiwan", "Taipei"),+ ("Tajikistan", "Dushanbe"),+ ("Tanzania", "Dar es Salaam; Dodoma (legislative)"),+ ("Thailand", "Bangkok"),+ ("Togo", "Lome"),+ ("Tonga", "Nuku'alofa"),+ ("Trinidad and Tobago", "Port-of-Spain"),+ ("Tunisia", "Tunis"),+ ("Turkey", "Ankara"),+ ("Turkmenistan", "Ashgabat"),+ ("Tuvalu", "Vaiaku village, Funafuti province"),+ ("Uganda", "Kampala"),+ ("Ukraine", "Kyiv"),+ ("United Arab Emirates", "Abu Dhabi"),+ ("United Kingdom", "London"),+ ("United States of America", "Washington D.C."),+ ("Uruguay", "Montevideo"),+ ("Uzbekistan", "Tashkent"),+ ("Vanuatu", "Port-Vila"),+ ("Vatican City (Holy See)", "Vatican City"),+ ("Venezuela", "Caracas"),+ ("Vietnam", "Hanoi"),+ ("Yemen", "Sanaa"),+ ("Zambia", "Lusaka"),+ ("Zimbabwe", "Harare")]
+ examples/Test2.hs view
@@ -0,0 +1,20 @@+module Main where++import System.Environment+import Database.Berkeley.Db+import Database.Berkeley.DbXml+import Control.Monad++data Action = Read | Write | Fail deriving Eq++main = do+ dbenv <- dbEnv_create []+ dbEnv_open dbenv "." [DB_CREATE,DB_INIT_MPOOL] 0+ mgr <- xmlManager_create dbenv []+ db <- xmlManager_openContainer mgr "metabarter.dbxml"+ [DBXML_TRANSACTIONAL,DB_FLAG DB_READ_UNCOMMITTED,DB_FLAG DB_THREAD,DB_FLAG DB_MULTIVERSION,DB_FLAG DB_CREATE]+ WholedocContainer 0++ -- To do: Make this test more interesting+ putStrLn "Finished."+