diff --git a/BerkeleyDBXML.cabal b/BerkeleyDBXML.cabal new file mode 100644 --- /dev/null +++ b/BerkeleyDBXML.cabal @@ -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++ + diff --git a/Database/Berkeley/Db.hs b/Database/Berkeley/Db.hs new file mode 100644 --- /dev/null +++ b/Database/Berkeley/Db.hs @@ -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 () + diff --git a/Database/Berkeley/DbXml.hs b/Database/Berkeley/DbXml.hs new file mode 100644 --- /dev/null +++ b/Database/Berkeley/DbXml.hs @@ -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 () + diff --git a/Database/Berkeley/Util.hs b/Database/Berkeley/Util.hs new file mode 100644 --- /dev/null +++ b/Database/Berkeley/Util.hs @@ -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 + diff --git a/Database/Berkeley/db_helper.cpp b/Database/Berkeley/db_helper.cpp new file mode 100644 --- /dev/null +++ b/Database/Berkeley/db_helper.cpp @@ -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(); + } +} + diff --git a/Database/Berkeley/db_helper.h b/Database/Berkeley/db_helper.h new file mode 100644 --- /dev/null +++ b/Database/Berkeley/db_helper.h @@ -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 + diff --git a/Database/Berkeley/dbxml_helper.cpp b/Database/Berkeley/dbxml_helper.cpp new file mode 100644 --- /dev/null +++ b/Database/Berkeley/dbxml_helper.cpp @@ -0,0 +1,449 @@ +#include "dbxml_helper.h" + +#include "XmlManager.hpp" +#include "XmlException.hpp" + +#include + +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); + } +} + diff --git a/Database/Berkeley/dbxml_helper.h b/Database/Berkeley/dbxml_helper.h new file mode 100644 --- /dev/null +++ b/Database/Berkeley/dbxml_helper.h @@ -0,0 +1,56 @@ +#ifndef _DBXML_HELPER_H_ +#define _DBXML_HELPER_H_ + +#include + +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 + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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 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. + */ + diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -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. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff --git a/examples/Makefile b/examples/Makefile new file mode 100644 --- /dev/null +++ b/examples/Makefile @@ -0,0 +1,8 @@ +all: test1 test2 + +test1: Test1.hs + ghc --make -o $@ $< + +test2: Test2.hs + ghc --make -o $@ $< + diff --git a/examples/Test1.hs b/examples/Test1.hs new file mode 100644 --- /dev/null +++ b/examples/Test1.hs @@ -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")] diff --git a/examples/Test2.hs b/examples/Test2.hs new file mode 100644 --- /dev/null +++ b/examples/Test2.hs @@ -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." +