X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FHandle.hs;h=e0b755f1050e2821595f9c3f938c8d2180677b26;hb=a70f356e023abdd0abb130cc149b0e3de7469044;hp=1db09ff8a377a3287be7624165f09513f315d268;hpb=bb534f206682be14daf72b33c6105ab27295c6ac;p=haskell-directory.git diff --git a/GHC/Handle.hs b/GHC/Handle.hs index 1db09ff..e0b755f 100644 --- a/GHC/Handle.hs +++ b/GHC/Handle.hs @@ -17,6 +17,7 @@ -- ----------------------------------------------------------------------------- +-- #hide module GHC.Handle ( withHandle, withHandle', withHandle_, wantWritableHandle, wantReadableHandle, wantSeekableHandle, @@ -75,6 +76,9 @@ import GHC.Enum import GHC.Num ( Integer(..), Num(..) ) import GHC.Show import GHC.Real ( toInteger ) +#if defined(DEBUG_DUMP) +import GHC.Pack +#endif import GHC.Conc @@ -511,7 +515,7 @@ fillReadBufferWithoutBlocking fd is_stream -- buffer better be empty: assert (r == 0 && w == 0) $ do #ifdef DEBUG_DUMP - puts ("fillReadBufferLoopNoBlock: bytes = " ++ show bytes ++ "\n") + puts ("fillReadBufferLoopNoBlock: bytes = " ++ show size ++ "\n") #endif res <- readRawBufferNoBlock "fillReadBuffer" fd is_stream b 0 (fromIntegral size) @@ -590,7 +594,7 @@ writeRawBufferPtr loc fd is_stream buf off len -- ToDo: we don't have a non-blocking primitve read on Win32 readRawBufferNoBlock :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt -readRawBufferNoBlock = readRawBufferNoBlock +readRawBufferNoBlock = readRawBuffer -- Async versions of the read/write primitives, for the non-threaded RTS @@ -809,15 +813,21 @@ openFile' filepath mode binary = throwErrnoIfMinus1Retry "openFile" (c_open f (fromIntegral oflags) 0o666) - h <- openFd fd Nothing False filepath mode binary + fd_type <- fdType fd + + h <- openFd fd (Just fd_type) 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. -- ASSERT: if we just created the file, then openFd won't fail -- (so we don't need to worry about removing the newly created file -- in the event of an error). + #ifndef mingw32_HOST_OS - if mode == WriteMode + -- we want to truncate() if this is an open in WriteMode, but only + -- if the target is a RegularFile. ftruncate() fails on special files + -- like /dev/null. + if mode == WriteMode && fd_type == RegularFile then throwErrnoIf (/=0) "openFile" (c_ftruncate (fromIntegral fd) 0) else return 0 @@ -905,10 +915,6 @@ openFd fd mb_fd_type is_socket filepath mode binary = do ioException (IOError Nothing InappropriateType "openFile" "is a directory" Nothing) - Stream - | ReadWriteHandle <- ha_type -> mkDuplexHandle fd is_socket filepath binary - | otherwise -> mkFileHandle fd is_socket filepath ha_type binary - -- regular files need to be locked RegularFile -> do #ifndef mingw32_HOST_OS @@ -919,6 +925,16 @@ openFd fd mb_fd_type is_socket filepath mode binary = do #endif mkFileHandle fd is_socket filepath ha_type binary + Stream + -- only *Streams* can be DuplexHandles. Other read/write + -- Handles must share a buffer. + | ReadWriteHandle <- ha_type -> + mkDuplexHandle fd is_socket filepath binary + | otherwise -> + mkFileHandle fd is_socket filepath ha_type binary + + RawDevice -> + mkFileHandle fd is_socket filepath ha_type binary fdToHandle :: FD -> IO Handle fdToHandle fd = do @@ -953,6 +969,17 @@ mkStdHandle fd filepath ha_type buf bmode = do mkFileHandle :: FD -> Bool -> FilePath -> HandleType -> Bool -> IO Handle mkFileHandle fd is_stream filepath ha_type binary = do (buf, bmode) <- getBuffer fd (initBufferState ha_type) + +#ifdef mingw32_HOST_OS + -- On Windows, if this is a read/write handle and we are in text mode, + -- turn off buffering. We don't correctly handle the case of switching + -- from read mode to write mode on a buffered text-mode handle, see bug + -- \#679. + bmode <- case ha_type of + ReadWriteHandle | not binary -> return NoBuffering + _other -> return bmode +#endif + spares <- newIORef BufferListNil newFileHandle filepath (handleFinalizer filepath) (Handle__ { haFD = fd, @@ -1136,7 +1163,7 @@ hLookAhead handle = do -- fill up the read buffer if necessary new_buf <- if bufferEmpty buf - then fillReadBuffer fd is_line (haIsStream handle_) buf + then fillReadBuffer fd True (haIsStream handle_) buf else return buf writeIORef ref new_buf @@ -1207,6 +1234,8 @@ hSetBuffering handle mode = -- 'raw' mode under win32 is a bit too specialised (and troublesome -- for most common uses), so simply disable its use here. NoBuffering -> setCooked (haFD handle_) False +#else + NoBuffering -> return () #endif _ -> setCooked (haFD handle_) True @@ -1450,9 +1479,8 @@ hIsSeekable handle = SemiClosedHandle -> ioe_closedHandle AppendHandle -> return False _ -> do t <- fdType (haFD handle_) - return (t == RegularFile - && (haIsBin handle_ - || tEXT_MODE_SEEK_ALLOWED)) + return ((t == RegularFile || t == RawDevice) + && (haIsBin handle_ || tEXT_MODE_SEEK_ALLOWED)) -- ----------------------------------------------------------------------------- -- Changing echo status (Non-standard GHC extensions) @@ -1511,26 +1539,38 @@ foreign import ccall unsafe "__hscore_setmode" -- ----------------------------------------------------------------------------- -- Duplicating a Handle --- |Returns a duplicate of the original handle, with its own buffer --- and file pointer. The original handle's buffer is flushed, including --- discarding any input data, before the handle is duplicated. +-- | Returns a duplicate of the original handle, with its own buffer. +-- The two Handles will share a file pointer, however. The original +-- handle's buffer is flushed, including discarding any input data, +-- before the handle is duplicated. hDuplicate :: Handle -> IO Handle hDuplicate h@(FileHandle path m) = do - new_h_ <- withHandle' "hDuplicate" h m (dupHandle_ Nothing) + new_h_ <- withHandle' "hDuplicate" h m (dupHandle Nothing) newFileHandle path (handleFinalizer path) new_h_ hDuplicate h@(DuplexHandle path r w) = do - new_w_ <- withHandle' "hDuplicate" h w (dupHandle_ Nothing) + new_w_ <- withHandle' "hDuplicate" h w (dupHandle Nothing) new_w <- newMVar new_w_ - new_r_ <- withHandle' "hDuplicate" h r (dupHandle_ (Just new_w)) + new_r_ <- withHandle' "hDuplicate" h r (dupHandle (Just new_w)) new_r <- newMVar new_r_ addMVarFinalizer new_w (handleFinalizer path new_w) return (DuplexHandle path new_r new_w) -dupHandle_ other_side h_ = do +dupHandle other_side h_ = do -- flush the buffer first, so we don't have to copy its contents flushBuffer h_ - new_fd <- c_dup (fromIntegral (haFD h_)) + new_fd <- throwErrnoIfMinus1 "dupHandle" $ + c_dup (fromIntegral (haFD h_)) + dupHandle_ other_side h_ new_fd + +dupHandleTo other_side hto_ h_ = do + flushBuffer h_ + -- Windows' dup2 does not return the new descriptor, unlike Unix + throwErrnoIfMinus1 "dupHandleTo" $ + c_dup2 (fromIntegral (haFD h_)) (fromIntegral (haFD hto_)) + dupHandle_ other_side h_ (haFD hto_) + +dupHandle_ other_side h_ new_fd = do buffer <- allocateBuffer dEFAULT_BUFFER_SIZE (initBufferState (haType h_)) ioref <- newIORef buffer ioref_buffers <- newIORef BufferListNil @@ -1558,14 +1598,14 @@ hDuplicateTo :: Handle -> Handle -> IO () hDuplicateTo h1@(FileHandle _ m1) h2@(FileHandle _ m2) = do withHandle__' "hDuplicateTo" h2 m2 $ \h2_ -> do _ <- hClose_help h2_ - withHandle' "hDuplicateTo" h1 m1 (dupHandle_ Nothing) + withHandle' "hDuplicateTo" h1 m1 (dupHandleTo Nothing h2_) hDuplicateTo h1@(DuplexHandle _ r1 w1) h2@(DuplexHandle _ r2 w2) = do withHandle__' "hDuplicateTo" h2 w2 $ \w2_ -> do _ <- hClose_help w2_ - withHandle' "hDuplicateTo" h1 r1 (dupHandle_ Nothing) + withHandle' "hDuplicateTo" h1 r1 (dupHandleTo Nothing w2_) withHandle__' "hDuplicateTo" h2 r2 $ \r2_ -> do _ <- hClose_help r2_ - withHandle' "hDuplicateTo" h1 r1 (dupHandle_ (Just w1)) + withHandle' "hDuplicateTo" h1 r1 (dupHandleTo (Just w1) r2_) hDuplicateTo h1 _ = ioException (IOError (Just h1) IllegalOperation "hDuplicateTo" "handles are incompatible" Nothing) @@ -1616,10 +1656,10 @@ showHandle' filepath is_duplex h = -- --------------------------------------------------------------------------- -- debugging -#ifdef DEBUG_DUMP +#if defined(DEBUG_DUMP) puts :: String -> IO () -puts s = withCString s $ \cstr -> do write_rawBuffer 1 False cstr 0 (fromIntegral (length s)) - return () +puts s = do write_rawBuffer 1 (unsafeCoerce# (packCString# s)) 0 (fromIntegral (length s)) + return () #endif -- -----------------------------------------------------------------------------