From: krasimir <unknown>
Date: Wed, 5 Jan 2005 21:30:07 +0000 (+0000)
Subject: [project @ 2005-01-05 21:30:05 by krasimir]
X-Git-Tag: nhc98-1-18-release~143
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=8449ae9350867e2f18cb70f765fdea842ce61542;p=ghc-base.git

[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
--- 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
--- 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
--- 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
--- 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
--- 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 )
 {