BerkeleyDB 0.2 → 0.3
raw patch · 3 files changed
+1171/−18 lines, 3 filesdep +bytestring
Dependencies added: bytestring
Files
- BerkeleyDB.cabal +10/−7
- Database/BerkeleyDB.hs +1149/−0
- Database/BerkeleyDB.hsc +12/−11
BerkeleyDB.cabal view
@@ -1,5 +1,5 @@ name: BerkeleyDB-version: 0.2+version: 0.3 license: BSD3 license-file: LICENSE copyright: John McCall, 2007@@ -8,16 +8,18 @@ stability: alpha homepage: http://www.cs.pdx.edu/~rjmccall/hackage/BerkeleyDB/ category: Database-build-depends: base, unix+build-depends: base, unix, bytestring synopsis: Bindings for Berkeley DB v1.x description: Provides Haskell bindings for Berkeley DB v1.x, a simple file-backed database library which is included by default with many UNIX- distributions. Databases may be organized in one of four methods:- in a hashtable, in a b-tree, in a stream of fixed-length records,- and in a stream of variable-length records. Custom comparison- and hash functions are supported. Most of the standard database- API is supported.+ distributions. This package presently makes no effort to support+ modern versions of Berkeley DB.+ .+ Databases may be organized in one of four methods: in a hashtable,+ in a b-tree, in a stream of fixed-length records, and in a stream+ of variable-length records. Custom comparison and hash functions+ are supported. Most of the standard database API is supported. . This implementation *seems* stable, inasmuch as I don't know of any glaring flaws, but I haven't done anything that could even jokingly@@ -28,4 +30,5 @@ ForeignFunctionInterface MultiParamTypeClasses FunctionalDependencies+ GeneralizedNewtypeDeriving includes: db.h
+ Database/BerkeleyDB.hs view
@@ -0,0 +1,1149 @@+{-# INCLUDE "Database/BerkeleyDB_hsc.h" #-}+{-# LINE 1 "Database/BerkeleyDB.hsc" #-}+{-+{-# LINE 2 "Database/BerkeleyDB.hsc" #-}+ Database.BerkeleyDB v0.2+ Copyright 2007 John McCall+ Licensed for general use under a BSD3-style license; for the exact+ license text, see the LICENSE file included in this distribution. If+ you find this file distributed without a LICENSE file, please contact+ me at rjmccall@gmail.com and tell me where you found it.++ It's my hope that this module could be used to bootstrap bindings for a+ modern version of Berkeley DB, but I'm not currently working on that.++ Author: John McCall <rjmccall@gmail.com>+ Maintainer: John McCall <rjmccall@gmail.com>+ History:+ v0.2 2007-04-06 Haddock documentation; FileMode.+ v0.1 2007-04-05 Creation.+-}++{- We require a preprocessor pass in order to bring the structure+ layout into scope. We can't rely the LANGUAGE CPP pragma, though,+ because we're a literate Haskell file, and it doesn't mix well+ (in particular, GHC doesn't add the current directory to the include+ path, which is a problem, because unlitting this file creates a file+ in /tmp somewhere). -}++{-# LANGUAGE ForeignFunctionInterface #-}+++{-# LINE 29 "Database/BerkeleyDB.hsc" #-}++{-# LINE 30 "Database/BerkeleyDB.hsc" #-}+++{-# LINE 32 "Database/BerkeleyDB.hsc" #-}++{-# LINE 33 "Database/BerkeleyDB.hsc" #-}++{-# LINE 36 "Database/BerkeleyDB.hsc" #-}++{-|+Haskell bindings for Berkeley DB v1.85, i.e. @db.h@ on BSD-derived Unices.+This module is intended to be imported qualified.++The database implementations provided by this module are not safe+against concurrent access; for that, users must seek a more resilient+database.++This module has been written with GHC 6.6 in mind; it is quite+possible that it will function with minimal changes on other+implementations of Haskell or earlier versions of GHC, and patches for+this purpose would be welcome, providing they don't compromise the integrity+of the up-to-date GHC implementation.++The open functions generally interpret 'IOMode' as follows:++- 'ReadMode' attempts to open a database in read-only mode; if the database+ doesn't exist, an exception is thrown.++- 'ReadWriteMode' and 'AppendMode' are synonymous; both open the database in+ read\/write mode, creating it if necessary.++- 'WriteMode' opens the database in read\/write mode, but it truncates any+ existing database file.+ -}+module Database.BerkeleyDB+ (HashDB, openHash, HashDBCursor,HashDBConf(..), defaultHashDBConf,+ TreeDB, openTree, TreeDBCursor,TreeDBConf(..), defaultTreeDBConf, + RecordDB, openRecord, Record, RecordDBCursor,+ RecordDBConf(..), defaultRecordDBConf,+ FixedRecordDB, openFixedRecord, FixedRecordDBCursor,+ FixedRecordDBConf(..), defaultFixedRecordDBConf,+ DB(..), DBCursor(..),+ IOMode(..)) where++import System.IO (IOMode(..)) -- re-exported+import System.Posix.Files -- for FileMode's helpful constants+import System.Posix.Types -- for mode_t++import Foreign+import Foreign.C+import Control.Monad (when, liftM)+import Control.Exception (bracketOnError)+import Data.ByteString (ByteString, packCStringLen, copyCStringLen, useAsCStringLen)+import Prelude hiding (lookup)++{- We use 0666 as our default umask, but we define it in this crazy way. -}+defaultUmask :: FileMode+defaultUmask = foldl1 unionFileModes [ownerReadMode,+ ownerWriteMode,+ groupReadMode,+ groupWriteMode,+ otherReadMode,+ otherWriteMode]++--------- TYPE CLASSES ---------++{-| Common operations supported by databases. The database type+ functionally defines its key, value, and cursor types. -}+class (DBCursor c k v) => DB t c k v | t -> c k v where++ {-| The simplified "open" command. Individual database types usually+ provide a specialized open operation. If no filepath is given, the+ database will exist primarily in memory or a temporary file. -}+ open :: Maybe FilePath -> IOMode -> IO t++ {-| Closes the database. Just as with files, it's important to explicitly+ close a database to avoid memory leaks; it's also important to explicitly+ close a database in order to flush database writes which might currently+ be cached.++ The internal database structures may be in an unstable state after this+ function is called; it's unsafe to make any further calls on the same+ database object after it's been closed. -}+ close :: t -> IO ()++ {-| Inserts an entry into the database. -}+ insert :: t -> k -> v -> IO ()++ {-| Looks up an entry in the database. -}+ lookup :: t -> k -> IO (Maybe v)++ {-| Deletes an entry from the database. Returns true if the entry existed+ before it was deleted. -}+ delete :: t -> k -> IO Bool++ {-| Creates a new cursor for sequential access to the database. The+ standard Berkeley DB implementations only support a single cursor+ per database, so even if multiple cursors are created, they'll+ all change the same state. Other database implementations might+ support multiple simultaneous cursors. -}+ cursor :: t -> IO c++ {-| Forces a sync with the disk, to the extent that this is possible+ with system calls. -}+ sync :: t -> IO ()+++{-| A type-class for database cursors. The cursor type functionally+ defines the key and value types. -}+class DBCursor c k v | c -> k v where++ {-| Jumps to the first entry in the database. -}+ jumpFirst :: c -> IO (Maybe (k,v))++ {-| Jumps to the last entry in the database. Not all database+ implementations support this operation. -}+ jumpLast :: c -> IO (Maybe (k,v))++ {-| Jumps to an arbitrary place in the database. The returned match+ may not be an exact match for the key; see the notes for each+ database implementation for more details. -}+ jump :: c -> k -> IO (Maybe (k,v))++ {-| Moves to the next entry in the database. -}+ next :: c -> IO (Maybe (k,v))++ {-| Moves to the previous entry in the database. -}+ previous :: c -> IO (Maybe (k,v))++ {-| Replaces the current entry with a new value. The cursor must be+ initialized for this operation to succeed. -}+ replace :: c -> k -> v -> IO ()++ {-| Removes the entry at the current cursor position. -}+ remove :: c -> IO ()++ {-| Closes the cursor. For Berkeley databases, this doesn't do anything. -}+ closeCursor:: c -> IO ()+++-------- GENERAL IMPLEMENTATION -------++{- The type of databases; in C-land, this is "DB". Here, it's+ completely opaque, we never try to modify it, and we don't export+ it. -}+data DBStruct = DBStruct++{- The type of "database thangs"; in C-land, this is "DBT". -}+data DBT = DBT Int (Ptr CChar)+instance Storable DBT where+ sizeOf _ = sizeOf (undefined :: CInt) + sizeOf (undefined :: Ptr CChar)+ alignment _ = alignment (undefined :: Ptr CChar)+ peek ptr = do+ dat <- peek (castPtr ptr)+ size <- peek (plusPtr ptr (sizeOf (undefined :: Ptr CChar)))+ return $ DBT size dat+ poke ptr (DBT size dat) = do+ poke (castPtr ptr) dat+ poke (plusPtr ptr (sizeOf (undefined :: Ptr CChar))) size++{- Copies a DBT into a new ByteString, which will have a finalizer+ associated with it. -}+copyDBT :: Ptr DBT -> IO ByteString+copyDBT ptr = do+ DBT sz dat <- peek ptr+ copyCStringLen (dat, sz)++{- Temporarily wraps a DBT in a ByteString. ByteStrings created this way+ should never become visible out of this module --- the database doesn't+ guarantee that returned values will remain consistent across subsequent+ database calls, so it's important to copy anything that we think should+ stick around. We provide this wrapping only for our callbacks, which+ (since they're not monadic) shouldn't ever capture the memory. -}+wrapDBT :: Ptr DBT -> ByteString+wrapDBT ptr = unsafePerformIO $ do+ DBT sz dat <- peek ptr+ return $ packCStringLen (dat, sz)++{- Use a ByteString transparently as a DBT. The DBT+ will become unstable as soon as withDBT completes, so don't capture+ a reference to it in the enclosed computation. -}+withDBT :: ByteString -> (Ptr DBT -> IO a) -> IO a+withDBT bs fn =+ useAsCStringLen bs $ \(dat,sz) ->+ alloca $ \bst -> do+ poke bst (DBT sz dat)+ fn bst++{- Using a Maybe String transparently as a CString. The CString+ will become unstable as soon as withMaybeString completes, so don't+ capture a reference to it in the enclosed computation. -}+withMaybeString :: Maybe String -> (CString -> IO a) -> IO a+withMaybeString Nothing action = action nullPtr+withMaybeString (Just s) action = withCAString s action++{- Permanently allocates a function pointer, but frees it if the enclosed+ operation fails. This is useful for ensuring that the function pointer+ survives until it can be successfully compiled into some structure+ which the user is obliged to manually destroy. -}+allocFunPtr :: IO (FunPtr a) -> (FunPtr a -> IO b) -> IO b+allocFunPtr makeFun action = do+ bracketOnError makeFun freeHaskellFunPtr action++{- A helper routine to convert a list of boolean/mask pairs into a mask. -}+toFlags :: [(Bool,CULong)] -> CULong+toFlags = foldr (\(bool,mask) -> if bool then (mask .&.) else id) 0++{- Converts an IOMode constant into the appropriate bitmask. -}++fromIOMode :: IOMode -> CInt+fromIOMode ReadMode = 0+{-# LINE 239 "Database/BerkeleyDB.hsc" #-}+fromIOMode WriteMode = 1538+{-# LINE 240 "Database/BerkeleyDB.hsc" #-}+fromIOMode AppendMode = 514+{-# LINE 241 "Database/BerkeleyDB.hsc" #-}+fromIOMode ReadWriteMode = 514+{-# LINE 242 "Database/BerkeleyDB.hsc" #-}++{- The standard database cursor. The second parameter is whether safe or+ unsafe routines must be used. -}+data Cursor = Cursor (Ptr DBStruct) Bool+instance DBCursor Cursor ByteString ByteString where+ jump (Cursor ptr sf) key = _cursorKeyed sf ptr key 1+{-# LINE 248 "Database/BerkeleyDB.hsc" #-}+ jumpFirst (Cursor ptr sf) = _cursorUnkeyed sf ptr 3+{-# LINE 249 "Database/BerkeleyDB.hsc" #-}+ jumpLast (Cursor ptr sf) = _cursorUnkeyed sf ptr 6+{-# LINE 250 "Database/BerkeleyDB.hsc" #-}+ next (Cursor ptr sf) = _cursorUnkeyed sf ptr 7+{-# LINE 251 "Database/BerkeleyDB.hsc" #-}+ previous (Cursor ptr sf) = _cursorUnkeyed sf ptr 9+{-# LINE 252 "Database/BerkeleyDB.hsc" #-}+ replace (Cursor ptr sf) key val = _insert sf ptr key val 10+{-# LINE 253 "Database/BerkeleyDB.hsc" #-}+ remove (Cursor ptr sf) = _deleteCursor sf ptr+ closeCursor _ = return ()++{- Create a new standard cursor. -}+newCursor :: Ptr DBStruct -> Bool -> IO Cursor+newCursor ptr sf = return $ Cursor ptr sf++------- HASHTABLES --------++{-| Hashtable-based databases. -}+data HashDB = HashDB (Ptr DBStruct) Bool HashToken+instance DB HashDB HashDBCursor ByteString ByteString where+ open file mode = openHash file mode defaultUmask defaultHashDBConf+ close (HashDB ptr sf t) = do+ freeHashToken t+ _close ptr+ insert (HashDB ptr sf _) key value = _insert sf ptr key value 0+ lookup (HashDB ptr sf _) key = _lookup sf ptr key+ delete (HashDB ptr sf _) key = _delete sf ptr key+ cursor (HashDB ptr sf _) = liftM HashDBCursor $ newCursor ptr sf+ sync (HashDB ptr sf _) = _sync ptr++{-| The type of hashtable database cursors. -}+newtype HashDBCursor = HashDBCursor Cursor+instance DBCursor HashDBCursor ByteString ByteString where+ jump (HashDBCursor c) = jump c+ jumpFirst (HashDBCursor c) = jumpFirst c+ jumpLast (HashDBCursor c) = jumpLast c+ next (HashDBCursor c) = next c+ previous (HashDBCursor c) = previous c+ replace (HashDBCursor c) = replace c+ remove (HashDBCursor c) = remove c+ closeCursor (HashDBCursor c) = closeCursor c++{-| The configuration of a hashtable database. -}+data HashDBConf = HashDBConf {++ {-| The size of a hash bucket, in bytes. -}+ hash_bucketSize :: Int,++ {-| A desired density for the hashtable. This value approximates the+ maximum number of keys allowed in a bucket; the default value is 8. -}+ hash_keyDensity :: Int,++ {-| The initial size of the database. The hashtable will grow gracefully + as keys are added, but performance may temporarily suffer at each+ expansion, so it's always better to get this right. -}+ hash_initialSize :: Int,++ {-| An advistory maximum size for the in-memory database cache. -}+ hash_cacheSize :: Int,++ {-| The byte order of hashtable metadata; for example, 4321 specifies a+ big-endian format. Not all byte orders are necessarily supported, and+ this setting is ignored when opening existing databases. 0 means to use+ host order. -}+ hash_byteOrder :: Int,++ {-| A custom hash function. Specifying a custom hash function can+ sometimes improve hashtable performance, depending on the expected+ range of keys; however, since it requires a callback into Haskell, it+ can also hurt performance by requiring "safe" calls into C (which forces+ the runtime system to stabilize itself before every database call). -}+ hash_hashFunction :: Maybe (ByteString -> Word32)+}++{-| The default database configuration. -}+defaultHashDBConf :: HashDBConf+defaultHashDBConf = HashDBConf {+ hash_bucketSize = 0,+ hash_keyDensity = 0,+ hash_initialSize = 0,+ hash_cacheSize = 0,+ hash_byteOrder = 0,+ hash_hashFunction = Nothing+}++{-| Opens or creates a hashtable database. -}+openHash :: Maybe FilePath -> IOMode -> FileMode -> HashDBConf -> IO HashDB+openHash path iomode umask conf = + withMaybeString path $ \cpath ->+ alloca $ \info ->+ allocFunPtr (makeHash $ hash_hashFunction conf) $ \fpHash -> do+ writeHashDBConf conf fpHash info+ ptr <- throwErrnoIfNull "BerkeleyDB.openHash"+ $ db_open_hash cpath (fromIOMode iomode) umask info+ let safe = fpHash /= nullFunPtr+ return $ HashDB ptr safe fpHash++{- Tokens are created during database initialization and must be manually+ freed during database teardown. -}+type HashToken = FunPtr (CString -> CSize -> Word32)+freeHashToken :: HashToken -> IO ()+freeHashToken fpHash = do+ when (fpHash /= nullFunPtr) $ freeHaskellFunPtr fpHash++{- Writes a hashtable configuration into the corresponding C structure.+ We pass in the function pointer from elsewhere because it+ aids emergency cleanup to do so. -}+writeHashDBConf :: HashDBConf+ -> FunPtr (CString -> CSize -> Word32)+ -> Ptr HASHINFO+ -> IO ()+writeHashDBConf conf fpHash info = do+ poke info $ HASHINFO {+ hi_bsize = toEnum $ hash_bucketSize conf,+ hi_ffactor = toEnum $ hash_keyDensity conf,+ hi_nelem = toEnum $ hash_initialSize conf,+ hi_cachesize = toEnum $ hash_cacheSize conf,+ hi_lorder = toEnum $ hash_byteOrder conf,+ hi_hash = fpHash+ }++{- Turns a Haskell hash function into a database-appropriate foreign hash+ function. -}+makeHash :: Maybe (ByteString -> Word32) -> IO (FunPtr (CString -> CSize -> Word32))+makeHash Nothing = return nullFunPtr+makeHash (Just h) = wrapHash $ wrap h+ where wrap hash dat sz = hash $ packCStringLen (dat, fromEnum sz)++{-+ typedef struct {+ u_int bsize;+ u_int ffactor;+ u_int nelem;+ u_int cachesize;+ u_int32_t (*hash)(const void *, size_t);+ int lorder;+ } HASHINFO;+-}+data HASHINFO = HASHINFO {+ hi_bsize, hi_ffactor, hi_nelem, hi_cachesize :: CUInt,+ hi_hash :: FunPtr (CString -> CSize -> Word32),+ hi_lorder :: CInt+}+instance Storable HASHINFO where+ sizeOf _ = (24)+{-# LINE 390 "Database/BerkeleyDB.hsc" #-}+ alignment _ = 4+{-# LINE 391 "Database/BerkeleyDB.hsc" #-}+ poke ptr info = do+ (\hsc_ptr -> pokeByteOff hsc_ptr 0) ptr (hi_bsize info)+{-# LINE 393 "Database/BerkeleyDB.hsc" #-}+ (\hsc_ptr -> pokeByteOff hsc_ptr 4) ptr (hi_ffactor info)+{-# LINE 394 "Database/BerkeleyDB.hsc" #-}+ (\hsc_ptr -> pokeByteOff hsc_ptr 8) ptr (hi_nelem info)+{-# LINE 395 "Database/BerkeleyDB.hsc" #-}+ (\hsc_ptr -> pokeByteOff hsc_ptr 12) ptr (hi_cachesize info)+{-# LINE 396 "Database/BerkeleyDB.hsc" #-}+ (\hsc_ptr -> pokeByteOff hsc_ptr 20) ptr (hi_lorder info)+{-# LINE 397 "Database/BerkeleyDB.hsc" #-}+ (\hsc_ptr -> pokeByteOff hsc_ptr 16) ptr (hi_hash info)+{-# LINE 398 "Database/BerkeleyDB.hsc" #-}+ peek ptr = do+ bsize <- (\hsc_ptr -> peekByteOff hsc_ptr 0) ptr+{-# LINE 400 "Database/BerkeleyDB.hsc" #-}+ ffactor <- (\hsc_ptr -> peekByteOff hsc_ptr 4) ptr+{-# LINE 401 "Database/BerkeleyDB.hsc" #-}+ nelem <- (\hsc_ptr -> peekByteOff hsc_ptr 8) ptr+{-# LINE 402 "Database/BerkeleyDB.hsc" #-}+ cachesize <- (\hsc_ptr -> peekByteOff hsc_ptr 12) ptr+{-# LINE 403 "Database/BerkeleyDB.hsc" #-}+ hash <- (\hsc_ptr -> peekByteOff hsc_ptr 16) ptr+{-# LINE 404 "Database/BerkeleyDB.hsc" #-}+ lorder <- (\hsc_ptr -> peekByteOff hsc_ptr 20) ptr+{-# LINE 405 "Database/BerkeleyDB.hsc" #-}+ return $ HASHINFO { hi_bsize = bsize, hi_ffactor = ffactor,+ hi_nelem = nelem, hi_cachesize = cachesize,+ hi_hash = hash, hi_lorder = lorder }++------- B-TREE DATABASES ---------++{-| A database built on a b-tree. -}+data TreeDB = TreeDB (Ptr DBStruct) Bool TreeToken+instance DB TreeDB TreeDBCursor ByteString ByteString where+ open file mode = openTree file mode defaultUmask defaultTreeDBConf+ close (TreeDB ptr sf t) = do+ freeTreeToken t+ _close ptr+ insert (TreeDB ptr sf _) key value = _insert sf ptr key value 0+ lookup (TreeDB ptr sf _) key = _lookup sf ptr key+ delete (TreeDB ptr sf _) key = _delete sf ptr key+ sync (TreeDB ptr sf _) = _sync ptr+ cursor (TreeDB ptr sf _) = liftM TreeDBCursor (newCursor ptr sf)++{-| The cursor for a tree database. -}+newtype TreeDBCursor = TreeDBCursor Cursor+instance DBCursor TreeDBCursor ByteString ByteString where+ jump (TreeDBCursor c) = jump c+ jumpFirst (TreeDBCursor c) = jumpFirst c+ jumpLast (TreeDBCursor c) = jumpLast c+ next (TreeDBCursor c) = next c+ previous (TreeDBCursor c) = previous c+ replace (TreeDBCursor c) = replace c+ remove (TreeDBCursor c) = remove c+ closeCursor (TreeDBCursor c) = closeCursor c++{-| The configuration for a b-tree database. -}+data TreeDBConf = TreeDBConf {++ {-| Permit multiple entries to appear in the database per key. Only+ sequential operations can observe the difference. -}+ tree_duplicateKeys :: Bool,++ {-| An advistory maximum size of the in-memory database cache, in+ bytes. A default cache size is used if this value is 0. -}+ tree_cacheSize :: Int,++ {-| An advisory maximum number of keys to store on a page. btree(3)+ says this isn't implemented. -}+ tree_maxKeysPerPage :: Int,++ {-| The minimum number of keys to store on a page (other than the+ root). This can never been less than 2. -}+ tree_minKeysPerPage :: Int,++ {-| The size of each pages of the btree, in bytes. This much be at+ least 512 and no more than 64K; if it is zero, a default size is+ chosen based on the filesystem block size. This value is ignored+ when opening existing databases. -}+ tree_pageSize :: Int,++ {-| The byte order of btree metadata; for example, 4321 specifies a+ big-endian format. Not all byte orders are necessarily supported,+ and this setting is ignored when opening existing databases. 0 means+ to use host order. -}+ tree_byteOrder :: Int,++ {-| A comparison function for keys. It is important that the same function+ be used every time the tree is opened. The default comparison order is+ lexicographic (i.e. shorter keys sort first, then each byte is compared+ from the beginning to the end). -}+ tree_compare :: Maybe (ByteString -> ByteString -> Ordering),++ {-| A function indicating how many bytes are required from the second key+ argument in order to decide the ordering. If the keys are equal, this+ should be the length of the key. This can produce highly-compressed trees+ in certain domains. -}+ tree_prefix :: Maybe (ByteString -> ByteString -> Int)+}++{-| The default b-tree configuration. -}+defaultTreeDBConf :: TreeDBConf+defaultTreeDBConf = TreeDBConf {+ tree_duplicateKeys = False, -- disallow duplicate keys+ tree_cacheSize = 0, -- use default cache size+ tree_maxKeysPerPage = 0, -- evidentally, not implemented yet anyway in Berkeley DB+ tree_minKeysPerPage = 0, -- use the default minimum number of keys per page+ tree_pageSize = 0, -- use the default page size+ tree_compare = Nothing, -- no custom comparison operation+ tree_prefix = Nothing, -- no custom prefix operation+ tree_byteOrder = 0 -- host order+}++{-| Opens a b-tree database, failing with an I\/O exception if the database+ couldn't be opened. -}+openTree :: Maybe FilePath -> IOMode -> FileMode -> TreeDBConf -> IO TreeDB+openTree path iomode filemode conf =+ alloca $ \info ->+ withMaybeString path $ \cpath ->+ allocFunPtr (makeCompare $ tree_compare conf) $ \fpCompare ->+ allocFunPtr (makePrefix $ tree_prefix conf) $ \fpPrefix -> do+ writeTreeDBConf conf fpCompare fpPrefix info+ ptr <- throwErrnoIfNull "BerkeleyDB.openTree"+ $ db_open_btree cpath (fromIOMode iomode) filemode info+ let safe = fpCompare /= nullFunPtr || fpPrefix /= nullFunPtr+ return $ TreeDB ptr safe (fpCompare,fpPrefix)++{- The token which must be explicitly freed when a database is shut down.+ Here, it's a pointer to the two foreign function pointers. -}+type TreeToken = (FunPtr (Ptr DBT -> Ptr DBT -> CInt),+ FunPtr (Ptr DBT -> Ptr DBT -> CSize))+freeTreeToken :: TreeToken -> IO ()+freeTreeToken (fpCompare, fpPrefix) = do+ when (fpCompare /= nullFunPtr) $ freeHaskellFunPtr fpCompare+ when (fpPrefix /= nullFunPtr) $ freeHaskellFunPtr fpPrefix++{- Writes a b-tree database configuration into a C structure.+ We pass in the function pointers from elsewhere because it+ aids emergency cleanup to do so. -}+writeTreeDBConf :: TreeDBConf+ -> FunPtr (Ptr DBT -> Ptr DBT -> CInt)+ -> FunPtr (Ptr DBT -> Ptr DBT -> CSize)+ -> Ptr BTREEINFO+ -> IO ()+writeTreeDBConf conf fpCompare fpPrefix info = do+ poke info $ BTREEINFO {+ bi_flags = toFlags [(tree_duplicateKeys conf, 1)],+{-# LINE 527 "Database/BerkeleyDB.hsc" #-}+ bi_cachesize = toEnum $ tree_cacheSize conf,+ bi_maxkeypage = toEnum $ tree_maxKeysPerPage conf,+ bi_minkeypage = toEnum $ tree_minKeysPerPage conf,+ bi_psize = toEnum $ tree_pageSize conf,+ bi_compare = fpCompare,+ bi_prefix = fpPrefix,+ bi_lorder = toEnum $ tree_byteOrder conf+ }++{- Wraps a Haskell comparison function as a pointer to a C function. -}+makeCompare :: Maybe (ByteString -> ByteString -> Ordering) -> IO (FunPtr (Ptr DBT -> Ptr DBT -> CInt))+makeCompare Nothing = return nullFunPtr+makeCompare (Just f) = wrapCompare wrap+ where wrap a b =+ case f (wrapDBT a) (wrapDBT b) of+ LT -> -1+ EQ -> 0+ GT -> 1++{- Wraps a Haskell prefix function as a pointer to a C function. -}+makePrefix :: Maybe (ByteString -> ByteString -> Int) -> IO (FunPtr (Ptr DBT -> Ptr DBT -> CSize))+makePrefix Nothing = return nullFunPtr+makePrefix (Just f) = wrapPrefix (wrap f)+ where wrap f a b = toEnum $ f (wrapDBT a) (wrapDBT b)++{-+ typedef struct {+ u_long flags;+ u_int cachesize;+ int maxkeypage;+ int minkeypage;+ u_int psize;+ int (*compare)(const DBT *key1, const DBT *key2);+ size_t (*prefix)(const DBT *key1, const DBT *key2);+ int lorder;+ } BTREEINFO;+-}++data BTREEINFO = BTREEINFO {+ bi_flags :: CULong,+ bi_cachesize, bi_psize :: CUInt,+ bi_maxkeypage, bi_minkeypage, bi_lorder :: CInt,+ bi_compare :: FunPtr (Ptr DBT -> Ptr DBT -> CInt),+ bi_prefix :: FunPtr (Ptr DBT -> Ptr DBT -> CSize)+}+instance Storable BTREEINFO where+ sizeOf _ = (32)+{-# LINE 574 "Database/BerkeleyDB.hsc" #-}+ alignment _ = 4+{-# LINE 575 "Database/BerkeleyDB.hsc" #-}+ peek ptr = do+ flags <- (\hsc_ptr -> peekByteOff hsc_ptr 0) ptr+{-# LINE 577 "Database/BerkeleyDB.hsc" #-}+ cachesize <- (\hsc_ptr -> peekByteOff hsc_ptr 4) ptr+{-# LINE 578 "Database/BerkeleyDB.hsc" #-}+ maxkeypage <- (\hsc_ptr -> peekByteOff hsc_ptr 8) ptr+{-# LINE 579 "Database/BerkeleyDB.hsc" #-}+ minkeypage <- (\hsc_ptr -> peekByteOff hsc_ptr 12) ptr+{-# LINE 580 "Database/BerkeleyDB.hsc" #-}+ psize <- (\hsc_ptr -> peekByteOff hsc_ptr 16) ptr+{-# LINE 581 "Database/BerkeleyDB.hsc" #-}+ lorder <- (\hsc_ptr -> peekByteOff hsc_ptr 28) ptr+{-# LINE 582 "Database/BerkeleyDB.hsc" #-}+ compare <- (\hsc_ptr -> peekByteOff hsc_ptr 20) ptr+{-# LINE 583 "Database/BerkeleyDB.hsc" #-}+ prefix <- (\hsc_ptr -> peekByteOff hsc_ptr 24) ptr+{-# LINE 584 "Database/BerkeleyDB.hsc" #-}+ return $ BTREEINFO { bi_flags = flags, bi_cachesize = cachesize,+ bi_maxkeypage = maxkeypage, bi_minkeypage = minkeypage,+ bi_psize = psize, bi_lorder = lorder,+ bi_compare = compare, bi_prefix = prefix }+ poke ptr info = do+ (\hsc_ptr -> pokeByteOff hsc_ptr 0) ptr (bi_flags info)+{-# LINE 590 "Database/BerkeleyDB.hsc" #-}+ (\hsc_ptr -> pokeByteOff hsc_ptr 4) ptr (bi_cachesize info)+{-# LINE 591 "Database/BerkeleyDB.hsc" #-}+ (\hsc_ptr -> pokeByteOff hsc_ptr 8) ptr (bi_maxkeypage info)+{-# LINE 592 "Database/BerkeleyDB.hsc" #-}+ (\hsc_ptr -> pokeByteOff hsc_ptr 12) ptr (bi_minkeypage info)+{-# LINE 593 "Database/BerkeleyDB.hsc" #-}+ (\hsc_ptr -> pokeByteOff hsc_ptr 16) ptr (bi_psize info)+{-# LINE 594 "Database/BerkeleyDB.hsc" #-}+ (\hsc_ptr -> pokeByteOff hsc_ptr 20) ptr (bi_compare info)+{-# LINE 595 "Database/BerkeleyDB.hsc" #-}+ (\hsc_ptr -> pokeByteOff hsc_ptr 24) ptr (bi_prefix info)+{-# LINE 596 "Database/BerkeleyDB.hsc" #-}+ (\hsc_ptr -> pokeByteOff hsc_ptr 28) ptr (bi_lorder info)+{-# LINE 597 "Database/BerkeleyDB.hsc" #-}++------- RECORD DATABASES --------++{-| recno_t, the type of record indices. recno(3) says this is "normally+ the largest unsigned integral type available to the implementation", but on+ modern systems it's usually just uint32_t. -}+newtype Record = Record Recno+ deriving (Bits,Bounded,Enum,Eq,Integral,Num,+ Ord,Read,Real,Show,Storable)+type Recno = Word32+{-# LINE 607 "Database/BerkeleyDB.hsc" #-}++{- The type of record cursors. -}+newtype RecCursor = RecCursor (Ptr DBStruct)++-- Haddock wants to publicize this because it mentions Record, but I+-- don't really want to preprocess before running Haddock, because CPP+-- will throw all the HSC stuff in my face. Really, Haddock needs to+-- recognize that this instance is functionally defined by a private+-- type and therefore not expose it.+instance DBCursor RecCursor Record ByteString where+ jump (RecCursor ptr) (Record key) = _cursorRecord ptr key 1+{-# LINE 618 "Database/BerkeleyDB.hsc" #-}+ jumpFirst (RecCursor ptr) = _cursorRecord ptr 0 3+{-# LINE 619 "Database/BerkeleyDB.hsc" #-}+ jumpLast (RecCursor ptr) = _cursorRecord ptr 0 6+{-# LINE 620 "Database/BerkeleyDB.hsc" #-}+ next (RecCursor ptr) = _cursorRecord ptr 0 7+{-# LINE 621 "Database/BerkeleyDB.hsc" #-}+ previous (RecCursor ptr) = _cursorRecord ptr 0 9+{-# LINE 622 "Database/BerkeleyDB.hsc" #-}+ replace (RecCursor ptr) (Record key) val = _insertRecord ptr key val 10+{-# LINE 623 "Database/BerkeleyDB.hsc" #-}+ remove (RecCursor ptr) = _deleteCursor False ptr -- never needs to be safe+ closeCursor _ = return ()++newRecCursor :: Ptr DBStruct -> IO RecCursor+newRecCursor ptr = return $ RecCursor ptr++{-| Variable-length record databases. -}+newtype RecordDB = RecordDB (Ptr DBStruct)+instance DB RecordDB RecordDBCursor Record ByteString where+ open file mode = openRecord file mode defaultUmask defaultRecordDBConf+ close (RecordDB ptr) = _close ptr+ insert (RecordDB ptr) (Record key) value = _insertRecord ptr key value 0+ lookup (RecordDB ptr) (Record key) = _lookupRecord ptr key+ delete (RecordDB ptr) (Record key) = _deleteRecord ptr key+ cursor (RecordDB ptr) = liftM RecordDBCursor $ newRecCursor ptr+ sync (RecordDB ptr) = _sync ptr++{-| The type of variable-length record database cursors. The key returned by+ cursor procedures is always 0. -}+newtype RecordDBCursor = RecordDBCursor RecCursor+instance DBCursor RecordDBCursor Record ByteString where+ jump (RecordDBCursor c) = jump c+ jumpFirst (RecordDBCursor c) = jumpFirst c+ jumpLast (RecordDBCursor c) = jumpLast c+ next (RecordDBCursor c) = next c+ previous (RecordDBCursor c) = previous c+ replace (RecordDBCursor c) = replace c+ remove (RecordDBCursor c) = remove c+ closeCursor (RecordDBCursor c) = closeCursor c++{-| A configuration for variable-length record databases. -}+data RecordDBConf = RecordDBConf {+ {-| Forces a snapshot of the database to be taken when the file+ is opened. -}+ record_snapshot :: Bool,++ {-| An advisory maximum size of the in-memory database cache. -}+ record_cacheSize :: Int,++ {-| The page size used for the in-memory database cache, which happens+ to be a b-tree. If this value is 0, a default size will be chosen. -}+ record_pageSize :: Int,++ {-| The byte order for integers in the database metadata; for example,+ 4321 represents big-endian order. Not all orders are guaranteed to+ be supported; if the byte order is 0, host order will be used.+ Unlike the other database types, record databases have no metadata,+ so it's important to get this right when opening existing+ databases. -}+ record_byteOrder :: Int,++ {-| The byte value used to separate records in the database. By default,+ this is a newline character (0x0A). -}+ record_separatorByte :: Word8,++ {-| A file which should be used to store the the in-memory record cache. -}+ record_treeFile :: Maybe String+}++{-| The default variable-length record database configuration. -}+defaultRecordDBConf :: RecordDBConf+defaultRecordDBConf = RecordDBConf {+-- record_noKey = False,+ record_snapshot = False,+ record_cacheSize = 0,+ record_pageSize = 0,+ record_byteOrder = 0,+ record_separatorByte = 0x0a,+ record_treeFile = Nothing+}++{-| Opens a variable-length record database. -}+openRecord :: Maybe FilePath -> IOMode -> FileMode -> RecordDBConf -> IO RecordDB+openRecord path iomode filemode conf =+ withMaybeString path $ \cpath ->+ withMaybeString (record_treeFile conf) $ \ctreefile ->+ alloca $ \info -> do+ writeRecordDBConf conf ctreefile info+ ptr <- throwErrnoIfNull "BerkeleyDB.openRecord"+ $ db_open_recno cpath (fromIOMode iomode) filemode info+ return $ RecordDB ptr++{- Writes a variable-length record database configuration into a C structure.+ We pass in the btree filename string from elsewhere because it aids+ emergency cleanup to do so. -}+writeRecordDBConf :: RecordDBConf -> CString -> Ptr RECNOINFO -> IO ()+writeRecordDBConf conf bfname info = do+ poke info $ RECNOINFO {+ ri_flags = toFlags [(False, 1),+{-# LINE 712 "Database/BerkeleyDB.hsc" #-}+ (True, 2),+{-# LINE 713 "Database/BerkeleyDB.hsc" #-}+ (record_snapshot conf, 4)],+{-# LINE 714 "Database/BerkeleyDB.hsc" #-}+ ri_cachesize = toEnum $ record_cacheSize conf,+ ri_psize = toEnum $ record_pageSize conf,+ ri_lorder = toEnum $ record_byteOrder conf,+ ri_reclen = 0,+ ri_bval = fromInteger $ toInteger $ record_separatorByte conf,+ ri_bfname = bfname+ }++{-| Fixed-length record databases. -}+newtype FixedRecordDB = FixedRecordDB (Ptr DBStruct)+instance DB FixedRecordDB FixedRecordDBCursor Record ByteString where+ open file mode = openFixedRecord file mode defaultUmask defaultFixedRecordDBConf+ close (FixedRecordDB ptr) = _close ptr+ insert (FixedRecordDB ptr) (Record key) value = _insertRecord ptr key value 0+ lookup (FixedRecordDB ptr) (Record key) = _lookupRecord ptr key+ delete (FixedRecordDB ptr) (Record key) = _deleteRecord ptr key+ cursor (FixedRecordDB ptr) = liftM FixedRecordDBCursor $ newRecCursor ptr+ sync (FixedRecordDB ptr) = _sync ptr++{-| The type of fixed-length record database cursors. The key returned by+ cursor procedures is always 0. -}+newtype FixedRecordDBCursor = FixedRecordDBCursor RecCursor+instance DBCursor FixedRecordDBCursor Record ByteString where+ jump (FixedRecordDBCursor c) = jump c+ jumpFirst (FixedRecordDBCursor c) = jumpFirst c+ jumpLast (FixedRecordDBCursor c) = jumpLast c+ next (FixedRecordDBCursor c) = next c+ previous (FixedRecordDBCursor c) = previous c+ replace (FixedRecordDBCursor c) = replace c+ remove (FixedRecordDBCursor c) = remove c+ closeCursor (FixedRecordDBCursor c) = closeCursor c++{-| A configuration for fixed-length record databases. -}+data FixedRecordDBConf = FixedRecordDBConf {+ {-| Forces a snapshot of the database to be taken when the file+ is opened. -}+ fixed_snapshot :: Bool,++ {-| An advisory maximum size of the in-memory database cache. -}+ fixed_cacheSize :: Int,++ {-| The page size used for the in-memory database cache, which happens+ to be a b-tree. If this value is 0, a default size will be chosen. -}+ fixed_pageSize :: Int,++ {-| The fixed length of the records. This must be manually overridden in+ the default configuration, or an exception will be thrown. -}+ fixed_recordLength :: Int,++ {-| The byte order for integers in the database metadata; for example,+ 4321 represents big-endian order. Not all orders are guaranteed to+ be supported; if the byte order is 0, host order will be used.+ Unlike the other database types, record databases have no metadata,+ so it's important to get this right when opening existing+ databases. -}+ fixed_byteOrder :: Int,++ {-| The byte value used to pad fixed-length records in the database.+ By default, this is a space character (0x20). -}+ fixed_paddingByte :: Word8,++ {-| A file which should be used to store the the in-memory record cache. -}+ fixed_treeFile :: Maybe String+}++{-| The default configuration for fixed-length record databases. -}+defaultFixedRecordDBConf :: FixedRecordDBConf+defaultFixedRecordDBConf = FixedRecordDBConf {+ fixed_snapshot = False,+ fixed_cacheSize = 0,+ fixed_pageSize = 0,+ fixed_recordLength = 0,+ fixed_byteOrder = 0,+ fixed_paddingByte = 0x20,+ fixed_treeFile = Nothing+}++{-| Opens or creates a fixed-length record database. -}+openFixedRecord :: Maybe FilePath -> IOMode -> FileMode -> FixedRecordDBConf -> IO FixedRecordDB+openFixedRecord path iomode filemode conf =+ if (fixed_recordLength conf <= 0) then fail "non-positive record length" else+ withMaybeString path $ \cpath ->+ withMaybeString (fixed_treeFile conf) $ \ctreefile ->+ alloca $ \info -> do+ writeFixedRecordDBConf conf ctreefile info+ ptr <- throwErrnoIfNull "BerkeleyDB.openFixedRecord"+ $ db_open_recno cpath (fromIOMode iomode) filemode info+ return $ FixedRecordDB ptr++{- Writes a fixed record database configuration into a C structure.+ We pass in the btree filename string from elsewhere because it aids+ emergency cleanup to do so. -}+writeFixedRecordDBConf :: FixedRecordDBConf -> CString -> Ptr RECNOINFO -> IO ()+writeFixedRecordDBConf conf bfname info = do+ poke info $ RECNOINFO {+ ri_flags = toFlags [(True, 1),+{-# LINE 810 "Database/BerkeleyDB.hsc" #-}+ (True, 2),+{-# LINE 811 "Database/BerkeleyDB.hsc" #-}+ (fixed_snapshot conf, 4)],+{-# LINE 812 "Database/BerkeleyDB.hsc" #-}+ ri_cachesize = toEnum $ fixed_cacheSize conf,+ ri_psize = toEnum $ fixed_pageSize conf,+ ri_lorder = toEnum $ fixed_byteOrder conf,+ ri_reclen = toEnum $ fixed_recordLength conf,+ ri_bval = fromInteger $ toInteger $ fixed_paddingByte conf,+ ri_bfname = bfname+ }++{-+ typedef struct {+ u_long flags;+ u_int cachesize;+ u_int psize;+ int lorder;+ size_t reclen;+ u_char bval;+ char *bfname;+ } RECNOINFO;+-}++data RECNOINFO = RECNOINFO {+ ri_flags :: CULong,+ ri_cachesize, ri_psize :: CUInt,+ ri_lorder :: CInt,+ ri_reclen :: CSize,+ ri_bval :: CUChar,+ ri_bfname :: CString+}+instance Storable RECNOINFO where+ sizeOf _ = (28)+{-# LINE 842 "Database/BerkeleyDB.hsc" #-}+ alignment _ = 4+{-# LINE 843 "Database/BerkeleyDB.hsc" #-}+ peek ptr = do+ flags <- (\hsc_ptr -> peekByteOff hsc_ptr 0) ptr+{-# LINE 845 "Database/BerkeleyDB.hsc" #-}+ cachesize <- (\hsc_ptr -> peekByteOff hsc_ptr 4) ptr+{-# LINE 846 "Database/BerkeleyDB.hsc" #-}+ psize <- (\hsc_ptr -> peekByteOff hsc_ptr 8) ptr+{-# LINE 847 "Database/BerkeleyDB.hsc" #-}+ lorder <- (\hsc_ptr -> peekByteOff hsc_ptr 12) ptr+{-# LINE 848 "Database/BerkeleyDB.hsc" #-}+ reclen <- (\hsc_ptr -> peekByteOff hsc_ptr 16) ptr+{-# LINE 849 "Database/BerkeleyDB.hsc" #-}+ bval <- (\hsc_ptr -> peekByteOff hsc_ptr 20) ptr+{-# LINE 850 "Database/BerkeleyDB.hsc" #-}+ bfname <- (\hsc_ptr -> peekByteOff hsc_ptr 24) ptr+{-# LINE 851 "Database/BerkeleyDB.hsc" #-}+ return $ RECNOINFO { ri_flags = flags, ri_cachesize = cachesize,+ ri_psize = psize, ri_lorder = lorder,+ ri_reclen = reclen, ri_bval = bval,+ ri_bfname = bfname }+ poke ptr info = do+ let pokeAt offset selector = poke (plusPtr ptr offset) (selector info)+ (\hsc_ptr -> pokeByteOff hsc_ptr 0) ptr (ri_flags info)+{-# LINE 858 "Database/BerkeleyDB.hsc" #-}+ (\hsc_ptr -> pokeByteOff hsc_ptr 4) ptr (ri_cachesize info)+{-# LINE 859 "Database/BerkeleyDB.hsc" #-}+ (\hsc_ptr -> pokeByteOff hsc_ptr 8) ptr (ri_psize info)+{-# LINE 860 "Database/BerkeleyDB.hsc" #-}+ (\hsc_ptr -> pokeByteOff hsc_ptr 12) ptr (ri_lorder info)+{-# LINE 861 "Database/BerkeleyDB.hsc" #-}+ (\hsc_ptr -> pokeByteOff hsc_ptr 16) ptr (ri_reclen info)+{-# LINE 862 "Database/BerkeleyDB.hsc" #-}+ (\hsc_ptr -> pokeByteOff hsc_ptr 20) ptr (ri_bval info)+{-# LINE 863 "Database/BerkeleyDB.hsc" #-}+ (\hsc_ptr -> pokeByteOff hsc_ptr 24) ptr (ri_bfname info)+{-# LINE 864 "Database/BerkeleyDB.hsc" #-}++------- PRIMITIVE OPERATIONS --------++{- Primitive close. -}+_close :: Ptr DBStruct -> IO ()+_close ptr = do+ throwErrnoIfMinus1_ "BerkeleyDB.close" $ db_close ptr++{- Primitive sync. -}+_sync :: Ptr DBStruct -> IO ()+_sync ptr = do+ throwErrnoIfMinus1_ "BerkeleyDB.sync" $ db_sync ptr++{- Primitive delete. The first parameter is true if the operation must+ use the safe foreign call. -}+_delete :: Bool -> Ptr DBStruct -> ByteString -> IO Bool+_delete sf ptr key =+ withDBT key $ \tKey -> do+ result <- throwErrnoIfMinus1 "BerkeleyDB.delete"+ $ (if sf then db_delete_sf else db_delete) ptr tKey+ case result of+ 0 -> return True+ _ -> return False++_deleteRecord :: Ptr DBStruct -> Recno -> IO Bool+_deleteRecord ptr key = do+ result <- throwErrnoIfMinus1 "BerkeleyDB.delete"+ $ db_delete_record ptr key+ case result of+ 0 -> return True+ _ -> return False++_deleteCursor :: Bool -> Ptr DBStruct -> IO ()+_deleteCursor sf ptr = do+ throwErrnoIfMinus1_ "BerkeleyDB.remove"+ $ (if sf then db_delete_cursor_sf else db_delete_cursor) ptr++{- Primitive insertion. The first parameter is true if the operation must+ use the safe foreign call. -}+_insert :: Bool -> Ptr DBStruct -> ByteString -> ByteString -> CUInt -> IO ()+_insert sf ptr key val flags =+ withDBT key $ \tKey ->+ withDBT val $ \tVal -> do+ throwErrnoIfMinus1_ "BerkeleyDB.insert"+ $ (if sf then db_insert_sf else db_insert) ptr tKey tVal flags++_insertRecord :: Ptr DBStruct -> Recno -> ByteString -> CUInt -> IO ()+_insertRecord ptr key val flags = + withDBT val $ \tVal -> do+ throwErrnoIfMinus1_ "BerkeleyDB.insert"+ $ db_insert_record ptr key tVal flags++{- Primitive lookup. The first parameter is true if the operation must use+ the safe foreign call. -}+_lookup :: Bool -> Ptr DBStruct -> ByteString -> IO (Maybe ByteString)+_lookup sf ptr key =+ withDBT key $ \tKey ->+ alloca $ \tVal -> do+ result <- throwErrnoIfMinus1 "BerkeleyDB.lookup"+ $ (if sf then db_lookup_sf else db_lookup) ptr tKey tVal+ case result of+ 0 -> liftM Just $ copyDBT tVal+ _ -> return Nothing++_lookupRecord :: Ptr DBStruct -> Recno -> IO (Maybe ByteString)+_lookupRecord ptr key = + alloca $ \tVal -> do+ result <- throwErrnoIfMinus1 "BerkeleyDB.lookup"+ $ db_lookup_record ptr key tVal+ case result of+ 0 -> liftM Just $ copyDBT tVal+ _ -> return Nothing++{- Primitive cursor. The first parameter is true if the operation must+ use the safe foreign call. -}++{- The 'keyed' version exposes a byte-string key to the database; the+ 'unkeyed' version passes a freshly-allocated pointer. The record routine+ doesn't need to be split like this because it doesn't require additional+ allocation. -}++_cursorKeyed sf ptr key flags = withDBT key (_cursor sf ptr flags)+_cursorUnkeyed sf ptr flags = alloca (_cursor sf ptr flags)++_cursor :: Bool -> Ptr DBStruct -> CUInt -> Ptr DBT -> IO (Maybe (ByteString,ByteString))+_cursor sf ptr flags tKey =+ alloca $ \tVal -> do+ result <- throwErrnoIfMinus1 "BerkeleyDB.cursor"+ $ (if sf then db_cursor_sf else db_cursor) ptr tKey tVal flags+ case result of+ 0 -> do+ retKey <- copyDBT tKey+ retVal <- copyDBT tVal+ return $ Just (retKey, retVal)+ _ -> return Nothing++_cursorRecord :: Ptr DBStruct -> Recno -> CUInt -> IO (Maybe (Record,ByteString))+_cursorRecord ptr rec flags = do+ alloca $ \tVal -> do+ result <- throwErrnoIfMinus1 "BerkeleyDB.cursor"+ $ db_cursor_record ptr rec tVal flags+ case result of+ 0 -> do+ retVal <- copyDBT tVal+ return $ Just (Record 0, retVal)+ _ -> return Nothing++{- Creation calls are all unsafe. -}++foreign import ccall unsafe "db_open_recno"+ db_open_recno :: CString -> CInt -> CMode -> Ptr RECNOINFO -> IO (Ptr DBStruct)++{-# LINE 980 "Database/BerkeleyDB.hsc" #-}++foreign import ccall unsafe "db_open_hash"+ db_open_hash :: CString -> CInt -> CMode -> Ptr HASHINFO -> IO (Ptr DBStruct)++{-# LINE 988 "Database/BerkeleyDB.hsc" #-}++foreign import ccall unsafe "db_open_btree"+ db_open_btree :: CString -> CInt -> CMode -> Ptr BTREEINFO -> IO (Ptr DBStruct)++{-# LINE 996 "Database/BerkeleyDB.hsc" #-}++{- Close and sync calls. Unsafe against reentry to Haskell. -}+foreign import ccall unsafe "db_close"+ db_close :: Ptr DBStruct -> IO CInt++{-# LINE 1005 "Database/BerkeleyDB.hsc" #-}++foreign import ccall unsafe "db_sync"+ db_sync :: Ptr DBStruct -> IO CInt++{-# LINE 1013 "Database/BerkeleyDB.hsc" #-}++{- Deletion family of calls. -}+{- delete-by-key, safe and unsafe. -}+foreign import ccall unsafe "db_delete"+ db_delete :: Ptr DBStruct -> Ptr DBT -> IO CInt+foreign import ccall safe "db_delete"+ db_delete_sf :: Ptr DBStruct -> Ptr DBT -> IO CInt++{-# LINE 1025 "Database/BerkeleyDB.hsc" #-}++{- delete-record, always unsafe -}+foreign import ccall unsafe "db_delete_record"+ db_delete_record :: Ptr DBStruct -> Recno -> IO CInt++{-# LINE 1035 "Database/BerkeleyDB.hsc" #-}++{- delete-at-cursor, safe and unsafe -}+foreign import ccall unsafe "db_delete_cursor"+ db_delete_cursor :: Ptr DBStruct -> IO CInt+foreign import ccall safe "db_delete_cursor"+ db_delete_cursor_sf :: Ptr DBStruct -> IO CInt++{-# LINE 1046 "Database/BerkeleyDB.hsc" #-}++{- Lookup family of calls. -}+{- lookup-by-key, safe and unsafe -}+foreign import ccall unsafe "db_lookup"+ db_lookup :: Ptr DBStruct -> Ptr DBT -> Ptr DBT -> IO CInt+foreign import ccall safe "db_lookup"+ db_lookup_sf :: Ptr DBStruct -> Ptr DBT -> Ptr DBT -> IO CInt++{-# LINE 1058 "Database/BerkeleyDB.hsc" #-}++{- lookup-record, always unsafe -}+foreign import ccall unsafe "db_lookup_record"+ db_lookup_record :: Ptr DBStruct -> Recno -> Ptr DBT -> IO CInt++{-# LINE 1068 "Database/BerkeleyDB.hsc" #-}++{- Insert family of calls. -}+{- insert-by-key, safe and unsafe -}+foreign import ccall unsafe "db_c.h"+ db_insert :: Ptr DBStruct -> Ptr DBT -> Ptr DBT -> CUInt -> IO CInt+foreign import ccall safe "db_c.h db_insert"+ db_insert_sf :: Ptr DBStruct -> Ptr DBT -> Ptr DBT -> CUInt -> IO CInt++{-# LINE 1080 "Database/BerkeleyDB.hsc" #-}++{- insert-record, always unsafe -}+foreign import ccall unsafe "db_c.h"+ db_insert_record :: Ptr DBStruct -> Recno -> Ptr DBT -> CUInt -> IO CInt++{-# LINE 1090 "Database/BerkeleyDB.hsc" #-}++{- Sequence family of calls. -}+{- cursor-by-key, safe and unsafe -}+foreign import ccall unsafe "db_c.h"+ db_cursor :: Ptr DBStruct -> Ptr DBT -> Ptr DBT -> CUInt -> IO CInt+foreign import ccall safe "db_c.h db_cursor"+ db_cursor_sf :: Ptr DBStruct -> Ptr DBT -> Ptr DBT -> CUInt -> IO CInt++{-# LINE 1102 "Database/BerkeleyDB.hsc" #-}++{- cursor-record, always unsafe -}+foreign import ccall unsafe "db_c.h"+ db_cursor_record :: Ptr DBStruct -> Recno -> Ptr DBT -> CUInt -> IO CInt++{- Wrapper-creation functions for callbacks. -}+foreign import ccall unsafe "wrapper"+ wrapHash :: (CString -> CSize -> Word32) -> IO (FunPtr (CString -> CSize -> Word32))+foreign import ccall unsafe "wrapper"+ wrapCompare :: (Ptr DBT -> Ptr DBT -> CInt) -> IO (FunPtr (Ptr DBT -> Ptr DBT -> CInt))+foreign import ccall unsafe "wrapper"+ wrapPrefix :: (Ptr DBT -> Ptr DBT -> CSize) -> IO (FunPtr (Ptr DBT -> Ptr DBT -> CSize))
Database/BerkeleyDB.hsc view
@@ -1,5 +1,5 @@ {-- Database.BerkeleyDB v0.2+ Database.BerkeleyDB v0.3 Copyright 2007 John McCall Licensed for general use under a BSD3-style license; for the exact license text, see the LICENSE file included in this distribution. If@@ -77,7 +77,8 @@ import Foreign.C import Control.Monad (when, liftM) import Control.Exception (bracketOnError)-import Data.ByteString (ByteString, packCStringLen, copyCStringLen, useAsCStringLen)+import Data.ByteString (ByteString, packCStringLen, useAsCStringLen)+import Data.ByteString.Unsafe (unsafePackCStringLen) import Prelude hiding (lookup) {- We use 0666 as our default umask, but we define it in this crazy way. -}@@ -190,7 +191,7 @@ copyDBT :: Ptr DBT -> IO ByteString copyDBT ptr = do DBT sz dat <- peek ptr- copyCStringLen (dat, sz)+ packCStringLen (dat, sz) {- Temporarily wraps a DBT in a ByteString. ByteStrings created this way should never become visible out of this module --- the database doesn't@@ -201,7 +202,7 @@ wrapDBT :: Ptr DBT -> ByteString wrapDBT ptr = unsafePerformIO $ do DBT sz dat <- peek ptr- return $ packCStringLen (dat, sz)+ unsafePackCStringLen (dat, sz) {- Use a ByteString transparently as a DBT. The DBT will become unstable as soon as withDBT completes, so don't capture@@ -341,7 +342,7 @@ {- Tokens are created during database initialization and must be manually freed during database teardown. -}-type HashToken = FunPtr (CString -> CSize -> Word32)+type HashToken = FunPtr (CString -> CSize -> IO Word32) freeHashToken :: HashToken -> IO () freeHashToken fpHash = do when (fpHash /= nullFunPtr) $ freeHaskellFunPtr fpHash@@ -350,7 +351,7 @@ We pass in the function pointer from elsewhere because it aids emergency cleanup to do so. -} writeHashDBConf :: HashDBConf- -> FunPtr (CString -> CSize -> Word32)+ -> FunPtr (CString -> CSize -> IO Word32) -> Ptr HASHINFO -> IO () writeHashDBConf conf fpHash info = do@@ -365,10 +366,10 @@ {- Turns a Haskell hash function into a database-appropriate foreign hash function. -}-makeHash :: Maybe (ByteString -> Word32) -> IO (FunPtr (CString -> CSize -> Word32))+makeHash :: Maybe (ByteString -> Word32) -> IO (FunPtr (CString -> CSize -> IO Word32)) makeHash Nothing = return nullFunPtr-makeHash (Just h) = wrapHash $ wrap h- where wrap hash dat sz = hash $ packCStringLen (dat, fromEnum sz)+makeHash (Just hash) = wrapHash hash'+ where hash' dat sz = unsafePackCStringLen (dat, fromEnum sz) >>= return . hash {- typedef struct {@@ -382,7 +383,7 @@ -} data HASHINFO = HASHINFO { hi_bsize, hi_ffactor, hi_nelem, hi_cachesize :: CUInt,- hi_hash :: FunPtr (CString -> CSize -> Word32),+ hi_hash :: FunPtr (CString -> CSize -> IO Word32), hi_lorder :: CInt } instance Storable HASHINFO where@@ -1106,7 +1107,7 @@ {- Wrapper-creation functions for callbacks. -} foreign import ccall unsafe "wrapper"- wrapHash :: (CString -> CSize -> Word32) -> IO (FunPtr (CString -> CSize -> Word32))+ wrapHash :: (CString -> CSize -> IO Word32) -> IO (FunPtr (CString -> CSize -> IO Word32)) foreign import ccall unsafe "wrapper" wrapCompare :: (Ptr DBT -> Ptr DBT -> CInt) -> IO (FunPtr (Ptr DBT -> Ptr DBT -> CInt)) foreign import ccall unsafe "wrapper"