diff --git a/System/IO/MMap.hs b/System/IO/MMap.hs --- a/System/IO/MMap.hs +++ b/System/IO/MMap.hs @@ -1,4 +1,4 @@ - +{-# LANGUAGE ForeignFunctionInterface, CPP #-} -- | -- Module : System.IO.MMap -- Copyright : (c) Gracjan Polak 2009 @@ -47,7 +47,7 @@ import System.IO.Unsafe (unsafePerformIO) import qualified Data.ByteString.Internal as BS (fromForeignPtr) import Data.Int (Int64) -import Control.Monad (when) +import Control.Monad (when,liftM) import Control.Exception import qualified Data.ByteString as BS (ByteString) import qualified Data.ByteString.Lazy as BSL (ByteString,fromChunks) @@ -167,8 +167,13 @@ deriving (Eq,Ord,Enum,Show,Read) sanitizeFileRegion :: (Integral a,Bounded a) => String -> ForeignPtr () -> Mode -> Maybe (Int64,a) -> IO (Int64,a) -sanitizeFileRegion filepath handle ReadWriteEx (Just region) - = return region +sanitizeFileRegion filepath handle ReadWriteEx (Just region@(offset,length)) = + withForeignPtr handle $ \handle -> do + longsize <- c_system_io_file_size handle + let needsize = fromIntegral (offset + fromIntegral length) + when (longsize < needsize) + ((throwErrnoIfMinus1 "extend file size" $ c_system_io_extend_file_size handle needsize) >> return ()) + return region sanitizeFileRegion filepath handle ReadWriteEx _ = error "sanitizeRegion given ReadWriteEx with no region, please check earlier for this" sanitizeFileRegion filepath handle mode region = withForeignPtr handle $ \handle -> do @@ -375,6 +380,10 @@ -- | Get file size in system specific manner foreign import ccall unsafe "HsMmap.h system_io_mmap_file_size" c_system_io_file_size :: Ptr () -> IO CLLong +-- | Set file size in system specific manner. It is guaranteed to be called +-- only with new size being at least current size. +foreign import ccall unsafe "HsMmap.h system_io_mmap_extend_file_size" + c_system_io_extend_file_size :: Ptr () -> CLLong -> IO CInt -- | Memory mapping granularity. foreign import ccall unsafe "HsMmap.h system_io_mmap_granularity" c_system_io_granularity :: CInt diff --git a/cbits/HsMmap.h b/cbits/HsMmap.h --- a/cbits/HsMmap.h +++ b/cbits/HsMmap.h @@ -13,6 +13,8 @@ long long system_io_mmap_file_size(void *handle); +int system_io_mmap_extend_file_size(void *handle, long long size); + int system_io_mmap_granularity(); // this is only implemented in _DEBUG builds diff --git a/cbits/posix.c b/cbits/posix.c --- a/cbits/posix.c +++ b/cbits/posix.c @@ -82,7 +82,6 @@ int prot; int flags; int fd = (int)(intptr_t)handle - 1; - struct stat st; switch(mode) { case 0: @@ -105,13 +104,6 @@ return NULL; } - if( mode==3 ) { - fstat(fd,&st); - if( st.st_size0 ) { ptr = mmap(NULL,size,prot,flags,fd,offset); @@ -158,6 +150,13 @@ fstat(fd,&st); return st.st_size; } + +int system_io_mmap_extend_file_size(void *handle, long long size) +{ + int fd = (int)(intptr_t)handle - 1; + return ftruncate(fd,size); +} + //foreign import ccall unsafe "system_io_mmap_granularity" c_system_io_granularity :: CInt int system_io_mmap_granularity() diff --git a/cbits/win32.c b/cbits/win32.c --- a/cbits/win32.c +++ b/cbits/win32.c @@ -185,6 +185,16 @@ return (long long)lobits + ((long long)hibits << 32); } +int system_io_mmap_extend_file_size(void *handle, long long size) +{ + DWORD lobits = (DWORD)size, hibits = (DWORD)(size>>32); + HANDLE mapping = CreateFileMapping(handle,NULL,PAGE_READWRITE,hibits,lobits,NULL); + if(mapping==NULL) + return -1; + CloseHandle(mapping); + return 0; +} + //foreign import ccall unsafe "system_io_mmap_granularity" c_system_io_granularity :: CInt int system_io_mmap_granularity() { diff --git a/mmap.cabal b/mmap.cabal --- a/mmap.cabal +++ b/mmap.cabal @@ -1,5 +1,5 @@ Name: mmap -Version: 0.5.3 +Version: 0.5.4 Stability: alpha License: BSD3 License-File: LICENSE diff --git a/tests/mmaptest.hs b/tests/mmaptest.hs --- a/tests/mmaptest.hs +++ b/tests/mmaptest.hs @@ -17,6 +17,7 @@ import Foreign.C.Types (CInt,CLLong) import Control.Monad import System.IO +import Data.Int #ifdef WINDOWS import qualified System.Win32.File as W #endif @@ -49,6 +50,13 @@ bs <- mmapFileByteString "test_normal.bin" Nothing bs @?= content +test_normal_readonly_many_times = do + BSC.writeFile "test_normal.bin" content + bs1 <- mmapFileByteString "test_normal.bin" Nothing + bs2 <- mmapFileByteString "test_normal.bin" Nothing + bs3 <- mmapFileByteString "test_normal.bin" Nothing + BSC.concat [bs1,bs2,bs3] @?= BSC.concat [content, content, content] + test_normal_readonly_lazy = do let filename = "test_normalQ.bin" BSC.writeFile filename content @@ -142,12 +150,19 @@ mmapFileByteString filename (Just (4,5000)) assertFailure "Should throw exception" +test_normal_offset_plus_size_beyond_eof_readonly_lazy = do + let filename = "test_normal7.bin" + BSC.writeFile filename content + ignoreExceptions $ do + mmapFileByteStringLazy filename (Just (4,5000)) + assertFailure "Should throw exception" + test_normal_offset_plus_size_beyond_eof_readwriteex = do let filename = "test_normal8.bin" BSC.writeFile filename content mmapWithFilePtr filename ReadWriteEx (Just (4,5000)) $ \(ptr,size) -> do size @?= 5000 - bs <- BSC.unsafePackCStringLen (castPtr ptr,size) + bs <- BSC.packCStringLen (castPtr ptr,size) bs @?= BSC.take 5000 (BSC.drop 4 (content `BSC.append` BSC.replicate 10000 '\0')) test_delete_while_mmapped = do @@ -155,7 +170,7 @@ BSC.writeFile filename content mmapWithFilePtr filename ReadOnly Nothing $ \(ptr,size) -> do removeFileDelayed filename - bs <- BSC.unsafePackCStringLen (castPtr ptr,size) + bs <- BSC.packCStringLen (castPtr ptr,size) bs @?= content v <- doesFileExist filename False @=? v @@ -168,12 +183,22 @@ let size = sum (Prelude.map (\(_,_,s) -> s) ignore) size @?= fromIntegral threegb +test_readwriteex_lazy_make_dont_touch = do + let filename = "test_normal86.bin" + BSC.writeFile filename content + let threegb = 3*1000 + mmapFileForeignPtrLazy filename ReadWriteEx (Just (0,threegb)) + System.Mem.performGC + threadDelay 1000 + size <- withFile filename ReadMode hFileSize + size @?= fromIntegral threegb + test_create_offset_plus_size_readwriteex = do let filename = "test_normal9.bin" ignoreExceptions $ removeFile filename mmapWithFilePtr filename ReadWriteEx (Just (4,5000)) $ \(ptr,size) -> do size @?= 5000 - bs <- BSC.unsafePackCStringLen (castPtr ptr,size) + bs <- BSC.packCStringLen (castPtr ptr,size) bs @?= BSC.replicate 5000 '\0' test_create_readwriteex_no_way = do @@ -186,12 +211,46 @@ ignoreExceptions $ removeFile filename ignoreExceptions $ mmapWithFilePtr filename ReadWriteEx Nothing $ \(ptr,size) -> do size @?= 5000 - bs <- BSC.unsafePackCStringLen (castPtr ptr,size) + bs <- BSC.packCStringLen (castPtr ptr,size) bs @?= BSC.replicate 5000 '\0' assertFailure "Should throw exception" x <- doesFileExist filename x @?= False +test_change_two_places = do + let filename = "test_normalAB.bin" + BSC.writeFile filename content + mmapWithFilePtr filename ReadWrite Nothing $ \(ptr1,size1) -> + do + -- this should change one common memory + let v1 = 0x41414141::Int32 + poke (castPtr ptr1) v1 + v2 <- peek (castPtr ptr1) + v2 @?= v1 + bs2 <- mmapFileByteString filename Nothing + size1 @?= BSC.length bs2 + bs1 <- BSC.packCStringLen (castPtr ptr1,size1) + bs1 @?= bs2 + +test_change_read_write = do + let filename = "test_normalAC.bin" + BSC.writeFile filename content + mmapWithFilePtr filename ReadWrite Nothing $ \(ptr1,size1) -> + do + poke (castPtr ptr1) (0x41414141::Int32) + bs3 <- BSC.readFile filename + bs3 @?= BSC.pack "\x41\x41\x41\x41" `BSC.append` BSC.drop 4 content + +test_writecopy = do + let filename = "test_normalAD.bin" + BSC.writeFile filename content + mmapWithFilePtr filename WriteCopy Nothing $ \(ptr1,size1) -> + do + poke (castPtr ptr1) (0x41414141::Int32) + -- change should NOT be reflected in file on disk + bs3 <- BSC.readFile filename + bs3 @?= content + test_counters_zero = do System.Mem.performGC threadDelay 1000 @@ -220,10 +279,12 @@ test_normal_offset_size_zero_readonly_lazy , "Should throw error if mmaping readonly beyond end of file" ~: test_normal_offset_beyond_eof_readonly - , "Should throw error if mmaping readonly beyond end of file" ~: + , "Should throw error if mmaping readonly beyond end of file lazy" ~: test_normal_offset_beyond_eof_readonly_lazy - , "Should throw error if mmaping readonly with size beyond end of file lazy" ~: + , "Should throw error if mmaping readonly with size beyond end of file" ~: test_normal_offset_plus_size_beyond_eof_readonly + , "Should throw error if mmaping readonly with size beyond end of file lazy" ~: + test_normal_offset_plus_size_beyond_eof_readonly_lazy , "Should ReadWriteEx mmap existing file and resize" ~: test_normal_offset_plus_size_beyond_eof_readwriteex , "Should ReadWriteEx mmap new file and resize" ~: @@ -232,11 +293,21 @@ test_create_nothing_readwriteex_should_throw , "Report error in file creation" ~: test_create_readwriteex_no_way - , "ReadWriteEx in lazy should extend file beyond 3GB when mapped in" ~: - test_readwriteex_lazy_make_a_touch + , "ReadWriteEx in lazy mode should set file size even if not touching" ~: + test_readwriteex_lazy_make_dont_touch , "Remove file while mmaped" ~: test_delete_while_mmapped + , "MMap byte string many times" ~: + test_normal_readonly_many_times + , "Mmap common memory" ~: + test_change_two_places + , "Mmap read write memory" ~: + test_change_read_write + , "Mmap WriteCopy mode" ~: + test_writecopy + --, "ReadWriteEx in lazy should extend file beyond 3GB when mapped in" ~: + -- Test_readwriteex_lazy_make_a_touch -- insert tests above this line , "Counters should be zero" ~: test_counters_zero @@ -262,7 +333,7 @@ E.catch (do bs3 <- mmapFileByteString "test.bin" Nothing print (fromIntegral l==BSC.length bs3 + 5 )) - (\e -> print True -- exception here is also ok + (\E -> print True -- exception here is also ok ) bs4 <- mmapFileByteStringLazy "test.bin" Nothing print (BSL.fromChunks [content] == BSL.take (fromIntegral $ BSC.length content) bs4) @@ -272,4 +343,5 @@ System.Mem.performGC threadDelay 10000 --} +-} +