[project @ 2005-01-01 23:59:58 by krasimir]

According to the documentation, the Haskell implementation of Handle
should implement single writer/multiple readers locking but the current
implementation doesn't work under Windows. This commit fixes this using
'_sopen' function instead of 'open'. The former allows to implement system
level locking on Windows. The changes doesn't affect other platforms.

diff --git a/GHC/Handle.hs b/GHC/Handle.hs
index a7e9e98..6bbc439 100644 (file)
--- a/GHC/Handle.hs
+++ b/GHC/Handle.hs
@@ -26,8 +26,11 @@ module GHC.Handle (
   fillReadBuffer, fillReadBufferWithoutBlocking,
   readRawBuffer, readRawBufferPtr,
   writeRawBuffer, writeRawBufferPtr,
+
+#ifndef mingw32_TARGET_OS
   unlockFile,
-  
+#endif
+
   ioe_closedHandle, ioe_EOF, ioe_notReadable, ioe_notWritable,
 
   stdin, stdout, stderr,
@@ -787,9 +790,6 @@ openFile' filepath mode binary =
                  ReadWriteMode -> rw_flags    
                  AppendMode    -> append_flags
 
-      truncate | WriteMode <- mode = True
-              | otherwise         = False
-
       binary_flags
          | binary    = o_BINARY
          | otherwise = 0
@@ -806,7 +806,7 @@ openFile' filepath mode binary =
              throwErrnoIfMinus1Retry "openFile"
                (c_open f (fromIntegral oflags) 0o666)
 
-    openFd fd Nothing False filepath mode binary truncate
+    openFd fd Nothing False filepath mode binary
        `catchException` \e -> do c_close (fromIntegral fd); throw e
        -- NB. don't forget to close the FD if openFd fails, otherwise
        -- this FD leaks.
@@ -818,15 +818,15 @@ openFile' filepath mode binary =
 std_flags    = o_NONBLOCK   .|. o_NOCTTY
 output_flags = std_flags    .|. o_CREAT
 read_flags   = std_flags    .|. o_RDONLY 
-write_flags  = output_flags .|. o_WRONLY
+write_flags  = output_flags .|. o_WRONLY .|. o_TRUNC
 rw_flags     = output_flags .|. o_RDWR
 append_flags = write_flags  .|. o_APPEND
 
 -- ---------------------------------------------------------------------------
 -- openFd
 
-openFd :: FD -> Maybe FDType -> Bool -> FilePath -> IOMode -> Bool -> Bool -> IO Handle
-openFd fd mb_fd_type is_socket filepath mode binary truncate = do
+openFd :: FD -> Maybe FDType -> Bool -> FilePath -> IOMode -> Bool -> IO Handle
+openFd fd mb_fd_type is_socket filepath mode binary = do
     -- turn on non-blocking mode
     setNonBlockingFD fd
 
@@ -855,14 +855,12 @@ openFd fd mb_fd_type is_socket filepath mode binary truncate = do
 
        -- regular files need to be locked
        RegularFile -> do
+#ifndef mingw32_TARGET_OS
           r <- lockFile (fromIntegral fd) (fromBool write) 1{-exclusive-}
           when (r == -1)  $
                ioException (IOError Nothing ResourceBusy "openFile"
                                   "file is locked" Nothing)
-
-          -- truncate the file if necessary
-          when truncate (fileTruncate filepath)
-
+#endif
           mkFileHandle fd is_socket filepath ha_type binary
 
 
@@ -870,13 +868,16 @@ fdToHandle :: FD -> IO Handle
 fdToHandle fd = do
    mode <- fdGetMode fd
    let fd_str = "<file descriptor: " ++ show fd ++ ">"
-   openFd fd Nothing False{-XXX!-} fd_str mode True{-bin mode-} False{-no truncate-}
+   openFd fd Nothing False{-XXX!-} fd_str mode True{-bin mode-}
+
 
+#ifndef mingw32_TARGET_OS
 foreign import ccall unsafe "lockFile"
   lockFile :: CInt -> CInt -> CInt -> IO CInt
 
 foreign import ccall unsafe "unlockFile"
   unlockFile :: CInt -> IO CInt
+#endif
 
 mkStdHandle :: FD -> FilePath -> HandleType -> IORef Buffer -> BufferMode
        -> IO Handle
@@ -996,9 +997,11 @@ hClose_handle_ handle_ = do
     -- free the spare buffers
     writeIORef (haBuffers handle_) BufferListNil
   
+#ifndef mingw32_TARGET_OS
     -- unlock it
     unlockFile c_fd
-  
+#endif
+
     -- we must set the fd to -1, because the finalizer is going
     -- to run eventually and try to close/unlock it.
     return (handle_{ haFD        = -1, 

diff --git a/System/Posix/Internals.hs b/System/Posix/Internals.hs
index 4976e9d..a2821e0 100644 (file)
--- a/System/Posix/Internals.hs
+++ b/System/Posix/Internals.hs
@@ -119,18 +119,6 @@ statGetType p_stat = do
 ioe_unknownfiletype = IOError Nothing UnsupportedOperation "fdType"
                        "unknown file type" Nothing
 
--- It isn't clear whether ftruncate is POSIX or not (I've read several
--- manpages and they seem to conflict), so we truncate using open/2.
-fileTruncate :: FilePath -> IO ()
-fileTruncate file = do
-  let flags = o_WRONLY .|. o_TRUNC
-  withCString file $ \file_cstr -> do
-    fd <- fromIntegral `liftM`
-           throwErrnoIfMinus1Retry "fileTruncate"
-               (c_open file_cstr (fromIntegral flags) 0o666)
-    c_close fd
-  return ()
-
 #if defined(mingw32_TARGET_OS) || defined(__MINGW32__)
 closeFd :: Bool -> CInt -> IO CInt
 closeFd isStream fd 

diff --git a/System/Process.hs b/System/Process.hs
index a35038e..7a1965b 100644 (file)
--- a/System/Process.hs
+++ b/System/Process.hs
@@ -279,7 +279,7 @@ fdToHandle pfd mode = do
   fd <- peek pfd
   openFd fd (Just Stream) 
      False{-not a socket-}
-     ("fd:" ++ show fd) mode True{-binary-} False{-no truncate-}
+     ("fd:" ++ show fd) mode True{-binary-}
 
 -- ----------------------------------------------------------------------------
 -- waitForProcess

diff --git a/cbits/lockFile.c b/cbits/lockFile.c
index 5208020..7756616 100644 (file)
--- a/cbits/lockFile.c
+++ b/cbits/lockFile.c
@@ -1,36 +1,25 @@
-/* 
+/*
  * (c) The GRASP/AQUA Project, Glasgow University, 1994-2004
  *
- * $Id: lockFile.c,v 1.3 2004/06/02 12:35:11 simonmar Exp $
+ * $Id: lockFile.c,v 1.4 2005/01/01 23:59:59 krasimir Exp $
  *
  * stdin/stout/stderr Runtime Support
  */
 
+#ifndef mingw32_TARGET_OS
+
 #include "HsBase.h"
 #include "Rts.h"
 #include "../../ghc/rts/RtsUtils.h" // for barf()
 
-#ifdef mingw32_TARGET_OS
-   // The Win32 C runtime has a max of 2048 file descriptors (see
-   // _NHANDLE_ in the crt sources), but mingw defines FD_SETSIZE to
-   // 64.
-#  define NUM_FDS 2048
-#else
-#  ifndef FD_SETSIZE
-#    error No FD_SETSIZE defined!
-#  else
-#    define NUM_FDS FD_SETSIZE
-#  endif
-#endif
-
 typedef struct {
     dev_t device;
     ino_t inode;
     int fd;
 } Lock;
 
-static Lock readLock[NUM_FDS];
-static Lock writeLock[NUM_FDS];
+static Lock readLock[FD_SETSIZE];
+static Lock writeLock[FD_SETSIZE];
 
 static int readLocks = 0;
 static int writeLocks = 0;
@@ -41,34 +30,21 @@ lockFile(int fd, int for_writing, int exclusive)
     struct stat sb;
     int i;
 
-    if (fd > NUM_FDS) {
+    if (fd > FD_SETSIZE) {
        barf("lockFile: fd out of range");
     }
 
     while (fstat(fd, &sb) < 0) {
-       if (errno != EINTR) {
-#ifndef _WIN32
+       if (errno != EINTR)
            return -1;
-#else
-           /* fstat()ing socket fd's seems to fail with CRT's fstat(),
-              so let's just silently return and hope for the best..
-           */
-           return 0;
-#endif
-       }
     }
 
     if (for_writing) {
       /* opening a file for writing, check to see whether
          we don't have any read locks on it already.. */
       for (i = 0; i < readLocks; i++) {
-        if (readLock[i].inode == sb.st_ino && readLock[i].device == sb.st_dev) {
-#ifndef __MINGW32__
+        if (readLock[i].inode == sb.st_ino && readLock[i].device == sb.st_dev)
            return -1;
-#else
-           break;    
-#endif
-        }          
       }
       /* If we're determined that there is only a single
          writer to the file, check to see whether the file
@@ -77,11 +53,7 @@ lockFile(int fd, int for_writing, int exclusive)
       if (exclusive) {
        for (i = 0; i < writeLocks; i++) {
          if (writeLock[i].inode == sb.st_ino && writeLock[i].device == sb.st_dev) {
-#ifndef __MINGW32__
             return -1;
-#else
-            break;
-#endif
          }
         }
       }
@@ -91,17 +63,12 @@ lockFile(int fd, int for_writing, int exclusive)
       writeLock[i].inode = sb.st_ino;
       writeLock[i].fd = fd;
       return 0;
-    } else { 
+    } else {
       /* For reading, it's simpler - just check to see
          that there's no-one writing to the underlying file. */
       for (i = 0; i < writeLocks; i++) {
-       if (writeLock[i].inode == sb.st_ino && writeLock[i].device == sb.st_dev) {
-#ifndef __MINGW32__
+       if (writeLock[i].inode == sb.st_ino && writeLock[i].device == sb.st_dev)
             return -1;
-#else
-            break;
-#endif
-        }
       }
       /* Fit in new entry, reusing an existing table entry, if possible. */
       for (i = 0; i < readLocks; i++) {
@@ -141,3 +108,5 @@ unlockFile(int fd)
      /* Signal that we did not find an entry */
     return 1;
 }
+
+#endif

diff --git a/include/HsBase.h b/include/HsBase.h
index 289f9b5..b5d5fdb 100644 (file)
--- a/include/HsBase.h
+++ b/include/HsBase.h
@@ -125,6 +125,7 @@
 #include <fcntl.h>
 #include "timeUtils.h"
 #include <shlobj.h>
+#include <share.h>
 #endif
 
 #if HAVE_SYS_SELECT_H
@@ -693,14 +694,21 @@ INLINE int __hsposix_SIG_SETMASK() { return SIG_SETMASK; }
 
 #endif /* mingw32_TARGET_OS */
 
+INLINE int __hscore_open(char *file, int how, mode_t mode) {
+#ifdef mingw32_TARGET_OS
+       if ((how & O_WRONLY) || (how & O_RDWR) || (how & O_APPEND))
+         return _sopen(file,how,_SH_DENYRW,mode);
+       else
+         return _sopen(file,how,_SH_DENYWR,mode);
+#else
+       return open(file,how,mode);
+#endif
+}
+
 // These are wrapped because on some OSs (eg. Linux) they are
 // macros which redirect to the 64-bit-off_t versions when large file
 // support is enabled.
 //
-INLINE int __hscore_open(char *file, int how, mode_t mode) {
-       return (open(file,how,mode));
-}
-
 INLINE off_t __hscore_lseek(int fd, off_t off, int whence) {
        return (lseek(fd,off,whence));
 }
@@ -731,7 +739,7 @@ extern void hsFD_ZERO(fd_set *fds);
 INLINE HsInt sizeofTimeVal(void) { return sizeof(struct timeval); }
 
 INLINE HsInt getTicksOfDay(void)
-{  
+{
     struct timeval tv;
     gettimeofday(&tv, (struct timezone *) NULL);
     return (tv.tv_sec * TICK_FREQ +

diff --git a/include/lockFile.h b/include/lockFile.h
index 508640f..bcaa7fd 100644 (file)
--- a/include/lockFile.h
+++ b/include/lockFile.h
@@ -1,10 +1,14 @@
-/* 
+/*
  * (c) The University of Glasgow 2001
  *
- * $Id: lockFile.h,v 1.1 2001/06/28 14:15:04 simonmar Exp $
+ * $Id: lockFile.h,v 1.2 2005/01/02 00:00:00 krasimir Exp $
  *
  * lockFile header
  */
 
+#ifndef mingw32_TARGET_OS
+
 int lockFile(int fd, int for_writing, int exclusive);
 int unlockFile(int fd);
+
+#endif