Commit 4f3c6654 authored by sewardj's avatar sewardj
Browse files

[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.
parent a76dd9ee
% -----------------------------------------------------------------------------
% $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 ()
......
......@@ -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
--
......@@ -75,6 +75,12 @@ import PrelConc
-- hSetBuffering: can't change buffering on a stream,
-- 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
......@@ -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 = "<stdin>",
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 = "<stdout>",
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 = "<stderr>",
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
-- -----------------------------------------------------------------------------
......
% ------------------------------------------------------------------------------
% $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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment