[project @ 2005-01-05 21:30:05 by krasimir]

Added implementation for hSetFileSize. The configure script checks
for _chsize (usially Windows) and ftruncate (Linux) C functions
and the package uses one of them to implement hSetFileSize.

diff --git a/GHC/Handle.hs b/GHC/Handle.hs
index 6bbc439..63117a2 100644 (file)
--- a/GHC/Handle.hs
+++ b/GHC/Handle.hs
@@ -35,7 +35,7 @@ module GHC.Handle (
 
   stdin, stdout, stderr,
   IOMode(..), openFile, openBinaryFile, openFd, fdToHandle,
-  hFileSize, hIsEOF, isEOF, hLookAhead, hSetBuffering, hSetBinaryMode,
+  hFileSize, hSetFileSize, hIsEOF, isEOF, hLookAhead, hSetBuffering, hSetBinaryMode,
   hFlush, hDuplicate, hDuplicateTo,
 
   hClose, hClose_help,
@@ -1009,7 +1009,7 @@ hClose_handle_ handle_ = do
                   })
 
 -----------------------------------------------------------------------------
--- Detecting the size of a file
+-- Detecting and changing the size of a file
 
 -- | For a handle @hdl@ which attached to a physical file,
 -- 'hFileSize' @hdl@ returns the size of that file in 8-bit bytes.
@@ -1027,6 +1027,20 @@ hFileSize handle =
                 else ioException (IOError Nothing InappropriateType "hFileSize"
                                   "not a regular file" Nothing)
 
+
+-- | 'hSetFileSize' @hdl@ @size@ truncates the physical file with handle @hdl@ to @size@ bytes.
+
+hSetFileSize :: Handle -> Integer -> IO ()
+hSetFileSize handle size =
+    withHandle_ "hSetFileSize" handle $ \ handle_ -> do
+    case haType handle_ of 
+      ClosedHandle             -> ioe_closedHandle
+      SemiClosedHandle                 -> ioe_closedHandle
+      _ -> do flushWriteBufferOnly handle_
+             throwErrnoIf (/=0) "hSetFileSize" 
+                (c_ftruncate (fromIntegral (haFD handle_)) (fromIntegral size))
+             return ()
+
 -- ---------------------------------------------------------------------------
 -- Detecting the End of Input
 

diff --git a/System/IO.hs b/System/IO.hs
index f94dca6..b47bb42 100644 (file)
--- a/System/IO.hs
+++ b/System/IO.hs
@@ -57,9 +57,12 @@ module System.IO (
 
     -- * Operations on handles
 
-    -- ** Determining the size of a file
+    -- ** Determining and changing the size of a file
 
     hFileSize,                -- :: Handle -> IO Integer
+#ifdef __GLASGOW_HASKELL__
+    hSetFileSize,              -- :: Handle -> Integer -> IO ()
+#endif
 
     -- ** Detecting the end of input
 

diff --git a/System/Posix/Internals.hs b/System/Posix/Internals.hs
index a2821e0..e127520 100644 (file)
--- a/System/Posix/Internals.hs
+++ b/System/Posix/Internals.hs
@@ -376,6 +376,9 @@ foreign import ccall unsafe "HsBase.h umask"
 foreign import ccall unsafe "HsBase.h write" 
    c_write :: CInt -> Ptr CChar -> CSize -> IO CSsize
 
+foreign import ccall unsafe "HsBase.h __hscore_ftruncate"
+   c_ftruncate :: CInt -> COff -> IO CInt
+
 foreign import ccall unsafe "HsBase.h unlink"
    c_unlink :: CString -> IO CInt
 

diff --git a/configure.ac b/configure.ac
index 2ac516d..232ebf1 100644 (file)
--- a/configure.ac
+++ b/configure.ac
@@ -22,6 +22,8 @@ AC_CHECK_HEADERS([wctype.h], [AC_CHECK_FUNCS(iswspace)])
 
 AC_CHECK_FUNCS([ftime gmtime_r localtime_r lstat readdir_r])
 
+AC_CHECK_FUNCS([_chsize ftruncate])
+
 # map standard C types and ISO types to Haskell types
 FPTOOLS_CHECK_HTYPE(char)
 FPTOOLS_CHECK_HTYPE(signed char)

diff --git a/include/HsBase.h b/include/HsBase.h
index b5d5fdb..abc26d0 100644 (file)
--- a/include/HsBase.h
+++ b/include/HsBase.h
@@ -397,6 +397,18 @@ __hscore_seek_end( void )
   return SEEK_END;
 }
 
+INLINE int
+__hscore_ftruncate( int fd, off_t where )
+{
+#if defined(HAVE_FTRUNCATE)
+  return ftruncate(fd,where);
+#elif defined(HAVE__CHSIZE)
+  return _chsize(fd,where);
+#else
+#error at least ftruncate or _chsize functions are required to build
+#endif
+}
+
 INLINE HsInt
 __hscore_setmode( HsInt fd, HsBool toBin )
 {