From: Simon Marlow <simonmar@microsoft.com>
Date: Thu, 22 Nov 2007 09:42:07 +0000 (+0000)
Subject: FIX #1753
X-Git-Tag: 2008-05-28~108
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=9bff1d368026b5163eee571102a162ce4af433f3;p=ghc-base.git

FIX #1753
hClose should close the Handle and unlock the file even if calling
close() fails for some reason.
---

diff --git a/GHC/Handle.hs b/GHC/Handle.hs
index fa57fce..e33df5d 100644
--- a/GHC/Handle.hs
+++ b/GHC/Handle.hs
@@ -1068,26 +1068,35 @@ initBufferState _ 	   = WriteBuffer
 -- computation finishes, if @hdl@ is writable its buffer is flushed as
 -- for 'hFlush'.
 -- Performing 'hClose' on a handle that has already been closed has no effect; 
--- doing so not an error.  All other operations on a closed handle will fail.
+-- doing so is not an error.  All other operations on a closed handle will fail.
 -- If 'hClose' fails for any reason, any further operations (apart from
 -- 'hClose') on the handle will still fail as if @hdl@ had been successfully
 -- closed.
 
 hClose :: Handle -> IO ()
-hClose h@(FileHandle _ m)     = hClose' h m
-hClose h@(DuplexHandle _ r w) = hClose' h w >> hClose' h r
-
-hClose' h m = withHandle__' "hClose" h m $ hClose_help
+hClose h@(FileHandle _ m)     = do 
+  mb_exc <- hClose' h m
+  case mb_exc of
+    Nothing -> return ()
+    Just e  -> throwIO e
+hClose h@(DuplexHandle _ r w) = do
+  mb_exc1 <- hClose' h w
+  mb_exc2 <- hClose' h r
+  case (do mb_exc1; mb_exc2) of
+     Nothing -> return ()
+     Just e  -> throwIO e
+
+hClose' h m = withHandle' "hClose" h m $ hClose_help
 
 -- hClose_help is also called by lazyRead (in PrelIO) when EOF is read
 -- or an IO error occurs on a lazy stream.  The semi-closed Handle is
 -- then closed immediately.  We have to be careful with DuplexHandles
 -- though: we have to leave the closing to the finalizer in that case,
 -- because the write side may still be in use.
-hClose_help :: Handle__ -> IO Handle__
+hClose_help :: Handle__ -> IO (Handle__, Maybe Exception)
 hClose_help handle_ =
   case haType handle_ of 
-      ClosedHandle -> return handle_
+      ClosedHandle -> return (handle_,Nothing)
       _ -> do flushWriteBufferOnly handle_ -- interruptible
 	      hClose_handle_ handle_
 
@@ -1096,15 +1105,24 @@ hClose_handle_ handle_ = do
 
     -- close the file descriptor, but not when this is the read
     -- side of a duplex handle.
-    case haOtherSide handle_ of
-      Nothing ->
-  		  throwErrnoIfMinus1Retry_ "hClose" 
+    -- If an exception is raised by the close(), we want to continue
+    -- to close the handle and release the lock if it has one, then 
+    -- we return the exception to the caller of hClose_help which can
+    -- raise it if necessary.
+    maybe_exception <- 
+      case haOtherSide handle_ of
+        Nothing -> (do
+                      throwErrnoIfMinus1Retry_ "hClose" 
 #ifdef mingw32_HOST_OS
 	    			(closeFd (haIsStream handle_) fd)
 #else
 	    			(c_close fd)
 #endif
-      Just _  -> return ()
+                      return Nothing
+                    )
+                     `catchException` \e -> return (Just e)
+
+        Just _  -> return Nothing
 
     -- free the spare buffers
     writeIORef (haBuffers handle_) BufferListNil
@@ -1119,7 +1137,8 @@ hClose_handle_ handle_ = do
     -- to run eventually and try to close/unlock it.
     return (handle_{ haFD        = -1, 
   		     haType      = ClosedHandle
-  		   })
+  		   },
+            maybe_exception)
 
 {-# NOINLINE noBuffer #-}
 noBuffer = unsafePerformIO $ allocateBuffer 1 ReadBuffer
diff --git a/GHC/IO.hs b/GHC/IO.hs
index 6eac466..1f3590d 100644
--- a/GHC/IO.hs
+++ b/GHC/IO.hs
@@ -353,7 +353,7 @@ lazyRead' h handle_ = do
 	let raw = bufBuf buf
 	r <- readRawBuffer "lazyRead" fd (haIsStream handle_) raw 0 1
 	if r == 0
-	   then do handle_ <- hClose_help handle_ 
+	   then do (handle_,_) <- hClose_help handle_ 
 		   return (handle_, "")
 	   else do (c,_) <- readCharFromBuffer raw 0
 		   rest <- lazyRead h
@@ -370,7 +370,7 @@ lazyReadBuffered h handle_ fd ref buf = do
 	    lazyReadHaveBuffer h handle_ fd ref buf
      	)
 	-- all I/O errors are discarded.  Additionally, we close the handle.
-     	(\e -> do handle_ <- hClose_help handle_
+     	(\e -> do (handle_,_) <- hClose_help handle_
 		  return (handle_, "")
 	)