[Pkg-haskell-commits] [SCM] haskell-testpack branch, master, updated. debian/1.0.2-1-4-gb0d6b36

[John Goerzen]

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