[Pkg-haskell-commits] [SCM] haskell-testpack branch, master, updated. debian/1.0.2-1-4-gb0d6b36
John Goerzen
jgoerzen at complete.org
Fri Apr 23 15:05:40 UTC 2010
The following commit has been merged in the master branch:
commit 1e96db4bf85dc1cb13755efb81678853dbe05338
Author: John Goerzen <jgoerzen at complete.org>
Date: Tue Dec 27 04:12:05 2005 +0100
Add some locking to StringDBM for thread-safety
diff --git a/MissingH/AnyDBM/StringDBM.hs b/MissingH/AnyDBM/StringDBM.hs
index 620fb07..e2f8348 100644
--- a/MissingH/AnyDBM/StringDBM.hs
+++ b/MissingH/AnyDBM/StringDBM.hs
@@ -45,9 +45,10 @@ import System.IO
import MissingH.IO.HVFS
import MissingH.IO.HVIO
import Data.HashTable
+import Control.Concurrent.MVar
{- | The type of the StringDBM instances. -}
-data StringDBM = forall a. HVFSOpenable a => StringDBM (HashTable String String) IOMode a FilePath
+data StringDBM = forall a. HVFSOpenable a => StringDBM (MVar ()) (HashTable String String) IOMode a FilePath
{- | Opens a 'StringDBM' file. Please note: only ReadMode, WriteMode,
and ReadWriteMode are supported for the IOMode. AppendMode is not supported.
@@ -67,26 +68,29 @@ openStringVDBM :: HVFSOpenable a => a -> FilePath -> IOMode -> IO StringDBM
openStringVDBM _ _ AppendMode = fail "openStringDBM: AppendMode is not supported"
openStringVDBM h fp ReadMode =
do ht <- new (==) hashString
+ lock <- newMVar ()
vReadFile h fp >>= strToA ht
- return $ StringDBM ht ReadMode h fp
+ return $ StringDBM lock ht ReadMode h fp
openStringVDBM h fp WriteMode =
do ht <- new (==) hashString
- return $ StringDBM ht WriteMode h fp
+ lock <- newMVar ()
+ return $ StringDBM lock ht WriteMode h fp
openStringVDBM h fp ReadWriteMode =
-- Nothing different to start with. Later, we emulate WriteMode.
-- Nothing is ever read after the object is created.
do ht <- new (==) hashString
+ lock <- newMVar ()
d <- vDoesFileExist h fp
if d
then vReadFile h fp >>= strToA ht
else return ()
- return $ StringDBM ht WriteMode h fp
+ return $ StringDBM lock ht WriteMode h fp
g :: StringDBM -> HashTable String String
-g (StringDBM ht _ _ _) = ht
+g (StringDBM _ ht _ _ _) = ht
instance AnyDBM StringDBM where
- flushA (StringDBM ht WriteMode h fp) =
+ flushA (StringDBM lock ht WriteMode h fp) = withMVar lock $ \_ ->
do s <- strFromA ht
vWriteFile h fp s
flushA _ = return ()
--
haskell-testpack
More information about the Pkg-haskell-commits
mailing list