Ticket #7970: database-test.hs

File database-test.hs, 833 bytes (added by joeyadams, 21 months ago)

Demonstrates a ForeignPtr being accessed after the GC finalized it (compile with database.c)

Line 
1{-# OPTIONS -fno-warn-name-shadowing #-}
2import Control.Concurrent.MVar
3import Control.Exception
4import Foreign.Ptr
5import Foreign.ForeignPtr.Safe
6
7foreign import ccall "db_open"    c_db_open :: IO (Ptr ())
8foreign import ccall "&db_close"  p_db_close :: FunPtr (Ptr () -> IO ())
9foreign import ccall "db_is_open" c_db_is_open :: Ptr () -> IO Bool
10
11main :: IO ()
12main = do
13    fptr <- c_db_open >>= newForeignPtr p_db_close
14
15    o <- withForeignPtr fptr c_db_is_open
16    putStrLn $ "1: Database is " ++ (if o then "open" else "closed")
17
18    Left BlockedIndefinitelyOnMVar <- try $ newEmptyMVar >>= takeMVar
19
20    -- Database should still be open, since we have a db handle.
21    o <- withForeignPtr fptr c_db_is_open
22    putStrLn $ "2: Database is " ++ (if o then "open" else "closed")
23
24    finalizeForeignPtr fptr
25    putStrLn "Done"