From 6ac8d6fdb2ab1285405f4da1f6e785c2474d2c5e Mon Sep 17 00:00:00 2001
From: sof <unknown>
Date: Tue, 12 May 1998 16:40:11 +0000
Subject: [PATCH] [project @ 1998-05-12 16:40:09 by sof] - closeFile: make
 sure that (FILE*)s pointing to non-regular,   unlocked
 files (sockets, FDs etc.) are closed. - new function:
 openFd, which implements process local file locking   for
 files that are initially opened by the Posix Fd-based ops
 before   being converted into a Haskell handle by
 Posix.fdToHandle

---
 ghc/lib/std/cbits/closeFile.lc |   29 +++++++++++---
 ghc/lib/std/cbits/openFile.lc  |   82 ++++++++++++++++++++++++++++++++++++++++
 ghc/lib/std/cbits/stgio.h      |    1 +
 3 files changed, 107 insertions(+), 5 deletions(-)

diff --git a/ghc/lib/std/cbits/closeFile.lc b/ghc/lib/std/cbits/closeFile.lc
index 9f4c80e..6118574 100644
--- a/ghc/lib/std/cbits/closeFile.lc
+++ b/ghc/lib/std/cbits/closeFile.lc
@@ -13,14 +13,33 @@ closeFile(fp)
 StgForeignObj fp;
 {
     int rc;
-
-    if (unlockFile(fileno((FILE *) fp))) {
-       /* If it has been unlocked, don't bother fclose()ing */
-       return 0;
+    int unlocked=1;
+
+    if ( unlockFile(fileno((FILE *) fp)) ) {
+      /* If the file has already been unlocked (or an entry
+         for it in the locking tables couldn't be fond), could
+         mean two things:
+
+	    - we're repeating an hClose on an already
+	      closed file (this is likely to be a bug
+	      in the implementation of hClose, as this 
+	      condition should have been caught before
+	      we ended up here.)
+	      
+	    - the file wasn't locked in the first place!
+	      (file descriptors to non regular files.)
+
+	 We proceed with attempting to close the file,
+	 but don't flag the error should fclose() return
+	 EBADF
+      */
+	unlocked=0;
+	
     }
 
     while ((rc = fclose((FILE *) fp)) != 0) {
-	if (errno != EINTR) {
+        /* See above comment */
+	if ( errno != EINTR && (!unlocked && errno != EBADF ) ) {
 	    cvtErrno();
 	    stdErrno();
 	    return rc;
diff --git a/ghc/lib/std/cbits/openFile.lc b/ghc/lib/std/cbits/openFile.lc
index fb4bdfb..43dd1dd 100644
--- a/ghc/lib/std/cbits/openFile.lc
+++ b/ghc/lib/std/cbits/openFile.lc
@@ -234,4 +234,86 @@ StgByteArray how;
     return (StgAddr) fp;
 }
 
+/*
+ fdopen() plus implement locking.
+*/
+StgAddr
+openFd(fd,how)
+StgInt fd;
+StgByteArray how;
+{
+    int exclusive;
+    int oflags;
+    FILE* fp;
+
+    /*
+     * Since we aren't supposed to succeed when we're opening for writing and
+     * there's another writer, we can't just do an fopen() for "w" mode.
+     */
+
+    switch (how[0]) {
+    case 'a':
+	oflags = O_WRONLY | O_NOCTTY | O_APPEND;
+	exclusive = 1;
+	break;
+    case 'w':
+	oflags = O_WRONLY | O_NOCTTY;
+	exclusive = 1;
+	break;
+    case 'r':
+#if defined(cygwin32_TARGET_OS)
+	/* With cygwin32-b19, fdopen() returns EBADF under some
+	   hard-to-reproduce situations (causing hsc's renamer
+	   to break on some ~10 modules when recompiling it.)
+	   As a temporary workaround, we open files that was requested
+	   opened as read-only instead as read-write, since fdopen()
+	   only appears to fail on RO file descriptors.
+
+	   This won't have any impact on the correctness of the Haskell IO
+	   implementation since the Handle in Haskell land will record the
+	   file as being read-only, so illegal writes will be caught.
+	   
+	   ToDo: isolate and report.
+	*/
+	oflags = how[1] == '+' ? O_RDWR | O_NOCTTY : O_RDWR | O_NOCTTY;
+#else
+	oflags = how[1] == '+' ? O_RDWR | O_NOCTTY : O_RDONLY | O_NOCTTY;
+#endif
+	exclusive = 0;
+	break;
+    default:
+	fprintf(stderr, "openFd: unknown mode `%s'\n", how);
+	EXIT(EXIT_FAILURE);
+    }
+
+
+    if (lockFile(fd, exclusive) < 0) {
+	cvtErrno();
+	switch (ghc_errno) {
+	default:
+	    stdErrno();
+	    break;
+	case GHC_EACCES:
+	case GHC_EAGAIN:
+	    ghc_errtype = ERR_RESOURCEBUSY;
+	    ghc_errstr = "file is locked";
+	    break;
+	}
+	(void) close(fd);
+	return NULL;
+    }
+
+    errno = 0;			/* Just in case fdopen() is lame */
+    while ((fp = fdopen(fd, how)) == NULL) {
+	if (errno != EINTR) {
+#if defined(cygwin32_TARGET_OS) && defined(DEBUG)
+	    fprintf(stderr, "openFd %s : %s : %d : %d\n", file, how, errno, fd);
+#endif
+	    cvtErrno();
+	    (void) close(fd);
+	    return NULL;
+	}
+    }
+    return (StgAddr) fp;
+}
 \end{code}
diff --git a/ghc/lib/std/cbits/stgio.h b/ghc/lib/std/cbits/stgio.h
index 05213ec..e5f62df 100644
--- a/ghc/lib/std/cbits/stgio.h
+++ b/ghc/lib/std/cbits/stgio.h
@@ -85,6 +85,7 @@ StgInt	inputReady  PROTO((StgForeignObj,StgInt));
 
 /* openFile.lc */
 StgAddr openFile PROTO((StgByteArray, StgByteArray));
+StgAddr openFd   PROTO((StgInt, StgByteArray));
 
 /* readFile.lc */
 StgInt	readBlock PROTO((StgAddr, StgForeignObj, StgInt));
-- 
1.7.10.4