From 4f3c6654c08dd84bdabb8a9cac7dfa8a64a5d9ae Mon Sep 17 00:00:00 2001 From: sewardj Date: Fri, 1 Jun 2001 13:06:01 +0000 Subject: [PATCH] [project @ 2001-06-01 13:06:01 by sewardj] More fixups to make the new IO lib work on mingw. * Outlaw changing the file position on a text-mode file. After consideration of the mingw translation semantics I cannot see how to make a correct implementation. * Add a field to Handle__ to say whether or not the handle is in binary mode. * Restrict seek operations on Handles to those in binary mode. * Export hSetBinaryMode from IO.lhs. --- ghc/lib/std/IO.lhs | 3 +- ghc/lib/std/PrelHandle.hsc | 80 +++++++++++++++++++++++++++++++------------- ghc/lib/std/PrelIOBase.lhs | 4 ++- 3 files changed, 62 insertions(+), 25 deletions(-) diff --git a/ghc/lib/std/IO.lhs b/ghc/lib/std/IO.lhs index b6b18dc..71bfa69 100644 --- a/ghc/lib/std/IO.lhs +++ b/ghc/lib/std/IO.lhs @@ -1,5 +1,5 @@ % ----------------------------------------------------------------------------- -% $Id: IO.lhs,v 1.41 2001/05/18 16:54:04 simonmar Exp $ +% $Id: IO.lhs,v 1.42 2001/06/01 13:06:01 sewardj Exp $ % % (c) The University of Glasgow, 1994-2000 % @@ -29,6 +29,7 @@ module IO ( hSetBuffering, -- :: Handle -> BufferMode -> IO () hGetBuffering, -- :: Handle -> IO BufferMode + hSetBinaryMode, -- :: Handle -> Bool -> IO () hFlush, -- :: Handle -> IO () hGetPosn, -- :: Handle -> IO HandlePosn hSetPosn, -- :: Handle -> HandlePosn -> IO () diff --git a/ghc/lib/std/PrelHandle.hsc b/ghc/lib/std/PrelHandle.hsc index 0452fc1..8f5e4bd 100644 --- a/ghc/lib/std/PrelHandle.hsc +++ b/ghc/lib/std/PrelHandle.hsc @@ -4,7 +4,7 @@ #undef DEBUG -- ----------------------------------------------------------------------------- --- $Id: PrelHandle.hsc,v 1.7 2001/05/31 10:03:35 simonmar Exp $ +-- $Id: PrelHandle.hsc,v 1.8 2001/06/01 13:06:01 sewardj Exp $ -- -- (c) The University of Glasgow, 1994-2001 -- @@ -76,6 +76,12 @@ import PrelConc -- when the read buffer is non-empty? (no way to flush the buffer) -- --------------------------------------------------------------------------- +-- Are files opened by default in text or binary mode, if the user doesn't +-- specify? +dEFAULT_OPEN_IN_BINARY_MODE :: Bool +dEFAULT_OPEN_IN_BINARY_MODE = False + +-- --------------------------------------------------------------------------- -- Creating a new handle newFileHandle :: (MVar Handle__ -> IO ()) -> Handle__ -> IO Handle @@ -105,7 +111,7 @@ possible combinations of: - the operation may return a result If the operation generates an error or an exception is raised, the -orignal handle is always replaced [ this is the case at the moment, +original handle is always replaced [ this is the case at the moment, but we might want to revisit this in the future --SDM ]. -} @@ -240,16 +246,18 @@ wantSeekableHandle fun h@(FileHandle m) act = checkSeekableHandle act handle_ = case haType handle_ of - ClosedHandle -> ioe_closedHandle - SemiClosedHandle -> ioe_closedHandle - AppendHandle -> ioe_notSeekable - _ -> act handle_ + ClosedHandle -> ioe_closedHandle + SemiClosedHandle -> ioe_closedHandle + AppendHandle -> ioe_notSeekable + _ | haIsBin handle_ -> act handle_ + | otherwise -> ioe_notSeekable_notBin -- ----------------------------------------------------------------------------- -- Handy IOErrors ioe_closedHandle, ioe_EOF, - ioe_notReadable, ioe_notWritable, ioe_notSeekable :: IO a + ioe_notReadable, ioe_notWritable, + ioe_notSeekable, ioe_notSeekable_notBin :: IO a ioe_closedHandle = ioException (IOError Nothing IllegalOperation "" @@ -265,6 +273,9 @@ ioe_notWritable = ioException ioe_notSeekable = ioException (IOError Nothing IllegalOperation "" "handle is not seekable" Nothing) +ioe_notSeekable_notBin = ioException + (IOError Nothing IllegalOperation "" + "seek operations are only allowed on binary-mode handles" Nothing) ioe_bufsiz :: Int -> IO a ioe_bufsiz n = ioException @@ -389,11 +400,15 @@ flushBuffer h_ = do -- characters in the buffer. The file descriptor must therefore be -- seekable: attempting to flush the read buffer on an unseekable -- handle is not allowed. + flushReadBuffer :: FD -> Buffer -> IO Buffer flushReadBuffer fd buf | bufferEmpty buf = return buf | otherwise = do let off = negate (bufWPtr buf - bufRPtr buf) +# ifdef DEBUG_DUMP + puts ("flushReadBuffer: new file offset = " ++ show off ++ "\n") +# endif throwErrnoIfMinus1Retry "flushReadBuffer" (c_lseek (fromIntegral fd) (fromIntegral off) (#const SEEK_CUR)) return buf{ bufWPtr=0, bufRPtr=0 } @@ -448,6 +463,9 @@ fillReadBufferLoop fd is_line buf b w size = do (read_off fd b (fromIntegral w) (fromIntegral bytes)) (threadWaitRead fd) let res' = fromIntegral res +#ifdef DEBUG_DUMP + puts ("fillReadBufferLoop: res' = " ++ show res' ++ "\n") +#endif if res' == 0 then if w == 0 then ioe_EOF @@ -483,6 +501,7 @@ stdin = unsafePerformIO $ do newFileHandle stdHandleFinalizer (Handle__ { haFD = fd_stdin, haType = ReadHandle, + haIsBin = dEFAULT_OPEN_IN_BINARY_MODE, haBufferMode = bmode, haFilePath = "", haBuffer = buf, @@ -500,6 +519,7 @@ stdout = unsafePerformIO $ do newFileHandle stdHandleFinalizer (Handle__ { haFD = fd_stdout, haType = WriteHandle, + haIsBin = dEFAULT_OPEN_IN_BINARY_MODE, haBufferMode = bmode, haFilePath = "", haBuffer = buf, @@ -517,6 +537,7 @@ stderr = unsafePerformIO $ do newFileHandle stdHandleFinalizer (Handle__ { haFD = fd_stderr, haType = WriteHandle, + haIsBin = dEFAULT_OPEN_IN_BINARY_MODE, haBufferMode = NoBuffering, haFilePath = "", haBuffer = buffer, @@ -568,7 +589,9 @@ addFilePathToIOError _ _ other_exception openFile :: FilePath -> IOMode -> IO Handle openFile fp im = catch - (openFile' fp (TextMode im)) + (openFile' fp (if dEFAULT_OPEN_IN_BINARY_MODE + then BinaryMode im + else TextMode im)) (\e -> throw (addFilePathToIOError "openFile" fp e)) openFileEx :: FilePath -> IOModeEx -> IO Handle @@ -611,7 +634,7 @@ openFile' filepath ex_mode = throwErrnoIfMinus1Retry "openFile" (c_open f (fromIntegral oflags) 0o666) - openFd fd filepath mode + openFd fd filepath mode binary std_flags = o_NONBLOCK .|. o_NOCTTY @@ -624,8 +647,8 @@ append_flags = output_flags .|. o_WRONLY .|. o_APPEND -- --------------------------------------------------------------------------- -- openFd -openFd :: FD -> FilePath -> IOMode -> IO Handle -openFd fd filepath mode = do +openFd :: FD -> FilePath -> IOMode -> Bool -> IO Handle +openFd fd filepath mode binary = do -- turn on non-blocking mode setNonBlockingFD fd @@ -645,8 +668,8 @@ openFd fd filepath mode = do "is a directory" Nothing) Stream - | ReadWriteHandle <- ha_type -> mkDuplexHandle fd filepath - | otherwise -> mkFileHandle fd filepath ha_type + | ReadWriteHandle <- ha_type -> mkDuplexHandle fd filepath binary + | otherwise -> mkFileHandle fd filepath ha_type binary -- regular files need to be locked RegularFile -> do @@ -654,7 +677,7 @@ openFd fd filepath mode = do when (r == -1) $ ioException (IOError Nothing ResourceBusy "openFile" "file is locked" Nothing) - mkFileHandle fd filepath ha_type + mkFileHandle fd filepath ha_type binary foreign import "lockFile" unsafe @@ -663,26 +686,28 @@ foreign import "lockFile" unsafe foreign import "unlockFile" unsafe unlockFile :: CInt -> IO CInt -mkFileHandle :: FD -> FilePath -> HandleType -> IO Handle -mkFileHandle fd filepath ha_type = do +mkFileHandle :: FD -> FilePath -> HandleType -> Bool -> IO Handle +mkFileHandle fd filepath ha_type binary = do (buf, bmode) <- getBuffer fd (initBufferState ha_type) spares <- newIORef BufferListNil newFileHandle handleFinalizer (Handle__ { haFD = fd, haType = ha_type, + haIsBin = binary, haBufferMode = bmode, haFilePath = filepath, haBuffer = buf, haBuffers = spares }) -mkDuplexHandle :: FD -> FilePath -> IO Handle -mkDuplexHandle fd filepath = do +mkDuplexHandle :: FD -> FilePath -> Bool -> IO Handle +mkDuplexHandle fd filepath binary = do (w_buf, w_bmode) <- getBuffer fd WriteBuffer w_spares <- newIORef BufferListNil let w_handle_ = Handle__ { haFD = fd, haType = WriteHandle, + haIsBin = binary, haBufferMode = w_bmode, haFilePath = filepath, haBuffer = w_buf, @@ -695,6 +720,7 @@ mkDuplexHandle fd filepath = do let r_handle_ = Handle__ { haFD = fd, haType = ReadSideHandle write_side, + haIsBin = binary, haBufferMode = r_bmode, haFilePath = filepath, haBuffer = r_buf, @@ -925,7 +951,6 @@ hGetPosn handle = -- current buffer size. Just flush instead. flushBuffer handle_ #endif - let fd = fromIntegral (haFD handle_) posn <- fromIntegral `liftM` throwErrnoIfMinus1Retry "hGetPosn" @@ -937,7 +962,10 @@ hGetPosn handle = let real_posn | bufferIsWritable buf = posn + fromIntegral (bufWPtr buf) | otherwise = posn - fromIntegral (bufWPtr buf - bufRPtr buf) - +# ifdef DEBUG_DUMP + puts ("\nhGetPosn: (fd, posn, real_posn) = " ++ show (fd, posn, real_posn) ++ "\n") + puts (" (bufWPtr, bufRPtr) = " ++ show (bufWPtr buf, bufRPtr buf) ++ "\n") +# endif return (HandlePosn handle real_posn) @@ -980,6 +1008,9 @@ data SeekMode = AbsoluteSeek | RelativeSeek | SeekFromEnd hSeek :: Handle -> SeekMode -> Integer -> IO () hSeek handle mode offset = wantSeekableHandle "hSeek" handle $ \ handle_ -> do +# ifdef DEBUG_DUMP + puts ("hSeek " ++ show (mode,offset) ++ "\n") +# endif let ref = haBuffer handle_ buf <- readIORef ref let r = bufRPtr buf @@ -1080,7 +1111,7 @@ hIsSeekable handle = SemiClosedHandle -> ioe_closedHandle AppendHandle -> return False _ -> do t <- fdType (haFD handle_) - return (t == RegularFile) + return (t == RegularFile && haIsBin handle_) -- ----------------------------------------------------------------------------- -- Changing echo status @@ -1122,15 +1153,18 @@ hIsTerminalDevice handle = do #ifdef _WIN32 hSetBinaryMode handle bin = - withHandle_ "hSetBinaryMode" handle $ \ handle_ -> + withHandle "hSetBinaryMode" handle $ \ handle_ -> do let flg | bin = (#const O_BINARY) | otherwise = (#const O_TEXT) throwErrnoIfMinus1_ "hSetBinaryMode" (setmode (fromIntegral (haFD handle_)) flg) + return (handle_{haIsBin=bin}, ()) foreign import "setmode" setmode :: CInt -> CInt -> IO CInt #else -hSetBinaryMode _ _ = return () +hSetBinaryMode handle bin = + withHandle "hSetBinaryMode" handle $ \ handle_ -> + return (handle_{haIsBin=bin}, ()) #endif -- ----------------------------------------------------------------------------- diff --git a/ghc/lib/std/PrelIOBase.lhs b/ghc/lib/std/PrelIOBase.lhs index 148ae00..9f36163 100644 --- a/ghc/lib/std/PrelIOBase.lhs +++ b/ghc/lib/std/PrelIOBase.lhs @@ -1,5 +1,5 @@ % ------------------------------------------------------------------------------ -% $Id: PrelIOBase.lhs,v 1.41 2001/05/31 10:03:35 simonmar Exp $ +% $Id: PrelIOBase.lhs,v 1.42 2001/06/01 13:06:01 sewardj Exp $ % % (c) The University of Glasgow, 1994-2001 % @@ -153,6 +153,7 @@ data Handle__ = Handle__ { haFD :: !FD, haType :: HandleType, + haIsBin :: Bool, haBufferMode :: BufferMode, haFilePath :: FilePath, haBuffer :: !(IORef Buffer), @@ -352,6 +353,7 @@ showHandle p h = showHdl (haType hdl_) (showString "loc=" . showString (haFilePath hdl_) . showChar ',' . showString "type=" . showsPrec p (haType hdl_) . showChar ',' . + showString "binary=" . showsPrec p (haIsBin hdl_) . showChar ',' . showString "buffering=" . showBufMode (unsafePerformIO (readIORef (haBuffer hdl_))) (haBufferMode hdl_) . showString "}" ) where showHdl :: HandleType -> ShowS -> ShowS -- 1.7.10.4