add test for #2122
authorSimon Marlow <simonmar@microsoft.com>
Tue, 26 Feb 2008 14:06:06 +0000 (14:06 +0000)
committerSimon Marlow <simonmar@microsoft.com>
Tue, 26 Feb 2008 14:06:06 +0000 (14:06 +0000)
testsuite/tests/ghc-regress/lib/IO/2122.hs [new file with mode: 0644]
testsuite/tests/ghc-regress/lib/IO/all.T

diff --git a/testsuite/tests/ghc-regress/lib/IO/2122.hs b/testsuite/tests/ghc-regress/lib/IO/2122.hs
new file mode 100644 (file)
index 0000000..dd84fef
--- /dev/null
@@ -0,0 +1,70 @@
+{- 
+
+Before running this, check that /tmp/test does not exist and
+contain something important. Then do:
+
+ $ touch /tmp/test
+
+If you do:
+
+ $ runhaskell Test.hs
+
+it will work. If you do:
+
+ $ runhaskell Test.hs fail
+
+it will fail every time with:
+
+Test.hs: writeFile: /tmp/test: openFile: resource busy (file is locked)
+
+-}
+
+import Control.Monad
+import System.Directory
+import System.IO
+import System.Environment
+import System.Posix.IO
+
+fp = "2122-test"
+
+main :: IO ()
+main = do
+   writeFile fp "test"
+   test True
+
+-- fails everytime when causeFailure is True in GHCi, with runhaskell,
+-- or when compiled.
+test :: Bool -> IO ()
+test causeFailure =
+    do h1 <- openFile fp ReadMode `Prelude.catch` (\e -> error ("openFile 1: " ++ show e))
+       when causeFailure $ do
+         h2 <- openFile fp ReadMode `Prelude.catch` (\e -> error ("openFile 2: " ++ show e))
+         hClose h2
+       hClose h1
+       removeFile fp
+       writeFile fp (show [1..100]) `Prelude.catch` (\e -> error ("writeFile: " ++ show e))
+
+-- this version never fails (except in GHCi, if test has previously failed).
+-- probably because openFd does not try to lock the file
+test2 :: Bool -> IO ()
+test2 causeFailure =
+    do fd1 <- openFd fp ReadOnly Nothing defaultFileFlags `Prelude.catch` (\e -> error ("openFile 1: " ++ show e))
+       when causeFailure $ do
+         fd2 <- openFd fp ReadOnly Nothing defaultFileFlags `Prelude.catch` (\e -> error ("openFile 2: " ++ show e))
+         closeFd fd2
+       closeFd fd1
+       removeFile fp
+       writeFile fp (show [1..100]) `Prelude.catch` (\e -> error ("writeFile: " ++ show e))
+
+-- fails sometimes when run repeated in GHCi, but seems fine with
+-- runhaskell or compiled
+test3 :: IO ()
+test3 =
+    do h1 <- openFile fp ReadMode `Prelude.catch` (\e -> error ("openFile 1: " ++ show e))
+       h2 <- openFile fp ReadMode `Prelude.catch` (\e -> error ("openFile 2: " ++ show e))
+       removeFile fp
+       writeFile fp (show [1..100]) `Prelude.catch` (\e -> error ("writeFile: " ++ show e))
+       print =<< hGetContents h1
+       print =<< hGetContents h2
+       hClose h2
+       hClose h1
index e4dd4e9..f131ff8 100644 (file)
@@ -102,3 +102,5 @@ test('concio001', skip, run_command, ['$MAKE -s --no-print-directory test.concio
 test('concio001.thr', skip, run_command, ['$MAKE -s --no-print-directory test.concio001.thr'])
 
 test('concio002', reqlib('process'), compile_and_run, [''])
+
+test('2122', extra_clean(['2122-test']), compile_and_run, [''])